Initial deriving

This actually generates some plausibly passing code

Author: jkopanski

src/comp/Deriving.hs

@@ -59,7 +59,7 @@ import FStringCompat
 
 import qualified Data.Set as S
 
--- import Debug.Trace
+import Debug.Trace
 
 -- | Derive instances for all types with deriving (...) in a package, and
 -- return the package agumented with the instance definitions.
@@ -96,7 +96,10 @@ doDer flags r packageid xs data_decl@(Cdata {}) =
         int_sums = cd_internal_summands data_decl
         derivs = cd_derivings data_decl
         stockDerivs = addAutoDerivs flags r qual_name ty_vars (getStockDerivs derivs)
-    in Right [data_decl] : map (doDataDer r packageid xs qual_name ty_vars orig_sums int_sums) stockDerivs
+        viaDerivs = getViaDerivs derivs
+    in Right [data_decl]
+       : map (doDataDer r packageid xs qual_name ty_vars orig_sums int_sums) stockDerivs
+       ++ map (doDataVia r packageid xs qual_name ty_vars orig_sums int_sums) viaDerivs
 doDer flags r packageid xs struct_decl@(Cstruct _ s i ty_var_names fields derivs) =
     let unqual_name = iKName i
         qual_name = qualId packageid unqual_name
@@ -241,6 +244,67 @@ doStructDer _ _ _ i vs cs (CTypeclass di) | isTCId i =
 doStructDer _ _ _ i vs cs (CTypeclass di) =
   Left (getPosition di, ECannotDerive (pfpString di))
 
+-- -------------------------
+
+-- | Derive an instance of a typeclass using Deriving via mechanism
+-- for a given data (sum type), and return the instance definitions.
+-- I've copied the args from doDataDer, potentially add or remove
+--  r   =  the current symbol table
+--  packageid = id name of the package
+--  xs  =  available bindings
+--  i   =  qualified id of the data type
+--  vs  =  argument type variables of the data type
+--  ocs =  original summands of the data type
+--         (an id and a list of types of its arguments)
+--  cs  =  internal summands of the data type
+--         (an id and one type -- the list became a struct)
+--  di  =  the class to be derived
+--  tgt =  data type via which to derive
+doDataVia :: SymTab -> Id -> [(Id, CDefn)] -> Id -> [Type] -> COSummands -> CSummands ->
+             (CTypeclass, Id) -> Either EMsg [CDefn]
+doDataVia r packageid xs i vs ocs cs (di, tgt)
+  | Just (Cclass _ _ ident (dv : args) _ _ fs) <- lookup (typeclassId di) xs
+  = let
+      ctx = []
+      -- TODO: I think there is a type var name clash here. Can I get fresh variable names?
+      ity = cTApplys (cTCon i) vs
+      applied = cTApplys (cTCon $ iKName ident) $ ity : map cTVar args
+      isDataArg :: CType -> Bool
+      isDataArg (TVar tvar) | tv_name tvar == dv = True
+      isDataArg t = False
+      isDataArg' :: CQType -> Bool
+      isDataArg' (CQType _ t) = isDataArg t
+      subst' :: CType -> CType
+      subst' (TVar tvar) | tv_name tvar == dv = ity
+      subst' t = t
+      subst :: CType -> (CType, [CType])
+      subst ty = let (a, rs) = splitTAp ty
+                 in (subst' a, map subst' rs)
+      mkCDef :: CField -> CDef
+      mkCDef f =
+        let
+          CQType preds ty = cf_type f
+          tys = subst ty
+          (args', ret) = getCQArrows $ cf_type f
+          vars = zip args' tmpVarXIds
+          pats = map (CPVar . snd) vars
+          cvar :: (CQType, Id) -> CExpr
+          cvar (CQType preds (TVar tvar), id) | tv_name tvar == dv = CCon tgt $ [cVar id]
+          cvar (_, id) = cVar id
+          args = map cvar vars
+          fun = unQualId $ cf_name f
+          fcall = CApply (cVar fun) args
+          body = if isDataArg' ret 
+            then Ccase (getPosition di) fcall [CCaseArm (CPCon tgt [CPVar id_y]) [] (cVar id_y)]
+            -- [CLMatch (CPCon tgt [CPVar id_y]) fcall] (cVar id_y)
+            else fcall
+        in CDef fun (CQType preds $ uncurry cTApplys tys) [CClause pats [] body]
+      mkFun :: CField -> CDefl
+      mkFun f = CLValueSign (mkCDef f) []
+    in Right $ pure $ Cinstance (CQType ctx applied) (traceShowId $ map mkFun fs)
+
+doDataVia _ _ _ _ _ _ _ (di, tgt) =
+  Left (getPosition di, ECannotDerive (pfpString di ++ " via " ++ pfpString tgt))
 
 -- -------------------------
 
@@ -876,6 +940,11 @@ genericRepWrapName pos tid isData cid fid = mkId pos $ concatFString $
 
 -- -------------------------
 
+doVia :: Position -> Id -> [Type] -> CFields -> CDefn
+doVia dpos ti vs fields = undefined
+
+-- -------------------------
+
 eNot :: CExpr -> CExpr
 eNot e = cVApply idNot [e]
 eAnd :: CExpr -> CExpr -> CExpr
@@ -999,4 +1068,11 @@ getStockTC _ = []
 getStockDerivs :: [CDeriving] -> [CTypeclass]
 getStockDerivs = concatMap getStockTC
 
+getViaTC :: CDeriving -> Maybe (CTypeclass, Id)
+getViaTC (CVia tc id) = Just (tc, id)
+getViaTC _ = Nothing
+
+getViaDerivs :: [CDeriving] -> [(CTypeclass, Id)]
+getViaDerivs = mapMaybe getViaTC
+
 -- -------------------------