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
|
{-|
A Pseudo derivation. For every label, creates a function
foo_u and foo_s which updates and sets the label respectively,
e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'
-}
module Data.Derive.Update(makeUpdate) where
{-
test :: Computer
speed_u :: (Int -> Int) -> Computer -> Computer
speed_u f x = x{speed = f (speed x)}
speed_s :: Int -> Computer -> Computer
speed_s v x = x{speed = v}
weight_u :: (Double -> Double) -> Computer -> Computer
weight_u f x = x{weight = f (weight x)}
weight_s :: Double -> Computer -> Computer
weight_s v x = x{weight = v}
test :: Sample
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.Maybe
makeUpdate :: Derivation
makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d
makeUpdateField :: DataDecl -> String -> [Decl]
makeUpdateField d field =
[TypeSig sl [name upd] (TyParen (TyFun typF typF) `TyFun` typR)
,bind upd [pVar "f",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (App (var "f") (Paren $ App (var field) (var "x")))]
,TypeSig sl [name set] (typF `TyFun` typR)
,bind set [pVar "v",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]]
where
set = field ++ "_s"
upd = field ++ "_u"
typR = dataDeclType d `TyFun` dataDeclType d
typF = fromBangType $ fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
|
