refactoring

2 files changed, 27 insertions, 18 deletions

diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs
index 1c60ae8a..5eefce9a 100644
--- a/src/LambdaCube/Compiler/Infer.hs
+++ b/src/LambdaCube/Compiler/Infer.hs
@@ -15,7 +15,7 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}  -- TODO: remove
 -- {-# OPTIONS_GHC -O0 #-}
 module LambdaCube.Compiler.Infer
-    ( Binder (..), SName, Lit(..), Visibility(..), Export(..), Module(..)
+    ( Binder (..), SName, Lit(..), Visibility(..)
     , Exp (..), Neutral (..), ExpType, GlobalEnv
     , pattern Var, pattern CaseFun, pattern TyCaseFun, pattern App_, pattern LabelEnd
     , pattern Con, pattern TyCon, pattern Pi, pattern Lam, pattern Fun
@@ -23,13 +23,13 @@ module LambdaCube.Compiler.Infer
     , down, Subst (..), free
     , litType
     , initEnv, Env(..), pattern EBind2
+    , SI(..), Range(..) -- todo: remove
     , Info(..), Infos, listAllInfos, listTypeInfos, listTraceInfos
-    , PolyEnv(..), parseLC, joinPolyEnvs, filterPolyEnv, inference_
-    , ImportItems (..)
-    , SI(..), Range(..)
+    , PolyEnv(..), joinPolyEnvs, filterPolyEnv, inference_
     , nType, conType, neutType, neutType', appTy, mkConPars, makeCaseFunPars, makeCaseFunPars'
     , MaxDB(..), unfixlabel
     , ErrorMsg, showError
+    , extractDesugarInfo
     ) where
 
 import Data.Monoid
@@ -1120,6 +1120,7 @@ initEnv = Map.fromList
     [ (,) "'Type" (TType, TType, (debugSI "source-of-Type", Nothing))
     ]
 
+-- todo: eliminate
 extractDesugarInfo :: GlobalEnv -> DesugarInfo
 extractDesugarInfo ge =
     ( Map.fromList
@@ -1470,18 +1471,8 @@ instance MkDoc (CEnv Exp) where
 mfix' f = ExceptT (mfix (runExceptT . f . either bomb id))
   where bomb e = error $ "mfix (ExceptT): inner computation returned Left value:\n" ++ show e
 
-inference_ :: PolyEnv -> Module -> ExceptT ErrorMsg (WriterT Infos Identity) PolyEnv
-inference_ (PolyEnv pe is) m = do
-
-    ((defs, dns), ds) <- mfix $ \ ~(_, ds) -> do
-        let (x, dns) = definitions m ds
-        defs <- either (throwError' . ErrorMsg . show) return x
-        let ds' = mkDesugarInfo defs `joinDesugarInfo` extractDesugarInfo pe
-        return ((defs, dns), ds')
-
-    mapM_ (maybe (return ()) (throwError' . ErrorMsg)) dns
-    mapExceptT (ff . runWriter . flip runReaderT (extensions m, mempty)) $ gg (handleStmt defs) (initEnv <> pe) $ sortDefs ds defs
-
+inference_ :: PolyEnv -> Extensions -> [Stmt] -> ExceptT ErrorMsg (WriterT Infos Identity) PolyEnv
+inference_ (PolyEnv pe is) exts defs = mapExceptT (ff . runWriter . flip runReaderT (exts, mempty)) $ gg (handleStmt defs) (initEnv <> pe) defs
   where
     ff (Left e, is) = do
         tell is
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index c1215ee9..aa9efe28 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -15,7 +15,8 @@ module LambdaCube.Compiler.Parser
     , pattern SVar, pattern SType, pattern Wildcard, pattern SAppV, pattern SLamV, pattern SAnn
     , pattern SBuiltin, pattern SPi, pattern Primitive, pattern SLabelEnd, pattern SLam
     , pattern TyType, pattern Wildcard_
-    , debug, LI, isPi, varDB, lowerDB, justDB, upDB, cmpDB, MaxDB (..), iterateN, traceD, parseLC
+    , debug, LI, isPi, varDB, lowerDB, justDB, upDB, cmpDB, MaxDB (..), iterateN, traceD
+    , parseLC, runDefParser
     , getParamsS, addParamsS, getApps, apps', downToS, addForalls
     , mkDesugarInfo, joinDesugarInfo
     , Up (..), up1, up
@@ -1045,9 +1046,11 @@ data Module
   { extensions    :: Extensions
   , moduleImports :: [(SIName, ImportItems)]
   , moduleExports :: Maybe [Export]
-  , definitions   :: DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck])
+  , definitions   :: DefParser
   }
 
+type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck])
+
 parseModule :: FilePath -> String -> P Module
 parseModule f str = do
     exts <- concat <$> many parseExtensions
@@ -1084,6 +1087,21 @@ parseLC f str
     . runP (error "globalenv used", Namespace (Just ExpLevel) True) f (parseModule f str)
     $ str
 
+--type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck])
+runDefParser :: (MonadFix m, MonadError String m) => DesugarInfo -> DefParser -> m [Stmt]
+runDefParser ds_ dp = do
+
+    ((defs, dns), ds) <- mfix $ \ ~(_, ds) -> do
+        let (x, dns) = dp ds
+        defs <- either (throwError . show) return x
+        let ds' = mkDesugarInfo defs `joinDesugarInfo` ds_
+        return ((defs, dns), ds')
+
+    mapM_ (maybe (return ()) throwError) dns
+
+    return $ sortDefs ds defs
+
+
 -------------------------------------------------------------------------------- pretty print
 
 instance Up a => PShow (SExp' a) where