{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TypeApplications #-} module Main where import Control.Lens import Data.Maybe (maybeToList) import Data.Generics.Product import Data.Generics.Sum import GHC.Generics (Generic) -- $setup -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XFlexibleContexts main :: IO () main = putStrLn "hello" data Item = Item { name :: String , cost :: Cost } deriving (Generic, Show) newtype Cost = Cost Double deriving (Generic, Show) data Invoice p = Invoice { item :: Item , name :: String , number :: Int , priority :: p } deriving (Generic, Show) data Orders = Orders [ Invoice Int ] [ Invoice (Int, Double) ] deriving (Generic, Show) -- | -- >>> view (field @"name") bourbon -- "Bourbon" -- >>> bourbon & field @"cost" .~ Cost 110 -- Item {name = "Bourbon", cost = Cost 110.0} -- -- >>> bourbon & field @"cost" %~ (\(Cost c) -> (Cost (c + 5))) -- Item {name = "Bourbon", cost = Cost 105.0} -- -- >>> Invoice bourbon "Johnny" 2 2 & field @"priority" %~ (\i -> (i, 0)) -- Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "Johnny", number = 2, priority = (2,0)} -- -- >>> view (field @"weight") bourbon -- ... -- ... The type Item does not contain a field named 'weight'. -- ... -- -- >>> bourbon & typed @Cost .~ Cost 200 -- Item {name = "Bourbon", cost = Cost 200.0} -- -- >>> bourbon & typed %~ ("Chocolate " ++) -- Item {name = "Chocolate Bourbon", cost = Cost 100.0} -- -- >>> view (position @1) (42, "foo") -- 42 -- >>> view (position @1) (42, "foo", False) -- 42 -- >>> view (position @2) orders -- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}] -- -- >>> view (position @2) orders -- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}] -- -- >>> view (position @3) orders -- ... -- ... The type Orders does not contain a field at position 3 -- ... -- -- >>> view (super @Item) (WItem "Bourbon" (Cost 2000) (Weight 0.03)) -- Item {name = "Bourbon", cost = Cost 2000.0} -- -- >>> (WItem "Bourbon+" (Cost 500) (Weight 0.03)) & super @Item .~ bourbon -- WItem {name = "Bourbon", cost = Cost 100.0, weight = Weight 3.0e-2} -- -- >>> DInt 1 ^? _Ctor @"DInt" -- Just 1 -- -- >>> _Typed # (False, "wurble") :: D -- DPair False "wurble" -- -- >>> EChar 'a' ^? _Sub @D -- Nothing -- -- >>> _Sub # DInt 10 :: E -- EInt 10 bourbon :: Item bourbon = Item "Bourbon" (Cost 100) orders :: Orders orders = Orders [Invoice bourbon "Earl" 1 0 , Invoice bourbon "Johnny" 2 2] [Invoice bourbon "George" 2 (0, 3)] nameOfItem :: Invoice p -> String nameOfItem = view (field @"item" . field @"name") thankYou :: Orders -> Orders thankYou = over (types @Cost) (\(Cost c) -> Cost (c * 0.85)) thankYouPriority :: Orders -> Orders thankYouPriority = over (position @2 . types @Cost) (\(Cost c) -> Cost (c * 0.85)) upgrade :: Double -> Invoice Int -> Invoice (Int, Double) upgrade bribe invoice = over (param @0) (\i -> (i, bribe)) invoice audit :: Orders -> [Item] audit = toListOf (types @Item) newtype Weight = Weight Double deriving (Generic, Show) data WeighedItem = WItem { name :: String , cost :: Cost , weight :: Weight } deriving (Generic, Show) data D = DInt Int | DPair Bool String deriving (Generic, Show) data E = EInt Int | EPair Bool String | EChar Char deriving (Generic, Show) costInc :: HasTypes t Cost => t -> t costInc = over (types @Cost) (\(Cost c) -> Cost (c + 5)) modifyPriority :: (Int -> Int) -> Invoice Int -> Invoice Int modifyPriority = over (types @Int) treeIncParam :: HasParam 0 s s Int Int => s -> s treeIncParam = over (param @0) (+ 1) instance Functor Invoice where fmap = over (param @0) data Numbers = Numbers Int Float Double deriving (Show, Generic) -- | -- >>> constraints' @Num (\x -> pure (x + 20)) numbers -- Numbers 30 40.0 50.0 numbers = Numbers 10 20.0 30.0