compdata 0.10 → 0.10.1

raw patch · 24 files changed

+154/−94 lines, 24 filesdep ~basedep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• compdata.cabal +4/−4
• src/Data/Comp/Algebra.hs +2/−2
• src/Data/Comp/Derive/Arbitrary.hs +2/−2
• src/Data/Comp/Derive/DeepSeq.hs +3/−3
• src/Data/Comp/Derive/Equality.hs +2/−2
• src/Data/Comp/Derive/Foldable.hs +3/−3
• src/Data/Comp/Derive/HaskellStrict.hs +11/−6
• src/Data/Comp/Derive/Ordering.hs +2/−2
• src/Data/Comp/Derive/Show.hs +8/−8
• src/Data/Comp/Derive/SmartAConstructors.hs +1/−1
• src/Data/Comp/Derive/SmartConstructors.hs +1/−1
• src/Data/Comp/Derive/Traversable.hs +3/−3
• src/Data/Comp/Derive/Utils.hs +74/−19
• src/Data/Comp/Multi/Derive/Equality.hs +4/−4
• src/Data/Comp/Multi/Derive/HFoldable.hs +3/−3
• src/Data/Comp/Multi/Derive/HFunctor.hs +3/−3
• src/Data/Comp/Multi/Derive/HTraversable.hs +3/−3
• src/Data/Comp/Multi/Derive/Ordering.hs +13/−13
• src/Data/Comp/Multi/Derive/Show.hs +4/−4
• src/Data/Comp/Multi/Derive/SmartAConstructors.hs +1/−1
• src/Data/Comp/Multi/Derive/SmartConstructors.hs +1/−1
• src/Data/Comp/Multi/Generic.hs +2/−2
• src/Data/Comp/Multi/HFoldable.hs +2/−2
• src/Data/Comp/Multi/Term.hs +2/−2

@@ -1,5 +1,5 @@ Name:			compdata-Version:		0.10+Version:		0.10.1 Synopsis:            	Compositional Data Types Description: @@ -187,7 +187,7 @@                         Data.Comp.Multi.Derive.SmartConstructors                         Data.Comp.Multi.Derive.SmartAConstructors -  Build-Depends:	base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1, QuickCheck >= 2 && < 2.8, derive,+  Build-Depends:	base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1, QuickCheck >= 2 && < 2.9, derive,                         deepseq, th-expand-syns, transformers, tree-view   Extensions:           FlexibleContexts   hs-source-dirs:	src@@ -198,7 +198,7 @@   Type:                 exitcode-stdio-1.0   Main-is:		Data_Test.hs   hs-source-dirs:	testsuite/tests examples src-  Build-Depends:        base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1, QuickCheck >= 2 && < 2.8, +  Build-Depends:        base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1, QuickCheck >= 2 && < 2.9,                          HUnit, test-framework, test-framework-hunit, test-framework-quickcheck2 >= 0.3, derive,                         th-expand-syns, deepseq, transformers @@ -209,7 +209,7 @@   ghc-options:          -W -O2   -- Disable short-cut fusion rules in order to compare optimised and unoptimised code.   cpp-options:          -DNO_RULES-  Build-Depends:        base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1, QuickCheck >= 2 && < 2.8, derive, deepseq, criterion, random, uniplate, th-expand-syns, transformers+  Build-Depends:        base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1, QuickCheck >= 2 && < 2.9, derive, deepseq, criterion, random, uniplate, th-expand-syns, transformers   source-repository head

@@ -454,12 +454,12 @@  -- | Shortcut fusion variant of 'ana'. ana' :: forall a f . Functor f => Coalg f a -> a -> Term f-ana' f t = build $ run t+ana' f t = build (run t)     where run :: forall b . a -> Alg f b -> b           run t con = run' t where               run' :: a ->  b               run' t = con $ fmap run' (f t)-+{-# INLINE [2] ana' #-} build :: (forall a. Alg f a -> a) -> Term f {-# INLINE [1] build #-} build g = g Term

