1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
-- Contributed by Tim Newsham <newsham -AT- lava -DOT- net>
{-|
A pseudo derivation. Derive a (non-recursive) fold function for
the type which takes one function per alternative constructor. Each
function takes the same arguments as the constructor and returns
a value. When applied to a value the fold function applies the
function for the matching constructor to the constructor fields.
This provides a first-class alternative to pattern matching to
deconstruct the data type.
-}
module Data.Derive.Fold(makeFold) where
{-
test :: Computer
foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a
foldComputer f _ (Laptop x1 x2) = f x1 x2
foldComputer _ f (Desktop x1) = f x1
test :: Assoced
foldAssoced :: (typ -> String -> a) -> Assoced typ -> a
foldAssoced f (Assoced x1 x2) = f x1 x2
test :: Either
foldEither :: (a -> c) -> (b -> c) -> Either a b -> c
foldEither f _ (Left x1) = f x1
foldEither _ f (Right x1) = f x1
test :: Bool
foldBool :: a -> a -> Bool -> a
foldBool f _ False = f
foldBool _ f True = f
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.List
import Data.Generics.Uniplate.DataOnly
makeFold :: Derivation
makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d
mkFold :: DataDecl -> [Decl]
mkFold d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f [0..] $ dataDeclCtors d]
where
n = "fold" ++ title (dataDeclName d)
f i c = Match sl (name n) pat Nothing (UnGuardedRhs bod) (BDecls [])
where pat = replicate i PWildCard ++ [pVar "f"] ++ replicate (length (dataDeclCtors d) - i - 1) PWildCard ++
[PParen $ PApp (qname $ ctorDeclName c) (map pVar vars)]
bod = apps (var "f") (map var vars)
vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]
foldType :: DataDecl -> Type
foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]
where
dt = dataDeclType d
v = head $ map (tyVar . return) ['a'..] \\ universe dt
f c = TyParen $ tyFun $ map (fromBangType . snd) (ctorDeclFields c) ++ [v]
|
