packages feed

thorn 0.1.0.3 → 0.2

raw patch · 9 files changed

+889/−566 lines, 9 files

Files

Data/Thorn.hs view
@@ -1,125 +1,16 @@--- | Thorn, Datatype Manipulation with Template Haskell.
+-- |
+-- Thorn, Datatype Manipulation with Template Haskell.
 
 module Data.Thorn (
-    -- * Functor
-    -- $functor
-    autofmap
-  , Variance(..)
-  , autovariance, autofunctorize
-    
+    -- * Functors
+    module Data.Thorn.Functor
     -- * Folding and Unfolding
-    -- $fold
-  , unfixdata, unfixdataEx
-  , autoin, autoout, autohylo, autofold, autounfold
-
-    -- * Type Variants
-    -- $typevariants
-  , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9    
-
-    -- * Example
-
-    -- ** Functor Example
-    -- $functorexample
-
-    -- ** Folding and Unfolding Example
-    -- $foldexample
+  , module Data.Thorn.Fold
+    -- * Basic
+  , module Data.Thorn.Basic
   ) where
 
-import Data.Thorn.Type
 import Data.Thorn.Functor
 import Data.Thorn.Fold
-
-{- $functor
-    Thorn generates functors from various kinds of data types.
-
-    Quite surprisingly, it still works for any arities, co\/contra\/free\/fixed-variances, partially applied types, type synonyms, and mutual recursions.
-
-    For more information, see <Data-Thorn.html#FunctorExample Functor Example>.
--}
-
-{- $fold
-    For more information, see <Data-Thorn.html#FoldExample Folding and Unfolding Example>.
--}
-
-{- $typevariants
-    These types are used for representing type variants. For more information, see <Data-Thorn.html#FunctorExample Functor Example>.
--}
-
-{- $functorexample
-   #FunctorExample#
-
-> import Data.Thorn
-> import Data.Char
-> import Data.Functor.Contravariant
-> import Data.Bifunctor
-> import Data.Profunctor
-> 
-> type a :<- b = b -> a
-> nuf :: Char
-> nuf = $(autofmap [t|(:<-)|]) chr ord (+1) 'a' -- 'b'
-> varnuf :: [Variance]
-> varnuf = $(autovariance [t|(:<-)|]) -- [Co,Contra]
-> 
-> data Cntr a = Cntr (a -> Int)
-> autofunctorize [t|Cntr|] -- instance Contravariant Cntr where ...
-> 
-> tuple :: (Int,Int,Int)
-> tuple = $(autofmap $[t|(,,) Int|]) (+1) (+2) (0,0,0) -- (0,1,2)
-> vartuple :: [Variance]
-> vartuple = $(autovariance [t|(,,) Int|]) -- [Co,Co]
-> 
-> data FunFun a b = FunFun ((b -> a) -> b)
-> varfunfun :: [Variance]
-> varfunfun = $(autovariance [t|FunFun|]) -- [Contra,Co]
-> autofunctorize [t|FunFun|] -- instance Profunctor FunFun where ...
-> 
-> data What a b c = What1 c (a -> c) | What2 a
-> varwhat :: [Variance]
-> varwhat = $(autovariance [t|What|]) -- [Fixed,Free,Co]
-> autofunctorize [t|What T0|]
-> -- instance Bifunctor (What a) where ... and
-> -- instance Profunctor (What a) where ...
-> 
-> data List a = Nil | a :* (List a) deriving Show
-> fromNormalList :: [a] -> List a
-> fromNormalList [] = Nil
-> fromNormalList (a : as) = a :* fromNormalList as
-> toNormalList :: List a -> [a]
-> toNormalList Nil = []
-> toNormalList (a :* as) = a : toNormalList as
-> list :: [Int]
-> list = toNormalList $ $(autofmap [t|List|]) (+10) (fromNormalList [1..5]) -- [11..15]
-> varlist :: [Variance]
-> varlist = $(autovariance [t|List|]) -- [Co]
-> autofunctorize [t|List|] -- instance Functor List where ...
-> 
-> data Rose a = Rose a (Forest a) deriving Show
-> data Forest a = Forest [Rose a] deriving Show
-> gorose n = Rose n (Forest (replicate n (gorose (n-1))))
-> rose = $(autofmap [t|Rose|]) (+1) (gorose 2)
-> varrose, varforest :: [Variance]
-> varrose = $(autovariance [t|Rose|]) -- [Co]
-> varforest = $(autovariance [t|Forest|]) -- [Co]
-> autofunctorize [t|Rose|] -- instance Functor Rose where ...
-> autofunctorize [t|Forest|] -- instance Functor Forest where ...
-
-
-
--}
-
-{- $foldexample
-   #FoldExample#
-
-> import Data.Thorn
-> 
-> data x :$ y = Nil | (x,y) :* (x :$ y)
-> 
-> unfixdata [t|(:$)|]
-> 
-> insth = $(autoin [t|(:&$)|] [t|(:$)|])
-> outsth = $(autoout [t|(:&$)|] [t|(:$)|])
-> hylosth = $(autohylo [t|(:&$)|])
-> foldsth = $(autofold [t|(:&$)|] [t|(:$)|])
-> unfoldsth = $(autounfold [t|(:&$)|] [t|(:$)|])
--}
+import Data.Thorn.Basic
+ Data/Thorn/Basic.hs view
@@ -0,0 +1,20 @@+-- |
+-- The module Data.Thorn.Basic.
+module Data.Thorn.Basic (
+    -- * Type Variants
+    -- $typevariants
+    T0, T1, T2, T3, T4, T5, T6, T7, T8, T9
+
+    -- * Names
+  , modifyname
+  ) where
+
+import Data.Thorn.Internal
+
+{- $typevariants
+    These types @'T0', ..., 'T9'@ are used for representing type variants.
+
+> testtypevariant :: (String,Int,Int)
+> testtypevariant = $(autofmap $[t|(,,) T0|]) (+10) (+20) ("hello",1,1) -- ("hello",11,21)
+-}
+
Data/Thorn/Fold.hs view
@@ -3,148 +3,382 @@ -- |
 -- The module Data.Thorn.Fold.
 module Data.Thorn.Fold (
-    unfixdata, unfixdataEx
-  , autoin, autoout, autohylo, autofold, autounfold
-  , unfixdataMutual, unfixdataMutualEx
-  , autoinMutual, autooutMutual, autohyloMutual, autofoldMutual, autounfoldMutual
+    -- * Folding and Unfolding
+    -- $fold
+    unfixdata, autofold, autofoldtype, autofolddec, autounfold, autounfoldtype, autounfolddec
+    -- ** Mutual Recursion
+  , unfixdataMutual, autofoldMutual, autofoldtypeMutual, autofolddecMutual, autounfoldMutual, autounfoldtypeMutual, autounfolddecMutual
+    -- ** Helper Function
+  , modifynameUf
+    -- ** Primitive Functions
+  , autoin, autoout, autohylo
+  , autoinMutual, autooutMutual, autohyloMutual
+
+    -- * Examples
+    -- ** Basic
+    -- $basic
+
+    -- ** Mutual Recursion
+    -- $mutual
     ) where
 
-import Data.Thorn.Type
+import Data.Thorn.Internal
 import Data.Thorn.Functor
 import Language.Haskell.TH
+import Data.List
 import Control.Applicative
 
+{- $fold
+    Thorn generates folds and unfolds from various kinds of recursive datatypes, including mutually recursive ones.
+-}
+
+{- $basic
+
+It's a piece of cake.
+
+Note tht @foldlist@ is analogous with 'foldr' and @unfoldlist@ with 'unfoldr'.
+
+> data List a = Nil | a :* (List a) deriving Show
+> 
+> unfixdata [t|List|] "UfList" modifynameUf [''Show]
+> -- data UfList a self = UfNil | a :&* self deriving Show
+> 
+> autofolddec "foldlist" [t|UfList|] [t|List|]
+> autounfolddec "unfoldlist" [t|UfList|] [t|List|]
+> 
+> fib :: List Int
+> fib = unfoldlist go (0,1)
+>       -- 1 :* (1 :* (2 :* (3 :* (5 :* (8 :* (13 :* Nil))))))
+>     where go :: (Int,Int) -> UfList Int (Int,Int)
+>           go (a,b)
+>             | b > 20 = UfNil
+>             | otherwise = b :&* (b,a+b)
+> 
+> fibsum :: Int
+> fibsum = foldlist add fib
+>          -- 33
+>     where add :: UfList Int Int -> Int
+>           add UfNil = 0
+>           add (m :&* n) = m+n
+> 
+> normalfib :: [Int]
+> normalfib = foldlist go fib
+>             -- [1,1,2,3,5,8,13]
+>     where go :: UfList a [a] -> [a]
+>           go UfNil = []
+>           go (a :&* as) = a:as
+
+-}
+
+{- $mutual
+
+It also works for mutual recursion.
+
+It's just an extension of simple recursion. Take it easy.
+
+> data Rose x = x :-< (Forest x) deriving Show
+> data Forest x = F [Rose x] deriving Show
+> 
+> unfixdataMutual [([t|Rose|],"UfRose",modifynameUf,[''Show]), ([t|Forest|],"UfForest",modifynameUf,[''Show])]
+> -- data UfRose x rose forest = x :&-< forest deriving Show
+> -- data UfForest x rose forest = UfF [rose] deriving Show
+> 
+> autofolddecMutual "foldrose" [([t|UfRose|],[t|Rose|]),([t|UfForest|],[t|Forest|])] 0
+> -- foldrose :: (UfRose x a b -> a) -> (UfForest x a b -> b) -> Rose x -> a
+> -- foldrose = ...
+> autounfolddecMutual "unfoldrose" [([t|UfRose|],[t|Rose|]),([t|UfForest|],[t|Forest|])] 0
+> -- unfoldrose :: (a -> UfRose x a b) -> (b -> UfForest x a b) -> a -> Rose x
+> -- unfoldrose = ...
+> 
+> rose :: Rose Int
+> rose = unfoldrose gorose goforest 0
+>        -- 0 :-< F [1 :-< F [3 :-< F [],4 :-< F []],2 :-< F [5 :-< F [],6 :-< F []]]
+>     where gorose :: Int -> UfRose Int Int Int
+>           gorose n
+>             | n > 2 = n :&-< (-1)
+>             | otherwise = n :&-< n
+>           goforest :: Int -> UfForest Int Int Int
+>           goforest (-1) = UfF []
+>           goforest n = UfF [n*2+1,n*2+2]
+> 
+> showrose :: Show x => Rose x -> String
+> showrose = unlines . foldrose gorose goforest
+>     where gorose :: Show x => UfRose x [String] [String] -> [String]
+>           gorose (x :&-< ls) = [show x] ++ ls
+>           goforest :: UfForest x [String] [String] -> [String]
+>           goforest (UfF []) = []
+>           goforest (UfF lss) = concatMap hang (init lss) ++ hang' (last lss)
+>           hang ls = ["|"] ++ ["+--" ++ head ls] ++ map ("|  "++) (tail ls)
+>           hang' ls = ["|"] ++ ["+--" ++ head ls] ++ map ("   "++) (tail ls)
+> 
+> shownrose :: String
+> shownrose = showrose rose
+> -- 0
+> -- |
+> -- +--1
+> -- |  |
+> -- |  +--3
+> -- |  |
+> -- |  +--4
+> -- |
+> -- +--2
+> --    |
+> --    +--5
+> --    |
+> --    +--6
+
+-}
+
 -- |