@@ -46,14 +46,14 @@   instances of 'Arbitrary'. -} makeArbitraryF :: Name -> Q [Dec] makeArbitraryF dt = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt   let argNames = map (VarT . tyVarBndrName) (tail args)       complType = foldl AppT (ConT name) argNames       preCond = map (mkClassP ''Arbitrary . (: [])) argNames       classType = AppT (ConT ''ArbitraryF) complType   arbitraryDecl <- generateArbitraryFDecl constrs   shrinkDecl <- generateShrinkFDecl constrs-  return [InstanceD preCond classType [arbitraryDecl, shrinkDecl]]+  return [mkInstanceD preCond classType [arbitraryDecl, shrinkDecl]]  {-|   This function generates a declaration of the method 'arbitrary' for the given

@@ -32,16 +32,16 @@   kind taking at least one argument. -} makeNFDataF :: Name -> Q [Dec] makeNFDataF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames       preCond = map (mkClassP ''NFData . (: [])) argNames       classType = AppT (ConT ''NFDataF) complType   constrs' <- mapM normalConExp constrs   rnfFDecl <- funD 'rnfF (rnfFClauses constrs')-  return [InstanceD preCond classType [rnfFDecl]]+  return [mkInstanceD preCond classType [rnfFDecl]]       where rnfFClauses = map genRnfFClause-            genRnfFClause (constr, args) = do+            genRnfFClause (constr, args,_) = do               let n = length args               varNs <- newNames n "x"               let pat = ConP constr $ map VarP varNs

@@ -31,13 +31,13 @@   taking at least one argument. -} makeEqF :: Name -> Q [Dec] makeEqF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames       preCond = map (mkClassP ''Eq . (: [])) argNames       classType = AppT (ConT ''EqF) complType   eqFDecl <- funD 'eqF  (eqFClauses constrs)-  return [InstanceD preCond classType [eqFDecl]]+  return [mkInstanceD preCond classType [eqFDecl]]       where eqFClauses constrs = map (genEqClause.abstractConType) constrs                                    ++ defEqClause constrs             defEqClause constrs

@@ -39,7 +39,7 @@   kind taking at least one argument. -} makeFoldable :: Name -> Q [Dec] makeFoldable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -51,8 +51,8 @@   foldrDecl <- funD 'foldr (map foldrClause constrs')   foldl1Decl <- funD 'foldl1 (map foldl1Clause constrs')   foldr1Decl <- funD 'foldr1 (map foldr1Clause constrs')-  return [InstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl,foldl1Decl,foldr1Decl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl,foldl1Decl,foldr1Decl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getUnaryFArg fArg gadtTy)) args)             filterVar [] _ = Nothing             filterVar [d] x =Just (d, varE x)             filterVar _ _ =  error "functor variable occurring twice in argument type"

@@ -57,7 +57,7 @@   first-order kind taking at least one argument. -} makeHaskellStrict :: Name -> Q [Dec] makeHaskellStrict fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -68,7 +68,7 @@      sequenceDecl <- valD (varP 'thunkSequence) (normalB [|return|]) []      injectDecl <- valD (varP 'thunkSequenceInject) (normalB [|inject|]) []      injectDecl' <- valD (varP 'thunkSequenceInject') (normalB [|inject|]) []-     return [InstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]+     return [mkInstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]    else do      (sc',matchPat,ic') <- liftM unzip3 $ P.mapM mkClauses constrs_      xn <- newName "x"@@ -76,13 +76,18 @@      let sequenceDecl = FunD 'thunkSequence sc'          injectDecl = FunD 'thunkSequenceInject [Clause [VarP xn] (NormalB (doThunk `AppE` CaseE (VarE xn) matchPat)) []]          injectDecl' = FunD 'thunkSequenceInject' ic'-     return [InstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]-      where isFarg fArg (constr, args) = (constr, map (containsStr fArg) args)-            containsStr _ (NotStrict,_) = []+     return [mkInstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (containsStr (getUnaryFArg fArg gadtTy)) args)+            +#if __GLASGOW_HASKELL__ < 800             containsStr fArg (IsStrict,ty) = ty `containsType'` fArg-#if __GLASGOW_HASKELL__ > 702             containsStr fArg (Unpacked,ty) = ty `containsType'` fArg+#else+            containsStr fArg (Bang _ SourceStrict,ty) = ty `containsType'` fArg+            containsStr fArg (Bang SourceUnpack _,ty) = ty `containsType'` fArg #endif+            containsStr _ _ = []+             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"

