@@ -0,0 +1,149 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DuplicateRecordFields #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE NoMonomorphismRestriction #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeInType #-}
10+
11+module Main where
12+
13+import Control.Lens
14+import Data.Generics.Product
15+import Data.Generics.Sum
16+import GHC.Generics (Generic)
17+
18+-- $setup
19+--
20+-- >>> :set -XTypeApplications
21+-- >>> :set -XDataKinds
22+-- >>> :set -XFlexibleContexts
23+
24+main :: IO ()
25+main = putStrLn "hello"
26+
27+data Item = Item
28+ { name :: String
29+ , cost :: Cost
30+ } deriving (Generic, Show)
31+
32+newtype Cost = Cost Double deriving (Generic, Show)
33+
34+data Invoice p = Invoice
35+ { item :: Item
36+ , name :: String
37+ , number :: Int
38+ , priority :: p
39+ } deriving (Generic, Show)
40+
41+data Orders = Orders [ Invoice Int ] [ Invoice (Int, Double) ]
42+ deriving (Generic, Show)
43+
44+-- |
45+-- >>> view (field @"name") bourbon
46+-- "Bourbon"
47+-- >>> bourbon & field @"cost" .~ Cost 110
48+-- Item {name = "Bourbon", cost = Cost 110.0}
49+--
50+-- >>> bourbon & field @"cost" %~ (\(Cost c) -> (Cost (c + 5)))
51+-- Item {name = "Bourbon", cost = Cost 105.0}
52+--
53+-- >>> Invoice bourbon "Johnny" 2 2 & field @"priority" %~ (\i -> (i, 0))
54+-- Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "Johnny", number = 2, priority = (2,0)}
55+--
56+-- >>> view (field @"weight") bourbon
57+-- ...
58+-- ... The type Item does not contain a field named 'weight'.
59+-- ...
60+--
61+-- >>> bourbon & typed @Cost .~ Cost 200
62+-- Item {name = "Bourbon", cost = Cost 200.0}
63+--
64+-- >>> bourbon & typed %~ ("Chocolate " ++)
65+-- Item {name = "Chocolate Bourbon", cost = Cost 100.0}
66+--
67+-- >>> view (position @1) (42, "foo")
68+-- 42
69+-- >>> view (position @1) (42, "foo", False)
70+-- 42
71+-- >>> view (position @2) orders
72+-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
73+--
74+-- >>> view (position @2) orders
75+-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
76+--
77+-- >>> view (position @3) orders
78+-- ...
79+-- ... The type Orders does not contain a field at position 3
80+-- ...
81+--
82+-- >>> view (super @Item) (WItem "Bourbon" (Cost 2000) (Weight 0.03))
83+-- Item {name = "Bourbon", cost = Cost 2000.0}
84+--
85+-- >>> (WItem "Bourbon+" (Cost 500) (Weight 0.03)) & super @Item .~ bourbon
86+-- WItem {name = "Bourbon", cost = Cost 100.0, weight = Weight 3.0e-2}
87+--
88+-- >>> DInt 1 ^? _Ctor @"DInt"
89+-- Just 1
90+--
91+-- >>> _Typed # (False, "wurble") :: D
92+-- DPair False "wurble"
93+--
94+-- >>> EChar 'a' ^? _Sub @D
95+-- Nothing
96+--
97+-- >>> _Sub # DInt 10 :: E
98+-- EInt 10
99+bourbon :: Item
100+bourbon = Item "Bourbon" (Cost 100)
101+
102+orders :: Orders
103+orders = Orders [Invoice bourbon "Earl" 1 0 , Invoice bourbon "Johnny" 2 2]
104+ [Invoice bourbon "George" 2 (0, 3)]
105+
106+nameOfItem :: Invoice p -> String
107+nameOfItem = view (field @"item" . field @"name")
108+
109+thankYou :: Orders -> Orders
110+thankYou = over (types @Cost) (\(Cost c) -> Cost (c * 0.85))
111+
112+thankYouPriority :: Orders -> Orders
113+thankYouPriority = over (position @2 . types @Cost) (\(Cost c) -> Cost (c * 0.85))
114+
115+upgrade :: Double -> Invoice Int -> Invoice (Int, Double)
116+upgrade bribe invoice = over (param @0) (\i -> (i, bribe)) invoice
117+
118+audit :: Orders -> [Item]
119+audit = toListOf (types @Item)
120+
121+newtype Weight = Weight Double deriving (Generic, Show)
122+data WeighedItem = WItem
123+ { name :: String
124+ , cost :: Cost
125+ , weight :: Weight
126+ } deriving (Generic, Show)
127+
128+data D = DInt Int | DPair Bool String
129+
130+deriving instance Generic D
131+deriving instance Show D
132+
133+data E = EInt Int | EPair Bool String | EChar Char
134+
135+deriving instance Generic E
136+deriving instance Show E
137+
138+costInc :: HasTypes t Cost => t -> t
139+costInc = over (types @Cost) (\(Cost c) -> Cost (c + 5))
140+
141+modifyPriority :: (Int -> Int) -> Invoice Int -> Invoice Int
142+modifyPriority = over (types @Int)
143+
144+treeIncParam :: HasParam 0 s s Int Int => s -> s
145+treeIncParam = over (param @0) (+ 1)
146+
147+instance Functor Invoice where
148+ fmap = over (param @0)
149+