shithub: MicroHs

--- a/src/MicroHs/Deriving.hs

+++ b/src/MicroHs/Deriving.hs

@@ -39,13 +39,13 @@

                                    (ELit loc (LStr (unIdent fld)))

                                    (eApps (EVar qtycon) (map (EVar . idKindIdent) iks))

                                    fldty

-      conEqnGet (Constr _ _ c (Left ts))   = eEqn [eApps (EVar c) (map (const dummy) ts)] $ undef

+      conEqnGet (Constr _ _ c (Left ts))   = eEqn [eApps (EVar c) (map (const eDummy) ts)] $ undef

       conEqnGet (Constr _ _ c (Right fts)) = eEqn [conApp] $ if fld `elem` fs then rhs else undef

         where fs = map fst fts

               conApp = eApps (EVar c) (map EVar fs)

               rhs = eFld

-      conEqnSet (Constr _ _ c (Left ts))   = eEqn [dummy, eApps (EVar c) (map (const dummy) ts)] $ undef

-      conEqnSet (Constr _ _ c (Right fts)) = eEqn [dummy, conApp] $ if fld `elem` fs then rhs else undef

+      conEqnSet (Constr _ _ c (Left ts))   = eEqn [eDummy, eApps (EVar c) (map (const eDummy) ts)] $ undef

+      conEqnSet (Constr _ _ c (Right fts)) = eEqn [eDummy, conApp] $ if fld `elem` fs then rhs else undef

         where fs = map fst fts

               conApp = eApps (EVar c) (map EVar fs)

               rhs = eLam [eFld] conApp

@@ -53,7 +53,7 @@

   pure [ Sign [getName] $ eForall iks $ lhsToType (qtycon, iks) `tArrow` fldty

        , Fcn getName $ map conEqnGet cs

-       , Instance hdrGet [BFcn igetField [eEqn [dummy] $ EVar getName] ]

+       , Instance hdrGet [BFcn igetField [eEqn [eDummy] $ EVar getName] ]

        , Instance hdrSet [BFcn isetField $ map conEqnSet cs]

@@ -80,9 +80,6 @@

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

-dummy :: Expr

-dummy = EVar dummyIdent

 eApp2 :: Expr -> Expr -> Expr -> Expr

 eApp2 a b c = EApp (EApp a b) c

@@ -89,10 +86,6 @@

 eApp3 :: Expr -> Expr -> Expr -> Expr -> Expr

 eApp3 a b c d = EApp (eApp2 a b c) d

-eForall :: [IdKind] -> EType -> EType

-eForall [] t = t

-eForall vs t = EForall vs t

 -- MicroHs currently has no way of using the original name,

 -- so we just ignore the qualification part for now.

 mkQIdent :: SLoc -> String -> String -> Ident

@@ -142,7 +135,7 @@

     hdr = EApp etyp (EVar $ qualIdent mn i)

     mdl = ELit loc $ LStr $ unIdent mn

     nam = ELit loc $ LStr $ unIdent i

-    eqns = eEqns [dummy] $ eApp2 (EVar imkTyConApp) (eApp2 (EVar imkTyCon) mdl nam) (EVar (mkQIdent loc nameDataListType "[]"))

+    eqns = eEqns [eDummy] $ eApp2 (EVar imkTyConApp) (eApp2 (EVar imkTyCon) mdl nam) (EVar (mkQIdent loc nameDataListType "[]"))

     inst = Instance hdr [BFcn itypeRep eqns]

   return [inst]

@@ -185,7 +178,7 @@

         let (xp, xs) = mkPat c "x"

             (yp, ys) = mkPat c "y"

         in  eEqn [xp, yp] $ if null xs then eTrue else foldr1 eAnd $ zipWith eEq xs ys

-      eqns = map mkEqn cs ++ [eEqn [dummy, dummy] eFalse]

+      eqns = map mkEqn cs ++ [eEqn [eDummy, eDummy] eFalse]

       iEq = mkQIdent loc nameDataEq "=="

       eEq = EApp . EApp (EVar iEq)

       eAnd = EApp . EApp (EVar $ mkQIdent loc nameDataBool "&&")

@@ -215,8 +208,8 @@

         let (xp, xs) = mkPat c "x"

             (yp, ys) = mkPat c "y"

         in  [eEqn [xp, yp] $ if null xs then eEQ else foldr1 eComb $ zipWith eCompare xs ys

-            ,eEqn [xp, dummy] $ eLT

-            ,eEqn [dummy, yp] $ eGT]

+            ,eEqn [xp, eDummy] $ eLT

+            ,eEqn [eDummy, yp] $ eGT]

       eqns = concatMap mkEqn cs

       iCompare = mkQIdent loc nameDataOrd "compare"

       eCompare = EApp . EApp (EVar iCompare)

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

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

