Exp binary instance

7 files changed, 161 insertions, 15 deletions

diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs
index a61686ff..4d5213c3 100644
--- a/src/LambdaCube/Compiler.hs
+++ b/src/LambdaCube/Compiler.hs
@@ -89,7 +89,7 @@ type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (Either Doc
 ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x)
 ioFetch paths' imp n = do
     preludePath <- (</> "lc") <$> liftIO getDataDir
-    let paths = map (id &&& id) paths' ++ [(preludePath, "<<installed-prelude-path>>")]
+    let paths = map (id &&& id) paths' ++ [(preludePath, preludePath)]
         find ((x, (x', mn)): xs) = liftIO (readFileIfExists x) >>= maybe (find xs) (\src -> return $ Right (x', mn, liftIO src))
         find [] = return $ Left $ "can't find" <+> either (("lc file" <+>) . text) (("module" <+>) . text) n
                                   <+> "in path" <+> hsep (text . snd <$> paths)
@@ -141,7 +141,7 @@ loadModule ex imp mname_ = do
         src <- srcm
         fid <- gets nextMId
         modify $ \(Modules nm im ni) -> Modules (Map.insert fname fid nm) im $ ni+1
-        let fi = FileInfo fid fname mname src
+        let fi = FileInfo fid fname mname
         res <- case parseLC fi of
           Left e -> return $ Left $ text $ show e
           Right e -> do
@@ -224,7 +224,7 @@ preCompile paths paths' backend mod = do
       where
         compile src = runMM fetch $ do
             let pname = "." </> "Prelude.lc"
-            modify $ \(Modules nm im ni) -> Modules (Map.insert pname ni nm) (IM.insert ni (FileInfo ni pname "Prelude" $ fileContent fi, prelude) im) (ni+1)
+            modify $ \(Modules nm im ni) -> Modules (Map.insert pname ni nm) (IM.insert ni (FileInfo ni pname "Prelude", prelude) im) (ni+1)
             (snd &&& fst) <$> compilePipeline' ex backend "Main"
           where
             fetch imp = \case
diff --git a/src/LambdaCube/Compiler/Core.hs b/src/LambdaCube/Compiler/Core.hs
index 91056dd9..8e97c6b2 100644
--- a/src/LambdaCube/Compiler/Core.hs
+++ b/src/LambdaCube/Compiler/Core.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -12,6 +13,9 @@
 --{-# OPTIONS_GHC -fno-warn-unused-binds #-}  -- TODO: remove
 module LambdaCube.Compiler.Core where
 
+import Data.Binary
+import GHC.Generics (Generic)
+
 import Data.Monoid
 import Data.Function
 import Data.List
@@ -25,14 +29,18 @@ import LambdaCube.Compiler.DesugaredSource
 -------------------------------------------------------------------------------- names with infos
 
 data ConName       = ConName       FName Int{-ordinal number, e.g. Zero:0, Succ:1-} Type
+  deriving Generic
 
 data TyConName     = TyConName     FName Int{-num of indices-} Type [(ConName, Type)]{-constructors-} CaseFunName
+  deriving Generic
 
 data FunName       = FunName       FName Int{-num of global vars-} FunDef Type
 
 data CaseFunName   = CaseFunName   FName Type Int{-num of parameters-}
+  deriving Generic
 
 data TyCaseFunName = TyCaseFunName FName Type
+  deriving Generic
 
 data FunDef
     = DeltaDef !Int{-arity-} (FreeVars -> [Exp]{-args in reversed order-} -> Exp)
@@ -67,7 +75,7 @@ instance PShow TyCaseFunName where pShow (TyCaseFunName n _) = text $ MatchName
 -------------------------------------------------------------------------------- core expression representation
 
 data Freq = CompileTime | RunTime       -- TODO
-  deriving (Eq)
+  deriving (Eq, Generic)
 
 data Exp
     = ELit   Lit
@@ -80,6 +88,8 @@ data Exp
     | RHS    Exp{-always in hnf-}
     | Let_   FreeVars ExpType Exp
     | Up_    FreeVars [Int] Exp
+    | STOP
+    deriving Generic
 
 data Neutral
     = Var_        !Int{-De Bruijn index-}
@@ -88,13 +98,14 @@ data Neutral
     | TyCaseFun__ FreeVars TyCaseFunName [Exp] Neutral
     | Fun_        FreeVars FunName [Exp]{-given parameters, reversed-} Exp{-unfolded expression, in hnf-}
     | UpN_        FreeVars [Int] Neutral
+    deriving Generic
 
 -------------------------------------------------------------------------------- auxiliary functions and patterns
 
 type Type = Exp
 
 data ExpType = ET {expr :: Exp, ty :: Type}
-    deriving (Eq)
+    deriving (Eq, Generic)
 {-
 pattern ET a b <- ET_ a b
   where ET a b =  ET_ a (hnf b)
@@ -469,6 +480,7 @@ instance MkDoc Neutral where
     MT "finElim" [m, z, s, n, ConN "FZero" [i]] -> z `app_` i
 -}
 
+mkFunDef :: FName -> Type -> FunName
 mkFunDef a@(FTag FprimFix) t = fn
   where
     fn = FunName a 0 (DeltaDef 2 fx) t
@@ -681,3 +693,70 @@ instance NType Lit where
         LChar _   -> TChar
 
 
+closeTyConName (TyConName fname ints type_ cons caseFunName)
+ -- = TyConName fname ints (closeExp type_) [(closeConName n, closeExp t) | (n,t) <- cons] (closeCaseFunName caseFunName)
+  = TyConName fname ints STOP [(closeConName n, STOP) | (n,t) <- cons] (closeCaseFunName caseFunName)
+
+closeTyCaseFunName (TyCaseFunName fname type_)
+ -- = TyCaseFunName fname (closeExp type_)
+  = TyCaseFunName fname STOP
+
+closeConName (ConName fname ordinal type_)
+ -- = ConName fname ordinal (closeExp type_)
+  = ConName fname ordinal STOP
+
+closeCaseFunName (CaseFunName fname type_ int)
+ -- = CaseFunName fname (closeExp type_) int
+  = CaseFunName fname STOP int
+
+closeFunName (FunName fname int funDef type_)
+ -- = FunName fname int (closeFunDef funDef) (closeExp type_)
+  = FunName fname int (closeFunDef funDef) STOP
+
+closeFunDef = \case
+  ExpDef exp -> ExpDef STOP
+  --ExpDef exp -> ExpDef (closeExp exp)
+  x -> x
+
+closeExp :: Exp -> Exp
+closeExp = \case
+  Lam_   freeVars exp -> Lam_ freeVars $ closeExp exp
+  Con_   freeVars conName noErasedApplied argsReversed -> Con_ freeVars (closeConName conName) noErasedApplied (map closeExp argsReversed)
+  TyCon_ freeVars tyConName argsReversed -> TyCon_ freeVars (closeTyConName tyConName) (map closeExp argsReversed)
+  Pi_    freeVars visibility exp1 exp2 -> Pi_ freeVars visibility (closeExp exp1) (closeExp exp2)
+  Neut   neutral -> Neut $ closeNeutral neutral
+  RHS    whnf -> STOP
+  Let_   freeVars expType exp -> Let_ freeVars (closeExpType expType) (closeExp exp)
+  Up_    freeVars ints exp -> Up_ freeVars ints (closeExp exp)
+  e -> e
+
+closeNeutral :: Neutral -> Neutral
+closeNeutral = \case
+  App__       freeVars neutral exp -> App__ freeVars (closeNeutral neutral) (closeExp exp)
+  CaseFun__   freeVars caseFunName   exps neutral -> CaseFun__ freeVars (closeCaseFunName caseFunName) (map closeExp exps) (closeNeutral neutral)
+  TyCaseFun__ freeVars tyCaseFunName exps neutral -> TyCaseFun__ freeVars (closeTyCaseFunName tyCaseFunName) (map closeExp exps) (closeNeutral neutral)
+  Fun_        freeVars funName exps exp -> Fun_ freeVars (closeFunName funName) (map closeExp exps) (closeExp exp)
+  UpN_        freeVars ints neutral -> UpN_ freeVars ints (closeNeutral neutral)
+  n -> n
+
+closeExpType :: ExpType -> ExpType
+closeExpType (ET e t) = ET (closeExp e) (closeExp t)
+
+instance Binary ExpType
+instance Binary Exp
+instance Binary Neutral
+instance Binary Freq
+instance Binary ConName
+instance Binary CaseFunName
+instance Binary TyConName
+instance Binary TyCaseFunName
+
+instance Binary FunName where -- do FunName/FunDef instance together
+  put (FunName fName int funDef type_) = do
+    put fName
+    put type_
+
+  get = do
+    fName <- get
+    type_ <- get
+    pure $ mkFunDef fName type_
diff --git a/src/LambdaCube/Compiler/DeBruijn.hs b/src/LambdaCube/Compiler/DeBruijn.hs
index a1af40db..a0fd8326 100644
--- a/src/LambdaCube/Compiler/DeBruijn.hs
+++ b/src/LambdaCube/Compiler/DeBruijn.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -10,6 +11,9 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 module LambdaCube.Compiler.DeBruijn where
 
+import Data.Binary
+import GHC.Generics (Generic)
+
 import Data.Bits
 import Control.Arrow hiding ((<+>))
 
@@ -63,7 +67,9 @@ instance Rearrange Void where
 ------------------------------------------------------- set of free variables (implemented with bit vectors)
 
 newtype FreeVars = FreeVars Integer
-    deriving Eq
+    deriving (Eq, Generic)
+
+instance Binary FreeVars
 
 instance PShow FreeVars where
     pShow (FreeVars s) = "FreeVars" `DApp` pShow s
diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs
index d355b4b9..8d9a38be 100644
--- a/src/LambdaCube/Compiler/DesugaredSource.hs
+++ b/src/LambdaCube/Compiler/DesugaredSource.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -13,6 +14,13 @@ module LambdaCube.Compiler.DesugaredSource
     , Fixity(..)
     )where
 
+import System.IO.Unsafe
+import Text.Printf
+import qualified Data.ByteString.Char8 as BS
+
+import Data.Binary
+import GHC.Generics (Generic)
+
 import Data.Monoid
 import Data.Maybe
 import Data.List
@@ -51,7 +59,9 @@ pattern MatchName cs <- 'm':'a':'t':'c':'h':cs where MatchName cs = "match" ++ c
 
 -- source position without file name
 newtype SPos = SPos_ Int
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Generic)
+
+instance Binary SPos
 
 row :: SPos -> Int
 row (SPos_ i) = i `shiftR` 16
