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
|
{-
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
module Data.Derive.Traversable(makeTraversable, makeTraversableN) where
{-
import Data.Traversable
import Control.Applicative(pure, (<*>))
instance Traversable (FailList t1) where
traverse _f (Zoro) = pure Nil
traverse _f (Fial a1) = pure (Fial a1)
traverse _f (Const a1 a2) = (Const <$> _f a1) <*> traverse _f a2
instance Traversable Sample where
traverse _f (First) = pure First
traverse _f (Second a1 a2) = (Second <$> _f a1) <*> _f a2
traverse _f (Third a1) = Third <$> _f a1
instance Traversable (Either t1) where
traverse _f (Left a1) = pure (Left a1)
traverse _f (Right a1) = Right <$> _f a1
-}
import Data.Derive.Internal.Traversal
import Data.Derive.Internal.Derivation
import Language.Haskell
makeTraversable :: Derivation
makeTraversable = makeTraversableN 1
makeTraversableN :: Int -> Derivation
makeTraversableN n = traversalDerivation1 traverseTraversal{traversalArg = n} "Traversable"
traverseTraversal = defaultTraversalType
{ traversalName = qname "traverse"
, traversalId = var "pure"
, traversalPlus = fail "variable used in multiple positions in a data type"
, traverseTuple = \args -> liftAN (Con $ Special $ TupleCon Unboxed $ length args) args
, traverseCtor = \ctor -> liftAN (con ctor)
, traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) (BDecls [])
}
liftAN :: Exp -> [Exp] -> Exp
liftAN base args = foldl (<*>) (appP (var "pure") base) args
where x <*> y = InfixApp (paren x) (QVarOp $ UnQual $ Symbol "<*>") (paren y)
|
