shithub: MicroHs

--- a/src/MicroHs/Desugar.hs

+++ b/src/MicroHs/Desugar.hs

@@ -36,8 +36,9 @@

let

         f i = mkIdent ("$f" ++ showInt i)

         fs = [f i | (i, _) <- zip (enumFrom 0) cs]

-        dsConstr i (Constr c ts) =

+        dsConstr i (Constr c ets) =

let

+            ts = either id (map snd) ets

             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))

       in  zipWith dsConstr (enumFrom 0) cs

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

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

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

   EKind, kType,

   IdKind(..), idKindIdent,

   LHS,

-  Constr(..),

+  Constr(..), ConstrField,

   ConTyInfo,

   Con(..), conIdent, conArity, eqCon, getSLocCon,

   tupleConstr, untupleConstr, isTupleConstr,

@@ -183,9 +183,11 @@

 type LHS = (Ident, [IdKind])

-data Constr = Constr Ident [EType]

+data Constr = Constr Ident (Either [EType] [ConstrField])

   --Xderiving(Show, Eq)

+type ConstrField = (Ident, EType)              -- record label and type

 -- Expr restricted to

 --  * after desugaring: EApp and EVar

 --  * before desugaring: EApp, EVar, ETuple, EList

@@ -373,7 +375,9 @@

       where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""

 showConstr :: Constr -> String

-showConstr (Constr i ts) = unwords (showIdent i : map showEType ts)

+showConstr (Constr c (Left  ts)) = unwords (showIdent c : map showEType ts)

+showConstr (Constr c (Right fs)) = unwords (showIdent c : "{" : map f fs ++ ["}"])

+  where f (i, t) = showIdent i ++ " :: " ++ showEType t ++ ","

 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 (Constr <$> pUIdentSym <*> emany pAType) (pSymbol "|"))

+      Data        <$> (pKeyword "data"    *> pLHS) <*> ((pSymbol "=" *> esepBy1 (Constr <$> pUIdentSym <*> pFields) (pSymbol "|"))

                                                         <|< P.pure [])

   <|< Newtype     <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> pUIdent) <*> pAType

   <|< Type        <$> (pKeyword "type"    *> pLHS) <*> (pSymbol "=" *> pType)

@@ -261,6 +261,8 @@

     dig (TInt _ i) | -1 <= i && i <= 9 = Just i

     dig _ = Nothing

     pPrec = satisfyM "digit" dig

+    pFields = Left  <$> emany pAType <|<

+              Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pType) (pSpec ',') <* pSpec '}')

 pLHS :: P LHS

 pLHS = (,) <$> pUIdentSym <*> emany pIdKind

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

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

@@ -165,13 +165,14 @@

 mkTModule :: forall a . IdentModule -> [EDef] -> a -> TModule a

 mkTModule mn tds a =

let

-    con ci it vks (Constr ic ts) =

+    con ci it vks (Constr ic ets) =

let

         e = ECon $ ConData ci (qualIdent mn ic)

+        ts = either id (map snd) ets

       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) | Constr c ts <- cs ]

+        ci = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]

       in map (con ci i vks) cs

     conn it vks ic t =

let

@@ -767,7 +768,9 @@

       withExtVal i k $ withVars iks ta

 tcConstr :: Constr -> T Constr

-tcConstr (Constr i ts) = Constr i <$> T.mapM (\ t -> tcTypeT (Check kType) t) ts

+tcConstr (Constr c ets) =

+  Constr c <$> either (\ x -> Left  T.<$> T.mapM (\ t     ->          tcTypeT (Check kType) t) x)

+                      (\ x -> Right T.<$> T.mapM (\ (i,t) -> (i,) <$> tcTypeT (Check kType) t) x) ets

 tcDefsValue :: [EDef] -> T [EDef]

 tcDefsValue ds = T.do

@@ -783,9 +786,10 @@

       extVal (qualIdent mn i) t

     Data (i, vks) cs -> T.do

let

-        cti = [ (qualIdent mn c, length ts) | Constr c ts <- cs ]

+        cti = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]

         tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)

-        addCon (Constr c ts) =

+        addCon (Constr c ets) = T.do

+          let ts = either id (map snd) ets

           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

--

⑨