@@ -72,8 +82,16 @@ data FileInfo = FileInfo
     { fileId      :: !Int
     , filePath    :: FilePath
     , fileModule  :: String   -- module name
-    , fileContent :: String
     }
+    deriving Generic
+
+instance Binary FileInfo
+
+fileContent :: FileInfo -> String
+fileContent fi = unsafePerformIO $ do
+  let fname = filePath fi
+  BS.putStrLn $ BS.pack $ printf "load source %s" fname
+  readFile fname
 
 instance Eq FileInfo where (==) = (==) `on` fileId
 instance Ord FileInfo where compare = compare `on` fileId
@@ -90,7 +108,9 @@ data Range = Range
     , rangeStart :: !SPos
     , rangeStop  :: !SPos
     }
-    deriving (Eq, Ord)
+    deriving (Eq, Ord, Generic)
+
+instance Binary Range
 
 instance Show Range where show = ppShow
 instance PShow Range
@@ -112,6 +132,9 @@ joinRange (Range n b e) (Range n' b' e') = Range n (min b b') (max e e')
 data SI
     = NoSI (Set.Set String) -- no source info, attached debug info
     | RangeSI Range
+    deriving Generic
+
+instance Binary SI
 
 getRange :: SI -> Maybe Range
 getRange (RangeSI r) = Just r
@@ -159,6 +182,9 @@ class SetSourceInfo a where
 -------------------------------------------------------------------------------- name with source info
 
 data SIName = SIName__ { nameHash :: Int, nameSI :: SI, nameFixity :: Maybe Fixity, sName :: SName }
+    deriving Generic
+
+instance Binary SIName
 
 pattern SIName_ :: SI -> Maybe Fixity -> SName -> SIName
 pattern SIName_ si f n <- SIName__ _ si f n
@@ -186,6 +212,9 @@ instance SetSourceInfo SIName where
 -------------------------------------------------------------------------------- hashed names
 
 newtype FName = FName { fName :: SIName }
+    deriving Generic
+
+instance Binary FName
 
 instance Eq    FName where (==) = (==) `on` nameHash . fName
 instance Ord   FName where compare = compare `on` nameHash . fName
@@ -228,7 +257,9 @@ data FNameTag
 
     -- other
     | F_rhs | F_section
-    deriving (Eq, Ord, Show, Enum, Bounded)
+    deriving (Eq, Ord, Show, Enum, Bounded, Generic)
+
+instance Binary FNameTag
 
 tagName :: FNameTag -> String
 tagName FCons = ":"
@@ -267,7 +298,9 @@ data Lit
     | LChar   Char
     | LFloat  Double
     | LString String
-  deriving (Eq)
+  deriving (Eq, Generic)
+
+instance Binary Lit
 
 instance PShow Lit where
     pShow = \case
@@ -287,7 +320,9 @@ data SExp' a
     | SLet_   SI (SData SIName) (SExp' a) (SExp' a)    -- let x = e in f   -->  SLet e f{-x is Var 0-}
     | SLHS    SIName (SExp' a)
     | STyped  a
-  deriving (Eq)
+  deriving (Eq, Generic)
+
+instance Binary SExp
 
 sLHS :: SIName -> SExp' a -> SExp' a
 sLHS _ (SRHS x) = x
@@ -299,7 +334,9 @@ data Binder
     = BPi  Visibility
     | BLam Visibility
     | BMeta      -- a metavariable is like a floating hidden lambda
-  deriving (Eq)
+  deriving (Eq, Generic)
+
+instance Binary Binder
 
 instance PShow Binder where
     pShow = \case
@@ -308,7 +345,9 @@ instance PShow Binder where
         BMeta -> "BMeta"
 
 data Visibility = Hidden | Visible
-  deriving (Eq)
+  deriving (Eq, Generic)
+
+instance Binary Visibility
 
 instance PShow Visibility where
     pShow = \case
@@ -617,6 +656,9 @@ data Stmt
     = StmtLet SIName SExp
     | Data SIName [(Visibility, SExp)]{-parameters-} SExp{-type-} [(SIName, SExp)]{-constructor names and types-}
     | PrecDef SIName Fixity
+    deriving Generic
+
+instance Binary Stmt
 
 pattern StLet :: SIName -> Maybe (SExp' Void) -> SExp' Void -> Stmt
 pattern StLet n mt x <- StmtLet n (getSAnn -> (x, mt))
diff --git a/src/LambdaCube/Compiler/InferMonad.hs b/src/LambdaCube/Compiler/InferMonad.hs
index 1905c839..2499fa5c 100644
--- a/src/LambdaCube/Compiler/InferMonad.hs
+++ b/src/LambdaCube/Compiler/InferMonad.hs
@@ -214,3 +214,5 @@ dependentVars ie = cycle mempty
         a <-> b = (a --> b) <> (b --> a)
 
 
+--closeGlobalEnv :: GlobalEnv -> GlobalEnv
+closeGlobalEnv = fmap (\(exp, type_, si) -> (closeExp exp {-, closeExp type_, si)-})) -- HINT: type should be finite
diff --git a/src/LambdaCube/Compiler/Pretty.hs b/src/LambdaCube/Compiler/Pretty.hs
index 317c4080..24e540dd 100644
--- a/src/LambdaCube/Compiler/Pretty.hs
+++ b/src/LambdaCube/Compiler/Pretty.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE LambdaCase #-}
@@ -13,6 +14,9 @@ module LambdaCube.Compiler.Pretty
     ( module LambdaCube.Compiler.Pretty
     ) where
 
+import Data.Binary (Binary)
+import GHC.Generics (Generic)
+
 import Data.Maybe
 import Data.String
 import Data.Char
@@ -36,7 +40,9 @@ data Fixity
     = Infix  !Int
     | InfixL !Int
     | InfixR !Int
-    deriving (Eq)
+    deriving (Eq, Generic)
+
+instance Binary Fixity
 
 instance PShow Fixity where
     pShow = \case
diff --git a/src/LambdaCube/Compiler/Utils.hs b/src/LambdaCube/Compiler/Utils.hs
index 2a86f80b..3d1dc1ec 100644
--- a/src/LambdaCube/Compiler/Utils.hs
+++ b/src/LambdaCube/Compiler/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE EmptyCase #-}
@@ -7,6 +8,9 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module LambdaCube.Compiler.Utils where
 
+import Data.Binary (Binary(..))
+import GHC.Generics (Generic)
+
 import qualified Data.IntSet as IS
 import qualified Data.Text as T
 import qualified Text.Show.Pretty as PP
@@ -36,6 +40,10 @@ foldlrev f = foldr (flip f)
 
 data Void
 
+instance Binary Void where
+  get = error "Binary get"
+  put = error "Binary put"
+
 instance Eq Void where x == y = elimVoid x
 
 elimVoid :: Void -> a
@@ -45,6 +53,9 @@ elimVoid v = case v of
 
 -- supplementary data: data with no semantic relevance
 newtype SData a = SData a
+  deriving Generic
+
+instance Binary a => Binary (SData a)
 
 instance Eq (SData a) where _ == _ = True
 instance Ord (SData a) where _ `compare` _ = EQ