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
|
{-
This module is not written/maintained by the usual Data.Derive author.
MAINTAINER: Twan van Laarhoven
EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
Please send all patches to this module to Neil (ndmitchell -at- gmail),
and CC Twan.
-}
-- NOTE: Cannot be guessed as it relies on type information
-- | Derives 'Functor', as discussed on the Haskell-prime mailing list:
-- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.
module Data.Derive.Functor(makeFunctor,makeFunctorN) where
{-
import Prelude
test :: FailList
instance Functor (FailList t1) where
fmap _ Zoro = Zoro
fmap _ (Fial a1) = Fial a1
fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2)
test :: State
instance Functor (State t1) where
fmap _f (StateT a1) = StateT (fmap _f . a1)
test :: Sample
instance Functor Sample where
fmap _ First = First
fmap _f (Second a1 a2) = Second (_f a1) (_f a2)
fmap _f (Third a1) = Third (_f a1)
-}
import Data.Derive.Internal.Traversal
import Data.Derive.Internal.Derivation
import Language.Haskell
makeFunctor :: Derivation
makeFunctor = makeFunctorN 1
makeFunctorN :: Int -> Derivation
makeFunctorN n = traversalDerivation1 functorTraversal{traversalArg = n} "Functor"
functorTraversal = defaultTraversalType
{ traversalName = qname "fmap"
, traverseArrow = Just functorForArrowType
, traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) (BDecls [])
}
functorForArrowType :: Exp -> Exp -> Exp
functorForArrowType a b
| isId a && isId b = var "id"
| isId a = LeftSection b (qvop ".")
| isId b = RightSection (qvop ".") a
| otherwise = Lambda sl [pVar "arg"] $ b .: var "arg" .: a
where isId = (var "id" ==)
a .: b = InfixApp (paren a) (qvop ".") (paren b)
|
