Data.Thorn.Fold

The module Data.Thorn.Fold.

Folding and Unfolding

Thorn generates folds and unfolds from various kinds of recursive datatypes, including mutually recursive ones.

unfixdata

Arguments

:: 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 n f ds provides a declaration of a nonrecursive datatype whose fixpoint is the recursive type t, with a deriving declaration with names ds.

autofold

Arguments

:: TypeQ

u, nonrecursive datatype

-> TypeQ

t, fixpoint of u

-> ExpQ

fold with a type (u x0 .. xn a -> a) -> (t x0 .. xn -> a)

autofold u t provides a fold for the recursive type t.

autofoldtype :: TypeQ -> TypeQ -> TypeQ

autofoldtype u t provides the type of $(autofold u t), that is, (u x0 .. xn a -> a) -> (t x0 .. xn -> a).

autofolddec :: String -> TypeQ -> TypeQ -> DecsQ

autofolddec s u t provides a declaration of a fold for the recursive type t with the name s, with a type signature.

autounfold

Arguments

:: TypeQ

u, nonrecursive datatype

-> TypeQ

t, fixpoint of u

-> ExpQ

unfold with a type (a -> u x0 .. xn a) -> (a -> t x0 .. xn)

autounfold u t provides an unfold for the recursive type t.

autounfoldtype :: TypeQ -> TypeQ -> TypeQ

autounfoldtype u t provides the type of $(autounfold u t), that is, (a -> u x0 .. xn a) -> (a -> t x0 .. xn).

autounfolddec :: String -> TypeQ -> TypeQ -> DecsQ

autounfolddec s u t provides a declaration of an unfold for the recursive type t with the name s, with a type signature.

Mutual Recursion

unfixdataMutual

Arguments

:: [(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

Mutually recursive version of unfixdata. Note that

unfixdata t s f ds = unfixdataMutual [(t,s,f,ds)]

autofoldMutual

Arguments

:: [(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 provides a fold for the mutually recursive type tk.

autofoldtypeMutual :: [(TypeQ, TypeQ)] -> Int -> TypeQ

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).

autofolddecMutual :: String -> [(TypeQ, TypeQ)] -> Int -> DecsQ

autofolddecMutual s uts k provides a declaration of a fold for the mutually recursive type tk with the name s, with a type signature.

autounfoldMutual

Arguments

:: [(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 provides an unfold for the mutually recursive type tk.

autounfoldtypeMutual :: [(TypeQ, TypeQ)] -> Int -> TypeQ

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).

autounfolddecMutual :: String -> [(TypeQ, TypeQ)] -> Int -> DecsQ

autounfolddecMutual s uts k provides a declaration of an unfold for the mutually recursive type tk with the name s, with a type signature.

Helper Function

modifynameUf :: String -> String

Use this function to designate how to convert the name of data constructors for unfixdata.

modifynameUf "Hello" == "UfHello"
modifynameUf ":***" == ":&***"

Note that

modifynameUf == modifyname ("Uf","") ("&","")

Primitive Functions

autoin

Arguments

:: TypeQ

u, nonrecursive datatype

-> TypeQ

t, fixpoint of u

-> ExpQ

function with a type u x0 .. xn t -> t x0 .. xn

autoout

Arguments

:: TypeQ

u, nonrecursive datatype

-> TypeQ

t, fixpoint of u

-> ExpQ

function with a type t x0 .. xn -> u x0 .. xn t

autohylo

Arguments

:: TypeQ

u, nonrecursive datatype

-> ExpQ

function with a type (a -> u x0 .. xn a) -> (u x0 .. xn b -> b) -> (a -> b)

autoinMutual

Arguments

:: [(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

Mutually recursive version of autoin.

autooutMutual

Arguments

:: [(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

Mutually recursive version of autoout.

autohyloMutual

Arguments

:: [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)

Mutually recursive version of autohylo.

Examples

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 Recursion

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