compdata 0.11 → 0.12

raw patch · 37 files changed

+145/−142 lines, 37 filesdep −derivedep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies removed: derive

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• benchmark/Benchmark.hs +3/−3
• benchmark/DataTypes.hs +5/−8
• benchmark/DataTypes/Comp.hs +10/−3
• benchmark/DataTypes/Standard.hs +10/−11
• benchmark/Functions/Comp/Eval.hs +18/−14
• benchmark/Functions/Standard/FreeVars.hs +1/−1
• benchmark/Functions/Standard/Inference.hs +6/−3
• compdata.cabal +16/−8
• examples/Examples/Desugar.hs +1/−1
• examples/Examples/Eval.hs +3/−3
• examples/Examples/EvalM.hs +3/−3
• examples/Examples/Multi/Eval.hs +3/−3
• examples/Examples/Multi/EvalM.hs +3/−3
• examples/Examples/Simple.hs +20/−0
• src/Data/Comp/Algebra.hs +1/−9
• src/Data/Comp/Arbitrary.hs +0/−1
• src/Data/Comp/Decompose.hs +11/−12
• src/Data/Comp/Derive.hs +1/−6
• src/Data/Comp/Derive/Arbitrary.hs +1/−7
• src/Data/Comp/Derive/SmartConstructors.hs +1/−1
• src/Data/Comp/Derive/Utils.hs +10/−5
• src/Data/Comp/Desugar.hs +2/−3
• src/Data/Comp/Multi/Derive/SmartConstructors.hs +1/−1
• src/Data/Comp/Multi/Desugar.hs +2/−3
• src/Data/Comp/Multi/HFunctor.hs +0/−2
• src/Data/Comp/Multi/HTraversable.hs +1/−1
• src/Data/Comp/Multi/Ops.hs +1/−1
• src/Data/Comp/Multi/Term.hs +2/−2
• src/Data/Comp/Multi/Variables.hs +3/−3
• src/Data/Comp/Sum.hs +0/−1
• src/Data/Comp/Unification.hs +0/−2
• src/Data/Comp/Variables.hs +2/−3
• testsuite/tests/Data/Comp/Equality_Test.hs +4/−5
• testsuite/tests/Data/Comp/Examples/Comp.hs +0/−4
• testsuite/tests/Data/Comp/Examples/Multi.hs +0/−1
• testsuite/tests/Data/Comp/Examples_Test.hs +0/−3
• testsuite/tests/Test/Utils.hs +0/−2

