Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit b0c5ac8

Browse files
Implement advanced Haskell lenses
1 parent c133fbb commit b0c5ac8

File tree

6 files changed

+187
-0
lines changed

6 files changed

+187
-0
lines changed

‎.gitignore‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,7 @@
11
node_modules
22
*.log
33
.DS_Store
4+
*.hi
5+
*.o
6+
*.dyn_hi
7+
*.dyn_o

‎Haskell/advanced/1-lens.hs‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
-- cabal install template-haskell
2+
--
3+
-- Lens is implementation of most common of optics.
4+
--
5+
-- Real makeLens implementation more complex supporting all of Haskell syntax
6+
-- cases for creating types.
7+
--
8+
{-# LANGUAGE Rank2Types #-}
9+
{-# LANGUAGE TemplateHaskell #-}
10+
module Lens where
11+
12+
import Language.Haskell.TH
13+
14+
type Lens s t a b = forall f . Functor f => (a -> f b) -> s -> f t
15+
type Lens' s a = Lens s s a a
16+
17+
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
18+
lens getter setter = \afb s -> setter s <$> afb (getter s)
19+
20+
fieldLens :: Name -> (Name, a, Type) -> Q [Dec]
21+
fieldLens s (v, _, a) = do
22+
sVar <- newName "s"
23+
bVar <- newName "b"
24+
let setter = return $ LamE [VarP sVar, VarP bVar] $ RecUpdE (VarE sVar) [(v, VarE bVar)]
25+
body <- NormalB <$> [| lens $(return $ VarE v) $setter |]
26+
let fn = mkName $ tail $ nameBase v
27+
return [ SigD fn (AppT (AppT (ConT $ mkName "Lens'") (ConT s)) a)
28+
, FunD fn [Clause [] body []]
29+
]
30+
31+
makeLens :: Name -> Q [Dec]
32+
makeLens s = do
33+
(TyConI (DataD _ _ _ _ [RecC _ cs] _)) <- reify s
34+
concat <$> mapM (fieldLens s) cs

‎Haskell/advanced/2-view.hs‎

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
--
2+
-- cabal install template-haskell
3+
-- ghc 1-lens.hs 2-view.hs -o 2-view
4+
-- ./2-view
5+
--
6+
{-# LANGUAGE Rank2Types #-}
7+
{-# LANGUAGE TemplateHaskell #-}
8+
import Data.Functor.Const (Const(..))
9+
import Text.Printf (printf)
10+
11+
import Lens
12+
13+
view :: Lens s t a b -> s -> a
14+
view l s = getConst $ l Const s
15+
16+
data City = City
17+
{ _cityName :: String
18+
, _country :: String
19+
, _inEU :: Bool
20+
} deriving Show
21+
$(makeLens ''City)
22+
23+
data Person = Person
24+
{ _name :: String
25+
, _city :: City
26+
, _born :: Int
27+
} deriving Show
28+
$(makeLens ''Person)
29+
30+
person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
31+
32+
main = printf "view country of the city person was born in: %v\n"
33+
$ view (city . country) person

‎Haskell/advanced/3-set.hs‎

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
--
2+
-- cabal install template-haskell
3+
-- ghc 1-lens.hs 3-set.hs -o 3-set
4+
-- ./3-set
5+
--
6+
{-# LANGUAGE Rank2Types #-}
7+
{-# LANGUAGE TemplateHaskell #-}
8+
import Data.Functor.Identity (Identity(..))
9+
import Text.Printf (printf)
10+
11+
import Lens
12+
13+
set :: Lens' s a -> a -> s -> s
14+
set l a s = runIdentity $ l (Identity . const a) s
15+
16+
data City = City
17+
{ _cityName :: String
18+
, _country :: String
19+
, _inEU :: Bool
20+
} deriving Show
21+
$(makeLens ''City)
22+
23+
data Person = Person
24+
{ _name :: String
25+
, _city :: City
26+
, _born :: Int
27+
} deriving Show
28+
$(makeLens ''Person)
29+
30+
person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
31+
32+
main = printf "set inEU of the city person was born in: %v\n"
33+
$ show $ set (city . inEU) False person

‎Haskell/advanced/4-over.hs‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
--
2+
-- cabal install template-haskell
3+
-- ghc 1-lens.hs 4-over.hs -o 4-over
4+
-- ./4-over
5+
--
6+
{-# LANGUAGE Rank2Types #-}
7+
{-# LANGUAGE TemplateHaskell #-}
8+
9+
import Data.Char (toUpper)
10+
import Data.Functor.Identity (Identity(..))
11+
import Text.Printf (printf)
12+
13+
import Lens
14+
15+
over :: Lens' s a -> (a -> a) -> s -> s
16+
over l ab s = runIdentity $ l (Identity . ab) s
17+
18+
data City = City
19+
{ _cityName :: String
20+
, _country :: String
21+
, _inEU :: Bool
22+
} deriving Show
23+
$(makeLens ''City)
24+
25+
data Person = Person
26+
{ _name :: String
27+
, _city :: City
28+
, _born :: Int
29+
} deriving Show
30+
$(makeLens ''Person)
31+
32+
person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
33+
34+
main = printf "over name of the city person was born in: %v\n"
35+
$ show $ over (city . cityName) (map toUpper) person

‎Haskell/advanced/5-together.hs‎

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
--
2+
-- cabal install template-haskell
3+
-- ghc 1-lens.hs 5-together.hs -o 5-together
4+
-- ./5-together
5+
--
6+
{-# LANGUAGE Rank2Types #-}
7+
{-# LANGUAGE TemplateHaskell #-}
8+
9+
import Data.Char (toUpper)
10+
import Data.Functor.Const (Const(..))
11+
import Data.Functor.Identity (Identity(..))
12+
import Text.Printf (printf)
13+
14+
import Lens
15+
16+
view :: Lens s t a b -> s -> a
17+
view l s = getConst $ l Const s
18+
19+
set :: Lens' s a -> a -> s -> s
20+
set l a s = runIdentity $ l (Identity . const a) s
21+
22+
over :: Lens' s a -> (a -> a) -> s -> s
23+
over l ab s = runIdentity $ l (Identity . ab) s
24+
25+
data City = City
26+
{ _cityName :: String
27+
, _country :: String
28+
, _inEU :: Bool
29+
} deriving Show
30+
$(makeLens ''City)
31+
32+
data Person = Person
33+
{ _name :: String
34+
, _city :: City
35+
, _born :: Int
36+
} deriving Show
37+
$(makeLens ''Person)
38+
39+
person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
40+
41+
42+
main = do
43+
printf "view country of the city person was born in: %v\n"
44+
$ view (city . country) person
45+
printf "set inEU of the city person was born in: %v\n"
46+
$ show $ set (city . inEU) False person
47+
printf "over name of the city person was born in: %v\n"
48+
$ show $ over (city . cityName) (map toUpper) person

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /