ref: 4c2cb9e52fa8690e2864e2b5da24c1295d53a32e
parent: 956624b4ea52a226fb82919b3ab4687628fc59b5
author: Lennart Augustsson <lennart@augustsson.net>
date: Wed Dec 27 10:58:44 EST 2023
Implement deriving Eq
--- a/src/MicroHs/Deriving.hs
+++ b/src/MicroHs/Deriving.hs
@@ -73,7 +73,7 @@
derivers :: [(String, Deriver)]
derivers =
[("Data.Typeable.Typeable", derTypeable)- ,("Data.Eq.Eq", derNotYet)+ ,("Data.Eq.Eq", derEq) ,("Data.Ord.Ord", derNotYet) ,("Text.Show.Show", derNotYet)]
@@ -90,6 +90,8 @@
traceM ("Warning: cannot derive " ++ show d ++ " yet, " ++ showSLoc (getSLoc d))return []
+--------------------------------------------
+
derTypeable :: Deriver
derTypeable (i, _) _ etyp = do
mn <- gets moduleName
@@ -103,4 +105,47 @@
nam = ELit loc $ LStr $ unIdent i
eqns = eEqns [dummy] $ eApp2 (EVar imkTyConApp) (eApp2 (EVar imkTyCon) mdl nam) (EVar (mkIdent "[]"))
inst = Instance hdr [BFcn itypeRep eqns]
+ return [inst]
+
+--------------------------------------------
+
+getConstrTyVars :: Constr -> [Ident]
+getConstrTyVars (Constr evs ctx _ flds) =
+ let vs = freeTyVars $ ctx ++ either (map snd) (map (snd . snd)) flds
+ in vs \\ map idKindIdent evs
+
+mkHdr :: LHS -> [Constr] -> EConstraint -> T EConstraint
+mkHdr (t, iks) cs cls = do
+ mn <- gets moduleName
+ let used = foldr (union . getConstrTyVars) [] cs -- Used type variables
+ iks' = filter ((`elem` used) . idKindIdent) iks
+ vs = map tVarK iks'
+ ty = tApps (qualIdent mn t) $ map tVarK iks
+ pure $ eForall iks $ addConstraints (map (tApp cls) vs) $ tApp cls ty
+
+mkPat :: Constr -> String -> (EPat, [Expr])
+mkPat (Constr _ _ c flds) s =
+ let n = either length length flds
+ loc = getSLoc c
+ vs = map (EVar . mkIdentSLoc loc . (s ++) . show) [1..n]
+ in (tApps c vs, vs)
+
+--------------------------------------------
+
+derEq :: Deriver
+derEq lhs cs eeq = do
+ hdr <- mkHdr lhs cs eeq
+ let loc = getSLoc eeq
+ mkEqn c =
+ 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]
+ iEq = mkIdentSLoc loc "=="
+ eEq = EApp . EApp (EVar iEq)
+ eAnd = EApp . EApp (EVar $ mkIdentSLoc loc "&&")
+ eTrue = EVar $ mkIdentSLoc loc "True"
+ eFalse = EVar $ mkIdentSLoc loc "False"
+ inst = Instance hdr [BFcn iEq eqns]
+-- traceM $ showEDefs [inst]
return [inst]
--- a/src/MicroHs/TCMonad.hs
+++ b/src/MicroHs/TCMonad.hs
@@ -321,3 +321,60 @@
getAppCon (EApp f _) = getAppCon f
getAppCon _ = error "getAppCon"
+-----------------------------------------------
+
+type TyVar = Ident
+
+freeTyVars :: [EType] -> [TyVar]
+-- Get the free TyVars from a type; no duplicates in result
+freeTyVars = foldr (go []) []
+ where
+ go :: [TyVar] -- Ignore occurrences of bound type variables
+ -> EType -- Type to look at
+ -> [TyVar] -- Accumulates result
+ -> [TyVar]
+ go bound (EVar tv) acc
+ | elem tv bound = acc
+ | elem tv acc = acc
+ | isConIdent tv = acc
+ | otherwise = tv : acc
+ go bound (EForall tvs ty) acc = go (map idKindIdent tvs ++ bound) ty acc
+ go bound (EApp fun arg) acc = go bound fun (go bound arg acc)
+ go _bound (EUVar _) acc = acc
+ go _ _ _ = undefined
+
+addConstraints :: [EConstraint] -> EType -> EType
+addConstraints [] t = t
+addConstraints cs t = tupleConstraints cs `tImplies` t
+
+tupleConstraints :: [EConstraint] -> EConstraint
+tupleConstraints [] = error "tupleConstraints"
+tupleConstraints [c] = c
+tupleConstraints cs = tApps (tupleConstr noSLoc (length cs)) cs
+
+-----------------------------------------------
+
+builtinLoc :: SLoc
+builtinLoc = SLoc "builtin" 0 0
+
+tConI :: SLoc -> String -> EType
+tConI loc = tCon . mkIdentSLoc loc
+
+tCon :: Ident -> EType
+tCon = EVar
+
+tVarK :: IdKind -> EType
+tVarK (IdKind i _) = EVar i
+
+tApp :: EType -> EType -> EType
+tApp = EApp
+
+tApps :: Ident -> [EType] -> EType
+tApps i ts = foldl tApp (tCon i) ts
+
+tArrow :: EType -> EType -> EType
+tArrow a r = tApp (tApp (tConI builtinLoc "Primitives.->") a) r
+
+tImplies :: EType -> EType -> EType
+tImplies a r = tApp (tApp (tConI builtinLoc "Primitives.=>") a) r
+
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -123,7 +123,6 @@
type Sigma = EType
--type Tau = EType
type Rho = EType
-type TyVar = Ident
typeCheck :: forall a . [(ImportSpec, TModule a)] -> EModule -> TModule [EDef]
typeCheck aimps (EModule mn exps defs) =
@@ -474,9 +473,6 @@
kTypeTypeConstraintS :: EType
kTypeTypeConstraintS = kArrow kType (kArrow kType kConstraint)
-builtinLoc :: SLoc
-builtinLoc = SLoc "builtin" 0 0
-
mkIdentB :: String -> Ident
mkIdentB = mkIdentSLoc builtinLoc
@@ -563,24 +559,6 @@
in (c, [Entry (ECon $ ConData [(c, n)] c []) $ EForall vks $ foldr tArrow r ts ])
in map tuple (enumFromTo 2 10)
-tCon :: Ident -> EType
-tCon = EVar
-
-tVarK :: IdKind -> EType
-tVarK (IdKind i _) = EVar i
-
-tApp :: EType -> EType -> EType
-tApp = EApp
-
-tApps :: Ident -> [EType] -> EType
-tApps i ts = foldl tApp (tCon i) ts
-
-tArrow :: EType -> EType -> EType
-tArrow a r = tApp (tApp (tConI builtinLoc "Primitives.->") a) r
-
-tImplies :: EType -> EType -> EType
-tImplies a r = tApp (tApp (tConI builtinLoc "Primitives.=>") a) r
-
kArrow :: EKind -> EKind -> EKind
kArrow = tArrow
@@ -1137,15 +1115,6 @@
usup []
-}
-addConstraints :: [EConstraint] -> EType -> EType
-addConstraints [] t = t
-addConstraints cs t = tupleConstraints cs `tImplies` t
-
-tupleConstraints :: [EConstraint] -> EConstraint
-tupleConstraints [] = error "tupleConstraints"
-tupleConstraints [c] = c
-tupleConstraints cs = tApps (tupleConstr noSLoc (length cs)) cs
-
splitInst :: EConstraint -> ([IdKind], [EConstraint], EConstraint)
splitInst (EForall iks t) =
case splitInst t of
@@ -2008,9 +1977,6 @@
ELit _ (LInteger _) -> at
_ -> impossible
-tConI :: SLoc -> String -> EType
-tConI loc = tCon . mkIdentSLoc loc
-
tListI :: SLoc -> Ident
tListI loc = mkIdentSLoc loc $ listPrefix ++ "[]"
@@ -2097,24 +2063,6 @@
newSkolemTyVar tv = do
uniq <- newUniq
return (mkIdentSLoc (getSLoc tv) (unIdent tv ++ "#" ++ show uniq))
-
-freeTyVars :: [EType] -> [TyVar]
--- Get the free TyVars from a type; no duplicates in result
-freeTyVars = foldr (go []) []
- where
- go :: [TyVar] -- Ignore occurrences of bound type variables
- -> EType -- Type to look at
- -> [TyVar] -- Accumulates result
- -> [TyVar]
- go bound (EVar tv) acc
- | elem tv bound = acc
- | elem tv acc = acc
- | isConIdent tv = acc
- | otherwise = tv : acc
- go bound (EForall tvs ty) acc = go (map idKindIdent tvs ++ bound) ty acc
- go bound (EApp fun arg) acc = go bound fun (go bound arg acc)
- go _bound (EUVar _) acc = acc
- go _ _ _ = undefined
metaTvs :: [EType] -> [TRef]
-- Get the MetaTvs from a type; no duplicates in result
--- /dev/null
+++ b/tests/Deriving.hs
@@ -1,0 +1,14 @@
+module Deriving(main) where
+import Prelude
+
+data T a b c = A a | B b | C a Int | D
+ deriving Eq
+
+main :: IO ()
+main = do
+ print $ A 'a' == (A 'a' :: T Char () ())
+ print $ A 'a' == (A 'b' :: T Char () ())
+ print $ A 'a' == B False
+ print $ C 'a' 1 == (C 'a' 1 :: T Char () ())
+ print $ C 'a' 1 == (C 'a' 2 :: T Char () ())
+ print $ D == (D :: T () () ())
--- /dev/null
+++ b/tests/Deriving.ref
@@ -1,0 +1,6 @@
+True
+False
+False
+True
+False
+True
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -55,6 +55,7 @@
$(TMHS) HigherKind && $(EVAL) > HigherKind.out && diff HigherKind.ref HigherKind.out
$(TMHS) PolyKind && $(EVAL) > PolyKind.out && diff PolyKind.ref PolyKind.out
$(TMHS) Record && $(EVAL) > Record.out && diff Record.ref Record.out
+ $(TMHS) Deriving && $(EVAL) > Deriving.out && diff Deriving.ref Deriving.out
errtest:
sh errtester.sh < errmsg.test
--
⑨