ref: bf23440e3fa1cbee7e90d5e40b88406e47f478c4
parent: 0b5ebea7268da216f2cfe734c5ecbf4283c4ce64
author: Lennart Augustsson <lennart@augustsson.net>
date: Wed Nov 8 11:21:40 EST 2023
Implement strict constructors
--- a/TODO
+++ b/TODO
@@ -1,4 +1,3 @@
-* Add strict constructors
* Put on hackage
* Have compile return a Stats record of timing etc
* Implement deriving
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.1
-1537
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _271) ((B _12) _1)) _454))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _453))) ((A :10 (((S' P) _2) (((C' _13) _1) _1278))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _268) _12) _259))) ((A :20 (((S' B) _14) (((C' _271) _12) _260))) ((A :21 _1364) ((A :22 ((B _1405) _21)) ((A :23 (((S' _1405) _21) I)) ((A :24 _1334) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1363) ((C _258) _26))) ((A :28 (((C' _27) ((_267 _1375) _170)) ((_258 (_34 _1377)) _169))) ((A :29 ((B ((S _1405) (_34 _1377))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _453)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _454)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1278)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1278))) ((A :46 ((C _43) _259)) ((A :47 ((B _261) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _261) _48)) ((A :50 T) ((A :51 ((_266 ((B (B (_256 _50))) ((B ((C' C) _54)) (B P)))) (_270 _51))) ((A :52 (((((_11 _51) ((B (_256 _50)) P)) (_38 _53)) ((B (B (_256 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_256 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_258 _557)) _54)) ((A :56 ((B (_256 _50)) (B (P _1278)))) ((A :57 ((B (_256 _50)) (BK (P _1278)))) ((A :58 ((_256 _50) ((S P) I))) ((A :59 ((B (_256 _50)) ((C (S' P)) I))) ((A :60 ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))) ((B (B (B (B (B (B (B (B (B (B (B C))))))))))) ((B (B (B (B (B (B (B (B (B (B C)))))))))) ((B (B (B (B (B (B (B (B (B C))))))))) ((B (B (B (B (B (B (B (B C)))))))) ((B (B (B (B (B (B (B C))))))) ((B (B (B (B (B (B C)))))) ((B (B (B (B (B C))))) ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P))))))))))))))))))))) ((A :61 (T (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :62 (T (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :63 (T (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :64 (T (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :65 (T (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :66 (T (K (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :67 (T (K (K (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK
\ No newline at end of file
+1538
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _271) ((B _12) _1)) _454))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _453))) ((A :10 (((S' P) _2) (((C' _13) _1) _1279))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _268) _12) _259))) ((A :20 (((S' B) _14) (((C' _271) _12) _260))) ((A :21 _1365) ((A :22 ((B _1406) _21)) ((A :23 (((S' _1406) _21) I)) ((A :24 _1335) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1364) ((C _258) _26))) ((A :28 (((C' _27) ((_267 _1376) _170)) ((_258 (_34 _1378)) _169))) ((A :29 ((B ((S _1406) (_34 _1378))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _453)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _454)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1279)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1279))) ((A :46 ((C _43) _259)) ((A :47 ((B _261) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _261) _48)) ((A :50 T) ((A :51 ((_266 ((B (B (_256 _50))) ((B ((C' C) _54)) (B P)))) (_270 _51))) ((A :52 (((((_11 _51) ((B (_256 _50)) P)) (_38 _53)) ((B (B (_256 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_256 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_258 _557)) _54)) ((A :56 ((B (_256 _50)) (B (P _1279)))) ((A :57 ((B (_256 _50)) (BK (P _1279)))) ((A :58 ((_256 _50) ((S P) I))) ((A :59 ((B (_256 _50)) ((C (S' P)) I))) ((A :60 ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B (B C))))))))))))) ((B (B (B (B (B (B (B (B (B (B (B (B C)))))))))))) ((B (B (B (B (B (B (B (B (B (B (B C))))))))))) ((B (B (B (B (B (B (B (B (B (B C)))))))))) ((B (B (B (B (B (B (B (B (B C))))))))) ((B (B (B (B (B (B (B (B C)))))))) ((B (B (B (B (B (B (B C))))))) ((B (B (B (B (B (B C)))))) ((B (B (B (B (B C))))) ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P))))))))))))))))))))) ((A :61 (T (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :62 (T (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :63 (T (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :64 (T (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :65 (T (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :66 (T (K (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK (BK K)))))))))))))))))))))) ((A :67 (T (K (K (K (K (K (K (BK (BK (BK (BK (BK (BK (BK (BK
\ No newline at end of file
--- a/lib/Data/Complex.hs
+++ b/lib/Data/Complex.hs
@@ -3,7 +3,7 @@
infix 6 :+
-data Complex a = a :+ a -- XXX should be strict
+data Complex a = !a :+ !a
instance forall a . Eq a => Eq (Complex a) where
(:+) x y == (:+) x' y' = x == x' && y == y' -- parser bug
--- a/lib/Data/Ratio_Type.hs
+++ b/lib/Data/Ratio_Type.hs
@@ -2,7 +2,7 @@
import Primitives
import Data.Integer_Type
-data Ratio a = (:%) a a -- XXX should be strict
+data Ratio a = !a :% !a
type Rational = Ratio Integer
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -40,9 +40,12 @@
fs = [f i | (i, _) <- zip [0::Int ..] cs]
dsConstr i (Constr c ets) =
let
- ts = either id (map snd) ets
- xs = [mkIdent ("$x" ++ show j) | (j, _) <- zip [0::Int ..] ts]- in (qualIdent mn c, lams xs $ lams fs $ apps (Var (f i)) (map Var xs))
+ ss = map fst $ either id (map snd) ets -- strict flags
+ xs = [mkIdent ("$x" ++ show j) | (j, _) <- zip [0::Int ..] ss]+ strict (False:ys) (_:is) e = strict ys is e
+ strict (True:ys) (x:is) e = App (App (Lit (LPrim "seq")) (Var x)) (strict ys is e)
+ strict _ _ e = e
+ in (qualIdent mn c, lams xs $ strict ss xs $ lams fs $ apps (Var (f i)) (map Var xs))
in zipWith dsConstr [0::Int ..] cs
Newtype _ (Constr c _) -> [ (qualIdent mn c, Lit (LPrim "I")) ]
Type _ _ -> []
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -21,7 +21,7 @@
EKind, kType, kConstraint,
IdKind(..), idKindIdent,
LHS,
- Constr(..), ConstrField,
+ Constr(..), ConstrField, SType,
ConTyInfo,
Con(..), conIdent, conArity,
tupleConstr, getTupleConstr,
@@ -201,10 +201,11 @@
type LHS = (Ident, [IdKind])
-data Constr = Constr Ident (Either [EType] [ConstrField])
+data Constr = Constr Ident (Either [SType] [ConstrField])
--Xderiving(Show)
-type ConstrField = (Ident, EType) -- record label and type
+type ConstrField = (Ident, SType) -- record label and type
+type SType = (Bool, EType) -- the Bool indicates strict
-- Expr restricted to
-- * after desugaring: EApp and EVar
@@ -504,9 +505,13 @@
ppEqns name sepr = vcat . map (\ (Eqn ps alts) -> sep [name <+> hsep (map ppEPat ps), ppAlts sepr alts])
ppConstr :: Constr -> Doc
-ppConstr (Constr c (Left ts)) = hsep (ppIdent c : map ppEType ts)
+ppConstr (Constr c (Left ts)) = hsep (ppIdent c : map ppSType ts)
ppConstr (Constr c (Right fs)) = ppIdent c <> braces (hsep $ map f fs)
- where f (i, t) = ppIdent i <+> text "::" <+> ppEType t <> text ","
+ where f (i, t) = ppIdent i <+> text "::" <+> ppSType t <> text ","
+
+ppSType :: SType -> Doc
+ppSType (False, t) = ppEType t
+ppSType (True, t) = text "!" <> ppEType t
ppLHS :: LHS -> Doc
ppLHS (f, vs) = hsep (ppIdent f : map ppIdKind vs)
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -270,8 +270,8 @@
pContext = (pCtx <* pSymbol "=>") <|< pure []
pCtx = pParens (emany pType) <|< ((:[]) <$> pTypeApp)
- pFields = Left <$> emany pAType <|<
- Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pType) (pSpec ',') <* pSpec '}')+ pFields = Left <$> emany pSAType <|<
+ Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pSType) (pSpec ',') <* pSpec '}')pField = do
fs <- pFields
guard $ either length length fs == 1
@@ -280,7 +280,10 @@
pFunDep = (,) <$> esome pLIdent <*> (pSymbol "->" *> esome pLIdent)
pConstr :: P Constr
pConstr = (Constr <$> pUIdentSym <*> pFields)
- <|< ((\ t1 c t2 -> Constr c (Left [t1, t2])) <$> pAType <*> pUSymOper <*> pAType)
+ <|< ((\ t1 c t2 -> Constr c (Left [t1, t2])) <$> pSAType <*> pUSymOper <*> pSAType)
+ pSAType = (,) <$> pStrict <*> pAType
+ pSType = (,) <$> pStrict <*> pType
+ pStrict = (True <$ pSymbol "!") <|< pure False
pLHS :: P LHS
pLHS = (,) <$> pTypeIdentSym <*> emany pIdKind
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1031,8 +1031,8 @@
tcConstr :: Constr -> T Constr
tcConstr (Constr c ets) =
- Constr c <$> either (\ x -> Left <$> mapM (\ t -> tcTypeT (Check kType) t) x)
- (\ x -> Right <$> mapM (\ (i,t) -> (i,) <$> tcTypeT (Check kType) t) x) ets
+ Constr c <$> either (\ x -> Left <$> mapM (\ (s,t) -> (s,) <$> tcTypeT (Check kType) t) x)
+ (\ x -> Right <$> mapM (\ (i,(s,t)) -> ((i,) . (s,)) <$> tcTypeT (Check kType) t) x) ets
-- Expand a class defintion to
@@ -1178,11 +1178,11 @@
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
addCon (Constr c ets) = do
let ts = either id (map snd) ets
- extValETop c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
+ extValETop c (EForall vks $ foldr (tArrow . snd) tret ts) (ECon $ ConData cti (qualIdent mn c))
mapM_ addCon cs
Newtype (i, vks) (Constr c fs) -> do
let
- t = head $ either id (map snd) fs
+ t = snd $ head $ either id (map snd) fs
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
extValETop c (EForall vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
ForImp _ i t -> extValQTop i t
--
⑨