genifunctors (empty) → 0.1.0.0
raw patch · 4 files changed
+318/−0 lines, 4 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, template-haskell
Files
- Data/Generics/Genifunctors.hs +266/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- genifunctors.cabal +20/−0
+ Data/Generics/Genifunctors.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE TemplateHaskell,PatternGuards,RecordWildCards #-}+-- | Generate (derive) generalized 'fmap', 'foldMap' and 'traverse' for Bifunctors, Trifunctors, or a functor with any arity+--+-- Example:+--+-- @+--data U a b c d+-- = L [U a b c d] -- polymorphic recursion+-- | M (V (a,b) (Either c d)) -- mutually recursive+-- | a :+: Int -- infix syntax, record syntax, type synonyms+-- | R { c :: c, d :: String } -- and primitive data types supported+--+--data V u v = X (U v v u u) | Z u+--+--fmapU :: (a -> a') -> (b -> b') -> (c -> c') -> (d -> d') -> U a b c d -> U a' b' c' d'+--fmapU = $(genFmap ''U)+--+--foldU :: Monoid m => (a -> m) -> (b -> m) -> (c -> m) -> (d -> m) -> U a b c d -> m+--foldU = $(genFoldMap ''U)+--+--travU :: Applicative f => (a -> f a') -> (b -> f b') -> (c -> f c') -> (d -> f d') -> U a b c d -> f (U a' b' c' d')+--travU = $(genTraverse ''U)+-- @+module Data.Generics.Genifunctors (genFmap, genFoldMap, genTraverse) where++import Language.Haskell.TH+import Control.Applicative+import Control.Monad+import Control.Monad.RWS+import Data.Map (Map)+import qualified Data.Map as M++import Control.Exception(assert)+import Data.Maybe++type GenM = RWST Generator [Dec] (Map Name Name) Q++data Generator = Generator+ { gen_combine :: Name -> [Exp] -> Exp+ , gen_primitive :: Exp -> Exp+ , gen_type :: Name -> [Name] -> Q Type+ }++gen :: Generator -> Name -> Q Exp+gen generator tc = do+ (fn,decls) <- evalRWST (generate tc) generator M.empty+ return $ LetE decls (VarE fn)+++-- | Generate generalized 'fmap' for a type+--+-- @+--bimapTuple :: (a -> a') -> (b -> b') -> (a,b) -> (a',b')+--bimapTuple = $(genFmap ''(,))+-- @+genFmap :: Name -> Q Exp+genFmap = gen Generator+ { gen_combine = fmapCombine+ , gen_primitive = fmapPrimitive+ , gen_type = fmapType+ }++-- | Generate generalized 'foldMap' for a type+--+-- @+--foldMapEither :: Monoid m => (a -> m) -> (b -> m) -> Either a b -> m+--foldMapEither = $(genFoldMap ''Either)+-- @+genFoldMap :: Name -> Q Exp+genFoldMap = gen Generator+ { gen_combine = foldMapCombine+ , gen_primitive = foldMapPrimitive+ , gen_type = foldMapType+ }++-- | Generate generalized 'traversable' for a type+--+-- @+--travTriple :: Applicative f => (a -> f a') -> (b -> f b') -> (c -> f c') -> (a,b,c) -> f (a',b',c')+--travTriple = $(genTraverse ''(,,))+-- @+genTraverse :: Name -> Q Exp+genTraverse = gen Generator+ { gen_combine = traverseCombine+ , gen_primitive = traversePrimitive+ , gen_type = traverseType ''Applicative+ }++fmapCombine :: Name -> [Exp] -> Exp+fmapCombine con_name args = foldl AppE (ConE con_name) args++foldMapCombine :: Name -> [Exp] -> Exp+foldMapCombine _con_name [] = VarE 'mempty+foldMapCombine _con_name (a:as) = foldr (<<>>) a as++traverseCombine :: Name -> [Exp] -> Exp+traverseCombine con_name [] = VarE 'pure `AppE` ConE con_name+traverseCombine con_name (a:as) = foldl (<***>) (ConE con_name <$$> a) as++mkInfix :: Name -> Exp -> Exp -> Exp+mkInfix n e1 e2 = InfixE (Just e1) (VarE n) (Just e2)++(<***>) :: Exp -> Exp -> Exp+(<***>) = mkInfix '(<*>)++(<$$>) :: Exp -> Exp -> Exp+(<$$>) = mkInfix '(<$>)++(<<>>) :: Exp -> Exp -> Exp+(<<>>) = mkInfix 'mappend++fmapPrimitive :: Exp -> Exp+fmapPrimitive = id++foldMapPrimitive :: Exp -> Exp+foldMapPrimitive = const (VarE 'mempty)++traversePrimitive :: Exp -> Exp+traversePrimitive e = VarE 'pure `AppE` e++fmapType :: Name -> [Name] -> Q Type+fmapType tc tvs = do+ from <- mapM (newName . nameBase) tvs+ to <- mapM (newName . nameBase) tvs+ return $ ForallT (map PlainTV (from ++ to)) []+ $ foldr arr+ (applyTyVars tc from `arr` applyTyVars tc to)+ (zipWith arr (map VarT from) (map VarT to))++foldMapType :: Name -> [Name] -> Q Type+foldMapType tc tvs = do+ m <- newName "m"+ from <- mapM (newName . nameBase) tvs+ return $ ForallT (map PlainTV (m : from)) [ClassP ''Monoid [VarT m]]+ $ foldr arr+ (applyTyVars tc from `arr` VarT m)+ (zipWith arr (map VarT from) (repeat (VarT m)))++traverseType :: Name -> Name -> [Name] -> Q Type+traverseType constraint_class tc tvs = do+ f <- newName "f"+ from <- mapM (newName . nameBase) tvs+ to <- mapM (newName . nameBase) tvs+ return $ ForallT (map PlainTV (f : from ++ to)) [ClassP constraint_class [VarT f]]+ $ foldr arr+ (applyTyVars tc from `arr` (VarT f `AppT` applyTyVars tc to))+ (zipWith arr (map VarT from) (map (\ t -> VarT f `AppT` VarT t) to))++genMatch :: Type -> [(Name,Name)] -> GenM Exp+genMatch t tvfs = case t of+ VarT a | Just f <- lookup a tvfs -> return (VarE f)+ AppT t1 t2 -> AppE <$> genMatch t1 tvfs <*> genMatch t2 tvfs+ ConT tc -> VarE <$> generate tc+ TupleT i -> VarE <$> generate (tupleTypeName i)+ ListT -> VarE <$> generate ''[]+ _ -> error $ "genMatch:" ++ show t++simpCon :: Con -> (Name,[Type])+simpCon con = case con of+ NormalC n ts -> (n,map snd ts)+ RecC n vts -> (n,map (\ (_,_,t) -> t) vts)+ InfixC t1 n t2 -> (n,[snd t1,snd t2])+ ForallC{} -> error "simpCon: ForallC"+++generate :: Name -> GenM Name+generate tc = do+ m_fn <- gets (M.lookup tc)+ case m_fn of+ Just fn -> return fn+ Nothing -> do++ Generator{..} <- ask++ fn <- q $ newName ("_" ++ nameBase tc)+ modify (M.insert tc fn)+ (tvs,cons) <- getTyConInfo tc+ fs <- zipWithM (const . q . newName) (repeat "_f") tvs+ x <- q $ newName "_x"++ body <- if null cons || null tvs+ then return $ gen_primitive (VarE x) -- primitive data types/non polymorphic+ else do+ matches <- forM (map simpCon cons) $ \ (con_name,ts) -> do++ ys <- zipWithM (const . q . newName) (repeat "_y") ts++ lhs <- gen_combine con_name <$> sequence+ [ do t' <- q (expandSyn t)+ le <- genMatch t' (zip tvs fs)+ return (le `AppE` VarE y)+ | (y,t) <- zip ys ts ]++ return $ Match (ConP con_name (map VarP ys)) (NormalB lhs) []++ return (CaseE (VarE x) matches)++ ty <- q $ gen_type tc tvs++ tell+ [ SigD fn ty+ , FunD fn [ Clause (map VarP (fs ++ [x])) (NormalB $ body) [] ]+ ]+ return fn++arr :: Type -> Type -> Type+arr t1 t2 = (ArrowT `AppT` t1) `AppT` t2++applyTyVars :: Name -> [Name] -> Type+applyTyVars tc ns = foldl AppT (ConT tc) (map VarT ns)++q :: Q a -> GenM a+q = lift++-- All the following functions are by Lennart in Geniplate++getTyConInfo :: Name -> GenM ([Name], [Con])+getTyConInfo con = do+ info <- q (reify con)+ case info of+ TyConI (DataD _ _ tvs cs _) -> return (map unPlainTv tvs, cs)+ TyConI (NewtypeD _ _ tvs c _) -> return (map unPlainTv tvs, [c])+ PrimTyConI{} -> return ([], [])+ i -> error $ "unexpected TyCon: " ++ show i+ where+ unPlainTv (PlainTV tv) = tv+ unPlainTv i = error $ "unexpected non-plain TV" ++ show i++expandSyn :: Type -> Q Type+expandSyn (ForallT tvs ctx t) = liftM (ForallT tvs ctx) $ expandSyn t+expandSyn t@AppT{} = expandSynApp t []+expandSyn t@ConT{} = expandSynApp t []+expandSyn (SigT t _) = expandSyn t -- Ignore kind synonyms+expandSyn t = return t++expandSynApp :: Type -> [Type] -> Q Type+expandSynApp (AppT t1 t2) ts = do t2' <- expandSyn t2; expandSynApp t1 (t2':ts)+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl AppT ListT ts+expandSynApp t@(ConT n) ts = do+ info <- reify n+ case info of+ TyConI (TySynD _ tvs rhs) ->+ let (ts', ts'') = splitAt (length tvs) ts+ s = mkSubst tvs ts'+ rhs' = subst s rhs+ in expandSynApp rhs' ts''+ _ -> return $ foldl AppT t ts+expandSynApp t ts = do t' <- expandSyn t; return $ foldl AppT t' ts+++type Subst = [(Name, Type)]++mkSubst :: [TyVarBndr] -> [Type] -> Subst+mkSubst vs ts =+ let vs' = map un vs+ un (PlainTV v) = v+ un (KindedTV v _) = v+ in assert (length vs' == length ts) $ zip vs' ts++subst :: Subst -> Type -> Type+subst s (ForallT v c t) = ForallT v c $ subst s t+subst s t@(VarT n) = fromMaybe t $ lookup n s+subst s (AppT t1 t2) = AppT (subst s t1) (subst s t2)+subst s (SigT t k) = SigT (subst s t) k+subst _ t = t+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Dan Rosén++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Dan Rosén nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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,2 @@+import Distribution.Simple+main = defaultMain
+ genifunctors.cabal view
@@ -0,0 +1,20 @@+name: genifunctors+version: 0.1.0.0+synopsis: Generate generalized fmap, foldMap and traverse+description: Generate (derive) fmap, foldMap and traverse for Bifunctors, Trifunctors, or a functor with any arity+license: BSD3+license-file: LICENSE+author: Dan Rosén+maintainer: danr@chalmers.se+category: Generics+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Data.Generics.Genifunctors+ other-extensions: TemplateHaskell, PatternGuards, RecordWildCards+ build-depends: base >= 4 && < 5,+ template-haskell <2.9,+ mtl,+ containers+ default-language: Haskell2010