@@ -37,13 +37,13 @@   taking at least one argument. -} makeOrdF :: Name -> Q [Dec] makeOrdF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames       preCond = map (mkClassP ''Ord . (: [])) argNames       classType = AppT (ConT ''OrdF) complType   eqAlgDecl <- funD 'compareF  (compareFClauses constrs)-  return [InstanceD preCond classType [eqAlgDecl]]+  return [mkInstanceD preCond classType [eqAlgDecl]]       where compareFClauses [] = []             compareFClauses constrs =                 let constrs' = map abstractConType constrs `zip` [1..]

@@ -36,7 +36,7 @@   taking at least one argument. -} makeShowF :: Name -> Q [Dec] makeShowF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -44,18 +44,18 @@       classType = AppT (ConT ''ShowF) complType   constrs' <- mapM normalConExp constrs   showFDecl <- funD 'showF (showFClauses fArg constrs')-  return [InstanceD preCond classType [showFDecl]]+  return [mkInstanceD preCond classType [showFDecl]]       where showFClauses fArg = map (genShowFClause fArg)             filterFarg fArg ty x = (fArg == ty, varE x)             mkShow :: (Bool, ExpQ) -> ExpQ             mkShow (isFArg, var)                 | isFArg = var                 | otherwise = [| show $var |]-            genShowFClause fArg (constr, args) = do+            genShowFClause fArg (constr, args, gadtTy) = do               let n = length args               varNs <- newNames n "x"               let pat = ConP constr $ map VarP varNs-                  allVars = zipWith (filterFarg fArg) args varNs+                  allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs                   shows = listE $ map mkShow allVars                   conName = nameBase constr               body <- [|showCon conName $shows|]@@ -72,7 +72,7 @@   taking at least one argument. -} makeShowConstr :: Name -> Q [Dec] makeShowConstr fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -80,18 +80,18 @@       classType = AppT (ConT ''ShowConstr) complType   constrs' <- mapM normalConExp constrs   showConstrDecl <- funD 'showConstr (showConstrClauses fArg constrs')-  return [InstanceD preCond classType [showConstrDecl]]+  return [mkInstanceD preCond classType [showConstrDecl]]       where showConstrClauses fArg = map (genShowConstrClause fArg)             filterFarg fArg ty x = (fArg == ty, varE x)             mkShow :: (Bool, ExpQ) -> ExpQ             mkShow (isFArg, var)                 | isFArg = [| "" |]                 | otherwise = [| show $var |]-            genShowConstrClause fArg (constr, args) = do+            genShowConstrClause fArg (constr, args, gadtTy) = do               let n = length args               varNs <- newNames n "x"               let pat = ConP constr $ map VarP varNs-                  allVars = zipWith (filterFarg fArg) args varNs+                  allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs                   shows = listE $ map mkShow allVars                   conName = nameBase constr               body <- [|showCon' conName $shows|]

@@ -30,7 +30,7 @@   inserted. -} smartAConstructors :: Name -> Q [Dec] smartAConstructors fname = do-    TyConI (DataD _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let cons = map abstractConType constrs     liftM concat $ mapM genSmartConstr cons         where genSmartConstr   (name, args) = do

@@ -28,7 +28,7 @@  ordinary constructors, but an 'inject' is automatically inserted. -} smartConstructors :: Name -> Q [Dec] smartConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let cons = map abstractConType constrs     liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons         where genSmartConstr targs tname (name, args) = do

@@ -39,7 +39,7 @@   first-order kind taking at least one argument. -} makeTraversable :: Name -> Q [Dec] makeTraversable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -49,8 +49,8 @@   sequenceADecl <- funD 'sequenceA (map sequenceAClause constrs')   mapMDecl <- funD 'mapM (map mapMClause constrs')   sequenceDecl <- funD 'sequence (map sequenceClause constrs')-  return [InstanceD [] classType [traverseDecl, sequenceADecl, mapMDecl,sequenceDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [traverseDecl, sequenceADecl, mapMDecl,sequenceDecl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getUnaryFArg fArg gadtTy)) args)             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"