@@ -12,8 +12,8 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen import Test.QuickCheck.Random-import System.Random + aExpr :: SugarExpr aExpr = iIf ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))             `iOr` ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))))@@ -42,8 +42,8 @@     where depth = 15  standardBenchmarks :: (PExpr, SugarExpr, String) -> Benchmark-standardBenchmarks  (sExpr,aExpr,n) = rnf aExpr `seq` rnf sExpr `seq` getBench (sExpr, aExpr,n)-    where getBench (sExpr, aExpr,n) = bgroup n paperBenchmarks+standardBenchmarks  (sExpr,aExpr,n) = rnf aExpr `seq` rnf sExpr `seq` getBench n+    where getBench n = bgroup n paperBenchmarks           -- these are the benchmarks for evaluation           evalBenchmarks = [                  bench "evalDesug" (nf A.desugEval2 aExpr),

@@ -1,14 +1,11 @@-{-# LANGUAGE TypeSynonymInstances, CPP #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}  module DataTypes where +import Control.Monad.Fail++ type Err = Either String -#if __GLASGOW_HASKELL__ < 700-instance Monad Err where-    return = Right-    e >>= f = case e of -                Left m -> Left m-                Right x -> f x+instance MonadFail Err where     fail  = Left-#endif

@@ -8,7 +8,8 @@   ScopedTypeVariables,   TypeSynonymInstances,   DeriveFunctor,-  ConstraintKinds #-}+  ConstraintKinds,+  DeriveGeneric, DeriveAnyClass #-}  module DataTypes.Comp      ( module DataTypes.Comp,@@ -28,6 +29,8 @@ import Control.Monad hiding (sequence_,mapM) import Prelude hiding (sequence_,mapM) +import GHC.Generics (Generic)+ -- base values  type ValueSig = Value@@ -39,6 +42,8 @@ type BaseTypeSig = ValueT type BaseType = Term BaseTypeSig ++ data ValueT e = TInt               | TBool               | TPair e e@@ -50,7 +55,7 @@                deriving (Eq, Functor)  data Proj = ProjLeft | ProjRight-            deriving (Eq)+            deriving (Eq, Generic, NFData)  data Op e = Plus e e           | Mult e e@@ -69,7 +74,9 @@              | Impl e e                deriving (Eq, Functor) -$(derive [makeNFData, makeArbitrary] [''Proj])++instance Arbitrary Proj where+  arbitrary = elements [ProjLeft,ProjRight]  $(derive   [makeFoldable, makeTraversable,

@@ -1,12 +1,13 @@-{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, DeriveDataTypeable,+DeriveGeneric, DeriveAnyClass #-} module DataTypes.Standard      ( module DataTypes.Standard,       module DataTypes      ) where +import GHC.Generics (Generic)+ import DataTypes-import Data.Derive.NFData-import Data.DeriveTH import Data.Data import Control.DeepSeq @@ -15,15 +16,15 @@ data VType = VTInt            | VTBool            | VTPair VType VType-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data SExpr = SInt Int            | SBool Bool            | SPair SExpr SExpr-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data SProj = SProjLeft | SProjRight-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data OExpr = OInt Int            | OBool Bool@@ -36,7 +37,7 @@            | OAnd OExpr OExpr            | ONot OExpr            | OProj SProj OExpr-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data PExpr = PInt Int            | PBool Bool@@ -54,13 +55,13 @@            | PGt PExpr PExpr            | POr PExpr PExpr            | PImpl PExpr PExpr-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data VHType = VHTInt             | VHTBool             | VHTPair VType VType             | VHTFun VType VType-              deriving (Eq,Typeable,Data)+              deriving (Eq,Typeable,Data, Generic, NFData)  showBinOp :: String -> String -> String -> String showBinOp op x y = "("++ x ++ op ++ y ++ ")"@@ -88,5 +89,3 @@     show VTInt = "Int"     show VTBool = "Bool"     show (VTPair x y) = "(" ++ show x ++ "," ++ show y ++ ")"--$(derives [makeNFData] [''SProj,''SExpr,''OExpr,''PExpr,''VType])

@@ -16,8 +16,12 @@ import Data.Comp import Data.Comp.Thunk hiding (eval, eval2) import Data.Comp.Derive-import Control.Monad +import Control.Monad.Fail+import Prelude hiding (fail)+import Control.Monad hiding (fail)++ -- evaluation with thunks  class (Monad m, Traversable v) => EvalT e v m where@@ -31,7 +35,7 @@ instance (Monad m, Traversable v, Value :<: m :+: v) => EvalT Value v m where     evalTAlg = inject -instance (Value :<: (m :+: v), Value :<: v, Traversable v, EqF v, Monad m) => EvalT Op v m where+instance (Value :<: (m :+: v), Value :<: v, Traversable v, EqF v, MonadFail m) => EvalT Op v m where     evalTAlg (Plus x y) = thunk $ do                            VInt i <- whnfPr x                            VInt j <- whnfPr y@@ -64,7 +68,7 @@                               ProjLeft -> x                               ProjRight -> y -instance (Value :<: (m :+: v), Value :<: v, Traversable v, Monad m) => EvalT Sugar v m where+instance (Value :<: (m :+: v), Value :<: v, Traversable v, MonadFail m) => EvalT Sugar v m where     evalTAlg (Neg x) = thunk $ do                          VInt i <- whnfPr x                          return $ iVInt (-i)@@ -101,22 +105,22 @@ instance (Value :<: v, Monad m) => Eval Value v m where     evalAlg = return . inject -coerceInt :: (Value :<: v, Monad m) => Term v -> m Int+coerceInt :: (Value :<: v, MonadFail m) => Term v -> m Int coerceInt t = case project t of                 Just (VInt i) -> return i                 _ -> fail "" -coerceBool :: (Value :<: v, Monad m) => Term v -> m Bool+coerceBool :: (Value :<: v, MonadFail m) => Term v -> m Bool coerceBool t = case project t of                 Just (VBool b) -> return b                 _ -> fail "" -coercePair :: (Value :<: v, Monad m) => Term v -> m (Term v, Term v)+coercePair :: (Value :<: v, MonadFail m) => Term v -> m (Term v, Term v) coercePair t = case project t of                 Just (VPair x y) -> return (x,y)                 _ -> fail "" -instance (Value :<: v, EqF v, Monad m) => Eval Op v m where+instance (Value :<: v, EqF v, MonadFail m) => Eval Op v m where     evalAlg (Plus x y) = liftM2 (\ i j -> iVInt (i + j)) (coerceInt x) (coerceInt y)     evalAlg (Mult x y) = liftM2 (\ i j -> iVInt (i * j)) (coerceInt x) (coerceInt y)     evalAlg (If b x y) = liftM select (coerceBool b)@@ -130,7 +134,7 @@                                ProjLeft -> x                                ProjRight -> y -instance (Value :<: v, Monad m) => Eval Sugar v m where+instance (Value :<: v, MonadFail m) => Eval Sugar v m where     evalAlg (Neg x) = liftM (iVInt . negate) (coerceInt x)     evalAlg (Minus x y) = liftM2 (\ i j -> iVInt (i - j)) (coerceInt x) (coerceInt y)     evalAlg (Gt x y) = liftM2 (\ i j -> iVBool (i > j)) (coerceInt x) (coerceInt y)@@ -140,18 +144,18 @@  -- direct evaluation -class Monad m => EvalDir e m where+class MonadFail m => EvalDir e m where     evalDir :: (Traversable f, EvalDir f m) => e (Term f) -> m ValueExpr  evalDirect :: (Traversable e, EvalDir e m) => Term e -> m ValueExpr-evalDirect = evalDir . unTerm+evalDirect (Term x) = evalDir x  evalDirectE :: SugarExpr -> Err ValueExpr evalDirectE = evalDirect  $(derive [liftSum] [''EvalDir]) -instance (Monad m) => EvalDir Value m where+instance (MonadFail m) => EvalDir Value m where     evalDir (VInt i) = return $ iVInt i     evalDir (VBool i) = return $ iVBool i     evalDir (VPair x y) = liftM2 iVPair (evalDirect x) (evalDirect y)@@ -178,7 +182,7 @@     Just (VPair x y) -> return (x,y)     _ -> fail "" -instance (Monad m) => EvalDir Op m where+instance (MonadFail m) => EvalDir Op m where     evalDir (Plus x y) = liftM2 (\ i j -> iVInt (i + j)) (evalInt x) (evalInt y)     evalDir (Mult x y) = liftM2 (\ i j -> iVInt (i * j)) (evalInt x) (evalInt y)     evalDir (If b x y) = do @@ -193,7 +197,7 @@                                ProjLeft -> x                                ProjRight -> y -instance (Monad m) => EvalDir Sugar m where+instance (MonadFail m) => EvalDir Sugar m where     evalDir (Neg x) = liftM (iVInt . negate) (evalInt x)     evalDir (Minus x y) = liftM2 (\ i j -> iVInt (i - j)) (evalInt x) (evalInt y)     evalDir (Gt x y) = liftM2 (\ i j -> iVBool (i > j)) (evalInt x) (evalInt y)@@ -258,7 +262,7 @@     evalDir2 :: (EvalDir2 f) => e (Term f) -> ValueExpr  evalDirect2 :: (EvalDir2 e) => Term e -> ValueExpr-evalDirect2 = evalDir2 . unTerm+evalDirect2 (Term x) = evalDir2 x  evalDirectE2 :: SugarExpr -> ValueExpr evalDirectE2 = evalDirect2

@@ -1,7 +1,7 @@ module Functions.Standard.FreeVars where  import DataTypes.Standard-import Data.Generics.PlateDirect+import Data.Generics.Uniplate.Direct  instance Uniplate PExpr where     uniplate (PInt x) = plate PInt |- x

@@ -1,17 +1,20 @@ module Functions.Standard.Inference where ++import Control.Monad.Fail import DataTypes.Standard-import Control.Monad+import Prelude hiding (fail)+import Control.Monad hiding (fail) import Functions.Standard.Desugar -checkOp :: (Monad m) => [VType] -> VType -> [OExpr] -> m VType+checkOp :: (MonadFail m) => [VType] -> VType -> [OExpr] -> m VType checkOp tys rety args = do    argsty <- mapM inferType args   if tys == argsty      then return rety      else fail "" -inferType :: (Monad m) => OExpr -> m VType+inferType :: (MonadFail m) => OExpr -> m VType inferType (OInt _) = return VTInt inferType (OBool _) = return VTBool inferType (OPair x y) = liftM2 VTPair (inferType x) (inferType y)

@@ -1,5 +1,5 @@ Name:			compdata-Version:		0.11+Version:		0.12 Synopsis:            	Compositional Data Types Description: @@ -96,7 +96,7 @@ License:                BSD3 License-file:           LICENSE Author:                 Patrick Bahr, Tom Hvitved-Maintainer:             paba@diku.dk+Maintainer:             paba@itu.dk Build-Type:             Simple Cabal-Version:          >=1.9.2 bug-reports:            https://github.com/pa-ba/compdata/issues@@ -187,8 +187,12 @@                         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.9, derive,-                        deepseq, th-expand-syns, transformers, tree-view >= 0.5++++  Build-Depends:	base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1,+                        QuickCheck >= 2, deepseq, transformers, th-expand-syns,+                        tree-view >= 0.5   Extensions:           FlexibleContexts   hs-source-dirs:	src   ghc-options:          -W@@ -198,10 +202,12 @@   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.9, -                        HUnit, test-framework, test-framework-hunit, test-framework-quickcheck2 >= 0.3, derive,-                        th-expand-syns, deepseq, transformers+  Build-Depends:        base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1,+                        QuickCheck >= 2, HUnit, test-framework, test-framework-hunit,+                        test-framework-quickcheck2 >= 0.3, deepseq, transformers, th-expand-syns +  ghc-options:          -W -Wno-incomplete-patterns+                         Benchmark algebra   Type:                 exitcode-stdio-1.0   Main-is:		Benchmark.hs@@ -209,7 +215,9 @@   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.9, 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, deepseq, criterion, random, uniplate, transformers,+                        th-expand-syns   source-repository head

@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances, ConstraintKinds #-}+  ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} -------------------------------------------------------------------------------- -- |

@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances, ConstraintKinds #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Eval@@ -35,10 +35,10 @@ eval :: (Functor f, Eval f v) => Term f -> Term v eval = cata evalAlg -instance (f :<: v) => Eval f v where+instance {-# OVERLAPPABLE #-} (f :<: v) => Eval f v where   evalAlg = inject -- default instance -instance (Value :<: v) => Eval Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => Eval Op v where   evalAlg (Add x y)  = iConst $ projC x + projC y   evalAlg (Mult x y) = iConst $ projC x * projC y   evalAlg (Fst x)    = fst $ projP x

@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances, ConstraintKinds #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.EvalM@@ -35,10 +35,10 @@ evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v) evalM = cataM evalAlgM -instance (f :<: v) => EvalM f v where+instance {-# OVERLAPPABLE #-} (f :<: v) => EvalM f v where   evalAlgM = return . inject -- default instance -instance (Value :<: v) => EvalM Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => EvalM Op v where   evalAlgM (Add x y)  = do n1 <- projC x                            n2 <- projC y                            return $ iConst $ n1 + n2

@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,-  OverlappingInstances, ConstraintKinds #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Multi.Eval@@ -34,10 +34,10 @@ eval :: (HFunctor f, Eval f v) => Term f :-> Term v eval = cata evalAlg -instance (f :<: v) => Eval f v where+instance  {-# OVERLAPPABLE #-} (f :<: v) => Eval f v where   evalAlg = inject -- default instance -instance (Value :<: v) => Eval Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => Eval Op v where   evalAlg (Add x y)  = iConst $ projC x + projC y   evalAlg (Mult x y) = iConst $ projC x * projC y   evalAlg (Fst x)    = fst $ projP x

@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,-  OverlappingInstances, ConstraintKinds #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Multi.EvalM@@ -34,10 +34,10 @@ evalM :: (HTraversable f, EvalM f v) => Term f i -> Maybe (Term v i) evalM = cataM evalAlgM -instance (f :<: v) => EvalM f v where+instance {-# OVERLAPPABLE #-} (f :<: v) => EvalM f v where   evalAlgM = return . inject -- default instance -instance (Value :<: v) => EvalM Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => EvalM Op v where   evalAlgM (Add x y)  = do n1 <- projC x                            n2 <- projC y                            return $ iConst $ n1 + n2

@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Examples.Simple where++import Data.Comp++data Lambda t a = App a a | Abs (Maybe (Term t)) +data Arith a = Const Int+++data LambdaType a = Fun a a++data IntType a = IntType++type Type = LambdaType :+: IntType++type Sig t = Lambda t :+: Arith++

@@ -399,11 +399,6 @@                 => HomM m g h -> HomM m f g -> HomM m f h compHomM' f g = appHomM' f <=< g -{-| Compose two monadic term homomorphisms. -}-compHomM_ :: (Functor h, Functor g, Monad m)-                => Hom g h -> HomM m f g -> HomM m f h-compHomM_ f g = liftM (appHom f) . g- {-| Compose a monadic algebra with a monadic term homomorphism to get a new   monadic algebra. -} compAlgM :: (Traversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a@@ -923,10 +918,7 @@    "appSigFunM'/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.      appSigFunM' a (appSigFun' h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;---  "appHom/appHomM" forall (a :: Hom g h) (h :: HomM m f g) x.-     appHomM h x >>= (return . appHom a) = appHomM (compHomM_ a h) x; #-}+#-}  {-# RULES   "cata/build"  forall alg (g :: forall a . Alg f a -> a) .

@@ -21,7 +21,6 @@     ( ArbitraryF(..)     )where -import Control.Applicative import Data.Comp.Derive import Data.Comp.Derive.Utils import Data.Comp.Ops

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ConstraintKinds  #-}  -------------------------------------------------------------------------------- -- |@@ -18,7 +19,8 @@ module Data.Comp.Decompose (   Decomp (..),   DecompTerm,-  Decompose (..),+  Decompose,+  decomp,   structure,   arguments,   decompose@@ -49,20 +51,17 @@  {-| This class specifies the decomposability of a functorial value. -} -class (HasVars f v, Functor f, Foldable f) => Decompose f v where-    {-| This function decomposes a functorial value. -}--    decomp :: f a -> Decomp f v a-    decomp t = case isVar t of-                 Just v -> Var v-                 Nothing -> Fun sym args-                     where sym = fmap (const ()) t-                           args = arguments t+type Decompose f v = (HasVars f v, Functor f, Foldable f) -instance (HasVars f v, Functor f, Foldable f) => Decompose f v where+decomp :: Decompose f v => f a -> Decomp f v a+decomp t = case isVar t of+             Just v -> Var v+             Nothing -> Fun sym args+               where sym = fmap (const ()) t+                     args = arguments t   {-| This function decomposes a term. -} -decompose :: (Decompose f v) => Term f -> DecompTerm f v+decompose :: Decompose f v => Term f -> DecompTerm f v decompose (Term t) = decomp t

@@ -34,7 +34,6 @@      -- ** Arbitrary      module Data.Comp.Derive.Arbitrary,      NFData(..),-     makeNFData,      -- ** DeepSeq      module Data.Comp.Derive.DeepSeq,      -- ** Smart Constructors@@ -61,12 +60,8 @@  import Language.Haskell.TH -import qualified Data.Derive.All as A-import qualified Data.DeriveTH as D -{-| Derive an instance of 'NFData' for a type constructor. -}-makeNFData :: Name -> Q [Dec]-makeNFData = D.derive A.makeNFData+  {-| Given the name of a type class, where the first parameter is a functor,   lift it to sums of functors. Example: @class ShowF f where ...@ is lifted

@@ -17,18 +17,12 @@     (      ArbitraryF(..),      makeArbitraryF,-     Arbitrary(..),-     makeArbitrary+     Arbitrary(..)     )where  import Data.Comp.Derive.Utils hiding (derive)-import qualified Data.DeriveTH as D import Language.Haskell.TH import Test.QuickCheck--{-| Derive an instance of 'Arbitrary' for a type constructor. -}-makeArbitrary :: Name -> Q [Dec]-makeArbitrary = D.derive D.makeArbitrary  {-| Signature arbitration. An instance @ArbitraryF f@ gives rise to an instance   @Arbitrary (Term f)@. -}

@@ -52,7 +52,7 @@                     h = varT hvar                     a = varT avar                     ftype = foldl appT (conT tname) (map varT targs')-                    constr = classP ''(:<:) [ftype, f]+                    constr = (conT ''(:<:) `appT` ftype) `appT` f                     typ = foldl appT (conT ''Cxt) [h, f, a]                     typeSig = forallT (map PlainTV vars) (sequence [constr]) typ                 sigD sname typeSig

@@ -17,8 +17,8 @@  import Control.Monad import Language.Haskell.TH-import Language.Haskell.TH.ExpandSyns import Language.Haskell.TH.Syntax+import Language.Haskell.TH.ExpandSyns  -- reportError is introduced only from version 7.6 of GHC #if __GLASGOW_HASKELL__ < 706@@ -29,8 +29,12 @@ #if __GLASGOW_HASKELL__ < 800 data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] [Name] #else+#if __GLASGOW_HASKELL__ < 802 data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] Cxt+#else+data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] [DerivClause]  #endif+#endif  {-|   This is the @Q@-lifted version of 'abstractNewtype.@@ -65,8 +69,9 @@ 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)+normalCon (GadtC (constr:_) args typ) = (constr,args,Just typ) #endif+normalCon _ = error "missing case for 'normalCon'"  normalCon' :: Con -> (Name,[Type], Maybe Type) normalCon' con = (n, map snd ts, t)@@ -84,8 +89,7 @@ normalConExp :: Con -> Q (Name,[Type], Maybe Type) normalConExp c = do   let (n,ts,t) = normalCon' c-  ts' <- mapM expandSyns ts-  return (n, ts',t)+  return (n, ts,t)   -- | Same as normalConExp' but retains strictness annotations.@@ -123,8 +127,9 @@ 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+abstractConType (GadtC (constr:_) args _typ) = (constr,length args) -- Only first Name #endif+abstractConType _ = error "missing case for 'abstractConType'"  {-|   This function returns the name of a bound type variable

@@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances  #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} --------------------------------------------------------------------------------@@ -30,7 +29,7 @@  -- We make the lifting to sums explicit in order to make the Desugar -- class work with the default instance declaration further below.-instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where+instance {-# OVERLAPPABLE #-} (Desugar f h, Desugar g h) => Desugar (f :+: g) h where     desugHom = caseF desugHom desugHom  -- |Desugar a term.@@ -44,5 +43,5 @@ desugarA = appHom (propAnn desugHom)  -- |Default desugaring instance.-instance (Functor f, Functor g, f :<: g) => Desugar f g where+instance {-# OVERLAPPABLE #-} (Functor f, Functor g, f :<: g) => Desugar f g where     desugHom = simpCxt . inj

@@ -62,7 +62,7 @@                     a = varT avar                     i = varT ivar                     ftype = foldl appT (conT tname) (map varT targs')-                    constr = classP ''(:<:) [ftype, f]+                    constr = (conT ''(:<:) `appT` ftype) `appT` f                     typ = foldl appT (conT ''Cxt) [h, f, a, maybe i return miTp]                     typeSig = forallT (map PlainTV vars) (sequence [constr]) typ                 sigD sname typeSig

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances  #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} --------------------------------------------------------------------------------@@ -31,7 +30,7 @@  -- We make the lifting to sums explicit in order to make the Desugar -- class work with the default instance declaration further below.-instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where+instance {-# OVERLAPPABLE #-} (Desugar f h, Desugar g h) => Desugar (f :+: g) h where     desugHom = caseH desugHom desugHom  -- |Desugar a term.@@ -44,5 +43,5 @@ desugarA = appHom (propAnn desugHom)  -- |Default desugaring instance.-instance (HFunctor f, HFunctor g, f :<: g) => Desugar f g where+instance {-# OVERLAPPABLE #-} (HFunctor f, HFunctor g, f :<: g) => Desugar f g where     desugHom = simpCxt . inj

@@ -39,8 +39,6 @@      (:.:)(..)      ) where -import Data.Traversable-import Data.Foldable import Data.Functor.Compose  -- | The identity Functor.

@@ -24,7 +24,7 @@      HTraversable (..)     ) where -import Control.Applicative+ import Data.Comp.Multi.HFoldable import Data.Comp.Multi.HFunctor 

@@ -35,7 +35,7 @@     , O.fsnd     ) where -import Control.Applicative+ import Control.Monad import Data.Comp.Multi.HFoldable import Data.Comp.Multi.HFunctor

@@ -35,9 +35,9 @@ import Data.Comp.Multi.HFoldable import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable-import Data.Monoid -import Control.Applicative hiding (Const)++ import Control.Monad  import Unsafe.Coerce

@@ -3,7 +3,6 @@ {-# LANGUAGE GADTs                 #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances  #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TemplateHaskell       #-}@@ -210,7 +209,8 @@ appSubst :: (Ord v, SubstVars v t a) => GSubst v t -> a :-> a appSubst subst = substVars (substFun subst) -instance (Ord v, HasVars f v, HTraversable f) => SubstVars v (Cxt h f a) (Cxt h f a) where+instance {-# OVERLAPPABLE #-} (Ord v, HasVars f v, HTraversable f)+       => SubstVars v (Cxt h f a) (Cxt h f a) where     -- have to use explicit GADT pattern matching!!     substVars subst = doSubst Set.empty       where doSubst :: Set v -> Cxt h f a :-> Cxt h f a@@ -221,7 +221,7 @@                 where run :: Set v -> Cxt h f a :-> Cxt h f a                       run vars = doSubst (b `Set.union` vars) -instance (SubstVars v t a, HFunctor f) => SubstVars v t (f a) where+instance {-# OVERLAPPABLE #-} (SubstVars v t a, HFunctor f) => SubstVars v t (f a) where     substVars subst = hfmap (substVars subst)  {-| This function composes two substitutions @s1@ and @s2@. That is,

@@ -62,7 +62,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Data.Traversable   -- |Project the outermost layer of a term to a sub signature. If the signature

@@ -23,8 +23,6 @@ import Control.Monad.Except import Control.Monad.State -import Data.Traversable- import qualified Data.Map as Map  {-| This type represents equations between terms over a specific

@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances  #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeOperators         #-} @@ -191,7 +190,7 @@ appSubst subst = substVars f     where f v = Map.lookup v subst -instance (Ord v, HasVars f v, Traversable f)+instance  {-# OVERLAPPABLE #-} (Ord v, HasVars f v, Traversable f)     => SubstVars v (Cxt h f a) (Cxt h f a) where         -- have to use explicit GADT pattern matching!!         -- subst f = free (substAlg f) Hole@@ -202,7 +201,7 @@             Nothing  -> Term $ fmapBoundVars run t               where run vars = doSubst (b `Set.union` vars) -instance (SubstVars v t a, Functor f) => SubstVars v t (f a) where+instance  {-# OVERLAPPABLE #-} (SubstVars v t a, Functor f) => SubstVars v t (f a) where     substVars f = fmap (substVars f)  {-| This function composes two substitutions @s1@ and @s2@. That is,

@@ -2,13 +2,12 @@   import Data.Comp-import Data.Comp.Equality-import Data.Comp.Arbitrary-import Data.Comp.Show+import Data.Comp.Equality ()+import Data.Comp.Arbitrary ()+import Data.Comp.Show ()  import Test.Framework import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck import Test.Utils  @@ -34,4 +33,4 @@                    Nothing -> False                    Just list -> all (uncurry (==)) $ map (\(x,y)->(f x,y)) list     where cxt' = fmap f cxt -          with = (cxt :: Context SigP Int, f :: Int -> Int)+          _with = (cxt :: Context SigP Int, f :: Int -> Int)

@@ -11,10 +11,6 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit-import Test.Utils hiding (iPair)---   --------------------------------------------------------------------------------

@@ -12,7 +12,6 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit-import Test.Utils hiding (iPair)  -------------------------------------------------------------------------------- -- Test Suits

@@ -5,9 +5,6 @@ import qualified Data.Comp.Examples.Multi as M  import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import Test.Utils  tests = testGroup "Examples" [          C.tests,

@@ -6,8 +6,6 @@ import Data.Comp import Data.Comp.Derive -import Data.Foldable-  data Tree l e = Leaf l               | UnNode l e