@@ -37,6 +37,8 @@

   Assoc(..), Fixity,

   getBindsVars,

   HasLoc(..),

+  eForall,

+  eDummy,

   impossible, impossibleShow,

   ) where

 import Prelude hiding ((<>))

@@ -51,6 +53,7 @@

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

 data EModule = EModule IdentModule [ExportItem] [EDef]

+--DEBUG  deriving (Show)

 data ExportItem

   = ExpModule IdentModule

@@ -57,7 +60,7 @@

   | ExpTypeCon Ident

   | ExpType Ident

   | ExpValue Ident

---  deriving (Show)

+--DEBUG  deriving (Show)

 data EDef

   = Data LHS [Constr] Deriving

@@ -72,16 +75,16 @@

   | Class [EConstraint] LHS [FunDep] [EBind]  -- XXX will probable need initial forall with FD

   | Instance EConstraint [EBind]  -- no deriving yet

   | Default [EType]

---  deriving (Show)

+--DEBUG  deriving (Show)

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

---  deriving (Show)

+--DEBUG  deriving (Show)

 data ImportItem

   = ImpTypeCon Ident

   | ImpType Ident

   | ImpValue Ident

---  deriving (Show)

+--DEBUG  deriving (Show)

 type Deriving = [EConstraint]

@@ -112,12 +115,13 @@

   -- Constructors after type checking

   | ECon Con

   | EForall [IdKind] Expr -- only in types

---  deriving (Show)

+--DEBUG  deriving (Show)

 data EField

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

   | EFieldPun [Ident]       -- a.b

   | EFieldWild              -- ..

+--DEBUG  deriving (Show)

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

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

@@ -139,7 +143,7 @@

 data Con

   = ConData ConTyInfo Ident [FieldName]

   | ConNew Ident [FieldName]

---  deriving(Show)

+--DEBUG  deriving(Show)

 data Listish

   = LList [Expr]

@@ -148,7 +152,7 @@

   | LFromTo Expr Expr

   | LFromThen Expr Expr

   | LFromThenTo Expr Expr Expr

---  deriving(Show)

+--DEBUG  deriving(Show)

 conIdent :: HasCallStack =>

             Con -> Ident

@@ -179,22 +183,23 @@

   | LPrim String

   | LForImp String

   | LTick String

---  deriving (Show)

+--DEBUG  deriving (Show)

   deriving (Eq)

 type ECaseArm = (EPat, EAlts)

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

---  deriving (Show)

+--DEBUG  deriving (Show)

 data EBind = BFcn Ident [Eqn] | BPat EPat Expr | BSign Ident EType

---  deriving (Show)

+--DEBUG  deriving (Show)

 -- A single equation for a function

 data Eqn = Eqn [EPat] EAlts

+--DEBUG  deriving (Show)

 data EAlts = EAlts [EAlt] [EBind]

---  deriving (Show)

+--DEBUG  deriving (Show)

 type EAlt = ([EStmt], Expr)

@@ -237,7 +242,7 @@

   [IdKind] [EConstraint]          -- existentials: forall vs . ctx =>

   Ident                           -- constructor name

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

---  deriving(Show)

+--DEBUG  deriving(Show)

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

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

@@ -250,7 +255,7 @@

 type EConstraint = EType

 data IdKind = IdKind Ident EKind

-  --deriving (Show, Eq)

+--DEBUG  deriving (Show)

 instance Show IdKind where

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

@@ -328,7 +333,7 @@

   getSLoc (EForall iks _) = getSLoc iks

 instance forall a . HasLoc a => HasLoc [a] where

-  getSLoc [] = error "getSLoc []"

+  getSLoc [] = noSLoc  -- XXX shouldn't happen

   getSLoc (a:_) = getSLoc a

 instance HasLoc IdKind where

@@ -370,17 +375,9 @@

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

 data Assoc = AssocLeft | AssocRight | AssocNone

---  deriving (Show)

+--DEBUG  deriving (Show)

   deriving (Eq)

-{-

-instance Eq Assoc where

-  AssocLeft  == AssocLeft  = True

-  AssocRight == AssocRight = True

-  AssocNone  == AssocNone  = True

-  _          == _          = False

--}

 type Fixity = (Assoc, Int)

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

@@ -748,6 +745,13 @@

 getBindsVars :: [EBind] -> [Ident]

 getBindsVars = concatMap getBindVars

+eForall :: [IdKind] -> EType -> EType

+eForall [] t = t

+eForall vs t = EForall vs t

+eDummy :: Expr

+eDummy = EVar dummyIdent

 impossible :: forall a .

               HasCallStack =>

--

⑨