--- @unfixdata t@ provides a declaration of a data whose fixpoint is the recursive type @t@.
-unfixdata :: TypeQ -> DecsQ
-unfixdata = unfixdataEx ("Uf","") ("Uf","") ("&","") ("&","")
+-- Use this function to designate how to convert the name of data constructors for 'unfixdata'.
+-- 
+-- > modifynameUf "Hello" == "UfHello"
+-- > modifynameUf ":***" == ":&***"
+-- 
+-- Note that
+-- 
+-- @'modifynameUf' == 'modifyname' (\"Uf\",\"\") (\"&\",\"\")@
+modifynameUf :: String -> String
+modifynameUf = modifyname ("Uf","") ("&","")
 
 -- |
--- Special version of @unfixdata@. Note that
---
--- > unfixdata = unfixdataEx ("Uf","") ("Uf","") ("&","") ("&","")
-unfixdataEx ::
-    (String,String) -- ^ prefix and suffix of type constructor
- -> (String,String) -- ^ prefix and suffix of data constructor
- -> (String,String) -- ^ prefix and suffix of infix type constructor
- -> (String,String) -- ^ prefix and suffix of infix data constructor
- -> TypeQ -- ^ data type
- -> DecsQ -- ^ declaration of data
-unfixdataEx (pretype,suftype) (predata,sufdata) (pretypeinfix,suftypeinfix) (predatainfix,sufdatainfix) t = do
-    (n, DataTx nm _ cxs) <- applyFixed 0 =<< type2typex [] [] =<< t
-    let modifytx (DataTx nm' vmp cxs') = if nm == nm' then VarTx $ mkName ("self") else DataTx nm' (map (\(nm'',tx) -> (nm'',modifytx tx)) vmp) (map modifycx cxs')
-        modifytx tx@(SeenDataTx nm' _) = if nm == nm' then VarTx $ mkName ("self") else modifytx tx
-        modifytx (TupleTx txs) = TupleTx (map modifytx txs)
-        modifytx (ArrowTx txa txb) = ArrowTx (modifytx txa) (modifytx txb)
-        modifytx (ListTx tx) = ListTx (modifytx tx)
-        modifytx tx = tx
-        modifycx (nm',txs) = (nm',map modifytx txs)
-        go (nm',txs) = do
-              ts <- map ((,) NotStrict) <$> mapM (typex2type . modifytx) txs
-              return $ NormalC (datanm nm') ts
-    cns <- mapM go cxs
-    return [DataD [] (typenm nm) (map var [0..n-1] ++ [self]) cns []]
-    where typenm nm
-            | elem (head s) ['A'..'Z'] = mkName $ pretype ++ s ++ suftype
-            | head s == '(' = mkName $ ":" ++ pretypeinfix ++ init (drop 2 s) ++ suftypeinfix
-            | otherwise = mkName $ ":" ++ pretypeinfix ++ tail s ++ suftypeinfix
-            where s = nameBase nm
-          datanm nm
-            | elem (head s) ['A'..'Z'] = mkName $ predata ++ s ++ sufdata
-            | head s == '(' = mkName $ ":" ++ predatainfix ++ init (drop 2 s) ++ sufdatainfix
-            | otherwise = mkName $ ":" ++ predatainfix ++ tail s ++ sufdatainfix
-            where s = nameBase nm
-          var i = PlainTV $ mkName ("t" ++ show i)
-          self = PlainTV $ mkName ("self")
+-- @unfixdata t n f ds@ provides a declaration of a nonrecursive datatype whose fixpoint is the recursive type @t@, with a deriving declaration with names @ds@.
+unfixdata ::
+    TypeQ -- ^ @t@, recursive datatype
+ -> String -- ^ @s@, name of the datatype to be declared
+ -> (String -> String) -- ^ @f@, how to convert the name of data constructors
+ -> [Name] -- ^ @ds@, derivings
+ -> DecsQ -- ^ declaration of a nonrecursive datatype whose fixpoint is @t@
+unfixdata t s f ds = unfixdataMutual [(t,s,f,ds)]
 
 autoin ::
-    TypeQ -- ^ @u@, un-recursive datatype
+    TypeQ -- ^ @u@, nonrecursive datatype
  -> TypeQ -- ^ @t@, fixpoint of @u@
- -> ExpQ -- ^ function with a type @u a0 .. an t -> t a0 .. an@
-autoin u t = do
-    (_,DataTx _ _ cxsu) <- applyFixed 0 =<< type2typex [] [] =<< u
-    (_,DataTx _ _ cxst) <- applyFixed 0 =<< type2typex [] [] =<< t
-    u1 <- unique
-    u2 <- unique
-    let go ((nmu,txsu),(nmt,_)) = Match (ConP nmu (map newVarP [u2..u2+length txsu-1])) (NormalB (applistE (ConE nmt) (map newVarE [u2..u2+length txsu-1]))) []
-    return $ LamE [newVarP u1] (CaseE (newVarE u1) (map go (zip cxsu cxst)))
+ -> ExpQ -- ^ function with a type @u x0 .. xn t -> t x0 .. xn@
+autoin u t = autoinMutual [(u,t)] 0
 
 autoout ::
-    TypeQ -- ^ @u@, un-recursive datatype
+    TypeQ -- ^ @u@, nonrecursive datatype
  -> TypeQ -- ^ @t@, fixpoint of @u@
  -> ExpQ -- ^ function with a type @t x0 .. xn -> u x0 .. xn t@
-autoout u t = do
-    (_,DataTx _ _ cxsu) <- applyFixed 0 =<< type2typex [] [] =<< u
-    (_,DataTx _ _ cxst) <- applyFixed 0 =<< type2typex [] [] =<< t
-    u1 <- unique
-    u2 <- unique
-    let go ((nmu,txsu),(nmt,_)) = Match (ConP nmt (map newVarP [u2..u2+length txsu-1])) (NormalB (applistE (ConE nmu) (map newVarE [u2..u2+length txsu-1]))) []
-    return $ LamE [newVarP u1] (CaseE (newVarE u1) (map go (zip cxsu cxst)))
+autoout u t = autooutMutual [(u,t)] 0
 
 autohylo ::
-    TypeQ -- ^ @u@, un-recursive datatype
+    TypeQ -- ^ @u@, nonrecursive datatype
  -> ExpQ -- ^ function with a type @(a -> u x0 .. xn a) -> (u x0 .. xn b -> b) -> (a -> b)@
-autohylo u = do
-    (n,DataTx nm _ cxs) <- applyFixed 0 =<< type2typex [] [] =<< u
-    f <- autofmap u
-    u <- unique
-    return $ LamE [newVarP u, newVarP (u+1)] (LetE [ValD (newVarP (u+3))
-        (NormalB (LamE [newVarP (u+2)] (AppE (newVarE (u+1)) (applistE f (replicate (n-1) (mkNameE "Prelude.id") ++ [newVarE (u+3)] ++ [AppE (newVarE u) (newVarE (u+2))])))))
-        []] (newVarE (u+3)))
+autohylo u = autohyloMutual [u] 0
 
 -- |
--- @autofold u t@ provides a folding function for a recursive type @t@.
+-- @autofold u t@ provides a fold for the recursive type @t@.
 autofold ::
-    TypeQ -- ^ @u@, un-recursive datatype
+    TypeQ -- ^ @u@, nonrecursive datatype
  -> TypeQ -- ^ @t@, fixpoint of @u@
- -> ExpQ -- ^ function with a type @(u x0 .. xn a -> a) -> (t -> a)@
-autofold u t = do
-    o <- autoout u t
-    h <- autohylo u
-    return $ AppE h o
+ -> ExpQ -- ^ fold with a type @(u x0 .. xn a -> a) -> (t x0 .. xn -> a)@
+autofold u t = autofoldMutual [(u,t)] 0
 
 -- |
--- @autounfold t@ provides an unfolding function for the recursive type @t@.
+-- @autofoldtype u t@ provides the type of @$('autofold' u t)@, that is, @(u x0 .. xn a -> a) -> (t x0 .. xn -> a)@.
+autofoldtype :: TypeQ -> TypeQ -> TypeQ
+autofoldtype u t = autofoldtypeMutual [(u,t)] 0
+
+-- |
+-- @autofolddec s u t@ provides a declaration of a fold for the recursive type @t@ with the name @s@, with a type signature.
+autofolddec :: String -> TypeQ -> TypeQ -> DecsQ
+autofolddec = gendec2 autofold autofoldtype
+
+-- |
+-- @autounfold u t@ provides an unfold for the recursive type @t@.
 autounfold ::
-    TypeQ -- ^ @u@, un-recursive datatype
+    TypeQ -- ^ @u@, nonrecursive datatype
  -> TypeQ -- ^ @t@, fixpoint of @u@
- -> ExpQ -- ^ function with a type @(a -> u x0 .. xn a) -> (a -> t)@
+ -> ExpQ -- ^ unfold with a type @(a -> u x0 .. xn a) -> (a -> t x0 .. xn)@
 autounfold u t = do
-    i <- autoin u t
-    h <- autohylo u
+    e <- autounfoldMutual [(u,t)] 0
+    return e
+
+-- |
+-- @autounfoldtype u t@ provides the type of @$('autounfold' u t)@, that is, @(a -> u x0 .. xn a) -> (a -> t x0 .. xn)@.
+autounfoldtype :: TypeQ -> TypeQ -> TypeQ
+autounfoldtype u t = autounfoldtypeMutual [(u,t)] 0
+
+-- |
+-- @autounfolddec s u t@ provides a declaration of an unfold for the recursive type @t@ with the name @s@, with a type signature.
+autounfolddec :: String -> TypeQ -> TypeQ -> DecsQ
+autounfolddec = gendec2 autounfold autounfoldtype
+
+-- |
+-- Mutually recursive version of 'unfixdata'. Note that
+--
+-- @'unfixdata' t s f ds = 'unfixdataMutual' [(t,s,f,ds)]@
+unfixdataMutual ::
+    [(TypeQ,String,String->String,[Name])] -- ^ @[(t0,s0,f0,ds0), ...]@; recursive datatype, name of the datatype to be declared, how to convert the name of data constructors, and derivings
+ -> DecsQ -- ^ declarations of datatypes @u0, u1, u2, ...@, whose fixpoints are @t0, t1, t2, ...@ respectively
+unfixdataMutual tsfdss = do
+    tpls <- mapM (\(t,_,_,_) -> t >>= type2typex [] [] >>= applyFixed 0) tsfdss
+    let nms = map (\(_, DataTx nm _ _) -> nm) tpls
+        cxss = map (\(_, DataTx _ _ cxs) -> cxs) tpls
+        ss = map (\(_,s,_,_) -> s) tsfdss
+        fs = map (\(_,_,f,_) -> f) tsfdss
+        dss = map (\(_,_,_,ds) -> ds) tsfdss
+        l = length tpls
+        (n,_) = head tpls
+        modifytx (DataTx nm vmp cxs) = case elemIndex nm nms of
+            Just k -> VarTx $ mkName ("self" ++ show k)
+            Nothing -> DataTx nm (map (\(nm',tx) -> (nm',modifytx tx)) vmp) (map modifycx cxs)
+        modifytx tx@(SeenDataTx nm _) = case elemIndex nm nms of
+            Just k -> VarTx $ mkName ("self" ++ show k)
+            Nothing -> tx
+        modifytx (TupleTx txs) = TupleTx (map modifytx txs)
+        modifytx (ArrowTx txa txb) = ArrowTx (modifytx txa) (modifytx txb)
+        modifytx (ListTx tx) = ListTx (modifytx tx)
+        modifytx tx = tx
+        modifycx (nm,txs) = (nm,map modifytx txs)
+        go f (nm,txs) = do
+              ts' <- map ((,) NotStrict) <$> mapM (typex2type . modifytx) txs
+              return $ NormalC (fixname f nm) ts'
+        ho (nm,s,cns,ds) = DataD [] newnm (map var [0..n-1] ++ map self [0..l-1]) cns ds
+            where newnm = if s=="" then fixname (modifyname ("Uf","") ("&","")) nm else mkName s
+    cnss <- mapM (\(cxs,f) -> mapM (go f) cxs) (zip cxss fs)
+    return $ map ho (zip4 nms ss cnss dss)
+    where var i = PlainTV $ mkName ("t" ++ show i)
+          self i = PlainTV $ mkName ("self" ++ show i)
+
+-- |
+-- Mutually recursive version of 'autoin'.
+autoinMutual ::
+    [(TypeQ,TypeQ)] -- ^ @[(u0,t0), .., (un,tn)]@; @ui@ is a nonrecursive datatype and @ti@ is a fixpoint of @ui@
+ -> Int -- ^ @k@, index
+ -> ExpQ -- ^ function with a type @uk x0 .. xm t0 .. tn -> tk x0 .. xm@
+autoinMutual uts k = do
+    cxsus <- mapM (\(u,_) -> u >>= type2typex [] [] >>= applyFixed 0 >>= return . getcxs . snd) uts
+    cxsts <- mapM (\(_,t) -> t >>= type2typex [] [] >>= applyFixed 0 >>= return . getcxs . snd) uts
+    let cxsu = cxsus !! k
+        cxst = cxsts !! k
     u1 <- unique
-    return $ LamE [newVarP u1] (AppE (AppE h (newVarE u1)) i)
+    u2 <- unique
+    let go ((nmu,txsu),(nmt,_)) = Match (ConP nmu (map newVarP [u2..u2+l-1])) (NormalB (applistE (ConE nmt) (map newVarE [u2..u2+l-1]))) []
+            where l = length txsu
+    return $ LamE [newVarP u1] (CaseE (newVarE u1) (map go (zip cxsu cxst)))
+    where getcxs (DataTx _ _ cxs) = cxs
+          getcxs _ = error "Thorn doesn't work well, sorry."
 
 -- |
--- @unfixdataMutual ts@ is a mutual recursion version of @unfixdata t@.
-unfixdataMutual :: [TypeQ] -> DecsQ
-unfixdataMutual = unfixdataMutualEx ("Uf","") ("Uf","") ("&","") ("&","")
+-- Mutually recursive version of 'autoout'.
+autooutMutual ::
+    [(TypeQ,TypeQ)] -- ^ @[(u0,t0), .., (un,tn)]@; @ui@ is a nonrecursive datatype and @ti@ is a fixpoint of @ui@
+ -> Int -- ^ @k@, index
+ -> ExpQ -- ^ function with a type @tk x0 .. xm -> uk x0 .. xm t0 .. tn@
+autooutMutual uts k = do
+    cxsus <- mapM (\(u,_) -> u >>= type2typex [] [] >>= applyFixed 0 >>= return . getcxs . snd) uts
+    cxsts <- mapM (\(_,t) -> t >>= type2typex [] [] >>= applyFixed 0 >>= return . getcxs . snd) uts
+    let cxsu = cxsus !! k
+        cxst = cxsts !! k
+    u1 <- unique
+    u2 <- unique
+    let go ((nmu,txsu),(nmt,_)) = Match (ConP nmt (map newVarP [u2..u2+l-1])) (NormalB (applistE (ConE nmu) (map newVarE [u2..u2+l-1]))) []
+            where l = length txsu
+    return $ LamE [newVarP u1] (CaseE (newVarE u1) (map go (zip cxsu cxst)))
+    where getcxs (DataTx _ _ cxs) = cxs
+          getcxs _ = error "Thorn doesn't work well, sorry."
 
-unfixdataMutualEx ::
-    (String,String) -- ^ prefix and suffix of type constructor
- -> (String,String) -- ^ prefix and suffix of data constructor
- -> (String,String) -- ^ prefix and suffix of infix type constructor
- -> (String,String) -- ^ prefix and suffix of infix data constructor
- -> [TypeQ] -- ^ data types
- -> DecsQ -- ^ declarations of data
-unfixdataMutualEx = undefined
+-- |
+-- Mutually recursive version of 'autohylo'.
+autohyloMutual ::
+    [TypeQ] -- ^ @[u0, .., un]@; @ui@ is a nonrecursive datatype
+ -> Int -- ^ @k@, index
+ -> ExpQ -- ^ function with a type @(a0 -> u0 x0 .. xm a0 .. an) -> .. -> (an -> un x0 .. xm a0 .. an) -> (u0 x0 .. xm b0 .. bn -> b0) -> .. -> (un x0 .. xm b0 .. bn -> bn) -> (ak -> bk)@
+autohyloMutual us k = do
+    ms <- mapM (\u -> u >>= type2typex [] [] >>= applyFixed 0 >>= \(m,DataTx _ _ _) -> return m) us
+    fms <- mapM autofmap us
+    u1 <- unique
+    let n = length us
+        m i = (ms !! i) - n
+        f i = mkName ("f"++show (u1+i))
+        g i = mkName ("g"++show (u1+i))
+        x = newVar u1
+        fm i = fms !! i
+        hylo i = mkName ("hylo"++show i)
+        hylodef i = ValD (VarP $ hylo i) (NormalB (LamE [VarP x] (
+            AppE (VarE $ g i) (applistE (fm i) (replicate (m i) idE ++ map (VarE . hylo) [0..n-1] ++ [AppE (VarE $ f i) (VarE x)]))
+            ))) []
+    return $ LamE (map (VarP . f) [0..n-1] ++ map (VarP . g) [0..n-1]) (LetE (map hylodef [0..n-1]) (VarE $ hylo k))
+    {-
+        \f0 .. fn-1 g0 .. gn-1 ->
+            let hylo0 = \x -> g0 (fm0 hylo0 .. hylon-1 (f1 x))
+                ..
+            in hylok
+    -}
 
-autoinMutual :: [TypeQ] -> DecsQ
-autoinMutual ts = fail "oh"
+-- |
+-- @autofoldMutual uts k@ provides a fold for the mutually recursive type @tk@.
+autofoldMutual ::
+    [(TypeQ,TypeQ)] -- ^ @[(u0,t0), .., (un,tn)]@; @ui@ is a nonrecursive datatype and @ti@ is a fixpoint of @ui@
+ -> Int -- ^ @k@, index
+ -> ExpQ -- ^ fold with a type @(u0 x0 .. xm a0 .. an -> a0) -> .. -> (un x0 .. xm a0 .. an -> an) -> (tk x0 .. xm -> ak)@
+autofoldMutual uts k = do
+    os <- mapM (autooutMutual uts) [0..n-1]
+    h <- autohyloMutual (map fst uts) k
+    return $ applistE h os
+    where n = length uts
 
-autooutMutual :: [TypeQ] -> DecsQ
-autooutMutual ts = fail "oh"
+-- |
+-- @autofoldtypeMutual uts k@ provides the type of @$('autofoldMutual' uts k)@, that is, @(u0 x0 .. xm a0 .. an -> a0) -> .. -> (un x0 .. xm a0 .. an -> an) -> (tk x0 .. xm -> ak)@.
+autofoldtypeMutual :: [(TypeQ,TypeQ)] -> Int -> TypeQ
+autofoldtypeMutual uts k = do
+    mtxs <- mapM (\(_,t) -> t >>= type2typex [] [] >>= applyFixed 0) uts
+    let n = length uts
+        ms = map fst mtxs
+        txs = map snd mtxs
+    t <- typex2type $ txs !! k
+    uxs <- mapM (\(m,(u,_)) -> u >>= type2typex [] [] >>= applyFixed' m 0) (zip ms uts)
+    let f i = do
+            uxa <- applistTx (uxs !! i) (map (VarTx . a) [0..n-1])
+            typex2type (ArrowTx uxa (VarTx $ a i))
+        a i = mkName ("a"++show i)
+        x i = mkName ("t"++show i)
+    fs <- mapM f [0..n-1]
+    return $ ForallT (map (PlainTV . x) [0..ms!!k-1] ++ map (PlainTV . a) [0..n-1]) [] (
+        foldr1 (\t1 t2 -> AppT (AppT ArrowT t1) t2) (fs ++ [t, VarT $ a k]))
 
-autohyloMutual :: [TypeQ] -> DecsQ
-autohyloMutual ts = fail "oh"
+-- |
+-- @autofolddecMutual s uts k@ provides a declaration of a fold for the mutually recursive type @tk@ with the name @s@, with a type signature.
+autofolddecMutual :: String -> [(TypeQ,TypeQ)] -> Int -> DecsQ
+autofolddecMutual = gendec2 autofoldMutual autofoldtypeMutual
 
 -- |
--- @autofoldMutual ts@ provides a folding function for the mutually recursive types @ts@.
-autofoldMutual :: [TypeQ] -> ExpQ
-autofoldMutual ts = do fail "oh"
+-- @autounfoldMutual uts k@ provides an unfold for the mutually recursive type @tk@.
+autounfoldMutual ::
+    [(TypeQ,TypeQ)] -- ^ @[(u0,t0), .., (un,tn)]@; @ui@ is a nonrecursive datatype and @ti@ is a fixpoint of @ui@
+ -> Int -- ^ @k@, index
+ -> ExpQ -- ^ unfold with a type @(a0 -> u0 x0 .. xm a0 .. an) -> .. -> (an -> un x0 .. xm a0 .. an) -> (ak -> tk x0 .. xm)@
+autounfoldMutual uts k = do
+    is <- mapM (autoinMutual uts) [0..n-1]
+    h <- autohyloMutual (map fst uts) k
+    u <- unique
+    return $ LamE (map newFuncP [u..u+n-1]) (applistE h (map newFuncE [u..u+n-1]++is))
+    where n = length uts
 
 -- |
--- @autounfoldMutual ts@ provides an unfolding function for the mutually recursive types @ts@.
-autounfoldMutual :: [TypeQ] -> ExpQ
-autounfoldMutual ts = do fail "oh"
+-- @autounfoldtypeMutual uts k@ provides the type of @$('autounfoldMutual' uts k)@, that is, @(a0 -> u0 x0 .. xm a0 .. an) -> .. -> (an -> un x0 .. xm a0 .. an) -> (ak -> tk x0 .. xm)@.
+autounfoldtypeMutual :: [(TypeQ,TypeQ)] -> Int -> TypeQ
+autounfoldtypeMutual uts k = do
+    mtxs <- mapM (\(_,t) -> t >>= type2typex [] [] >>= applyFixed 0) uts
+    let n = length uts
+        ms = map fst mtxs
+        txs = map snd mtxs
+    t <- typex2type $ txs !! k
+    uxs <- mapM (\(m,(u,_)) -> u >>= type2typex [] [] >>= applyFixed' m 0) (zip ms uts)
+    let f i = do
+            uxa <- applistTx (uxs !! i) (map (VarTx . a) [0..n-1])
+            typex2type (ArrowTx (VarTx $ a i) uxa)
+        a i = mkName ("a"++show i)
+        x i = mkName ("t"++show i)
+    fs <- mapM f [0..n-1]
+    return $ ForallT (map (PlainTV . x) [0..ms!!k-1] ++ map (PlainTV . a) [0..n-1]) [] (
+        foldr1 (\t1 t2 -> AppT (AppT ArrowT t1) t2) (fs ++ [VarT $ a k, t]))
+
+-- |
+-- @autounfolddecMutual s uts k@ provides a declaration of an unfold for the mutually recursive type @tk@ with the name @s@, with a type signature.
+autounfolddecMutual :: String -> [(TypeQ,TypeQ)] -> Int -> DecsQ
+autounfolddecMutual = gendec2 autounfoldMutual autounfoldtypeMutual
− Data/Thorn/FoldExample.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators #-}
-
-module Data.Thorn.FoldExample (module Data.Thorn.FoldExample) where
-
-import Data.Thorn
-
-data x :$ y = Nil | (x,y) :* (x :$ y)
-
-unfixdata [t|(:$)|]
-
-insth = $(autoin [t|(:&$)|] [t|(:$)|])
-outsth = $(autoout [t|(:&$)|] [t|(:$)|])
-hylosth = $(autohylo [t|(:&$)|])
-foldsth = $(autofold [t|(:&$)|] [t|(:$)|])
-unfoldsth = $(autounfold [t|(:&$)|] [t|(:$)|])
-
Data/Thorn/Functor.hs view
@@ -3,47 +3,197 @@ -- |
 -- The module Data.Thorn.Functor.
 module Data.Thorn.Functor (
-    autofmap
+    -- * Functors
+    -- $functor
+    autofmap, autofmaptype, autofmapdec, autofunctorize
+    
+    -- ** Variance
   , Variance(..)
-  , autovariance, autofunctorize
-  ) where
+  , autovariance
+    
+    -- * Examples
+     
+    -- ** Basic
+    -- $basic
+    
+    -- ** Functions
+    -- $function
+    
+    -- ** Partial Application
+    -- $partial
+    
+    -- ** Type Synonyms
+    -- $synonym
+    
+    -- ** Variances
+    -- $variance
+    
+    -- ** Recursive Types
+    -- $recursive
+    ) where
 
-import Data.Thorn.Type
+import Data.Thorn.Internal
 import Language.Haskell.TH
+import Data.Maybe
 import Data.List
 import qualified Data.Sequence as S
 import qualified Data.Foldable as F
+import Data.Monoid
 import Control.Applicative
 import Control.Monad.State
-import Data.Monoid
 
+{- $functor
+    Thorn generates functors from various kinds of datatypes.
+
+    Quite surprisingly, it still works for any arities, co\/contra\/free\/fixed-variances, partially applied types, type synonyms, and mutual recursions.
+-}
+
+{- $basic
+
+    It's a piece of cake.
+
+> testtuple :: (Int,String)
+> testtuple = $(autofmap [t|(,)|]) (+1) ('h':) (100,"ello") -- (101,"hello")
+> 
+> testeither :: Either Int String
+> testeither = $(autofmap [t|Either|]) (+1) ('a':) (Left 100) -- Left 101
+> 
+> testfunction :: String
+> testfunction = $(autofmap [t|(->)|]) ('h':) (++"!") (++", world") "ello" -- "hello, world!"
+> 
+> testlist :: [Int]
+> testlist = $(autofmap [t|[]|]) (+10) [1..5] -- [11..15]
+
+-}
+
+{- $function
+
+    You can nest functions.
+
+> data FunFun a b = FunFun ((b -> a) -> b)
+> 
+> varfunfun :: [Variance]
+> varfunfun = $(autovariance [t|FunFun|]) -- [Contra,Co]
+> 
+> autofunctorize [t|FunFun|]
+> -- instance Profunctor FunFun where
+> --     dimap = ...
+
+-}
+
+{- $partial
+
+    It works for partially applied types.
+
+> testpartial :: (Int,Int,Int)
+> testpartial = $(autofmap $[t|(,,) Int|]) (+10) (+20) (1,1,1) -- (1,11,21)
+
+    You can use type variants @'T0', 'T1', ..., 'T9'@ to represent any type.
+
+> testpartial' :: (String,Int,Int)
+> testpartial' = $(autofmap $[t|(,,) T0|]) (+10) (+20) ("hello",1,1) -- ("hello",11,21)
+
+-}
+
+{- $synonym
+
+Interestingly, it works for type synonyms.
+
+> type a :<- b = b -> a
+> varnuf :: [Variance]
+> varnuf = $(autovariance [t|(:<-)|]) -- [Co,Contra]
+> $(autofmapdec "fmapnuf" [t|(:<-)|])
+
+-}
+
+{- $variance
+
+It works for free-variance and fixed-variance. See how @autofunctorize@ works for free-variance.
+
+> data What a b c = What1 c (a -> c) | What2 a
+> 
+> varwhat :: [Variance]
+> varwhat = $(autovariance [t|What|]) -- [Fixed,Free,Co]
+> 
+> autofunctorize [t|What T0|]
+> -- instance Bifunctor (What a) where
+> --     bimap = ...
+> -- instance Profunctor (What a) where
+> --     dimap = ...
+
+-}
+
+{- $recursive
+
+It works for recursive datatypes.
+
+> data List a = Nil | a :* (List a) deriving Show
+> 
+> autofunctorize [t|List|]
+> -- instance Functor List where
+> --     fmap = ...
+> 
+> fromNormalList :: [a] -> List a
+> fromNormalList [] = Nil
+> fromNormalList (a : as) = a :* fromNormalList as
+> toNormalList :: List a -> [a]
+> toNormalList Nil = []
+> toNormalList (a :* as) = a : toNormalList as
+> 
+> testlist :: [Int]
+> testlist = toNormalList $ fmap (+10) (fromNormalList [1..5]) -- [11..15]
+
+It also works for mutually recursive datatypes.
+
+> data Rose a = Rose a (Forest a) deriving Show
+> data Forest a = Forest [Rose a] deriving Show
+> 
+> autofunctorize [t|Rose|]
+> -- instance Functor Rose where
+> --     fmap = ...
+> 
+> gorose :: Int -> Rose Int
+> gorose 0 = Rose 0 (Forest [])
+> gorose n = Rose n (Forest (replicate 2 (gorose (n-1))))
+> testrose :: Rose Int
+> testrose = fmap (+10) (gorose 2)
+> -- Rose 12 (Forest [Rose 11 (Forest [Rose 10 (Forest []),Rose 10 (Forest [])]),Rose 11 (Forest [Rose 10 (Forest []),Rose 10 (Forest [])])])
+
+-}
+
 -- |
--- @autofmap t@ generates the @fmap@ of the type @t@.
+-- @autofmap t@ generates an fmap of the type @t@.
 autofmap :: TypeQ -> ExpQ
 autofmap t = do
     (n,tx) <- t >>= type2typex [] [] >>= applySpecial 0
     u <- unique
-    (e,txnmes) <- runStateT (autofmap' u tx) []
-    return $ LamE (map newFuncP [u..u+n-1]) (LetE (fmap (\(_,nm,Just e') -> ValD (VarP nm) (NormalB e') []) txnmes) e)
+    (e,(txnmes,bs)) <- runStateT (autofmap' u tx) ([],S.replicate n False)
+    let txnmes' = filter (\(_,nm,_) -> isJust nm) txnmes
+    return $ LamE (map (\i -> if S.index bs i then newFuncP (i+u) else WildP) [0..n-1]) (LetE (fmap (\(_,Just nm,Just e') -> ValD (VarP nm) (NormalB e') []) txnmes') e)
 
-autofmap',autofmap'' :: Unique -> Typex -> StateT [(Typex,Name,Maybe Exp)] Q Exp
+autofmap',autofmap'' :: Unique -> Typex -> StateT ([(Typex,Maybe Name,Maybe Exp)],S.Seq Bool) Q Exp
 autofmap' u tx = do
-    txnmes <- get
+    (txnmes,bs) <- get
     case find (\(tx',_,_)->tx==tx') txnmes of
-         Just (_,nm,_) -> return (VarE nm)
+         Just (_,Just nm,_) -> return (VarE nm)
+         Just (_,Nothing,_) -> do
+             u2 <- unique
+             let nm = newFmap u2
+             put (map (\(tx',nm',e) -> if tx==tx' then (tx,Just nm,e) else (tx',nm',e)) txnmes, bs)
+             return (VarE nm)
          Nothing -> autofmap'' u tx
-autofmap'' _ (VarTx _) = return $ mkNameE "id"
-autofmap'' _ (BasicTx _) = return $ mkNameE "id"
-autofmap'' _ (FixedTx _) = return $ mkNameE "id"
+autofmap'' _ (VarTx _) = return idE
+autofmap'' _ (BasicTx _) = return idE
+autofmap'' _ (FixedTx _) = return idE
 autofmap'' _ NotTx = fail "Thorn doesn't work well, sorry."
 autofmap'' _ (FuncTx _) = fail "Thorn doesn't accept such a type with a kind * -> k, sorry."
 autofmap'' u (DataTx nm vmp cxs) = do
-    txnmes <- get
-    put ((tx0, newFmap (length txnmes), Nothing) : txnmes)
+    (txnmes,bs) <- get
+    put ((tx0,Nothing,Nothing) : txnmes, bs)
     u2 <- unique
     e <- LamE [newVarP u2] <$> (CaseE (newVarE u2) <$> (mapM go cxs))
-    txnmes' <- get
-    put $ map (\(tx,nm',e') -> if tx==tx0 then (tx,nm',Just e) else (tx,nm',e')) txnmes'
+    (txnmes',bs') <- get
+    put (map (\(tx,nm',e') -> if tx==tx0 then (tx,nm',Just e) else (tx,nm',e')) txnmes', bs')
     return e
     where go (nm',txs) = do
               (u2,es) <- autofmapmap u txs
@@ -59,9 +209,12 @@     u2 <- unique
     return $ LamE [newVarP u2, newVarP (u2+1)] (AppE fb (AppE (newVarE u2) (AppE fa (newVarE (u2+1)))))
 autofmap'' u (ListTx tx) = autofmap' u tx >>= \f -> return $ AppE (mkNameE "map") f
-autofmap'' u (SpecialTx n) = return $ newFuncE (u+n)
+autofmap'' u (SpecialTx n) = do
+    (txnmes,bs) <- get
+    put (txnmes,S.update n True bs)
+    return $ newFuncE (u+n)
 
-autofmapmap :: Unique -> [Typex] -> StateT [(Typex,Name,Maybe Exp)] Q (Unique,[Exp])
+autofmapmap :: Unique -> [Typex] -> StateT ([(Typex,Maybe Name,Maybe Exp)],S.Seq Bool) Q (Unique,[Exp])
 autofmapmap u txs = do
     u2 <- unique
     es <- mapM (\(i,tx) -> autofmap' u tx >>= \e -> return $ AppE e (newVarE i)) (zip [u2..u2+length txs-1] txs)
@@ -72,11 +225,11 @@ data Variance =
     -- | Covariance, one of a normal functor.
     Co
-    -- | Contravariance, a dual of covariance.
+    -- | Contravariance, the dual of covariance.
   | Contra
-    -- | Free-variance, or novariance, being supposed to satisfy either covariance or contravariance.
+    -- | Free-variance, or invariance, being supposed to satisfy either covariance or contravariance.
   | Free
-    -- | Fixed-variance, or invariance, being suppoesed to satisfy both covariance and contravariance.
+    -- | Fixed-variance, or nonvariance, being supposed to satisfy both covariance and contravariance.
   | Fixed deriving (Show, Read)
 
 -- | @v1 `mappend` v2@ means to be supposed to satisfy both @v1@ and @v2@.
@@ -142,7 +295,47 @@ autovariance' v dts (ListTx tx) = autovariance' v dts tx
 
 -- |
--- @autofunctorize t@ provides instance delcarations of the type @t@, for the suitable functor classes : Funtor, Contravariant, Bifunctor, or Profunctor.
+-- @autofmaptype t@ provides the type of @$('autofmap' t)@.
+autofmaptype :: TypeQ -> TypeQ
+autofmaptype t = do
+    tx <- type2typex [] [] =<< t
+    vs <- autovarianceRaw t
+    let ivs = zip [0..length vs-1] vs
+        a i = mkNameTx ("a"++show i)
+        b i = mkNameTx ("b"++show i)
+        c i = mkNameTx ("c"++show i)
+        a' i = mkName ("a"++show i)
+        b' i = mkName ("b"++show i)
+        c' i = mkName ("c"++show i)
+        gofunc (i,Co) = ArrowTx (a i) (b i)
+        gofunc (i,Contra) = ArrowTx (b i) (a i)
+        gofunc (i,Free) = a i
+        gofunc (i,Fixed) = ArrowTx (a i) (a i)
+        gosrc (i,Co) = a i
+        gosrc (i,Contra) = a i
+        gosrc (i,Free) = b i
+        gosrc (i,Fixed) = a i
+        godst (i,Co) = b i
+        godst (i,Contra) = b i
+        godst (i,Free) = c i
+        godst (i,Fixed) = a i
+        gonm (i,Co) = [a' i,b' i]
+        gonm (i,Contra) = [a' i,b' i]
+        gonm (i,Free) = [a' i,b' i,c' i]
+        gonm (i,Fixed) = [a' i]
+        tvs = map PlainTV $ concatMap gonm ivs
+    funcs <- mapM (typex2type . gofunc) ivs
+    src <- typex2type =<< applistTx tx (map gosrc ivs)
+    dst <- typex2type =<< applistTx tx (map godst ivs)
+    return $ ForallT tvs [] (foldr1 (\ta tb -> applistT ArrowT [ta,tb]) (funcs++[src]++[dst]))
+
+-- |
+-- @autofmapdec s t@ provides a declaration of an fmap for the type @t@ with the name @s@, with a type signature.
+autofmapdec :: String -> TypeQ -> DecsQ
+autofmapdec = gendec1 autofmap autofmaptype
+
+-- |
+-- @autofunctorize t@ provides instance delcarations of the type @t@, for the suitable functor classes : 'Functor', 'Data.Functor.Contravariant.Contravariant', 'Data.Bifunctor.Bifunctor', or 'Data.Profunctor.Profunctor'. Multiple classes can be suitable for @t@, when one of the variances of @t@ is 'Free'.
 autofunctorize :: TypeQ -> DecsQ
 autofunctorize t = do
     vs <- autovarianceRaw t
− Data/Thorn/FunctorExample.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators #-}
-
-module Data.Thorn.FunctorExample (module Data.Thorn.FunctorExample) where
-
-import Data.Thorn
-import Data.Char
-import Data.Functor.Contravariant
-import Data.Bifunctor
-import Data.Profunctor
-
-type a :<- b = b -> a
-nuf :: Char
-nuf = $(autofmap [t|(:<-)|]) chr ord (+1) 'a' -- 'b'
-varnuf :: [Variance]
-varnuf = $(autovariance [t|(:<-)|]) -- [Co,Contra]
-
-data Cntr a = Cntr (a -> Int)
-autofunctorize [t|Cntr|] -- instance Contravariant Cntr where ...
-
-tuple :: (Int,Int,Int)
-tuple = $(autofmap $[t|(,,) Int|]) (+1) (+2) (0,0,0) -- (0,1,2)
-vartuple :: [Variance]
-vartuple = $(autovariance [t|(,,) Int|]) -- [Co,Co]
-
-data FunFun a b = FunFun ((b -> a) -> b)
-varfunfun :: [Variance]
-varfunfun = $(autovariance [t|FunFun|]) -- [Contra,Co]
-autofunctorize [t|FunFun|] -- instance Profunctor FunFun where ...
-
-data What a b c = What1 c (a -> c) | What2 a
-varwhat :: [Variance]
-varwhat = $(autovariance [t|What|]) -- [Fixed,Free,Co]
-autofunctorize [t|What T0|]
--- instance Bifunctor (What a) where ... and
--- instance Profunctor (What a) where ...
-
-data List a = Nil | a :* (List a) deriving Show
-fromNormalList :: [a] -> List a
-fromNormalList [] = Nil
-fromNormalList (a : as) = a :* fromNormalList as
-toNormalList :: List a -> [a]
-toNormalList Nil = []
-toNormalList (a :* as) = a : toNormalList as
-list :: [Int]
-list = toNormalList $ $(autofmap [t|List|]) (+10) (fromNormalList [1..5]) -- [11..15]
-varlist :: [Variance]
-varlist = $(autovariance [t|List|]) -- [Co]
-autofunctorize [t|List|] -- instance Functor List where ...
-
-data Rose a = Rose a (Forest a) deriving Show
-data Forest a = Forest [Rose a] deriving Show
-gorose n = Rose n (Forest (replicate n (gorose (n-1))))
-rose = $(autofmap [t|Rose|]) (+1) (gorose 2)
-varrose, varforest :: [Variance]
-varrose = $(autovariance [t|Rose|]) -- [Co]
-varforest = $(autovariance [t|Forest|]) -- [Co]
-autofunctorize [t|Rose|] -- instance Functor Rose where ...
-autofunctorize [t|Forest|] -- instance Functor Forest where ...
-
+ Data/Thorn/Internal.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}
+
+-- | The module Data.Thorn.Internal.
+module Data.Thorn.Internal (
+    Unique, unique
+  , newVar, newSubvar, newFunc, newFmap
+  , newVarP, newSubvarP, newFuncP, newFmapP
+  , newVarE, newSubvarE, newFuncE, newFmapE
+  , mkNameE, mkNameCE, mkNameP, mkNameTx
+  , idE
+  , applistE, applistT, applistTx, appTx
+  , Typex(..)
+  , Conx
+  , cxtxs
+  , type2typex, typex2type, normalizetype
+  , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9
+  , applySpecial, applyFixed, applyFixed'
+  , gendec1, gendec2
+  , modifyname, fixname
+  ) where
+
+import Language.Haskell.TH
+import Data.Char
+import Data.List
+import Data.Maybe
+import Control.Monad
+import Control.Monad.Trans
+import Control.Applicative
+import System.Random
+
+instance MonadIO Q where
+    liftIO = runIO
+
+type Unique = Int
+
+unique :: MonadIO m => m Unique
+unique = liftIO $ getStdRandom (randomR (0,1000000000))
+
+newVar, newSubvar, newFunc, newFmap :: Int -> Name
+newVarP, newSubvarP, newFuncP, newFmapP :: Int -> Pat
+newVarE, newSubvarE, newFuncE, newFmapE :: Int -> Exp
+newVar n = mkName $ "var" ++ show n
+newVarP = VarP . newVar
+newVarE = VarE . newVar
+newSubvar n = mkName $ "subvar" ++ show n
+newSubvarP = VarP . newSubvar
+newSubvarE = VarE . newSubvar
+newFunc n = mkName $ "func" ++ show n
+newFuncP = VarP . newFunc
+newFuncE = VarE . newFunc
+newFmap n = mkName $ "fmap" ++ show n
+newFmapP = VarP . newFmap
+newFmapE = VarE . newFmap
+
+mkNameE, mkNameCE :: String -> Exp
+mkNameP :: String -> Pat
+mkNameTx :: String -> Typex
+mkNameE = VarE . mkName
+mkNameCE = ConE . mkName
+mkNameP = VarP . mkName
+mkNameTx = VarTx . mkName
+
+idE :: Exp
+idE = mkNameE "Prelude.id"
+
+applistE :: Exp -> [Exp] -> Exp
+applistT :: Type -> [Type] -> Type
+applistTx :: Typex -> [Typex] -> TypexQ
+applistE e es = foldl (\e1 e2 -> AppE e1 e2) e es
+applistT t ts = foldl (\t1 t2 -> AppT t1 t2) t ts
+applistTx tx txs = foldM (\tx1 tx2 -> appTx tx1 tx2) tx txs
+
+appTx :: Typex -> Typex -> TypexQ
+appTx (FuncTx f) tx = f tx
+appTx _ _ = fail "appTx : Thorn doesn't work well, sorry."
+
+data Typex =
+    VarTx Name
+  | BasicTx Name
+  | FixedTx Int
+  | SpecialTx Int
+  | NotTx
+  | FuncTx (Typex -> TypexQ)
+  | DataTx Name VarMap [Conx]
+  | SeenDataTx Name VarMap
+  | TupleTx [Typex]
+  | ArrowTx Typex Typex
+  | ListTx Typex
+type TypexQ = Q Typex
+
+type Conx = (Name,[Typex])
+
+cxtxs :: Conx -> [Typex]
+cxtxs = snd
+
+type VarMap = [(Name,Typex)]
+type Datas = [(Name,VarMap)]
+
+instance Eq Typex where
+    VarTx t == VarTx t' = t==t'
+    BasicTx nm == BasicTx nm' = nm==nm'
+    SpecialTx n == SpecialTx n' = n==n'
+    FixedTx n == FixedTx n' = n==n'
+    NotTx == NotTx = True
+    DataTx nm vmp cons == DataTx nm' vmp' cons' = nm==nm'&&vmp==vmp'&&cons==cons'
+    SeenDataTx nm vmp == SeenDataTx nm' vmp' = nm==nm'&&vmp==vmp'
+    TupleTx txs == TupleTx txs' = txs==txs'
+    ArrowTx txa txb == ArrowTx txa' txb' = txa==txa'&&txb==txb'
+    ListTx tx == ListTx tx' = tx==tx'
+    _ == _ = False
+
+instance Show Typex where
+    show (DataTx _ _ _) = "DataTx"
+    show (SeenDataTx _ _) = "SeenDataTx"
+    show _ = "Foo"
+
+type2typex :: VarMap -> Datas -> Type -> TypexQ
+type2typex vmp dts (ForallT tvs _ t) = type2typex vmp' dts t
+    where vmp' = filter (\(nm,_) -> notElem nm (map nameTV tvs)) vmp
+type2typex vmp dts (AppT t u) = do
+    FuncTx f <- type2typex vmp dts t
+    ux <- type2typex vmp dts u
+    f ux
+type2typex vmp dts (SigT t _) = type2typex vmp dts t
+type2typex vmp _ (VarT nm) = case (find (\(nm',_) -> nm==nm') vmp) of
+    Nothing -> return $ VarTx nm
+    Just (_,tx) -> return tx
+type2typex vmp dts (ConT nm)
+    | s == "()" = type2typex vmp dts (TupleT 0)
+    | head s == '(' && dropWhile (==',') (tail s) == ")" = type2typex vmp dts (TupleT (length s - 1))
+    | s == "(->)" = type2typex vmp dts ArrowT
+    | s == "[]" = type2typex vmp dts ListT
+    | elem s ["Int","Word","Float","Double","Char","Ptr","FunPtr"] = return $ BasicTx nm
+    | otherwise = reify nm >>= go
+    where s = nameBase nm
+          go (TyConI (TySynD _ tvs u)) = ho (length tvs) []
+            where ho 0 txs = type2typex (zip (map nameTV tvs) (reverse txs)) dts u
+                  ho n txs = return $ FuncTx $ \tx -> ho (n-1) (tx:txs)
+          go (TyConI (DataD _ nm' tvs cons _)) = do
+              b <- istypevariant nm'
+              if b then tofixed nm' else ho (length tvs) []
+            where ho 0 txs = fromData nm' (zip (map nameTV tvs) (reverse txs)) dts cons
+                  ho n txs = return $ FuncTx $ \tx -> ho (n-1) (tx:txs)
+          go (TyConI (NewtypeD _ _ tvs con _)) = ho (length tvs) []
+            where ho 0 txs = fromData nm (zip (map nameTV tvs) (reverse txs)) dts [con]
+                  ho n txs = return $ FuncTx $ \tx -> ho (n-1) (tx:txs)
+          go (PrimTyConI _ _ _) = fail "type2typex : Thorn doesn't support such primitive types, sorry."
+          go (FamilyI _ _) = fail "type2typex : Thorn doesn't support type families, sorry."
+          go _ = fail "type2typex : Thorn doesn't work well, sorry."
+type2typex _ _ (TupleT n) = go n []
+    where go 0 txs = return $ TupleTx (reverse txs)
+          go k txs = return $ FuncTx $ \tx -> go (k-1) (tx:txs)
+type2typex _ _ ArrowT = return $ FuncTx $ \txa -> return $ FuncTx $ \txb -> return $ ArrowTx txa txb
+type2typex _ _ ListT = return $ FuncTx $ \tx -> return $ ListTx tx
+type2typex _ _ _ = fail "type2typex : Thorn doesn't support such types, sorry."
+
+fromData :: Name -> VarMap -> Datas -> [Con] -> TypexQ
+fromData nm vmp dts cons = case find (\(nm',_)->nm==nm') dts of
+        Just (_,vmp')
+            | vmp == vmp' -> return $ SeenDataTx nm vmp
+            | otherwise -> fail "fromData : Thorn doesn't support irregular types, sorry."
+        Nothing -> DataTx nm vmp <$> mapM con2conx cons
+    where dts' = (nm,vmp) : dts
+          con2conx (NormalC nm' sts) = (,) nm' <$> mapM stype2typex sts
+          con2conx (RecC nm' vsts) = (,) nm' <$> mapM vstype2typex vsts
+          con2conx (InfixC sta nm' stb) = do
+              txa <- stype2typex sta
+              txb <- stype2typex stb
+              return (nm',[txa,txb])
+          con2conx (ForallC _ _ _) = fail "fromData : Thorn doesn't support existential types, sorry."
+          stype2typex (_,t) = type2typex vmp dts' t
+          vstype2typex (_,_,t) = type2typex vmp dts' t
+
+nameTV :: TyVarBndr -> Name
+nameTV (PlainTV nm) = nm
+nameTV (KindedTV nm _) = nm
+
+typex2type :: Typex -> TypeQ
+typex2type (VarTx nm) = return $ VarT nm
+typex2type (SpecialTx _) = return StarT
+typex2type (FixedTx n) = return $ VarT (mkName $ "t" ++ show n)
+typex2type NotTx = return StarT
+typex2type (FuncTx f) = do
+    AppT t StarT <- typex2type =<< f NotTx
+    return t
+typex2type (DataTx nm vmp _) = do
+    ts <- mapM (typex2type . snd) vmp
+    return $ applistT (ConT nm) ts
+typex2type (SeenDataTx nm vmp) = do
+    ts <- mapM (typex2type . snd) vmp
+    return $ applistT (ConT nm) ts
+typex2type (BasicTx nm) = return $ ConT nm
+typex2type (TupleTx txs) = do
+    ts <- mapM typex2type txs
+    return $ applistT (TupleT (length txs)) ts
+typex2type (ArrowTx txa txb) = do
+    ta <- typex2type txa
+    tb <- typex2type txb
+    return $ applistT ArrowT [ta,tb]
+typex2type (ListTx tx) = do
+    t <- typex2type tx
+    return $ AppT ListT t
+normalizetype :: Type -> TypeQ
+normalizetype t = typex2type =<< type2typex [] [] t
+
+data T0
+data T1
+data T2
+data T3
+data T4
+data T5
+data T6
+data T7
+data T8
+data T9
+
+typevariants :: Q [Name]
+typevariants = mapM (\n -> getnm <$> (reify . mkName $ 'T' : show n)) ([0..9] :: [Int])
+    where getnm (TyConI (DataD _ nm _ _ _)) = nm
+          getnm _ = error "typevariants : Thorn doesn't work well, sorry."
+
+istypevariant :: Name -> Q Bool
+istypevariant nm = do
+    typevariants' <- typevariants
+    return $ elem nm typevariants'
+
+tofixed :: Name -> Q Typex
+tofixed nm = do
+    typevariants' <- typevariants
+    return $ FixedTx (fromJust $ elemIndex nm typevariants')
+
+applySpecial :: Int -> Typex -> Q (Int,Typex)
+applySpecial n (FuncTx f) = f (SpecialTx n) >>= applySpecial (n+1)
+applySpecial n tx@(VarTx _) = return (n,tx)
+applySpecial n tx@(BasicTx _) = return (n,tx)
+applySpecial n tx@(FixedTx _) = return (n,tx)
+applySpecial n tx@(SpecialTx _) = return (n,tx)
+applySpecial n tx@NotTx = return (n,tx)
+applySpecial n tx@(DataTx _ _ _) = return (n,tx)
+applySpecial n tx@(SeenDataTx _ _) = return (n,tx)
+applySpecial n tx@(TupleTx _) = return (n,tx)
+applySpecial n tx@(ArrowTx _ _) = return (n,tx)
+applySpecial n tx@(ListTx _) = return (n,tx)
+
+applyFixed :: Int -> Typex -> Q (Int,Typex)
+applyFixed n (FuncTx f) = f (FixedTx n) >>= applyFixed (n+1)
+applyFixed n tx@(VarTx _) = return (n,tx)
+applyFixed n tx@(BasicTx _) = return (n,tx)
+applyFixed n tx@(FixedTx _) = return (n,tx)
+applyFixed n tx@(SpecialTx _) = return (n,tx)
+applyFixed n tx@NotTx = return (n,tx)
+applyFixed n tx@(DataTx _ _ _) = return (n,tx)
+applyFixed n tx@(SeenDataTx _ _) = return (n,tx)
+applyFixed n tx@(TupleTx _) = return (n,tx)
+applyFixed n tx@(ArrowTx _ _) = return (n,tx)
+applyFixed n tx@(ListTx _) = return (n,tx)
+
+applyFixed' :: Int -> Int -> Typex -> TypexQ
+applyFixed' k n tx@(FuncTx f)
+    | k==n = return tx
+    | otherwise = f (FixedTx n) >>= applyFixed' k (n+1)
+applyFixed' _ _ _ = fail "applyFixed' : Thorn doesn't work well, sorry."
+
+gendec1 :: (a -> ExpQ) -> (a -> TypeQ) -> String -> a -> DecsQ
+gendec1 f g s a = do
+    e <- f a
+    t <- g a
+    return [SigD (mkName s) t, ValD (mkNameP s) (NormalB e) []]
+
+gendec2 :: (a -> b -> ExpQ) -> (a -> b -> TypeQ) -> String -> a -> b -> DecsQ
+gendec2 f g s a b = do
+    e <- f a b
+    t <- g a b
+    return [SigD (mkName s) t, ValD (mkNameP s) (NormalB e) []]
+
+-- |
+-- > modifyname ("Prefix","Suffix") ("***","+++") "Hello" == "PrefixHelloSuffix"
+-- > modifyname ("Prefix","Suffix") ("***","+++") ":%%%" == ":***%%%+++"
+-- > modifyname ("prefix","suffix") ("***","+++") "hello" == "prefixhellosuffix"
+-- > modifyname ("prefix","suffix") ("***","+++") "%%%" == "***%%%+++"
+modifyname :: (String,String) -> (String,String) -> String -> String
+modifyname (pre,suf) (preinfix,sufinfix) s
+    | isAlpha (head s) = pre ++ s ++ suf
+    | head s == ':' = ":" ++ preinfix ++ tail s ++ sufinfix
+    | otherwise = preinfix ++ s ++ sufinfix
+
+fixname :: (String -> String) -> Name -> Name
+fixname f nm
+    | head s == '(' = mkName (f (init (tail s)))
+    | otherwise = mkName (f s)
+    where s = nameBase nm
+
− Data/Thorn/Type.hs 
@@ -1,241 +0,0 @@-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}
-
--- | The module Data.Thorn.Type.
-module Data.Thorn.Type (
-    Unique, unique
-  , newVar, newSubvar, newFunc, newFmap
-  , newVarP, newSubvarP, newFuncP, newFmapP
-  , newVarE, newSubvarE, newFuncE, newFmapE
-  , mkNameE, mkNameCE, mkNameP
-  , applistE, applistT
-  , Typex(..)
-  , Conx(..)
-  , cxtxs
-  , type2typex, typex2type, normalizetype
-  , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9
-  , applySpecial, applyFixed
-  ) where
-
-import Language.Haskell.TH
-import Data.List
-import Data.Maybe
-import Control.Monad.Trans
-import Control.Applicative
-import System.Random
-
-instance MonadIO Q where
-    liftIO = runIO
-
-type Unique = Int
-
-unique :: MonadIO m => m Unique
-unique = liftIO $ getStdRandom (randomR (0,1000000000))
-
-newVar, newSubvar, newFunc, newFmap :: Int -> Name
-newVarP, newSubvarP, newFuncP, newFmapP :: Int -> Pat
-newVarE, newSubvarE, newFuncE, newFmapE :: Int -> Exp
-newVar n = mkName $ "var" ++ show n
-newVarP = VarP . newVar
-newVarE = VarE . newVar
-newSubvar n = mkName $ "subvar" ++ show n
-newSubvarP = VarP . newSubvar
-newSubvarE = VarE . newSubvar
-newFunc n = mkName $ "func" ++ show n
-newFuncP = VarP . newFunc
-newFuncE = VarE . newFunc
-newFmap n = mkName $ "fmap" ++ show n
-newFmapP = VarP . newFmap
-newFmapE = VarE . newFmap
-
-mkNameE, mkNameCE :: String -> Exp
-mkNameP :: String -> Pat
-mkNameE = VarE . mkName
-mkNameCE = ConE . mkName
-mkNameP = VarP . mkName
-
-applistE :: Exp -> [Exp] -> Exp
-applistT :: Type -> [Type] -> Type
-applistE e es = foldl (\e' es' -> AppE e' es') e es
-applistT t ts = foldl (\t' ts' -> AppT t' ts') t ts
-
-data Typex =
-    VarTx Name
-  | BasicTx Name
-  | FixedTx Int
-  | SpecialTx Int
-  | NotTx
-  | FuncTx (Typex -> TypexQ)
-  | DataTx Name VarMap [Conx]
-  | SeenDataTx Name VarMap
-  | TupleTx [Typex]
-  | ArrowTx Typex Typex
-  | ListTx Typex
-type TypexQ = Q Typex
-
-type Conx = (Name,[Typex])
-
-cxtxs :: Conx -> [Typex]
-cxtxs = snd
-
-type VarMap = [(Name,Typex)]
-type Datas = [(Name,VarMap)]
-
-instance Eq Typex where
-    VarTx t == VarTx t' = t==t'
-    BasicTx nm == BasicTx nm' = nm==nm'
-    SpecialTx n == SpecialTx n' = n==n'
-    FixedTx n == FixedTx n' = n==n'
-    NotTx == NotTx = True
-    DataTx nm vmp cons == DataTx nm' vmp' cons' = nm==nm'&&vmp==vmp'&&cons==cons'
-    SeenDataTx nm vmp == SeenDataTx nm' vmp' = nm==nm'&&vmp==vmp'
-    TupleTx txs == TupleTx txs' = txs==txs'
-    ArrowTx txa txb == ArrowTx txa' txb' = txa==txa'&&txb==txb'
-    ListTx tx == ListTx tx' = tx==tx'
-    _ == _ = False
-
-instance Show Typex where
-    show (DataTx _ _ _) = "DataTx"
-    show (SeenDataTx _ _) = "SeenDataTx"
-    show _ = "Foo"
-
-type2typex :: VarMap -> Datas -> Type -> TypexQ
-type2typex vmp dts (ForallT tvs _ t) = type2typex vmp' dts t
-    where vmp' = filter (\(nm,_) -> notElem nm (map nameTV tvs)) vmp
-type2typex vmp dts (AppT t u) = do
-    FuncTx f <- type2typex vmp dts t
-    ux <- type2typex vmp dts u
-    f ux
-type2typex vmp dts (SigT t _) = type2typex vmp dts t
-type2typex vmp _ (VarT nm) = case (find (\(nm',_) -> nm==nm') vmp) of
-    Nothing -> return $ VarTx nm
-    Just (_,tx) -> return tx
-type2typex vmp dts (ConT nm)
-    | s == "()" = type2typex vmp dts (TupleT 0)
-    | head s == '(' && dropWhile (==',') (tail s) == ")" = type2typex vmp dts (TupleT (length s - 1))
-    | s == "(->)" = type2typex vmp dts ArrowT
-    | s == "[]" = type2typex vmp dts ListT
-    | elem s ["Int","Word","Float","Double","Char","Ptr","FunPtr"] = return $ BasicTx nm
-    | otherwise = reify nm >>= go
-    where s = nameBase nm
-          go (TyConI (TySynD _ tvs u)) = ho (length tvs) []
-            where ho 0 txs = type2typex (zip (map nameTV tvs) (reverse txs)) dts u
-                  ho n txs = return $ FuncTx $ \tx -> ho (n-1) (tx:txs)
-          go (TyConI (DataD _ nm' tvs cons _)) = do
-              b <- istypevariant nm'
-              if b then tofixed nm' else ho (length tvs) []
-            where ho 0 txs = fromData nm' (zip (map nameTV tvs) (reverse txs)) dts cons
-                  ho n txs = return $ FuncTx $ \tx -> ho (n-1) (tx:txs)
-          go (TyConI (NewtypeD _ _ tvs con _)) = ho (length tvs) []
-            where ho 0 txs = fromData nm (zip (map nameTV tvs) (reverse txs)) dts [con]
-                  ho n txs = return $ FuncTx $ \tx -> ho (n-1) (tx:txs)
-          go (PrimTyConI _ _ _) = fail "Thorn doesn't support such primitive types, sorry."
-          go (FamilyI _ _) = fail "Thorn doesn't support type families, sorry."
-          go _ = fail "Thorn doesn't work well, sorry."
-type2typex _ _ (TupleT n) = go n []
-    where go 0 txs = return $ TupleTx (reverse txs)
-          go k txs = return $ FuncTx $ \tx -> go (k-1) (tx:txs)
-type2typex _ _ ArrowT = return $ FuncTx $ \txa -> return $ FuncTx $ \txb -> return $ ArrowTx txa txb
-type2typex _ _ ListT = return $ FuncTx $ \tx -> return $ ListTx tx
-type2typex _ _ _ = fail "Thorn doesn't support such types, sorry."
-
-fromData :: Name -> VarMap -> Datas -> [Con] -> TypexQ
-fromData nm vmp dts cons = case find (\(nm',_)->nm==nm') dts of
-        Just (_,vmp')
-            | vmp == vmp' -> return $ SeenDataTx nm vmp
-            | otherwise -> fail "Thorn doesn't support irregular types, sorry."
-        Nothing -> DataTx nm vmp <$> mapM con2conx cons
-    where dts' = (nm,vmp) : dts
-          con2conx (NormalC nm' sts) = (,) nm' <$> mapM stype2typex sts
-          con2conx (RecC nm' vsts) = (,) nm' <$> mapM vstype2typex vsts
-          con2conx (InfixC sta nm' stb) = do
-              txa <- stype2typex sta
-              txb <- stype2typex stb
-              return (nm',[txa,txb])
-          con2conx (ForallC _ _ _) = fail "Thorn doesn't support existential types, sorry."
-          stype2typex (_,t) = type2typex vmp dts' t
-          vstype2typex (_,_,t) = type2typex vmp dts' t
-
-nameTV :: TyVarBndr -> Name
-nameTV (PlainTV nm) = nm
-nameTV (KindedTV nm _) = nm
-
-typex2type :: Typex -> TypeQ
-typex2type (VarTx nm) = return $ VarT nm
-typex2type (SpecialTx _) = return StarT
-typex2type (FixedTx n) = return $ VarT (mkName $ "t" ++ show n)
-typex2type NotTx = return StarT
-typex2type (FuncTx f) = do
-    AppT t StarT <- typex2type =<< f NotTx
-    return t
-typex2type (DataTx nm vmp _) = do
-    ts <- mapM (typex2type . snd) vmp
-    return $ applistT (ConT nm) ts
-typex2type (SeenDataTx nm vmp) = do
-    ts <- mapM (typex2type . snd) vmp
-    return $ applistT (ConT nm) ts
-typex2type (BasicTx nm) = return $ ConT nm
-typex2type (TupleTx txs) = do
-    ts <- mapM typex2type txs
-    return $ applistT (TupleT (length txs)) ts
-typex2type (ArrowTx txa txb) = do
-    ta <- typex2type txa
-    tb <- typex2type txb
-    return $ applistT ArrowT [ta,tb]
-typex2type (ListTx tx) = do
-    t <- typex2type tx
-    return $ AppT ListT t
-normalizetype :: Type -> TypeQ
-normalizetype t = typex2type =<< type2typex [] [] t
-
-data T0
-data T1
-data T2
-data T3
-data T4
-data T5
-data T6
-data T7
-data T8
-data T9
-
-typevariants :: Q [Name]
-typevariants = mapM (\n -> getnm <$> (reify . mkName $ 'T' : show n)) ([0..9] :: [Int])
-    where getnm (TyConI (DataD _ nm _ _ _)) = nm
-          getnm _ = error "Thorn doesn't work well, sorry."
-
-istypevariant :: Name -> Q Bool
-istypevariant nm = do
-    typevariants' <- typevariants
-    return $ elem nm typevariants'
-
-tofixed :: Name -> Q Typex
-tofixed nm = do
-    typevariants' <- typevariants
-    return $ FixedTx (fromJust $ elemIndex nm typevariants')
-
-applySpecial :: Int -> Typex -> Q (Int,Typex)
-applySpecial n (FuncTx f) = f (SpecialTx n) >>= applySpecial (n+1)
-applySpecial n tx@(VarTx _) = return (n,tx)
-applySpecial n tx@(BasicTx _) = return (n,tx)
-applySpecial n tx@(FixedTx _) = return (n,tx)
-applySpecial n tx@(SpecialTx _) = return (n,tx)
-applySpecial n tx@NotTx = return (n,tx)
-applySpecial n tx@(DataTx _ _ _) = return (n,tx)
-applySpecial n tx@(SeenDataTx _ _) = return (n,tx)
-applySpecial n tx@(TupleTx _) = return (n,tx)
-applySpecial n tx@(ArrowTx _ _) = return (n,tx)
-applySpecial n tx@(ListTx _) = return (n,tx)
-
-applyFixed :: Int -> Typex -> Q (Int,Typex)
-applyFixed n (FuncTx f) = f (FixedTx n) >>= applyFixed (n+1)
-applyFixed n tx@(VarTx _) = return (n,tx)
-applyFixed n tx@(BasicTx _) = return (n,tx)
-applyFixed n tx@(FixedTx _) = return (n,tx)
-applyFixed n tx@(SpecialTx _) = return (n,tx)
-applyFixed n tx@NotTx = return (n,tx)
-applyFixed n tx@(DataTx _ _ _) = return (n,tx)
-applyFixed n tx@(SeenDataTx _ _) = return (n,tx)
-applyFixed n tx@(TupleTx _) = return (n,tx)
-applyFixed n tx@(ArrowTx _ _) = return (n,tx)
-applyFixed n tx@(ListTx _) = return (n,tx)
-
thorn.cabal view
@@ -1,8 +1,17 @@ name: thorn synopsis: Datatype Manipulation with Template Haskell-description: Datatype Manipulation with Template Haskell+description:+    Thorn generates+    .+    * functors from various kinds of datatypes, regardless of arity or variances.+    .+    * folds and unfolds from various kinds of recursive datatypes, including mutually recursive ones.+    .+    A single function of Thorn will give you a lot. Just try it.+    .+    The haddock is here. <http://kinokkory.github.io/Thorn/> category: Data, Generics-version: 0.1.0.3+version: 0.2 stability: experimental license: BSD3 license-file: LICENSE@@ -19,8 +28,8 @@     location: git://github.com/Kinokkory/Thorn.git  library-    exposed-modules: Data.Thorn, Data.Thorn.FunctorExample, Data.Thorn.FoldExample-    other-modules: Data.Thorn.Functor, Data.Thorn.Fold, Data.Thorn.Type+    exposed-modules: Data.Thorn, Data.Thorn.Functor, Data.Thorn.Fold, Data.Thorn.Basic+    other-modules: Data.Thorn.Internal     build-depends:         base >= 4 && < 5,         random > 1,