@@ -26,50 +26,94 @@ reportError = report True #endif +#if __GLASGOW_HASKELL__ < 800+data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] [Name]+#else+data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] Cxt+#endif+ {-|   This is the @Q@-lifted version of 'abstractNewtype. -}-abstractNewtypeQ :: Q Info -> Q Info+abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo) abstractNewtypeQ = liftM abstractNewtype  {-|   This function abstracts away @newtype@ declaration, it turns them into   @data@ declarations. -}-abstractNewtype :: Info -> Info+abstractNewtype :: Info -> Maybe DataInfo+#if __GLASGOW_HASKELL__ < 800 abstractNewtype (TyConI (NewtypeD cxt name args constr derive))-    = TyConI (DataD cxt name args [constr] derive)-abstractNewtype owise = owise+    = Just (DataInfo cxt name args [constr] derive)+abstractNewtype (TyConI (DataD cxt name args constrs derive))+    = Just (DataInfo cxt name args constrs derive)+#else+abstractNewtype (TyConI (NewtypeD cxt name args _ constr derive))+    = Just (DataInfo cxt name args [constr] derive)+abstractNewtype (TyConI (DataD cxt name args _ constrs derive))+    = Just (DataInfo cxt name args constrs derive)+#endif+abstractNewtype _ = Nothing -{-|-  This function provides the name and the arity of the given data constructor.+{-| This function provides the name and the arity of the given data+constructor, and if it is a GADT also its type. -}-normalCon :: Con -> (Name,[StrictType])-normalCon (NormalC constr args) = (constr, args)-normalCon (RecC constr args) = (constr, map (\(_,s,t) -> (s,t)) args)-normalCon (InfixC a constr b) = (constr, [a,b])+normalCon :: Con -> (Name,[StrictType], Maybe Type)+normalCon (NormalC constr args) = (constr, args, Nothing)+normalCon (RecC constr args) = (constr, map (\(_,s,t) -> (s,t)) args, Nothing)+normalCon (InfixC a constr b) = (constr, [a,b], Nothing) normalCon (ForallC _ _ constr) = normalCon constr+#if __GLASGOW_HASKELL__ >= 800+normalCon (GadtC (constr:constrs) args typ) = (constr,args,Just typ)+#endif +normalCon' :: Con -> (Name,[Type], Maybe Type)+normalCon' con = (n, map snd ts, t)+  where (n, ts, t) = normalCon con+       -normalCon' :: Con -> (Name,[Type])-normalCon' = fmap (map snd) . normalCon+-- -- | Same as normalCon' but expands type synonyms.+-- normalConExp :: Con -> Q (Name,[Type])+-- normalConExp c = do+--   let (n,ts,t) = normalCon' c+--   ts' <- mapM expandSyns ts+--   return (n, ts')  -- | Same as normalCon' but expands type synonyms.-normalConExp :: Con -> Q (Name,[Type])+normalConExp :: Con -> Q (Name,[Type], Maybe Type) normalConExp c = do-  let (n,ts) = normalCon' c+  let (n,ts,t) = normalCon' c   ts' <- mapM expandSyns ts-  return (n, ts')+  return (n, ts',t)   -- | Same as normalConExp' but retains strictness annotations.-normalConStrExp :: Con -> Q (Name,[StrictType])+normalConStrExp :: Con -> Q (Name,[StrictType], Maybe Type) normalConStrExp c = do-  let (n,ts) = normalCon c+  let (n,ts,t) = normalCon c   ts' <- mapM (\ (st,ty) -> do ty' <- expandSyns ty; return (st,ty')) ts-  return (n, ts')+  return (n, ts',t) +-- | Auxiliary function to extract the first argument of a binary type+-- application (the second argument of this function). If the second+-- argument is @Nothing@ or not of the right shape, the first argument+-- is returned as a default. +getBinaryFArg :: Type -> Maybe Type -> Type+getBinaryFArg _ (Just (AppT (AppT _ t)  _)) = t+getBinaryFArg def _ = def++-- | Auxiliary function to extract the first argument of a type+-- application (the second argument of this function). If the second+-- argument is @Nothing@ or not of the right shape, the first argument+-- is returned as a default.+getUnaryFArg :: Type -> Maybe Type -> Type+getUnaryFArg _ (Just (AppT _ t)) = t+getUnaryFArg def _ = def+++ {-|   This function provides the name and the arity of the given data constructor. -}@@ -78,6 +122,9 @@ abstractConType (RecC constr args) = (constr, length args) abstractConType (InfixC _ constr _) = (constr, 2) abstractConType (ForallC _ _ constr) = abstractConType constr+#if __GLASGOW_HASKELL__ >= 800+abstractConType (GadtC (constr:_) args typ) = (constr,length args) -- Only first Name+#endif  {-|   This function returns the name of a bound type variable@@ -151,7 +198,15 @@ isEqualP _ = Nothing #endif +mkInstanceD :: Cxt -> Type -> [Dec] -> Dec+#if __GLASGOW_HASKELL__ < 800+mkInstanceD cxt ty decs = InstanceD cxt ty decs+#else+mkInstanceD cxt ty decs = InstanceD Nothing cxt ty decs+#endif ++ -- | This function lifts type class instances over sums -- ofsignatures. To this end it assumes that it contains only methods -- with types of the form @f t1 .. tn -> t@ where @f@ is the signature@@ -186,7 +241,7 @@       let tp = ((ConT sumName `AppT` f) `AppT` g)       let complType = foldl AppT (foldl AppT (ConT name) ts1 `AppT` tp) ts2       decs' <- sequence $ concatMap decl decs-      return [InstanceD cxt complType decs']+      return [mkInstanceD cxt complType decs']         where decl :: Dec -> [DecQ]               decl (SigD f _) = [funD f [clause f]]               decl _ = []

