shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Allow a field name in newtype

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

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

@@ -42,7 +42,7 @@

             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

-    Newtype _ c _ -> [ (qualIdent mn c, Lit (LPrim "I")) ]

+    Newtype _ (Constr c _) -> [ (qualIdent mn c, Lit (LPrim "I")) ]

     Type _ _ -> []

     Fcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]

     Sign _ _ -> []

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

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

@@ -55,7 +55,7 @@

 data EDef

   = Data LHS [Constr]

-  | Newtype LHS Ident EType

+  | Newtype LHS Constr

   | Type LHS EType

   | Fcn Ident [Eqn]

   | Sign Ident EType

@@ -362,7 +362,7 @@

 showEDef def =

   case def of

     Data lhs cs -> "data " ++ showLHS lhs ++ " = " ++ intercalate " | " (map showConstr cs)

-    Newtype lhs c t -> "newtype " ++ showLHS lhs ++ " = " ++ showIdent c ++ " " ++ showEType t

+    Newtype lhs c -> "newtype " ++ showLHS lhs ++ " = " ++ showConstr c

     Type lhs t -> "type " ++ showLHS lhs ++ " = " ++ showEType t

     Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> showIdent i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)

     Sign i t -> showIdent i ++ " :: " ++ showEType t

--- a/src/MicroHs/Parse.hs

+++ b/src/MicroHs/Parse.hs

@@ -249,7 +249,7 @@

 pDef =

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

                                                         <|< P.pure [])

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

+  <|< Newtype     <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> (Constr <$> pUIdentSym <*> pField))

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

   <|< uncurry Fcn <$> pEqns

   <|< Sign        <$> (pLIdentSym <* pSymbol "::") <*> pType

@@ -263,6 +263,10 @@

     pPrec = satisfyM "digit" dig

     pFields = Left  <$> emany pAType <|<

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

+    pField = P.do

+      fs <- pFields

+      guard $ either length length fs == 1

+      P.pure fs

 pLHS :: P LHS

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

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

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

@@ -195,9 +195,9 @@

     -- All top level types possible to export.

     tes =

-      [ TypeExport i (tentry i) (assoc i) | Data    (i, _) _   <- tds ] ++

-      [ TypeExport i (tentry i) (assoc i) | Newtype (i, _) _ _ <- tds ] ++

-      [ TypeExport i (tentry i) []        | Type    (i, _) _   <- tds ]

+      [ TypeExport i (tentry i) (assoc i) | Data    (i, _) _ <- tds ] ++

+      [ TypeExport i (tentry i) (assoc i) | Newtype (i, _) _ <- tds ] ++

+      [ TypeExport i (tentry i) []        | Type    (i, _) _ <- tds ]

     -- All type synonym definitions.

     ses = [ (qualIdent mn i, EForall vs t) | Type (i, vs) t  <- tds ]

@@ -734,7 +734,7 @@

   tcReset

   case adef of

     Data    (i, vks) cs  -> withVks vks kType $ \ vvks _  -> T.return $ Data    (i, vvks) cs

-    Newtype (i, vks) c t -> withVks vks kType $ \ vvks _  -> T.return $ Newtype (i, vvks) c t

+    Newtype (i, vks) c   -> withVks vks kType $ \ vvks _  -> T.return $ Newtype (i, vvks) c

     Type    (i, vks) at  ->

       case at of

         ESign t k        -> withVks vks k     $ \ vvks kr -> T.return $ Type    (i, vvks) (ESign t kr)

@@ -768,9 +768,9 @@

     Data    lhs@(i, _) cs   -> T.do

       addLHSKind lhs kType

       addAssoc i (nubBy eqIdent $ concatMap assocData cs)

-    Newtype lhs@(i, _) c _ -> T.do

+    Newtype lhs@(i, _) c -> T.do

       addLHSKind lhs kType

-      addAssoc i [c]

+      addAssoc i (assocData c)

     Type    lhs t   -> addLHSKind lhs (getTypeKind t)

     _               -> T.return ()

@@ -800,11 +800,11 @@

 tcDefType d = T.do

   tcReset

   case d of

-    Data    lhs cs   -> Data    lhs   <$> withVars (snd lhs) (T.mapM tcConstr cs)

-    Newtype lhs c  t -> Newtype lhs c <$> withVars (snd lhs) (tcTypeT (Check kType) t)

-    Type    lhs    t -> Type    lhs   <$> withVars (snd lhs) (tcInferTypeT t)

-    Sign    i      t -> (Sign    i  ) <$> tcTypeT (Check kType) t

-    ForImp  ie i   t -> (ForImp ie i) <$> tcTypeT (Check kType) t

+    Data    lhs cs -> Data    lhs   <$> withVars (snd lhs) (T.mapM tcConstr cs)

+    Newtype lhs c  -> Newtype lhs   <$> withVars (snd lhs) (tcConstr c)

+    Type    lhs  t -> Type    lhs   <$> withVars (snd lhs) (tcInferTypeT t)

+    Sign    i    t -> (Sign    i  ) <$> tcTypeT (Check kType) t

+    ForImp  ie i t -> (ForImp ie i) <$> tcTypeT (Check kType) t

     _ -> T.return d

 withVars :: forall a . [IdKind] -> T a -> T a

@@ -837,8 +837,9 @@

           let ts = either id (map snd) ets

           extValETop c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))

       T.mapM_ addCon cs

-    Newtype (i, vks) c t -> T.do

+    Newtype (i, vks) (Constr c fs) -> T.do

       let

+        t = 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

-- 

⑨