packages feed

compdata-param 0.9 → 0.9.1

raw patch · 15 files changed

+191/−134 lines, 15 filesdep ~compdata

Dependency ranges changed: compdata

Files

compdata-param.cabal view
@@ -1,5 +1,5 @@ Name:			compdata-param-Version:		0.9+Version:		0.9.1 Synopsis:            	Parametric Compositional Data Types Description: @@ -79,6 +79,7 @@                         Data.Comp.Param.Derive.SmartAConstructors                         Data.Comp.Param.Derive.Injections                         Data.Comp.Param.Derive.Projections+                        Data.Comp.Param.Derive.Utils                          Data.Comp.Param.Multi.Derive.HDifunctor                         Data.Comp.Param.Multi.Derive.Equality@@ -89,7 +90,7 @@                         Data.Comp.Param.Multi.Derive.Injections                         Data.Comp.Param.Multi.Derive.Projections -  Build-Depends:	base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.10 && < 0.11+  Build-Depends:	base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.10.1 && < 0.11   hs-source-dirs:	src   ghc-options:          -W @@ -98,7 +99,7 @@   Type:                 exitcode-stdio-1.0   Main-is:		Tests.hs   hs-source-dirs:	testsuite/tests examples-  Build-Depends:        base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.10 && < 0.11, HUnit,+  Build-Depends:        base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.10.1 && < 0.11, HUnit,                         test-framework, test-framework-hunit, containers, compdata-param  source-repository head
src/Data/Comp/Param/Derive/Difunctor.hs view
@@ -19,6 +19,7 @@     ) where  import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Data.Comp.Param.Difunctor import Language.Haskell.TH @@ -29,11 +30,11 @@   -- Comments below apply to the example where name = T, args = [a,b,c], and   -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type   -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname   -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args+  let coArg :: Type = VarT $ tyVarBndrName $ last args   -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args   -- argNames = [a]   let argNames = map (VarT . tyVarBndrName) (init $ init args)   -- compType = T a@@ -41,11 +42,11 @@   -- classType = Difunctor (T a)   let classType = AppT (ConT ''Difunctor) complType   -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs   dimapDecl <- funD 'dimap (map (dimapClause conArg coArg) constrs')-  return [InstanceD [] classType [dimapDecl]]-      where dimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            dimapClause conArg coArg (constr, args) = do+  return [mkInstanceD [] classType [dimapDecl]]+      where dimapClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            dimapClause conArg' coArg' (constr, args, gadtTy) = do               fn <- newName "_f"               gn <- newName "_g"               varNs <- newNames (length args) "x"@@ -55,9 +56,10 @@               let gp = VarP gn               -- Pattern for the constructor               let pat = ConP constr $ map VarP varNs+              let (conArg, coArg) = getBinaryFArgs conArg' coArg' gadtTy               body <- dimapArgs conArg coArg f g (zip varNs args) (conE constr)               return $ Clause [fp, gp, pat] (NormalB body) []-            dimapArgs :: Name -> Name -> ExpQ -> ExpQ+            dimapArgs :: Type -> Type -> ExpQ -> ExpQ                       -> [(Name, Type)] -> ExpQ -> ExpQ             dimapArgs _ _ _ _ [] acc =                 acc@@ -69,14 +71,14 @@             -- to the parameter of the given type.             -- Example: dimapArg a b (a -> b) f g yields the expression             -- [|\x -> g . x . f|]-            dimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ+            dimapArg :: Type -> Type -> Type -> ExpQ -> ExpQ -> ExpQ             dimapArg conArg coArg tp f g-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) = [| id |]+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) = [| id |]                 | otherwise =                     case tp of-                      VarT a | a == conArg -> f-                             | a == coArg -> g+                      a | a == conArg -> f+                        | a == coArg -> g                       AppT (AppT ArrowT tp1) tp2 -> do                           xn <- newName "x"                           let ftp1 = dimapArg conArg coArg tp1 f g@@ -90,7 +92,7 @@                       SigT tp' _ ->                           dimapArg conArg coArg tp' f g                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| dimap $f $g |]                           else                               [| fmap $g |]
src/Data/Comp/Param/Derive/Ditraversable.hs view
@@ -19,6 +19,7 @@     ) where  import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Data.Comp.Param.Ditraversable import Data.Traversable (mapM) import Language.Haskell.TH@@ -38,20 +39,21 @@   first-order kind taking at least one argument. -} makeDitraversable :: Name -> Q [Dec] makeDitraversable 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       aArg = VarT . tyVarBndrName $ last (init args)-      funTy = foldl AppT ArrowT [aArg,fArg]       argNames = map (VarT . tyVarBndrName) (init $ init args)       complType = foldl AppT (ConT name) argNames       classType = foldl1 AppT [ConT ''Ditraversable, complType]   normConstrs <- mapM normalConExp constrs-  constrs' <- mapM (mkPatAndVars . isFarg fArg funTy) normConstrs+  constrs' <- mapM (mkPatAndVars . isFarg aArg fArg) normConstrs   mapMDecl <- funD 'dimapM (map mapMClause constrs')   sequenceDecl <- funD 'disequence (map sequenceClause constrs')-  return [InstanceD [] classType [mapMDecl,sequenceDecl]]-      where isFarg fArg funTy (constr, args) =-                (constr, map (\t -> (t `containsType'` fArg, t `containsType'` funTy)) args)+  return [mkInstanceD [] classType [mapMDecl,sequenceDecl]]+      where isFarg aArg' fArg' (constr, args, gadtTy) =+              let (aArg, fArg) = getBinaryFArgs aArg' fArg' gadtTy+                  funTy = foldl AppT ArrowT [aArg,fArg]+              in (constr, map (\t -> (t `containsType'` fArg, t `containsType'` funTy)) args)             filterVar _ _ nonFarg ([],[]) x  = nonFarg x             filterVar farg _ _ ([depth],[]) x = farg depth x             filterVar _ aarg _ ([_],[depth]) x = aarg depth x
src/Data/Comp/Param/Derive/Equality.hs view
@@ -19,6 +19,7 @@     ) where  import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Data.Comp.Param.FreshM hiding (Name) import Data.Comp.Param.Equality import Control.Monad@@ -31,11 +32,11 @@   -- Comments below apply to the example where name = T, args = [a,b,c], and   -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type   -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname   -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args+  let coArg :: Type = VarT $ tyVarBndrName $ last args   -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args   -- argNames = [a]   let argNames = map (VarT . tyVarBndrName) (init $ init args)   -- compType = T a@@ -43,42 +44,43 @@   -- classType = Difunctor (T a)   let classType = AppT (ConT ''EqD) complType   -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type],Maybe Type)] <- mapM normalConExp constrs   let defC = if length constrs < 2 then                  []              else                  [clause [wildP,wildP] (normalB [|return False|]) []]   eqDDecl <- funD 'eqD (map (eqDClause conArg coArg) constrs' ++ defC)   let context = map (\arg -> mkClassP ''Eq [arg]) argNames-  return [InstanceD context classType [eqDDecl]]-      where eqDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            eqDClause conArg coArg (constr, args) = do+  return [mkInstanceD context classType [eqDDecl]]+      where eqDClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            eqDClause conArg' coArg' (constr, args, gadtTy) = do               varXs <- newNames (length args) "x"               varYs <- newNames (length args) "y"               -- Patterns for the constructors               let patx = ConP constr $ map VarP varXs               let paty = ConP constr $ map VarP varYs+              let (conArg, coArg) = getBinaryFArgs conArg' coArg' gadtTy               body <- eqDBody conArg coArg (zip3 varXs varYs args)               return $ Clause [patx,paty] (NormalB body) []-            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ+            eqDBody :: Type -> Type -> [(Name, Name, Type)] -> ExpQ             eqDBody conArg coArg x =                 [|liftM and (sequence $(listE $ map (eqDB conArg coArg) x))|]-            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ+            eqDB :: Type -> Type -> (Name, Name, Type) -> ExpQ             eqDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) =                     [| return $ $(varE x) == $(varE y) |]                 | otherwise =                     case tp of-                      VarT a+                      a                           | a == coArg -> [| peq $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (VarT a)) _+                      AppT (AppT ArrowT a) _                           | a == conArg ->                               [| withName (\v -> peq ($(varE x) v) ($(varE y) v)) |]                       SigT tp' _ ->                           eqDB conArg coArg (x, y, tp')                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| eqD $(varE x) $(varE y) |]                           else                               [| peq $(varE x) $(varE y) |]
src/Data/Comp/Param/Derive/Ordering.hs view
@@ -21,6 +21,7 @@ import Data.Comp.Param.FreshM hiding (Name) import Data.Comp.Param.Ordering import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Language.Haskell.TH hiding (Cxt) import Control.Monad (liftM) @@ -31,11 +32,11 @@   -- Comments below apply to the example where name = T, args = [a,b,c], and   -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type   -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname   -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args+  let coArg :: Type = VarT $ tyVarBndrName $ last args   -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args   -- argNames = [a]   let argNames = map (VarT . tyVarBndrName) (init $ init args)   -- compType = T a@@ -43,11 +44,11 @@   -- classType = Difunctor (T a)   let classType = AppT (ConT ''OrdD) complType   -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs   compareDDecl <- funD 'compareD (compareDClauses conArg coArg constrs')   let context = map (\arg -> mkClassP ''Ord [arg]) argNames-  return [InstanceD context classType [compareDDecl]]-      where compareDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ]+  return [mkInstanceD context classType [compareDDecl]]+      where compareDClauses :: Type -> Type -> [(Name,[Type], Maybe Type)] -> [ClauseQ]             compareDClauses _ _ [] = []             compareDClauses conArg coArg constrs =                  let constrs' = constrs `zip` [1..]@@ -57,37 +58,38 @@                 | n == m = genEqClause conArg coArg c                 | n < m = genLtClause c d                 | otherwise = genGtClause c d-            genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            genEqClause conArg coArg (constr, args) = do +            genEqClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            genEqClause conArg' 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+              let (conArg, coArg) = getBinaryFArgs conArg' coArg' gadtTy               body <- eqDBody conArg coArg (zip3 varXs varYs args)               return $ Clause [patX, patY] (NormalB body) []-            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ+            eqDBody :: Type -> Type -> [(Name, Name, Type)] -> ExpQ             eqDBody conArg coArg x =                 [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|]-            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ+            eqDB :: Type -> Type -> (Name, Name, Type) -> ExpQ             eqDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) =                     [| return $ compare $(varE x) $(varE y) |]                 | otherwise =                     case tp of-                      VarT a+                      a                           | a == coArg -> [| pcompare $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (VarT a)) _+                      AppT (AppT ArrowT a) _                           | a == conArg ->                               [| withName (\v -> pcompare ($(varE x) v) ($(varE y) v)) |]                       SigT tp' _ ->                           eqDB conArg coArg (x, y, tp')                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| compareD $(varE x) $(varE y) |]                           else                               [| pcompare $(varE x) $(varE y) |]-            genLtClause (c, _) (d, _) =+            genLtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| return LT |]) []-            genGtClause (c, _) (d, _) =+            genGtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| return GT |]) []
src/Data/Comp/Param/Derive/Show.hs view
@@ -19,6 +19,7 @@     ) where  import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Data.Comp.Param.FreshM hiding (Name) import qualified Data.Comp.Param.FreshM as FreshM import Control.Monad@@ -42,11 +43,11 @@   -- Comments below apply to the example where name = T, args = [a,b,c], and   -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type   -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname   -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args+  let coArg :: Type = VarT $ tyVarBndrName $ last args   -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args   -- argNames = [a]   let argNames = map (VarT . tyVarBndrName) (init $ init args)   -- compType = T a@@ -54,39 +55,40 @@   -- classType = Difunctor (T a)   let classType = AppT (ConT ''ShowD) complType   -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs   showDDecl <- funD 'showD (map (showDClause conArg coArg) constrs')   let context = map (\arg -> mkClassP ''Show [arg]) argNames-  return [InstanceD context classType [showDDecl]]-      where showDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            showDClause conArg coArg (constr, args) = do+  return [mkInstanceD context classType [showDDecl]]+      where showDClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            showDClause conArg' coArg' (constr, args, gadtTy) = do               varXs <- newNames (length args) "x"               -- Pattern for the constructor               let patx = ConP constr $ map VarP varXs+              let (conArg, coArg) = getBinaryFArgs conArg' coArg' gadtTy               body <- showDBody (nameBase constr) conArg coArg (zip varXs args)               return $ Clause [patx] (NormalB body) []-            showDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ+            showDBody :: String -> Type -> Type -> [(Name, Type)] -> ExpQ             showDBody constr conArg coArg x =                 [|liftM (unwords . (constr :) .                          map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x))                         (sequence $(listE $ map (showDB conArg coArg) x))|]-            showDB :: Name -> Name -> (Name, Type) -> ExpQ+            showDB :: Type -> Type -> (Name, Type) -> ExpQ             showDB conArg coArg (x, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) =                     [| return $ show $(varE x) |]                 | otherwise =                     case tp of-                      VarT a+                      a                           | a == coArg -> [| $(varE x) |]-                      AppT (AppT ArrowT (VarT a)) _+                      AppT (AppT ArrowT a) _                           | a == conArg ->                               [| withName (\v -> do body <- $(varE x) v;                                                     return $ "\\" ++ show v ++ " -> " ++ body) |]                       SigT tp' _ ->                           showDB conArg coArg (x, tp')                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| showD $(varE x) |]                           else                               [| liftM show $ T.mapM (liftM Dummy) $(varE x) |]
src/Data/Comp/Param/Derive/SmartAConstructors.hs view
@@ -30,7 +30,7 @@  'injectA . dimap Var id' is automatically 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
src/Data/Comp/Param/Derive/SmartConstructors.hs view
@@ -29,7 +29,7 @@  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
+ src/Data/Comp/Param/Derive/Utils.hs view
@@ -0,0 +1,34 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Param.Derive.Utils+-- Copyright   :  (c) 2016 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines some utility functions for deriving instances+-- for functor based type classes.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.Derive.Utils where++import Language.Haskell.TH++-- | Auxiliary function to extract the first and second argument of a+-- binary type application (the third argument of this function). If+-- the second argument is @Nothing@ or not of the right shape, the+-- first two arguments are returned as a default.++getBinaryFArgs :: Type -> Type -> Maybe Type -> (Type,Type)+getBinaryFArgs _ _ (Just (AppT (AppT _ t1)  t2)) = (t1, t2)+getBinaryFArgs t1 t2 _ = (t1, t2)++-- | Auxiliary function to extract the first and second argument of a+-- ternary type application (the third argument of this function). If+-- the second argument is @Nothing@ or not of the right shape, the+-- first two arguments are returned as a default.++getTernaryFArgs :: Type -> Type -> Maybe Type -> (Type,Type)+getTernaryFArgs _ _ (Just (AppT (AppT (AppT _ t1)  t2) _) ) = (t1, t2)+getTernaryFArgs t1 t2 _ = (t1, t2)
src/Data/Comp/Param/Multi/Derive/Equality.hs view
@@ -19,6 +19,7 @@     ) where  import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Data.Comp.Param.Multi.FreshM hiding (Name) import Data.Comp.Param.Multi.Equality import Control.Monad@@ -28,51 +29,52 @@   kind taking at least three arguments. -} makeEqHD :: Name -> Q [Dec] makeEqHD 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'   -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args'   let argNames = map (VarT . tyVarBndrName) (init $ init args')   let complType = foldl AppT (ConT name) argNames   let classType = AppT (ConT ''EqHD) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs   let defC = if length constrs < 2 then                  []              else                  [clause [wildP,wildP] (normalB [|return False|]) []]   eqHDDecl <- funD 'eqHD (map (eqHDClause conArg coArg) constrs' ++ defC)   let context = map (\arg -> mkClassP ''Eq [arg]) argNames-  return [InstanceD context classType [eqHDDecl]]-      where eqHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            eqHDClause conArg coArg (constr, args) = do+  return [mkInstanceD context classType [eqHDDecl]]+      where eqHDClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            eqHDClause conArg' coArg' (constr, args, gadtTy) = do               varXs <- newNames (length args) "x"               varYs <- newNames (length args) "y"               -- Patterns for the constructors               let patx = ConP constr $ map VarP varXs               let paty = ConP constr $ map VarP varYs+              let (conArg, coArg) = getTernaryFArgs conArg' coArg' gadtTy               body <- eqHDBody conArg coArg (zip3 varXs varYs args)               return $ Clause [patx,paty] (NormalB body) []-            eqHDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ+            eqHDBody :: Type -> Type -> [(Name, Name, Type)] -> ExpQ             eqHDBody conArg coArg x =                 [|liftM and (sequence $(listE $ map (eqHDB conArg coArg) x))|]-            eqHDB :: Name -> Name -> (Name, Name, Type) -> ExpQ+            eqHDB :: Type -> Type -> (Name, Name, Type) -> ExpQ             eqHDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) =                     [| return $ $(varE x) == $(varE y) |]                 | otherwise =                     case tp of-                      AppT (VarT a) _ +                      AppT a _                            | a == coArg -> [| peq $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (AppT (VarT a) _)) _+                      AppT (AppT ArrowT (AppT a _)) _                           | a == conArg ->                               [| withName (\v -> peq ($(varE x) $ nameCoerce v)                                                      ($(varE y) $ nameCoerce v)) |]                       SigT tp' _ ->                           eqHDB conArg coArg (x, y, tp')                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| eqHD $(varE x) $(varE y) |]                           else                               [| peq $(varE x) $(varE y) |]
src/Data/Comp/Param/Multi/Derive/HDifunctor.hs view
@@ -19,6 +19,7 @@     ) where  import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Data.Comp.Param.Multi.HDifunctor import Language.Haskell.TH @@ -26,20 +27,20 @@   kind taking at least three arguments. -} makeHDifunctor :: Name -> Q [Dec] makeHDifunctor 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'   -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args'   let argNames = map (VarT . tyVarBndrName) (init $ init args')   let complType = foldl AppT (ConT name) argNames   let classType = AppT (ConT ''HDifunctor) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs   hdimapDecl <- funD 'hdimap (map (hdimapClause conArg coArg) constrs')-  return [InstanceD [] classType [hdimapDecl]]-      where hdimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            hdimapClause conArg coArg (constr, args) = do+  return [mkInstanceD [] classType [hdimapDecl]]+      where hdimapClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            hdimapClause conArg' coArg' (constr, args, gadtTy) = do               fn <- newName "_f"               gn <- newName "_g"               varNs <- newNames (length args) "x"@@ -49,23 +50,24 @@               let gp = VarP gn               -- Pattern for the constructor               let pat = ConP constr $ map VarP varNs+              let (conArg, coArg) = getTernaryFArgs conArg' coArg' gadtTy               body <- hdimapArgs conArg coArg f g (zip varNs args) (conE constr)               return $ Clause [fp, gp, pat] (NormalB body) []-            hdimapArgs :: Name -> Name -> ExpQ -> ExpQ+            hdimapArgs :: Type -> Type -> ExpQ -> ExpQ                       -> [(Name, Type)] -> ExpQ -> ExpQ             hdimapArgs _ _ _ _ [] acc =                 acc             hdimapArgs conArg coArg f g ((x,tp):tps) acc =                 hdimapArgs conArg coArg f g tps                           (acc `appE` (hdimapArg conArg coArg tp f g `appE` varE x))-            hdimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ+            hdimapArg :: Type -> Type -> Type -> ExpQ -> ExpQ -> ExpQ             hdimapArg conArg coArg tp f g-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) = [| id |]+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) = [| id |]                 | otherwise =                     case tp of-                      AppT (VarT a) _ | a == conArg -> f-                                      | a == coArg -> g+                      AppT a _ | a == conArg -> f+                               | a == coArg -> g                       AppT (AppT ArrowT tp1) tp2 -> do                           xn <- newName "x"                           let ftp1 = hdimapArg conArg coArg tp1 f g@@ -79,7 +81,7 @@                       SigT tp' _ ->                           hdimapArg conArg coArg tp' f g                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| hdimap $f $g |]                           else                               [| fmap $g |]
src/Data/Comp/Param/Multi/Derive/Ordering.hs view
@@ -21,6 +21,7 @@ import Data.Comp.Param.Multi.FreshM hiding (Name) import Data.Comp.Param.Multi.Ordering import Data.Comp.Derive.Utils+import Data.Comp.Param.Derive.Utils import Data.Maybe import Data.List import Language.Haskell.TH hiding (Cxt)@@ -33,20 +34,20 @@   kind taking at least three arguments. -} makeOrdHD :: Name -> Q [Dec] makeOrdHD 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'   -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args'   let argNames = map (VarT . tyVarBndrName) (init $ init args')   let complType = foldl AppT (ConT name) argNames   let classType = AppT (ConT ''OrdHD) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs   compareHDDecl <- funD 'compareHD (compareHDClauses conArg coArg constrs')   let context = map (\arg -> mkClassP ''Ord [arg]) argNames-  return [InstanceD context classType [compareHDDecl]]-      where compareHDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ]+  return [mkInstanceD context classType [compareHDDecl]]+      where compareHDClauses :: Type -> Type -> [(Name,[Type], Maybe Type)] -> [ClauseQ]             compareHDClauses _ _ [] = []             compareHDClauses conArg coArg constrs =                  let constrs' = constrs `zip` [1..]@@ -56,38 +57,39 @@                 | n == m = genEqClause conArg coArg c                 | n < m = genLtClause c d                 | otherwise = genGtClause c d-            genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            genEqClause conArg coArg (constr, args) = do +            genEqClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            genEqClause conArg' 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+              let (conArg, coArg) = getTernaryFArgs conArg' coArg' gadtTy               body <- eqDBody conArg coArg (zip3 varXs varYs args)               return $ Clause [patX, patY] (NormalB body) []-            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ+            eqDBody :: Type -> Type -> [(Name, Name, Type)] -> ExpQ             eqDBody conArg coArg x =                 [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|]-            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ+            eqDB :: Type -> Type -> (Name, Name, Type) -> ExpQ             eqDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) =                     [| return $ compare $(varE x) $(varE y) |]                 | otherwise =                     case tp of-                      AppT (VarT a) _ +                      AppT a _                            | a == coArg -> [| pcompare $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (AppT (VarT a) _)) _+                      AppT (AppT ArrowT (AppT a _)) _                           | a == conArg ->                               [| withName (\v -> pcompare ($(varE x) $ nameCoerce v)                                                           ($(varE y) $ nameCoerce v)) |]                       SigT tp' _ ->                           eqDB conArg coArg (x, y, tp')                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| compareHD $(varE x) $(varE y) |]                           else                               [| pcompare $(varE x) $(varE y) |]-            genLtClause (c, _) (d, _) =+            genLtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| return LT |]) []-            genGtClause (c, _) (d, _) =+            genGtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| return GT |]) []
src/Data/Comp/Param/Multi/Derive/Show.hs view
@@ -18,6 +18,7 @@      makeShowHD     ) where +import Data.Comp.Param.Derive.Utils import Data.Comp.Derive.Utils import Data.Comp.Param.Multi.FreshM hiding (Name) import qualified Data.Comp.Param.Multi.FreshM as FreshM@@ -40,48 +41,49 @@   kind taking at least three arguments. -} makeShowHD :: Name -> Q [Dec] makeShowHD 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'   -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'+  let conArg :: Type = VarT $ tyVarBndrName $ last $ init args'   let argNames = map (VarT . tyVarBndrName) (init $ init args')   let complType = foldl AppT (ConT name) argNames   let classType = AppT (ConT ''ShowHD) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type], Maybe Type)] <- mapM normalConExp constrs   showHDDecl <- funD 'showHD (map (showHDClause conArg coArg) constrs')   let context = map (\arg -> mkClassP ''Show [arg]) argNames-  return [InstanceD context classType [showHDDecl]]-      where showHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            showHDClause conArg coArg (constr, args) = do+  return [mkInstanceD context classType [showHDDecl]]+      where showHDClause :: Type -> Type -> (Name,[Type], Maybe Type) -> ClauseQ+            showHDClause conArg' coArg' (constr, args, gadtTy) = do               varXs <- newNames (length args) "x"               -- Pattern for the constructor               let patx = ConP constr $ map VarP varXs+              let (conArg, coArg) = getBinaryFArgs conArg' coArg' gadtTy               body <- showHDBody (nameBase constr) conArg coArg (zip varXs args)               return $ Clause [patx] (NormalB body) []-            showHDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ+            showHDBody :: String -> Type -> Type -> [(Name, Type)] -> ExpQ             showHDBody constr conArg coArg x =                 [|liftM (unwords . (constr :) .                          map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x))                         (sequence $(listE $ map (showHDB conArg coArg) x))|]-            showHDB :: Name -> Name -> (Name, Type) -> ExpQ+            showHDB :: Type -> Type -> (Name, Type) -> ExpQ             showHDB conArg coArg (x, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =+                | not (containsType tp conArg) &&+                  not (containsType tp coArg) =                     [| return $ show $(varE x) |]                 | otherwise =                     case tp of-                      AppT (VarT a) _ +                      AppT a _                            | a == coArg -> [| unK $(varE x) |]-                      AppT (AppT ArrowT (AppT (VarT a) _)) _+                      AppT (AppT ArrowT (AppT a _)) _                           | a == conArg ->                               [| withName (\v -> do body <- (unK . $(varE x)) v                                                     return $ "\\" ++ show v ++ " -> " ++ body) |]                       SigT tp' _ ->                           showHDB conArg coArg (x, tp')                       _ ->-                          if containsType tp (VarT conArg) then+                          if containsType tp conArg then                               [| showHD $(varE x) |]                           else                               [| liftM show $ T.mapM (liftM Dummy . unK) $(varE x) |]
src/Data/Comp/Param/Multi/Derive/SmartAConstructors.hs view
@@ -31,7 +31,7 @@  'injectA . hdimap Var id' is automatically 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
src/Data/Comp/Param/Multi/Derive/SmartConstructors.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, CPP #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Param.Multi.Derive.SmartConstructors@@ -30,14 +30,18 @@  'inject . hdimap Var id' 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-        where iTp iVar (ForallC _ cxt _) =+        where iTp iVar (ForallC _ cxt constr) =                   -- Check if the GADT phantom type is constrained                   case [y | Just (x, y) <- map isEqualP cxt, x == VarT iVar] of-                    [] -> Nothing+                    [] -> case constr of+#if __GLASGOW_HASKELL__ >= 800+                      GadtC _ _ (AppT _ tp) -> Just tp+#endif+                      _ -> Nothing                     tp:_ -> Just tp               iTp _ _ = Nothing               genSmartConstr targs tname ((name, args), miTp) = do