@@ -27,7 +27,7 @@   kind taking at least two arguments. -} makeEqHF :: Name -> Q [Dec] makeEqHF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       argNames = map (VarT . tyVarBndrName) (init args')       ftyp = VarT . tyVarBndrName $ last args'@@ -36,13 +36,13 @@       classType = AppT (ConT ''EqHF) complType   constrs' <- mapM normalConExp constrs   eqFDecl <- funD 'eqHF  (eqFClauses ftyp constrs constrs')-  return [InstanceD preCond classType [eqFDecl]]+  return [mkInstanceD preCond classType [eqFDecl]]       where eqFClauses ftyp constrs constrs' = map (genEqClause ftyp) constrs'                                    ++ defEqClause constrs             defEqClause constrs                 | length constrs  < 2 = []                 | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]-            genEqClause ftyp (constr, argts) = do+            genEqClause ftyp (constr, argts, gadtTy) = do               let n = length argts               varNs <- newNames n "x"               varNs' <- newNames n "y"@@ -51,7 +51,7 @@                   vars = map VarE varNs                   vars' = map VarE varNs'                   mkEq ty x y = let (x',y') = (return x,return y)-                                in if containsType ty ftyp+                                in if containsType ty (getBinaryFArg ftyp gadtTy)                                    then [| $x' `keq` $y'|]                                    else [| $x' == $y'|]                   eqs = listE $ zipWith3 mkEq argts vars vars'

@@ -46,7 +46,7 @@   kind taking at least two arguments. -} makeHFoldable :: Name -> Q [Dec] makeHFoldable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')@@ -57,8 +57,8 @@   foldMapDecl <- funD 'hfoldMap (map foldMapClause constrs')   foldlDecl <- funD 'hfoldl (map foldlClause constrs')   foldrDecl <- funD 'hfoldr (map foldrClause constrs')-  return [InstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getBinaryFArg fArg gadtTy)) args)             filterVar [] _ = Nothing             filterVar [d] x =Just (d, varE x)             filterVar _ _ =  error "functor variable occurring twice in argument type"

@@ -33,7 +33,7 @@   kind taking at least two arguments. -} makeHFunctor :: Name -> Q [Dec] makeHFunctor fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')@@ -41,8 +41,8 @@       classType = AppT (ConT ''HFunctor) complType   constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs   hfmapDecl <- funD 'hfmap (map hfmapClause constrs')-  return [InstanceD [] classType [hfmapDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [hfmapDecl]]+      where isFarg fArg (constr, args, ty) = (constr, map (`containsType'` getBinaryFArg fArg ty) args)             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"

@@ -37,7 +37,7 @@   higher-order kind taking at least two arguments. -} makeHTraversable :: Name -> Q [Dec] makeHTraversable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')@@ -46,8 +46,8 @@   constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs   traverseDecl <- funD 'htraverse (map traverseClause constrs')   mapMDecl <- funD 'hmapM (map mapMClause constrs')-  return [InstanceD [] classType [traverseDecl, mapMDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [traverseDecl, mapMDecl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getBinaryFArg fArg gadtTy)) args)             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"

@@ -32,17 +32,17 @@   kind taking at least three arguments. -} makeOrdHF :: Name -> Q [Dec] makeOrdHF fname = do-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname   let args' = init args   -- covariant argument-  let coArg :: Name = tyVarBndrName $ last args'+  let coArg :: Type = VarT $ tyVarBndrName $ last args'   let argNames = map (VarT . tyVarBndrName) (init args')   let complType = foldl AppT (ConT name) argNames   let classType = AppT (ConT ''OrdHF) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type],Maybe Type)] <- mapM normalConExp constrs   compareHFDecl <- funD 'compareHF (compareHFClauses coArg constrs')-  return [InstanceD [] classType [compareHFDecl]]-      where compareHFClauses :: Name -> [(Name,[Type])] -> [ClauseQ]+  return [mkInstanceD [] classType [compareHFDecl]]+      where compareHFClauses :: Type -> [(Name,[Type],Maybe Type)] -> [ClauseQ]             compareHFClauses _ [] = []             compareHFClauses coArg constrs =                 let constrs' = constrs `zip` [1..]@@ -52,24 +52,24 @@                 | n == m = genEqClause coArg c                 | n < m = genLtClause c d                 | otherwise = genGtClause c d-            genEqClause :: Name -> (Name,[Type]) -> ClauseQ-            genEqClause coArg (constr, args) = do+            genEqClause :: Type -> (Name,[Type],Maybe Type) -> ClauseQ+            genEqClause coArg (constr, args,gadtTy) = do               varXs <- newNames (length args) "x"               varYs <- newNames (length args) "y"               let patX = ConP constr $ map VarP varXs               let patY = ConP constr $ map VarP varYs-              body <- eqDBody coArg (zip3 varXs varYs args)+              body <- eqDBody (getBinaryFArg coArg gadtTy) (zip3 varXs varYs args)               return $ Clause [patX, patY] (NormalB body) []-            eqDBody :: Name -> [(Name, Name, Type)] -> ExpQ+            eqDBody :: Type -> [(Name, Name, Type)] -> ExpQ             eqDBody coArg x =                 [|compList $(listE $ map (eqDB coArg) x)|]-            eqDB :: Name -> (Name, Name, Type) -> ExpQ+            eqDB :: Type -> (Name, Name, Type) -> ExpQ             eqDB coArg (x, y, tp)-                | not (containsType tp (VarT coArg)) =+                | not (containsType tp coArg) =                     [| compare $(varE x) $(varE y) |]                 | otherwise =                     [| kcompare $(varE x) $(varE y) |]-            genLtClause (c, _) (d, _) =+            genLtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| LT |]) []-            genGtClause (c, _) (d, _) =+            genGtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| GT |]) []

@@ -44,7 +44,7 @@   kind taking at least two arguments. -} makeShowHF :: Name -> Q [Dec] makeShowHF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')@@ -53,17 +53,17 @@       classType = AppT (ConT ''ShowHF) complType   constrs' <- mapM normalConExp constrs   showFDecl <- funD 'showHF (showFClauses fArg constrs')-  return [InstanceD preCond classType [showFDecl]]+  return [mkInstanceD preCond classType [showFDecl]]       where showFClauses fArg = map (genShowFClause fArg)             filterFarg fArg ty x = (containsType ty fArg, varE x)             mkShow (isFArg, var)                 | isFArg = [|unK $var|]                 | otherwise = [| show $var |]-            genShowFClause fArg (constr, args) = do+            genShowFClause fArg (constr, args, ty) = do               let n = length args               varNs <- newNames n "x"               let pat = ConP constr $ map VarP varNs-                  allVars = zipWith (filterFarg fArg) args varNs+                  allVars = zipWith (filterFarg (getBinaryFArg fArg ty)) args varNs                   shows = listE $ map mkShow allVars                   conName = nameBase constr               body <- [|K $ showConstr conName $shows|]

@@ -30,7 +30,7 @@   inserted. -} smartAConstructors :: Name -> Q [Dec] smartAConstructors fname = do-    TyConI (DataD _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let cons = map abstractConType constrs     liftM concat $ mapM genSmartConstr cons         where genSmartConstr (name, args) = do

@@ -29,7 +29,7 @@  ordinary constructors, but an 'inject' is automatically inserted. -} smartConstructors :: Name -> Q [Dec] smartConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let iVar = tyVarBndrName $ last targs     let cons = map (abstractConType &&& iTp iVar) constrs     liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons

@@ -38,14 +38,14 @@ -- term. This function is similar to Uniplate's @universe@ function. subterms :: forall f  . HFoldable f => Term f  :=> [E (Term f)] subterms t = build (f t)-    where f :: Term f :=> (E (Term f) -> b -> b) -> b -> b+    where f :: forall i b. Term f i -> (E (Term f) -> b -> b) -> b -> b           f t cons nil = E t `cons` hfoldl (\u s -> f s cons u) nil (unTerm t)  -- | This function returns a list of all subterms of the given term -- that are constructed from a particular functor. subterms' :: forall f g . (HFoldable f, g :<: f) => Term f :=> [E (g (Term f))] subterms' (Term t) = build (f t)-    where f :: f (Term f) :=> (E (g (Term f)) -> b -> b) -> b -> b+    where f :: forall i b. f (Term f) i -> (E (g (Term f)) -> b -> b) -> b -> b           f t cons nil = let rest = hfoldl (\u (Term s) -> f s cons u) nil t                          in case proj t of                               Just t' -> E t' `cons` rest

@@ -41,7 +41,7 @@     hfoldMap :: Monoid m => (a :=> m) -> h a :=> m     hfoldMap f = hfoldr (mappend . f) mempty -    hfoldr :: (a :=> b -> b) -> b -> h a :=> b+    hfoldr :: (a :=> (b->b) ) -> b -> h a :=> b     hfoldr f z t = appEndo (hfoldMap (Endo . f) t) z      hfoldl :: (b -> a :=> b) -> b -> h a :=> b@@ -51,7 +51,7 @@     hfoldr1 :: forall a. (a -> a -> a) -> h (K a) :=> a     hfoldr1 f xs = fromMaybe (error "hfoldr1: empty structure")                    (hfoldr mf Nothing xs)-          where mf :: K a :=> Maybe a -> Maybe a+          where mf :: K a :=> (Maybe a -> Maybe a)                 mf (K x) Nothing = Just x                 mf (K x) (Just y) = Just (f x y) 

@@ -83,9 +83,9 @@  instance (HFoldable f) => HFoldable (Cxt h f) where     hfoldr = hfoldr' where-        hfoldr'  :: forall a b. (a :=> b -> b) -> b -> Cxt h f a :=> b+        hfoldr'  :: forall a b. (a :=> (b -> b)) -> b -> Cxt h f a :=> b         hfoldr' op c a = run a c where-              run :: (Cxt h f) a :=> b ->  b+              run :: (Cxt h f) a :=> (b ->  b)               run (Hole a) e = a `op` e               run (Term t) e = hfoldr run e t