cleanup

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 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -8,8 +9,8 @@
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadMask m => MonadMask (ExceptT e m)
 module LambdaCube.Compiler
-    ( Backend(..)
-    , Pipeline
+    ( IR.Backend(..)
+    , IR.Pipeline
     , module Exported
 
     , MMT, runMMT, mapMMT
@@ -22,10 +23,11 @@ module LambdaCube.Compiler
     , ppShow
     , plainShow
     , prettyShowUnlines
+
+    , typecheckModule
     ) where
 import qualified Data.ByteString.Char8 as BS
 
-import Data.Binary
 import Data.Time.Clock
 import Text.Printf
 import Data.List
@@ -45,7 +47,7 @@ import System.Directory
 import System.IO.Unsafe
 --import Debug.Trace
 
-import LambdaCube.IR as IR
+import qualified LambdaCube.IR as IR
 import LambdaCube.Compiler.Pretty hiding ((</>))
 import LambdaCube.Compiler.DesugaredSource (Module_(..), Export(..), ImportItems (..), Stmt)
 import LambdaCube.Compiler.Parser (runDefParser, parseLC, DesugarInfo, Module)
@@ -55,7 +57,7 @@ import LambdaCube.Compiler.CoreToIR
 
 import LambdaCube.Compiler.Utils
 import LambdaCube.Compiler.DesugaredSource as Exported (FileInfo(..), Range(..), SPos(..), pattern SPos, SIName(..), pattern SIName, sName, SI(..))
-import LambdaCube.Compiler.Core as Exported (mkDoc, Exp, ExpType(..), pattern ET, outputType, boolType, trueExp, hnf, closeExp)
+import LambdaCube.Compiler.Core as Exported (mkDoc, Exp, ExpType(..), pattern ET, outputType, boolType, trueExp, hnf, closeExp, closeExpType)
 import LambdaCube.Compiler.InferMonad as Exported (errorRange, listAllInfos, listAllInfos', listTypeInfos, listErrors, listWarnings, listTraceInfos, Infos, Info(..))
 --import LambdaCube.Compiler.Infer as Exported ()
 
@@ -161,30 +163,18 @@ loadModule ex imp mname_ = do
                                     (\(ds, ge) -> Right (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge))
                                     e)
                                 dsge
-            ---------------
-            let (res, err, g_env, defs) = case sequence ms of
-                  Left err -> (ex mempty, Left $ pShow err, mempty, mempty)
+            let (res, err) = case sequence ms of
+                  Left err -> (ex mempty, Left $ pShow err)
                   Right ms@(mconcat -> (ds, ge)) -> case runExcept $ runDefParser ds $ definitions e of
-                    Left err -> (ex mempty, Left $ pShow err, mempty, mempty)
-                    Right (defs, warnings, dsinfo) -> ((ex (map ParseWarning warnings ++ is, defs)), res_1, g_env_1, defs) -- defs g_env_1
+                    Left err -> (ex mempty, Left $ pShow err)
+                    Right (defs, warnings, dsinfo) -> ((ex (map ParseWarning warnings ++ is, defs)), res_1)
                      where
-                        defs_cached = unsafePerformIO $ do
-                          let filename = printf "%s.def_bin" $ takeFileName fname :: String
-                          doesFileExist filename >>= \case
-                            True  -> do
-                              BS.putStrLn $ BS.pack $ printf "load %s" filename
-                              decodeFile filename
-                            False -> do
-                              BS.putStrLn $ BS.pack $ printf "save %s" filename
-                              encodeFile filename defs
-                              pure defs
-                        (res, is) = runWriter . flip runReaderT (extensions e, initEnv <> ge) . runExceptT $ inference defs --_cached
-
-                        (g_env_1, res_1) = case res of
-                              Left err -> (mempty, Left $ pShow err)
-                              Right (mconcat -> newge) -> --do
-                                --writeFile (printf "%s.exp" fname) $ show newge
-                                (newge, right mconcat $ forM (fromMaybe [ExportModule $ SIName mempty mname] $ moduleExports e) $ \case
+                        (res, is) = runWriter . flip runReaderT (extensions e, initEnv <> ge) . runExceptT $ inference defs
+
+                        (res_1) = case res of
+                              Left err -> (Left $ pShow err)
+                              Right (mconcat -> newge) ->
+                                (right mconcat $ forM (fromMaybe [ExportModule $ SIName mempty mname] $ moduleExports e) $ \case
                                     ExportId (sName -> d) -> case Map.lookup d newge of
                                         Just def -> Right (mempty{-TODO-}, Map.singleton d def)
                                         Nothing  -> Left $ text d <+> "is not defined"
@@ -193,59 +183,7 @@ loadModule ex imp mname_ = do
                                         [x] -> Right x
                                         []  -> Left $ "empty export list in module" <+> text fname -- m, map fst $ moduleImports e, mname)
                                         _   -> error "export list: internal error")
-            ---------------
-            let writeResult = do
-                  let filename = printf "%s.exp" $ takeFileName fname :: String
-                      filename_closed = printf "%s.exp.closed" $ takeFileName fname :: String
-                      filename_closed_tr = printf "%s.exp.closed.tr" $ takeFileName fname :: String
-                      filename_keys = printf "%s.exp.keys" $ takeFileName fname :: String
-                  --putStrLn $ printf "write result! %d %s" ({-Map.size-}length g_env) filename
-                  writeFile filename_keys $ unlines $ map show $ Map.keys g_env
-                  let (g_env_ok, g_env_closed, g_env_closed_tr) = unzip3
-                        [ ( printf "%s :: %s\n%s = %s\n\n" k ty_s k v_s :: String
-                          , printf "%s :: %s\n%s = %s\n\n" k c_ty_s k c_v_s :: String
-                          , printf "%s :: %s\n%s = %s\n\n" k tr_c_ty_s k tr_c_v_s :: String
-                          )
-                        | (k,(v, v_ty, v_si)) <- Map.toList g_env
-                        , let ty_s = show $ mkDoc (False,False) $ v_ty
-                        , let v_s = show $ mkDoc (False,True) $ v
-                        , let c_v_ty = closeExp v_ty
-                        , let c_v = closeExp v
-                        , let c_ty_s = show $ mkDoc (False,False) c_v_ty
-                        , let c_v_s = show $ mkDoc (False,True) $ c_v
-                        , let tr_c_ty_s = show $ mkDoc (False,False) $ tr_exp c_v_ty
-                        , let tr_c_v_s = show $ mkDoc (False,True) $ tr_exp c_v
-                        ]
-                      tr_exp :: Exp -> Exp
-                      tr_exp = decode . encode
-                  {-
-                  writeFile filename (concat $ g_env_ok :: String)
-                  writeFile filename_closed (concat $ g_env_closed :: String)
-                  writeFile filename_closed_tr (concat $ g_env_closed_tr :: String)
-                  -}
-                  BS.putStrLn $ BS.pack $ printf "write %s" (printf "%s.env_bin - START" $ takeFileName fname :: String)
-                  encodeFile (printf "%s.env_bin" $ takeFileName fname :: String) $ closeGlobalEnv g_env
-                  BS.putStrLn $ BS.pack $ printf "write %s" (printf "%s.env_bin - DONE" $ takeFileName fname :: String)
-                  
-                  -- TODO: guarded pShow save to file for g_env exps and closed g_env exps
-
-                writeParsedDefs = do
-                  BS.putStrLn $ BS.pack $ printf "defs count: %d" (length defs)
-                  let filename = printf "%s.defs" $ takeFileName fname :: String
-                  writeFile filename $ unlines $ map ((++ "\n"). show . pShow) defs
-                  encodeFile (printf "%s.def_bin" $ takeFileName fname :: String) defs
-                  {-
-                    Experiment:
-                      Stmt/SExp - can be serialized
-                      Exp - explodes ; must be the inference algorithm
-                  -}
-                debugAction = do
-                  printTimeDiff (fname ++ " Defs") writeParsedDefs
-                  printTimeDiff (fname ++ " Exp") writeResult
-                  --when (fname == "./SampleMaterial.lc") $
-                  --  fail "stop"
-            return $ unsafePerformIO (debugAction >> pure (Right (e, res, err)))
-            --return (Right (e, res, err))
+            return (Right (e, res, err))
         modify $ \(Modules nm im ni) -> Modules nm (IM.insert fid (fi, (src, res)) im) ni
         return $ Right (fi, (src, res))
   where
@@ -286,7 +224,7 @@ parseModule path fname = runMM (ioFetch path) $ loadModule snd Nothing (Left fna
     Right (fname, (src, Right (pm, infos, _))) -> Right $ pPrintStmts infos
 
 -- used by the compiler-service of the online editor
-preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either Doc IR.Pipeline, (Infos, String)))
+preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> IR.Backend -> FilePath -> IO (String -> m (Either Doc IR.Pipeline, (Infos, String)))
 preCompile paths paths' backend mod = do
   res <- runMM (ioFetch paths) $ loadModule ex Nothing $ Left mod
   case res of
