ref: eea5c5c8e74312b821a51bbd49c3f18edd05e2f5
parent: 772600423d69a6f98c1219690223368ddf0ba46d
author: Lennart Augustsson <lennart@augustsson.net>
date: Mon Dec 25 06:42:45 EST 2023
Add missing file.
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -43,6 +43,7 @@
other-modules: MicroHs.Abstract
MicroHs.Compile
MicroHs.CompileCache
+ MicroHs.Deriving
MicroHs.Desugar
MicroHs.EncodeData
MicroHs.Exp
--- /dev/null
+++ b/src/MicroHs/Deriving.hs
@@ -1,0 +1,57 @@
+module MicroHs.Deriving(expandField) where
+import Prelude
+import Data.Function
+import Data.List
+import MicroHs.Expr
+import MicroHs.Ident
+import MicroHs.TCMonad
+
+expandField :: EDef -> T [EDef]
+expandField def@(Data lhs cs) = (def:) <$> genHasFields lhs cs
+expandField def = return [def]
+
+genHasFields :: LHS -> [Constr] -> T [EDef]
+genHasFields lhs cs = do
+ let fldtys = nubBy ((==) `on` fst) [ (fld, ty) | Constr _ _ _ (Right fs) <- cs, (fld, (_, ty)) <- fs ]
+-- flds = map fst fldtys
+ mapM (genHasField lhs cs) fldtys
+
+genHasField :: LHS -> [Constr] -> (Ident, EType) -> T EDef
+genHasField (tycon, iks) cs (fld, fldty) = do
+ mn <- gets moduleName
+ let loc = getSLoc tycon
+ qtycon = qualIdent mn tycon
+ dum = EVar dummyIdent
+ eFld = EVar fld
+ undef = EVar $ mkIdentSLoc loc "undefined" -- XXX could be nicer
+ iHasField = mkIdentSLoc loc nameHasField
+ ihasField = mkIdentSLoc loc namehasField
+ hdr = eForall iks $ eApp3 (EVar iHasField)
+ (ELit loc (LStr (unIdent fld)))
+ (eApps (EVar qtycon) (map (EVar . idKindIdent) iks))
+ fldty
+ conEqn (Constr _ _ c (Left ts)) = eEqn [dum, eApps (EVar c) (map (const dum) ts)] $ undef
+ conEqn (Constr _ _ c (Right fts)) = eEqn [dum, conApp] $ if fld `elem` fs then rhs else undef
+ where fs = map fst fts
+ conApp = eApps (EVar c) (map EVar fs)
+ rhs = ETuple [eFld, eLam [eFld] conApp]
+ pure $ Instance hdr [BFcn ihasField $ map conEqn cs]
+
+eApp2 :: Expr -> Expr -> Expr -> Expr
+eApp2 a b c = EApp (EApp a b) c
+
+eApp3 :: Expr -> Expr -> Expr -> Expr -> Expr
+eApp3 a b c d = EApp (eApp2 a b c) d
+
+eApps :: Expr -> [Expr] -> Expr
+eApps = foldl EApp
+
+eForall :: [IdKind] -> EType -> EType
+eForall [] t = t
+eForall vs t = EForall vs t
+
+nameHasField :: String
+nameHasField = "Data.Record.HasField"
+
+namehasField :: String
+namehasField = "hasField"
--
⑨