packages feed

compdata (empty) → 0.1

raw patch · 77 files changed

+8390/−0 lines, 77 filesdep +QuickCheckdep +basedep +containersbuild-type:Customsetup-changed

Dependencies added: QuickCheck, base, containers, criterion, deepseq, derive, mtl, random, template-haskell, test-framework, test-framework-quickcheck2, th-expand-syns, uniplate

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010--2011 Patrick Bahr, Tom Hvitved++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,36 @@+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import System.Cmd+import System.FilePath+import System.Directory+import Control.Exception+import System.IO.Error (isDoesNotExistError)+++main = defaultMainWithHooks hooks+  where hooks = simpleUserHooks { runTests = runTests'}+++hpcReportDir = "hpcreport"++runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+runTests' _ _ _ lbi = do+  res <- try (removeFile tixFile)+  case res of+    Left err+        | not (isDoesNotExistError err) -> putStrLn "tix file could not be removed"+    _ -> return ()+  putStrLn "running tests ..."+  system testprog+  putStrLn "computing code coverage ..."+  hpcReport+  putStrLn "generating code coverage reports ..."+  hpcMarkup+  return ()+    where testprog = (buildDir lbi) </> "test" </> "test"+          tixFile = "test.tix"+          hpcReport = system $ "hpc report test"++exclArgs+          hpcMarkup = system $ "hpc markup test --destdir="++hpcReportDir++exclArgs+          excludedModules = []+          exclArgs = concatMap (" --exclude="++) excludedModules
+ benchmark/Benchmark.hs view
@@ -0,0 +1,129 @@+module Main where++import Criterion.Main+import qualified Functions.Comp as A+import qualified Functions.Standard as S+import DataTypes.Comp as DC+import DataTypes.Standard as DS+import DataTypes.Transform+import Data.Comp+import Data.Comp.DeepSeq ()+import Control.DeepSeq+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen+import System.Random++aExpr :: SugarExpr+aExpr = iIf ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))+            `iOr` ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))))+       ((iVInt 2 `iMinus` iVInt 1))+       (iVInt 3)++sExpr :: PExpr+sExpr = transSugar aExpr++aHOASExpr :: Int -> DC.HOASExpr+aHOASExpr n = (iLam $ \x -> x `iPlus` ((iLam $ \x -> x `iMult` x) `iApp` x))+              `iApp`+              ((iLam $ \x -> x `iMult` x)+               `iApp`+               (if n <= 0 then iVInt 2 else aHOASExpr (n - 1)))++sHOASExpr :: Int -> DS.HOASExpr+sHOASExpr = transHOAS . aHOASExpr++sfCoalg :: Coalg SugarSig Int+sfCoalg 0 = inj $ VInt 1+sfCoalg n = let n' = n-1 in inj $ Plus n' n'++sfGen' :: Int -> SugarExpr+sfGen'  = ana' sfCoalg++sfGen :: Int -> SugarExpr+sfGen  = ana sfCoalg++shortcutFusion :: Benchmark+shortcutFusion = bgroup "shortcut-fusion" [+                  bench "eval without fusion" (nf (A.evalSugar2 . sfGen) depth),+                  bench "eval with fusion" (nf (A.evalSugar2 . sfGen') depth)+                  ]+    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 [+                 bench "Comp.desugar" (nf A.desugarExpr aExpr),+                 bench "Comp.desugarAlg" (nf A.desugarExpr2 aExpr),+                 bench "Standard.desugar" (nf S.desugar sExpr),+                 bench "Comp.desugarType" (nf A.desugarType aExpr),+                 bench "Comp.desugarType'" (nf A.desugarType' aExpr),+                 bench "Standard.desugarType" (nf S.desugarType sExpr),+                 bench "Comp.typeSugar" (nf A.typeSugar aExpr),+                 bench "Standard.typeSugar" (nf S.typeSugar sExpr),+                 bench "Comp.desugarType2" (nf A.desugarType2 aExpr),+                 bench "Comp.desugarType2'" (nf A.desugarType2' aExpr),+                 bench "Standard.desugarType2" (nf S.desugarType2 sExpr),+                 bench "Comp.typeSugar2" (nf A.typeSugar2 aExpr),+                 bench "Standard.typeSugar2" (nf S.typeSugar2 sExpr),+                 bench "Comp.desugarEval" (nf A.desugarEval aExpr),+                 bench "Comp.desugarEval'" (nf A.desugarEval' aExpr),+                 bench "Standard.desugarEval" (nf S.desugarEval sExpr),+                 bench "Comp.evalSugar" (nf A.evalSugar aExpr),+                 bench "Comp.evalDirect" (nf A.evalDirectE aExpr),+                 bench "Standard.evalSugar" (nf S.evalSugar sExpr),+                 bench "Comp.desugarEval2" (nf A.desugarEval2 aExpr),+                 bench "Comp.desugarEval2'" (nf A.desugarEval2' aExpr),+                 bench "Standard.desugarEval2" (nf S.desugarEval2 sExpr),+                 bench "Comp.evalSugar2" (nf A.evalSugar2 aExpr),+                 bench "Comp.evalDirect2" (nf A.evalDirectE2 aExpr),+                 bench "Standard.evalSugar2" (nf S.evalSugar2 sExpr),+                 bench "Comp.contVar" (nf (A.contVar 10) aExpr),+                 bench "Comp.contVar'" (nf (A.contVar' 10) aExpr),+                 bench "Comp.contVarGen" (nf (A.contVarGen 10) aExpr),+                 bench "Standard.contVar" (nf (S.contVar 10) sExpr),+                 bench "Standard.contVarGen" (nf (S.contVarGen 10) sExpr),+                 bench "Comp.freeVars" (nf A.freeVars aExpr),+                 bench "Comp.freeVars'" (nf A.freeVars' aExpr),+                 bench "Comp.freeVarsGen" (nf A.freeVarsGen aExpr),+                 bench "Standard.freeVars" (nf S.freeVars sExpr),+                 bench "Standard.freeVarsGen" (nf S.freeVarsGen sExpr)]++randStdBenchmarks :: Int -> IO Benchmark+randStdBenchmarks s = do+  rand <- getStdGen+  let ty = unGen arbitrary rand s+  putStr "size of the type term: "+  print $ size ty+  print $ ty+  let aExpr = unGen (genTyped ty) rand s+      sExpr = transSugar aExpr+  putStr "size of the input term: "+  print $ size aExpr+  putStr "does it type check: "+  print (A.desugarType aExpr == Right ty)+  return $ standardBenchmarks (sExpr,aExpr, "random (depth: " ++ show s ++ ", size: "++ show (size aExpr) ++ ")")++hoasBenchmaks :: Int -> Benchmark+hoasBenchmaks s = bgroup ("HOAS (depth: " ++ show s ++ ")") $ getBench s+    where getBench size =+              let sExpr' = sHOASExpr size+                  aExpr' = aHOASExpr size in+              rnf aExpr' `seq` rnf sExpr' `seq`+              [bench "Comp.eval2E" +                     (nf (A.eval2E :: DC.HOASExpr -> HOASValueExpr) aExpr'),+               bench "Standard.evalHOAS" (nf S.evalHOAS sExpr')]++main = do b1 <- randStdBenchmarks 5+          b2 <- randStdBenchmarks 10+          b3 <- randStdBenchmarks 20+          let b0 = standardBenchmarks (sExpr, aExpr, "hand-written")+          let b4 = map hoasBenchmaks [1,10,100,1000,10000]+          defaultMain $ [b0,b1,b2,b3] ++ b4++          ++{-+TODO + - benchmark generic functions (e.g. size, depth, breadth)++-}
+ benchmark/DataTypes.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TypeSynonymInstances, CPP #-}++module DataTypes where++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+    fail  = Left+#endif
+ benchmark/DataTypes/Comp.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances #-}++module DataTypes.Comp +    ( module DataTypes.Comp,+      module DataTypes +    ) where++import DataTypes+import Data.Comp.Derive+import Data.Comp+import Data.Comp.Arbitrary ()+import Data.Comp.Show+import Data.Traversable+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen++import Control.Monad hiding (sequence_,mapM)+import Prelude hiding (sequence_,mapM)++-- base values++type ValueSig = Value+type ValueExpr = Term ValueSig+type ExprSig = Value :+:Op+type Expr = Term ExprSig+type SugarSig = Value :+: Op :+: Sugar+type SugarExpr = Term SugarSig+type BaseTypeSig = ValueT+type BaseType = Term BaseTypeSig++type HOASValueSig = Value :+: Lam+type HOASValueExpr = Term HOASValueSig+type HOASExprSig = Value :+: Lam :+: App :+: Op+type HOASExpr = Term HOASExprSig+type HOASBaseTypeSig = ValueT :+: FunT+type HOASBaseType = Term HOASBaseTypeSig++data ValueT e = TInt+              | TBool+              | TPair e e+                deriving (Eq)++data Value e = VInt Int+             | VBool Bool+             | VPair e e+               deriving (Eq)++data Proj = ProjLeft | ProjRight+            deriving (Eq)++data Op e = Plus e e+          | Mult e e+          | If e e e+          | Eq e e+          | Lt e e+          | And e e+          | Not e+          | Proj Proj e+            deriving (Eq)++data Sugar e = Neg e+             | Minus e e+             | Gt e e+             | Or e e+             | Impl e e+               deriving (Eq)++data FunT e = TFun e e+              deriving (Eq)++data Lam e = Lam (e -> e)++data App e = App e e+             deriving (Eq)++$(derive [instanceNFData, instanceArbitrary] [''Proj])++$(derive+  [instanceFunctor, instanceExpFunctor, instanceFoldable, instanceTraversable,+   instanceEqF, instanceNFDataF, instanceArbitraryF, smartConstructors]+  [''Value, ''Op, ''Sugar, ''ValueT, ''FunT, ''App])++$(derive [instanceExpFunctor, smartConstructors] [''Lam])++instance EqF Lam where+    eqF _ _ = False++instance NFDataF Lam where+    rnfF (Lam f) = f `seq` ()++showBinOp :: String -> String -> String -> String+showBinOp op x y = "("++ x ++ op ++ y ++ ")"++instance ShowF Value where+    showF (VInt i) = show i+    showF (VBool b) = show b+    showF (VPair x y) = showBinOp "," x y+++instance ShowF Op where+    showF (Plus x y) = showBinOp "+" x y+    showF (Mult x y) = showBinOp "*" x y+    showF (If b x y) = "if " ++ b ++ " then " ++ x ++ " else " ++ y ++ " fi"+    showF (Eq x y) = showBinOp "==" x y+    showF (Lt x y) = showBinOp "<" x y+    showF (And x y) = showBinOp "&&" x y+    showF (Not x) = "~" ++ x+    showF (Proj ProjLeft x) = x ++ "!0"+    showF (Proj ProjRight x) = x ++ "!1"++instance ShowF ValueT where +    showF TInt = "Int"+    showF TBool = "Bool"+    showF (TPair x y) = "(" ++ x ++ "," ++ y ++ ")"++instance ShowF Lam where +    showF (Lam f) = "\\x. " ++ f "x"++instance ShowF App where +    showF (App x y) = x ++ " " ++ y++instance ShowF FunT where +    showF (TFun x y) = x ++ " -> " ++ y+++class GenTyped f where+    genTypedAlg :: CoalgM Gen f BaseType+    genTypedAlg a = do dist <- genTypedAlg' a+                       frequency $ map (\ (i,f) -> (i,return f)) dist+    genTypedAlg' :: BaseType -> Gen [(Int,f BaseType)]+    genTypedAlg' a = genTypedAlg a >>= \ g -> return [(1,g)]++genTyped :: forall f . (Traversable f, GenTyped f) => BaseType -> Gen (Term f)+genTyped = run +    where run :: BaseType -> Gen (Term f)+          run t = liftM Term $ genTypedAlg t >>= mapM (desize . run)++desize :: Gen a -> Gen a+desize gen = sized (\n -> resize (max 0 (n-1)) gen)++genSomeTyped :: (Traversable f, GenTyped f) => Gen (Term f)+genSomeTyped = arbitrary >>= genTyped +++instance (GenTyped f, GenTyped g) => GenTyped (f :+: g) where+    genTypedAlg' t = do +      left <- genTypedAlg' t+      right <- genTypedAlg' t+      let left' = map inl left+          right' = map inr right+      return (left' ++ right')+        where inl (i,gen) = (i,Inl gen)+              inr (i,gen) = (i,Inr gen)++instance GenTyped Value where+    genTypedAlg' (Term t) = run t+        where run TInt  = arbitrary >>= \i-> return [(1,VInt i)]+              run TBool = arbitrary >>= \b-> return [(1,VBool b)]+              run (TPair s t) = return [(1, VPair s t)]++instance GenTyped Op where+    genTypedAlg' ty = sized run+        where run n = do (ty1,ty2) <- arbitrary+                         other' <- other n+                         return $ other' ++ [(n,If iTBool ty ty),+                                   (n,Proj ProjLeft (iTPair ty ty1)),+                                   (n,Proj ProjRight (iTPair ty2 ty))]+              other n = case unTerm ty of+                        TInt -> return [(n,Plus iTInt iTInt),(n,Plus iTInt iTInt)]+                        TBool -> arbitrary >>= \t -> return+                                 [(n, Eq t t),+                                  (n,Lt iTInt iTInt),+                                  (n,And iTBool iTBool),+                                  (n,Not iTBool)]+                        TPair _ _ -> return []++instance GenTyped Sugar where+    genTypedAlg' (Term t) = sized (run t)+        where run TInt n = return [(5*n,Neg iTInt),(5*n,Minus iTInt iTInt)]+              run TBool n = return [(5*n,Gt iTInt iTInt),(5*n,Or iTBool iTBool),+                                 (5*n,Impl iTBool iTBool)]+              run TPair{} _ = return []
+ benchmark/DataTypes/Standard.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, DeriveDataTypeable #-}+module DataTypes.Standard +    ( module DataTypes.Standard,+      module DataTypes +    ) where++import DataTypes+import Data.Derive.NFData+import Data.DeriveTH+import Data.Data+import Control.DeepSeq++-- base values++data VType = VTInt+           | VTBool+           | VTPair VType VType+             deriving (Eq,Typeable,Data)++data SExpr = SInt Int+           | SBool Bool+           | SPair SExpr SExpr+             deriving (Eq,Typeable,Data)++data SProj = SProjLeft | SProjRight+             deriving (Eq,Typeable,Data)++data OExpr = OInt Int+           | OBool Bool+           | OPair OExpr OExpr+           | OPlus OExpr OExpr+           | OMult OExpr OExpr+           | OIf OExpr OExpr OExpr+           | OEq OExpr OExpr+           | OLt OExpr OExpr+           | OAnd OExpr OExpr+           | ONot OExpr+           | OProj SProj OExpr+             deriving (Eq,Typeable,Data)++data PExpr = PInt Int+           | PBool Bool+           | PPair PExpr PExpr+           | PPlus PExpr PExpr+           | PMult PExpr PExpr+           | PIf PExpr PExpr PExpr+           | PEq PExpr PExpr+           | PLt PExpr PExpr+           | PAnd PExpr PExpr+           | PNot PExpr+           | PProj SProj PExpr+           | PNeg PExpr+           | PMinus PExpr PExpr+           | PGt PExpr PExpr+           | POr PExpr PExpr+           | PImpl PExpr PExpr+             deriving (Eq,Typeable,Data)++data VHType = VHTInt+            | VHTBool+            | VHTPair VType VType+            | VHTFun VType VType+              deriving (Eq,Typeable,Data)++-- HOAS+data HOASExpr = HOASInt Int+              | HOASBool Bool+              | HOASPair HOASExpr HOASExpr+              | HOASPlus HOASExpr HOASExpr+              | HOASMult HOASExpr HOASExpr+              | HOASIf HOASExpr HOASExpr HOASExpr+              | HOASEq HOASExpr HOASExpr+              | HOASLt HOASExpr HOASExpr+              | HOASAnd HOASExpr HOASExpr+              | HOASNot HOASExpr+              | HOASProj SProj HOASExpr+              | HOASApp HOASExpr HOASExpr+              | HOASLam (HOASSExpr -> HOASExpr) -- Nasty dependency with HOASSExpr!+              | HOASVal HOASSExpr -- Nasty dependency with HOASSExpr!+                deriving (Typeable,Data)++data HOASSExpr = HOASSInt Int+               | HOASSBool Bool+               | HOASSPair HOASSExpr HOASSExpr+               | HOASSLam (HOASSExpr -> HOASSExpr)+                 deriving (Typeable,Data)++instance NFData HOASExpr where+    rnf (HOASInt n) = rnf n `seq` ()+    rnf (HOASBool b) = rnf b `seq` ()+    rnf (HOASPair e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASPlus e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASMult e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASIf e1 e2 e3) = rnf e1 `seq` rnf e2 `seq` rnf e3 `seq` ()+    rnf (HOASEq e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASLt e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASAnd e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASNot e) = rnf e `seq` ()+    rnf (HOASProj e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASApp e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASLam e) = e `seq` ()+    rnf (HOASVal e) = rnf e `seq` ()++instance NFData HOASSExpr where+    rnf (HOASSInt n) = rnf n `seq` ()+    rnf (HOASSBool b) = rnf b `seq` ()+    rnf (HOASSPair e1 e2) = rnf e1 `seq` rnf e2 `seq` ()+    rnf (HOASSLam e) = e `seq` ()++instance Eq HOASSExpr where+    (==) (HOASSInt n1) (HOASSInt n2) = n1 == n2+    (==) (HOASSBool b1) (HOASSBool b2) = b1 == b2+    (==) (HOASSPair e1 e2) (HOASSPair e3 e4) = e1 == e3 && e2 == e4+    (==) _ _ = False+++showBinOp :: String -> String -> String -> String+showBinOp op x y = "("++ x ++ op ++ y ++ ")"++instance Show SExpr where+    show (SInt i) = show i+    show (SBool b) = show b+    show (SPair x y) = showBinOp "," (show x) (show y)++ +instance Show OExpr where+    show (OInt i) = show i+    show (OBool b) = show b+    show (OPair x y) = showBinOp "," (show x) (show y)+    show (OPlus x y) = showBinOp "+" (show x) (show y)+    show (OMult x y) = showBinOp "*" (show x) (show y)+    show (OIf b x y) = "if " ++ show b ++ " then " ++ show x ++ " else " ++ show y ++ " fi"+    show (OEq x y) = showBinOp "==" (show x) (show y)+    show (OLt x y) = showBinOp "<" (show x) (show y)+    show (OAnd x y) = showBinOp "&&" (show x) (show y)+    show (ONot x) = "~" ++ (show x)+    show (OProj SProjLeft x) = (show x) ++ "!0"+    show (OProj SProjRight x) = (show x) ++ "!1"++instance Show VType where +    show VTInt = "Int"+    show VTBool = "Bool"+    show (VTPair x y) = "(" ++ show x ++ "," ++ show y ++ ")"++$(derives [makeNFData] [''SProj,''SExpr,''OExpr,''PExpr,''VType])
+ benchmark/DataTypes/Transform.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances #-}++module DataTypes.Transform where++import Data.Comp+import Data.Comp.ExpFunctor+import DataTypes.Standard as S+import DataTypes.Comp++class TransSugar f where+    transSugarAlg :: Alg f PExpr++transSugar :: (Functor f, TransSugar f) => Term f -> PExpr+transSugar = cata transSugarAlg++instance (TransSugar f, TransSugar g) => TransSugar (f :+: g) where+    transSugarAlg (Inl v) = transSugarAlg v+    transSugarAlg (Inr v) = transSugarAlg v++instance TransSugar Value where+    transSugarAlg (VInt i) = PInt i+    transSugarAlg (VBool b) = PBool b+    transSugarAlg (VPair x y) = PPair x y++instance TransSugar Op where+    transSugarAlg (Plus x y) = PPlus x y+    transSugarAlg (Mult x y) = PMult x y+    transSugarAlg (If b x y) = PIf b x y+    transSugarAlg (Lt x y) = PLt x y+    transSugarAlg (And x y) = PAnd x y+    transSugarAlg (Not x) = PNot x+    transSugarAlg (Proj p x) = PProj (ptrans p) x+        where ptrans ProjLeft = SProjLeft+              ptrans ProjRight = SProjRight+    transSugarAlg (Eq x y) = PEq x y++instance TransSugar Sugar where+    transSugarAlg (Neg x) = PNeg x+    transSugarAlg (Minus x y) = PMinus x y+    transSugarAlg (Gt x y) = PGt x y+    transSugarAlg (Or x y) = POr x y+    transSugarAlg (Impl x y) = PImpl x y++class TransHOAS f where+    transHOASAlg :: Alg f S.HOASExpr++transHOAS :: (ExpFunctor f, TransHOAS f) => Term f -> S.HOASExpr+transHOAS = cataE transHOASAlg++instance (TransHOAS f, TransHOAS g) => TransHOAS (f :+: g) where+    transHOASAlg (Inl v) = transHOASAlg v+    transHOASAlg (Inr v) = transHOASAlg v++instance TransHOAS Value where+    transHOASAlg (VInt i) = HOASInt i+    transHOASAlg (VBool b) = HOASBool b+    transHOASAlg (VPair x y) = HOASPair x y++instance TransHOAS Op where+    transHOASAlg (Plus x y) = HOASPlus x y+    transHOASAlg (Mult x y) = HOASMult x y+    transHOASAlg (If b x y) = HOASIf b x y+    transHOASAlg (Lt x y) = HOASLt x y+    transHOASAlg (And x y) = HOASAnd x y+    transHOASAlg (Not x) = HOASNot x+    transHOASAlg (Proj p x) = HOASProj (ptrans p) x+        where ptrans ProjLeft = SProjLeft+              ptrans ProjRight = SProjRight+    transHOASAlg (Eq x y) = HOASEq x y++instance TransHOAS Lam where+    transHOASAlg (Lam f) = HOASLam $ f . HOASVal++instance TransHOAS App where+    transHOASAlg (App x y) = HOASApp x y
+ benchmark/Functions.hs view
@@ -0,0 +1,5 @@+module Functions +    ( module Functions.Comp,+      module Functions.Standard ) where+import Functions.Comp+import Functions.Standard
+ benchmark/Functions/Comp.hs view
@@ -0,0 +1,9 @@+module Functions.Comp+    ( module Functions.Comp.Desugar,+      module Functions.Comp.Eval,+      module Functions.Comp.Inference,+      module Functions.Comp.FreeVars ) where+import Functions.Comp.Desugar+import Functions.Comp.Eval+import Functions.Comp.Inference+import Functions.Comp.FreeVars
+ benchmark/Functions/Comp/Desugar.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances #-}++module Functions.Comp.Desugar where++import DataTypes.Comp+import Data.Comp+import Data.Traversable++-- de-sugar++class (Functor e, Traversable f) => Desugar f e where+    desugarAlg :: TermHom f e++desugarExpr :: SugarExpr -> Expr+desugarExpr = desugar++desugar :: Desugar f e => Term f -> Term e+{-# INLINE desugar #-}+desugar = appTermHom desugarAlg++instance (Desugar f e, Desugar g e) => Desugar (g :+: f) e where+    desugarAlg (Inl v) = desugarAlg v+    desugarAlg (Inr v) = desugarAlg v++instance (Value :<: v, Functor v) => Desugar Value v where+    desugarAlg = liftCxt++instance (Op :<: v, Functor v) => Desugar Op v where+    desugarAlg = liftCxt++instance (Op :<: v, Value :<: v, Functor v) => Desugar Sugar v where+    desugarAlg (Neg x) =  iVInt (-1) `iMult` (Hole x)+    desugarAlg (Minus x y) =  (Hole x) `iPlus` ((iVInt (-1)) `iMult` (Hole y))+    desugarAlg (Gt x y) =  (Hole y) `iLt` (Hole x)+    desugarAlg (Or x y) = iNot (iNot (Hole x) `iAnd` iNot (Hole y))+    desugarAlg (Impl x y) = iNot ((Hole x) `iAnd` iNot (Hole y))+++-- standard algebraic approach++class Desugar2 f g where+    desugarAlg2 :: Alg f (Term g)++desugarExpr2 :: SugarExpr -> Expr+desugarExpr2 = desugar2++desugar2 :: (Functor f, Desugar2 f g) => Term f -> Term g+desugar2 = cata desugarAlg2++instance (Desugar2 f e, Desugar2 g e) => Desugar2 (f :+: g) e where+    desugarAlg2 (Inl v) = desugarAlg2 v+    desugarAlg2 (Inr v) = desugarAlg2 v++instance (Value :<: v) => Desugar2 Value v where+    desugarAlg2 = inject++instance (Op :<: v) => Desugar2 Op v where+    desugarAlg2 = inject++instance (Op :<: v, Value :<: v, Functor v) => Desugar2 Sugar v where+    desugarAlg2 (Neg x) =  iVInt (-1) `iMult` x+    desugarAlg2 (Minus x y) =  x `iPlus` ((iVInt (-1)) `iMult` y)+    desugarAlg2 (Gt x y) =  y `iLt` x+    desugarAlg2 (Or x y) = iNot (iNot x `iAnd` iNot y)+    desugarAlg2 (Impl x y) = iNot (x `iAnd` iNot y)+
+ benchmark/Functions/Comp/Eval.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances #-}++module Functions.Comp.Eval where++import DataTypes.Comp+import Functions.Comp.Desugar+import Data.Comp+import Data.Comp.ExpFunctor+import Control.Monad+import Data.Traversable++-- evaluation++class Monad m => Eval e v m where+    evalAlg :: e (Term v) -> m (Term v)++eval :: (Traversable e, Eval e v m) => Term e -> m (Term v)+eval = cataM evalAlg++instance (Eval f v m, Eval g v m) => Eval (f :+: g) v m where+    evalAlg (Inl v) = evalAlg v+    evalAlg (Inr v) = evalAlg v++instance (Value :<: v, Monad m) => Eval Value v m where+    evalAlg = return . inject++coerceInt :: (Value :<: v, Monad 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 t = case project t of+                Just (VBool b) -> return b+                _ -> fail ""++coercePair :: (Value :<: v, Monad 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+    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)+        where select b' = if b' then x else y+    evalAlg (Eq x y) = return $ iVBool (x == y)+    evalAlg (Lt x y) = liftM2 (\ i j -> iVBool (i < j)) (coerceInt x) (coerceInt y)+    evalAlg (And x y) = liftM2 (\ b c -> iVBool (b && c)) (coerceBool x) (coerceBool y)+    evalAlg (Not x) = liftM (iVBool . not) (coerceBool x)+    evalAlg (Proj p x) = liftM select (coercePair x)+        where select (x,y) = case p of +                               ProjLeft -> x+                               ProjRight -> y++instance (Value :<: v, Monad 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)+    evalAlg (Or x y) = liftM2 (\ b c -> iVBool (b || c)) (coerceBool x) (coerceBool y)+    evalAlg (Impl x y) = liftM2 (\ b c -> iVBool (not b || c)) (coerceBool x) (coerceBool y)+++-- direct evaluation++class Monad 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++evalDirectE :: SugarExpr -> Err ValueExpr+evalDirectE = evalDirect++instance (EvalDir f m, EvalDir g m) => EvalDir (f :+: g) m where+    evalDir (Inl v) = evalDir v+    evalDir (Inr v) = evalDir v++instance (Monad 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)+++evalInt :: (Traversable e, EvalDir e m) => Term e -> m Int+evalInt t = do+  t' <- evalDirect t+  case project t' of+    Just (VInt i) -> return i+    _ -> fail ""++evalBool :: (Traversable e, EvalDir e m) => Term e -> m Bool+evalBool t = do+  t' <- evalDirect t+  case project t' of+    Just (VBool b) -> return b+    _ -> fail ""++evalPair :: (Traversable e, EvalDir e m) => Term e -> m (ValueExpr, ValueExpr)+evalPair t = do+  t' <- evalDirect t+  case project t' of+    Just (VPair x y) -> return (x,y)+    _ -> fail ""++instance (Monad 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 +      b' <- evalBool b+      if b' then evalDirect x else evalDirect y+    evalDir (Eq x y) = liftM iVBool $ liftM2 (==) (evalDirect x) (evalDirect y)+    evalDir (Lt x y) = liftM2 (\ i j -> iVBool (i < j)) (evalInt x) (evalInt y)+    evalDir (And x y) = liftM2 (\ b c -> iVBool (b && c)) (evalBool x) (evalBool y)+    evalDir (Not x) = liftM (iVBool . not) (evalBool x)+    evalDir (Proj p x) = liftM select (evalPair x)+        where select (x,y) = case p of +                               ProjLeft -> x+                               ProjRight -> y++instance (Monad 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)+    evalDir (Or x y) = liftM2 (\ b c -> iVBool (b || c)) (evalBool x) (evalBool y)+    evalDir (Impl x y) = liftM2 (\ b c -> iVBool (not b || c)) (evalBool x) (evalBool y)+++-- evaluation2++class ExpFunctor e => Eval2 e v where+    eval2Alg :: e (Term v) -> Term v++eval2 :: (Functor e, Eval2 e v) => Term e -> Term v+eval2 = cata eval2Alg++eval2E :: (ExpFunctor e, Eval2 e v) => Term e -> Term v+eval2E = cataE eval2Alg++instance (Eval2 f v, Eval2 g v) => Eval2 (f :+: g) v where+    eval2Alg (Inl v) = eval2Alg v+    eval2Alg (Inr v) = eval2Alg v++instance (Value :<: v) => Eval2 Value v where+    eval2Alg = inject++coerceInt2 :: (Value :<: v) => Term v -> Int+coerceInt2 t = case project t of+                Just (VInt i) -> i+                _ -> undefined++coerceBool2 :: (Value :<: v) => Term v -> Bool+coerceBool2 t = case project t of+                Just (VBool b) -> b+                _ -> undefined++coercePair2 :: (Value :<: v) => Term v -> (Term v, Term v)+coercePair2 t = case project t of+                Just (VPair x y) -> (x,y)+                _ -> undefined++coerceLam2 :: (Lam :<: v) => Term v -> Term v -> Term v+coerceLam2 t = case project t of+                Just (Lam f) -> f+                _ -> undefined++instance (Value :<: v, EqF v) => Eval2 Op v where+    eval2Alg (Plus x y) = (\ i j -> iVInt (i + j)) (coerceInt2 x) (coerceInt2 y)+    eval2Alg (Mult x y) = (\ i j -> iVInt (i * j)) (coerceInt2 x) (coerceInt2 y)+    eval2Alg (If b x y) = select (coerceBool2 b)+        where select b' = if b' then x else y+    eval2Alg (Eq x y) = iVBool (x == y)+    eval2Alg (Lt x y) = (\ i j -> iVBool (i < j)) (coerceInt2 x) (coerceInt2 y)+    eval2Alg (And x y) = (\ b c -> iVBool (b && c)) (coerceBool2 x) (coerceBool2 y)+    eval2Alg (Not x) = (iVBool . not) (coerceBool2 x)+    eval2Alg (Proj p x) = select (coercePair2 x)+        where select (x,y) = case p of +                               ProjLeft -> x+                               ProjRight -> y+++instance (Value :<: v) => Eval2 Sugar v where+    eval2Alg (Neg x) = (iVInt . negate) (coerceInt2 x)+    eval2Alg (Minus x y) = (\ i j -> iVInt (i - j)) (coerceInt2 x) (coerceInt2 y)+    eval2Alg (Gt x y) = (\ i j -> iVBool (i > j)) (coerceInt2 x) (coerceInt2 y)+    eval2Alg (Or x y) = (\ b c -> iVBool (b || c)) (coerceBool2 x) (coerceBool2 y)+    eval2Alg (Impl x y) = (\ b c -> iVBool (not b || c)) (coerceBool2 x) (coerceBool2 y)++instance (Lam :<: v) => Eval2 Lam v where+    eval2Alg = inject++instance (Lam :<: v) => Eval2 App v where+    eval2Alg (App v1 v2) = (coerceLam2 v1) v2+++-- direct evaluation 2++class EvalDir2 e where+    evalDir2 :: (EvalDir2 f) => e (Term f) -> ValueExpr++evalDirect2 :: (EvalDir2 e) => Term e -> ValueExpr+evalDirect2 = evalDir2 . unTerm++evalDirectE2 :: SugarExpr -> ValueExpr+evalDirectE2 = evalDirect2++instance (EvalDir2 f, EvalDir2 g) => EvalDir2 (f :+: g) where+    evalDir2 (Inl v) = evalDir2 v+    evalDir2 (Inr v) = evalDir2 v++instance EvalDir2 Value where+    evalDir2 (VInt i) = iVInt i+    evalDir2 (VBool i) =  iVBool i+    evalDir2 (VPair x y) = iVPair (evalDirect2 x) (evalDirect2 y)+++evalInt2 :: (EvalDir2 e) => Term e -> Int+evalInt2 t = case project (evalDirect2 t) of+               Just (VInt i) -> i+               _ -> error ""++evalBool2 :: (EvalDir2 e) => Term e -> Bool+evalBool2 t = case project (evalDirect2 t) of+                Just (VBool b) -> b+                _ -> error ""++evalPair2 :: (EvalDir2 e) => Term e -> (ValueExpr, ValueExpr)+evalPair2 t = case project (evalDirect2 t) of+               Just (VPair x y) -> (x,y)+               _ -> error ""++instance EvalDir2 Op where+    evalDir2 (Plus x y) = (\ i j -> iVInt (i + j)) (evalInt2 x) (evalInt2 y)+    evalDir2 (Mult x y) = (\ i j -> iVInt (i * j)) (evalInt2 x) (evalInt2 y)+    evalDir2 (If b x y) = if evalBool2 b then evalDirect2 x else evalDirect2 y+    evalDir2 (Eq x y) = iVBool $ (==) (evalDirect2 x) (evalDirect2 y)+    evalDir2 (Lt x y) = (\ i j -> iVBool (i < j)) (evalInt2 x) (evalInt2 y)+    evalDir2 (And x y) = (\ b c -> iVBool (b && c)) (evalBool2 x) (evalBool2 y)+    evalDir2 (Not x) =  (iVBool . not) (evalBool2 x)+    evalDir2 (Proj p x) =  select (evalPair2 x)+        where select (x,y) = case p of +                               ProjLeft -> x+                               ProjRight -> y++instance EvalDir2 Sugar where+    evalDir2 (Neg x) = (iVInt . negate) (evalInt2 x)+    evalDir2 (Minus x y) = (\ i j -> iVInt (i - j)) (evalInt2 x) (evalInt2 y)+    evalDir2 (Gt x y) = (\ i j -> iVBool (i > j)) (evalInt2 x) (evalInt2 y)+    evalDir2 (Or x y) = (\ b c -> iVBool (b || c)) (evalBool2 x) (evalBool2 y)+    evalDir2 (Impl x y) = (\ b c -> iVBool (not b || c)) (evalBool2 x) (evalBool2 y)++-- desugar++desugarEval :: SugarExpr -> Err ValueExpr+desugarEval = eval . (desugar :: SugarExpr -> Expr)+++evalSugar :: SugarExpr -> Err ValueExpr+evalSugar = eval++desugarEvalAlg  :: AlgM Err SugarSig ValueExpr+desugarEvalAlg = evalAlg  `compAlgM'` (desugarAlg :: TermHom SugarSig ExprSig)+++desugarEval' :: SugarExpr -> Err ValueExpr+desugarEval' = cataM desugarEvalAlg++desugarEval2 :: SugarExpr -> ValueExpr+desugarEval2 = eval2 . (desugar :: SugarExpr -> Expr)++desugarEval2E :: SugarExpr -> ValueExpr+desugarEval2E = eval2E . (desugar :: SugarExpr -> Expr)+++evalSugar2 :: SugarExpr -> ValueExpr+evalSugar2 = eval2++evalSugar2E :: SugarExpr -> ValueExpr+evalSugar2E = eval2E+++desugarEval2Alg  :: Alg SugarSig ValueExpr+desugarEval2Alg = eval2Alg  `compAlg` (desugarAlg :: TermHom SugarSig ExprSig)+++desugarEval2' :: SugarExpr -> ValueExpr+desugarEval2' = cata desugarEval2Alg++desugarEval2E' :: SugarExpr -> ValueExpr+desugarEval2E' = cataE desugarEval2Alg
+ benchmark/Functions/Comp/FreeVars.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances #-}++module Functions.Comp.FreeVars where++import DataTypes.Comp+import Data.Comp.Variables+import Data.Comp.Sum+import Data.Comp+import qualified Data.Foldable as F++-- we interpret integers as variables here+++instance HasVars Value Int where+    isVar (VInt i) = Just i+    isVar _ = Nothing++instance HasVars Op Int where++instance HasVars Sugar Int where++contVar :: Int -> SugarExpr -> Bool+contVar = containsVar+++freeVars :: SugarExpr -> [Int]+freeVars = variableList++contVar' :: Int -> SugarExpr -> Bool+contVar' i = cata alg+    where alg :: SugarSig Bool -> Bool+          alg x = case proj x of+                    Just (VInt j) -> i == j+                    _ -> F.foldl (||) False x++contVarGen :: Int -> SugarExpr -> Bool+contVarGen i e = elem i [ j | VInt j <- subterms' e]++freeVars' :: SugarExpr -> [Int]+freeVars' = cata alg+    where alg :: SugarSig [Int] -> [Int]+          alg x = case proj x of+                    Just (VInt j) -> [ j ]+                    _ -> F.foldl (++) [] x+++freeVarsGen :: SugarExpr -> [Int]+freeVarsGen e =  [ j | VInt j <- subterms' e]
+ benchmark/Functions/Comp/Inference.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances #-}++module Functions.Comp.Inference where++import Functions.Comp.Desugar+import DataTypes.Comp+import Data.Comp+import Data.Traversable++-- type inference++class Monad m => InferType f t m where+    inferTypeAlg :: f (Term t) -> m (Term t)++inferType :: (Traversable f, InferType f t m) => Term f -> m (Term t)+inferType = cataM inferTypeAlg++inferBaseType :: (Traversable f, InferType f ValueT m) => Term f -> m BaseType+inferBaseType = inferType++instance (InferType f t m, InferType g t m) => InferType (f :+: g) t m where+    inferTypeAlg (Inl v) = inferTypeAlg v+    inferTypeAlg (Inr v) = inferTypeAlg v++instance (ValueT :<: t, Monad m) => InferType Value t m where+    inferTypeAlg (VInt _) = return $ inject TInt+    inferTypeAlg (VBool _) = return $ inject TBool+    inferTypeAlg (VPair x y) = return $ inject $ TPair x y++check:: (g :<: f, Eq (g (Term f)), Monad m) =>+        g (Term f) -> Term f -> m ()+check f t = if project t == Just f then return () else fail ""++checkEq :: (Eq a, Monad m) => a -> a -> m ()+checkEq x y = if x == y then return () else fail ""++checkOp :: (g :<: f, Eq (g (Term f)), Monad m) =>+           [g (Term f)] -> g (Term f) -> [Term f] -> m (Term f)+checkOp exs ret tys = sequence_ (zipWith check exs tys) >> return $ inject ret+++instance (ValueT :<: t, EqF t, Monad m) => InferType Op t m where+    inferTypeAlg (Plus x y) = checkOp [TInt,TInt] TInt [x ,y]+    inferTypeAlg (Mult x y) = checkOp [TInt,TInt] TInt [x ,y]+    inferTypeAlg (Lt x y) = checkOp [TInt,TInt] TBool [x ,y]+    inferTypeAlg (And x y) = checkOp [TBool,TBool] TBool [x ,y]+    inferTypeAlg (Not x) = checkOp [TBool] TBool [x]+    inferTypeAlg (If b x y) = check TBool b >> checkEq x y >> return x+    inferTypeAlg (Eq x y) = checkEq x y >> return $ iTBool+    inferTypeAlg (Proj p x) = case project x of+                                Just (TPair x1 x2) -> return $+                                    case p of+                                      ProjLeft -> x1+                                      ProjRight -> x2+                                _ -> fail ""++instance (ValueT :<: t, EqF t, Monad m) => InferType Sugar t m where+    inferTypeAlg (Minus x y) = checkOp [TInt,TInt] TInt [x ,y]+    inferTypeAlg (Neg x) = checkOp [TInt] TInt [x]+    inferTypeAlg (Gt x y) = checkOp [TInt,TInt] TBool [x ,y]+    inferTypeAlg (Or x y) = checkOp [TBool,TBool] TBool [x ,y]+    inferTypeAlg (Impl x y) = checkOp [TBool,TBool] TBool [x ,y]++desugarType :: SugarExpr -> Err BaseType+desugarType = inferType . (desugar :: SugarExpr -> Expr)++typeSugar :: SugarExpr -> Err BaseType+typeSugar = inferType++desugarTypeAlg  :: AlgM Err SugarSig BaseType+desugarTypeAlg = inferTypeAlg  `compAlgM'` (desugarAlg :: TermHom SugarSig ExprSig)++desugarType' :: SugarExpr -> Err BaseType+desugarType' e = cataM desugarTypeAlg e++-- pure type inference++class InferType2 f t where+    inferTypeAlg2 :: f (Term t) -> (Term t)++inferType2 :: (Functor f, InferType2 f t) => Term f -> (Term t)+inferType2 = cata inferTypeAlg2++inferBaseType2 :: (Functor f, InferType2 f ValueT) => Term f -> BaseType+inferBaseType2 = inferType2++instance (InferType2 f t, InferType2 g t) => InferType2 (f :+: g) t where+    inferTypeAlg2 (Inl v) = inferTypeAlg2 v+    inferTypeAlg2 (Inr v) = inferTypeAlg2 v++instance (ValueT :<: t) => InferType2 Value t where+    inferTypeAlg2 (VInt _) = inject TInt+    inferTypeAlg2 (VBool _) = inject TBool+    inferTypeAlg2 (VPair x y) = inject $ TPair x y++check2:: (g :<: f, Eq (g (Term f))) =>+        g (Term f) -> Term f -> a -> a+check2 f t z = if project t == Just f then z else error ""++checkEq2 :: (Eq a) => a -> a -> b -> b+checkEq2 x y z = if x == y then z else error ""++runCheck :: [a -> a] -> a -> a+runCheck = foldr (.) id++checkOp2 :: (g :<: f, Eq (g (Term f))) =>+           [g (Term f)] -> g (Term f) -> [Term f] -> (Term f)+checkOp2 exs ret tys = runCheck (zipWith check2 exs tys) (inject ret)+++instance (ValueT :<: t, EqF t) => InferType2 Op t where+    inferTypeAlg2 (Plus x y) = checkOp2 [TInt,TInt] TInt [x ,y]+    inferTypeAlg2 (Mult x y) = checkOp2 [TInt,TInt] TInt [x ,y]+    inferTypeAlg2 (Lt x y) = checkOp2 [TInt,TInt] TBool [x ,y]+    inferTypeAlg2 (And x y) = checkOp2 [TBool,TBool] TBool [x ,y]+    inferTypeAlg2 (Not x) = checkOp2 [TBool] TBool [x]+    inferTypeAlg2 (If b x y) = checkEq2 x y $ check2 TBool b $ x+    inferTypeAlg2 (Eq x y) = checkEq2 x y $ iTBool+    inferTypeAlg2 (Proj p x) = case project x of+                                Just (TPair x1 x2) -> +                                    case p of+                                      ProjLeft -> x1+                                      ProjRight -> x2+                                _ -> error ""++instance (ValueT :<: t, EqF t) => InferType2 Sugar t where+    inferTypeAlg2 (Minus x y) = checkOp2 [TInt,TInt] TInt [x ,y]+    inferTypeAlg2 (Neg x) = checkOp2 [TInt] TInt [x]+    inferTypeAlg2 (Gt x y) = checkOp2 [TInt,TInt] TBool [x ,y]+    inferTypeAlg2 (Or x y) = checkOp2 [TBool,TBool] TBool [x ,y]+    inferTypeAlg2 (Impl x y) = checkOp2 [TBool,TBool] TBool [x ,y]++desugarType2 :: SugarExpr -> BaseType+desugarType2 = inferType2 . (desugar :: SugarExpr -> Expr)++typeSugar2 :: SugarExpr -> BaseType+typeSugar2 = inferType2++desugarTypeAlg2  :: Alg SugarSig BaseType+desugarTypeAlg2 = inferTypeAlg2  `compAlg` (desugarAlg :: TermHom SugarSig ExprSig)++desugarType2' :: SugarExpr -> Err BaseType+desugarType2' e = cataM desugarTypeAlg e
+ benchmark/Functions/Standard.hs view
@@ -0,0 +1,9 @@+module Functions.Standard+    ( module Functions.Standard.Desugar,+      module Functions.Standard.Eval,+      module Functions.Standard.Inference,+      module Functions.Standard.FreeVars) where+import Functions.Standard.Desugar+import Functions.Standard.Eval+import Functions.Standard.Inference+import Functions.Standard.FreeVars
+ benchmark/Functions/Standard/Desugar.hs view
@@ -0,0 +1,23 @@+module Functions.Standard.Desugar where++import DataTypes.Standard++-- de-sugar++desugar :: PExpr -> OExpr+desugar (PInt i) = OInt i+desugar (PBool b) = OBool b+desugar (PPair x y) = OPair (desugar x) (desugar y)+desugar (PPlus x y) = OPlus (desugar x) (desugar y)+desugar (PMult x y) = OMult (desugar x) (desugar y)+desugar (PIf b x y) = OIf (desugar b) (desugar x) (desugar y)+desugar (PEq x y) = OEq (desugar x) (desugar y)+desugar (PLt x y) = OLt (desugar x) (desugar y)+desugar (PAnd x y) = OAnd (desugar x) (desugar y)+desugar (PNot x) = ONot (desugar x)+desugar (PProj p x) = OProj p (desugar x)+desugar (PNeg x) = OInt (-1) `OMult` (desugar x)+desugar (PMinus x y) = (desugar x) `OPlus` ((OInt (-1)) `OMult` (desugar y))+desugar (PGt x y) = (desugar y) `OLt` (desugar x)+desugar (POr x y) = ONot (ONot (desugar x) `OAnd` ONot (desugar y))+desugar (PImpl x y) = ONot ((desugar x) `OAnd` ONot (desugar y))
+ benchmark/Functions/Standard/Eval.hs view
@@ -0,0 +1,149 @@+module Functions.Standard.Eval where++import DataTypes.Standard+import Functions.Standard.Desugar+import Control.Monad++coerceInt :: (Monad m) => SExpr -> m Int+coerceInt (SInt i) = return i+coerceInt _ = fail ""++coerceBool :: (Monad m) => SExpr -> m Bool+coerceBool (SBool b) = return b+coerceBool _ = fail ""++coercePair :: (Monad m) => SExpr -> m (SExpr,SExpr)+coercePair (SPair x y) = return (x,y)+coercePair _ = fail ""++eval :: (Monad m) => OExpr -> m SExpr+eval (OInt i) = return $ SInt i+eval (OBool b) = return $ SBool b+eval (OPair x y) = liftM2 SPair (eval x) (eval y)+eval (OPlus x y) = liftM2 (\ x y -> SInt (x + y)) (eval x >>= coerceInt) (eval y >>= coerceInt)+eval (OMult x y) = liftM2 (\ x y -> SInt (x * y)) (eval x >>= coerceInt) (eval y >>= coerceInt)+eval (OIf b x y) = eval b >>= coerceBool >>= (\b -> if b then eval x else eval y)+eval (OEq x y) = liftM2 (\ x y -> SBool (x == y)) (eval x) (eval y)+eval (OLt x y) = liftM2 (\ x y -> SBool (x < y)) (eval x >>= coerceInt) (eval y >>= coerceInt)+eval (OAnd x y) = liftM2 (\ x y -> SBool (x && y)) (eval x >>= coerceBool) (eval y >>= coerceBool)+eval (ONot x) = liftM (SBool . not)(eval x >>= coerceBool)+eval (OProj p x) = liftM select (eval x >>= coercePair)+    where select (x,y) = case p of+                           SProjLeft -> x+                           SProjRight -> y++evalSugar :: PExpr -> Err SExpr+evalSugar (PInt i) = return $ SInt i+evalSugar (PBool b) = return $ SBool b+evalSugar (PPair x y) = liftM2 SPair (evalSugar x) (evalSugar y)+evalSugar (PPlus x y) = liftM2 (\ x y -> SInt (x + y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)+evalSugar (PMult x y) = liftM2 (\ x y -> SInt (x * y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)+evalSugar (PIf b x y) = evalSugar b >>= coerceBool >>= (\b -> if b then evalSugar x else evalSugar y)+evalSugar (PEq x y) = liftM2 (\ x y -> SBool (x == y)) (evalSugar x) (evalSugar y)+evalSugar (PLt x y) = liftM2 (\ x y -> SBool (x < y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)+evalSugar (PAnd x y) = liftM2 (\ x y -> SBool (x && y)) (evalSugar x >>= coerceBool) (evalSugar y >>= coerceBool)+evalSugar (PNot x) = liftM (SBool . not)(evalSugar x >>= coerceBool)+evalSugar (PProj p x) = liftM select (evalSugar x >>= coercePair)+    where select (x,y) = case p of+                           SProjLeft -> x+                           SProjRight -> y+evalSugar (PNeg x) = liftM (SInt . negate) (evalSugar x >>= coerceInt)+evalSugar (PMinus x y) = liftM2 (\ x y -> SInt (x - y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)+evalSugar (PGt x y) = liftM2 (\ x y -> SBool (x > y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)+evalSugar (POr x y) = liftM2 (\ x y -> SBool (x || y)) (evalSugar x >>= coerceBool) (evalSugar y >>= coerceBool)+evalSugar (PImpl x y) = liftM2 (\ x y -> SBool (not x || y)) (evalSugar x >>= coerceBool) (evalSugar y >>= coerceBool)++desugarEval :: PExpr -> Err SExpr+desugarEval = eval . desugar+++coerceInt2 :: SExpr -> Int+coerceInt2 (SInt i) = i+coerceInt2 _ = undefined++coerceBool2 :: SExpr -> Bool+coerceBool2 (SBool b) = b+coerceBool2 _ = undefined++coercePair2 :: SExpr -> (SExpr,SExpr)+coercePair2 (SPair x y) = (x,y)+coercePair2 _ = undefined++eval2 :: OExpr -> SExpr+eval2 (OInt i) = SInt i+eval2 (OBool b) = SBool b+eval2 (OPair x y) = SPair (eval2 x) (eval2 y)+eval2 (OPlus x y) = (\ x y -> SInt (x + y)) (coerceInt2 $ eval2 x) (coerceInt2 $ eval2 y)+eval2 (OMult x y) = (\ x y -> SInt (x * y)) (coerceInt2 $ eval2 x) (coerceInt2 $ eval2 y)+eval2 (OIf b x y) = if coerceBool2 $ eval2 b then eval2 x else eval2 y+eval2 (OEq x y) = (\ x y -> SBool (x == y)) (eval2 x) (eval2 y)+eval2 (OLt x y) = (\ x y -> SBool (x < y)) (coerceInt2 $ eval2 x) (coerceInt2 $ eval2 y)+eval2 (OAnd x y) =(\ x y -> SBool (x && y)) (coerceBool2 $ eval2 x) (coerceBool2 $ eval2 y)+eval2 (ONot x) = (SBool . not)(coerceBool2 $ eval2 x)+eval2 (OProj p x) = select (coercePair2 $ eval2 x)+    where select (x,y) = case p of+                           SProjLeft -> x+                           SProjRight -> y+++evalSugar2 :: PExpr -> SExpr+evalSugar2 (PInt i) = SInt i+evalSugar2 (PBool b) =  SBool b+evalSugar2 (PPair x y) = SPair (evalSugar2 x) (evalSugar2 y)+evalSugar2 (PPlus x y) = (\ x y -> SInt (x + y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)+evalSugar2 (PMult x y) = (\ x y -> SInt (x * y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)+evalSugar2 (PIf b x y) = if coerceBool2 $ evalSugar2 b then evalSugar2 x else evalSugar2 y+evalSugar2 (PEq x y) = (\ x y -> SBool (x == y)) (evalSugar2 x) (evalSugar2 y)+evalSugar2 (PLt x y) = (\ x y -> SBool (x < y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)+evalSugar2 (PAnd x y) = (\ x y -> SBool (x && y)) (coerceBool2 $ evalSugar2 x) (coerceBool2 $ evalSugar2 y)+evalSugar2 (PNot x) = (SBool . not)(coerceBool2 $ evalSugar2 x)+evalSugar2 (PProj p x) = select (coercePair2 $ evalSugar2 x)+    where select (x,y) = case p of+                           SProjLeft -> x+                           SProjRight -> y+evalSugar2 (PNeg x) = (SInt . negate) (coerceInt2 $ evalSugar2 x)+evalSugar2 (PMinus x y) = (\ x y -> SInt (x - y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)+evalSugar2 (PGt x y) = (\ x y -> SBool (x > y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)+evalSugar2 (POr x y) = (\ x y -> SBool (x || y)) (coerceBool2 $ evalSugar2 x) (coerceBool2 $ evalSugar2 y)+evalSugar2 (PImpl x y) = (\ x y -> SBool (not x || y)) (coerceBool2 $ evalSugar2 x) (coerceBool2 $ evalSugar2 y)++desugarEval2 :: PExpr -> SExpr+desugarEval2 = eval2 . desugar+++++coerceHOASInt2 :: HOASSExpr -> Int+coerceHOASInt2 (HOASSInt i) = i+coerceHOASInt2 _ = undefined++coerceHOASBool2 :: HOASSExpr -> Bool+coerceHOASBool2 (HOASSBool b) = b+coerceHOASBool2 _ = undefined++coerceHOASPair2 :: HOASSExpr -> (HOASSExpr,HOASSExpr)+coerceHOASPair2 (HOASSPair x y) = (x,y)+coerceHOASPair2 _ = undefined++coerceHOASLam2 :: HOASSExpr -> HOASSExpr -> HOASSExpr+coerceHOASLam2 (HOASSLam f) = f+coerceHOASLam2 _ = undefined++evalHOAS :: HOASExpr -> HOASSExpr+evalHOAS (HOASInt i) = HOASSInt i+evalHOAS (HOASBool b) = HOASSBool b+evalHOAS (HOASPair x y) = HOASSPair (evalHOAS x) (evalHOAS y)+evalHOAS (HOASPlus x y) = (\ x y -> HOASSInt (x + y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)+evalHOAS (HOASMult x y) = (\ x y -> HOASSInt (x * y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)+evalHOAS (HOASIf b x y) = if coerceHOASBool2 $ evalHOAS b then evalHOAS x else evalHOAS y+evalHOAS (HOASEq x y) = (\ x y -> HOASSBool (x == y)) (evalHOAS x) (evalHOAS y)+evalHOAS (HOASLt x y) = (\ x y -> HOASSBool (x < y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)+evalHOAS (HOASAnd x y) =(\ x y -> HOASSBool (x && y)) (coerceHOASBool2 $ evalHOAS x) (coerceHOASBool2 $ evalHOAS y)+evalHOAS (HOASNot x) = (HOASSBool . not)(coerceHOASBool2 $ evalHOAS x)+evalHOAS (HOASProj p x) = select (coerceHOASPair2 $ evalHOAS x)+    where select (x,y) = case p of+                           SProjLeft -> x+                           SProjRight -> y+evalHOAS (HOASApp x y) = (coerceHOASLam2 $ evalHOAS x) (evalHOAS y)+evalHOAS (HOASLam f) = HOASSLam $ evalHOAS . f+evalHOAS (HOASVal v) = v
+ benchmark/Functions/Standard/FreeVars.hs view
@@ -0,0 +1,73 @@+module Functions.Standard.FreeVars where++import DataTypes.Standard+import Data.Generics.PlateDirect++instance Uniplate PExpr where+    uniplate (PInt x) = plate PInt |- x+    uniplate (PBool x) = plate PBool |- x+    uniplate (PPair x y) = plate PPair |* x |* y+    uniplate (PMult x y) = plate PMult |* x |* y+    uniplate (PPlus x y) = plate PPlus |* x |* y+    uniplate (PIf x y z) = plate PIf |* x |* y |* z+    uniplate (PEq x y) = plate PEq |* x |* y+    uniplate (PLt x y) = plate PLt |* x |* y+    uniplate (PAnd x y) = plate PAnd |* x |* y+    uniplate (PNot x) = plate PNot |* x+    uniplate (PProj x y) = plate PProj |- x |* y+    uniplate (PNeg x) = plate PNeg |* x+    uniplate (PMinus x y) = plate PMinus |* x |* y+    uniplate (PGt x y) = plate PGt |* x |* y+    uniplate (POr x y) = plate POr |* x |* y+    uniplate (PImpl x y) = plate PImpl |* x |* y+++contVar :: Int -> PExpr -> Bool+contVar v e = +    case e of+      PInt i -> i == v+      PBool{} -> False+      PPair x y -> re x || re y+      PPlus x y -> re x || re y+      PMult x y -> re x || re y+      PIf x y z -> re x || re y || re z+      PEq x y -> re x || re y+      PLt x y -> re x || re y+      PAnd x y -> re x || re y+      PNot x -> re x+      PProj _ x -> re x+      PNeg x -> re x+      PMinus x y -> re x || re y+      PGt x y -> re x || re y+      POr x y -> re x || re y+      PImpl x y -> re x || re y+    where re = contVar v++freeVars :: PExpr -> [Int]+freeVars e = +    case e of+      PInt i -> [i]+      PBool{} -> []+      PPair x y -> re2 x y+      PPlus x y -> re2 x y+      PMult x y -> re2 x y+      PIf x y z -> re3 x y z+      PEq x y -> re2 x y+      PLt x y -> re2 x y+      PAnd x y -> re2 x y+      PNot x -> re x+      PProj _ x -> re x+      PNeg x -> re x+      PMinus x y -> re2 x y+      PGt x y -> re2 x y+      POr x y -> re2 x y+      PImpl x y -> re2 x y+    where re = freeVars+          re2 x y = re x ++ re y+          re3 x y z = re x ++ re y ++ re z++contVarGen :: Int -> PExpr -> Bool+contVarGen v e = elem v [ j | (PInt j) <- universe e]++freeVarsGen :: PExpr -> [Int]+freeVarsGen e = [ j | (PInt j) <- universe e]
+ benchmark/Functions/Standard/Inference.hs view
@@ -0,0 +1,153 @@+module Functions.Standard.Inference where++import DataTypes.Standard+import Control.Monad+import Functions.Standard.Desugar++checkOp :: (Monad 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 (OInt _) = return VTInt+inferType (OBool _) = return VTBool+inferType (OPair x y) = liftM2 VTPair (inferType x) (inferType y)+inferType (OPlus x y) = checkOp [VTInt,VTInt] VTInt [x,y]+inferType (OMult x y) = checkOp [VTInt,VTInt] VTInt [x,y]+inferType (OIf b x y) = do [bty,xty,yty] <- mapM inferType [b,x,y]+                           if (bty == VTBool) && xty == yty+                             then return xty+                             else fail ""+inferType (OLt x y) = checkOp [VTInt,VTInt] VTBool [x,y]+inferType (OEq x y) = do [xty,yty] <- mapM inferType [x,y]+                         if xty == yty+                            then return VTBool+                            else fail ""+inferType (OAnd x y) = checkOp [VTBool,VTBool] VTBool [x,y]+inferType (ONot x) = checkOp [VTBool] VTBool [x]+inferType (OProj p x) = do xty <- inferType x+                           case xty of+                             VTPair s t -> return $+                                 case p of +                                   SProjLeft -> s+                                   SProjRight -> t+                             _ -> fail ""+++checkOpP :: [VType] -> VType -> [PExpr] -> Err VType+checkOpP tys rety args = do +  argsty <- mapM typeSugar args+  if tys == argsty+     then return rety+     else fail ""++--typeSugar :: (Monad m) => PExpr -> m VType+typeSugar :: PExpr -> Err VType+typeSugar (PInt _) = return VTInt+typeSugar (PBool _) = return VTBool+typeSugar (PPair x y) = liftM2 VTPair (typeSugar x) (typeSugar y)+typeSugar (PPlus x y) = checkOpP [VTInt,VTInt] VTInt [x,y]+typeSugar (PMult x y) = checkOpP [VTInt,VTInt] VTInt [x,y]+typeSugar (PIf b x y) = do [bty,xty,yty] <- mapM typeSugar [b,x,y]+                           if (bty == VTBool) && xty == yty+                             then return xty+                             else fail ""+typeSugar (PLt x y) = checkOpP [VTInt,VTInt] VTBool [x,y]+typeSugar (PEq x y) = do [xty,yty] <- mapM typeSugar [x,y]+                         if xty == yty+                            then return VTBool+                            else fail ""+typeSugar (PAnd x y) = checkOpP [VTBool,VTBool] VTBool [x,y]+typeSugar (PNot x) = checkOpP [VTBool] VTBool [x]+typeSugar (PProj p x) = do xty <- typeSugar x+                           case xty of+                             VTPair s t -> return $+                                 case p of +                                   SProjLeft -> s+                                   SProjRight -> t+                             _ -> fail ""+typeSugar (PNeg x) = checkOpP [VTInt] VTInt [x]+typeSugar (PMinus x y) = checkOpP [VTInt,VTInt] VTInt [x,y]+typeSugar (PGt x y) = checkOpP [VTInt,VTInt] VTBool [x,y]+typeSugar (POr x y) = checkOpP [VTBool,VTBool] VTBool [x,y]+typeSugar (PImpl x y) = checkOpP [VTBool,VTBool] VTBool [x,y]++desugarType :: PExpr -> Err VType+desugarType = inferType . desugar++-- non-monadic++checkOp2 :: [VType] -> VType -> [OExpr] -> VType+checkOp2 tys rety args = +  if tys == map inferType2 args+     then rety+     else error ""++inferType2 :: OExpr -> VType+inferType2 (OInt _) = VTInt+inferType2 (OBool _) = VTBool+inferType2 (OPair x y) = VTPair (inferType2 x) (inferType2 y)+inferType2 (OPlus x y) = checkOp2 [VTInt,VTInt] VTInt [x,y]+inferType2 (OMult x y) = checkOp2 [VTInt,VTInt] VTInt [x,y]+inferType2 (OIf b x y) =  let [bty,xty,yty] = map inferType2 [b,x,y]+                         in if (bty == VTBool) && xty == yty+                             then xty+                             else error ""+inferType2 (OLt x y) = checkOp2 [VTInt,VTInt] VTBool [x,y]+inferType2 (OEq x y) = let [xty,yty] = map inferType2 [x,y]+                      in if xty == yty+                            then VTBool+                            else error ""+inferType2 (OAnd x y) = checkOp2 [VTBool,VTBool] VTBool [x,y]+inferType2 (ONot x) = checkOp2 [VTBool] VTBool [x]+inferType2 (OProj p x) = let xty = inferType2 x+                        in case xty of+                             VTPair s t -> +                                 case p of +                                   SProjLeft -> s+                                   SProjRight -> t+                             _ -> error ""+++checkOpP2 :: [VType] -> VType -> [PExpr] -> VType+checkOpP2 tys rety args = +  if tys == map typeSugar2 args+     then rety+     else error ""++--typeSugar :: (Monad m) => PExpr -> m VType+typeSugar2 :: PExpr -> VType+typeSugar2 (PInt _) = VTInt+typeSugar2 (PBool _) = VTBool+typeSugar2 (PPair x y) = VTPair (typeSugar2 x) (typeSugar2 y)+typeSugar2 (PPlus x y) = checkOpP2 [VTInt,VTInt] VTInt [x,y]+typeSugar2 (PMult x y) = checkOpP2 [VTInt,VTInt] VTInt [x,y]+typeSugar2 (PIf b x y) = let [bty,xty,yty] = map typeSugar2 [b,x,y]+                        in if (bty == VTBool) && xty == yty+                             then xty+                             else error ""+typeSugar2 (PLt x y) = checkOpP2 [VTInt,VTInt] VTBool [x,y]+typeSugar2 (PEq x y) = let [xty,yty] = map typeSugar2 [x,y]+                      in if xty == yty+                            then VTBool+                            else error ""+typeSugar2 (PAnd x y) = checkOpP2 [VTBool,VTBool] VTBool [x,y]+typeSugar2 (PNot x) = checkOpP2 [VTBool] VTBool [x]+typeSugar2 (PProj p x) = let xty = typeSugar2 x+                        in case xty of+                             VTPair s t -> +                                 case p of +                                   SProjLeft -> s+                                   SProjRight -> t+                             _ -> error ""+typeSugar2 (PNeg x) = checkOpP2 [VTInt] VTInt [x]+typeSugar2 (PMinus x y) = checkOpP2 [VTInt,VTInt] VTInt [x,y]+typeSugar2 (PGt x y) = checkOpP2 [VTInt,VTInt] VTBool [x,y]+typeSugar2 (POr x y) = checkOpP2 [VTBool,VTBool] VTBool [x,y]+typeSugar2 (PImpl x y) = checkOpP2 [VTBool,VTBool] VTBool [x,y]++desugarType2 :: PExpr -> VType+desugarType2 = inferType2 . desugar
+ benchmark/Multi/DataTypes/Comp.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE+  TemplateHaskell,+  FlexibleInstances,+  FlexibleContexts,+  TypeOperators,+  GADTs,+  KindSignatures,+  IncoherentInstances #-}++-- base values++module Multi.DataTypes.Comp where++import Data.Comp.Derive+import Data.Comp.Multi++type ValueExpr = HTerm Value+type ExprSig = Value :++: Op+type Expr = HTerm ExprSig+type SugarSig = Value :++: Op :++: Sugar+type SugarExpr = HTerm SugarSig+type BaseType = HTerm ValueT++data ValueT e t = TInt+                | TBool+                | TPair (e t) (e t)+          deriving (Eq)++data Value e t where+    VInt :: Int -> Value e Int+    VBool :: Bool -> Value e Bool+    VPair :: e s -> e t -> Value e (s,t)++data Op e t where+    Plus :: e Int -> e Int -> Op e Int+    Mult :: e Int -> e Int -> Op e Int+    If :: e Bool -> e t -> e t -> Op e t+    Lt :: e Int -> e Int -> Op e Bool+    Eq :: e Int -> e Int -> Op e Bool+    And :: e Bool -> e Bool -> Op e Bool+    Not :: e Bool -> Op e Bool+    ProjLeft :: e (s,t) -> Op e s+    ProjRight :: e (s,t) -> Op e t++data Sugar e t where+    Neg  :: e Int -> Sugar e Int+    Minus :: e Int -> e Int -> Sugar e Int+    Gt :: e Int -> e Int -> Sugar e Bool+    Or :: e Bool -> e Bool -> Sugar e Bool+    Impl :: e Bool -> e Bool -> Sugar e Bool++$(derive+  [instanceHFunctor, instanceHFoldable, instanceHTraversable, instanceHEqF, smartHConstructors]+  [''ValueT, ''Value, ''Op, ''Sugar])+++showBinOp :: String -> String -> String -> String+showBinOp op x y = "("++ x ++ op ++ y ++ ")"++instance HShowF ValueT where+    hshowF' TInt = "Int"+    hshowF' TBool = "Bool"+    hshowF' (TPair (K x) (K y)) = showBinOp "," x y++instance HShowF Value where+    hshowF' (VInt i) = show i+    hshowF' (VBool b) = show b+    hshowF' (VPair (K x) (K y)) = showBinOp "," x y++instance HShowF Op where+    hshowF' (Plus (K x) (K y)) = showBinOp "+" x y+    hshowF' (Mult (K x) (K y)) = showBinOp "*" x y+    hshowF' (If (K b) (K x) (K y)) = "if " ++ b ++ " then " ++ x ++ " else " ++ y ++ " fi"+    hshowF' (Eq (K x) (K y)) = showBinOp "==" x y+    hshowF' (Lt (K x) (K y)) = showBinOp "<" x y+    hshowF' (And (K x) (K y)) = showBinOp "&&" x y+    hshowF' (Not (K x)) = "~" ++ x+    hshowF' (ProjLeft (K x)) = x ++ "!0"+    hshowF' (ProjRight (K x)) = x ++ "!1"
+ benchmark/Multi/Functions/Comp/Desugar.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances,+  GADTs#-}++module Multi.Functions.Comp.Desugar where++import Multi.DataTypes.Comp+import Data.Comp.Multi++-- de-sugar++class (HFunctor e, HFunctor f) => Desugar f e where+    desugarAlg :: HTermHom f e+    desugarAlg = desugarAlg' . hfmap HHole+    desugarAlg' :: HAlg f (HContext e a)+    desugarAlg' x = appHCxt $ desugarAlg x++desugarExpr :: SugarExpr :-> Expr+desugarExpr = desugar++desugar :: Desugar f e => HTerm f :-> HTerm e+desugar = appHTermHom desugarAlg++instance (Desugar f e, Desugar g e) => Desugar (g :++: f) e where+    desugarAlg (HInl v) = desugarAlg v+    desugarAlg (HInr v) = desugarAlg v++instance (Value :<<: v, HFunctor v) => Desugar Value v where+    desugarAlg = liftHCxt++instance (Op :<<: v, HFunctor v) => Desugar Op v where+    desugarAlg = liftHCxt++instance (Op :<<: v, Value :<<: v, HFunctor v) => Desugar Sugar v where+    desugarAlg' (Neg x) =  iVInt (-1) `iMult` x+    desugarAlg' (Minus x y) =  x `iPlus` ((iVInt (-1)) `iMult` y)+    desugarAlg' (Gt x y) =  y `iLt` x+    desugarAlg' (Or x y) = iNot (iNot x `iAnd` iNot y)+    desugarAlg' (Impl x y) = iNot (x `iAnd` iNot y)
+ benchmark/Multi/Functions/Comp/Eval.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE+  GADTs,+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances#-}++module Multi.Functions.Comp.Eval where++import Multi.DataTypes.Comp+import Multi.Functions.Comp.Desugar+import Data.Comp.Multi+import Data.Comp.Multi.HEquality++-- evaluation++class Eval e v where+    evalAlg :: Alg e (Term v)++eval :: (HFunctor e, Eval e v) => Term e :-> (Term v)+eval = cata evalAlg++instance (Eval f v, Eval g v) => Eval (f :++: g) v where+    evalAlg (HInl v) = evalAlg v+    evalAlg (HInr v) = evalAlg v++instance (Value :<<: v) => Eval Value v where+    evalAlg = inject+++getInt :: (Value :<<: v) => Term v Int -> Int+getInt t = case project t of+             Just (VInt x) -> x+             Nothing -> undefined+getBool :: (Value :<<: v) => Term v Bool -> Bool+getBool t = case project t of+             Just (VBool x) -> x+             Nothing -> undefined++getPair :: (Value :<<: v) => Term v (s,t) -> ((Term v s), (Term v t))+getPair t = case project t of+              Just (VPair x y) -> (x, y)+              Nothing -> undefined+++instance (Value :<<: v, HEqF v) => Eval Op v where+    evalAlg (Plus x y) = iVInt $ getInt x + getInt y+    evalAlg (Mult x y) = iVInt $ getInt x * getInt y+    evalAlg (If b x y) = if getBool b then x else y+    evalAlg (Eq x y) = iVBool $ x == y+    evalAlg (Lt x y) = iVBool $ getInt x < getInt y+    evalAlg (And x y) = iVBool $ getBool x && getBool y+    evalAlg (Not x) = iVBool $ not $ getBool x+    evalAlg (ProjLeft x) = fst $ getPair x+    evalAlg (ProjRight x) = snd $ getPair x++instance (Value :<<: v) => Eval Sugar v where+    evalAlg (Neg x) = iVInt $ negate $ getInt x+    evalAlg (Minus x y) = iVInt $ getInt x - getInt y+    evalAlg (Gt x y) = iVBool $ getInt x > getInt y+    evalAlg (Or x y) = iVBool $ getBool x || getBool y+    evalAlg (Impl x y) = iVBool $ not (getBool x) || getBool y++desugarEval :: SugarExpr :-> ValueExpr+desugarEval = eval . (desugar :: SugarExpr :-> Expr)++evalSugar :: SugarExpr :-> ValueExpr+evalSugar = eval++desugarEvalAlg  :: Alg SugarSig ValueExpr+desugarEvalAlg = evalAlg  `compAlg` (desugarAlg :: TermHom SugarSig ExprSig)++desugarEval' :: SugarExpr :-> ValueExpr+desugarEval' e = cata desugarEvalAlg e
+ benchmark/Transformations.hs view
@@ -0,0 +1,27 @@+module Transformations where++import DataTypes+import Data.Comp+++toBaseExp :: Term Value -> BaseExp+toBaseExp = algHom toBaseExpAlg+    where toBaseExpAlg (VInt i) = BInt i+          toBaseExpAlg (VBool b) = BBool b+          toBaseExpAlg (VString s) = BString s+          toBaseExpAlg (VDateTime d) = BDateTime d+          toBaseExpAlg (VDuration d) = BDuration d+          toBaseExpAlg (VDouble d) = BDouble d+          toBaseExpAlg (VRecord r) = BRecord r+          toBaseExpAlg (VList l) = BList l++toRepExp :: Term Value -> RepExp+toRepExp = algHom toRepExpAlg+    where toRepExpAlg (VInt i) = RInt i+          toRepExpAlg (VBool b) = RBool b+          toRepExpAlg (VString s) = RString s+          toRepExpAlg (VDateTime d) = RDateTime d+          toRepExpAlg (VDuration d) = RDuration d+          toRepExpAlg (VDouble d) = RDouble d+          toRepExpAlg (VRecord r) = RRecord r+          toRepExpAlg (VList l) = RList l
+ compdata.cabal view
@@ -0,0 +1,170 @@+Name:			compdata+Version:		0.1+Synopsis:            	Compositional Data Types+Description:++  Based on Wouter Swierstra's Functional Pearl /Data types à la carte/+  (Journal of Functional Programming, 18(4):423-436, 2008),+  this package provides a framework for defining recursive+  data types in a compositional manner. The fundamental idea of+  compositional data types is to separate the signature of a data type+  from the fixed point construction that produces its recursive+  structure. By allowing to compose and decompose signatures,+  /compositional data types/ enable to combine data types in a flexible+  way. The key point of Wouter Swierstra's original work is to define+  functions on /compositional data types/ in a compositional manner as+  well by leveraging Haskell's type class machinery.+  .+  Building on that foundation, this library provides additional+  extensions and (run-time) optimisations which makes compositional data types+  usable for practical implementations. In particular, it+  provides an excellent framework for manipulating and analysing+  abstract syntax trees in a type-safe manner. Thus, it is perfectly+  suited for programming language implementations, especially, in an environment+  consisting of a family of tightly interwoven /domain-specific languages/.+  .+  In concrete terms, this package provides the following features:+  .+  *  Compositional data types in the style of Wouter Swierstra's+     Functional Pearl /Data types à la carte/.+  .+  *  Modular definition of function on compositional data types through+     catamorphisms and anamorphisms as well as more structured+     recursion schemes such as primitive recursion  and co-recursion,+     and course-of-value iteration and co-iteration.+  .+  *  Support for monadic computations via monadic variants of all+     recursion schemes.+  .+  *  Support of a succinct programming style over compositional data types+     via generic programming combinators that allow various forms of+     generic transformations and generic queries.+  .+  *  Generalisation of compositional data types (terms) to+     compositional data types \"with holes\" (contexts). This allows+     flexible reuse of a wide variety of catamorphisms (called+     /term homomorphisms/) as well as an efficient composition of them.+  .+  *  Operations on signatures, for example, to add and remove+     annotations of abstract syntax trees. This includes combinators to+     propagate annotations fully automatically through certain+     term homomorphisms.+  .+  *  Optimisation of the implementation of recursion schemes. This+     includes /short-cut fusion/ style optimisation rules which yield a+     performance boost of up to factor six.+  .+  *  Efficient implementation of catamorphisms on non-polynomial+     signatures that contain function types. This allows to represent+     /higher-order abstract syntax/ with compositional data types.+  .+  *  Automatic derivation of instances of all relevant type classes for+     using compositional data types via /Template Haskell/. This includes+     instances of 'Prelude.Eq', 'Prelude.Ord' and 'Prelude.Show' that are+     derived via instances for functorial variants of them. Additionally,+     also /smart constructors/, which allow to easily construct inhabitants+     of compositional data types, are automatically generated.+  .+  *  /Mutually recursive data types/. All of the above is also lifted to+     families of mutually recursive data types.+  .+  For examples illustrating the use of compositional data types, consult+  "Data.Comp" resp. "Data.Comp.Multi" for mutually recursive data types.++Category:            	Generics+License:		BSD3+License-file:		LICENSE+Author:			Patrick Bahr, Tom Hvitved+Maintainer:		paba@diku.dk+Build-Type:		Custom+Cabal-Version:          >=1.8.0.6++extra-source-files:+  -- test files+  testsuite/tests/Data_Test.hs,+  testsuite/tests/Data/Comp_Test.hs,+  testsuite/tests/Data/Comp/Equality_Test.hs,+  testsuite/tests/Test/Utils.hs+  -- benchmark files+  benchmark/Benchmark.hs+  benchmark/DataTypes.hs+  benchmark/Functions.hs+  benchmark/DataTypes/Comp.hs+  benchmark/DataTypes/Transform.hs+  benchmark/DataTypes/Standard.hs+  benchmark/Multi/DataTypes/Comp.hs+  benchmark/Multi/Functions/Comp/Eval.hs+  benchmark/Multi/Functions/Comp/Desugar.hs+  benchmark/Transformations.hs+  benchmark/Functions/Comp.hs+  benchmark/Functions/Comp/Eval.hs+  benchmark/Functions/Comp/Desugar.hs+  benchmark/Functions/Comp/FreeVars.hs+  benchmark/Functions/Comp/Inference.hs+  benchmark/Functions/Standard/Eval.hs+  benchmark/Functions/Standard/Desugar.hs+  benchmark/Functions/Standard/FreeVars.hs+  benchmark/Functions/Standard/Inference.hs+  benchmark/Functions/Standard.hs+++flag test+  description: Build test executable.+  default:     False++flag benchmark+  description: Build benchmark executable.+  default:     False+++library+  Exposed-Modules:      Data.Comp, Data.Comp.Product, Data.Comp.Sum,+                        Data.Comp.Term, Data.Comp.Algebra, Data.Comp.Equality,+                        Data.Comp.Ordering, Data.Comp.DeepSeq, Data.Comp.Generic+                        Data.Comp.TermRewriting, Data.Comp.Automata,+                        Data.Comp.Arbitrary, Data.Comp.Show, Data.Comp.Variables,+                        Data.Comp.Decompose, Data.Comp.Unification,+                        Data.Comp.Derive, Data.Comp.Matching, Data.Comp.Multi,+                        Data.Comp.Multi.Term, Data.Comp.Multi.Sum,+                        Data.Comp.Multi.Functor, Data.Comp.Multi.ExpFunctor,+                        Data.Comp.Multi.Foldable, Data.Comp.Multi.Traversable,+                        Data.Comp.Multi.Algebra,+                        Data.Comp.Multi.Product, Data.Comp.Multi.Show,+                        Data.Comp.Multi.Equality, Data.Comp.Multi.Variables,+                        Data.Comp.Multi.Ops, Data.Comp.Ops, Data.Comp.ExpFunctor++  Other-Modules:        Data.Comp.Derive.Utils, Data.Comp.Derive.Equality,+                        Data.Comp.Derive.Ordering, Data.Comp.Derive.Arbitrary,+                        Data.Comp.Derive.Show, Data.Comp.Derive.DeepSeq,+                        Data.Comp.Derive.SmartConstructors,+                        Data.Comp.Derive.Foldable, Data.Comp.Derive.ExpFunctor,+                        Data.Comp.Derive.Traversable,+                        Data.Comp.Derive.Multi.Functor,+                        Data.Comp.Derive.Multi.Foldable,+                        Data.Comp.Derive.Multi.Traversable,+                        Data.Comp.Derive.Multi.Equality,+                        Data.Comp.Derive.Multi.Show,+                        Data.Comp.Derive.Multi.ExpFunctor,+                        Data.Comp.Derive.Multi.SmartConstructors++  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, th-expand-syns+  hs-source-dirs:	src+  ghc-options:          -W++Executable test+  Main-is:		Data_Test.hs+  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, test-framework, test-framework-quickcheck2, derive, th-expand-syns, deepseq+  hs-source-dirs:	src testsuite/tests+  ghc-options:          -fhpc+  if !flag(test)+    buildable:     False++Executable benchmark+  Main-is:		Benchmark.hs+  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns+  hs-source-dirs:	src benchmark+  ghc-options:          -W -O2+  -- Disable short-cut fusion rules in order to compare optimised and unoptimised code.+  cpp-options:          -DNO_RULES+  if !flag(benchmark)+    buildable:     False
+ src/Data/Comp.hs view
@@ -0,0 +1,429 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines the infrastructure necessary to use+-- /Compositional Data Types/. Compositional Data Types is an extension of+-- Wouter Swierstra's Functional Pearl: /Data types a la carte/. Examples of+-- usage are provided below.+--+--------------------------------------------------------------------------------+module Data.Comp(+  -- * Examples+  -- ** Pure Computations+  -- $ex1++  -- ** Monadic Computations+  -- $ex2++  -- ** Composing Term Homomorphisms and Algebras+  -- $ex3++  -- ** Lifting Term Homomorphisms to Products+  -- $ex4++  -- ** Higher-Order Abstract Syntax+  -- $ex5+    module Data.Comp.Term+  , module Data.Comp.Algebra+  , module Data.Comp.Sum+  , module Data.Comp.Product+  , module Data.Comp.Equality+  , module Data.Comp.Ordering+  , module Data.Comp.Generic+    ) where++import Data.Comp.Term+import Data.Comp.Algebra+import Data.Comp.Sum+import Data.Comp.Product+import Data.Comp.Equality+import Data.Comp.Ordering+import Data.Comp.Generic++{- $ex1+The example below illustrates how to use compositional data types to implement+a small expression language, with a sub language of values, and an evaluation+function mapping expressions to values.++The following language extensions are+needed in order to run the example: @TemplateHaskell@, @TypeOperators@,+@MultiParamTypeClasses@, @FlexibleInstances@, @FlexibleContexts@, and+@UndecidableInstances@.++> import Data.Comp+> import Data.Comp.Show ()+> import Data.Comp.Derive+> +> -- Signature for values and operators+> data Value e = Const Int | Pair e e+> data Op e = Add e e | Mult e e | Fst e | Snd e+> +> -- Signature for the simple expression language+> type Sig = Op :+: Value+> +> -- Derive boilerplate code using Template Haskell+> $(derive [instanceFunctor, instanceShowF, smartConstructors] [''Value, ''Op])+> +> -- Term evaluation algebra+> class Eval f v where+>   evalAlg :: Alg f (Term v)+> +> instance (Eval f v, Eval g v) => Eval (f :+: g) v where+>   evalAlg (Inl x) = evalAlg x+>   evalAlg (Inr x) = evalAlg x+> +> -- Lift the evaluation algebra to a catamorphism+> eval :: (Functor f, Eval f v) => Term f -> Term v+> eval = cata evalAlg+> +> instance (Value :<: v) => Eval Value v where+>   evalAlg = inject+> +> instance (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+>   evalAlg (Snd x)    = snd $ projP x+> +> projC :: (Value :<: v) => Term v -> Int+> projC v = let Just (Const n) = project v in n+> +> projP :: (Value :<: v) => Term v -> (Term v, Term v)+> projP v = let Just (Pair x y) = project v in (x,y)+> +> -- Example: evalEx = iConst 5+> evalEx :: Term Value+> evalEx = eval ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)+-}++{- $ex2+The example below illustrates how to use compositional data types to implement+a small expression language, with a sub language of values, and a monadic+evaluation function mapping expressions to values.++The following language+extensions are needed in order to run the example: @TemplateHaskell@,+@TypeOperators@, @MultiParamTypeClasses@, @FlexibleInstances@,+@FlexibleContexts@, and @UndecidableInstances@.++> import Data.Comp+> import Data.Comp.Derive+> import Control.Monad (liftM)+> +> -- Signature for values and operators+> data Value e = Const Int | Pair e e+> data Op e = Add e e | Mult e e | Fst e | Snd e+> +> -- Signature for the simple expression language+> type Sig = Op :+: Value+> +> -- Derive boilerplate code using Template Haskell+> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,+>           instanceEqF, instanceShowF, smartConstructors]+>          [''Value, ''Op])+> +> -- Monadic term evaluation algebra+> class EvalM f v where+>   evalAlgM :: AlgM Maybe f (Term v)+> +> instance (EvalM f v, EvalM g v) => EvalM (f :+: g) v where+>   evalAlgM (Inl x) = evalAlgM x+>   evalAlgM (Inr x) = evalAlgM x+> +> -- Lift the monadic evaluation algebra to a monadic catamorphism+> evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v)+> evalM = cataM evalAlgM+> +> instance (Value :<: v) => EvalM Value v where+>   evalAlgM = return . inject+> +> instance (Value :<: v) => EvalM Op v where+>   evalAlgM (Add x y)  = do n1 <- projC x+>                            n2 <- projC y+>                            return $ iConst $ n1 + n2+>   evalAlgM (Mult x y) = do n1 <- projC x+>                            n2 <- projC y+>                            return $ iConst $ n1 * n2+>   evalAlgM (Fst v)    = liftM fst $ projP v+>   evalAlgM (Snd v)    = liftM snd $ projP v+> +> projC :: (Value :<: v) => Term v -> Maybe Int+> projC v = case project v of+>             Just (Const n) -> return n+>             _ -> Nothing+> +> projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v)+> projP v = case project v of+>             Just (Pair x y) -> return (x,y)+>             _ -> Nothing+> +> -- Example: evalMEx = Just (iConst 5)+> evalMEx :: Maybe (Term Value)+> evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)+-}++{- $ex3+The example below illustrates how to compose a term homomorphism and an algebra,+exemplified via a desugaring term homomorphism and an evaluation algebra.++The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.++> import Data.Comp+> import Data.Comp.Show ()+> import Data.Comp.Derive+> +> -- Signature for values, operators, and syntactic sugar+> data Value e = Const Int | Pair e e+> data Op e = Add e e | Mult e e | Fst e | Snd e+> data Sugar e = Neg e | Swap e+>+> -- Source position information (line number, column number)+> data Pos = Pos Int Int+>            deriving Show+> +> -- Signature for the simple expression language+> type Sig = Op :+: Value+> type SigP = Op :&: Pos :+: Value :&: Pos+>+> -- Signature for the simple expression language, extended with syntactic sugar+> type Sig' = Sugar :+: Op :+: Value+> type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos+>+> -- Derive boilerplate code using Template Haskell+> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,+>           instanceEqF, instanceShowF, smartConstructors]+>          [''Value, ''Op, ''Sugar])+> +> -- Term homomorphism for desugaring of terms+> class (Functor f, Functor g) => Desugar f g where+>   desugHom :: TermHom f g+>   desugHom = desugHom' . fmap Hole+>   desugHom' :: Alg f (Context g a)+>   desugHom' x = appCxt (desugHom x)+> +> instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where+>   desugHom (Inl x) = desugHom x+>   desugHom (Inr x) = desugHom x+>   desugHom' (Inl x) = desugHom' x+>   desugHom' (Inr x) = desugHom' x+> +> instance (Value :<: v, Functor v) => Desugar Value v where+>   desugHom = simpCxt . inj+> +> instance (Op :<: v, Functor v) => Desugar Op v where+>   desugHom = simpCxt . inj+> +> instance (Op :<: v, Value :<: v, Functor v) => Desugar Sugar v where+>   desugHom' (Neg x)  = iConst (-1) `iMult` x+>   desugHom' (Swap x) = iSnd x `iPair` iFst x+>+> -- Term evaluation algebra+> class Eval f v where+>   evalAlg :: Alg f (Term v)+> +> instance (Eval f v, Eval g v) => Eval (f :+: g) v where+>   evalAlg (Inl x) = evalAlg x+>   evalAlg (Inr x) = evalAlg x+> +> instance (Value :<: v) => Eval Value v where+>   evalAlg = inject+> +> instance (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+>   evalAlg (Snd x)    = snd $ projP x+> +> projC :: (Value :<: v) => Term v -> Int+> projC v = let Just (Const n) = project v in n+> +> projP :: (Value :<: v) => Term v -> (Term v, Term v)+> projP v = let Just (Pair x y) = project v in (x,y)+>+> -- Compose the evaluation algebra and the desugaring homomorphism to an+> -- algebra+> eval :: Term Sig' -> Term Value+> eval = cata (evalAlg `compAlg` (desugHom :: TermHom Sig' Sig))+> +> -- Example: evalEx = iPair (iConst 2) (iConst 1)+> evalEx :: Term Value+> evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)+-}++{- $ex4+The example below illustrates how to lift a term homomorphism to products,+exemplified via a desugaring term homomorphism lifted to terms annotated with+source position information.++The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.++> import Data.Comp+> import Data.Comp.Show ()+> import Data.Comp.Derive+> +> -- Signature for values, operators, and syntactic sugar+> data Value e = Const Int | Pair e e+> data Op e = Add e e | Mult e e | Fst e | Snd e+> data Sugar e = Neg e | Swap e+>+> -- Source position information (line number, column number)+> data Pos = Pos Int Int+>            deriving Show+> +> -- Signature for the simple expression language+> type Sig = Op :+: Value+> type SigP = Op :&: Pos :+: Value :&: Pos+>+> -- Signature for the simple expression language, extended with syntactic sugar+> type Sig' = Sugar :+: Op :+: Value+> type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos+>+> -- Derive boilerplate code using Template Haskell+> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,+>           instanceEqF, instanceShowF, smartConstructors]+>          [''Value, ''Op, ''Sugar])+> +> -- Term homomorphism for desugaring of terms+> class (Functor f, Functor g) => Desugar f g where+>   desugHom :: TermHom f g+>   desugHom = desugHom' . fmap Hole+>   desugHom' :: Alg f (Context g a)+>   desugHom' x = appCxt (desugHom x)+> +> instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where+>   desugHom (Inl x) = desugHom x+>   desugHom (Inr x) = desugHom x+>   desugHom' (Inl x) = desugHom' x+>   desugHom' (Inr x) = desugHom' x+> +> instance (Value :<: v, Functor v) => Desugar Value v where+>   desugHom = simpCxt . inj+> +> instance (Op :<: v, Functor v) => Desugar Op v where+>   desugHom = simpCxt . inj+> +> instance (Op :<: v, Value :<: v, Functor v) => Desugar Sugar v where+>   desugHom' (Neg x)  = iConst (-1) `iMult` x+>   desugHom' (Swap x) = iSnd x `iPair` iFst x+> +> -- Lift the desugaring term homomorphism to a catamorphism+> desug :: Term Sig' -> Term Sig+> desug = appTermHom desugHom+>+> -- Example: desugEx = iPair (iConst 2) (iConst 1)+> desugEx :: Term Sig+> desugEx = desug $ iSwap $ iPair (iConst 1) (iConst 2)+>+> -- Lift desugaring to terms annotated with source positions+> desugP :: Term SigP' -> Term SigP+> desugP = appTermHom (productTermHom desugHom)+>+> iSwapP :: (DistProd f p f', Sugar :<: f) => p -> Term f' -> Term f'+> iSwapP p x = Term (injectP p $ inj $ Swap x)+>+> iConstP :: (DistProd f p f', Value :<: f) => p -> Int -> Term f'+> iConstP p x = Term (injectP p $ inj $ Const x)+>+> iPairP :: (DistProd f p f', Value :<: f) => p -> Term f' -> Term f' -> Term f'+> iPairP p x y = Term (injectP p $ inj $ Pair x y)+>+> iFstP :: (DistProd f p f', Op :<: f) => p -> Term f' -> Term f'+> iFstP p x = Term (injectP p $ inj $ Fst x)+>+> iSndP :: (DistProd f p f', Op :<: f) => p -> Term f' -> Term f'+> iSndP p x = Term (injectP p $ inj $ Snd x)+>+> -- Example: desugPEx = iPairP (Pos 1 0)+> --                            (iSndP (Pos 1 0) (iPairP (Pos 1 1)+> --                                                     (iConstP (Pos 1 2) 1)+> --                                                     (iConstP (Pos 1 3) 2)))+> --                            (iFstP (Pos 1 0) (iPairP (Pos 1 1)+> --                                                     (iConstP (Pos 1 2) 1)+> --                                                     (iConstP (Pos 1 3) 2)))+> desugPEx :: Term SigP+> desugPEx = desugP $ iSwapP (Pos 1 0) (iPairP (Pos 1 1) (iConstP (Pos 1 2) 1)+>                                                        (iConstP (Pos 1 3) 2))+-}++{- $ex5+The example below illustrates how to use Higher-Order Abstract Syntax (HOAS)+with compositional data types.++The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.++> import Data.Comp+> import Data.Comp.Show ()+> import Data.Comp.Derive+> +> -- Signature for values, operators, lambda functions, and applications+> data Value e = Const Int | Pair e e+> data Op e = Add e e | Mult e e | Fst e | Snd e+> data Lam e = Lam (e -> e)+> data App e = App e e+> +> -- Signature for the extended expression language+> type Val = Lam :+: Value+> type Sig = App :+: Op :+: Val+>+> -- Derive boilerplate code using Template Haskell+> $(derive [instanceExpFunctor, smartConstructors]+>          [''Value, ''Op, ''Lam, ''App])+> $(derive [instanceFunctor, instanceFoldable,+>           instanceTraversable, instanceShowF] [''Value])+> +> -- Term evaluation algebra+> class Eval f v where+>   evalAlg :: Alg f (Term v)+> +> instance (Eval f v, Eval g v) => Eval (f :+: g) v where+>   evalAlg (Inl x) = evalAlg x+>   evalAlg (Inr x) = evalAlg x+> +> instance (Value :<: v) => Eval Value v where+>   evalAlg = inject+> +> instance (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+>   evalAlg (Snd x)    = snd $ projP x+>+> instance (Lam :<: v) => Eval Lam v where+>   evalAlg = inject+> +> instance (Lam :<: v) => Eval App v where+>   evalAlg (App x y) = (projL x) y+> +> projC :: (Value :<: v) => Term v -> Int+> projC v = let Just (Const n) = project v in n+> +> projP :: (Value :<: v) => Term v -> (Term v, Term v)+> projP v = let Just (Pair x y) = project v in (x,y)+>+> projL :: (Lam :<: v) => Term v -> Term v -> Term v+> projL v = let Just (Lam f) = project v in f+>+> -- Lift the evaluation algebra to a catamorphism. Note the use of 'cataE'+> -- instead of 'cata'.+> eval :: (ExpFunctor f, Eval f v) => Term f -> Term v+> eval = cataE evalAlg+>+> -- Example: evalEx = Just (iConst 3). Note that we need to project the value+> -- to a value without HOAS in order to print it with 'showF'.+> evalEx :: Maybe (Term Value)+> evalEx = deepProject' $ (eval e :: Term Val)+>     where e :: Term Sig+>           e = (iLam $ \x -> x) `iApp` (iConst 1 `iAdd` iConst 2)+-}
+ src/Data/Comp/Algebra.hs view
@@ -0,0 +1,581 @@+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators,+  FlexibleContexts, CPP #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Algebra+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines the notion of algebras and catamorphisms, and their+-- generalizations to e.g. monadic versions and other (co)recursion schemes.+--+--------------------------------------------------------------------------------++module Data.Comp.Algebra (+      -- * Algebras & Catamorphisms+      Alg,+      free,+      cata,+      cata',+      appCxt,+      +      -- * Monadic Algebras & Catamorphisms+      AlgM,+      algM,+      freeM,+      cataM,+      cataM',++      -- * Term Homomorphisms+      CxtFun,+      SigFun,+      TermHom,+      appTermHom,+      compTermHom,+      appSigFun,+      compSigFun,+      termHom,+      compAlg,+      compCoalg,+      compCVCoalg,++      -- * Monadic Term Homomorphisms+      CxtFunM,+      SigFunM,+      TermHomM,+      SigFunM',+      TermHomM',+      sigFunM,+      termHom',+      appTermHomM,+      termHomM,+      termHomM',+      appSigFunM,+      appSigFunM',+      compTermHomM,+      compSigFunM,+      compAlgM,+      compAlgM',++      -- * Coalgebras & Anamorphisms+      Coalg,+      ana,+      ana',+      CoalgM,+      anaM,++      -- * R-Algebras & Paramorphisms+      RAlg,+      para,+      RAlgM,+      paraM,++      -- * R-Coalgebras & Apomorphisms+      RCoalg,+      apo,+      RCoalgM,+      apoM,++      -- * CV-Algebras & Histomorphisms+      CVAlg,+      histo,+      CVAlgM,+      histoM,++      -- * CV-Coalgebras & Futumorphisms+      CVCoalg,+      futu,+      CVCoalg',+      futu',+      CVCoalgM,+      futuM,++      -- * Exponential Functors+      appTermHomE,+      cataE,+      anaE,+      appCxtE+    ) where++import Data.Comp.Term+import Data.Comp.Ops+import Data.Traversable+import Control.Monad hiding (sequence, mapM)+import Data.Comp.ExpFunctor++import Prelude hiding (sequence, mapM)++++{-| This type represents an algebra over a functor @f@ and carrier+@a@. -}++type Alg f a = f a -> a++{-| Construct a catamorphism for contexts over @f@ with holes of type @a@, from+  the given algebra. -}+free :: forall f h a b . (Functor f) => Alg f b -> (a -> b) -> Cxt h f a -> b+free f g = run+    where run :: Cxt h f a -> b+          run (Hole x) = g x+          run (Term t) = f (fmap run t)++{-| Construct a catamorphism from the given algebra. -}+cata :: forall f a . (Functor f) => Alg f a -> Term f -> a +{-# NOINLINE [1] cata #-}+-- cata f = free f undefined+-- the above definition is safe since terms do not contain holes+--+-- a direct implementation:+cata f = run +    where run :: Term f -> a+          run  = f . fmap run . unTerm+++{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where+  the holes have the type of the algebra carrier. -}+cata' :: (Functor f) => Alg f a -> Cxt h f a -> a+{-# INLINE cata' #-}+cata' f = free f id+++{-| This function applies a whole context into another context. -}++appCxt :: (Functor f) => Context f (Cxt h f a) -> Cxt h f a+-- appCxt = cata' Term+appCxt (Hole x) = x+appCxt (Term t) = Term (fmap appCxt t)++++{-| This type represents a monadic algebra. It is similar to 'Alg' but+the return type is monadic.  -}++type AlgM m f a = f a -> m a ++{-| Convert a monadic algebra into an ordinary algebra with a monadic+  carrier. -}+algM :: (Traversable f, Monad m) => AlgM m f a -> Alg f (m a)+algM f x = sequence x >>= f++{-| Construct a monadic catamorphism for contexts over @f@ with holes of type+  @a@, from the given monadic algebra. -}+freeM :: forall h f a m b. (Traversable f, Monad m) =>+               AlgM m f b -> (a -> m b) -> Cxt h f a -> m b+-- freeM alg var = free (algM alg) var+freeM algm var = run+    where run :: Cxt h f a -> m b+          run (Hole x) = var x+          run (Term t) = algm =<< mapM run t++{-| Construct a monadic catamorphism from the given monadic algebra. -}+cataM :: forall f m a. (Traversable f, Monad m) => AlgM m f a -> Term f -> m a +{-# NOINLINE [1] cataM #-}+-- cataM = cata . algM+cataM algm = run+    where run :: Term f -> m a+          run = algm <=< mapM run . unTerm++{-| A generalisation of 'cataM' from terms over @f@ to contexts over @f@, where+  the holes have the type of the monadic algebra carrier. -}+cataM' :: forall h f a m . (Traversable f, Monad m)+            => AlgM m f a -> Cxt h f a -> m a+{-# NOINLINE [1] cataM' #-}+-- cataM' f = free (\x -> sequence x >>= f) return+cataM' f = run+    where run :: Cxt h f a -> m a+          run (Hole x) = return x+          run (Term t) = f =<< mapM run t+++{-| This type represents a context function. -}+type CxtFun f g = forall a h. Cxt h f a -> Cxt h g a++{-| This type represents a signature function.-}+type SigFun f g = forall a. f a -> g a++{-| This type represents a term homomorphism. -}+type TermHom f g = SigFun f (Context g)++{-| Apply a term homomorphism recursively to a term/context. -}+appTermHom :: (Traversable f, Functor g) => TermHom f g -> CxtFun f g+{-# INLINE [1] appTermHom #-}+-- Constraint Traversable f is not essential and can be replaced by+-- Functor f. It is, however, needed for the shortcut-fusion rules to+-- work.+appTermHom = appTermHom'++{-| This function applies the given term homomorphism to a+term/context. -}+appTermHom' :: forall f g . (Functor f, Functor g) => TermHom f g -> CxtFun f g+{-# NOINLINE [1] appTermHom' #-}+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type+-- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -> Cxt h f b -> Cxt h g b+-- would achieve the same. The given type is chosen for clarity.+appTermHom' f = run where+    run :: CxtFun f g+    run (Hole x) = Hole x+    run (Term t) = appCxt (f (fmap run t))++{-| Compose two term homomorphisms. -}+compTermHom :: (Functor g, Functor h) => TermHom g h -> TermHom f g -> TermHom f h+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type+-- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b))+-- -> (a -> Cxt h f b) -> a -> Cxt h g b+-- would achieve the same. The given type is chosen for clarity.+compTermHom f g = appTermHom' f . g++{-| Compose an algebra with a term homomorphism to get a new algebra. -}+compAlg :: (Functor g) => Alg g a -> TermHom f g -> Alg f a+compAlg alg talg = cata' alg . talg++{-| Compose a term homomorphism with a coalgebra to get a cv-coalgebra. -}+compCoalg :: TermHom f g -> Coalg f a -> CVCoalg' g a+compCoalg hom coa = hom . coa++{-| Compose a term homomorphism with a cv-coalgebra to get a new cv-coalgebra.+ -}+compCVCoalg :: (Functor f, Functor g)+  => TermHom f g -> CVCoalg' f a -> CVCoalg' g a+compCVCoalg hom coa = appTermHom' hom . coa+++{-| This function applies a signature function to the given context. -}+appSigFun :: (Functor f, Functor g) => SigFun f g -> CxtFun f g+appSigFun f = appTermHom' $ termHom f+++{-| This function composes two signature functions. -}+compSigFun :: SigFun g h -> SigFun f g -> SigFun f h+compSigFun f g = f . g+++{-| Lifts the given signature function to the canonical term homomorphism.+-}++termHom :: (Functor g) => SigFun f g -> TermHom f g+termHom f = simpCxt . f++{-|+  This type represents a monadic context function.+-}+type CxtFunM m f g = forall a h. Cxt h f a -> m (Cxt h g a)++{-| This type represents a monadic signature function. -}++type SigFunM m f g = forall a. f a -> m (g a)++{-| This type represents a monadic signature function.  It is similar+to 'SigFunM' but has monadic values also in the domain. -}+type SigFunM' m f g = forall a. f (m a) -> m (g a)++{-| This type represents a monadic term homomorphism.  -}+type TermHomM m f g = SigFunM m f (Context g)++{-| This type represents a monadic term homomorphism. It is similar to+'TermHomM' but has monadic values also in the domain. -}+type TermHomM' m f g = SigFunM' m f (Context g)+++{-| Lift the given signature function to a monadic signature function. Note that+  term homomorphisms are instances of signature functions. Hence this function+  also applies to term homomorphisms. -}+sigFunM :: (Monad m) => SigFun f g -> SigFunM m f g+sigFunM f = return . f++{-| Lift the give monadic signature function to a monadic term homomorphism. -}+termHom' :: (Functor f, Functor g, Monad m) => SigFunM m f g -> TermHomM m f g+termHom' f = liftM  (Term . fmap Hole) . f++{-| Lift the given signature function to a monadic term homomorphism. -}+termHomM :: (Functor g, Monad m) => SigFun f g -> TermHomM m f g+termHomM f = sigFunM $ termHom f+++{-| Apply a monadic term homomorphism recursively to a term/context. -}+appTermHomM :: forall f g m . (Traversable f, Functor g, Monad m)+         => TermHomM m f g -> CxtFunM m f g+{-# NOINLINE [1] appTermHomM #-}+appTermHomM f = run+    where run :: Cxt h f a -> m (Cxt h g a)+          run (Hole x) = return (Hole x)+          run (Term t) = liftM appCxt (f =<< mapM run t)++{-| This function constructs the unique monadic homomorphism from the+initial term algebra to the given term algebra. -}+termHomM' :: forall f g m . (Traversable f, Functor g, Monad m)+          => TermHomM' m f g -> CxtFunM m f g+termHomM' f = run +    where run :: Cxt h f a -> m (Cxt h g a)+          run (Hole x) = return (Hole x)+          run (Term t) = liftM appCxt (f (fmap run t))+++{-| This function applies a monadic signature function to the given context. -}+appSigFunM :: (Traversable f, Functor g, Monad m) => SigFunM m f g -> CxtFunM m f g+appSigFunM f = appTermHomM $ termHom' f++{-| This function applies a signature function to the given context. -}+appSigFunM' :: forall f g m . (Traversable f, Functor g, Monad m)+              => SigFunM' m f g -> CxtFunM m f g+appSigFunM' f = run +    where run :: Cxt h f a -> m (Cxt h g a)+          run (Hole x) = return (Hole x)+          run (Term t) = liftM Term (f (fmap run t))++{-| Compose two monadic term homomorphisms. -}+compTermHomM :: (Traversable g, Functor h, Monad m)+            => TermHomM m g h -> TermHomM m f g -> TermHomM m f h+compTermHomM f g =  appTermHomM 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 -> TermHomM m f g -> AlgM m f a+compAlgM alg talg = cataM' alg <=< talg++{-| Compose a monadic algebra with a term homomorphism to get a new monadic+  algebra. -}+compAlgM' :: (Traversable g, Monad m) => AlgM m g a -> TermHom f g -> AlgM m f a+compAlgM' alg talg = cataM' alg . talg+++{-| This function composes two monadic signature functions.  -}+compSigFunM :: (Monad m) => SigFunM m g h -> SigFunM m f g -> SigFunM m f h+compSigFunM f g a = g a >>= f++----------------+-- Coalgebras --+----------------++{-| This type represents a coalgebra over a functor @f@ and carrier @a@. -}+type Coalg f a = a -> f a++{-| Construct an anamorphism from the given coalgebra. -}+ana :: forall a f . Functor f => Coalg f a -> a -> Term f+ana f = run+    where run :: a -> Term f+          run t = Term $ fmap run (f t)++-- | Shortcut fusion variant of 'ana'.+ana' :: forall a f . Functor f => Coalg f a -> a -> Term f+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)++build :: (forall a. Alg f a -> a) -> Term f+{-# INLINE [1] build #-}+build g = g Term++{-| This type represents a monadic coalgebra over a functor @f@ and carrier+  @a@. -}+type CoalgM m f a = a -> m (f a)++{-| Construct a monadic anamorphism from the given monadic coalgebra. -}+anaM :: forall a m f. (Traversable f, Monad m)+          => CoalgM m f a -> a -> m (Term f)+anaM f = run +    where run :: a -> m (Term f)+          run t = liftM Term $ f t >>= mapM run+++--------------------------------+-- R-Algebras & Paramorphisms --+--------------------------------++{-| This type represents an r-algebra over a functor @f@ and carrier @a@. -}+type RAlg f a = f (Term f, a) -> a++{-| Construct a paramorphism from the given r-algebra. -}+para :: (Functor f) => RAlg f a -> Term f -> a+para f = snd . cata run+    where run t = (Term $ fmap fst t, f t)++{-| This type represents a monadic r-algebra over a functor @f@ and carrier+  @a@. -}+type RAlgM m f a = f (Term f, a) -> m a++{-| Construct a monadic paramorphism from the given monadic r-algebra. -}+paraM :: (Traversable f, Monad m) => +         RAlgM m f a -> Term f -> m a+paraM f = liftM snd . cataM run+    where run t = do+            a <- f t+            return (Term $ fmap fst t, a)++--------------------------------+-- R-Coalgebras & Apomorphisms --+--------------------------------++{-| This type represents an r-coalgebra over a functor @f@ and carrier @a@. -}+type RCoalg f a = a -> f (Either (Term f) a)++{-| Construct an apomorphism from the given r-coalgebra. -}+apo :: (Functor f) => RCoalg f a -> a -> Term f+apo f = run +    where run = Term . fmap run' . f+          run' (Left t) = t+          run' (Right a) = run a+-- can also be defined in terms of anamorphisms (but less+-- efficiently):+-- apo f = ana run . Right+--     where run (Left (Term t)) = fmap Left t+--           run (Right a) = f a++{-| This type represents a monadic r-coalgebra over a functor @f@ and carrier+  @a@. -}+type RCoalgM m f a = a -> m (f (Either (Term f) a))++{-| Construct a monadic apomorphism from the given monadic r-coalgebra. -}+apoM :: (Traversable f, Monad m) =>+        RCoalgM m f a -> a -> m (Term f)+apoM f = run +    where run a = do+            t <- f a+            t' <- mapM run' t+            return $ Term t'+          run' (Left t) = return t+          run' (Right a) = run a++-- can also be defined in terms of anamorphisms (but less+-- efficiently):+-- apoM f = anaM run . Right+--     where run (Left (Term t)) = return $ fmap Left t+--           run (Right a) = f a+++----------------------------------+-- CV-Algebras & Histomorphisms --+----------------------------------++{-| This type represents a cv-algebra over a functor @f@ and carrier @a@. -}+type CVAlg f a f' = f (Term f') -> a+++-- | This function applies 'projectP' at the tip of the term.++projectTip  :: (DistProd f a f') => Term f' -> (f (Term f'), a)+projectTip (Term v) = projectP v++{-| Construct a histomorphism from the given cv-algebra. -}+histo :: (Functor f,DistProd f a f') => CVAlg f a f' -> Term f -> a+histo alg  = snd . projectTip . cata run+    where run v = Term $ injectP (alg v) v++{-| This type represents a monadic cv-algebra over a functor @f@ and carrier+  @a@. -}+type CVAlgM m f a f' = f (Term f') -> m a++{-| Construct a monadic histomorphism from the given monadic cv-algebra. -}+histoM :: (Traversable f, Monad m, DistProd f a f') =>+          CVAlgM m f a f' -> Term f -> m a+histoM alg  = liftM (snd . projectTip) . cataM run+    where run v = do r <- alg v+                     return $ Term $ injectP r v++-----------------------------------+-- CV-Coalgebras & Futumorphisms --+-----------------------------------++{-| This type represents a cv-coalgebra over a functor @f@ and carrier @a@. -}+type CVCoalg f a = a -> f (Context f a)++{-| Construct a futumorphism from the given cv-coalgebra. -}+futu :: forall f a . Functor f => CVCoalg f a -> a -> Term f+futu coa = ana run . Hole+    where run :: Coalg f (Context f a)+          run (Hole x) = coa x+          run (Term t) = t++{-| This type represents a monadic cv-coalgebra over a functor @f@ and carrier+  @a@. -}+type CVCoalgM m f a = a -> m (f (Context f a))++{-| Construct a monadic futumorphism from the given monadic cv-coalgebra. -}+futuM :: forall f a m . (Traversable f, Monad m) =>+         CVCoalgM m f a -> a -> m (Term f)+futuM coa = anaM run . Hole+    where run :: CoalgM m f (Context f a)+          run (Hole x) = coa x+          run (Term t) = return t++{-| This type represents a generalised cv-coalgebra over a functor @f@ and+  carrier @a@. -}+type CVCoalg' f a = a -> Context f a++{-| Construct a futumorphism from the given generalised cv-coalgebra. -}+futu' :: forall f a . Functor f => CVCoalg' f a -> a -> Term f+futu' coa = run+    where run :: a -> Term f+          run x = appCxt $ fmap run (coa x)++--------------------------+-- Exponential Functors --+--------------------------++{-| Catamorphism for exponential functors. The intermediate 'cataFS' originates+ from <http://comonad.com/reader/2008/rotten-bananas/>. -}+cataE :: forall f a . ExpFunctor f => Alg f a -> Term f -> a+{-# NOINLINE [1] cataE #-}+cataE f = cataFS . toCxt+    where cataFS :: ExpFunctor f => Context f a -> a+          cataFS (Hole x) = x+          cataFS (Term t) = f (xmap cataFS Hole t)++{-| Anamorphism for exponential functors. -}+anaE :: forall a f . ExpFunctor f => Coalg f a -> a -> Term f+anaE f = cataE (Term . removeP) . anaFS+    where anaFS :: a -> Term (f :&: a)+          anaFS t = Term $ xmap anaFS (snd . projectP . unTerm) (f t) :&: t++-- | Variant of 'appCxt' for contexts over 'ExpFunctor' signatures.+appCxtE :: (ExpFunctor f) => Context f (Cxt h f a) -> Cxt h f a+appCxtE (Hole x) = x+appCxtE (Term t) = Term (xmap appCxtE Hole t)++-- | Variant of 'appTermHom' for term homomorphisms from and to+-- 'ExpFunctor' signatures.+appTermHomE :: forall f g . (ExpFunctor f, ExpFunctor g) => TermHom f g+            -> Term f -> Term g+appTermHomE f = cataFS . toCxt+    where cataFS :: Context f (Term g) -> Term g+          cataFS (Hole x) = x+          cataFS (Term t) = appCxtE (f (xmap cataFS Hole t))+++-------------------+-- rewrite rules --+-------------------++#ifndef NO_RULES+{-# RULES+  "cata/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) x.+    cata a (appTermHom h x) = cata (compAlg a h) x;++  "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.+    appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;++  "cataE/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) (x :: ExpFunctor f => Term f) .+    cataE a (appTermHom h x) = cataE (compAlg a h) x+ #-}++{-# RULES +  "cataM/appTermHomM" forall (a :: AlgM m g d) (h :: TermHomM m f g) x.+     appTermHomM h x >>= cataM a = cataM (compAlgM a h) x;++  "cataM/appTermHom" forall (a :: AlgM m g d) (h :: TermHom f g) x.+     cataM a (appTermHom h x) = cataM (compAlgM' a h) x;++  "appTermHomM/appTermHomM" forall (a :: TermHomM m g h) (h :: TermHomM m f g) x.+    appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;+ #-}++{-# RULES+  "cata/build"  forall alg (g :: forall a . Alg f a -> a) .+                cata alg (build g) = g alg+ #-}+#endif
+ src/Data/Comp/Arbitrary.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TypeOperators, TypeSynonymInstances, GADTs, TemplateHaskell, FlexibleInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Arbitrary+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines generation of arbitrary values for signatures, which+-- lifts to generating arbitrary terms.+--+--------------------------------------------------------------------------------++module Data.Comp.Arbitrary+    ( ArbitraryF(..)+    )where++import Test.QuickCheck+import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Product+import Data.Comp.Derive.Utils+import Data.Comp.Derive+import Control.Applicative++{-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary'+for the corresponding term type. -}++instance (ArbitraryF f) => Arbitrary (Term f) where+    arbitrary = Term <$> arbitraryF+    shrink (Term expr) = map Term $ shrinkF expr+    +    ++instance (ArbitraryF f, Arbitrary p) => ArbitraryF (f :&: p) where+    arbitraryF' = map addP arbitraryF'+        where addP (i,gen) =  (i,(:&:) <$> gen <*> arbitrary)+    arbitraryF = (:&:) <$> arbitraryF <*> arbitrary+    shrinkF (v :&: p) = tail [v' :&: p'| v' <- v: shrinkF v, p' <- p : shrink p ]++{-|+  This lifts instances of 'ArbitraryF' to instances of 'ArbitraryF' for +  the corresponding context functor.+-}+instance (ArbitraryF f) => ArbitraryF (Context f) where+    arbitraryF = oneof [Term <$> arbitraryF , Hole <$> arbitrary]+    shrinkF (Term expr) = map Term $ shrinkF expr+    shrinkF (Hole a) = map Hole $ shrink a+++{-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary'+for the corresponding context type.  -}++instance (ArbitraryF f, Arbitrary a) => Arbitrary (Context f a) where+    arbitrary = arbitraryF+    shrink = shrinkF+++{-| Instances of 'ArbitraryF' are closed under forming sums.  -}++instance (ArbitraryF f , ArbitraryF g) => ArbitraryF (f :+: g) where+    arbitraryF' = map inl arbitraryF' ++ map inr arbitraryF'+        where inl (i,gen) = (i,Inl <$> gen)+              inr (i,gen) = (i,Inr <$> gen)+    shrinkF (Inl val) = map Inl (shrinkF val)+    shrinkF (Inr val) = map Inr (shrinkF val)+++$(derive [instanceArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10)
+ src/Data/Comp/Automata.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Automata+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines tree automata based on compositional data types.+--+--------------------------------------------------------------------------------++module Data.Comp.Automata where++import Data.Comp+import Data.Maybe+import Data.Traversable+import Control.Monad+++{-| This type represents transition functions of deterministic+bottom-up tree acceptors (DUTAs).  -}++type DUTATrans f q = Alg f q++{-| This data type represents deterministic bottom-up tree acceptors (DUTAs).+-}+data DUTA f q = DUTA {+      dutaTrans :: DUTATrans f q,+      dutaAccept :: q -> Bool+    }++{-| This function runs the transition function of a DUTA on the given+term. -}++runDUTATrans :: Functor f => DUTATrans f q -> Term f -> q+runDUTATrans = cata++{-| This function checks whether a given DUTA accepts a term.  -}++duta :: Functor f => DUTA f q -> Term f -> Bool+duta DUTA{dutaTrans = trans, dutaAccept = accept} = accept . runDUTATrans trans++++{-| This type represents transition functions of non-deterministic+bottom-up tree acceptors (NUTAs).  -}++type NUTATrans f q = AlgM [] f q+++{-| This type represents non-deterministic bottom-up tree acceptors.+-}+data NUTA f q = NUTA {+      nutaTrans :: AlgM [] f q,+      nutaAccept :: q -> Bool+    }++{-| This function runs the given transition function of a NUTA on the+given term -}++runNUTATrans :: Traversable f => NUTATrans f q -> Term f -> [q]+runNUTATrans = cataM++{-| This function checks whether a given NUTA accepts a term. -}++nuta :: Traversable f => NUTA f q -> Term f -> Bool+nuta NUTA{nutaTrans = trans, nutaAccept = accept} = any accept . runNUTATrans trans+++{-| This function determinises the given NUTA.  -}++determNUTA :: (Traversable f) => NUTA f q -> DUTA f [q]+determNUTA n = DUTA{+               dutaTrans = algM $ nutaTrans n,+               dutaAccept = any $ nutaAccept n}++{-| This function represents transition functions of+deterministic bottom-up tree transducers (DUTTs).  -}++type DUTTTrans f g q = forall a. f (q,a) -> (q, Cxt Hole g a)++{-| This function transforms a DUTT transition function into an+algebra.  -}++duttTransAlg :: (Functor f, Functor g)  => DUTTTrans f g q -> Alg f (q, Term g)+duttTransAlg trans = fmap injectCxt . trans ++{-| This function runs the given DUTT transition function on the given+term.  -}++runDUTTTrans :: (Functor f, Functor g)  => DUTTTrans f g q -> Term f -> (q, Term g)+runDUTTTrans = cata . duttTransAlg++{-| This data type represents deterministic bottom-up tree+transducers. -}++data DUTT f g q = DUTT {+      duttTrans :: DUTTTrans f g q,+      duttAccept :: q -> Bool+    }++{-| This function transforms the given term according to the given+DUTT and returns the resulting term provided it is accepted by the+DUTT. -}++dutt :: (Functor f, Functor g) => DUTT f g q -> Term f -> Maybe (Term g)+dutt DUTT{duttTrans = trans, duttAccept = accept} = accept' . runDUTTTrans trans+    where accept' (q,res)+              | accept q = Just res+              | otherwise = Nothing++{-| This type represents transition functions of non-deterministic+bottom-up tree transducers (NUTTs).  -}++type NUTTTrans f g q = forall a. f (q,a) -> [(q, Cxt Hole g a)]++{-| This function transforms a NUTT transition function into a monadic+algebra.  -}++nuttTransAlg :: (Functor f, Functor g)  => NUTTTrans f g q -> AlgM [] f (q, Term g)+nuttTransAlg trans = liftM (fmap injectCxt) . trans ++{-| This function runs the given NUTT transition function on the given+term.  -}++runNUTTTrans :: (Traversable f, Functor g)  => NUTTTrans f g q -> Term f -> [(q, Term g)]+runNUTTTrans = cataM . nuttTransAlg++{-| This data type represents non-deterministic bottom-up tree+transducers (NUTTs). -}++data NUTT f g q = NUTT {+      nuttTrans :: NUTTTrans f g q,+      nuttAccept :: q -> Bool+    }++{-| This function transforms the given term according to the given+NUTT and returns a list containing all accepted results. -}++nutt :: (Traversable f, Functor g) => NUTT f g q -> Term f -> [Term g]+nutt NUTT{nuttTrans = trans, nuttAccept = accept} = mapMaybe accept' . runNUTTTrans trans+    where accept' (q,res)+              | accept q = Just res+              | otherwise = Nothing
+ src/Data/Comp/Decompose.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Decompose+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module implements the decomposition of terms into function+-- symbols and arguments resp. variables.+--+--------------------------------------------------------------------------------+module Data.Comp.Decompose (+  Decomp (..),+  DecompTerm,+  Decompose (..),+  structure,+  arguments,+  decompose+  ) where++import Data.Comp.Term+import Data.Comp.Variables+import Data.Foldable++{-| This function computes the structure of a functorial value. -}++structure :: (Functor f) => f a -> Const f+structure = fmap (const ())++{-| This function computes the arguments of a functorial value.  -}++arguments :: (Foldable f) => f a -> [a]+arguments = toList++{-| This type represents decompositions of functorial values. -}++data Decomp f v a = Var v+                  | Fun (Const f) [a]++{-| This type represents decompositions of terms.  -}++type DecompTerm f v = Decomp f v (Term f)++{-| 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++instance (HasVars f v, Functor f, Foldable f) => Decompose f v where+++{-| This function decomposes a term. -}++decompose :: (Decompose f v) => Term f -> DecompTerm f v+decompose (Term t) = decomp t
+ src/Data/Comp/DeepSeq.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances, TypeOperators,+  TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.DeepSeq+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines full evaluation of signatures, which lifts to full+-- evaluation of terms and contexts.+--+--------------------------------------------------------------------------------++module Data.Comp.DeepSeq+    (+     NFDataF(..),+     rnfF'+    )+    where++import Data.Comp.Term+import Data.Comp.Sum+import Control.DeepSeq+import Data.Comp.Derive+import Data.Foldable+import Prelude hiding (foldr)++{-| Fully evaluate a value over a foldable signature. -}+rnfF' :: (Foldable f, NFDataF f, NFData a) => f a -> ()+rnfF' x = foldr seq (rnfF x) x++instance (NFDataF f, NFData a) => NFData (Cxt h f a) where+    rnf (Hole x) = rnf x+    rnf (Term x) = rnfF x++instance (NFDataF f, NFDataF g) => NFDataF (f:+:g) where+    rnfF (Inl v) = rnfF v+    rnfF (Inr v) = rnfF v++instance NFData Nothing where+++$(derive [instanceNFDataF] [''Maybe, ''[], ''(,)])
+ src/Data/Comp/Derive.hs view
@@ -0,0 +1,108 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module contains functionality for automatically deriving boilerplate+-- code using Template Haskell. Examples include instances of 'Functor',+-- 'Foldable', and 'Traversable'.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive+    (+     derive,+     -- * First-order Signatures+     -- |Derive boilerplate instances for first-order signatures, i.e.+     -- signatures for ordinary compositional data types.++     -- ** ShowF+     module Data.Comp.Derive.Show,+     -- ** EqF+     module Data.Comp.Derive.Equality,+     -- ** OrdF+     module Data.Comp.Derive.Ordering,+     -- ** Functor+     Functor,+     instanceFunctor,+     -- ** Foldable+     module Data.Comp.Derive.Foldable,+     -- ** Traversable+     module Data.Comp.Derive.Traversable,+     -- ** ExpFunctor+     module Data.Comp.Derive.ExpFunctor,+     -- ** Arbitrary+     module Data.Comp.Derive.Arbitrary,+     NFData(..),+     instanceNFData,+     -- ** DeepSeq+     module Data.Comp.Derive.DeepSeq,+     -- ** Smart Constructors+     module Data.Comp.Derive.SmartConstructors,++     -- * Higher-order Signatures+     -- |Derive boilerplate instances for higher-order signatures, i.e.+     -- signatures for generalised compositional data types.++     -- ** HShowF+     module Data.Comp.Derive.Multi.Show,+     -- ** HEqF+     module Data.Comp.Derive.Multi.Equality,+     -- ** HFunctor+     module Data.Comp.Derive.Multi.Functor,+     -- ** HFoldable+     module Data.Comp.Derive.Multi.Foldable,+     -- ** HTraversable+     module Data.Comp.Derive.Multi.Traversable,+     -- ** HExpFunctor+     module Data.Comp.Derive.Multi.ExpFunctor,+     -- ** Smart Constructors+     module Data.Comp.Derive.Multi.SmartConstructors+    ) where++import Control.DeepSeq (NFData(..))+import Data.Comp.Derive.Foldable+import Data.Comp.Derive.Traversable+import Data.Comp.Derive.ExpFunctor+import Data.Comp.Derive.DeepSeq+import Data.Comp.Derive.Show+import Data.Comp.Derive.Ordering+import Data.Comp.Derive.Equality+import Data.Comp.Derive.Arbitrary+import Data.Comp.Derive.SmartConstructors+import Data.Comp.Derive.Multi.Equality+import Data.Comp.Derive.Multi.Show+import Data.Comp.Derive.Multi.Functor+import Data.Comp.Derive.Multi.Foldable+import Data.Comp.Derive.Multi.Traversable+import Data.Comp.Derive.Multi.ExpFunctor+import Data.Comp.Derive.Multi.SmartConstructors++import Language.Haskell.TH+import Control.Monad++import qualified Data.DeriveTH as D+import Data.Derive.All++{-| Helper function for generating a list of instances for a list of named+ signatures. For example, in order to derive instances 'Functor' and+ 'ShowF' for a signature @Exp@, use derive as follows (requires Template+ Haskell):++ > $(derive [instanceFunctor, instanceShowF] [''Exp])+ -}+derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]+derive ders names = liftM concat $ sequence [der name | der <- ders, name <- names]++{-| Derive an instance of 'Functor' for a type constructor of any first-order+  kind taking at least one argument. -}+instanceFunctor :: Name -> Q [Dec]+instanceFunctor = D.derive makeFunctor++{-| Derive an instance of 'NFData' for a type constructor. -}+instanceNFData :: Name -> Q [Dec]+instanceNFData = D.derive makeNFData
+ src/Data/Comp/Derive/Arbitrary.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE GADTs, TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Arbitrary+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @ArbitraryF@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Arbitrary+    (+     ArbitraryF(..),+     instanceArbitraryF,+     Arbitrary(..),+     instanceArbitrary+    )where++import Test.QuickCheck+import Data.Comp.Derive.Utils+import Language.Haskell.TH+import Data.DeriveTH++{-| Derive an instance of 'Arbitrary' for a type constructor. -}+instanceArbitrary :: Name -> Q [Dec]+instanceArbitrary = derive makeArbitrary++{-| Signature arbitration. An instance @ArbitraryF f@ gives rise to an instance+  @Arbitrary (Term f)@. -}+class ArbitraryF f where+    arbitraryF' :: Arbitrary v => [(Int,Gen (f v))]+    arbitraryF' = [(1,arbitraryF)]+    arbitraryF :: Arbitrary v => Gen (f v)+    arbitraryF = frequency arbitraryF'+    shrinkF :: Arbitrary v => f v -> [f v]+    shrinkF _ = []++{-| Derive an instance of 'ArbitraryF' for a type constructor of any+  first-order kind taking at least one argument. It is necessary that+  all types that are used by the data type definition are themselves+  instances of 'Arbitrary'. -}+instanceArbitraryF :: Name -> Q [Dec]+instanceArbitraryF dt = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt+  let argNames = (map (VarT . tyVarBndrName) (tail args))+      complType = foldl AppT (ConT name) argNames+      preCond = map (ClassP ''Arbitrary . (: [])) argNames+      classType = AppT (ConT ''ArbitraryF) complType+  arbitraryDecl <- generateArbitraryFDecl constrs+  shrinkDecl <- generateShrinkFDecl constrs+  return [InstanceD preCond classType [arbitraryDecl, shrinkDecl]]++{-|+  This function generates a declaration of the method 'arbitrary' for the given+  list of constructors using 'generateGenDecl'.+-}+generateArbitraryFDecl :: [Con] -> Q Dec+generateArbitraryFDecl = generateGenDecl 'arbitraryF'++{-|+  This function generates a declaration of a generator having the given name using+  the given constructors, i.e., something like this:+  +  @+  \<name\> :: Gen \<type\>+  \<name\> = ...+  @++  where @\<type\>@ is the type of the given constructors. If the constructors do not belong+  to the same type this function fails. The generated function will generate only elements of+  this type using the given constructors. All argument types of these constructors are supposed+  to be instances of 'Arbitrary'.+-}++generateGenDecl :: Name -> [Con] -> Q Dec+generateGenDecl genName constrs+    = do genBody <- listE $ map (addNum . constrGen . abstractConType) constrs+         let genClause = Clause [] (NormalB genBody) []+         return $ FunD genName [genClause]+    where addNum e = [| (1,$e) |]+          constrGen :: (Name,Int) -> ExpQ+          constrGen (constr, n)+              = do varNs <- newNames n "x"+                   newSizeN <- newName "newSize"+                   let newSizeE = varE newSizeN+                   let newSizeP = varP newSizeN+                   let constrsE = litE . IntegerL . toInteger $ n+                   let binds = (`map` varNs) (\var -> bindS+                                                     (varP var)+                                                     [| resize $newSizeE arbitrary |] )+                   let apps =  appsE (conE constr: map varE varNs)+                   let build = doE $+                               binds +++                               [noBindS [|return $apps|]]+                   if n == 0 +                      then [|return $apps|]+                      else  [| sized $ \ size ->+                                 $(letE [valD +                                         newSizeP+                                         (normalB [|((size - 1) `div` $constrsE ) `max` 0|])+                                         [] ]+                                   build) |]++{-|+  This function generates a declaration for the method 'shrink' using the given constructors.+  The constructors are supposed to belong to the same type.+-}+generateShrinkFDecl :: [Con] -> Q Dec+generateShrinkFDecl constrs+    = let clauses = map (generateClause.abstractConType) constrs+      in funD 'shrink clauses+  where generateClause (constr, n)+            = do varNs <- newNames n "x"+                 resVarNs <- newNames n "x'"+                 binds <- mapM (\(var,resVar) -> bindS (varP resVar) [| $(varE var) : shrink $(varE var) |]) $ zip varNs resVarNs+                 let ret = NoBindS $ AppE (VarE 'return) (foldl1 AppE ( ConE constr: map VarE resVarNs ))+                     stmtSeq = binds ++ [ret]+                     pat = ConP constr $ map VarP varNs+                 return $ Clause [pat] (NormalB $ AppE (VarE 'tail) (DoE stmtSeq)) []
+ src/Data/Comp/Derive/DeepSeq.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.DeepSeq+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @DeepSeq@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.DeepSeq+    (+     NFDataF(..),+     instanceNFDataF+    ) where+++import Control.DeepSeq+import Data.Comp.Derive.Utils+import Language.Haskell.TH+import Data.Maybe++{-| Signature normal form. An instance @NFDataF f@ gives rise to an instance+  @NFData (Term f)@. -}+class NFDataF f where+    rnfF :: NFData a => f a -> ()++{-| Derive an instance of 'NFDataF' for a type constructor of any first-order+  kind taking at least one argument. -}+instanceNFDataF :: Name -> Q [Dec]+instanceNFDataF fname = do+  TyConI (DataD _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+      preCond = map (ClassP ''NFData . (: [])) argNames+      classType = AppT (ConT ''NFDataF) complType+  constrs' <- mapM normalConExp constrs+  rnfFDecl <- funD 'rnfF (rnfFClauses fArg constrs')+  return [InstanceD preCond classType [rnfFDecl]]+      where rnfFClauses fArg = map (genRnfFClause fArg)+            filterFarg excl x+                | excl = Nothing+                | otherwise = Just $ varE x+            mkPat True _ = WildP+            mkPat False x = VarP x+            genRnfFClause fArg (constr, args) = do +              let isFargs = map (==fArg) args+                  n = length args+              varNs <- newNames n "x"+              let pat = ConP constr $ zipWith mkPat isFargs varNs+                  allVars = catMaybes $ zipWith filterFarg isFargs varNs+              body <- foldr (\ x y -> [|rnf $x `seq` $y|]) [| () |] allVars+              return $ Clause [pat] (NormalB body) []
+ src/Data/Comp/Derive/Equality.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Equality+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @EqF@.+--+--------------------------------------------------------------------------------+module Data.Comp.Derive.Equality+    (+     EqF(..),+     instanceEqF+    ) where++import Data.Comp.Derive.Utils+import Language.Haskell.TH hiding (Cxt, match)+++{-| Signature equality. An instance @EqF f@ gives rise to an instance+  @Eq (Term f)@. -}+class EqF f where++    eqF :: Eq a => f a -> f a -> Bool++{-| Derive an instance of 'EqF' for a type constructor of any first-order kind+  taking at least one argument. -}+instanceEqF :: Name -> Q [Dec]+instanceEqF fname = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let argNames = (map (VarT . tyVarBndrName) (init args))+      complType = foldl AppT (ConT name) argNames+      preCond = map (ClassP ''Eq . (: [])) argNames+      classType = AppT (ConT ''EqF) complType+  eqFDecl <- funD 'eqF  (eqFClauses constrs)+  return [InstanceD preCond classType [eqFDecl]]+      where eqFClauses constrs = map (genEqClause.abstractConType) constrs+                                   ++ defEqClause constrs+            filterFarg fArg ty x = (fArg == ty, x)+            defEqClause constrs+                | length constrs  < 2 = []+                | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]+            genEqClause (constr, n) = do +              varNs <- newNames n "x"+              varNs' <- newNames n "y"+              let pat = ConP constr $ map VarP varNs+                  pat' = ConP constr $ map VarP varNs'+                  vars = map VarE varNs+                  vars' = map VarE varNs'+                  mkEq x y = let (x',y') = (return x,return y)+                             in [| $x' == $y'|]+                  eqs = listE $ zipWith mkEq vars vars'+              body <- if n == 0 +                      then [|True|]+                      else [|and $eqs|]+              return $ Clause [pat, pat'] (NormalB body) []
+ src/Data/Comp/Derive/ExpFunctor.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.ExpFunctor+-- Copyright   :  (c) 2011 Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @ExpFunctor@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.ExpFunctor+    (+     ExpFunctor,+     instanceExpFunctor+    ) where++import Data.Comp.ExpFunctor+import Data.Comp.Derive.Utils+import Language.Haskell.TH++{-| Derive an instance of 'ExpFunctor' for a type constructor of any first-order+  kind taking at least one argument. -}+instanceExpFunctor :: Name -> Q [Dec]+instanceExpFunctor fname = do+  -- Comments below apply to the example where name = T, args = [a,b], and+  -- constrs = [(X,[a]), (Y,[a,b]), (Z,[b -> b])], i.e. the data type+  -- declaration: T a b = X a | Y a b | Z (b -> b)+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  -- fArg = b+  let fArg :: Name = tyVarBndrName $ last args+  -- argNames = [a]+  let argNames = map (VarT . tyVarBndrName) (init args)+  -- compType = T a+  let complType = foldl AppT (ConT name) argNames+  -- classType = ExpFunctor (T a)+  let classType = AppT (ConT ''ExpFunctor) complType+  -- constrs' = [(X,[a]), (Y,[a,b]), (Z,[b -> b])]+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  xmapDecl <- funD 'xmap (map (xmapClause fArg) constrs')+  return [InstanceD [] classType [xmapDecl]]+      where xmapClause :: Name -> (Name,[Type]) -> ClauseQ+            xmapClause fArg (constr, args) = do+              fn <- newName "_f"+              gn <- newName "_g"+              varNs <- newNames (length args) "x"+              let f = varE fn+              let g = varE gn+              let fp = VarP fn+              let gp = VarP gn+              -- Pattern for the constructor+              let pat = ConP constr $ map VarP varNs+              body <- xmapArgs fArg f g (zip varNs args) (conE constr)+              return $ Clause [fp, gp, pat] (NormalB body) []+            xmapArgs :: Name -> ExpQ -> ExpQ -> [(Name, Type)] -> ExpQ -> ExpQ+            xmapArgs _ _ _ [] acc =+                acc+            xmapArgs fArg f g ((x,tp):tps) acc =+                xmapArgs fArg f g tps (acc `appE`+                                       (xmapArg fArg tp f g `appE` varE x))+            -- Given the name of the functor variable, a type, and the two+            -- arguments to xmap, return the expression that should be applied+            -- to the parameter of the given type.+            -- Example: xmapArg b (b -> b) f g yields the expression+            -- [|\x -> f . x . g|]+            xmapArg :: Name -> Type -> ExpQ -> ExpQ -> ExpQ+            xmapArg fArg tp f g =+                -- No need to descend into tp if it does not contain the functor+                -- type variable+                if not $ containsType tp (VarT fArg) then+                    [|id|]+                else+                    case tp of+                      ForallT vars _ tp' ->+                          -- Check if the functor variable has been rebound+                          if any ((==) fArg . tyVarBndrName) vars then+                              [|id|]+                          else+                              xmapArg fArg tp' f g+                      VarT a ->+                          -- Apply f if we have reached the functor variable+                          if a == fArg then f else [|id|]+                      ConT _ ->+                          [|id|]+                      AppT (AppT ArrowT tp1) tp2 -> do+                          -- Note that f and g are swapped in the contravariant+                          -- type tp1+                          xn <- newName "x"+                          let ftp1 = xmapArg fArg tp1 g f+                          let ftp2 = xmapArg fArg tp2 f g+                          lamE [varP xn]+                               (infixE (Just ftp2)+                                       [|(.)|]+                                       (Just $ infixE (Just $ varE xn)+                                                      [|(.)|]+                                                      (Just ftp1)))+                      AppT _ tp' ->+                          [|fmap|] `appE` xmapArg fArg tp' f g+                      SigT tp' _ ->+                          xmapArg fArg tp' f g+                      _ ->+                          error $ "unsopported type: " ++ show tp
+ src/Data/Comp/Derive/Foldable.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Foldable+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @Foldable@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Foldable+    (+     Foldable,+     instanceFoldable+    ) where++import Data.Comp.Derive.Utils+import Language.Haskell.TH+import Data.Foldable+import Control.Monad+import Data.Monoid+import Data.Maybe+import qualified Prelude as P (foldl,foldr,foldl1,foldr1)+import Prelude hiding  (foldl,foldr,foldl1,foldr1)+++iter 0 _ e = e+iter n f e = iter (n-1) f (f `appE` e)++iter' n f e = run n f e+    where run 0 _ e = e+          run m f e = let f' = iter (m-1) [|fmap|] f+                        in run (m-1) f (f' `appE` e)++{-| Derive an instance of 'Foldable' for a type constructor of any first-order+  kind taking at least one argument. -}+instanceFoldable :: Name -> Q [Dec]+instanceFoldable fname = do+  TyConI (DataD _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+      classType = AppT (ConT ''Foldable) complType+  constrs' <- mapM (mkPatAndVars  . isFarg fArg <=< normalConExp) constrs+  foldDecl <- funD 'fold (map foldClause constrs')+  foldMapDecl <- funD 'foldMap (map foldMapClause constrs')+  foldlDecl <- funD 'foldl (map foldlClause constrs')+  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)+            filterVar [] _ = Nothing+            filterVar [d] x =Just (d, varE x)+            filterVar _ _ =  error "functor variable occurring twice in argument type"+            filterVars args varNs = catMaybes $ zipWith filterVar args varNs+            mkCPat constr args varNs = ConP constr $ zipWith mkPat args varNs+            mkPat [] _ = WildP+            mkPat _ x = VarP x+            mkPatAndVars (constr, args) =+                do varNs <- newNames (length args) "x"+                   return (mkCPat constr args varNs, filterVars args varNs)+            foldClause (pat,vars) =+                do body <- if null vars+                           then [|mempty|]+                           else P.foldl1 (\ x y -> [|$x `mappend` $y|])+                                    $ map (\(d,x) -> iter' d [|fold|] x) vars+                   return $ Clause [pat] (NormalB body) []+            foldMapClause (pat,vars) =+                do fn <- newName "y"+                   let f = varE fn+                       f' 0 = f+                       f' n = iter (n-1) [|fmap|] [| foldMap $f |]+                       fp = if null vars then WildP else VarP fn+                   body <- case vars of+                             [] -> [|mempty|]+                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $ +                                      map (\ (d,z) -> iter' (max (d-1) 0) [|fold|] (f' d `appE` z)) vars+                   return $ Clause [fp, pat] (NormalB body) []+            foldlClause (pat,vars) =+                do fn <- newName "f"+                   en <- newName "e"+                   let f = varE fn+                       e = varE en+                       fp = if null vars then WildP else VarP fn+                       ep = VarP en+                       conApp x (0,y) = [|$f $x $y|]+                       conApp x (1,y) = [|foldl $f $x $y|]+                       conApp x (d,y) = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldl $f)|] `appE` y+                                            endo = iter' (d-1) [|fold|] hidEndo+                                        in [| appEndo $endo $x|]+                   body <- P.foldl conApp e vars+                   return $ Clause [fp, ep, pat] (NormalB body) []+            foldrClause (pat,vars) =+                do fn <- newName "f"+                   en <- newName "e"+                   let f = varE fn+                       e = varE en+                       fp = if null vars then WildP else VarP fn+                       ep = VarP en+                       conApp (0,x) y = [|$f $x $y|]+                       conApp (1,x) y = [|foldr $f $y $x |]+                       conApp (d,x) y = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldr $f)|] `appE` x+                                            endo = iter' (d-1) [|fold|] hidEndo+                                        in [| appEndo $endo $y|]+                   body <- P.foldr conApp e vars+                   return $ Clause [fp, ep, pat] (NormalB body) []+            foldl1Clause (pat,vars) =+                do fn <- newName "f"+                   let f = varE fn+                       fp = case vars of+                              (d,_):r+                                  | d > 0 || not (null r) -> VarP fn                              +                              _ -> WildP +                       mkComp (d,x) = iter' d [|foldl1 $f|] x+                   body <- case vars of +                             [] -> [|undefined|] +                             _ -> P.foldl1 (\ x y -> [|$f $x $y|]) $ map mkComp vars+                   return $ Clause [fp, pat] (NormalB body) []+            foldr1Clause (pat,vars) =+                do fn <- newName "f"+                   let f = varE fn+                       fp = case vars of+                              (d,_):r+                                  | d > 0 || not (null r) -> VarP fn                              +                              _ -> WildP +                       mkComp (d,x) = iter' d [|foldr1 $f|] x+                   body <- case vars of +                             [] -> [|undefined|] +                             _ -> P.foldr1 (\ x y -> [|$f $x $y|]) $ map mkComp vars+                   return $ Clause [fp, pat] (NormalB body) []
+ src/Data/Comp/Derive/Multi/Equality.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Multi.Equality+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @HEqF@.+--+--------------------------------------------------------------------------------+module Data.Comp.Derive.Multi.Equality+    (+     HEqF(..),+     KEq(..),+     instanceHEqF+    ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Language.Haskell.TH hiding (Cxt, match)+++class KEq f where+    keq :: f i -> f j -> Bool++{-| Signature equality. An instance @HEqF f@ gives rise to an instance+  @KEq (HTerm f)@. -}+class HEqF f where++    heqF :: KEq g => f g i -> f g j -> Bool+++instance KEq f => Eq (f i) where+    (==) = keq++instance Eq a => KEq (K a) where+    keq (K x) (K y) = x == y++instance KEq a => Eq (A a) where+     A x == A y = x `keq`  y++{-| Derive an instance of 'HEqF' for a type constructor of any higher-order+  kind taking at least two arguments. -}+instanceHEqF :: Name -> Q [Dec]+instanceHEqF fname = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let args' = init args+      argNames = (map (VarT . tyVarBndrName) (init args'))+      ftyp = VarT . tyVarBndrName $ last args'+      complType = foldl AppT (ConT name) argNames+      preCond = map (ClassP ''Eq . (: [])) argNames+      classType = AppT (ConT ''HEqF) complType+  constrs' <- mapM normalConExp constrs+  eqFDecl <- funD 'heqF  (eqFClauses ftyp constrs constrs')+  return [InstanceD preCond classType [eqFDecl]]+      where eqFClauses ftyp constrs constrs' = map (genEqClause ftyp) constrs'+                                   ++ defEqClause constrs+            filterFarg fArg ty x = (containsType ty fArg, varE x)+            defEqClause constrs+                | length constrs  < 2 = []+                | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]+            genEqClause ftyp (constr, argts) = do +              let n = length argts+              varNs <- newNames n "x"+              varNs' <- newNames n "y"+              let pat = ConP constr $ map VarP varNs+                  pat' = ConP constr $ map VarP varNs'+                  vars = map VarE varNs+                  vars' = map VarE varNs'+                  mkEq ty x y = let (x',y') = (return x,return y)+                                in if containsType ty ftyp+                                   then [| $x' `keq` $y'|]+                                   else [| $x' == $y'|]+                  eqs = listE $ zipWith3 mkEq argts vars vars'+              body <- if n == 0 +                      then [|True|]+                      else [|and $eqs|]+              return $ Clause [pat, pat'] (NormalB body) []
+ src/Data/Comp/Derive/Multi/ExpFunctor.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Multi.ExpFunctor+-- Copyright   :  (c) 2011 Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @HExpFunctor@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Multi.ExpFunctor+    (+     HExpFunctor,+     instanceHExpFunctor+    ) where++import Data.Comp.Multi.ExpFunctor+import Data.Comp.Derive.Utils+import Language.Haskell.TH++{-| Derive an instance of 'HExpFunctor' for a type constructor of any + higher-order kind taking at least two arguments. -}+instanceHExpFunctor :: Name -> Q [Dec]+instanceHExpFunctor fname = do+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  let args' = init args+  let fArg :: Name = tyVarBndrName $ last args'+  let argNames = map (VarT . tyVarBndrName) (init args')+  let complType = foldl AppT (ConT name) argNames+  let classType = AppT (ConT ''HExpFunctor) complType+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  hxmapDecl <- funD 'hxmap (map (hxmapClause fArg) constrs')+  return [InstanceD [] classType [hxmapDecl]]+      where hxmapClause :: Name -> (Name,[Type]) -> ClauseQ+            hxmapClause fArg (constr, args) = do+              fn <- newName "_f"+              gn <- newName "_g"+              varNs <- newNames (length args) "x"+              let f = varE fn+              let g = varE gn+              let fp = VarP fn+              let gp = VarP gn+              -- Pattern for the constructor+              let pat = ConP constr $ map VarP varNs+              body <- hxmapArgs fArg f g (zip varNs args) (conE constr)+              return $ Clause [fp, gp, pat] (NormalB body) []+            hxmapArgs :: Name -> ExpQ -> ExpQ -> [(Name, Type)] -> ExpQ -> ExpQ+            hxmapArgs _ _ _ [] acc =+                acc+            hxmapArgs fArg f g ((x,tp):tps) acc =+                hxmapArgs fArg f g tps (acc `appE`+                                       (hxmapArg fArg tp f g `appE` varE x))+            hxmapArg :: Name -> Type -> ExpQ -> ExpQ -> ExpQ+            hxmapArg fArg tp f g =+                -- No need to descend into tp if it does not contain the +                -- higher-order functor type variable+                if not $ containsType tp (VarT fArg) then+                    [|id|]+                else+                    case tp of+                      ForallT vars _ tp' ->+                          -- Check if the variable has been rebound+                          if any ((==) fArg . tyVarBndrName) vars then+                              [|id|]+                          else+                              hxmapArg fArg tp' f g+                      (AppT (VarT a) _) ->+                          -- Apply f if we have reached the higher-order functor+                          -- variable+                          if a == fArg then f else [|id|]+                      ConT _ ->+                          [|id|]+                      AppT (AppT ArrowT tp1) tp2 -> do+                          -- Note that f and g are swapped in the contravariant+                          -- type tp1+                          xn <- newName "x"+                          let ftp1 = hxmapArg fArg tp1 g f+                          let ftp2 = hxmapArg fArg tp2 f g+                          lamE [varP xn]+                               (infixE (Just ftp2)+                                       [|(.)|]+                                       (Just $ infixE (Just $ varE xn)+                                                      [|(.)|]+                                                      (Just ftp1)))+                      AppT _ tp' ->+                          [|fmap|] `appE` hxmapArg fArg tp' f g+                      SigT tp' _ ->+                          hxmapArg fArg tp' f g+                      _ ->+                          error $ "unsopported type: " ++ show tp
+ src/Data/Comp/Derive/Multi/Foldable.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Multi.Foldable+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @HFoldable@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Multi.Foldable+    (+     HFoldable,+     instanceHFoldable+    )where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable+import Data.Foldable+import Language.Haskell.TH+import Data.Monoid+import Data.Maybe+import qualified Prelude as P (foldl,foldr,foldl1)+import Prelude hiding  (foldl,foldr,foldl1)+import Control.Monad+++iter 0 _ e = e+iter n f e = iter (n-1) f (f `appE` e)++iter' n f e = run n f e+    where run 0 _ e = e+          run m f e = let f' = iter (m-1) [|fmap|] f+                      in run (m-1) f (f' `appE` e)++iterSp n f g e = run n e+    where run 0 e = e+          run m e = let f' = iter (m-1) [|fmap|] (if n == m then g else f)+                    in run (m-1) (f' `appE` e)++{-| Derive an instance of 'HFoldable' for a type constructor of any higher-order+  kind taking at least two arguments. -}+instanceHFoldable :: Name -> Q [Dec]+instanceHFoldable fname = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let args' = init args+      fArg = VarT . tyVarBndrName $ last args'+      argNames = (map (VarT . tyVarBndrName) (init args'))+      complType = P.foldl AppT (ConT name) argNames+      classType = AppT (ConT ''HFoldable) complType+  constrs' <- mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs+  foldDecl <- funD 'hfold (map foldClause constrs')+  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)+            filterVar [] _ = Nothing+            filterVar [d] x =Just (d, varE x)+            filterVar _ _ =  error "functor variable occurring twice in argument type"+            filterVars args varNs = catMaybes $ zipWith filterVar args varNs+            mkCPat constr args varNs = ConP constr $ zipWith mkPat args varNs+            mkPat [] _ = WildP+            mkPat _ x = VarP x+            mkPatAndVars (constr, args) =+                do varNs <- newNames (length args) "x"+                   return (mkCPat constr args varNs, filterVars args varNs)+            foldClause (pat,vars) =+                do let conApp (0,x) = [|unK $x|]+                       conApp (d,x) = iterSp d [|fold|] [| foldMap unK |] x+                   body <- if null vars+                           then [|mempty|]+                           else P.foldl1 (\ x y -> [|$x `mappend` $y|])+                                    $ map conApp vars+                   return $ Clause [pat] (NormalB body) []+            foldMapClause (pat,vars) =+                do fn <- newName "y"+                   let f = varE fn+                       f' 0 = f+                       f' n = iter (n-1) [|fmap|] [| foldMap $f |]+                       fp = if null vars then WildP else VarP fn+                   body <- case vars of+                             [] -> [|mempty|]+                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $ +                                      map (\ (d,z) -> iter' (max (d-1) 0) [|fold|] (f' d `appE` z)) vars+                   return $ Clause [fp, pat] (NormalB body) []+            foldlClause (pat,vars) =+                do fn <- newName "f"+                   en <- newName "e"+                   let f = varE fn+                       e = varE en+                       fp = if null vars then WildP else VarP fn+                       ep = VarP en+                       conApp x (0,y) = [|$f $x $y|]+                       conApp x (1,y) = [|foldl $f $x $y|]+                       conApp x (d,y) = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldl $f)|] `appE` y+                                            endo = iter' (d-1) [|fold|] hidEndo+                                        in [| appEndo $endo $x|]+                   body <- P.foldl conApp e vars+                   return $ Clause [fp, ep, pat] (NormalB body) []+            foldrClause (pat,vars) =+                do fn <- newName "f"+                   en <- newName "e"+                   let f = varE fn+                       e = varE en+                       fp = if null vars then WildP else VarP fn+                       ep = VarP en+                       conApp (0,x) y = [|$f $x $y|]+                       conApp (1,x) y = [|foldr $f $y $x |]+                       conApp (d,x) y = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldr $f)|] `appE` x+                                            endo = iter' (d-1) [|fold|] hidEndo+                                        in [| appEndo $endo $y|]+                   body <- P.foldr conApp e vars+                   return $ Clause [fp, ep, pat] (NormalB body) []
+ src/Data/Comp/Derive/Multi/Functor.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Multi.Functor+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @HFunctor@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Multi.Functor+    (+     HFunctor,+     instanceHFunctor+    ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Language.Haskell.TH+import qualified Prelude as P (mapM)+import Prelude hiding (mapM)+import Data.Maybe+import Control.Monad++iter 0 _ e = e+iter n f e = iter (n-1) f (f `appE` e)++{-| Derive an instance of 'HFunctor' for a type constructor of any higher-order+  kind taking at least two arguments. -}+instanceHFunctor :: Name -> Q [Dec]+instanceHFunctor fname = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let args' = init args+      fArg = VarT . tyVarBndrName $ last args'+      argNames = (map (VarT . tyVarBndrName) (init args'))+      complType = foldl AppT (ConT name) argNames+      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)+            filterVar _ nonFarg [] x  = nonFarg x+            filterVar farg _ [depth] x = farg depth x+            filterVar _ _ _ _ = error "functor variable occurring twice in argument type"+            filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs+            mkCPat constr varNs = ConP constr $ map mkPat varNs+            mkPat = VarP+            mkPatAndVars (constr, args) =+                do varNs <- newNames (length args) "x"+                   return (conE constr, mkCPat constr varNs,+                           \ f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),+                           any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))+            hfmapClause (con, pat,vars',hasFargs,_,_) =+                do fn <- newName "f"+                   let f = varE fn+                       fp = if hasFargs then VarP fn else WildP+                       vars = vars' (\d x -> iter d [|fmap|] f `appE` x) id+                   body <- foldl appE con vars+                   return $ Clause [fp, pat] (NormalB body) []
+ src/Data/Comp/Derive/Multi/Show.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Multi.Show+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @HShowF@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Multi.Show+    (+     HShowF(..),+     KShow(..),+     instanceHShowF+    ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Algebra+import Language.Haskell.TH++{-| Signature printing. An instance @HShowF f@ gives rise to an instance+  @KShow (HTerm f)@. -}+class HShowF f where+    hshowF :: HAlg f (K String)+    hshowF = K . hshowF'+    hshowF' :: f (K String) :=> String+    hshowF' = unK . hshowF++class KShow a where+    kshow :: a i -> K String i++showConstr :: String -> [String] -> String+showConstr con [] = con+showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"++{-| Derive an instance of 'HShowF' for a type constructor of any higher-order+  kind taking at least two arguments. -}+instanceHShowF :: Name -> Q [Dec]+instanceHShowF fname = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let args' = init args+      fArg = VarT . tyVarBndrName $ last args'+      argNames = (map (VarT . tyVarBndrName) (init args'))+      complType = foldl AppT (ConT name) argNames+      preCond = map (ClassP ''Show . (: [])) argNames+      classType = AppT (ConT ''HShowF) complType+  constrs' <- mapM normalConExp constrs+  showFDecl <- funD 'hshowF (showFClauses fArg constrs')+  return [InstanceD 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 +              let n = length args+              varNs <- newNames n "x"+              let pat = ConP constr $ map VarP varNs+                  allVars = zipWith (filterFarg fArg) args varNs+                  shows = listE $ map mkShow allVars+                  conName = nameBase constr+              body <- [|K $ showConstr conName $shows|]+              return $ Clause [pat] (NormalB body) []
+ src/Data/Comp/Derive/Multi/SmartConstructors.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Multi.SmartConstructors+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive smart constructors for mutually recursive types.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Multi.SmartConstructors +    (smartHConstructors) where++import Language.Haskell.TH+import Data.Comp.Derive.Utils+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Term++import Control.Monad++{-| Derive smart constructors for a type constructor of any higher-order kind+ taking at least two arguments. The smart constructors are similar to the+ ordinary constructors, but an 'hinject' is automatically inserted. -}+smartHConstructors :: Name -> Q [Dec]+smartHConstructors fname = do+    TyConI (DataD _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+                let bname = nameBase name+                genSmartConstr' targs tname (mkName $ 'i' : bname) name args+              genSmartConstr' targs tname sname name args = do+                varNs <- newNames args "x"+                let pats = map varP varNs+                    vars = map varE varNs+                    val = foldl appE (conE name) vars+                    sig = genSig targs tname sname args+                    function = [funD sname [clause pats (normalB [|hinject $val|]) []]]+                sequence $ sig ++ function+              genSig targs tname sname 0 = (:[]) $ do+                fvar <- newName "f"+                hvar <- newName "h"+                avar <- newName "a"+                ivar <- newName "i"+                let targs' = init $ init targs+                    vars = fvar:hvar:avar:ivar:targs'+                    f = varT fvar+                    h = varT hvar+                    a = varT avar+                    i = varT ivar+                    ftype = foldl appT (conT tname) (map varT targs')+                    constr = classP ''(:<<:) [ftype, f]+                    typ = foldl appT (conT ''HCxt) [h, f, a, i]+                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ+                sigD sname typeSig+              genSig _ _ _ _ = []
+ src/Data/Comp/Derive/Multi/Traversable.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Multi.Traversable+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @HTraversable@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Multi.Traversable+    (+     HTraversable,+     instanceHTraversable+    ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Traversable+import Language.Haskell.TH+import Data.Maybe+import Data.Traversable+import Data.Foldable hiding (any,or)+import Control.Applicative+import Control.Monad hiding (mapM, sequence)+import qualified Prelude as P (foldl, foldr, mapM)+import Prelude hiding  (foldl, foldr,mapM, sequence)++iter 0 _ e = e+iter n f e = iter (n-1) f (f `appE` e)++iter' n f e = run n f e+    where run 0 _ e = e+          run m f e = let f' = iter (m-1) [|fmap|] f+                        in run (m-1) f (f' `appE` e)++{-| Derive an instance of 'HTraversable' for a type constructor of any+  higher-order kind taking at least two arguments. -}+instanceHTraversable :: Name -> Q [Dec]+instanceHTraversable fname = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let args' = init args+      fArg = VarT . tyVarBndrName $ last args'+      argNames = (map (VarT . tyVarBndrName) (init args'))+      complType = foldl AppT (ConT name) argNames+      classType = AppT (ConT ''HTraversable) complType+  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)+            filterVar _ nonFarg [] x  = nonFarg x+            filterVar farg _ [depth] x = farg depth x+            filterVar _ _ _ _ = error "functor variable occurring twice in argument type"+            filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs+            mkCPat constr varNs = ConP constr $ map mkPat varNs+            mkPat = VarP+            mkPatAndVars (constr, args) =+                do varNs <- newNames (length args) "x"+                   return (conE constr, mkCPat constr varNs,+                           \f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),+                           any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))+            traverseClause (con, pat,vars',hasFargs,_,_) =+                do fn <- newName "f"+                   let f = varE fn+                       fp = if hasFargs then VarP fn else WildP+                       vars = vars' (\d x -> iter d [|traverse|] f `appE` x) (\x -> [|pure $x|])+                   body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars+                   return $ Clause [fp, pat] (NormalB body) []+            -- Note: the monadic versions are not defined+            -- applicatively, as this results in a considerable+            -- performance penalty (by factor 2)!+            mapMClause (con, pat,_,hasFargs,allVars, fvars) =+                do fn <- newName "f"+                   let f = varE fn+                       fp = if hasFargs then VarP fn else WildP+                       conAp = P.foldl appE con allVars+                       conBind (d,x) y = [| $(iter d [|mapM|] f) $(varE x)  >>= $(lamE [varP x] y)|]+                   body <- P.foldr conBind [|return $conAp|] fvars+                   return $ Clause [fp, pat] (NormalB body) []
+ src/Data/Comp/Derive/Ordering.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Ordering+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @OrdF@.+--+--------------------------------------------------------------------------------+module Data.Comp.Derive.Ordering+    (+     OrdF(..),+     instanceOrdF+    ) where++import Data.Comp.Derive.Equality+import Data.Comp.Derive.Utils++import Data.Maybe+import Data.List+import Language.Haskell.TH hiding (Cxt)++{-| Signature ordering. An instance @OrdF f@ gives rise to an instance+  @Ord (Term f)@. -}+class EqF f => OrdF f where+    compareF :: Ord a => f a -> f a -> Ordering++    +compList :: [Ordering] -> Ordering+compList = fromMaybe EQ . find (/= EQ)++{-| Derive an instance of 'OrdF' for a type constructor of any first-order kind+  taking at least one argument. -}+instanceOrdF :: Name -> Q [Dec]+instanceOrdF fname = do+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let argNames = (map (VarT . tyVarBndrName) (init args))+      complType = foldl AppT (ConT name) argNames+      preCond = map (ClassP ''Ord . (: [])) argNames+      classType = AppT (ConT ''OrdF) complType+  eqAlgDecl <- funD 'compareF  (compareFClauses constrs)+  return [InstanceD preCond classType [eqAlgDecl]]+      where compareFClauses [] = []+            compareFClauses constrs = +                let constrs' = map abstractConType constrs `zip` [1..]+                    constPairs = [(x,y)| x<-constrs', y <- constrs']+                in map genClause constPairs+            genClause ((c,n),(d,m))+                | n == m = genEqClause c+                | n < m = genLtClause c d+                | otherwise = genGtClause c d+            genEqClause (constr, n) = do +              varNs <- newNames n "x"+              varNs' <- newNames n "y"+              let pat = ConP constr $ map VarP varNs+                  pat' = ConP constr $ map VarP varNs'+                  vars = map VarE varNs+                  vars' = map VarE varNs'+                  mkEq x y = let (x',y') = (return x,return y)+                             in [| compare $x' $y'|]+                  eqs = listE $ zipWith mkEq vars vars'+              body <- [|compList $eqs|]+              return $ Clause [pat, pat'] (NormalB body) []+            genLtClause (c, _) (d, _) = clause [recP c [], recP d []] (normalB [| LT |]) []+            genGtClause (c, _) (d, _) = clause [recP c [], recP d []] (normalB [| GT |]) []
+ src/Data/Comp/Derive/Show.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Show+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @ShowF@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Show+    (+     ShowF(..),+     instanceShowF+    ) where++import Data.Comp.Derive.Utils+import Language.Haskell.TH++{-| Signature printing. An instance @ShowF f@ gives rise to an instance+  @Show (Term f)@. -}+class ShowF f where+    showF :: f String -> String+             +showConstr :: String -> [String] -> String+showConstr con [] = con+showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"++{-| Derive an instance of 'ShowF' for a type constructor of any first-order kind+  taking at least one argument. -}+instanceShowF :: Name -> Q [Dec]+instanceShowF fname = do+  TyConI (DataD _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+      preCond = map (ClassP ''Show . (: [])) argNames+      classType = AppT (ConT ''ShowF) complType+  constrs' <- mapM normalConExp constrs+  showFDecl <- funD 'showF (showFClauses fArg constrs')+  return [InstanceD preCond classType [showFDecl]]+      where showFClauses fArg = map (genShowFClause fArg)+            filterFarg fArg ty x = (fArg == ty, varE x)+            mkShow (isFArg, var)+                | isFArg = var+                | otherwise = [| show $var |]+            genShowFClause fArg (constr, args) = do +              let n = length args+              varNs <- newNames n "x"+              let pat = ConP constr $ map VarP varNs+                  allVars = zipWith (filterFarg fArg) args varNs+                  shows = listE $ map mkShow allVars+                  conName = nameBase constr+              body <- [|showConstr conName $shows|]+              return $ Clause [pat] (NormalB body) []
+ src/Data/Comp/Derive/SmartConstructors.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Signature+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive smart constructors.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.SmartConstructors +    (smartConstructors) where++++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.Sum+import Data.Comp.Term++import Control.Monad++{-| Derive smart constructors for a type constructor of any first-order kind+ taking at least one argument. The smart constructors are similar to the+ 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+    let cons = map abstractConType constrs+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons+        where genSmartConstr targs tname (name, args) = do+                let bname = nameBase name+                genSmartConstr' targs tname (mkName $ 'i' : bname) name args+              genSmartConstr' targs tname sname name args = do+                varNs <- newNames args "x"+                let pats = map varP varNs+                    vars = map varE varNs+                    val = foldl appE (conE name) vars+                    sig = genSig targs tname sname args+                    function = [funD sname [clause pats (normalB [|inject $val|]) []]]+                sequence $ sig ++ function+              genSig targs tname sname 0 = (:[]) $ do+                fvar <- newName "f"+                hvar <- newName "h"+                avar <- newName "a"+                let targs' = init targs+                    vars = fvar:hvar:avar:targs'+                    f = varT fvar+                    h = varT hvar+                    a = varT avar+                    ftype = foldl appT (conT tname) (map varT targs')+                    constr = classP ''(:<:) [ftype, f]+                    typ = foldl appT (conT ''Cxt) [h, f, a]+                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ+                sigD sname typeSig+              genSig _ _ _ _ = []
+ src/Data/Comp/Derive/Traversable.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Traversable+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Automatically derive instances of @Traversable@.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Traversable+    (+     Traversable,+     instanceTraversable+    ) where++import Data.Comp.Derive.Utils+import Language.Haskell.TH+import Data.Maybe+import Data.Traversable+import Data.Foldable hiding (any,or)+import Control.Applicative+import Control.Monad hiding (mapM, sequence)+import qualified Prelude as P (foldl, foldr, mapM)+import Prelude hiding  (foldl, foldr,mapM, sequence)++iter 0 _ e = e+iter n f e = iter (n-1) f (f `appE` e)++iter' n f e = run n f e+    where run 0 _ e = e+          run m f e = let f' = iter (m-1) [|fmap|] f+                        in run (m-1) f (f' `appE` e)++{-| Derive an instance of 'Traversable' for a type constructor of any+  first-order kind taking at least one argument. -}+instanceTraversable :: Name -> Q [Dec]+instanceTraversable fname = do+  TyConI (DataD _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+      classType = AppT (ConT ''Traversable) complType+  constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs+  traverseDecl <- funD 'traverse (map traverseClause constrs')+  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)+            filterVar _ nonFarg [] x  = nonFarg x+            filterVar farg _ [depth] x = farg depth x+            filterVar _ _ _ _ = error "functor variable occurring twice in argument type"+            filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs+            mkCPat constr varNs = ConP constr $ map mkPat varNs+            mkPat = VarP+            mkPatAndVars (constr, args) =+                do varNs <- newNames (length args) "x"+                   return (conE constr, mkCPat constr varNs,+                           \f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),+                           any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))+            traverseClause (con, pat,vars',hasFargs,_,_) =+                do fn <- newName "f"+                   let f = varE fn+                       fp = if hasFargs then VarP fn else WildP+                       vars = vars' (\d x -> iter d [|traverse|] f `appE` x) (\x -> [|pure $x|])+                   body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars+                   return $ Clause [fp, pat] (NormalB body) []+            sequenceAClause (con, pat,vars',hasFargs,_,_) =+                do let vars = vars' (\d x -> iter' d [|sequenceA|] x) (\x -> [|pure $x|])+                   body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars+                   return $ Clause [pat] (NormalB body) []+            -- Note: the monadic versions are not defined+            -- applicatively, as this results in a considerable+            -- performance penalty (by factor 2)!+            mapMClause (con, pat,_,hasFargs,allVars, fvars) =+                do fn <- newName "f"+                   let f = varE fn+                       fp = if hasFargs then VarP fn else WildP+                       conAp = P.foldl appE con allVars+                       conBind (d,x) y = [| $(iter d [|mapM|] f) $(varE x)  >>= $(lamE [varP x] y)|]+                   body <- P.foldr conBind [|return $conAp|] fvars+                   return $ Clause [fp, pat] (NormalB body) []+            sequenceClause (con, pat,_,hasFargs,allVars, fvars) =+                do let conAp = P.foldl appE con allVars+                       conBind (d, x) y = [| $(iter' d [|sequence|] (varE x))  >>= $(lamE [varP x] y)|]+                   body <- P.foldr conBind [|return $conAp|] fvars+                   return $ Clause [pat] (NormalB body) []
+ src/Data/Comp/Derive/Utils.hs view
@@ -0,0 +1,101 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Derive.Utils+-- Copyright   :  (c) 2010-2011 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.Derive.Utils where+++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Control.Monad+import Language.Haskell.TH.ExpandSyns++{-|+  This is the @Q@-lifted version of 'abstractNewtypeQ.+-}+abstractNewtypeQ :: Q Info -> Q Info+abstractNewtypeQ = liftM abstractNewtype++{-|+  This function abstracts away @newtype@ declaration, it turns them into+  @data@ declarations.+-}+abstractNewtype :: Info -> Info+abstractNewtype (TyConI (NewtypeD cxt name args constr derive))+    = TyConI (DataD cxt name args [constr] derive)+abstractNewtype owise = owise++{-|+  This function provides the name and the arity of the given data constructor.+-}+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 (ForallC _ _ constr) = normalCon constr+++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) = normalCon' c+  ts' <- mapM expandSyns ts+  return (n, ts')++{-|+  This function provides the name and the arity of the given data constructor.+-}+abstractConType :: Con -> (Name,Int)+abstractConType (NormalC constr args) = (constr, length args)+abstractConType (RecC constr args) = (constr, length args)+abstractConType (InfixC _ constr _) = (constr, 2)+abstractConType (ForallC _ _ constr) = abstractConType constr++{-|+  This function returns the name of a bound type variable+-}+tyVarBndrName (PlainTV n) = n+tyVarBndrName (KindedTV n _) = n++containsType :: Type -> Type -> Bool+containsType s t+             | s == t = True+             | otherwise = case s of+                             ForallT _ _ s' -> containsType s' t+                             AppT s1 s2 -> containsType s1 t || containsType s2 t+                             SigT s' _ -> containsType s' t+                             _ -> False++containsType' :: Type -> Type -> [Int]+containsType' = run 0+    where run n s t+             | s == t = [n]+             | otherwise = case s of+                             ForallT _ _ s' -> run n s' t+                             -- only going through the right-hand side counts!+                             AppT s1 s2 -> run n s1 t ++ run (n+1) s2 t+                             SigT s' _ -> run n s' t+                             _ -> []+++{-|+  This function provides a list (of the given length) of new names based+  on the given string.+-}+newNames :: Int -> String -> Q [Name]+newNames n name = replicateM n (newName name)++tupleTypes n m = map tupleTypeName [n..m]+
+ src/Data/Comp/Equality.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Equality+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines equality for signatures, which lifts to equality for+-- terms and contexts.+--+--------------------------------------------------------------------------------+module Data.Comp.Equality+    (+     EqF(..),+     eqMod,+    ) where++import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Derive+import Data.Comp.Derive.Utils++import Data.Foldable++import Control.Monad hiding (mapM_)+import Prelude hiding (mapM_, all)++++-- instance (EqF f, Eq p) => EqF (f :*: p) where+--    eqF (v1 :*: p1) (v2 :*: p2) = p1 == p2 && v1 `eqF` v2++{-|+  'EqF' is propagated through sums.+-}++instance (EqF f, EqF g) => EqF (f :+: g) where+    eqF (Inl x) (Inl y) = eqF x y+    eqF (Inr x) (Inr y) = eqF x y+    eqF _ _ = False++{-|+  From an 'EqF' functor an 'Eq' instance of the corresponding+  term type can be derived.+-}+instance (EqF f) => EqF (Cxt h f) where++    eqF (Term e1) (Term e2) = e1 `eqF` e2+    eqF (Hole h1) (Hole h2) = h1 == h2+    eqF _ _ = False++instance (EqF f, Eq a)  => Eq (Cxt h f a) where+    (==) = eqF++instance EqF [] where+    eqF = (==)++{-| This function implements equality of values of type @f a@ modulo+the equality of @a@ itself. If two functorial values are equal in this+sense, 'eqMod' returns a 'Just' value containing a list of pairs+consisting of corresponding components of the two functorial+values. -}++eqMod :: (EqF f, Functor f, Foldable f) => f a -> f b -> Maybe [(a,b)]+eqMod s t+    | unit s `eqF` unit' t = Just args+    | otherwise = Nothing+    where unit = fmap (const ())+          unit' = fmap (const ())+          args = toList s `zip` toList t++$(derive [instanceEqF] $ (''Maybe) : tupleTypes 2 10)
+ src/Data/Comp/ExpFunctor.hs view
@@ -0,0 +1,21 @@+--------------------------------------------------------------------------------+-- |+-- Module	: Data.Comp.ExpFunctor+-- Copyright 	: 2008 Edward Kmett+-- License	: BSD+--+-- Maintainer	: Tom Hvitved <hvitved@diku.dk>+-- Stability	: unknown+-- Portability	: unknown+--+-- Exponential functors, see <http://comonad.com/reader/2008/rotten-bananas/>.+--------------------------------------------------------------------------------++module Data.Comp.ExpFunctor+    ( ExpFunctor(..)+    ) where++{-| Exponential functors are functors that may be both covariant (as ordinary+ functors) and contravariant. -}+class ExpFunctor f where+    xmap :: (a -> b) -> (b -> a) -> f a -> f b
+ src/Data/Comp/Generic.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Generic+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines type generic functions and recursive schemes+-- along the lines of the Uniplate library.+--+--------------------------------------------------------------------------------++module Data.Comp.Generic where++import Data.Comp.Term+import Data.Comp.Sum+import Data.Foldable+import Data.Maybe+import Data.Traversable+import GHC.Exts+import Control.Monad hiding (mapM)+import Prelude hiding (foldl,mapM)++-- | This function returns a list of all subterms of the given+-- term. This function is similar to Uniplate's @universe@ function.+subterms :: forall f . Foldable f => Term f -> [Term f]+subterms t = build (f t)+    where f :: Term f -> (Term f -> b -> b) -> b -> b+          f t cons nil = t `cons` foldl (\u s -> f s cons u) nil (unTerm t)+-- universe t = t : foldl (\u s -> u ++ universe s) [] (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 . (Foldable f, g :<: f) => Term f -> [g (Term f)]+subterms' (Term t) = build (f t)+    where f :: f (Term f) -> (g (Term f) -> b -> b) -> b -> b+          f t cons nil = let rest = foldl (\u (Term s) -> f s cons u) nil t+                         in case proj t of+                              Just t' -> t'`cons` rest+                              Nothing -> rest++-- | This function transforms every subterm according to the given+-- function in a bottom-up manner. This function is similar to+-- Uniplate's @transform@ function.+transform :: (Functor f) => (Term f -> Term f) -> Term f -> Term f+transform f = run+    where run = f . Term . fmap run . unTerm+-- transform f  = f . Term . fmap (transform f) . unTerm++transform' :: (Functor f) => (Term f -> Maybe (Term f)) -> Term f -> Term f+transform' f = transform f' where+    f' t = fromMaybe t (f t)+++-- | Monadic version of 'transform'.+transformM :: (Traversable f, Monad m) =>+             (Term f -> m (Term f)) -> Term f -> m (Term f)+transformM  f = run +    where run t = f =<< liftM Term (mapM run $ unTerm t)++query :: Foldable f => (Term f -> r) -> (r -> r -> r) -> Term f -> r+query q c = run +    where run i@(Term t) = foldl (\s x -> s `c` run x) (q i) t+-- query q c i@(Term t) = foldl (\s x -> s `c` query q c x) (q i) t++gsize :: Foldable f => Term f -> Int+gsize = query (const 1) (+)++-- | This function computes the generic size of the given term,+-- i.e. the its number of subterm occurrences.+size :: Foldable f => Cxt h f a -> Int+size (Hole {}) = 0+size (Term t) = foldl (\s x -> s + size x) 1 t++-- | This function computes the generic depth of the given term.+depth :: Foldable f => Cxt h f a -> Int+depth (Hole {}) = 0+depth (Term t) = 1 + foldl (\s x -> s + size x) 0 t
+ src/Data/Comp/Matching.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE GADTs, FlexibleContexts #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Matching+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module implements matching of contexts or terms with variables againts terms+--+--------------------------------------------------------------------------------++module Data.Comp.Matching+    (+     matchCxt,+     matchTerm,+     module Data.Comp.Variables+    ) where++import Data.Comp.Term+import Data.Comp.Equality+import Data.Comp.Variables+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Foldable++import Prelude hiding (mapM_, all)++{-| This is an auxiliary function for implementing 'matchCxt'. It behaves+similarly as 'match' but is oblivious to non-linearity. Therefore, the+substitution that is returned maps holes to non-empty lists of terms+(resp. contexts in general). This substitution is only a matching+substitution if all elements in each list of the substitution's range+are equal. -}++matchCxt' :: (Ord v, EqF f, Functor f, Foldable f)+       => Context f v -> Cxt h f a -> Maybe (Map v [Cxt h f a])+matchCxt' (Hole v) t = Just $  Map.singleton v [t]+matchCxt' (Term s) (Term t) = do+  eqs <- eqMod s t+  substs <- mapM (uncurry matchCxt') eqs+  return $ Map.unionsWith (++) substs+matchCxt' Term {} Hole {} = Nothing+++{-| This function takes a context @c@ as the first argument and tries+to match it against the term @t@ (or in general a context with holes+in @a@). The context @c@ matches the term @t@ if there is a+/matching substitution/ @s@ that maps holes to terms (resp. contexts in general)+such that if the holes in the context @c@ are replaced according to+the substitution @s@, the term @t@ is obtained. Note that the context+@c@ might be non-linear, i.e. has multiple holes that are+equal. According to the above definition this means that holes with+equal holes have to be instantiated by equal terms! -}++matchCxt :: (Ord v,EqF f, Eq (Cxt h f a), Functor f, Foldable f)+         => Context f v -> Cxt h f a -> Maybe (CxtSubst h a f v)+matchCxt c1 c2 = do +  res <- matchCxt' c1 c2+  let insts = Map.elems res+  mapM_ checkEq insts+  return $ Map.map head res+    where checkEq [] = Nothing+          checkEq (c : cs)+              | all (== c) cs = Just ()+              | otherwise = Nothing++{-| This function is similar to 'matchCxt' but instead of a context it+matches a term with variables against a context.  -}++matchTerm :: (Ord v, EqF f, Eq (Cxt h f a) , Functor f, Foldable f, HasVars f v)+          => Term f -> Cxt h f a -> Maybe (CxtSubst h a f v)+matchTerm t = matchCxt (varsToHoles t)+
+ src/Data/Comp/Multi.hs view
@@ -0,0 +1,456 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines the infrastructure necessary to use compositional data+-- types for mutually recursive data types. Examples of usage are provided+-- below.+--+--------------------------------------------------------------------------------+module Data.Comp.Multi (+  -- * Examples+  -- ** Pure Computations+  -- $ex1++  -- ** Monadic Computations+  -- $ex2++  -- ** Composing Term Homomorphisms and Algebras+  -- $ex3++  -- ** Lifting Term Homomorphisms to Products+  -- $ex4++  -- ** Higher-Order Abstract Syntax+  -- $ex5+    module Data.Comp.Multi.Term+  , module Data.Comp.Multi.Algebra+  , module Data.Comp.Multi.Functor+  , module Data.Comp.Multi.Sum+  , module Data.Comp.Multi.Product+    ) where++import Data.Comp.Multi.Term+import Data.Comp.Multi.Algebra+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Product++{- $ex1+The example below illustrates how to use generalised compositional data types +to implement a small expression language, with a sub language of values, and +an evaluation function mapping expressions to values.++The following language extensions are+needed in order to run the example: @TemplateHaskell@, @TypeOperators@,+@MultiParamTypeClasses@, @FlexibleInstances@, @FlexibleContexts@,+@UndecidableInstances@, and @GADTs@. Moreover, in order to derive instances for+GADTs, version 7 of GHC is needed.++> import Data.Comp.Multi+> import Data.Comp.Multi.Show ()+> import Data.Comp.Derive+> +> -- Signature for values and operators+> data Value e l where+>   Const  ::        Int -> Value e Int+>   Pair   :: e s -> e t -> Value e (s,t)+> data Op e l where+>   Add, Mult  :: e Int -> e Int   -> Op e Int+>   Fst        ::          e (s,t) -> Op e s+>   Snd        ::          e (s,t) -> Op e t+>+> -- Signature for the simple expression language+> type Sig = Op :++: Value+> +> -- Derive boilerplate code using Template Haskell (GHC 7 needed)+> $(derive [instanceHFunctor, instanceHShowF, smartHConstructors] +>          [''Value, ''Op])+> +> -- Term evaluation algebra+> class Eval f v where+>   evalAlg :: HAlg f (HTerm v)+> +> instance (Eval f v, Eval g v) => Eval (f :++: g) v where+>   evalAlg (HInl x) = evalAlg x+>   evalAlg (HInr x) = evalAlg x+> +> -- Lift the evaluation algebra to a catamorphism+> eval :: (HFunctor f, Eval f v) => HTerm f :-> HTerm v+> eval = hcata evalAlg+> +> instance (Value :<<: v) => Eval Value v where+>   evalAlg = hinject+> +> instance (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+>   evalAlg (Snd x)    = snd $ projP x+> +> projC :: (Value :<<: v) => HTerm v Int -> Int+> projC v = case hproject v of Just (Const n) -> n+> +> projP :: (Value :<<: v) => HTerm v (s,t) -> (HTerm v s, HTerm v t)+> projP v = case hproject v of Just (Pair x y) -> (x,y)+> +> -- Example: evalEx = iConst 2+> evalEx :: HTerm Value Int+> evalEx = eval (iFst $ iPair (iConst 2) (iConst 1) :: HTerm Sig Int)+-}++{- $ex2+The example below illustrates how to use generalised compositional data types to+implement a small expression language, with a sub language of values, and a +monadic evaluation function mapping expressions to values.++The following language+extensions are needed in order to run the example: @TemplateHaskell@,+@TypeOperators@, @MultiParamTypeClasses@, @FlexibleInstances@,+@FlexibleContexts@, @UndecidableInstances@, and @GADTs@.  Moreover, in order to+derive instances for GADTs, version 7 of GHC is needed.++> import Data.Comp.Multi+> import Data.Comp.Multi.Show ()+> import Data.Comp.Derive+> import Control.Monad (liftM)+> +> -- Signature for values and operators+> data Value e l where+>   Const  ::        Int -> Value e Int+>   Pair   :: e s -> e t -> Value e (s,t)+> data Op e l where+>   Add, Mult  :: e Int -> e Int   -> Op e Int+>   Fst        ::          e (s,t) -> Op e s+>   Snd        ::          e (s,t) -> Op e t+> +> -- Signature for the simple expression language+> type Sig = Op :++: Value+> +> -- Derive boilerplate code using Template Haskell (GHC 7 needed)+> $(derive [instanceHFunctor, instanceHTraversable, instanceHFoldable,+>           instanceHEqF, instanceHShowF, smartHConstructors]+>          [''Value, ''Op])+> +> -- Monadic term evaluation algebra+> class EvalM f v where+>   evalAlgM :: HAlgM Maybe f (HTerm v)+> +> instance (EvalM f v, EvalM g v) => EvalM (f :++: g) v where+>   evalAlgM (HInl x) = evalAlgM x+>   evalAlgM (HInr x) = evalAlgM x+> +> evalM :: (HTraversable f, EvalM f v) => HTerm f l+>                                      -> Maybe (HTerm v l)+> evalM = hcataM evalAlgM+> +> instance (Value :<<: v) => EvalM Value v where+>   evalAlgM = return . hinject+> +> instance (Value :<<: v) => EvalM Op v where+>   evalAlgM (Add x y)  = do n1 <- projC x+>                            n2 <- projC y+>                            return $ iConst $ n1 + n2+>   evalAlgM (Mult x y) = do n1 <- projC x+>                            n2 <- projC y+>                            return $ iConst $ n1 * n2+>   evalAlgM (Fst v)    = liftM fst $ projP v+>   evalAlgM (Snd v)    = liftM snd $ projP v+> +> projC :: (Value :<<: v) => HTerm v Int -> Maybe Int+> projC v = case hproject v of+>             Just (Const n) -> return n; _ -> Nothing+> +> projP :: (Value :<<: v) => HTerm v (a,b) -> Maybe (HTerm v a, HTerm v b)+> projP v = case hproject v of+>             Just (Pair x y) -> return (x,y); _ -> Nothing+> +> -- Example: evalMEx = Just (iConst 5)+> evalMEx :: Maybe (HTerm Value Int)+> evalMEx = evalM ((iConst 1) `iAdd`+>                  (iConst 2 `iMult` iConst 2) :: HTerm Sig Int)+-}++{- $ex3+The example below illustrates how to compose a term homomorphism and an algebra,+exemplified via a desugaring term homomorphism and an evaluation algebra.++The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@. +Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.++> import Data.Comp.Multi+> import Data.Comp.Multi.Show ()+> import Data.Comp.Derive+> +> -- Signature for values, operators, and syntactic sugar+> data Value e l where+>   Const  ::        Int -> Value e Int+>   Pair   :: e s -> e t -> Value e (s,t)+> data Op e l where+>   Add, Mult  :: e Int -> e Int   -> Op e Int+>   Fst        ::          e (s,t) -> Op e s+>   Snd        ::          e (s,t) -> Op e t+> data Sugar e l where+>   Neg   :: e Int   -> Sugar e Int+>   Swap  :: e (s,t) -> Sugar e (t,s)+>+> -- Source position information (line number, column number)+> data Pos = Pos Int Int+>            deriving Show+> +> -- Signature for the simple expression language+> type Sig = Op :++: Value+> type SigP = Op :&&: Pos :++: Value :&&: Pos+>+> -- Signature for the simple expression language, extended with syntactic sugar+> type Sig' = Sugar :++: Op :++: Value+> type SigP' = Sugar :&&: Pos :++: Op :&&: Pos :++: Value :&&: Pos+> +> -- Derive boilerplate code using Template Haskell (GHC 7 needed)+> $(derive [instanceHFunctor, instanceHTraversable, instanceHFoldable,+>           instanceHEqF, instanceHShowF, smartHConstructors]+>          [''Value, ''Op, ''Sugar])+> +> -- Term homomorphism for desugaring of terms+> class (HFunctor f, HFunctor g) => Desugar f g where+>   desugHom :: HTermHom f g+>   desugHom = desugHom' . hfmap HHole+>   desugHom' :: HAlg f (HContext g a)+>   desugHom' x = appHCxt (desugHom x)+> +> instance (Desugar f h, Desugar g h) => Desugar (f :++: g) h where+>   desugHom (HInl x) = desugHom x+>   desugHom (HInr x) = desugHom x+>   desugHom' (HInl x) = desugHom' x+>   desugHom' (HInr x) = desugHom' x+> +> instance (Value :<<: v, HFunctor v) => Desugar Value v where+>   desugHom = simpHCxt . hinj+> +> instance (Op :<<: v, HFunctor v) => Desugar Op v where+>   desugHom = simpHCxt . hinj+> +> instance (Op :<<: v, Value :<<: v, HFunctor v) => Desugar Sugar v where+>   desugHom' (Neg x)  = iConst (-1) `iMult` x+>   desugHom' (Swap x) = iSnd x `iPair` iFst x+>+> -- Term evaluation algebra+> class Eval f v where+>   evalAlg :: HAlg f (HTerm v)+> +> instance (Eval f v, Eval g v) => Eval (f :++: g) v where+>   evalAlg (HInl x) = evalAlg x+>   evalAlg (HInr x) = evalAlg x+> +> instance (Value :<<: v) => Eval Value v where+>   evalAlg = hinject+> +> instance (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+>   evalAlg (Snd x)    = snd $ projP x+>+> projC :: (Value :<<: v) => HTerm v Int -> Int+> projC v = case hproject v of Just (Const n) -> n+>+> projP :: (Value :<<: v) => HTerm v (s,t) -> (HTerm v s, HTerm v t)+> projP v = case hproject v of Just (Pair x y) -> (x,y)+>+> -- Compose the evaluation algebra and the desugaring homomorphism to an+> -- algebra+> eval :: HTerm Sig' :-> HTerm Value+> eval = hcata (evalAlg `compHAlg` (desugHom :: HTermHom Sig' Sig))+> +> -- Example: evalEx = iPair (iConst 2) (iConst 1)+> evalEx :: HTerm Value (Int,Int)+> evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)+-}++{- $ex4+The example below illustrates how to lift a term homomorphism to products,+exemplified via a desugaring term homomorphism lifted to terms annotated with+source position information.++The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@.+ Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.++> import Data.Comp.Multi+> import Data.Comp.Multi.Show ()+> import Data.Comp.Derive+> +> -- Signature for values, operators, and syntactic sugar+> data Value e l where+>   Const  ::        Int -> Value e Int+>   Pair   :: e s -> e t -> Value e (s,t)+> data Op e l where+>   Add, Mult  :: e Int -> e Int   -> Op e Int+>   Fst        ::          e (s,t) -> Op e s+>   Snd        ::          e (s,t) -> Op e t+> data Sugar e l where+>   Neg   :: e Int   -> Sugar e Int+>   Swap  :: e (s,t) -> Sugar e (t,s)+>+> -- Source position information (line number, column number)+> data Pos = Pos Int Int+>            deriving Show+> +> -- Signature for the simple expression language+> type Sig = Op :++: Value+> type SigP = Op :&&: Pos :++: Value :&&: Pos+>+> -- Signature for the simple expression language, extended with syntactic sugar+> type Sig' = Sugar :++: Op :++: Value+> type SigP' = Sugar :&&: Pos :++: Op :&&: Pos :++: Value :&&: Pos+> +> -- Derive boilerplate code using Template Haskell (GHC 7 needed)+> $(derive [instanceHFunctor, instanceHTraversable, instanceHFoldable,+>           instanceHEqF, instanceHShowF, smartHConstructors]+>          [''Value, ''Op, ''Sugar])+> +> -- Term homomorphism for desugaring of terms+> class (HFunctor f, HFunctor g) => Desugar f g where+>   desugHom :: HTermHom f g+>   desugHom = desugHom' . hfmap HHole+>   desugHom' :: HAlg f (HContext g a)+>   desugHom' x = appHCxt (desugHom x)+> +> instance (Desugar f h, Desugar g h) => Desugar (f :++: g) h where+>   desugHom (HInl x) = desugHom x+>   desugHom (HInr x) = desugHom x+>   desugHom' (HInl x) = desugHom' x+>   desugHom' (HInr x) = desugHom' x+> +> instance (Value :<<: v, HFunctor v) => Desugar Value v where+>   desugHom = simpHCxt . hinj+> +> instance (Op :<<: v, HFunctor v) => Desugar Op v where+>   desugHom = simpHCxt . hinj+> +> instance (Op :<<: v, Value :<<: v, HFunctor v) => Desugar Sugar v where+>   desugHom' (Neg x)  = iConst (-1) `iMult` x+>   desugHom' (Swap x) = iSnd x `iPair` iFst x+>+> -- Lift the desugaring term homomorphism to a catamorphism+> desug :: HTerm Sig' :-> HTerm Sig+> desug = appHTermHom desugHom+>+> -- Example: desugEx = iPair (iConst 2) (iConst 1)+> desugEx :: HTerm Sig (Int,Int)+> desugEx = desug $ iSwap $ iPair (iConst 1) (iConst 2)+>+> -- Lift desugaring to terms annotated with source positions+> desugP :: HTerm SigP' :-> HTerm SigP+> desugP = appHTermHom (productHTermHom desugHom)+>+> iSwapP :: (HDistProd f p f', Sugar :<<: f) => p -> HTerm f' (a,b) -> HTerm f' (b,a)+> iSwapP p x = HTerm (hinjectP p $ hinj $ Swap x)+>+> iConstP :: (HDistProd f p f', Value :<<: f) => p -> Int -> HTerm f' Int+> iConstP p x = HTerm (hinjectP p $ hinj $ Const x)+>+> iPairP :: (HDistProd f p f', Value :<<: f) => p -> HTerm f' a -> HTerm f' b -> HTerm f' (a,b)+> iPairP p x y = HTerm (hinjectP p $ hinj $ Pair x y)+>+> iFstP :: (HDistProd f p f', Op :<<: f) => p -> HTerm f' (a,b) -> HTerm f' a+> iFstP p x = HTerm (hinjectP p $ hinj $ Fst x)+>+> iSndP :: (HDistProd f p f', Op :<<: f) => p -> HTerm f' (a,b) -> HTerm f' b+> iSndP p x = HTerm (hinjectP p $ hinj $ Snd x)+>+> -- Example: desugPEx = iPairP (Pos 1 0)+> --                            (iSndP (Pos 1 0) (iPairP (Pos 1 1)+> --                                                     (iConstP (Pos 1 2) 1)+> --                                                     (iConstP (Pos 1 3) 2)))+> --                            (iFstP (Pos 1 0) (iPairP (Pos 1 1)+> --                                                     (iConstP (Pos 1 2) 1)+> --                                                     (iConstP (Pos 1 3) 2)))+> desugPEx :: HTerm SigP (Int,Int)+> desugPEx = desugP $ iSwapP (Pos 1 0) (iPairP (Pos 1 1) (iConstP (Pos 1 2) 1)+>                                                        (iConstP (Pos 1 3) 2))+-}++{- $ex5+The example below illustrates how to use Higher-Order Abstract Syntax (HOAS)+with generalised compositional data types.++The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@.+Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.++> import Data.Comp.Multi+> import Data.Comp.Derive+> +> data Value e l where+>   Const  ::        Int -> Value e Int+>   Pair   :: e s -> e t -> Value e (s,t)+> data Op e l where+>   Add, Mult  :: e Int -> e Int   -> Op e Int+>   Fst        ::          e (s,t) -> Op e s+>   Snd        ::          e (s,t) -> Op e t+> data Lam e l where+>   Lam :: (e l1 -> e l2) -> Lam e (l1 -> l2)+> data App e l where+>   App :: e (l1 -> l2) -> e l1 -> App e l2+>+> -- Signature for values+> type Val = Lam :++: Value+>+> -- Signature for expressions+> type Sig = App :++: Op :++: Val+> +> -- Derive boilerplate code using Template Haskell (GHC 7 needed)+> $(derive [instanceHExpFunctor, smartHConstructors] +>          [''Value, ''Op, ''Lam, ''App])+> +> -- Term evaluation algebra+> class Eval f v where+>   evalAlg :: HAlg f (HTerm v)+> +> instance (Eval f v, Eval g v) => Eval (f :++: g) v where+>   evalAlg (HInl x) = evalAlg x+>   evalAlg (HInr x) = evalAlg x+> +> -- Lift the evaluation algebra to a catamorphism+> evalE :: (HExpFunctor f, Eval f v) => HTerm f :-> HTerm v+> evalE = hcataE evalAlg+> +> instance (Value :<<: v) => Eval Value v where+>   evalAlg = hinject+> +> instance (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+>   evalAlg (Snd x)    = snd $ projP x+>+> instance (Lam :<<: v) => Eval Lam v where+>   evalAlg = hinject+>+> instance (Lam :<<: v) => Eval App v where+>   evalAlg (App x y) = (projL x) y+>+> projC :: (Value :<<: v) => HTerm v Int -> Int+> projC v = case hproject v of Just (Const n) -> n+> +> projP :: (Value :<<: v) => HTerm v (s,t) -> (HTerm v s, HTerm v t)+> projP v = case hproject v of Just (Pair x y) -> (x,y)+>+> projL :: (Lam :<<: v) => HTerm v (l1 -> l2) -> HTerm v l1 -> HTerm v l2+> projL v = case hproject v of Just (Lam f) -> f+> +> -- Example: evalEEx = iConst 3+> evalEEx :: HTerm Val Int+> evalEEx = evalE (((iLam $ \x -> x) `iApp`+>                   (iConst 1 `iAdd` iConst 2)) :: HTerm Sig Int)+-}
+ src/Data/Comp/Multi/Algebra.hs view
@@ -0,0 +1,475 @@+{-# LANGUAGE GADTs, RankNTypes, TypeOperators, ScopedTypeVariables, +  FlexibleContexts #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Algebra+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines the notion of algebras and catamorphisms, and their+-- generalizations to e.g. monadic versions and other (co)recursion schemes.+-- All definitions are generalised versions of those in "Data.Comp.Algebra".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Algebra (+      -- * Algebras & Catamorphisms+      HAlg,+      hfree,+      hcata,+      hcata',+      appHCxt,+      +      -- * Monadic Algebras & Catamorphisms+      HAlgM,+--      halgM,+      hfreeM,+      hcataM,+      hcataM',+      liftMHAlg,++      -- * Term Homomorphisms+      HCxtFun,+      HSigFun,+      HTermHom,+      appHTermHom,+      compHTermHom,+      appHSigFun,+      compHSigFun,+      htermHom,+      compHAlg,+--      compHCoalg,+--      compHCVCoalg,++      -- * Monadic Term Homomorphisms+      HCxtFunM,+      HSigFunM,+      HTermHomM,+--      HSigFunM',+--      HTermHomM',+      hsigFunM,+--      htermHom',+      appHTermHomM,+      htermHomM,+--      htermHomM',+      appHSigFunM,+--      appHSigFunM',+      compHTermHomM,+      compHSigFunM,+      compHAlgM,+      compHAlgM',++      -- * Coalgebras & Anamorphisms+      HCoalg,+      hana,+--      hana',+      HCoalgM,+      hanaM,++      -- * R-Algebras & Paramorphisms+      HRAlg,+      hpara,+      HRAlgM,+      hparaM,++      -- * R-Coalgebras & Apomorphisms+      HRCoalg,+      hapo,+      HRCoalgM,+      hapoM,++      -- * CV-Algebras & Histomorphisms+      -- $l1+--      HCVAlg,+--      hhisto,+--      HCVAlgM,+--      hhistoM,++      -- * CV-Coalgebras & Futumorphisms+      HCVCoalg,+      hfutu,+--      HCVCoalg',+--      hfutu',+      HCVCoalgM,+      hfutuM,++      -- * Exponential Functors+      appHTermHomE,+      hcataE,+--      hanaE,+      appHCxtE+    ) where+++import Data.Comp.Multi.Term+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Traversable+import Data.Comp.Multi.ExpFunctor+import Data.Comp.Ops++import Control.Monad+++type HAlg f e = f e :-> e++hfree :: forall f h a b . (HFunctor f) =>+              HAlg f b -> (a :-> b) -> HCxt h f a :-> b+hfree f g = run+    where run :: HCxt h f a :-> b+          run (HHole v) = g v+          run (HTerm c) = f $ hfmap run c+++hcata :: forall f a. (HFunctor f) => HAlg f a -> HTerm f :-> a+hcata f = run +    where run :: HTerm f :-> a+          run (HTerm t) = f (hfmap run t)++hcata' :: (HFunctor f) => HAlg f e -> HCxt h f e :-> e+hcata' alg = hfree alg id++-- | This function applies a whole context into another context.++appHCxt :: (HFunctor f) => HContext f (HCxt h f a) :-> HCxt h f a+appHCxt = hcata' HTerm++-- | This function lifts a many-sorted algebra to a monadic domain.+liftMHAlg :: forall m f. (Monad m, HTraversable f) =>+            HAlg f I -> HAlg f m+liftMHAlg alg =  turn . liftM alg . hmapM run+    where run :: m i -> m (I i)+          run m = do x <- m+                     return $ I x+          turn x = do I y <- x+                      return y++type HAlgM m f e = NatM m (f e) e++hfreeM :: forall f m h a b. (HTraversable f, Monad m) =>+               HAlgM m f b -> NatM m a b -> NatM m (HCxt h f a)  b+hfreeM algm var = run+    where run :: NatM m (HCxt h f a) b+          run (HHole x) = var x+          run (HTerm x) = hmapM run x >>= algm++-- | This is a monadic version of 'hcata'.++hcataM :: forall f m a. (HTraversable f, Monad m) =>+         HAlgM m f a -> NatM m (HTerm f) a+-- hcataM alg h (HTerm t) = alg =<< hmapM (hcataM alg h) t+hcataM alg = run+    where run :: NatM m (HTerm f) a+          run (HTerm x) = alg =<< hmapM run x+++hcataM' :: forall m h a f. (Monad m, HTraversable f) => HAlgM m f a -> NatM m (HCxt h f a) a+-- hcataM' alg = hfreeM alg return+hcataM' f = run+    where run :: NatM m (HCxt h f a) a+          run (HHole x) = return x+          run (HTerm x) = hmapM run x >>= f++-- | This type represents context function.++type HCxtFun f g = forall a h. HCxt h f a :-> HCxt h g a++-- | This type represents uniform signature function specification.++type HSigFun f g = forall a. f a :-> g a+++-- | This type represents a term algebra.++type HTermHom f g = HSigFun f (HContext g)++-- | This function applies the given term homomorphism to a+-- term/context.++appHTermHom :: (HFunctor f, HFunctor g) => HTermHom f g -> HCxtFun f g+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type+-- (Functor f, Functor g) => (f (HCxt h g b) -> HContext g (HCxt h g b)) -> HCxt h f b -> HCxt h g b+-- would achieve the same. The given type is chosen for clarity.+appHTermHom _ (HHole b) = HHole b+appHTermHom f (HTerm t) = appHCxt . f . hfmap (appHTermHom f) $ t++-- | This function composes two term algebras.++compHTermHom :: (HFunctor g, HFunctor h) => HTermHom g h -> HTermHom f g -> HTermHom f h+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type+-- (Functor f, Functor g) => (f (HCxt h g b) -> HContext g (HCxt h g b))+-- -> (a -> HCxt h f b) -> a -> HCxt h g b+-- would achieve the same. The given type is chosen for clarity.+compHTermHom f g = appHTermHom f . g++-- | This function composes a term algebra with an algebra.++compHAlg :: (HFunctor g) => HAlg g a -> HTermHom f g -> HAlg f a+compHAlg alg talg = hcata' alg . talg++-- | This function applies a signature function to the given context.++appHSigFun :: (HFunctor f, HFunctor g) => HSigFun f g -> HCxtFun f g+appHSigFun f = appHTermHom $ htermHom f+++-- | This function composes two signature functions.++compHSigFun :: HSigFun g h -> HSigFun f g -> HSigFun f h+compHSigFun f g = f . g+++++-- | Lifts the given signature function to the canonical term homomorphism.+htermHom :: (HFunctor g) => HSigFun f g -> HTermHom f g+htermHom f = simpHCxt . f++-- | This type represents monadic context function.++type HCxtFunM m f g = forall a h. NatM m (HCxt h f a) (HCxt h g a)++-- | This type represents monadic signature functions.++type HSigFunM m f g = forall a. NatM m (f a) (g a)+++-- | This type represents monadic term algebras.++type HTermHomM m f g = HSigFunM m f (HContext g)++-- | This function lifts the given signature function to a monadic+-- signature function. Note that term algebras are instances of+-- signature functions. Hence this function also applies to term+-- algebras.++hsigFunM :: (Monad m) => HSigFun f g -> HSigFunM m f g+hsigFunM f = return . f++-- | This function lifts the give monadic signature function to a+-- monadic term algebra.++htermHom' :: (HFunctor f, HFunctor g, Monad m) =>+            HSigFunM m f g -> HTermHomM m f g+htermHom' f = liftM  (HTerm . hfmap HHole) . f++-- | This function lifts the given signature function to a monadic+-- term algebra.++htermHomM :: (HFunctor g, Monad m) => HSigFun f g -> HTermHomM m f g+htermHomM f = hsigFunM $ htermHom f++-- | This function applies the given monadic term homomorphism to the+-- given term/context.++appHTermHomM :: forall f g m . (HTraversable f, HFunctor g, Monad m)+         => HTermHomM m f g -> HCxtFunM m f g+appHTermHomM f = run+    where run :: NatM m (HCxt h f a) (HCxt h g a)+          run (HHole b) = return $ HHole b+          run (HTerm t) = liftM appHCxt . (>>= f) . hmapM run $ t++-- | This function applies the given monadic signature function to the+-- given context.++appHSigFunM :: (HTraversable f, HFunctor g, Monad m) =>+                HSigFunM m f g -> HCxtFunM m f g+appHSigFunM f = appHTermHomM $ htermHom' f++-- | This function composes two monadic term algebras.++compHTermHomM :: (HTraversable g, HFunctor h, Monad m)+             => HTermHomM m g h -> HTermHomM m f g -> HTermHomM m f h+compHTermHomM f g a = g a >>= appHTermHomM f++{-| This function composes a monadic term algebra with a monadic algebra -}++compHAlgM :: (HTraversable g, Monad m) => HAlgM m g a -> HTermHomM m f g -> HAlgM m f a+compHAlgM alg talg c = hcataM' alg =<< talg c++-- | This function composes a monadic term algebra with a monadic+-- algebra.++compHAlgM' :: (HTraversable g, Monad m) => HAlgM m g a -> HTermHom f g -> HAlgM m f a+compHAlgM' alg talg = hcataM' alg . talg+++{-| This function composes two monadic signature functions.  -}++compHSigFunM :: (Monad m) => HSigFunM m g h -> HSigFunM m f g -> HSigFunM m f h+compHSigFunM f g a = g a >>= f+++----------------+-- Coalgebras --+----------------++type HCoalg f a = a :-> f a++{-| This function unfolds the given value to a term using the given+unravelling function. This is the unique homomorphism @a -> HTerm f@+from the given coalgebra of type @a -> f a@ to the final coalgebra+@HTerm f@. -}++hana :: forall f a. HFunctor f => HCoalg f a -> a :-> HTerm f+hana f = run+    where run :: a :-> HTerm f+          run t = HTerm $ hfmap run (f t)++type HCoalgM m f a = NatM m a (f a)++-- | This function unfolds the given value to a term using the given+-- monadic unravelling function. This is the unique homomorphism @a ->+-- HTerm f@ from the given coalgebra of type @a -> f a@ to the final+-- coalgebra @HTerm f@.++hanaM :: forall a m f. (HTraversable f, Monad m)+          => HCoalgM m f a -> NatM m a (HTerm f)+hanaM f = run +    where run :: NatM m a (HTerm f)+          run t = liftM HTerm $ f t >>= hmapM run++--------------------------------+-- R-Algebras & Paramorphisms --+--------------------------------++-- | This type represents r-algebras over functor @f@ and with domain+-- @a@.++type HRAlg f a = f (HTerm f :*: a) :-> a++-- | This function constructs a paramorphism from the given r-algebra+hpara :: forall f a. (HFunctor f) => HRAlg f a -> HTerm f :-> a+hpara f = fsnd . hcata run+    where run :: HAlg f  (HTerm f :*: a)+          run t = HTerm (hfmap ffst t) :*: f t++-- | This type represents monadic r-algebras over monad @m@ and+-- functor @f@ and with domain @a@.+type HRAlgM m f a = NatM m (f (HTerm f :*: a)) a++-- | This function constructs a monadic paramorphism from the given+-- monadic r-algebra+hparaM :: forall f m a. (HTraversable f, Monad m) => +         HRAlgM m f a -> NatM m(HTerm f)  a+hparaM f = liftM fsnd . hcataM run+    where run :: HAlgM m f (HTerm f :*: a)+          run t = do+            a <- f t+            return (HTerm (hfmap ffst t) :*: a)++--------------------------------+-- R-Coalgebras & Apomorphisms --+--------------------------------++-- | This type represents r-coalgebras over functor @f@ and with+-- domain @a@.+type HRCoalg f a = a :-> f (HTerm f :+: a)++-- | This function constructs an apomorphism from the given+-- r-coalgebra.+hapo :: forall f a . (HFunctor f) => HRCoalg f a -> a :-> HTerm f+hapo f = run +    where run :: a :-> HTerm f+          run = HTerm . hfmap run' . f+          run' :: HTerm f :+: a :-> HTerm f+          run' (Inl t) = t+          run' (Inr a) = run a++-- | This type represents monadic r-coalgebras over monad @m@ and+-- functor @f@ with domain @a@.++type HRCoalgM m f a = NatM m a (f (HTerm f :+: a))++-- | This function constructs a monadic apomorphism from the given+-- monadic r-coalgebra.+hapoM :: forall f m a . (HTraversable f, Monad m) =>+        HRCoalgM m f a -> NatM m a (HTerm f)+hapoM f = run +    where run :: NatM m a (HTerm f)+          run a = do+            t <- f a+            t' <- hmapM run' t+            return $ HTerm t'+          run' :: NatM m (HTerm f :+: a)  (HTerm f)+          run' (Inl t) = return t+          run' (Inr a) = run a++----------------------------------+-- CV-Algebras & Histomorphisms --+----------------------------------++-- $l1 For this to work we need a more general version of @:&&:@ which is of+-- kind @((* -> *) -> * -> *) -> (* -> *) -> (* -> *) -> * -> *@,+-- i.e. one which takes a functor as second argument instead of a+-- type.++-----------------------------------+-- CV-Coalgebras & Futumorphisms --+-----------------------------------+++-- | This type represents cv-coalgebras over functor @f@ and with domain+-- @a@.++type HCVCoalg f a = a :-> f (HContext f a)+++-- | This function constructs the unique futumorphism from the given+-- cv-coalgebra to the term algebra.++hfutu :: forall f a . HFunctor f => HCVCoalg f a -> a :-> HTerm f+hfutu coa = hana run . HHole+    where run :: HCoalg f (HContext f a)+          run (HHole a) = coa a+          run (HTerm v) = v+++-- | This type represents monadic cv-coalgebras over monad @m@ and+-- functor @f@, and with domain @a@.++type HCVCoalgM m f a = NatM m a (f (HContext f a))++-- | This function constructs the unique monadic futumorphism from the+-- given monadic cv-coalgebra to the term algebra.+hfutuM :: forall f a m . (HTraversable f, Monad m) =>+         HCVCoalgM m f a -> NatM m a (HTerm f)+hfutuM coa = hanaM run . HHole+    where run :: HCoalgM m f (HContext f a)+          run (HHole a) = coa a+          run (HTerm v) = return v+++--------------------------+-- Exponential Functors --+--------------------------++{-| Catamorphism for higher-order exponential functors. -}+hcataE :: forall f a . HExpFunctor f => HAlg f a -> HTerm f :-> a+hcataE f = cataFS . toHCxt+    where cataFS :: HExpFunctor f => HContext f a :-> a+          cataFS (HHole x) = x+          cataFS (HTerm t) = f (hxmap cataFS HHole t)+++{-{-| Anamorphism for higher-order exponential functors. -}+hanaE :: forall a f . HExpFunctor f => HCoalg f a -> a :-> HTerm (f :&: a)+hanaE f = run+    where run :: a :-> HTerm (f :&: a)+          run t = HTerm $ hxmap run (snd . hprojectP . unHTerm) (f t) :&: t-}++-- | Variant of 'appHCxt' for contexts over 'HExpFunctor' signatures.+appHCxtE :: (HExpFunctor f) => HContext f (HCxt h f a) :-> HCxt h f a+appHCxtE (HHole x) = x+appHCxtE (HTerm t)  = HTerm (hxmap appHCxtE HHole t)++-- | Variant of 'appHTermHom' for term homomorphisms from and to+-- 'HExpFunctor' signatures.+appHTermHomE :: forall f g . (HExpFunctor f, HExpFunctor g) => HTermHom f g+             -> HTerm f :-> HTerm g+appHTermHomE f = cataFS . toHCxt+    where cataFS :: HContext f (HTerm g) :-> HTerm g+          cataFS (HHole x) = x+          cataFS (HTerm t) = appHCxtE (f (hxmap cataFS HHole t))
+ src/Data/Comp/Multi/Equality.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeOperators, GADTs, FlexibleInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Equality+-- Copyright   :  (c) Patrick Bahr, 2011+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines equality for (higher-order) signatures, which lifts to+-- equality for (higher-order) terms and contexts. All definitions are+-- generalised versions of those in "Data.Comp.Equality".+--+--------------------------------------------------------------------------------+module Data.Comp.Multi.Equality+    (+     HEqF(..),+     KEq(..),+     heqMod+    ) where++import Data.Comp.Multi.Term+import Data.Comp.Multi.Sum+import Data.Comp.Derive++import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable++{-|+  'EqF' is propagated through sums.+-}++instance (HEqF f, HEqF g) => HEqF (f :++: g) where+    heqF (HInl x) (HInl y) = heqF x y+    heqF (HInr x) (HInr y) = heqF x y+    heqF _ _ = False++{-|+  From an 'EqF' functor an 'Eq' instance of the corresponding+  term type can be derived.+-}+instance (HEqF f) => HEqF (HCxt h f) where++    heqF (HTerm e1) (HTerm e2) = e1 `heqF` e2+    heqF (HHole h1) (HHole h2) = h1 `keq` h2+    heqF _ _ = False++instance (HEqF f, KEq a)  => KEq (HCxt h f a) where+    keq = heqF++instance KEq HNothing where+    keq _ = undefined+++{-| This function implements equality of values of type @f a@ modulo+the equality of @a@ itself. If two functorial values are equal in this+sense, 'eqMod' returns a 'Just' value containing a list of pairs+consisting of corresponding components of the two functorial+values. -}++heqMod :: (HEqF f, HFunctor f, HFoldable f) => f a i -> f b i -> Maybe [(A a, A b)]+heqMod s t+    | unit s `heqF` unit' t = Just args+    | otherwise = Nothing+    where unit = hfmap (const $ K ())+          unit' = hfmap (const $ K ())+          args = htoList s `zip` htoList t
+ src/Data/Comp/Multi/ExpFunctor.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeOperators, RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.ExpFunctor+-- Copyright   :  (c) 2011 Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines higher-order exponential functors.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.ExpFunctor+    (+      HExpFunctor(..)+    ) where++import Data.Comp.Multi.Functor++{-| Higher-order exponential functors are higher-order functors that may be both covariant (as ordinary higher-order functors) and contravariant. -}+class HExpFunctor f where+    hxmap :: (a :-> b) -> (b :-> a) -> f a :-> f b
+ src/Data/Comp/Multi/Foldable.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Foldable+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines higher-order foldable functors.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Foldable+    (+     HFoldable (..),+     kfoldr,+     kfoldl,+     htoList+     ) where++import Data.Monoid+import Data.Maybe+import Data.Comp.Multi.Functor++-- | Higher-order functors that can be folded.+--+-- Minimal complete definition: 'hfoldMap' or 'hfoldr'.+class HFunctor h => HFoldable h where+    hfold :: Monoid m => h (K m) :=> m+    hfold = hfoldMap unK++    hfoldMap :: Monoid m => (a :=> m) -> h a :=> m+    hfoldMap f = hfoldr (mappend . f) mempty++    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+    hfoldl f z t = appEndo (getDual (hfoldMap (Dual . Endo . flip f) t)) z+++    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+                mf (K x) Nothing = Just x+                mf (K x) (Just y) = Just (f x y)++    hfoldl1 :: forall a . (a -> a -> a) -> h (K a) :=> a+    hfoldl1 f xs = fromMaybe (error "hfoldl1: empty structure")+                   (hfoldl mf Nothing xs)+          where mf :: Maybe a -> K a :=> Maybe a+                mf Nothing (K y) = Just y+                mf (Just x) (K y) = Just (f x y)++htoList :: (HFoldable f) => f a :=> [A a]+htoList = hfoldr (\ n l ->  A n : l) []+    +kfoldr :: (HFoldable f) => (a -> b -> b) -> b -> f (K a) :=> b+kfoldr f = hfoldr (\ (K x) y -> f x y)+++kfoldl :: (HFoldable f) => (b -> a -> b) -> b -> f (K a) :=> b+kfoldl f = hfoldl (\ x (K y) -> f x y)
+ src/Data/Comp/Multi/Functor.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Functor+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines higher-order functors (Johann, Ghani, POPL+-- '08), i.e. endofunctors on the category of endofunctors.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Functor+    (+     HFunctor (..),+     (:->),+     (:=>),+     NatM,+     I (..),+     K (..),+     A (..),+     (:.:)(..)+     ) where++-- | The identity Functor.+data I a = I {unI :: a}++-- | The parametrised constant functor.+data K a b = K {unK :: a}++instance Functor (K a) where+    fmap _ (K x) = K x++data A f = forall i. A {unA :: f i}++instance Eq a => Eq (K a i) where+    K x == K y = x == y+    K x /= K y = x /= y++instance Ord a => Ord (K a i) where+    K x < K y = x < y+    K x > K y = x > y+    K x <= K y = x <= y+    K x >= K y = x >= y+    min (K x) (K y) = K $ min x y+    max (K x) (K y) = K $ max x y+    compare (K x) (K y) = compare x y+++infixr 0 :-> -- same precedence as function space operator ->+infixr 0 :=> -- same precedence as function space operator ->++-- | This type represents natural transformations.+type f :-> g = forall i . f i -> g i++-- | This type represents co-cones from @f@ to @a@. @f :=> a@ is+-- isomorphic to f :-> K a+type f :=> a = forall i . f i -> a+++type NatM m f g = forall i. f i -> m (g i)++-- | This class represents higher-order functors (Johann, Ghani, POPL+-- '08) which are endofunctors on the category of endofunctors.+class HFunctor h where+    -- A higher-order functor @f@ maps every functor @g@ to a+    -- functor @f g@.+    --+    -- @ffmap :: (Functor g) => (a -> b) -> f g a -> f g b@+    -- +    -- We omit this, as it does not work for GADTs (see Johand and+    -- Ghani 2008).++    -- | A higher-order functor @f@ also maps a natural transformation+    -- @g :-> h@ to a natural transformation @f g :-> f h@+    hfmap :: (f :-> g) -> h f :-> h g++infixl 5 :.:++-- | This data type denotes the composition of two functor families.+data (f :.: g) e t = Comp f (g e) t
+ src/Data/Comp/Multi/Ops.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,+             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,+             ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, KindSignatures #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Ops+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides operators on higher-order functors. All definitions are+-- generalised versions of those in "Data.Comp.Ops".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Ops where++import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable+import Data.Comp.Multi.Traversable+import Data.Comp.Multi.ExpFunctor+import Data.Comp.Ops+import Control.Monad+import Control.Applicative+++infixr 5 :++:+++-- |Data type defining coproducts.+data (f :++: g) (h :: * -> *) e = HInl (f h e)+                    | HInr (g h e)++instance (HFunctor f, HFunctor g) => HFunctor (f :++: g) where+    hfmap f (HInl v) = HInl $ hfmap f v+    hfmap f (HInr v) = HInr $ hfmap f v++instance (HFoldable f, HFoldable g) => HFoldable (f :++: g) where+    hfold (HInl e) = hfold e+    hfold (HInr e) = hfold e+    hfoldMap f (HInl e) = hfoldMap f e+    hfoldMap f (HInr e) = hfoldMap f e+    hfoldr f b (HInl e) = hfoldr f b e+    hfoldr f b (HInr e) = hfoldr f b e+    hfoldl f b (HInl e) = hfoldl f b e+    hfoldl f b (HInr e) = hfoldl f b e++    hfoldr1 f (HInl e) = hfoldr1 f e+    hfoldr1 f (HInr e) = hfoldr1 f e+    hfoldl1 f (HInl e) = hfoldl1 f e+    hfoldl1 f (HInr e) = hfoldl1 f e++instance (HTraversable f, HTraversable g) => HTraversable (f :++: g) where+    htraverse f (HInl e) = HInl <$> htraverse f e+    htraverse f (HInr e) = HInr <$> htraverse f e+    hmapM f (HInl e) = HInl `liftM` hmapM f e+    hmapM f (HInr e) = HInr `liftM` hmapM f e++instance (HExpFunctor f, HExpFunctor g) => HExpFunctor (f :++: g) where+    hxmap f g (HInl v) = HInl $ hxmap f g v+    hxmap f g (HInr v) = HInr $ hxmap f g v++-- |The subsumption relation.+class (sub :: (* -> *) -> * -> *) :<<: sup where+    hinj :: sub a :-> sup a+    hproj :: NatM Maybe (sup a) (sub a)++instance (:<<:) f f where+    hinj = id+    hproj = Just++instance (:<<:) f (f :++: g) where+    hinj = HInl+    hproj (HInl x) = Just x+    hproj (HInr _) = Nothing++instance (f :<<: g) => (:<<:) f (h :++: g) where+    hinj = HInr . hinj+    hproj (HInr x) = hproj x+    hproj (HInl _) = Nothing++-- Products++infixr 8 :**:++data (f :**: g) a = f a :**: g a+++hfst :: (f :**: g) a -> f a+hfst (x :**: _) = x++hsnd :: (f :**: g) a -> g a+hsnd (_ :**: x) = x++-- Constant Products++infixr 7 :&&:++-- | This data type adds a constant product to a+-- signature. Alternatively, this could have also been defined as+-- +-- @data (f :&&: a) (g ::  * -> *) e = f g e :&&: a e@+-- +-- This is too general, however, for example for 'productHTermHom'.++data (f :&&: a) (g ::  * -> *) e = f g e :&&: a+++instance (HFunctor f) => HFunctor (f :&&: a) where+    hfmap f (v :&&: c) = hfmap f v :&&: c++instance (HFoldable f) => HFoldable (f :&&: a) where+    hfold (v :&&: _) = hfold v+    hfoldMap f (v :&&: _) = hfoldMap f v+    hfoldr f e (v :&&: _) = hfoldr f e v+    hfoldl f e (v :&&: _) = hfoldl f e v+    hfoldr1 f (v :&&: _) = hfoldr1 f v+    hfoldl1 f (v :&&: _) = hfoldl1 f v+++instance (HTraversable f) => HTraversable (f :&&: a) where+    htraverse f (v :&&: c) =  (:&&: c) <$> (htraverse f v)+    hmapM f (v :&&: c) = liftM (:&&: c) (hmapM f v)++-- | This class defines how to distribute a product over a sum of+-- signatures.++class HDistProd (s :: (* -> *) -> * -> *) p s' | s' -> s, s' -> p where+        +    -- | This function injects a product a value over a signature.+    hinjectP :: p -> s a :-> s' a+    hprojectP :: s' a :-> (s a :&: p)+++class HRemoveP (s :: (* -> *) -> * -> *) s' | s -> s'  where+    hremoveP :: s a :-> s' a+++instance (HRemoveP s s') => HRemoveP (f :&&: p :++: s) (f :++: s') where+    hremoveP (HInl (v :&&: _)) = HInl v+    hremoveP (HInr v) = HInr $ hremoveP v+++instance HRemoveP (f :&&: p) f where+    hremoveP (v :&&: _) = v+++instance HDistProd f p (f :&&: p) where++    hinjectP p v = v :&&: p++    hprojectP (v :&&: p) = v :&: p+++instance (HDistProd s p s') => HDistProd (f :++: s) p ((f :&&: p) :++: s') where+    hinjectP p (HInl v) = HInl (v :&&: p)+    hinjectP p (HInr v) = HInr $ hinjectP p v++    hprojectP (HInl (v :&&: p)) = (HInl v :&: p)+    hprojectP (HInr v) = let (v' :&: p) = hprojectP v+                        in  (HInr v' :&: p)
+ src/Data/Comp/Multi/Product.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses,+  FlexibleInstances, UndecidableInstances, RankNTypes, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Product+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines products on signatures. All definitions are+-- generalised versions of those in "Data.Comp.Product".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Product+    ( (:&&:) (..),+      HDistProd (..),+      HRemoveP (..),+      liftP,+      constP,+      liftP',+      stripP,+      productHTermHom,+      hproject'+    )where++import Data.Comp.Multi.Term+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Ops+import Data.Comp.Ops+import Data.Comp.Multi.Algebra+import Data.Comp.Multi.Functor++import Control.Monad+++++-- | This function transforms a function with a domain constructed+-- from a functor to a function with a domain constructed with the+-- same functor but with an additional product.++liftP :: (HRemoveP s s') => (s' a :-> t) -> s a :-> t+liftP f v = f (hremoveP v)+++-- | This function annotates each sub term of the given term with the+-- given value (of type a).++constP :: (HDistProd f p g, HFunctor f, HFunctor g) +       => p -> HCxt h f a :-> HCxt h g a+constP c = appHSigFun (hinjectP c)++-- | This function transforms a function with a domain constructed+-- from a functor to a function with a domain constructed with the+-- same functor but with an additional product.++liftP' :: (HDistProd s' p s, HFunctor s, HFunctor s')+       => (s' a :-> HCxt h s' a) -> s a :-> HCxt h s a+liftP' f v = let (v' :&: p) = hprojectP v+             in constP p (f v')+    +{-| This function strips the products from a term over a+functor whith products. -}++stripP :: (HFunctor f, HRemoveP g f, HFunctor g)+       => HCxt h g a :-> HCxt h f a+stripP = appHSigFun hremoveP+++productHTermHom :: (HDistProd f p f', HDistProd g p g', HFunctor g, HFunctor g') +               => HTermHom f g -> HTermHom f' g'+productHTermHom alg f' = constP p (alg f)+    where (f :&: p) = hprojectP f'++++++-- | This function is similar to 'hproject' but applies to signatures+-- with a product which is then ignored.++-- hproject' :: (HRemoveP s s',s :<<: f) =>+--      NatM Maybe (HCxt h f a) (s' (HCxt h f a))+hproject' v = liftM hremoveP $ hproject v
+ src/Data/Comp/Multi/Show.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeOperators, GADTs, FlexibleContexts,+  ScopedTypeVariables, UndecidableInstances, FlexibleInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Show+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines showing of (higher-order) signatures, which lifts to+-- showing of (higher-order) terms and contexts. All definitions are+-- generalised versions of those in "Data.Comp.Show".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Show+    ( HShowF(..)+    ) where++import Data.Comp.Multi.Term+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Product+import Data.Comp.Multi.Algebra+import Data.Comp.Multi.Functor+import Data.Comp.Derive++instance KShow HNothing where+    kshow _ = undefined+instance KShow (K String) where+    kshow = id++instance (HShowF f, HFunctor f) => HShowF (HCxt h f) where+    hshowF (HHole s) = s+    hshowF (HTerm t) = hshowF $ hfmap hshowF t++instance (HShowF f, HFunctor f, KShow a) => KShow (HCxt h f a) where+    kshow = hfree hshowF kshow++instance (KShow f) => Show (f i) where+    show = unK . kshow++instance (HShowF f, Show p) => HShowF (f :&&: p) where+    hshowF (v :&&: p) =  K $ unK (hshowF v) ++ " :&&: " ++ show p++instance (HShowF f, HShowF g) => HShowF (f :++: g) where+    hshowF (HInl f) = hshowF f+    hshowF (HInr g) = hshowF g
+ src/Data/Comp/Multi/Sum.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables, IncoherentInstances,+  RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Sum+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines sums on signatures. All definitions are+-- generalised versions of those in "Data.Comp.Sum".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Sum+    (+     (:<<:)(..),+     (:++:)(..),++     -- * Projections for Signatures and Terms+     hproj2,+     hproj3,+     hproject,+     hproject2,+     hproject3,+     deepHProject,+     deepHProject2,+     deepHProject3,+--     deepHProject',+--     deepHProject2',+--     deepHProject3',++     -- * Injections for Signatures and Terms+     hinj2,+     hinj3,+     hinject,+     hinject2,+     hinject3,+     deepHInject,+     deepHInject2,+     deepHInject3,+     deepHInjectE,+     deepHInjectE2,+     deepHInjectE3,++     -- * Injections and Projections for Constants+     hinjectHConst,+     hinjectHConst2,+     hinjectHConst3,+     hprojectHConst,+     hinjectHCxt,+     liftHCxt,+     substHHoles,+--     substHHoles'+    ) where++import Data.Comp.Multi.Functor+import Data.Comp.Multi.Traversable+import Data.Comp.Multi.ExpFunctor+import Data.Comp.Multi.Ops+import Data.Comp.Multi.Term+import Data.Comp.Multi.Algebra+import Control.Monad (liftM)++{-| A variant of 'hproj' for binary sum signatures.  -}+hproj2 :: forall f g1 g2 a i. (g1 :<<: f, g2 :<<: f) =>+          f a i -> Maybe (((g1 :++: g2) a) i)+hproj2 x = case hproj x of+             Just (y :: g1 a i) -> Just $ hinj y+             _ -> liftM hinj (hproj x :: Maybe (g2 a i))++{-| A variant of 'hproj' for ternary sum signatures.  -}+hproj3 :: forall f g1 g2 g3 a i. (g1 :<<: f, g2 :<<: f, g3 :<<: f) =>+          f a i -> Maybe (((g1 :++: g2 :++: g3) a) i)+hproj3 x = case hproj x of+             Just (y :: g1 a i) -> Just $ hinj y+             _ -> case hproj x of+                    Just (y :: g2 a i) -> Just $ hinj y+                    _ -> liftM hinj (hproj x :: Maybe (g3 a i))++-- |Project the outermost layer of a term to a sub signature.+hproject :: (g :<<: f) => NatM Maybe (HCxt h f a)  (g (HCxt h f a))+hproject (HHole _) = Nothing+hproject (HTerm t) = hproj t++-- |Project the outermost layer of a term to a binary sub signature.+hproject2 :: (g1 :<<: f, g2 :<<: f) =>+             NatM Maybe (HCxt h f a) ((g1 :++: g2) (HCxt h f a))+hproject2 (HHole _) = Nothing+hproject2 (HTerm t) = hproj2 t++-- |Project the outermost layer of a term to a ternary sub signature.+hproject3 :: (g1 :<<: f, g2 :<<: f, g3 :<<: f) =>+             NatM Maybe (HCxt h f a) ((g1 :++: g2 :++: g3) (HCxt h f a))+hproject3 (HHole _) = Nothing+hproject3 (HTerm t) = hproj3 t++-- |Project a term to a term over a sub signature.+deepHProject :: (HTraversable f, HFunctor g, g :<<: f)+             => NatM Maybe (HCxt h f a) (HCxt h g a)+deepHProject = appHSigFunM hproj++-- |Project a term to a term over a binary sub signature.+deepHProject2 :: (HTraversable f, HFunctor g1, HFunctor g2,+                  g1 :<<: f, g2 :<<: f)+              => NatM Maybe (HCxt h f a) (HCxt h (g1 :++: g2) a)+deepHProject2 = appHSigFunM hproj2++-- |Project a term to a term over a ternary sub signature.+deepHProject3 :: (HTraversable f, HFunctor g1, HFunctor g2, HFunctor g3,+                  g1 :<<: f, g2 :<<: f, g3 :<<: f)+              => NatM Maybe (HCxt h f a) (HCxt h (g1 :++: g2 :++: g3) a)+deepHProject3 = appHSigFunM hproj3++{-| A variant of 'hinj' for binary sum signatures.  -}+hinj2 :: (f1 :<<: g, f2 :<<: g) => (f1 :++: f2) a :-> g a+hinj2 (HInl x) = hinj x+hinj2 (HInr y) = hinj y++{-| A variant of 'hinj' for ternary sum signatures.  -}+hinj3 :: (f1 :<<: g, f2 :<<: g, f3 :<<: g) => (f1 :++: f2 :++: f3) a :-> g a+hinj3 (HInl x) = hinj x+hinj3 (HInr y) = hinj2 y++-- |Inject a term where the outermost layer is a sub signature.+hinject :: (g :<<: f) => g (HCxt h f a) :-> HCxt h f a+hinject = HTerm . hinj++-- |Inject a term where the outermost layer is a binary sub signature.+hinject2 :: (f1 :<<: g, f2 :<<: g) => (f1 :++: f2) (HCxt h g a) :-> HCxt h g a+hinject2 = HTerm . hinj2++-- |Inject a term where the outermost layer is a ternary sub signature.+hinject3 :: (f1 :<<: g, f2 :<<: g, f3 :<<: g)+         => (f1 :++: f2 :++: f3) (HCxt h g a) :-> HCxt h g a+hinject3 = HTerm . hinj3++-- |Inject a term over a sub signature to a term over larger signature.+deepHInject :: (HFunctor g, HFunctor f, g :<<: f) => HCxt h g a :-> HCxt h f a+deepHInject = appHSigFun hinj++-- |Inject a term over a binary sub signature to a term over larger signature.+deepHInject2 :: (HFunctor f1, HFunctor f2, HFunctor g, f1 :<<: g, f2 :<<: g)+             => HCxt h (f1 :++: f2) a :-> HCxt h g a+deepHInject2 = appHSigFun hinj2++-- |Inject a term over a ternary sub signature to a term over larger signature.+deepHInject3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g,+                 f1 :<<: g, f2 :<<: g, f3 :<<: g)+             => HCxt h (f1 :++: f2 :++: f3) a :-> HCxt h g a+deepHInject3 = appHSigFun hinj3++{-| A variant of 'deepHInject' for exponential signatures. -}+deepHInjectE :: (HExpFunctor g, g :<<: f) => HTerm g :-> HTerm f+deepHInjectE = hcataE hinject++{-| A variant of 'deepHInject2' for exponential signatures. -}+deepHInjectE2 :: (HExpFunctor g1, HExpFunctor g2, g1 :<<: f, g2 :<<: f) =>+                 HTerm (g1 :++: g2) :-> HTerm f+deepHInjectE2 = hcataE hinject2++{-| A variant of 'deepHInject3' for exponential signatures. -}+deepHInjectE3 :: (HExpFunctor g1, HExpFunctor g2, HExpFunctor g3,+                  g1 :<<: f, g2 :<<: f, g3 :<<: f) =>+                 HTerm (g1 :++: g2 :++: g3) :-> HTerm f+deepHInjectE3 = hcataE hinject3++-- | This function injects a whole context into another context.+hinjectHCxt :: (HFunctor g, g :<<: f) => HCxt h' g (HCxt h f a) :-> HCxt h f a+hinjectHCxt = hcata' hinject++-- | This function lifts the given functor to a context.+liftHCxt :: (HFunctor f, g :<<: f) => g a :-> HContext f a+liftHCxt g = simpHCxt $ hinj g++-- | This function applies the given context with hole type @a@ to a+-- family @f@ of contexts (possibly terms) indexed by @a@. That is,+-- each hole @h@ is replaced by the context @f h@.++substHHoles :: (HFunctor f, HFunctor g, f :<<: g)+           => (v :-> HCxt h g a) -> HCxt h' f v :-> HCxt h g a+substHHoles f c = hinjectHCxt $ hfmap f c++hinjectHConst :: (HFunctor g, g :<<: f) => HConst g :-> HCxt h f a+hinjectHConst = hinject . hfmap (const undefined)++hinjectHConst2 :: (HFunctor f1, HFunctor f2, HFunctor g, f1 :<<: g, f2 :<<: g)+               => HConst (f1 :++: f2) :-> HCxt h g a+hinjectHConst2 = hinject2 . hfmap (const undefined)++hinjectHConst3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g,+                   f1 :<<: g, f2 :<<: g, f3 :<<: g)+               => HConst (f1 :++: f2 :++: f3) :-> HCxt h g a+hinjectHConst3 = hinject3 . hfmap (const undefined)++hprojectHConst :: (HFunctor g, g :<<: f) => NatM Maybe (HCxt h f a) (HConst g)+hprojectHConst = fmap (hfmap (const (K ()))) . hproject
+ src/Data/Comp/Multi/Term.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, RankNTypes,+  TypeOperators, ScopedTypeVariables, IncoherentInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Term+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines the central notion of mutual recursive (or, higher-order)+-- /terms/ and its generalisation to (higher-order) contexts. All definitions+-- are generalised versions of those in "Data.Comp.Term".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Term +    (HCxt (..),+     HHole,+     HNoHole,+     HContext,+     HNothing,+     HTerm,+     HConst,+     constHTerm,+     unHTerm,+     toHCxt,+     simpHCxt+     ) where++import Data.Comp.Multi.Functor+import Unsafe.Coerce++type HConst (f :: (* -> *) -> * -> *) = f (K ())++-- | This function converts a constant to a term. This assumes that+-- the argument is indeed a constant, i.e. does not have a value for+-- the argument type of the functor f.++constHTerm :: (HFunctor f) => HConst f :-> HTerm f+constHTerm = HTerm . hfmap (const undefined)++-- | This data type represents contexts over a signature. Contexts are+-- terms containing zero or more holes. The first type parameter is+-- supposed to be one of the phantom types 'HHole' and 'HNoHole'. The+-- second parameter is the signature of the context. The third+-- parameter is the type family of the holes. The last parameter is+-- the index/label.++data HCxt h f a i where+    HTerm ::  f (HCxt h f a) i -> HCxt h f a i+    HHole :: a i -> HCxt HHole f a i++-- | Phantom type that signals that a 'HCxt' might contain holes.+data HHole+-- | Phantom type that signals that a 'HCxt' does not contain holes.+data HNoHole++-- | A context might contain holes.+type HContext = HCxt HHole++{-| Phantom type family used to define 'HTerm'.  -}+data HNothing :: * -> *++instance Show (HNothing i) where+instance Eq (HNothing i) where+instance Ord (HNothing i) where++-- | A (higher-order) term is a context with no holes.+type HTerm f = HCxt HNoHole f HNothing++-- | This function unravels the given term at the topmost layer.+unHTerm :: HTerm f t -> f (HTerm f) t+unHTerm (HTerm t) = t++instance (HFunctor f) => HFunctor (HCxt h f) where+    hfmap f (HHole x) = HHole (f x)+    hfmap f (HTerm t) = HTerm (hfmap (hfmap f) t)+++simpHCxt :: (HFunctor f) => f a i -> HContext f a i+simpHCxt = HTerm . hfmap HHole++toHCxt :: HTerm f i -> HContext f a i+toHCxt = unsafeCoerce+--toHCxt :: (HFunctor f) => HTerm f i -> HContext f a i+--toHCxt (HTerm t) = HTerm $ hfmap toHCxt t
+ src/Data/Comp/Multi/Traversable.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Traversable+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines higher-order traversable functors.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Traversable+    (+     HTraversable (..)+    ) where++import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable+import Control.Applicative++class HFoldable t => HTraversable t where++    -- | Map each element of a structure to a monadic action, evaluate+    -- these actions from left to right, and collect the results.+    --+    -- Alternative type in terms of natural transformations using+    -- functor composition @:.:@:+    --+    -- @hmapM :: Monad m => (a :-> m :.: b) -> t a :-> m :.: (t b)@+    hmapM :: (Monad m) => NatM m a b -> NatM m (t a) (t b)++    htraverse :: (Applicative f) => NatM f a b -> NatM f (t a) (t b)
+ src/Data/Comp/Multi/Variables.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,+  OverlappingInstances, TypeOperators, KindSignatures, FlexibleContexts, ScopedTypeVariables, RankNTypes #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Variables+-- Copyright   :  (c) 2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines an abstraction notion of a variable in a term. All+-- definitions are generalised versions of those in "Data.Comp.Variables".+--+--------------------------------------------------------------------------------+module Data.Comp.Multi.Variables  where++import Data.Comp.Multi.Term+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Algebra+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable++import Data.Set (Set)+import qualified Data.Set as Set++import Data.Maybe+++-- type HCxtSubst h a f v =  [A (v :*: (HCxt h f a))]++-- type Subst f v = HCxtSubst HNoHole HNothing f v++type GSubst v a = NatM Maybe (K v) a++type HCxtSubst h a f v =  GSubst v (HCxt h f a)++type Subst f v = HCxtSubst HNoHole HNothing f v++{-| This multiparameter class defines functors with variables. An+instance @HasVar f v@ denotes that values over @f@ might contain+variables of type @v@. -}++class HasVars (f  :: (* -> *) -> * -> *) v where+    isVar :: f a :=> Maybe v+    isVar _ = Nothing++instance (HasVars f v, HasVars g v) => HasVars (f :++: g) v where+    isVar (HInl v) = isVar v+    isVar (HInr v) = isVar v++instance HasVars f v => HasVars (HCxt h f) v where+    isVar (HTerm t) = isVar t+    isVar _ = Nothing++varsToHHoles :: forall f v. (HFunctor f, HasVars f v) => HTerm f :-> HContext f (K v)+varsToHHoles = hcata alg+    where alg :: HAlg f (HContext f (K v))+          alg t = case isVar t of +                    Just v -> HHole $ K v+                    Nothing -> HTerm t++containsVarAlg :: (Eq v, HasVars f v, HFoldable f) => v -> HAlg f (K Bool)+containsVarAlg v t = K $ local || kfoldl (||) False t +    where local = case isVar t of+                    Just v' -> v == v'+                    Nothing -> False++{-| This function checks whether a variable is contained in a+context. -}++containsVar :: (Eq v, HasVars f v, HFoldable f, HFunctor f)+            => v -> HCxt h f a :=> Bool+containsVar v = unK . hfree (containsVarAlg v) (const $ K False)+++variableListAlg :: (HasVars f v, HFoldable f)+            => HAlg f (K [v])+variableListAlg t = K $ kfoldl (++) local t+    where local = case isVar t of+                    Just v -> [v]+                    Nothing -> [] ++{-| This function computes the list of variables occurring in a+context. -}++variableList :: (HasVars f v, HFoldable f, HFunctor f)+            => HCxt h f a :=> [v]+variableList = unK . hfree variableListAlg (const $ K [])++++variablesAlg :: (Ord v, HasVars f v, HFoldable f)+            => HAlg f (K (Set v))+variablesAlg t = K $ kfoldl Set.union local t+    where local = case isVar t of+                    Just v -> Set.singleton v+                    Nothing -> Set.empty++{-| This function computes the set of variables occurring in a+context. -}++variables :: (Ord v, HasVars f v, HFoldable f, HFunctor f)+            => HCxt h f a :=> Set v+variables = unK . hfree variablesAlg (const $ K Set.empty)++{-| This function computes the set of variables occurring in a+context. -}++variables' :: (Ord v, HasVars f v, HFoldable f, HFunctor f)+            => HConst f :=> Set v+variables' c =  case isVar c of+                  Nothing -> Set.empty+                  Just v -> Set.singleton v++++substAlg :: (HasVars f v) => HCxtSubst h a f v -> HAlg f (HCxt h f a)+substAlg f t = fromMaybe (HTerm t) (isVar t >>= f . K)++{-| This function substitutes variables in a context according to a+partial mapping from variables to contexts.-}++class SubstVars v t a where+    substVars :: GSubst v t -> a :-> a+++appSubst :: SubstVars v t a => GSubst v t -> a :-> a+appSubst = substVars++instance (Ord v, HasVars f v, HFunctor f) => SubstVars v (HCxt h f a) (HCxt h f a) where+    substVars f (HTerm v) = substAlg f $ hfmap (substVars f) v+    substVars _ (HHole a) = HHole a+-- have to use explicit GADT pattern matching!!+-- subst f = hfree (substAlg f) HHole++instance (SubstVars v t a, HFunctor f) => SubstVars v t (f a) where+    substVars f = hfmap (substVars f) ++++{-| This function composes two substitutions @s1@ and @s2@. That is,+applying the resulting substitution is equivalent to first applying+@s2@ and then @s1@. -}++compSubst :: (Ord v, HasVars f v, HFunctor f)+          => HCxtSubst h a f v -> HCxtSubst h a f v -> HCxtSubst h a f v+compSubst s1 s2 v = case s2 v of+                      Nothing -> s1 v+                      Just t -> Just $ appSubst s1 t
+ src/Data/Comp/Ops.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,+             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,+             ScopedTypeVariables, FunctionalDependencies, UndecidableInstances #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Ops+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides operators on functors.+--+--------------------------------------------------------------------------------++module Data.Comp.Ops where++import Data.Foldable+import Data.Traversable++import Control.Applicative+import Control.Monad hiding (sequence, mapM)++import Data.Comp.ExpFunctor++import Prelude hiding (foldl, mapM, sequence, foldl1, foldr1, foldr)+++-- Sums++infixr 6 :+:+++-- |Formal sum of signatures (functors).+data (f :+: g) e = Inl (f e)+                 | Inr (g e)++instance (Functor f, Functor g) => Functor (f :+: g) where+    fmap f (Inl e) = Inl (fmap f e)+    fmap f (Inr e) = Inr (fmap f e)++instance (Foldable f, Foldable g) => Foldable (f :+: g) where+    fold (Inl e) = fold e+    fold (Inr e) = fold e+    foldMap f (Inl e) = foldMap f e+    foldMap f (Inr e) = foldMap f e+    foldr f b (Inl e) = foldr f b e+    foldr f b (Inr e) = foldr f b e+    foldl f b (Inl e) = foldl f b e+    foldl f b (Inr e) = foldl f b e+    foldr1 f (Inl e) = foldr1 f e+    foldr1 f (Inr e) = foldr1 f e+    foldl1 f (Inl e) = foldl1 f e+    foldl1 f (Inr e) = foldl1 f e++instance (Traversable f, Traversable g) => Traversable (f :+: g) where+    traverse f (Inl e) = Inl <$> traverse f e+    traverse f (Inr e) = Inr <$> traverse f e+    sequenceA (Inl e) = Inl <$> sequenceA e+    sequenceA (Inr e) = Inr <$> sequenceA e+    mapM f (Inl e) = Inl `liftM` mapM f e+    mapM f (Inr e) = Inr `liftM` mapM f e+    sequence (Inl e) = Inl `liftM` sequence e+    sequence (Inr e) = Inr `liftM` sequence e++instance (ExpFunctor f, ExpFunctor g) => ExpFunctor (f :+: g) where+    xmap f g (Inl e) = Inl (xmap f g e)+    xmap f g (Inr e) = Inr (xmap f g e)++-- | Signature containment relation for automatic injections. The left-hand must+-- be an atomic signature, where as the right-hand side must have a list-like+-- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@,+-- non-examples include @f :+: g :<: f :+: (g :+: h)@ and+-- @f :<: (f :+: g) :+: h@.+class sub :<: sup where+  inj :: sub a -> sup a+  proj :: sup a -> Maybe (sub a)++instance (:<:) f f where+    inj = id+    proj = Just++instance (:<:) f (f :+: g) where+    inj = Inl+    proj (Inl x) = Just x+    proj (Inr _) = Nothing++instance (f :<: g) => (:<:) f (h :+: g) where+    inj = Inr . inj+    proj (Inr x) = proj x+    proj (Inl _) = Nothing++-- Products++infixr 8 :*:++-- |Formal product of signatures (functors).+data (f :*: g) a = f a :*: g a+++ffst :: (f :*: g) a -> f a+ffst (x :*: _) = x++fsnd :: (f :*: g) a -> g a+fsnd (_ :*: x) = x++-- Constant Products++infixr 7 :&:++{-| This data type adds a constant product to a signature.  -}++data (f :&: a) e = f e :&: a+++instance (Functor f) => Functor (f :&: a) where+    fmap f (v :&: c) = fmap f v :&: c++instance (Foldable f) => Foldable (f :&: a) where+    fold (v :&: _) = fold v+    foldMap f (v :&: _) = foldMap f v+    foldr f e (v :&: _) = foldr f e v+    foldl f e (v :&: _) = foldl f e v+    foldr1 f (v :&: _) = foldr1 f v+    foldl1 f (v :&: _) = foldl1 f v++instance (Traversable f) => Traversable (f :&: a) where+    traverse f (v :&: c) = liftA (:&: c) (traverse f v)+    sequenceA (v :&: c) = liftA (:&: c)(sequenceA v)+    mapM f (v :&: c) = liftM (:&: c) (mapM f v)+    sequence (v :&: c) = liftM (:&: c) (sequence v)++instance (ExpFunctor f) => ExpFunctor (f :&: a) where+    xmap f g (v :&: c) = xmap f g v :&: c++{-| This class defines how to distribute a product over a sum of+signatures. -}++class DistProd s p s' | s' -> s, s' -> p where+    {-| Inject a product value over a signature. -}+    injectP :: p -> s a -> s' a+    {-| Project a product value from a signature. -}+    projectP :: s' a -> (s a, p)+++class RemoveP s s' | s -> s'  where+    {-| Remove products from a signature. -}+    removeP :: s a -> s' a++instance (RemoveP s s') => RemoveP (f :&: p :+: s) (f :+: s') where+    removeP (Inl (v :&: _)) = Inl v+    removeP (Inr v) = Inr $ removeP v+++instance RemoveP (f :&: p) f where+    removeP (v :&: _) = v+++instance DistProd f p (f :&: p) where++    injectP c v = v :&: c++    projectP (v :&: p) = (v,p)+++instance (DistProd s p s') => DistProd (f :+: s) p ((f :&: p) :+: s') where+++    injectP c (Inl v) = Inl (v :&: c)+    injectP c (Inr v) = Inr $ injectP c v++    projectP (Inl (v :&: p)) = (Inl v,p)+    projectP (Inr v) = let (v',p) = projectP v+                       in  (Inr v',p)
+ src/Data/Comp/Ordering.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Ordering+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines ordering of signatures, which lifts to ordering of+-- terms and contexts.+--+--------------------------------------------------------------------------------+module Data.Comp.Ordering+    (+     OrdF(..)+    ) where++import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Equality ()+import Data.Comp.Derive+import Data.Comp.Derive.Utils+++instance (OrdF f, Ord a) => Ord (Cxt h f a) where+    compare = compareF++{-|+  From an 'OrdF' functor an 'Ord' instance of the corresponding+  term type can be derived.+-}+instance (OrdF f) => OrdF (Cxt h f) where+    compareF (Term e1) (Term e2) = compareF e1 e2+    compareF (Hole h1) (Hole h2) = compare h1 h2+    compareF Term{} Hole{} = LT+    compareF Hole{} Term{} = GT++-- instance (OrdF f, Ord p) => OrdF (f :*: p) where+--     compareF (v1 :*: p1) (v2 :*: p2) = +--         case compareF v1 v2 of+--           EQ ->  compare p1 p2+--           res -> res++{-|+  'OrdF' is propagated through sums.+-}++instance (OrdF f, OrdF g) => OrdF (f :+: g) where+    compareF (Inl _) (Inr _) = LT+    compareF (Inr _) (Inl _) = GT+    compareF (Inl x) (Inl y) = compareF x y+    compareF (Inr x) (Inr y) = compareF x y++$(derive [instanceOrdF] $ [''Maybe, ''[]] ++ tupleTypes 2 10)
+ src/Data/Comp/Product.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,+  UndecidableInstances, RankNTypes, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Product+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines products on signatures.+--+--------------------------------------------------------------------------------++module Data.Comp.Product+    ( (:&:) (..),+      (:*:) (..),+      DistProd (..),+      RemoveP (..),+      liftP,+      liftP',+      stripP,+      productTermHom,+      constP,+      project'+    )where++import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Ops+import Data.Comp.Algebra++import Control.Monad++++{-| Transform a function with a domain constructed from a functor to a function+ with a domain constructed with the same functor, but with an additional+ product. -}++liftP :: (RemoveP s s') => (s' a -> t) -> s a -> t+liftP f v = f (removeP v)+++{-| Transform a function with a domain constructed from a functor to a function+  with a domain constructed with the same functor, but with an additional+  product. -}+liftP' :: (DistProd s' p s, Functor s, Functor s')+       => (s' a -> Cxt h s' a) -> s a -> Cxt h s a+liftP' f v = let (v',p) = projectP v+             in constP p (f v')+    +{-| Strip the products from a term over a functor with products. -}+stripP :: (Functor f, RemoveP g f, Functor g) => Cxt h g a -> Cxt h f a+stripP = appSigFun removeP++{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism+ over the same signatures, but extended with products. -}+productTermHom :: (DistProd f p f', DistProd g p g', Functor g, Functor g') +            => TermHom f g -> TermHom f' g'+productTermHom alg f' = constP p (alg f)+    where (f,p) = projectP f'++{-| Annotate each node of a term with a constant value. -}+constP :: (DistProd f p g, Functor f, Functor g) +       => p -> Cxt h f a -> Cxt h g a+constP c = appSigFun (injectP c)++{-| This function is similar to 'project' but applies to signatures+with a product which is then ignored. -}+-- bug in type checker? below is the inferred type, however, the type checker+-- rejects it.+-- project' :: (RemoveP f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))+project' v = liftM removeP $ project v
+ src/Data/Comp/Show.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell, TypeSynonymInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Show+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines showing of signatures, which lifts to showing of+-- terms and contexts.+--+--------------------------------------------------------------------------------++module Data.Comp.Show+    ( ShowF(..)+    ) where++import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Product+import Data.Comp.Algebra+import Data.Comp.Derive++instance (Functor f, ShowF f) => ShowF (Cxt h f) where+    showF (Hole s) = s+    showF (Term t) = showF $ fmap showF t++instance (Functor f, ShowF f, Show a) => Show (Cxt h f a) where+    show = free showF show++instance (ShowF f, Show p) => ShowF (f :&: p) where+    showF (v :&: p) = showF v ++ " :&: " ++ show p++instance (ShowF f, ShowF g) => ShowF (f :+: g) where+    showF (Inl f) = showF f+    showF (Inr g) = showF g++$(derive [instanceShowF] [''Maybe, ''[], ''(,)])
+ src/Data/Comp/Sum.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,+             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,+             ScopedTypeVariables #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Sum+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides the infrastructure to extend signatures.+--+--------------------------------------------------------------------------------++module Data.Comp.Sum+    (+     (:<:)(..),+     (:+:)(..),++     -- * Projections for Signatures and Terms+     proj2,+     proj3,+     project,+     project2,+     project3,+     deepProject,+     deepProject2,+     deepProject3,+     deepProject',+     deepProject2',+     deepProject3',++     -- * Injections for Signatures and Terms+     inj2,+     inj3,+     inject,+     inject2,+     inject3,+     deepInject,+     deepInject2,+     deepInject3,+     deepInjectE,+     deepInjectE2,+     deepInjectE3,++     -- * Injections and Projections for Constants+     injectConst,+     injectConst2,+     injectConst3,+     projectConst,+     injectCxt,+     liftCxt,+     substHoles,+     substHoles'+    ) where++import Data.Comp.Term+import Data.Comp.Algebra+import Data.Comp.Ops+import Data.Comp.ExpFunctor++import Control.Monad hiding (sequence)+import Prelude hiding (sequence)+++import Data.Maybe+import Data.Traversable+import Data.Map (Map)+import qualified Data.Map as Map++{-| A variant of 'proj' for binary sum signatures.  -}+proj2 :: forall f g1 g2 a. (g1 :<: f, g2 :<: f) => f a -> Maybe ((g1 :+: g2) a)+proj2 x = case proj x of+            Just (y :: g1 a) -> Just $ inj y+            _ -> liftM inj (proj x :: Maybe (g2 a))++{-| A variant of 'proj' for ternary sum signatures.  -}+proj3 :: forall f g1 g2 g3 a. (g1 :<: f, g2 :<: f, g3 :<: f) => f a+      -> Maybe ((g1 :+: g2 :+: g3) a)+proj3 x = case proj x of+            Just (y :: g1 a) -> Just $ inj y+            _ -> case proj x of+                   Just (y :: g2 a) -> Just $ inj y+                   _ -> liftM inj (proj x :: Maybe (g3 a))++-- |Project the outermost layer of a term to a sub signature.+project :: (g :<: f) => Cxt h f a -> Maybe (g (Cxt h f a))+project (Hole _) = Nothing+project (Term t) = proj t++-- |Project the outermost layer of a term to a binary sub signature.+project2 :: (g1 :<: f, g2 :<: f) => Cxt h f a -> Maybe ((g1 :+: g2) (Cxt h f a))+project2 (Hole _) = Nothing+project2 (Term t) = proj2 t++-- |Project the outermost layer of a term to a ternary sub signature.+project3 :: (g1 :<: f, g2 :<: f, g3 :<: f) => Cxt h f a+         -> Maybe ((g1 :+: g2 :+: g3) (Cxt h f a))+project3 (Hole _) = Nothing+project3 (Term t) = proj3 t++-- |Project a term to a term over a sub signature.+deepProject :: (Traversable f, Functor g, g :<: f) => Cxt h f a+            -> Maybe (Cxt h g a)+deepProject = appSigFunM proj++-- |Project a term to a term over a binary sub signature.+deepProject2 :: (Traversable f, Functor g1, Functor g2, g1 :<: f, g2 :<: f) => Cxt h f a -> Maybe (Cxt h (g1 :+: g2) a)+deepProject2 = appSigFunM proj2++-- |Project a term to a term over a ternary sub signature.+deepProject3 :: (Traversable f, Functor g1, Functor g2, Functor g3,+                 g1 :<: f, g2 :<: f, g3 :<: f) => Cxt h f a+             -> Maybe (Cxt h (g1 :+: g2 :+: g3) a)+deepProject3 = appSigFunM proj3++-- |A variant of 'deepProject' where the sub signature is required to be+-- 'Traversable' rather than the whole signature.+deepProject' :: forall g f h a. (Traversable g, g :<: f) => Cxt h f a+             -> Maybe (Cxt h g a)+deepProject' val = do+  v <- project val+  v' <- sequence (fmap deepProject' v :: g (Maybe (Cxt h g a)))+  return $ Term v'++-- |A variant of 'deepProject2' where the sub signatures are required to be+-- 'Traversable' rather than the whole signature.+deepProject2' :: forall g1 g2 f h a. (Traversable g1, Traversable g2,+                                      g1 :<: f, g2 :<: f) => Cxt h f a+             -> Maybe (Cxt h (g1 :+: g2) a)+deepProject2' val = do+  v <- project2 val+  v' <- sequence (fmap deepProject2' v :: (g1 :+: g2) (Maybe (Cxt h (g1 :+: g2) a)))+  return $ Term v'++-- |A variant of 'deepProject3' where the sub signatures are required to be+-- 'Traversable' rather than the whole signature.+deepProject3' :: forall g1 g2 g3 f h a. (Traversable g1, Traversable g2,+                                         Traversable g3, g1 :<: f, g2 :<: f,+                                         g3 :<: f) => Cxt h f a+             -> Maybe (Cxt h (g1 :+: g2 :+: g3) a)+deepProject3' val = do+  v <- project3 val+  v' <- sequence (fmap deepProject3' v :: (g1 :+: g2 :+: g3) (Maybe (Cxt h (g1 :+: g2 :+: g3) a)))+  return $ Term v'++{-| A variant of 'inj' for binary sum signatures.  -}+inj2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a -> g a+inj2 (Inl x) = inj x+inj2 (Inr y) = inj y++{-| A variant of 'inj' for ternary sum signatures.  -}+inj3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a -> g a+inj3 (Inl x) = inj x+inj3 (Inr y) = inj2 y++-- |Inject a term where the outermost layer is a sub signature.+inject :: (g :<: f) => g (Cxt h f a) -> Cxt h f a+inject = Term . inj++-- |Inject a term where the outermost layer is a binary sub signature.+inject2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) (Cxt h g a) -> Cxt h g a+inject2 = Term . inj2++-- |Inject a term where the outermost layer is a ternary sub signature.+inject3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) (Cxt h g a) -> Cxt h g a+inject3 = Term . inj3++-- |Inject a term over a sub signature to a term over larger signature.+deepInject  :: (Functor g, Functor f, g :<: f) => Cxt h g a -> Cxt h f a+deepInject = appSigFun inj++-- |Inject a term over a binary sub signature to a term over larger signature.+deepInject2 :: (Functor f1, Functor f2, Functor g, f1 :<: g, f2 :<: g)+            => Cxt h (f1 :+: f2) a -> Cxt h g a+deepInject2 = appSigFun inj2++-- |Inject a term over a ternary signature to a term over larger signature.+deepInject3 :: (Functor f1, Functor f2, Functor f3, Functor g,+                f1 :<: g, f2 :<: g, f3 :<: g)+            => Cxt h (f1 :+: f2 :+: f3) a -> Cxt h g a+deepInject3 =  appSigFun inj3++{-| A variant of 'deepInject' for exponential signatures. -}+deepInjectE :: (ExpFunctor g, g :<: f) => Term g -> Term f+deepInjectE = cataE inject++{-| A variant of 'deepInject2' for exponential signatures. -}+deepInjectE2 :: (ExpFunctor g1, ExpFunctor g2, g1 :<: f, g2 :<: f) =>+                Term (g1 :+: g2)+             -> Term f+deepInjectE2 = cataE inject2++{-| A variant of 'deepInject3' for exponential signatures. -}+deepInjectE3 :: (ExpFunctor g1, ExpFunctor g2, ExpFunctor g3,+                 g1 :<: f, g2 :<: f, g3 :<: f) =>+                Term (g1 :+: g2 :+: g3)+             -> Term f+deepInjectE3 = cataE inject3++injectConst :: (Functor g, g :<: f) => Const g -> Cxt h f a+injectConst = inject . fmap (const undefined)++injectConst2 :: (Functor f1, Functor f2, Functor g, f1 :<: g, f2 :<: g)+             => Const (f1 :+: f2) -> Cxt h g a+injectConst2 = inject2 . fmap (const undefined)++injectConst3 :: (Functor f1, Functor f2, Functor f3, Functor g, f1 :<: g, f2 :<: g, f3 :<: g)+             => Const (f1 :+: f2 :+: f3) -> Cxt h g a+injectConst3 = inject3 . fmap (const undefined)++projectConst :: (Functor g, g :<: f) => Cxt h f a -> Maybe (Const g)+projectConst = fmap (fmap (const ())) . project++{-| This function injects a whole context into another context. -}++injectCxt :: (Functor g, g :<: f) => Cxt h' g (Cxt h f a) -> Cxt h f a+injectCxt = cata' inject++{-| This function lifts the given functor to a context. -}+liftCxt :: (Functor f, g :<: f) => g a -> Context f a+liftCxt g = simpCxt $ inj g++{-| This function applies the given context with hole type @a@ to a+family @f@ of contexts (possibly terms) indexed by @a@. That is, each+hole @h@ is replaced by the context @f h@. -}++substHoles :: (Functor f, Functor g, f :<: g) => Cxt h' f v -> (v -> Cxt h g a) -> Cxt h g a+substHoles c f = injectCxt $ fmap f c++substHoles' :: (Functor f, Functor g, f :<: g, Ord v) => Cxt h' f v -> Map v (Cxt h g a) -> Cxt h g a+substHoles' c m = substHoles c (fromJust . (`Map.lookup`  m))++instance (Functor f) => Monad (Context f) where+    return = Hole+    (>>=) = substHoles+++instance (Show (f a), Show (g a)) => Show ((f :+: g) a) where+    show (Inl v) = show v+    show (Inr v) = show v+++instance (Ord (f a), Ord (g a)) => Ord ((f :+: g) a) where+    compare (Inl _) (Inr _) = LT+    compare (Inr _) (Inl _) = GT+    compare (Inl x) (Inl y) = compare x y+    compare (Inr x) (Inr y) = compare x y+++instance (Eq (f a), Eq (g a)) => Eq ((f :+: g) a) where+    (Inl x) == (Inl y) = x == y+    (Inr x) == (Inr y) = x == y                   +    _ == _ = False
+ src/Data/Comp/Term.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Term+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines the central notion of /terms/ and its+-- generalisation to contexts.+--+--------------------------------------------------------------------------------++module Data.Comp.Term+    (Cxt (..),+     Hole,+     NoHole,+     Context,+     Nothing,+     Term,+     PTerm,+     Const,+     unTerm,+     simpCxt,+     toCxt,+     constTerm+     ) where++import Control.Applicative hiding (Const)+import Control.Monad hiding (mapM, sequence)++import Data.Traversable+import Data.Foldable++import Unsafe.Coerce++import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)+++{-|  -}+type Const f = f ()++{-| This function converts a constant to a term. This assumes that the+argument is indeed a constant, i.e. does not have a value for the+argument type of the functor @f@. -}++constTerm :: (Functor f) => Const f -> Term f+constTerm = Term . fmap (const undefined)++{-| This data type represents contexts over a signature. Contexts are+terms containing zero or more holes. The first type parameter is+supposed to be one of the phantom types 'Hole' and 'NoHole'. The+second parameter is the signature of the context. The third parameter+is the type of the holes. -}++data Cxt :: * -> (* -> *) -> * -> * where+            Term :: f (Cxt h f a) -> Cxt h f a+            Hole :: a -> Cxt Hole f a+++{-| Phantom type that signals that a 'Cxt' might contain holes.  -}++data Hole++{-| Phantom type that signals that a 'Cxt' does not contain holes.+-}++data NoHole++type Context = Cxt Hole++{-| Convert a functorial value into a context.  -}+simpCxt :: (Functor f) => f a -> Context f a+{-# INLINE simpCxt #-}+simpCxt = Term . fmap Hole+++{-| Cast a term over a signature to a context over the same signature. -}+toCxt :: Term f -> Cxt h f a+{-# INLINE toCxt #-}+toCxt = unsafeCoerce++{-| Phantom type used to define 'Term'.  -}++data Nothing++instance Eq Nothing where+instance Ord Nothing where+instance Show Nothing where++++{-| A term is a context with no holes.  -}++type Term f = Cxt NoHole f Nothing++-- | Polymorphic definition of a term. This formulation is more+-- natural than 'Term', it leads to impredicative types in some cases,+-- though.+type PTerm f = forall h a . Cxt h f a++instance Functor f => Functor (Cxt h f) where+    fmap f (Hole v) = Hole (f v)+    fmap f (Term t) = Term (fmap (fmap f) t)++instance (Foldable f) => Foldable (Cxt h f) where+    foldr op e (Hole a) = a `op` e+    foldr op e (Term t) = foldr op' e t+        where op' c a = foldr op a c++    foldl op e (Hole a) = e `op` a+    foldl op e (Term t) = foldl op' e t+        where op' = foldl op++    fold (Hole a) = a+    fold (Term t) = foldMap fold t++    foldMap f (Hole a) = f a+    foldMap f (Term t) = foldMap (foldMap f) t++instance (Traversable f) => Traversable (Cxt h f) where+    traverse f (Hole a) = Hole <$> f a+    traverse f (Term t) = Term <$> traverse (traverse f) t+                          +    sequenceA (Hole a) = Hole <$> a+    sequenceA (Term t) = Term <$> traverse sequenceA t++    mapM f (Hole a) = liftM Hole $ f a+    mapM f (Term t) = liftM Term $ mapM (mapM f) t++    sequence (Hole a) = liftM Hole a+    sequence (Term t) = liftM Term $ mapM sequence t++++{-| This function unravels the given term at the topmost layer.  -}++unTerm :: Cxt NoHole f a -> f (Cxt NoHole f a)+{-# INLINE unTerm #-}+unTerm (Term t) = t
+ src/Data/Comp/TermRewriting.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE RankNTypes, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.TermRewriting+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines term rewriting systems (TRSs) using compositional data+-- types.+--+--------------------------------------------------------------------------------++module Data.Comp.TermRewriting where++import Prelude hiding (any)++import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Algebra+import Data.Comp.Equality+import Data.Comp.Matching+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe+import Data.Foldable++import Control.Monad+++{-| This type represents /recursive program schemes/.  -}++type RPS f g  = TermHom f g++type Var = Int++{-| This type represents term rewrite rules from signature @f@ to+signature @g@ over variables of type @v@ -}++type Rule f g v = (Context f v, Context g v)+++{-| This type represents term rewriting systems (TRSs) from signature+@f@ to signature @g@ over variables of type @v@. -}++type TRS f g v = [Rule f g v]++type Step t = t -> Maybe t+type BStep t = t -> (t,Bool)++{-| This function tries to match the given rule against the given term+(resp. context in general) at the root. If successful, the function+returns the right hand side of the rule and the matching+substitution. -}++matchRule ::  (Ord v, EqF f, Eq a, Functor f, Foldable f)+          => Rule f g v -> Cxt h f a -> Maybe (Context g v, Map v (Cxt h f a))+matchRule (lhs,rhs) t = do+  subst <- matchCxt lhs t+  return (rhs,subst)++matchRules :: (Ord v, EqF f, Eq a, Functor f, Foldable f)+           => TRS f g v -> Cxt h f a -> Maybe (Context g v, Map v (Cxt h f a))+matchRules trs t = listToMaybe $ mapMaybe (`matchRule` t) trs++{-| This function tries to apply the given rule at the root of the+given term (resp. context in general). If successful, the function+returns the result term of the rewrite step; otherwise @Nothing@. -}++appRule :: (Ord v, EqF f, Eq a, Functor f, Foldable f)+          => Rule f f v -> Step (Cxt h f a)+appRule rule t = do +  (res, subst) <- matchRule rule t+  return $ substHoles' res subst++{-| This function tries to apply one of the rules in the given TRS at+the root of the given term (resp. context in general) by trying each+rule one by one using 'appRule' until one rule is applicable. If no+rule is applicable @Nothing@ is returned. -}++appTRS :: (Ord v, EqF f, Eq a, Functor f, Foldable f)+         => TRS f f v -> Step (Cxt h f a)+appTRS trs t = listToMaybe $ mapMaybe (`appRule` t) trs+++{-| This is an auxiliary function that turns function @f@ of type+  @(t -> Maybe t)@ into functions @f'@ of type @t -> (t,Bool)@. @f' x@+  evaluates to @(y,True)@ if @f x@ evaluates to @Just y@, and to+  @(x,False)@ if @f x@ evaluates to @Nothing@. This function is useful+  to change the output of functions that apply rules such as 'appTRS'. -}++bStep :: Step t -> BStep t+bStep f t = case f t of+                Nothing -> (t, False)+                Just t' -> (t',True)++{-| This function performs a parallel reduction step by trying to+apply rules of the given system to all outermost redexes. If the given+term contains no redexes, @Nothing@ is returned. -}++parTopStep :: (Ord v, EqF f, Eq a, Foldable f, Functor f)+           => TRS f f v -> Step (Cxt h f a)+parTopStep _ Hole{} = Nothing+parTopStep trs c@(Term t) = tTop `mplus` tBelow'+    where tTop = appTRS trs c+          tBelow = fmap (bStep $ parTopStep trs) t+          tAny = any snd tBelow+          tBelow'+              | tAny = Just $ Term $ fmap fst tBelow+              | otherwise = Nothing++{-| This function performs a parallel reduction step by trying to+apply rules of the given system to all outermost redexes and then+recursively in the variable positions of the redexes. If the given+term does not contain any redexes, @Nothing@ is returned. -}++parallelStep :: (Ord v, EqF f, Eq a,Foldable f, Functor  f)+             => TRS f f v -> Step (Cxt h f a)+parallelStep _ Hole{} = Nothing+parallelStep trs c@(Term t) =+    case matchRules trs c of+      Nothing +          | anyBelow -> Just $ Term $ fmap fst below+          | otherwise -> Nothing+        where below = fmap (bStep $ parallelStep trs) t +              anyBelow = any snd below+      Just (rhs,subst) -> Just $ substHoles' rhs substBelow+          where rhsVars = Set.fromList $ toList rhs+                substBelow = Map.mapMaybeWithKey apply subst+                apply v t+                    | Set.member v rhsVars = Just $ fst $ bStep (parallelStep trs) t+                    | otherwise = Nothing+                ++{-| This function applies the given reduction step repeatedly until a+normal form is reached. -}++reduce :: Step t -> t -> t+reduce s t = case s t of+               Nothing -> t+               Just t' -> reduce s t'
+ src/Data/Comp/Unification.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE FlexibleContexts #-}+-------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Unification+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module implements a simple unification algorithm using compositional+-- data types.+--+--------------------------------------------------------------------------------+module Data.Comp.Unification where++import Data.Comp.Term+import Data.Comp.Variables+import Data.Comp.Decompose++import Control.Monad.Error+import Control.Monad.State++import qualified Data.Map as Map++{-| This type represents equations between terms over a specific+signature. -}++type Equation f = (Term f,Term f)++{-| This type represents list of equations. -}++type Equations f = [Equation f]++{-| This type represents errors that might occur during the+unification.  -}++data UnifError f v = FailedOccursCheck v (Term f)+                   | HeadSymbolMismatch (Term f) (Term f)+                   | UnifError String++instance Error (UnifError f v) where+    strMsg = UnifError+++failedOccursCheck :: (MonadError (UnifError f v) m) => v -> Term f -> m a+failedOccursCheck v t = throwError $ FailedOccursCheck v t++headSymbolMismatch :: (MonadError (UnifError f v) m) => Term f -> Term f -> m a+headSymbolMismatch f g = throwError $ HeadSymbolMismatch f g++appSubstEq :: (Ord v,  HasVars f v, Functor f) =>+     Subst f v -> Equation f -> Equation f+appSubstEq s (t1,t2) = (appSubst s t1,appSubst s t2)+++{-| This function returns the most general unifier of the given+equations using the algorithm of Martelli and Montanari. -}++unify :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f))+      => Equations f -> m (Subst f v)+unify = runUnifyM runUnify++data UnifyState f v = UnifyState {usEqs ::Equations f, usSubst :: Subst f v}+type UnifyM f v m a = StateT (UnifyState f v) m a++runUnifyM :: MonadError (UnifError f v) m+          => UnifyM f v m a -> Equations f -> m (Subst f v)+runUnifyM m eqs = liftM (usSubst . snd) $+                           runStateT m UnifyState { usEqs = eqs, usSubst = Map.empty}++withNextEq :: Monad m+           => (Equation f -> UnifyM f v m ()) -> UnifyM f v m ()+withNextEq m = do eqs <- gets usEqs+                  case eqs of +                    [] -> return ()+                    x : xs -> modify (\s -> s {usEqs = xs})+                           >> m x++putEqs :: Monad m +       => Equations f -> UnifyM f v m ()+putEqs eqs = modify addEqs+    where addEqs s = s {usEqs = eqs ++ usEqs s}++putBinding :: (Monad m, Ord v, HasVars f v, Functor f) => (v, Term f) -> UnifyM f v m ()+putBinding bind = modify appSubst+    where binds = Map.fromList [bind]+          appSubst s = s { usEqs = map (appSubstEq binds) (usEqs s),+                             usSubst = compSubst binds (usSubst s)}+++runUnify :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f))+         => UnifyM f v m ()+runUnify = withNextEq (\ e -> unifyStep e >> runUnify)++unifyStep :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f)) +          => Equation f -> UnifyM f v m ()+unifyStep (s,t) = case decompose s of+                    Var v1 -> case decompose t of+                                 Var v2 -> unless (v1 == v2) $+                                             putBinding (v1, t)+                                 _ -> if containsVar v1 t+                                      then failedOccursCheck v1 t+                                      else putBinding (v1,t)+                    Fun s1 args1 -> case decompose t of+                                       Var v -> if containsVar v s+                                                 then failedOccursCheck v s+                                                 else putBinding (v,s)+                                       Fun s2 args2 -> if s1 == s2+                                                        then putEqs $ zip args1 args2+                                                        else headSymbolMismatch s t
+ src/Data/Comp/Variables.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,+  OverlappingInstances, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Variables+-- Copyright   :  (c) 2010-2011 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module defines an abstraction notion of a variable in compositional+-- data type.+--+--------------------------------------------------------------------------------+module Data.Comp.Variables (+  HasVars(..),+  Subst,+  CxtSubst,+  varsToHoles,+  containsVar,+  variables,+  variableList,+  variables',+  substVars,+  appSubst,+  compSubst) where++import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Algebra+import Data.Foldable++import Data.Maybe++import Data.Set (Set)+import qualified Data.Set as Set++import Data.Map (Map)+import qualified Data.Map as Map++import Prelude hiding (or, foldl)++type CxtSubst h a f v = Map v (Cxt h f a)++type Subst f v = CxtSubst NoHole Nothing f v++{-| This multiparameter class defines functors with variables. An+instance @HasVar f v@ denotes that values over @f@ might contain+variables of type @v@. -}++class HasVars f v where+    isVar :: f a -> Maybe v+    isVar _ = Nothing++instance (HasVars f v, HasVars g v) => HasVars (f :+: g) v where+    isVar (Inl v) = isVar v+    isVar (Inr v) = isVar v++instance HasVars f v => HasVars (Cxt h f) v where+    isVar (Term t) = isVar t+    isVar _ = Nothing++varsToHoles :: (Functor f, HasVars f v) => Term f -> Context f v+varsToHoles = cata alg+    where alg t = case isVar t of +                    Just v -> Hole v+                    Nothing -> Term t++containsVarAlg :: (Eq v, HasVars f v, Foldable f) => v -> Alg f Bool+containsVarAlg v t = local || or t +    where local = case isVar t of+                    Just v' -> v == v'+                    Nothing -> False++{-| This function checks whether a variable is contained in a+context. -}++containsVar :: (Eq v, HasVars f v, Foldable f, Functor f)+            => v -> Cxt h f a -> Bool+containsVar v = free (containsVarAlg v) (const False)++variablesAlg :: (Ord v, HasVars f v, Foldable f)+            => Alg f (Set v)+variablesAlg t = foldl Set.union local t+    where local = case isVar t of+                    Just v -> Set.singleton v+                    Nothing -> Set.empty++variableListAlg :: (Ord v, HasVars f v, Foldable f)+            => Alg f [v]+variableListAlg t = foldl (++) local t+    where local = case isVar t of+                    Just v -> [v]+                    Nothing -> [] ++{-| This function computes the list of variables occurring in a+context. -}++variableList :: (Ord v, HasVars f v, Foldable f, Functor f)+            => Cxt h f a -> [v]+variableList = free variableListAlg (const [])++{-| This function computes the set of variables occurring in a+context. -}++variables :: (Ord v, HasVars f v, Foldable f, Functor f)+            => Cxt h f a -> Set v+variables = free variablesAlg (const Set.empty)++{-| This function computes the set of variables occurring in a+context. -}++variables' :: (Ord v, HasVars f v, Foldable f, Functor f)+            => Const f -> Set v+variables' c =  case isVar c of+                  Nothing -> Set.empty+                  Just v -> Set.singleton v+++substAlg :: (HasVars f v) => (v -> Maybe (Cxt h f a)) -> Alg f (Cxt h f a)+substAlg f t = fromMaybe (Term t) (isVar t >>= f)++{-| This function substitutes variables in a context according to a+partial mapping from variables to contexts.-}++++class SubstVars v t a where+    substVars :: (v -> Maybe t) -> a -> a+++appSubst :: (Ord v, SubstVars v t a) => Map v t -> a -> a+appSubst subst = substVars f+    where f v = Map.lookup v subst++instance (Ord v, HasVars f v, Functor f) => SubstVars v (Cxt h f a) (Cxt h f a) where+    substVars f (Term v) = substAlg f $ fmap (substVars f) v+    substVars _ (Hole a) = Hole a+-- have to use explicit GADT pattern matching!!+-- subst f = free (substAlg f) Hole++instance (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,+applying the resulting substitution is equivalent to first applying+@s2@ and then @s1@. -}++compSubst :: (Ord v, HasVars f v, Functor f)+          => CxtSubst h a f v -> CxtSubst h a f v -> CxtSubst h a f v+compSubst s1 s2 = fmap (appSubst s1) s2 `Map.union` s1
+ testsuite/tests/Data/Comp/Equality_Test.hs view
@@ -0,0 +1,37 @@+module Data.Comp.Equality_Test where+++import Data.Comp+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++++++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++main = defaultMain [tests]++tests = testGroup "Equality" [+         testProperty "prop_eqMod_fmap" prop_eqMod_fmap+        ]+++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++prop_eqMod_fmap cxt f = case eqMod cxt cxt' of+                   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)
+ testsuite/tests/Data/Comp_Test.hs view
@@ -0,0 +1,30 @@+module Data.Comp_Test where+++import Data.Comp+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++import qualified Data.Comp.Equality_Test+++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++main = defaultMain [tests]++tests = testGroup "Comp" [+         Data.Comp.Equality_Test.tests+        ]++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------+
+ testsuite/tests/Data_Test.hs view
@@ -0,0 +1,18 @@+module Main where++import Test.Framework+import qualified Data.Comp_Test++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++main = defaultMain [tests]++tests = testGroup "Data" [+         Data.Comp_Test.tests+       ]++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------
+ testsuite/tests/Test/Utils.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleContexts, FlexibleInstances #-}++module Test.Utils where++import Data.Comp+import Data.Comp.Derive++import Data.Foldable+++data Tree l e = Leaf l+              | UnNode l e+              | BinNode e l e+              | TerNode l e e e++data Pair a e = Pair a e++$(derive+  [instanceFunctor, instanceFoldable, instanceShowF, instanceEqF, instanceArbitraryF]+  [''Tree, ''Pair])++$(derive+  [smartConstructors]+  [''Tree, ''Pair, ''Maybe])+++type Sig1 = Maybe :+: Tree Int+type Sig2 = [] :+: Pair Int+type Sig = Maybe :+: Tree Int :+: [] :+: Pair Int+++type SigP = Maybe :&: Int :+: Tree Int :&: Int :+: [] :&: Int :+: Pair Int :&: Int++instance EqF f => EqF (f :&: Int) where+    eqF (x :&: i) (y :&: j) = x `eqF` y && i == j++instance Show (a -> b) where+    show _ = "<function>"