shithub: MicroHs

--- a/src/MicroHs/Exp.hs

+++ b/src/MicroHs/Exp.hs

@@ -15,6 +15,7 @@

 import MicroHs.Ident

 import MicroHs.Expr(Lit(..), showLit)

 import MicroHs.List

+import MicroHs.MRnf

 import Text.PrettyPrint.HughesPJLite

 import Debug.Trace

@@ -26,6 +27,12 @@

   | Lam Ident Exp

   | Lit Lit

   deriving (Eq)

+instance MRnf Exp where

+  mrnf (Var a) = mrnf a

+  mrnf (App a b) = mrnf a `seq` mrnf b

+  mrnf (Lam a b) = mrnf a `seq` mrnf b

+  mrnf (Lit a) = mrnf a

 app2 :: Exp -> Exp -> Exp -> Exp

 app2 f a1 a2 = App (App f a1) a2

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -54,6 +54,7 @@

 import Data.List

 import Data.Maybe

 import MicroHs.Ident

+import MicroHs.MRnf

 import Text.PrettyPrint.HughesPJLite

 import GHC.Stack

@@ -89,12 +90,34 @@

   | Deriving EConstraint

 --DEBUG  deriving (Show)

+instance MRnf EDef where

+  mrnf (Data a b c) = mrnf a `seq` mrnf b `seq` mrnf c

+  mrnf (Newtype a b c) = mrnf a `seq` mrnf b `seq` mrnf c

+  mrnf (Type a b) = mrnf a `seq` mrnf b

+  mrnf (Fcn a b) = mrnf a `seq` mrnf b

+  mrnf (PatBind a b) = mrnf a `seq` mrnf b

+  mrnf (Sign a b) = mrnf a `seq` mrnf b

+  mrnf (KindSign a b) = mrnf a `seq` mrnf b

+  mrnf (Import a) = mrnf a

+  mrnf (ForImp a b c) = mrnf a `seq` mrnf b `seq` mrnf c

+  mrnf (Infix a b) = mrnf a `seq` mrnf b

+  mrnf (Class a b c d) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d

+  mrnf (Instance a b) = mrnf a `seq` mrnf b

+  mrnf (Default a b) = mrnf a `seq` mrnf b

+  mrnf (Pattern a b c) = mrnf a `seq` mrnf b `seq` mrnf c

+  mrnf (Deriving a) = mrnf a

 data ImpType = ImpNormal | ImpBoot

   deriving (Eq)

+instance MRnf ImpType

 data ImportSpec = ImportSpec ImpType Bool Ident (Maybe Ident) (Maybe (Bool, [ImportItem]))  -- first Bool indicates 'qualified', second 'hiding'

 --DEBUG  deriving (Show)

+instance MRnf ImportSpec where

+  mrnf (ImportSpec a b c d e) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d `seq` mrnf e

 data ImportItem

   = ImpTypeSome Ident [Ident]

   | ImpTypeAll Ident

@@ -101,6 +124,11 @@

   | ImpValue Ident

 --DEBUG  deriving (Show)

+instance MRnf ImportItem where

+  mrnf (ImpTypeSome a b) = mrnf a `seq` mrnf b

+  mrnf (ImpTypeAll a) = mrnf a

+  mrnf (ImpValue a) = mrnf a

 type Deriving = [EConstraint]

 data Expr

@@ -137,6 +165,36 @@

   | ECon Con

 --DEBUG  deriving (Show)

+instance MRnf Expr where

+  mrnf (EVar a) = mrnf a

+  mrnf (EApp a b) = mrnf a `seq` mrnf b

+  mrnf (EOper a b) = mrnf a `seq` mrnf b

+  mrnf (ELam a) = mrnf a

+  mrnf (ELit a b) = mrnf a `seq` mrnf b

+  mrnf (ECase a b) = mrnf a `seq` mrnf b

+  mrnf (ELet a b) = mrnf a `seq` mrnf b

+  mrnf (ETuple a) = mrnf a

+  mrnf (EParen a) = mrnf a

+  mrnf (EListish a) = mrnf a

+  mrnf (EDo a b) = mrnf a `seq` mrnf b

+  mrnf (ESectL a b) = mrnf a `seq` mrnf b

+  mrnf (ESectR a b) = mrnf a `seq` mrnf b

+  mrnf (EIf a b c) = mrnf a `seq` mrnf b `seq` mrnf c

+  mrnf (EMultiIf a) = mrnf a

+  mrnf (ESign a b) = mrnf a `seq` mrnf b

+  mrnf (ENegApp a) = mrnf a

+  mrnf (EUpdate a b) = mrnf a `seq` mrnf b

+  mrnf (ESelect a) = mrnf a

+  mrnf (EAt a b) = mrnf a `seq` mrnf b

