Permalink
Browse files

Change constraint generation algorithm

GTraversable constraints are generated for every field type, except the type for
which we're deriving the instance

'c' constraints are generated for every field type, plus the type for
which we're deriving the instance
  • Loading branch information...
1 parent d12da16 commit 137eacd47af7d35ff4d993c0f58c5f05f6d2a7bf @feuerbach committed Mar 14, 2013
Showing with 7 additions and 7 deletions.
  1. +7 −7 Data/Generics/Traversable/TH.hs
@@ -12,6 +12,7 @@ import Language.Haskell.TH
import Control.Monad
import Data.Generics.Traversable.Core
import Control.Applicative
+import Data.List
err s = error $ "Data.Generics.Traversable.TH: " ++ s
@@ -76,22 +77,21 @@ deriveGTraversable name = do
(typeName, typeParams, constructors) <- getDataInfo name
let
- appliedType = foldl appT (conT typeName) $ map varT typeParams
+ appliedType = foldl AppT (ConT typeName) $ map VarT typeParams
-- instance (...) => GTraversable ctx MyType where { ... }
inst =
- instanceD context (conT ''GTraversable `appT` varT ctx `appT` appliedType) [ do
+ instanceD context (conT ''GTraversable `appT` varT ctx `appT` pure appliedType) [ do
-- gtraverse = ...
funD 'gtraverse [ clause [] (normalB $ gtraverseExpr typeName) [] ]
]
- context = sequence $ gtraversableContext ++ userContext ++ selfContext
+ context = sequence $ gtraversableContext ++ userContext
- selfContext = [ classP ctx $ pure appliedType ]
+ types = filter (/= appliedType) $ nub [ t | (_,_,ts) <- constructors, t <- ts ]
- gtraversableContext = [ classP ''GTraversable [varT ctx, varT name ] | name <- typeParams ]
-
- userContext = [ classP ctx [pure t] | (_,_,ts) <- constructors, t <- ts ]
+ userContext = [ classP ctx [pure t] | t <- appliedType : types ]
+ gtraversableContext = [ classP ''GTraversable [varT ctx, pure t] | t <- types ]
sequence [inst]

0 comments on commit 137eacd

Please sign in to comment.