diff options
author | Csaba Hruska <csaba.hruska@gmail.com> | 2017-09-24 14:45:29 +0100 |
---|---|---|
committer | Csaba Hruska <csaba.hruska@gmail.com> | 2017-09-24 14:45:29 +0100 |
commit | cbac76692978c316223eda2407deda4978a09241 (patch) | |
tree | 9a5d0e1073c3ab6aa5c1a471228a538cff1a4524 | |
parent | 8e4907fcba393f9712f8b5b0d34b95a603485721 (diff) |
cleanup
-rw-r--r-- | src/LambdaCube/Compiler.hs | 114 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/Infer.hs | 1 |
2 files changed, 34 insertions, 81 deletions
diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs index e92688d6..d1c178ec 100644 --- a/src/LambdaCube/Compiler.hs +++ b/src/LambdaCube/Compiler.hs | |||
@@ -1,3 +1,4 @@ | |||
1 | {-# LANGUAGE RecordWildCards #-} | ||
1 | {-# LANGUAGE OverloadedStrings #-} | 2 | {-# LANGUAGE OverloadedStrings #-} |
2 | {-# LANGUAGE PatternSynonyms #-} | 3 | {-# LANGUAGE PatternSynonyms #-} |
3 | {-# LANGUAGE ViewPatterns #-} | 4 | {-# LANGUAGE ViewPatterns #-} |
@@ -8,8 +9,8 @@ | |||
8 | {-# LANGUAGE NoMonomorphismRestriction #-} | 9 | {-# LANGUAGE NoMonomorphismRestriction #-} |
9 | {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadMask m => MonadMask (ExceptT e m) | 10 | {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadMask m => MonadMask (ExceptT e m) |
10 | module LambdaCube.Compiler | 11 | module LambdaCube.Compiler |
11 | ( Backend(..) | 12 | ( IR.Backend(..) |
12 | , Pipeline | 13 | , IR.Pipeline |
13 | , module Exported | 14 | , module Exported |
14 | 15 | ||
15 | , MMT, runMMT, mapMMT | 16 | , MMT, runMMT, mapMMT |
@@ -22,10 +23,11 @@ module LambdaCube.Compiler | |||
22 | , ppShow | 23 | , ppShow |
23 | , plainShow | 24 | , plainShow |
24 | , prettyShowUnlines | 25 | , prettyShowUnlines |
26 | |||
27 | , typecheckModule | ||
25 | ) where | 28 | ) where |
26 | import qualified Data.ByteString.Char8 as BS | 29 | import qualified Data.ByteString.Char8 as BS |
27 | 30 | ||
28 | import Data.Binary | ||
29 | import Data.Time.Clock | 31 | import Data.Time.Clock |
30 | import Text.Printf | 32 | import Text.Printf |
31 | import Data.List | 33 | import Data.List |
@@ -45,7 +47,7 @@ import System.Directory | |||
45 | import System.IO.Unsafe | 47 | import System.IO.Unsafe |
46 | --import Debug.Trace | 48 | --import Debug.Trace |
47 | 49 | ||
48 | import LambdaCube.IR as IR | 50 | import qualified LambdaCube.IR as IR |
49 | import LambdaCube.Compiler.Pretty hiding ((</>)) | 51 | import LambdaCube.Compiler.Pretty hiding ((</>)) |
50 | import LambdaCube.Compiler.DesugaredSource (Module_(..), Export(..), ImportItems (..), Stmt) | 52 | import LambdaCube.Compiler.DesugaredSource (Module_(..), Export(..), ImportItems (..), Stmt) |
51 | import LambdaCube.Compiler.Parser (runDefParser, parseLC, DesugarInfo, Module) | 53 | import LambdaCube.Compiler.Parser (runDefParser, parseLC, DesugarInfo, Module) |
@@ -55,7 +57,7 @@ import LambdaCube.Compiler.CoreToIR | |||
55 | 57 | ||
56 | import LambdaCube.Compiler.Utils | 58 | import LambdaCube.Compiler.Utils |
57 | import LambdaCube.Compiler.DesugaredSource as Exported (FileInfo(..), Range(..), SPos(..), pattern SPos, SIName(..), pattern SIName, sName, SI(..)) | 59 | import LambdaCube.Compiler.DesugaredSource as Exported (FileInfo(..), Range(..), SPos(..), pattern SPos, SIName(..), pattern SIName, sName, SI(..)) |
58 | import LambdaCube.Compiler.Core as Exported (mkDoc, Exp, ExpType(..), pattern ET, outputType, boolType, trueExp, hnf, closeExp) | 60 | import LambdaCube.Compiler.Core as Exported (mkDoc, Exp, ExpType(..), pattern ET, outputType, boolType, trueExp, hnf, closeExp, closeExpType) |
59 | import LambdaCube.Compiler.InferMonad as Exported (errorRange, listAllInfos, listAllInfos', listTypeInfos, listErrors, listWarnings, listTraceInfos, Infos, Info(..)) | 61 | import LambdaCube.Compiler.InferMonad as Exported (errorRange, listAllInfos, listAllInfos', listTypeInfos, listErrors, listWarnings, listTraceInfos, Infos, Info(..)) |
60 | --import LambdaCube.Compiler.Infer as Exported () | 62 | --import LambdaCube.Compiler.Infer as Exported () |
61 | 63 | ||
@@ -161,30 +163,18 @@ loadModule ex imp mname_ = do | |||
161 | (\(ds, ge) -> Right (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge)) | 163 | (\(ds, ge) -> Right (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge)) |
162 | e) | 164 | e) |
163 | dsge | 165 | dsge |
164 | --------------- | 166 | let (res, err) = case sequence ms of |
165 | let (res, err, g_env, defs) = case sequence ms of | 167 | Left err -> (ex mempty, Left $ pShow err) |
166 | Left err -> (ex mempty, Left $ pShow err, mempty, mempty) | ||
167 | Right ms@(mconcat -> (ds, ge)) -> case runExcept $ runDefParser ds $ definitions e of | 168 | Right ms@(mconcat -> (ds, ge)) -> case runExcept $ runDefParser ds $ definitions e of |
168 | Left err -> (ex mempty, Left $ pShow err, mempty, mempty) | 169 | Left err -> (ex mempty, Left $ pShow err) |
169 | Right (defs, warnings, dsinfo) -> ((ex (map ParseWarning warnings ++ is, defs)), res_1, g_env_1, defs) -- defs g_env_1 | 170 | Right (defs, warnings, dsinfo) -> ((ex (map ParseWarning warnings ++ is, defs)), res_1) |
170 | where | 171 | where |
171 | defs_cached = unsafePerformIO $ do | 172 | (res, is) = runWriter . flip runReaderT (extensions e, initEnv <> ge) . runExceptT $ inference defs |
172 | let filename = printf "%s.def_bin" $ takeFileName fname :: String | 173 | |
173 | doesFileExist filename >>= \case | 174 | (res_1) = case res of |
174 | True -> do | 175 | Left err -> (Left $ pShow err) |
175 | BS.putStrLn $ BS.pack $ printf "load %s" filename | 176 | Right (mconcat -> newge) -> |
176 | decodeFile filename | 177 | (right mconcat $ forM (fromMaybe [ExportModule $ SIName mempty mname] $ moduleExports e) $ \case |
177 | False -> do | ||
178 | BS.putStrLn $ BS.pack $ printf "save %s" filename | ||
179 | encodeFile filename defs | ||
180 | pure defs | ||
181 | (res, is) = runWriter . flip runReaderT (extensions e, initEnv <> ge) . runExceptT $ inference defs --_cached | ||
182 | |||
183 | (g_env_1, res_1) = case res of | ||
184 | Left err -> (mempty, Left $ pShow err) | ||
185 | Right (mconcat -> newge) -> --do | ||
186 | --writeFile (printf "%s.exp" fname) $ show newge | ||
187 | (newge, right mconcat $ forM (fromMaybe [ExportModule $ SIName mempty mname] $ moduleExports e) $ \case | ||
188 | ExportId (sName -> d) -> case Map.lookup d newge of | 178 | ExportId (sName -> d) -> case Map.lookup d newge of |
189 | Just def -> Right (mempty{-TODO-}, Map.singleton d def) | 179 | Just def -> Right (mempty{-TODO-}, Map.singleton d def) |
190 | Nothing -> Left $ text d <+> "is not defined" | 180 | Nothing -> Left $ text d <+> "is not defined" |
@@ -193,59 +183,7 @@ loadModule ex imp mname_ = do | |||
193 | [x] -> Right x | 183 | [x] -> Right x |
194 | [] -> Left $ "empty export list in module" <+> text fname -- m, map fst $ moduleImports e, mname) | 184 | [] -> Left $ "empty export list in module" <+> text fname -- m, map fst $ moduleImports e, mname) |
195 | _ -> error "export list: internal error") | 185 | _ -> error "export list: internal error") |
196 | --------------- | 186 | return (Right (e, res, err)) |
197 | let writeResult = do | ||
198 | let filename = printf "%s.exp" $ takeFileName fname :: String | ||
199 | filename_closed = printf "%s.exp.closed" $ takeFileName fname :: String | ||
200 | filename_closed_tr = printf "%s.exp.closed.tr" $ takeFileName fname :: String | ||
201 | filename_keys = printf "%s.exp.keys" $ takeFileName fname :: String | ||
202 | --putStrLn $ printf "write result! %d %s" ({-Map.size-}length g_env) filename | ||
203 | writeFile filename_keys $ unlines $ map show $ Map.keys g_env | ||
204 | let (g_env_ok, g_env_closed, g_env_closed_tr) = unzip3 | ||
205 | [ ( printf "%s :: %s\n%s = %s\n\n" k ty_s k v_s :: String | ||
206 | , printf "%s :: %s\n%s = %s\n\n" k c_ty_s k c_v_s :: String | ||
207 | , printf "%s :: %s\n%s = %s\n\n" k tr_c_ty_s k tr_c_v_s :: String | ||
208 | ) | ||
209 | | (k,(v, v_ty, v_si)) <- Map.toList g_env | ||
210 | , let ty_s = show $ mkDoc (False,False) $ v_ty | ||
211 | , let v_s = show $ mkDoc (False,True) $ v | ||
212 | , let c_v_ty = closeExp v_ty | ||
213 | , let c_v = closeExp v | ||
214 | , let c_ty_s = show $ mkDoc (False,False) c_v_ty | ||
215 | , let c_v_s = show $ mkDoc (False,True) $ c_v | ||
216 | , let tr_c_ty_s = show $ mkDoc (False,False) $ tr_exp c_v_ty | ||
217 | , let tr_c_v_s = show $ mkDoc (False,True) $ tr_exp c_v | ||
218 | ] | ||
219 | tr_exp :: Exp -> Exp | ||
220 | tr_exp = decode . encode | ||
221 | {- | ||
222 | writeFile filename (concat $ g_env_ok :: String) | ||
223 | writeFile filename_closed (concat $ g_env_closed :: String) | ||
224 | writeFile filename_closed_tr (concat $ g_env_closed_tr :: String) | ||
225 | -} | ||
226 | BS.putStrLn $ BS.pack $ printf "write %s" (printf "%s.env_bin - START" $ takeFileName fname :: String) | ||
227 | encodeFile (printf "%s.env_bin" $ takeFileName fname :: String) $ closeGlobalEnv g_env | ||
228 | BS.putStrLn $ BS.pack $ printf "write %s" (printf "%s.env_bin - DONE" $ takeFileName fname :: String) | ||
229 | |||
230 | -- TODO: guarded pShow save to file for g_env exps and closed g_env exps | ||
231 | |||
232 | writeParsedDefs = do | ||
233 | BS.putStrLn $ BS.pack $ printf "defs count: %d" (length defs) | ||
234 | let filename = printf "%s.defs" $ takeFileName fname :: String | ||
235 | writeFile filename $ unlines $ map ((++ "\n"). show . pShow) defs | ||
236 | encodeFile (printf "%s.def_bin" $ takeFileName fname :: String) defs | ||
237 | {- | ||
238 | Experiment: | ||
239 | Stmt/SExp - can be serialized | ||
240 | Exp - explodes ; must be the inference algorithm | ||
241 | -} | ||
242 | debugAction = do | ||
243 | printTimeDiff (fname ++ " Defs") writeParsedDefs | ||
244 | printTimeDiff (fname ++ " Exp") writeResult | ||
245 | --when (fname == "./SampleMaterial.lc") $ | ||
246 | -- fail "stop" | ||
247 | return $ unsafePerformIO (debugAction >> pure (Right (e, res, err))) | ||
248 | --return (Right (e, res, err)) | ||
249 | modify $ \(Modules nm im ni) -> Modules nm (IM.insert fid (fi, (src, res)) im) ni | 187 | modify $ \(Modules nm im ni) -> Modules nm (IM.insert fid (fi, (src, res)) im) ni |
250 | return $ Right (fi, (src, res)) | 188 | return $ Right (fi, (src, res)) |
251 | where | 189 | where |
@@ -286,7 +224,7 @@ parseModule path fname = runMM (ioFetch path) $ loadModule snd Nothing (Left fna | |||
286 | Right (fname, (src, Right (pm, infos, _))) -> Right $ pPrintStmts infos | 224 | Right (fname, (src, Right (pm, infos, _))) -> Right $ pPrintStmts infos |
287 | 225 | ||
288 | -- used by the compiler-service of the online editor | 226 | -- used by the compiler-service of the online editor |
289 | preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either Doc IR.Pipeline, (Infos, String))) | 227 | preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> IR.Backend -> FilePath -> IO (String -> m (Either Doc IR.Pipeline, (Infos, String))) |
290 | preCompile paths paths' backend mod = do | 228 | preCompile paths paths' backend mod = do |
291 | res <- runMM (ioFetch paths) $ loadModule ex Nothing $ Left mod | 229 | res <- runMM (ioFetch paths) $ loadModule ex Nothing $ Left mod |
292 | case res of | 230 | case res of |
@@ -307,3 +245,17 @@ preCompile paths paths' backend mod = do | |||
307 | 245 | ||
308 | pPrintStmts = unlines . map ((++"\n") . plainShow) | 246 | pPrintStmts = unlines . map ((++"\n") . plainShow) |
309 | 247 | ||
248 | -- basic interface | ||
249 | type Program = Map FilePath (DesugarInfo, GlobalEnv) | ||
250 | |||
251 | typecheckModule :: [FilePath] -> MName -> IO (Either [Doc] Program) | ||
252 | typecheckModule path fname = runMM (ioFetch path) $ loadModule (const ()) Nothing (Left fname) >> do | ||
253 | fileInfoModules <- gets (IM.elems . modules) | ||
254 | let collect (FileInfo{..}, (sourceCode, errorOrGlobalEnv)) = case errorOrGlobalEnv of | ||
255 | Left error -> ([error],mempty) | ||
256 | Right (module_, (), Left error) -> ([error], mempty) | ||
257 | Right (module_, (), Right (desugarInfo, globalEnv)) -> (mempty, Map.singleton filePath (desugarInfo, closeGlobalEnv globalEnv)) | ||
258 | (error, program) = mconcat $ map collect fileInfoModules | ||
259 | pure $ case error of | ||
260 | [] -> Right program | ||
261 | _ -> Left error | ||
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs index f2889dd0..b4e6a9d4 100644 --- a/src/LambdaCube/Compiler/Infer.hs +++ b/src/LambdaCube/Compiler/Infer.hs | |||
@@ -48,6 +48,7 @@ varType err n_ env = f n_ env where | |||
48 | f n (ELet2 _ (ET x t) es) = if n == 0 then (BLam Visible{-??-}, up 1 t) else second (up 1) $ f (n-1) es | 48 | f n (ELet2 _ (ET x t) es) = if n == 0 then (BLam Visible{-??-}, up 1 t) else second (up 1) $ f (n-1) es |
49 | f n e = either (error $ "varType: " ++ err ++ "\n" ++ show n_ ++ "\n" ++ ppShow env) (f n) $ parent e | 49 | f n e = either (error $ "varType: " ++ err ++ "\n" ++ show n_ ++ "\n" ++ ppShow env) (f n) $ parent e |
50 | 50 | ||
51 | mkELet :: SIName -> Exp -> Exp -> Env -> Exp | ||
51 | mkELet n x xt env = mkFun fn (Var <$> reverse vs) x | 52 | mkELet n x xt env = mkFun fn (Var <$> reverse vs) x |
52 | where | 53 | where |
53 | fn = FunName (FName n) (length vs) (ExpDef $ foldr addLam x vs) (foldr addPi xt vs) | 54 | fn = FunName (FName n) (length vs) (ExpDef $ foldr addLam x vs) (foldr addPi xt vs) |