diff options
Diffstat (limited to 'src/LambdaCube/Compiler.hs')
-rw-r--r-- | src/LambdaCube/Compiler.hs | 55 |
1 files changed, 50 insertions, 5 deletions
diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs index 6a65c811..f87f3a3d 100644 --- a/src/LambdaCube/Compiler.hs +++ b/src/LambdaCube/Compiler.hs | |||
@@ -13,6 +13,9 @@ module LambdaCube.Compiler | |||
13 | , IR.Pipeline | 13 | , IR.Pipeline |
14 | , module Exported | 14 | , module Exported |
15 | 15 | ||
16 | , MName | ||
17 | , SourceCode | ||
18 | , ModuleFetcher | ||
16 | , MMT, runMMT, mapMMT | 19 | , MMT, runMMT, mapMMT |
17 | , MM, runMM | 20 | , MM, runMM |
18 | , ioFetch, decideFilePath | 21 | , ioFetch, decideFilePath |
@@ -58,6 +61,7 @@ import LambdaCube.Compiler.CoreToIR | |||
58 | import LambdaCube.Compiler.Utils | 61 | import LambdaCube.Compiler.Utils |
59 | import LambdaCube.Compiler.DesugaredSource as Exported (FileInfo(..), Range(..), SPos(..), pattern SPos, SIName(..), pattern SIName, sName, SI(..)) | 62 | import LambdaCube.Compiler.DesugaredSource as Exported (FileInfo(..), Range(..), SPos(..), pattern SPos, SIName(..), pattern SIName, sName, SI(..)) |
60 | import LambdaCube.Compiler.Core as Exported (mkDoc, Exp, ExpType(..), pattern ET, outputType, boolType, trueExp, hnf, closeExp, closeExpType) | 63 | import LambdaCube.Compiler.Core as Exported (mkDoc, Exp, ExpType(..), pattern ET, outputType, boolType, trueExp, hnf, closeExp, closeExpType) |
64 | import qualified LambdaCube.Compiler.Core as Core | ||
61 | import LambdaCube.Compiler.InferMonad as Exported (errorRange, listAllInfos, listAllInfos', listTypeInfos, listErrors, listWarnings, listTraceInfos, Infos, Info(..)) | 65 | import LambdaCube.Compiler.InferMonad as Exported (errorRange, listAllInfos, listAllInfos', listTypeInfos, listErrors, listWarnings, listTraceInfos, Infos, Info(..)) |
62 | --import LambdaCube.Compiler.Infer as Exported () | 66 | --import LambdaCube.Compiler.Infer as Exported () |
63 | 67 | ||
@@ -66,8 +70,13 @@ import Paths_lambdacube_compiler (getDataDir) | |||
66 | 70 | ||
67 | -------------------------------------------------------------------------------- | 71 | -------------------------------------------------------------------------------- |
68 | 72 | ||
73 | -- | The name of module. | ||
69 | type MName = String | 74 | type MName = String |
75 | |||
76 | -- | The name of a symbol defined in a module. | ||
70 | type SName = String | 77 | type SName = String |
78 | |||
79 | -- | The source code of a module. | ||
71 | type SourceCode = String | 80 | type SourceCode = String |
72 | 81 | ||
73 | -- file name or module name? | 82 | -- file name or module name? |
@@ -77,14 +86,21 @@ decideFilePath n | |||
77 | 86 | ||
78 | dropExtension' e f | 87 | dropExtension' e f |
79 | | takeExtension f == e = dropExtension f | 88 | | takeExtension f == e = dropExtension f |
80 | | otherwise = error $ "dropExtension: expcted extension: " ++ e ++ " ; filename: " ++ f | 89 | | otherwise = error $ "dropExtension: expected extension: " ++ e ++ " ; filename: " ++ f |
81 | 90 | ||
91 | -- | Removes the .lc filename extension and replaces path seperators with dots. | ||
92 | -- | ||
93 | -- It is a run-time error to pass a string that does not end with the ".lc" | ||
94 | -- suffix. | ||
95 | fileNameToModuleName :: String -> String | ||
82 | fileNameToModuleName n | 96 | fileNameToModuleName n |
83 | = intercalate "." $ remDot $ (\(a, b) -> map takeDirectory (splitPath a) ++ [b]) $ splitFileName $ dropExtension' ".lc" $ normalise n | 97 | = intercalate "." $ remDot $ (\(a, b) -> map takeDirectory (splitPath a) ++ [b]) $ splitFileName $ dropExtension' ".lc" $ normalise n |
84 | where | 98 | where |
85 | remDot (".": xs) = xs | 99 | remDot (".": xs) = xs |
86 | remDot xs = xs | 100 | remDot xs = xs |
87 | 101 | ||
102 | -- | Converts dots into path separators and appends a .lc filename extension. | ||
103 | moduleNameToFileName :: String -> String | ||
88 | moduleNameToFileName n = hn n ++ ".lc" | 104 | moduleNameToFileName n = hn n ++ ".lc" |
89 | where | 105 | where |
90 | hn = h [] | 106 | hn = h [] |
@@ -92,10 +108,18 @@ moduleNameToFileName n = hn n ++ ".lc" | |||
92 | h acc ('.':cs) = reverse acc </> hn cs | 108 | h acc ('.':cs) = reverse acc </> hn cs |
93 | h acc (c: cs) = h (c: acc) cs | 109 | h acc (c: cs) = h (c: acc) cs |
94 | 110 | ||
95 | type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (Either Doc (FilePath, MName, m SourceCode)) | 111 | -- | This function can be used with 'runMM' to customize how the compiler |
112 | -- resolves module names. | ||
113 | type ModuleFetcher m = Maybe FilePath -- ^ The file that is importing this module. | ||
114 | -> Either FilePath MName -- ^ Module or file name to load. | ||
115 | -> m (Either Doc (FilePath, MName, m SourceCode)) | ||
96 | 116 | ||
117 | -- | Provides a ModuleFetcher that ignores its first argument and searches a | ||
118 | -- fixed list of paths to find a module file to parse. | ||
119 | -- | ||
120 | -- This is the default module fetcher that is used by 'compileMain'. | ||
97 | ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x) | 121 | ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x) |
98 | ioFetch paths' imp n = do | 122 | ioFetch paths' _ n = do |
99 | preludePath <- (</> "lc") <$> liftIO getDataDir | 123 | preludePath <- (</> "lc") <$> liftIO getDataDir |
100 | let paths = map (id &&& id) paths' ++ [(preludePath, "<<installed-prelude-path>>")] | 124 | let paths = map (id &&& id) paths' ++ [(preludePath, "<<installed-prelude-path>>")] |
101 | find ((x, (x', mn)): xs) = liftIO (readFileIfExists x) >>= maybe (find xs) (\src -> return $ Right (x, mn, liftIO src)) | 125 | find ((x, (x', mn)): xs) = liftIO (readFileIfExists x) >>= maybe (find xs) (\src -> return $ Right (x, mn, liftIO src)) |
@@ -103,14 +127,22 @@ ioFetch paths' imp n = do | |||
103 | <+> "in path" <+> hsep (text . snd <$> paths) | 127 | <+> "in path" <+> hsep (text . snd <$> paths) |
104 | find $ nubBy ((==) `on` fst) $ map (first normalise . lcModuleFile) paths | 128 | find $ nubBy ((==) `on` fst) $ map (first normalise . lcModuleFile) paths |
105 | where | 129 | where |
130 | -- Given (path,symbolicPath) where modules might be stored, | ||
131 | -- returns candidate (fullFilePath,(symbolicFilePath,moduleName)) for module of interest. | ||
106 | lcModuleFile (path, path') = case n of | 132 | lcModuleFile (path, path') = case n of |
107 | Left n -> (path </> n, (path' </> n, fileNameToModuleName n)) | 133 | Left n -> (path </> n, (path' </> n, fileNameToModuleName n)) |
108 | Right n -> (path </> moduleNameToFileName n, (path' </> moduleNameToFileName n, n)) | 134 | Right n -> (path </> moduleNameToFileName n, (path' </> moduleNameToFileName n, n)) |
109 | 135 | ||
110 | -------------------------------------------------------------------------------- | 136 | -------------------------------------------------------------------------------- |
111 | 137 | ||
138 | -- | A monad with an associated 'ModuleFetcher' for the compiler to resolve | ||
139 | -- module names into filepaths and a 'Modules' state which caches parsed | ||
140 | -- modules. | ||
112 | newtype MMT m x a = MMT { runMMT :: ReaderT (ModuleFetcher (MMT m x)) (StateT (Modules x) m) a } | 141 | newtype MMT m x a = MMT { runMMT :: ReaderT (ModuleFetcher (MMT m x)) (StateT (Modules x) m) a } |
113 | deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m x)), MonadState (Modules x), MonadIO, MonadThrow, MonadCatch, MonadMask) | 142 | deriving ( Functor, Applicative, Monad |
143 | , MonadReader (ModuleFetcher (MMT m x)) | ||
144 | , MonadState (Modules x) | ||
145 | , MonadIO, MonadThrow, MonadCatch, MonadMask ) | ||
114 | 146 | ||
115 | type MM = MMT IO Infos | 147 | type MM = MMT IO Infos |
116 | 148 | ||
@@ -136,7 +168,10 @@ data Modules x = Modules | |||
136 | , nextMId :: !Int | 168 | , nextMId :: !Int |
137 | } | 169 | } |
138 | 170 | ||
139 | loadModule :: MonadMask m => ((Infos, [Stmt]) -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (Either Doc (FileInfo, Module' x)) | 171 | loadModule :: MonadMask m => ((Infos, [Stmt]) -> x) |
172 | -> Maybe FilePath -- ^ The file requesting the module. | ||
173 | -> Either FilePath MName -- ^ The module to load. | ||
174 | -> MMT m x (Either Doc (FileInfo, Module' x)) | ||
140 | loadModule ex imp mname_ = do | 175 | loadModule ex imp mname_ = do |
141 | r <- ask >>= \fetch -> fetch imp mname_ | 176 | r <- ask >>= \fetch -> fetch imp mname_ |
142 | case r of | 177 | case r of |
@@ -195,6 +230,12 @@ loadModule ex imp mname_ = do | |||
195 | getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m (Infos, [Stmt]) ((Infos, [Stmt]), Either Doc (FileInfo, Either Doc ExpType)) | 230 | getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m (Infos, [Stmt]) ((Infos, [Stmt]), Either Doc (FileInfo, Either Doc ExpType)) |
196 | getDef = getDef_ id | 231 | getDef = getDef_ id |
197 | 232 | ||
233 | getDef_ :: (MonadMask m, Monoid a) => | ||
234 | ((Infos, [Stmt]) -> a) | ||
235 | -> FilePath -- ^ Path to module. | ||
236 | -> SName -- ^ Name of symbol to fetch. | ||
237 | -> Maybe Core.Type -- ^ Type of symbol to fetch. | ||
238 | -> MMT m a (a, Either Doc (FileInfo, Either Doc ExpType)) | ||
198 | getDef_ ex m d ty = loadModule ex Nothing (Left m) <&> \case | 239 | getDef_ ex m d ty = loadModule ex Nothing (Left m) <&> \case |
199 | Left err -> (mempty, Left err) | 240 | Left err -> (mempty, Left err) |
200 | Right (fname, (src, Left err)) -> (mempty, Left err) | 241 | Right (fname, (src, Left err)) -> (mempty, Left err) |
@@ -209,6 +250,10 @@ getDef_ ex m d ty = loadModule ex Nothing (Left m) <&> \case | |||
209 | Nothing -> Left $ text d <+> "is not found" | 250 | Nothing -> Left $ text d <+> "is not found" |
210 | ) | 251 | ) |
211 | 252 | ||
253 | compilePipeline' :: (MonadMask m, Monoid a) => | ||
254 | ((Infos, [Stmt]) -> a) | ||
255 | -> IR.Backend -> FilePath | ||
256 | -> MMT m a (a, Either Doc IR.Pipeline) | ||
212 | compilePipeline' ex backend m | 257 | compilePipeline' ex backend m |
213 | = second (either Left (fmap (compilePipeline backend) . snd)) <$> getDef_ ex m "main" (Just outputType) | 258 | = second (either Left (fmap (compilePipeline backend) . snd)) <$> getDef_ ex m "main" (Just outputType) |
214 | 259 | ||