blob: 90a11d57b853573a767d8f8928a3193e4d68b3c9 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
module Language.Fiddle.Compiler.ImportResolution
( resolveImports,
getImportResolutionState,
importResolutionPhase,
)
where
import Control.Monad.Identity (Identity)
import Control.Monad.Writer.Lazy (MonadWriter (tell))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Fiddle.Ast
import Language.Fiddle.Ast.FileInterface (ResolvedImport)
import Language.Fiddle.Compiler
import Language.Fiddle.Compiler.Expansion
import Language.Fiddle.Internal.UnitInterface
import Language.Fiddle.Types
import Options.Applicative
import Text.Printf (printf)
newtype Flags = Flags
{ importDirectories :: [FilePath]
}
parseFlags :: Parser Flags
parseFlags =
Flags
<$> many
( strOption
( long "import"
<> short 'I'
<> metavar "DIRECTORY"
<> help "Directory to add to the import search path"
)
)
importResolutionPhase ::
CompilationPhase CurrentStage ImportsResolved
importResolutionPhase =
CompilationPhase parseFlags getImportResolutionState resolveImports
type GlobalState = ()
type LocalState = ResolvedImports
type M = Compile GlobalState
type Annot = Commented SourceSpan
data ImportError = ImportError Text (Maybe SourceSpan)
deriving (Show)
newtype ResolvedImports = ResolvedImports
{ importMap :: Map Text (Either ImportError UnitInterface)
}
type CurrentStage = Parsed
type I = Identity
instance CompilationStage CurrentStage where
type StageAfter CurrentStage = ImportsResolved
type StageMonad CurrentStage = M
type StageState CurrentStage = LocalState
type StageFunctor CurrentStage = Identity
type StageAnnotation CurrentStage = Annot
resolveImports ::
Flags ->
ResolvedImports ->
FiddleUnit CurrentStage I Annot ->
Compile () (FiddleUnit ImportsResolved I Annot)
resolveImports _ = advanceStage
deriving instance AdvanceStage CurrentStage ObjTypeBody
deriving instance AdvanceStage CurrentStage DeferredRegisterBody
deriving instance AdvanceStage CurrentStage RegisterBody
deriving instance AdvanceStage CurrentStage AnonymousBitsType
deriving instance AdvanceStage CurrentStage BitType
deriving instance AdvanceStage CurrentStage EnumBody
deriving instance AdvanceStage CurrentStage EnumConstantDecl
deriving instance AdvanceStage CurrentStage RegisterBitsDecl
deriving instance AdvanceStage CurrentStage PackageBody
deriving instance AdvanceStage CurrentStage ObjTypeDecl
deriving instance AdvanceStage CurrentStage FiddleUnit
deriving instance AdvanceStage CurrentStage Expression
deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef
deriving instance AdvanceStage CurrentStage ObjType
deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
deriving instance AdvanceStage CurrentStage FiddleDecl
diagnosticError :: String -> Annot -> Compile a ()
diagnosticError str a = tell [Diagnostic Error str (unCommented a)]
instance AdvanceStage CurrentStage ImportStatement where
advanceStage s (ImportStatement path list _ a) = do
let what = Map.lookup path (importMap s)
empty = UnitInterface mempty mempty
v <- case what of
Nothing -> do
diagnosticError "Failed to lookup imports (This is a bug)" a
return empty
Just (Left err) -> do
diagnosticError (printf "Error in import %s: %s" path (show err)) a
return empty
Just (Right val) -> return val
return $ ImportStatement path list v a
getImportResolutionState ::
Flags ->
FiddleUnit CurrentStage Identity Annot ->
IO ResolvedImports
getImportResolutionState _ _ = return (ResolvedImports mempty)
|
