Implement advanced Haskell lenses

Author: DzyubSpirit

.gitignore

@@ -1,3 +1,7 @@
 node_modules
 *.log
 .DS_Store
+*.hi
+*.o
+*.dyn_hi
+*.dyn_o

Haskell/advanced/1-lens.hs

@@ -0,0 +1,34 @@
+-- cabal install template-haskell
+--
+-- Lens is implementation of most common of optics.
+--
+-- Real makeLens implementation more complex supporting all of Haskell syntax
+-- cases for creating types.
+--
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Lens where
+
+import Language.Haskell.TH
+
+type Lens s t a b = forall f . Functor f => (a -> f b) -> s -> f t
+type Lens' s a = Lens s s a a
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens getter setter = \afb s -> setter s <$> afb (getter s)
+
+fieldLens :: Name -> (Name, a, Type) -> Q [Dec]
+fieldLens s (v, _, a) = do
+  sVar <- newName "s"
+  bVar <- newName "b"
+  let setter = return $ LamE [VarP sVar, VarP bVar] $ RecUpdE (VarE sVar) [(v, VarE bVar)]
+  body <- NormalB <$> [| lens $(return $ VarE v) $setter |]
+  let fn = mkName $ tail $ nameBase v
+  return [ SigD fn (AppT (AppT (ConT $ mkName "Lens'") (ConT s)) a)
+         , FunD fn [Clause [] body []]
+         ]
+
+makeLens :: Name -> Q [Dec]
+makeLens s = do
+  (TyConI (DataD _ _ _ _ [RecC _ cs] _)) <- reify s
+  concat <$> mapM (fieldLens s) cs

Haskell/advanced/2-view.hs

@@ -0,0 +1,33 @@
+--
+-- cabal install template-haskell
+-- ghc 1-lens.hs 2-view.hs -o 2-view
+-- ./2-view
+--
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Data.Functor.Const (Const(..))
+import Text.Printf (printf)
+
+import Lens
+
+view :: Lens s t a b -> s -> a
+view l s = getConst $ l Const s
+
+data City = City
+  { _cityName :: String
+  , _country :: String
+  , _inEU :: Bool
+  } deriving Show
+$(makeLens ''City)
+
+data Person = Person 
+  { _name :: String
+  , _city :: City
+  , _born :: Int
+  } deriving Show
+$(makeLens ''Person)
+
+person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
+
+main = printf "view country of the city person was born in: %v\n"
+     $ view (city . country) person

Haskell/advanced/3-set.hs

@@ -0,0 +1,33 @@
+--
+-- cabal install template-haskell
+-- ghc 1-lens.hs 3-set.hs -o 3-set
+-- ./3-set
+--
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Data.Functor.Identity (Identity(..))
+import Text.Printf (printf)
+
+import Lens
+
+set :: Lens' s a -> a -> s -> s
+set l a s = runIdentity $ l (Identity . const a) s 
+
+data City = City
+  { _cityName :: String
+  , _country :: String
+  , _inEU :: Bool
+  } deriving Show
+$(makeLens ''City)
+
+data Person = Person 
+  { _name :: String
+  , _city :: City
+  , _born :: Int
+  } deriving Show
+$(makeLens ''Person)
+
+person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
+
+main = printf "set inEU of the city person was born in: %v\n"
+     $ show $ set (city . inEU) False person

Haskell/advanced/4-over.hs

@@ -0,0 +1,35 @@
+--
+-- cabal install template-haskell
+-- ghc 1-lens.hs 4-over.hs -o 4-over
+-- ./4-over
+--
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+import Data.Char (toUpper)
+import Data.Functor.Identity (Identity(..))
+import Text.Printf (printf)
+
+import Lens
+
+over :: Lens' s a -> (a -> a) -> s -> s
+over l ab s = runIdentity $ l (Identity . ab) s 
+
+data City = City
+  { _cityName :: String
+  , _country :: String
+  , _inEU :: Bool
+  } deriving Show
+$(makeLens ''City)
+
+data Person = Person 
+  { _name :: String
+  , _city :: City
+  , _born :: Int
+  } deriving Show
+$(makeLens ''Person)
+
+person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
+
+main = printf "over name of the city person was born in: %v\n"
+     $ show $ over (city . cityName) (map toUpper) person

Haskell/advanced/5-together.hs

@@ -0,0 +1,48 @@
+--
+-- cabal install template-haskell
+-- ghc 1-lens.hs 5-together.hs -o 5-together
+-- ./5-together
+--
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+import Data.Char (toUpper)
+import Data.Functor.Const (Const(..))
+import Data.Functor.Identity (Identity(..))
+import Text.Printf (printf)
+
+import Lens
+
+view :: Lens s t a b -> s -> a
+view l s = getConst $ l Const s
+
+set :: Lens' s a -> a -> s -> s
+set l a s = runIdentity $ l (Identity . const a) s
+
+over :: Lens' s a -> (a -> a) -> s -> s
+over l ab s = runIdentity $ l (Identity . ab) s 
+
+data City = City
+  { _cityName :: String
+  , _country :: String
+  , _inEU :: Bool
+  } deriving Show
+$(makeLens ''City)
+
+data Person = Person 
+  { _name :: String
+  , _city :: City
+  , _born :: Int
+  } deriving Show
+$(makeLens ''Person)
+
+person = Person "Marcus Aurelius" (City "Rome" "Italy" True) 121
+
+
+main = do
+  printf "view country of the city person was born in: %v\n"
+     $ view (city . country) person
+  printf "set inEU of the city person was born in: %v\n"
+     $ show $ set (city . inEU) False person
+  printf "over name of the city person was born in: %v\n"
+     $ show $ over (city . cityName) (map toUpper) person