From eb12972c9b217d46397791c63d19c418b1a3c83f Mon Sep 17 00:00:00 2001 From: ross Date: Fri, 25 Apr 2003 10:50:06 +0000 Subject: [haddock @ 2003-04-25 10:50:05 by ross] An 80% solution to generating derived instances. A complete solution would duplicate the instance inference logic, but if a type variable occurs as a constructor argument, then we can just propagate the derived class to the variable. But we know nothing of the constraints on any type variables that occur elsewhere. For example, the declarations data Either a b = Left a | Right b deriving (Eq, Ord) data Ptr a = Ptr Addr# deriving (Eq, Ord) newtype IORef a = IORef (STRef RealWorld a) deriving Eq yield the instances (Eq a, Eq b) => Eq (Either a b) (Ord a, Ord b) => Ord (Either a b) Eq (Ptr a) Ord (Ptr a) (??? a) => Eq (IORef a) The last example shows the limits of this local analysis. Note that a type variable may be in both categories: then we know a constraint, but there may be more, or a stronger constraint, e.g. data Tree a = Node a [Tree a] deriving Eq yields (Eq a, ??? a) => Eq (Tree a) --- src/HaddockRename.hs | 8 ++++-- src/Main.hs | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 80 insertions(+), 3 deletions(-) diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index 77983e02..b539e9ff 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -88,12 +88,16 @@ renameDecl decl ty <- renameType ty0 doc <- renameMaybeDoc doc0 return (HsTypeDecl loc t args ty doc) - HsDataDecl loc ctx t args cons0 drv doc0 -> do + HsDataDecl loc ctx0 t args cons0 drv0 doc0 -> do + ctx <- mapM renamePred ctx0 cons <- mapM renameConDecl cons0 + drv <- mapM (lookupRn id) drv0 doc <- renameMaybeDoc doc0 return (HsDataDecl loc ctx t args cons drv doc) - HsNewTypeDecl loc ctx t args con0 drv doc0 -> do + HsNewTypeDecl loc ctx0 t args con0 drv0 doc0 -> do + ctx <- mapM renamePred ctx0 con <- renameConDecl con0 + drv <- mapM (lookupRn id) drv0 doc <- renameMaybeDoc doc0 return (HsNewTypeDecl loc ctx t args con drv doc) HsClassDecl loc ctxt0 nm tvs fds decls0 doc0 -> do diff --git a/src/Main.hs b/src/Main.hs index cc1b76f6..b7432166 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -341,7 +341,8 @@ mkInterface no_implicit_prelude mod_map filename decl_map :: FiniteMap HsName HsDecl decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ] - instances = [ d | d@HsInstDecl{} <- final_decls ] + instances = [ d | d@HsInstDecl{} <- final_decls ] ++ + [ d | decl <- orig_decls, d <- derivedInstances mdl decl] -- make the "export items", which will be converted into docs later orig_export_list <- mkExportItems mod_map mdl orig_env decl_map sub_map @@ -394,6 +395,78 @@ mkInterface no_implicit_prelude mod_map filename } ) +-- Try to generate instance declarations for derived instances. +-- We can't do this properly without instance inference, but if a type +-- variable occurs as a constructor argument, then we can just +-- propagate the derived class to the variable. But we know nothing of +-- the constraints on any type variables that occur elsewhere. +-- Note that a type variable may be in both categories: then we know a +-- constraint, but there may be more, or a stronger constraint. +derivedInstances :: Module -> HsDecl -> [HsDecl] +derivedInstances mdl decl = case decl of + HsDataDecl srcloc ctxt n tvs cons drv@(_:_) _ -> + derived srcloc ctxt n tvs cons drv + HsNewTypeDecl srcloc ctxt n tvs con drv@(_:_) _ -> + derived srcloc ctxt n tvs [con] drv + _ -> [] + where + derived srcloc ctxt n tvs cons drv = + [HsInstDecl srcloc + (ctxt ++ [(cls,[v]) | v <- simple_tvars] ++ extra_constraint) + (cls,[t]) [] | + cls <- drv] + where + tvar_map = fmToList $ unionMaps (map tvarsConstr cons) + simple_tvars = [HsTyVar v | (v,(in_constr,_)) <- tvar_map, in_constr] + complex_tvars = [HsTyVar v | (v,(_,in_tycons)) <- tvar_map, in_tycons] + extra_constraint + | null complex_tvars = [] + | otherwise = [(unknownConstraint,complex_tvars)] + t | n == tuple_tycon_name (length tvs - 1) = + HsTyTuple True (map HsTyVar tvs) + | otherwise = foldl HsTyApp (HsTyCon (Qual mdl n)) (map HsTyVar tvs) + + -- collect the type variables occurring free in a constr + tvarsConstr :: HsConDecl -> FiniteMap HsName (Bool,Bool) + -- first Bool: tvar occurs as a data constructor argument + -- second Bool: tvar occurs as a type constructor argument + tvarsConstr (HsConDecl _ _ vs _ bts _) = + unionMaps (map tvarsBangType bts) `delListFromFM` vs + tvarsConstr (HsRecDecl _ _ vs _ fs _) = + unionMaps (map tvarsField fs) `delListFromFM` vs + + tvarsField (HsFieldDecl _ bt _) = tvarsBangType bt + + tvarsBangType (HsBangedTy t) = tvarsType t + tvarsBangType (HsUnBangedTy t) = tvarsType t + + tvarsType (HsTyTuple _ ts) = unionMaps (map tvarsType ts) + tvarsType (HsTyVar tv) = unitFM tv (True,False) + tvarsType (HsTyDoc t _) = tvarsType t + tvarsType t = tvarsType2 t + + tvarsType2 (HsForAllType (Just tvs) _ t) = tvarsType2 t `delListFromFM` tvs + tvarsType2 (HsForAllType Nothing _ t) = tvarsType2 t + tvarsType2 (HsTyFun t1 t2) = tvarsType2 t1 `unionMap` tvarsType2 t2 + tvarsType2 (HsTyTuple _ ts) = unionMaps (map tvarsType2 ts) + tvarsType2 (HsTyApp t1 t2) = tvarsType2 t1 `unionMap` tvarsType2 t2 + tvarsType2 (HsTyVar tv) = unitFM tv (False,True) + tvarsType2 (HsTyCon _) = emptyFM + tvarsType2 (HsTyDoc t _) = tvarsType2 t + + unionMaps :: [FiniteMap HsName (Bool,Bool)] -> FiniteMap HsName (Bool,Bool) + unionMaps = foldr unionMap emptyFM + + unionMap :: FiniteMap HsName (Bool,Bool) -> FiniteMap HsName (Bool,Bool) -> + FiniteMap HsName (Bool,Bool) + unionMap = plusFM_C or2 + + or2 :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) + or2 (a1,b1) (a2,b2) = (a1 || a2, b1 || b2) + +unknownConstraint :: HsQName +unknownConstraint = UnQual (HsTyClsName (HsIdent "???")) + -- ----------------------------------------------------------------------------- -- Build the list of items that will become the documentation, from the -- export list. At this point, the list of ExportItems is in terms of -- cgit v1.2.3