+  mrnf (EViewPat a b) = mrnf a `seq` mrnf b

+  mrnf (ELazy a b) = mrnf a `seq` mrnf b

+  mrnf (EOr a) = mrnf a

+  mrnf (EForall a b c) = mrnf a `seq` mrnf b `seq` mrnf c

+  mrnf (EUVar a) = mrnf a

+  mrnf (EQVar a b) = mrnf a `seq` mrnf b

+  mrnf (ECon a) = mrnf a

 data EField

   = EField [Ident] Expr     -- a.b = e

   | EFieldPun [Ident]       -- a.b

@@ -143,6 +201,11 @@

   | EFieldWild              -- ..

 --DEBUG  deriving (Show)

+instance MRnf EField where

+  mrnf (EField a b) = mrnf a `seq` mrnf b

+  mrnf (EFieldPun a) = mrnf a

+  mrnf EFieldWild = ()

 unEField :: EField -> ([Ident], Expr)

 unEField (EField is e) = (is, e)

 unEField _ = impossible

@@ -166,6 +229,11 @@

   | ConSyn Ident Int (Expr, EType)

 --DEBUG  deriving(Show)

+instance MRnf Con where

+  mrnf (ConData a b c) = mrnf a `seq` mrnf b `seq` mrnf c

+  mrnf (ConNew a b) = mrnf a `seq` mrnf b

+  mrnf (ConSyn a b c) = mrnf a `seq` mrnf b `seq` mrnf c

 data Listish

   = LList [Expr]

   | LCompr Expr [EStmt]

@@ -175,6 +243,14 @@

   | LFromThenTo Expr Expr Expr

 --DEBUG  deriving(Show)

+instance MRnf Listish where

+  mrnf (LList a) = mrnf a

+  mrnf (LCompr a b) = mrnf a `seq` mrnf b

+  mrnf (LFrom a) = mrnf a

+  mrnf (LFromTo a b) = mrnf a `seq` mrnf b

+  mrnf (LFromThen a b) = mrnf a `seq` mrnf b

+  mrnf (LFromThenTo a b c) = mrnf a `seq` mrnf b `seq` mrnf c

 conIdent :: HasCallStack =>

             Con -> Ident

 conIdent (ConData _ i _) = i

@@ -212,10 +288,25 @@

 --DEBUG  deriving (Show)

   deriving (Eq)

+instance MRnf Lit where

+  mrnf (LInt a) = mrnf a

+  mrnf (LInteger a) = mrnf a

+  mrnf (LDouble a) = mrnf a

+  mrnf (LRat a) = mrnf a

+  mrnf (LChar a) = mrnf a

+  mrnf (LStr a) = mrnf a

+  mrnf (LUStr a) = mrnf a

+  mrnf (LPrim a) = mrnf a

+  mrnf (LExn a) = mrnf a

+  mrnf (LForImp a b) = mrnf a `seq` mrnf b

+  mrnf (LTick a) = mrnf a

 -- A type of a C FFI function

 newtype CType = CType EType

 instance Eq CType where

   _ == _  =  True    -- Just ignore the CType

+instance MRnf CType where

+  mrnf (CType t) = mrnf t

 type ECaseArm = (EPat, EAlts)

@@ -222,6 +313,11 @@

 data EStmt = SBind EPat Expr | SThen Expr | SLet [EBind]

 --DEBUG  deriving (Show)

+instance MRnf EStmt where

+  mrnf (SBind a b) = mrnf a `seq` mrnf b

+  mrnf (SThen a) = mrnf a

+  mrnf (SLet a) = mrnf a

 data EBind

   = BFcn Ident [Eqn]

   | BPat EPat Expr

@@ -229,13 +325,25 @@

   | BDfltSign Ident EType     -- only in class declarations

 --DEBUG  deriving (Show)

+instance MRnf EBind where

+  mrnf (BFcn a b) = mrnf a `seq` mrnf b

+  mrnf (BPat a b) = mrnf a `seq` mrnf b

+  mrnf (BSign a b) = mrnf a `seq` mrnf b

+  mrnf (BDfltSign a b) = mrnf a `seq` mrnf b

 -- A single equation for a function

 data Eqn = Eqn [EPat] EAlts

 --DEBUG  deriving (Show)

+instance MRnf Eqn where

+  mrnf (Eqn a b) = mrnf a `seq` mrnf b

 data EAlts = EAlts [EAlt] [EBind]

 --DEBUG  deriving (Show)

+instance MRnf EAlts where

+  mrnf (EAlts a b) = mrnf a `seq` mrnf b

 type EAlt = ([EStmt], Expr)

 type ConTyInfo = [(Ident, Int)]    -- All constructors with their arities

@@ -283,6 +391,9 @@

   (Either [SType] [ConstrField])  -- types or named fields

   deriving(Show)

