From 225a491d67500e0c29904122d3b63b5d77a87910 Mon Sep 17 00:00:00 2001
From: ross <unknown>
Date: Wed, 19 May 2004 13:10:23 +0000
Subject: [haddock @ 2004-05-19 13:10:23 by ross] Make the handling of
"deriving" slightly smarter, by ignoring data constructor arguments that are
identical to the lhs. Now handles things like
data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving ...
---
src/Main.hs | 87 ++++++++++++++++++++++++++++++++-----------------------------
1 file changed, 46 insertions(+), 41 deletions(-)
diff --git a/src/Main.hs b/src/Main.hs
index 28842d3c..41612ed3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -33,11 +33,13 @@ import IO
#if __GLASGOW_HASKELL__ < 503
import MonadWriter
import FiniteMap
+import Set
import GetOpt
import IOExts
#else
import Control.Monad.Writer
import Data.FiniteMap
+import Data.Set
import System.Console.GetOpt
import Data.IORef
--import Debug.Trace
@@ -501,56 +503,59 @@ derivedInstances mdl decl = case decl of
derived srcloc ctxt n tvs cons drv =
[HsInstDecl srcloc
(ctxt ++ [(cls,[v]) | v <- simple_tvars] ++ extra_constraint)
- (cls,[t]) [] |
+ (cls,[lhs]) [] |
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]
+ targs = map stripDocs (targsConstrs cons)
+ -- a type variable is simple if it occurs as a data constructor argument
+ simple_tvars = map HsTyVar $ setToList $ mkSet $ [tv | HsTyVar tv <- targs]
+ -- a type variable is complex if it occurs inside a data constructor
+ -- argument, except where the argument is identical to the lhs.
+ complex_tvars = map HsTyVar $ setToList $ unionManySets $ map tvarsType $
+ filter (/= lhs) $ filter (not . isVar) targs
+ isVar (HsTyVar _) = True
+ isVar _ = False
extra_constraint
| null complex_tvars = []
| otherwise = [(unknownConstraint,complex_tvars)]
- t | n == tuple_tycon_name (length tvs - 1) =
+ lhs
+ | 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)
+ -- collect type arguments of constructors
+ targsConstrs :: [HsConDecl] -> [HsType]
+ targsConstrs = foldr targsConstr []
+
+ targsConstr :: HsConDecl -> [HsType] -> [HsType]
+ targsConstr (HsConDecl _ _ _ _ bts _) ts = foldr targsBangType ts bts
+ targsConstr (HsRecDecl _ _ _ _ fs _) ts = foldr targsField ts fs
+
+ targsField (HsFieldDecl _ bt _) = targsBangType bt
+
+ targsBangType (HsBangedTy t) ts = t : ts
+ targsBangType (HsUnBangedTy t) ts = t : ts
+
+ -- remove documentation comments from a type
+ stripDocs :: HsType -> HsType
+ stripDocs (HsForAllType n ctxt t) = HsForAllType n ctxt (stripDocs t)
+ stripDocs (HsTyFun t1 t2) = HsTyFun (stripDocs t1) (stripDocs t2)
+ stripDocs (HsTyTuple boxed ts) = HsTyTuple boxed (map stripDocs ts)
+ stripDocs (HsTyApp t1 t2) = HsTyApp (stripDocs t1) (stripDocs t2)
+ stripDocs (HsTyDoc t _) = stripDocs t
+ stripDocs (HsTyIP n t) = HsTyIP n (stripDocs t)
+ stripDocs t = t
+
+ -- collect the type variables occurring free in a type
+ tvarsType (HsForAllType (Just tvs) _ t) = foldl delFromSet (tvarsType t) tvs
+ tvarsType (HsForAllType Nothing _ t) = tvarsType t
+ tvarsType (HsTyFun t1 t2) = tvarsType t1 `union` tvarsType t2
+ tvarsType (HsTyTuple _ ts) = unionManySets (map tvarsType ts)
+ tvarsType (HsTyApp t1 t2) = tvarsType t1 `union` tvarsType t2
+ tvarsType (HsTyVar tv) = unitSet tv
+ tvarsType (HsTyCon _) = emptySet
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)
+ tvarsType (HsTyIP _ t) = tvarsType t
unknownConstraint :: HsQName
unknownConstraint = UnQual (HsTyClsName (HsIdent "???"))
--
cgit v1.2.3