shithub: MicroHs

Download patch

ref: 8d68f0d22ab39f1c2a18668d17595a06c4f75fd5
parent: 5864f798e032b791e451cb9f7e0bcc6b5fed9be5
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sun Oct 8 20:01:54 EDT 2023 

Make Constr a data type.


--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
 v3.5
-967
-(($A :0 _851) (($A :1 (($B _897) _0)) (($A :2 ((($S' _897) _0) $I)) (($A :3 _821) (($A :4 (_3 "undefined")) (($A :5 $I) (($A :6 ((($C' $B) _850) (($C _74) _5))) (($A :7 ((($C' _6) (_868 _71)) ((_74 _866) _70))) (($A :8 (($B (($S _897) _866)) _3)) (($A :9 $T) (($A :10 ($T $I)) (($A :11 (($B (_74 _188)) _10)) (($A :12 (($B ($B (_73 _9))) ((($C' $B) (($B $C) _10)) ($B _10)))) (($A :13 (($B ($B (_73 _9))) ((($C' $B) (($B $C) _10)) ($BK _10)))) (($A :14 (($B (_73 _9)) $P)) (($A :15 (($B ($B (_73 _9))) (($B (($C' $C) _10)) ($B $P)))) (($A :16 _15) (($A :17 (($B (_73 _9)) ($B ($P _779)))) (($A :18 (($B (_73 _9)) ($BK ($P _779)))) (($A :19 ((_73 _9) (($S $P) $I))) (($A :20 (($B (_73 _9)) (($C ($S' $P)) $I))) (($A :21 (($B $Y) (($B ($B ($P (_14 _114)))) ((($C' $B) (($B ($C' $B)) ($B _12))) ((($C' ($C' $B)) ($B _12)) (($B ($B _14)) _115)))))) (($A :22 (($B $Y) (($B ($B ($P (_14 _779)))) (($B ($C' $B)) ($B _13))))) (($A :23 _3) (($A :24 ($T (_14 _779))) (($A :25 (_21 _75)) (($A :26 (($C $C) _33)) (($A :27 ($T _32)) (($A :28 (($P _33) _32)) (($A :29 _33) (($A :30 (($C (($C $S') _28)) $I)) (($A :31 (($C $S) _28)) (($A :32 $K) (($A :33 $A) (($A :34 _826) (($A :35 _827) (($A :36 ((($S' _27) (_818 97)) (($C _818) 122))) (($A :37 ((($S' _27) (_818 65)) (($C _818) 90))) (($A :38 ((($S' _26) _36) _37)) (($A :39 ((($S' _27) (_818 48)) (($C _818) 57))) (($A :40 ((($S' _27) (_818 32)) (($C _818) 126))) (($A :41 _815) (($A :42 _816) (($A :43 _818) (($A :44 _817) (($A :45 ((($S' _26) (($C _41) 32)) ((($S' _26) (($C _41) 9)) (($C _41) 10)))) (($A :46 (($S (($S ((($S' _27) (_43 65)) (($C _43) 90))) (_33 (((_778 "lib/Data/Char.hs") 3) 8)))) (($B _34) ((($C' _81) ((($C' _82) _35) (_35 65))) (_35 97))))) (($A :47 (($S (($S ((($S' _27) (_43 97)) (($C _43) 97))) (_33 (((_778 "lib/Data/Char.hs") 3) 8)))) (($B _34) ((($C' _81) ((($C' _82) _35) (_35 97))) (_35 65))))) (($A :48 _786) (($A :49 _787) (($A :50 _788) (($A :51 _789) (($A :52 (_49 %0.0)) (($A :53 _48) (($A :54 _49) (($A :55 _50) (($A :56 _51) (($A :57 _790) (($A :58 _791) (($A :59 _57) (($A :60 _58) (($A :61 _792) (($A :62 _793) (($A :63 _794) (($A :64 _795) (($A :65 _61) (($A :66 _62) (($A :67 _63) (($A :68 _64) (($A :69 _796) (($A :70 (($B $BK) $T)) (($A :71 ($BK $T)) (($A :72 $P) (($A :73 $I) (($A :74 $B) (($A :75 $I) (($A :76 $K) (($A :77 $C) (($A :78 _822) (($A :79 (($C (($C $S') _188)) _189)) (($A :80 ((($C' ($S' ($C' $B))) $B) $I)) (($A :81 _780) (($A :82 _781) (($A :83 _782) (($A :84 _783) (($A :85 _784) (($A :86 _785) (($A :87 (_82 0)) (($A :88 _803) (($A :89 _804) (($A :90 _805) (($A :91 _806) (($A :92 _807) (($A :93 _808) (($A :94 _88) (($A :95 ($BK $K)) (($A :96 (($B $BK) (($B ($B $BK)) $P))) (($A :97 (($B ($B ($B $BK))) (($B ($B ($B $BK))) (($B ($B ($B $C))) (($B ($B $C)) $P))))) (($A :98 ((($S' $S) ((($S' ($S' $C)) ((($C' ($C' $S)) ((($C' $B) (($B ($S' $S')) ((($C' $B) (($B _26) (_91 0))) (_88 0)))) (($B ($B (($C' $P) (_86 1)))) _81))) ($C $P))) _84)) _85)) (($A :99 _95) (($A :100 ((($S' $C) (($B ($P _176)) ((($C' ($C' $B)) ((($C' $C) _88) _176)) _177))) (($B (($C' ($C' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) (($B (($C' ($C' ($C' $C))) (($B ($B ($B (($S' $S') (_88 0))))) (($B (($C' ($C' $C)) (($B ($B (($S' $S') (_88 1)))) (($B (($C' $C) (($B (($C' $S') (_88 2))) ($C _100)))) ($C _100))))) ($C _100))))) ($C _100)))) ($T $K))) ($T $A)))) (($C _98) 4)))) (($A :101 (_107 _76)) (($A :102 ((_122 (_79 _101)) _99)) (($A :103 (($C ((($C' $B) (($P _114) ((($C' ($C' $O)) $P) $K))) ((($S' ($C' ($C' ($C' $B)))) (($B ($B ($B ($B _104)))) ((($S' ($C' ($C' $B))) (($B ($B ($B _104))) ((($S' ($C' $B)) (($B ($B _104)) ((($C' $B) (($B _120) ($T 0))) _103))) ((($C' $B) (($B _120) ($T 1))) _103)))) ((($C' $B) (($B _120) ($T 2))) _103)))) ((($C' $B) (($B _120) ($T 3))) _103)))) (($B $T) (($B ($B $P)) (($C' _81) (_83 4)))))) (($A :104 (($S $S) (($B $BK) (($B $BK) ((($S' $S) $T) (($B $BK) (($B $BK) (($C ((($S' $C') $S) (($B ($B ($B ($S $B)))) (($B ($B ($B ($B ($B $BK))))) (($B (($S' ($C' $B)) (($B $B') $B'))) (($B ($B ($B ($B ($B ($S $B)))))) (($B ($B ($B (
\ No newline at end of file
+968
+(($A :0 _852) (($A :1 (($B _898) _0)) (($A :2 ((($S' _898) _0) $I)) (($A :3 _822) (($A :4 (_3 "undefined")) (($A :5 $I) (($A :6 ((($C' $B) _851) (($C _74) _5))) (($A :7 ((($C' _6) (_869 _71)) ((_74 _867) _70))) (($A :8 (($B (($S _898) _867)) _3)) (($A :9 $T) (($A :10 ($T $I)) (($A :11 (($B (_74 _188)) _10)) (($A :12 (($B ($B (_73 _9))) ((($C' $B) (($B $C) _10)) ($B _10)))) (($A :13 (($B ($B (_73 _9))) ((($C' $B) (($B $C) _10)) ($BK _10)))) (($A :14 (($B (_73 _9)) $P)) (($A :15 (($B ($B (_73 _9))) (($B (($C' $C) _10)) ($B $P)))) (($A :16 _15) (($A :17 (($B (_73 _9)) ($B ($P _780)))) (($A :18 (($B (_73 _9)) ($BK ($P _780)))) (($A :19 ((_73 _9) (($S $P) $I))) (($A :20 (($B (_73 _9)) (($C ($S' $P)) $I))) (($A :21 (($B $Y) (($B ($B ($P (_14 _114)))) ((($C' $B) (($B ($C' $B)) ($B _12))) ((($C' ($C' $B)) ($B _12)) (($B ($B _14)) _115)))))) (($A :22 (($B $Y) (($B ($B ($P (_14 _780)))) (($B ($C' $B)) ($B _13))))) (($A :23 _3) (($A :24 ($T (_14 _780))) (($A :25 (_21 _75)) (($A :26 (($C $C) _33)) (($A :27 ($T _32)) (($A :28 (($P _33) _32)) (($A :29 _33) (($A :30 (($C (($C $S') _28)) $I)) (($A :31 (($C $S) _28)) (($A :32 $K) (($A :33 $A) (($A :34 _827) (($A :35 _828) (($A :36 ((($S' _27) (_819 97)) (($C _819) 122))) (($A :37 ((($S' _27) (_819 65)) (($C _819) 90))) (($A :38 ((($S' _26) _36) _37)) (($A :39 ((($S' _27) (_819 48)) (($C _819) 57))) (($A :40 ((($S' _27) (_819 32)) (($C _819) 126))) (($A :41 _816) (($A :42 _817) (($A :43 _819) (($A :44 _818) (($A :45 ((($S' _26) (($C _41) 32)) ((($S' _26) (($C _41) 9)) (($C _41) 10)))) (($A :46 (($S (($S ((($S' _27) (_43 65)) (($C _43) 90))) (_33 (((_779 "lib/Data/Char.hs") 3) 8)))) (($B _34) ((($C' _81) ((($C' _82) _35) (_35 65))) (_35 97))))) (($A :47 (($S (($S ((($S' _27) (_43 97)) (($C _43) 97))) (_33 (((_779 "lib/Data/Char.hs") 3) 8)))) (($B _34) ((($C' _81) ((($C' _82) _35) (_35 97))) (_35 65))))) (($A :48 _787) (($A :49 _788) (($A :50 _789) (($A :51 _790) (($A :52 (_49 %0.0)) (($A :53 _48) (($A :54 _49) (($A :55 _50) (($A :56 _51) (($A :57 _791) (($A :58 _792) (($A :59 _57) (($A :60 _58) (($A :61 _793) (($A :62 _794) (($A :63 _795) (($A :64 _796) (($A :65 _61) (($A :66 _62) (($A :67 _63) (($A :68 _64) (($A :69 _797) (($A :70 (($B $BK) $T)) (($A :71 ($BK $T)) (($A :72 $P) (($A :73 $I) (($A :74 $B) (($A :75 $I) (($A :76 $K) (($A :77 $C) (($A :78 _823) (($A :79 (($C (($C $S') _188)) _189)) (($A :80 ((($C' ($S' ($C' $B))) $B) $I)) (($A :81 _781) (($A :82 _782) (($A :83 _783) (($A :84 _784) (($A :85 _785) (($A :86 _786) (($A :87 (_82 0)) (($A :88 _804) (($A :89 _805) (($A :90 _806) (($A :91 _807) (($A :92 _808) (($A :93 _809) (($A :94 _88) (($A :95 ($BK $K)) (($A :96 (($B $BK) (($B ($B $BK)) $P))) (($A :97 (($B ($B ($B $BK))) (($B ($B ($B $BK))) (($B ($B ($B $C))) (($B ($B $C)) $P))))) (($A :98 ((($S' $S) ((($S' ($S' $C)) ((($C' ($C' $S)) ((($C' $B) (($B ($S' $S')) ((($C' $B) (($B _26) (_91 0))) (_88 0)))) (($B ($B (($C' $P) (_86 1)))) _81))) ($C $P))) _84)) _85)) (($A :99 _95) (($A :100 ((($S' $C) (($B ($P _176)) ((($C' ($C' $B)) ((($C' $C) _88) _176)) _177))) (($B (($C' ($C' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) (($B (($C' ($C' ($C' $C))) (($B ($B ($B (($S' $S') (_88 0))))) (($B (($C' ($C' $C)) (($B ($B (($S' $S') (_88 1)))) (($B (($C' $C) (($B (($C' $S') (_88 2))) ($C _100)))) ($C _100))))) ($C _100))))) ($C _100)))) ($T $K))) ($T $A)))) (($C _98) 4)))) (($A :101 (_107 _76)) (($A :102 ((_122 (_79 _101)) _99)) (($A :103 (($C ((($C' $B) (($P _114) ((($C' ($C' $O)) $P) $K))) ((($S' ($C' ($C' ($C' $B)))) (($B ($B ($B ($B _104)))) ((($S' ($C' ($C' $B))) (($B ($B ($B _104))) ((($S' ($C' $B)) (($B ($B _104)) ((($C' $B) (($B _120) ($T 0))) _103))) ((($C' $B) (($B _120) ($T 1))) _103)))) ((($C' $B) (($B _120) ($T 2))) _103)))) ((($C' $B) (($B _120) ($T 3))) _103)))) (($B $T) (($B ($B $P)) (($C' _81) (_83 4)))))) (($A :104 (($S $S) (($B $BK) (($B $BK) ((($S' $S) $T) (($B $BK) (($B $BK) (($C ((($S' $C') $S) (($B ($B ($B ($S $B)))) (($B ($B ($B ($B ($B $BK))))) (($B (($S' ($C' $B)) (($B $B') $B'))) (($B ($B ($B ($B ($B ($S $B)))))) (($B ($B ($B (
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -36,7 +36,7 @@
       let
         f i = mkIdent ("$f" ++ showInt i)
         fs = [f i | (i, _) <- zip (enumFrom 0) cs]
-        dsConstr i (c, ts) =
+        dsConstr i (Constr c ts) =
           let
             xs = [mkIdent ("$x" ++ showInt j) | (j, _) <- zip (enumFrom 0) ts]
           in (qualIdent mn c, lams xs $ lams fs $ apps (Var (f i)) (map Var xs))
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -20,7 +20,7 @@
   EKind, kType,
   IdKind(..), idKindIdent,
   LHS,
-  Constr,
+  Constr(..),
   ConTyInfo,
   Con(..), conIdent, conArity, eqCon, getSLocCon,
   tupleConstr, untupleConstr, isTupleConstr,
@@ -182,8 +182,10 @@
 patVars = filter (not . isConIdent) . allVarsExpr
 
 type LHS = (Ident, [IdKind])
-type Constr = (Ident, [EType])
 
+data Constr = Constr Ident [EType]
+  --Xderiving(Show, Eq)
+
 -- Expr restricted to
 --  * after desugaring: EApp and EVar
 --  * before desugaring: EApp, EVar, ETuple, EList
@@ -374,7 +376,7 @@
       where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
 
 showConstr :: Constr -> String
-showConstr (i, ts) = unwords (showIdent i : map showEType ts)
+showConstr (Constr i ts) = unwords (showIdent i : map showEType ts)
 
 showLHS :: LHS -> String
 showLHS lhs =
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -247,7 +247,7 @@
 
 pDef :: P EDef
 pDef =
-      Data        <$> (pKeyword "data"    *> pLHS) <*> ((pSymbol "=" *> esepBy1 ((,) <$> pUIdentSym <*> emany pAType) (pSymbol "|"))
+      Data        <$> (pKeyword "data"    *> pLHS) <*> ((pSymbol "=" *> esepBy1 (Constr <$> pUIdentSym <*> emany pAType) (pSymbol "|"))
                                                         <|< P.pure [])
   <|< Newtype     <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> pUIdent) <*> pAType
   <|< Type        <$> (pKeyword "type"    *> pLHS) <*> (pSymbol "=" *> pType)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -165,13 +165,13 @@
 mkTModule :: forall a . IdentModule -> [EDef] -> a -> TModule a
 mkTModule mn tds a =
   let
-    con ci it vks (ic, ts) =
+    con ci it vks (Constr ic ts) =
       let
         e = ECon $ ConData ci (qualIdent mn ic)
       in ValueExport ic $ Entry e (EForall vks (foldr tArrow (tApps (qualIdent mn it) (map tVarK vks)) ts))
     cons i vks cs =
       let
-        ci = [ (qualIdent mn c, length ts) | (c, ts) <- cs ]
+        ci = [ (qualIdent mn c, length ts) | Constr c ts <- cs ]
       in map (con ci i vks) cs
     conn it vks ic t =
       let
@@ -734,7 +734,7 @@
       withExtVal i k $ withVars iks ta
 
 tcConstr :: Constr -> T Constr
-tcConstr (i, ts) = (i,) <$> T.mapM (\ t -> tcTypeT (Check kType) t) ts
+tcConstr (Constr i ts) = Constr i <$> T.mapM (\ t -> tcTypeT (Check kType) t) ts
 
 tcDefsValue :: [EDef] -> T [EDef]
 tcDefsValue ds = T.do
@@ -750,9 +750,9 @@
       extVal (qualIdent mn i) t
     Data (i, vks) cs -> T.do
       let
-        cti = [ (qualIdent mn c, length ts) | (c, ts) <- cs ]
+        cti = [ (qualIdent mn c, length ts) | Constr c ts <- cs ]
         tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
-        addCon (c, ts) =
+        addCon (Constr c ts) =
           extValE c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
       T.mapM_ addCon cs
     Newtype (i, vks) c t -> T.do
-- 
⑨