+instance MRnf Constr where

+  mrnf (Constr a b c d) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d

 type ConstrField = (Ident, SType)              -- record label and type

 type SType = (Bool, EType)                     -- the Bool indicates strict

@@ -299,6 +410,9 @@

 instance Show IdKind where

   show (IdKind i k) = "(" ++ show i ++ "::" ++ show k ++ ")"

+instance MRnf IdKind where

+  mrnf (IdKind a b) = mrnf a `seq` mrnf b

 idKindIdent :: IdKind -> Ident

 idKindIdent (IdKind i _) = i

@@ -438,6 +552,8 @@

 type Fixity = (Assoc, Int)

+instance MRnf Assoc

 ---------------------------------

 -- Enough to handle subsitution in types

@@ -710,11 +826,12 @@

 ppExprRaw = ppExprR True

 ppExpr :: Expr -> Doc

-ppExpr = ppExprR False

+ppExpr = ppExprR True -- False

 ppExprR :: Bool -> Expr -> Doc

-ppExprR raw = ppE

+ppExprR _raw = ppE

   where

+    raw = True

     ppE :: Expr -> Doc

     ppE ae =

       case ae of

--- a/src/MicroHs/Ident.hs

+++ b/src/MicroHs/Ident.hs

@@ -23,6 +23,7 @@

 import Text.PrettyPrint.HughesPJLite

 import GHC.Stack

 import MicroHs.List(dropEnd)

+import MicroHs.MRnf

 import Data.Text(Text, pack, unpack, append, head)

 import Compat

@@ -53,6 +54,9 @@

 instance Show SLoc where

   show (SLoc f l c) = show f ++ "," ++ show l ++ ":" ++ show c

+instance MRnf SLoc where

+  mrnf (SLoc a b c) = mrnf a `seq` mrnf b `seq` mrnf c

 data Ident = Ident SLoc Text

   --deriving (Show)

@@ -68,6 +72,9 @@

 instance Show Ident where

   show = showIdent

+instance MRnf Ident where

+  mrnf (Ident a b) = mrnf a `seq` mrnf b

 slocIdent :: Ident -> SLoc

 slocIdent (Ident l _) = l

--- a/src/MicroHs/IdentMap.hs

+++ b/src/MicroHs/IdentMap.hs

@@ -19,6 +19,7 @@

   ) where

 import Prelude(); import MHSPrelude hiding(lookup, mapM, null)

 import MicroHs.Ident

+import MicroHs.MRnf

 data Map a

   = Nil           -- empty tree

@@ -35,6 +36,11 @@

 instance Show a => Show (Map a) where

   show m = show (toList m)

-}

+instance MRnf a => MRnf (Map a) where

+  mrnf Nil = ()

+  mrnf (One a b) = mrnf a `seq` mrnf b

+  mrnf (Node a b c d e) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d `seq` mrnf e

 empty :: forall a . Map a

 empty = Nil

--- a/src/MicroHs/Main.hs

+++ b/src/MicroHs/Main.hs

@@ -157,9 +157,11 @@

       (name, ver) = splitNameVer namever

       (exported, other) = partition ((`elem` mns) . tModuleName) mdls

       pkgDeps = map (\ p -> (pkgName p, pkgVersion p)) $ getPkgs cash