@@ -307,3 +245,17 @@ preCompile paths paths' backend mod = do
 
 pPrintStmts = unlines . map ((++"\n") . plainShow)
 
+-- basic interface
+type Program = Map FilePath (DesugarInfo, GlobalEnv)
+
+typecheckModule :: [FilePath] -> MName -> IO (Either [Doc] Program)
+typecheckModule path fname = runMM (ioFetch path) $ loadModule (const ()) Nothing (Left fname) >> do
+  fileInfoModules <- gets (IM.elems . modules)
+  let collect (FileInfo{..}, (sourceCode, errorOrGlobalEnv)) = case errorOrGlobalEnv of
+        Left error -> ([error],mempty)
+        Right (module_, (), Left error) -> ([error], mempty)
+        Right (module_, (), Right (desugarInfo, globalEnv)) -> (mempty, Map.singleton filePath (desugarInfo, closeGlobalEnv globalEnv))
+      (error, program) = mconcat $ map collect fileInfoModules
+  pure $ case error of
+    [] -> Right program
+    _ -> 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
     f n (ELet2 _ (ET x t) es) = if n == 0 then (BLam Visible{-??-}, up 1 t) else second (up 1) $ f (n-1) es
     f n e = either (error $ "varType: " ++ err ++ "\n" ++ show n_ ++ "\n" ++ ppShow env) (f n) $ parent e
 
+mkELet :: SIName -> Exp -> Exp -> Env -> Exp
 mkELet n x xt env = mkFun fn (Var <$> reverse vs) x
   where
     fn = FunName (FName n) (length vs) (ExpDef $ foldr addLam x vs) (foldr addPi xt vs)