catamorphism 0.4.0.1 → 0.5.0.0

raw patch · 2 files changed

+39/−24 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• catamorphism.cabal +1/−1
• src/Data/Morphism/Cata.hs +38/−23

@@ -1,5 +1,5 @@ name:                catamorphism-version:             0.4.0.1+version:             0.5.0.0 synopsis:            A package exposing a helper function for generating catamorphisms. description:         A package exposing a helper function for generating catamorphisms. homepage:            http://github.com/frerich/catamorphism

@@ -12,9 +12,9 @@ in-depth discussion of catamorphisms in Haskell.  The Haskell base package already comes with a couple of standard catamorphisms-such as 'bool' (for Bool values), 'maybe' (for Maybe values) values, 'either' for (Either values)-values and foldr (for lists). These catamorphisms could have been generated using-'makeCata' as follows:+such as 'bool' (for Bool values), 'maybe' (for Maybe values) values, 'either'+for (Either values) values and 'foldr' (for lists). These catamorphisms could+have been generated using 'makeCata' as follows:  > -- Defines 'bool :: a -> a -> Bool -> a' > $(makeCata defaultOptions ''Bool)@@ -30,15 +30,14 @@ of numbers, supporting variables:  > {-# LANGUAGE TemplateHaskell #-}-> +> > import Data.Morphism.Cata > import Data.Maybe (fromJust)-> import Data.Function (on)-> +> > data Expr a = Number a >             | Variable Char >             | Sum (Expr a) (Expr a)-> +> > $(makeCata defaultOptions { cataName = "cataExpr" } ''Expr)  The 'makeCata' invocation defines a 'cataExpr' function which works like a fold on@@ -46,15 +45,15 @@  > -- Evaluate an Expr, given some variable bindings > eval :: Num a => [(Char, a)] -> Expr a -> a-> eval vars = cataExpr id (fromJust . (`lookup` vars)) ((+) `on` eval vars)-> +> eval vars = cataExpr id (fromJust . (`lookup` vars)) (+)+> > -- Pretty-prints an Expr > pprint :: Show a => Expr a -> String-> pprint = cataExpr show show (\a b -> pprint a ++ " + " ++ pprint b)-> +> pprint = cataExpr show show (\a b -> a ++ " + " ++ b)+> > -- Counts the number of variables used in an expr > numVars :: Expr a -> Int-> numVars = cataExpr (const 1) (const 0) ((+) `on` numVars)+> numVars = cataExpr (const 1) (const 0) (+) -}  module Data.Morphism.Cata@@ -111,15 +110,26 @@ conName (InfixC _ n _)  = n conName (ForallC _ _ c) = conName c -conType :: Name -> Con -> Type-conType resultT c = foldr makeFuncT (VarT resultT) (conArgTypes c)+typeName :: Type -> Maybe Name+typeName (AppT t _) = typeName t+typeName (ConT n)   = Just n+typeName _          = Nothing +conType :: Name -> Name -> Con -> Type+conType inputT resultT c = foldr makeFuncT (VarT resultT) argTypes+  where+    argTypes = map fixupArgType (conArgTypes c)++    fixupArgType t = case typeName t of+                        Just n  -> if n == inputT then VarT resultT else t+                        Nothing -> t+ -- |The 'makeCata' function creates a catamorphism for the given type. makeCata :: CataOptions     -- Options to customize the catamorphism; the name of the defined function can be changed          -> Name            -- The type to generate a catamorphism for.          -> Q [Dec]-makeCata opts typeName = do-    typeInfo <- reify typeName+makeCata opts ty = do+    typeInfo <- reify ty     (tyVarBndrs, cons) <- case typeInfo of             TyConI (DataD _ _ tyVarBndrs cons _)   -> return (tyVarBndrs, cons)             TyConI (NewtypeD _ _ tyVarBndrs con _) -> return (tyVarBndrs, [con])@@ -129,9 +139,9 @@     signature :: [TyVarBndr] -> [Con] -> Q Dec     signature tyVarBndrs cons = do         let tyVarNames = map tyVarName tyVarBndrs-        let typeConType = foldl AppT (ConT typeName) (map VarT tyVarNames)+        let typeConType = foldl AppT (ConT ty) (map VarT tyVarNames)         resultTypeName <- newName "a"-        let args = map (conType resultTypeName) cons ++ [typeConType, VarT resultTypeName]+        let args = map (conType ty resultTypeName) cons ++ [typeConType, VarT resultTypeName]         return (SigD funName (ForallT (PlainTV resultTypeName : tyVarBndrs) [] (foldr1 makeFuncT args)))      funDef :: [Con] -> Q Dec@@ -140,21 +150,26 @@     funName :: Name     funName = mkName $         if null (cataName opts)-            then let (x:xs) = nameBase typeName in toLower x : xs+            then let (x:xs) = nameBase ty in toLower x : xs             else cataName opts      funImpl :: [Con] -> Q Clause     funImpl cons = do-        conArgs <- replicateM (length cons) (VarP <$> newName "c")+        conArgNames <- replicateM (length cons) (newName "c")          valueArgName <- newName "x"-        let funArgs = conArgs ++ [VarP valueArgName]+        let funArgs = map VarP (conArgNames ++ [valueArgName]) -        matches <- forM (zip cons conArgs) $ \(c, VarP cn) -> do+        matches <- forM (zip cons conArgNames) $ \(c, cn) -> do             pat@(ConP _ conPats) <- conToConP c             let patNames = map (\(VarP n) -> n) conPats -            let bodyE = foldl1 AppE . map VarE $ (cn : patNames)+            let translateArg t arg = case typeName t of+                    Just n -> if n == ty then foldl AppE (VarE funName) (map VarE (conArgNames ++ [arg])) else VarE arg+                    Nothing -> VarE arg++            let argsWithTypes = zipWith translateArg (conArgTypes c) patNames+            let bodyE = foldl AppE (VarE cn) argsWithTypes             return (Match pat (NormalB bodyE) [])          let bodyE = CaseE (VarE valueArgName) matches