-      pkg = Package { pkgName = mkIdent name, pkgVersion = ver

+      pkg = Package { pkgName = mkIdent name

+                    , pkgVersion = ver

                     , pkgCompiler = mhsVersion

-                    , pkgExported = exported, pkgOther = other

+                    , pkgExported = exported

+                    , pkgOther = other

                     , pkgTables = getCacheTables cash

                     , pkgDepends = pkgDeps }

   --print (map tModuleName $ pkgOther pkg)

@@ -166,7 +168,7 @@

   t1 <- getTimeMilli

   when (verbose flags > 0) $

     putStrLn $ "Writing package " ++ namever ++ " to " ++ output flags

-  writeSerializedCompressed (output flags) pkg

+  writeSerializedCompressed (output flags) (forcePackage pkg)

   t2 <- getTimeMilli

   when (verbose flags > 0) $

     putStrLn $ "Compression time " ++ show (t2 - t1) ++ " ms"

@@ -321,7 +323,7 @@

           ok <- doesDirectoryExist pdir

           when ok $ do

             files <- getDirectoryContents pdir

-            let pkgs = [ b | f <- files, Just b <- [stripSuffix ".pkg" f] ]

+            let pkgs = [ b | f <- files, Just b <- [stripSuffix packageSuffix f] ]

             putStrLn $ pdir ++ ":"

             mapM_ (\ p -> putStrLn $ "  " ++ p) pkgs

--- a/src/MicroHs/Package.hs

+++ b/src/MicroHs/Package.hs

@@ -1,11 +1,13 @@

 module MicroHs.Package(

   IdentPackage,

   Package(..),

+  forcePackage,

   ) where

 import Prelude(); import MHSPrelude

 import Data.Version

 import MicroHs.Desugar(LDef)

 import MicroHs.Ident(Ident)

+import MicroHs.MRnf

 import MicroHs.TypeCheck(TModule, GlobTables)

--

@@ -35,3 +37,11 @@

   pkgDepends   :: [(IdentPackage, Version)]        -- used packages

   -- deriving (Show)

+instance MRnf Package where

+  mrnf (Package a b c d e f g) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d `seq` mrnf e `seq` mrnf f `seq` mrnf g

+-- Fully evaluate a package

+forcePackage :: Package -> Package

+forcePackage p = mrnf p `seq` p

--- a/src/MicroHs/SymTab.hs

+++ b/src/MicroHs/SymTab.hs

@@ -22,6 +22,7 @@

 import MicroHs.Expr(Expr(..), EType, conIdent)

 import MicroHs.Ident(Ident, showIdent, unIdent, mkIdentSLoc, slocIdent)

 import MicroHs.List

+import MicroHs.MRnf

 import qualified MicroHs.IdentMap as M

 -- Symbol table

@@ -38,6 +39,9 @@

 instance Eq Entry where

   Entry x _ == Entry y _  =  getIdent x == getIdent y

+instance MRnf Entry where

+  mrnf (Entry a b) = mrnf a `seq` mrnf b

 getIdent :: Expr -> Ident

 getIdent ae =

--- a/src/MicroHs/TCMonad.hs

+++ b/src/MicroHs/TCMonad.hs

@@ -13,6 +13,7 @@

 import MicroHs.Ident

 import qualified MicroHs.IdentMap as M

 import qualified MicroHs.IntMap as IM

+import MicroHs.MRnf

 import MicroHs.State

 import MicroHs.SymTab

 import Debug.Trace

@@ -72,6 +73,9 @@

        [IFunDep]

 --  deriving (Show)

+instance MRnf InstInfo where

+  mrnf (InstInfo a b c) = mrnf a `seq` mrnf b `seq` mrnf c

 -- This is the dictionary expression, instance variables, instance context,

 -- and instance.

 type InstDictC  = (Expr, [IdKind], [EConstraint], EConstraint, [IFunDep])

@@ -85,6 +89,9 @@

 data ClassInfo = ClassInfo [IdKind] [EConstraint] EKind [Ident] [IFunDep]  -- class tyvars, superclasses, class kind, methods, fundeps

 type IFunDep = ([Bool], [Bool])           -- the length of the lists is the number of type variables

+instance MRnf ClassInfo where

+  mrnf (ClassInfo a b c d e) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d `seq` mrnf e

 -----------------------------------------------

 -- TCState

--- a/src/MicroHs/TypeCheck.hs

+++ b/src/MicroHs/TypeCheck.hs

@@ -32,6 +32,7 @@

 import qualified MicroHs.IdentMap as M

 import qualified MicroHs.IntMap as IM

 import MicroHs.List

+import MicroHs.MRnf

 import MicroHs.Parse(dotDotIdent)

 import MicroHs.SymTab

 import MicroHs.TCMonad

@@ -127,6 +128,9 @@

   gInstInfo   :: InstTable        -- instances are implicitely global

+instance MRnf GlobTables where

+  mrnf (GlobTables a b c d) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d

 emptyGlobTables :: GlobTables

 emptyGlobTables = GlobTables { gSynTable = M.empty, gDataTable = M.empty, gClassTable = M.empty, gInstInfo = M.empty }

@@ -149,6 +153,9 @@

 --  deriving (Show)

+instance MRnf a => MRnf (TModule a) where

+  mrnf (TModule a b c d e f) = mrnf a `seq` mrnf b `seq` mrnf c `seq` mrnf d `seq` mrnf e `seq` mrnf f

 setBindings :: TModule b -> a -> TModule a

 setBindings (TModule x y z w v _) a = TModule x y z w v a

@@ -160,6 +167,9 @@

 --instance Show TypeExport where show (TypeExport i _ vs) = showIdent i ++ show vs

+instance MRnf TypeExport where

+  mrnf (TypeExport a b c) = mrnf a `seq` mrnf b `seq` mrnf c

 data ValueExport = ValueExport

   Ident           -- unqualified name

   Entry           -- symbol table entry

@@ -166,6 +176,9 @@

 --  deriving (Show)

 --instance Show ValueExport where show (ValueExport i _) = showIdent i

+instance MRnf ValueExport where

+  mrnf (ValueExport a b) = mrnf a `seq` mrnf b

 type FixDef = (Ident, Fixity)