Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 383 lines (318 sloc) 9.2 KB
#!/usr/bin/env stack
-- stack --install-ghc ghci --package profunctors --package refined-0.2.3.0 --package containers --resolver nightly-2018-06-06
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
import Data.Bifunctor (first)
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Profunctor
import Numeric.Natural
import Refined hiding (NonEmpty)
import qualified Data.Set as S
-- This file can be "executed"!
--
-- $ ./lenses-and-prisms.hs
--
-- T
-- Challenge: write a `match` for the "init and last" sum decomposition
-- using only one fold and no partial functions or booleans.
-- | Difference list
type Diff a = [a] -> [a]
matchInitLast :: [a] -> Either () ([a], a)
matchInitLast = (fmap . first) ($[]) -- "extract" the difference list
. foldl' go (Left ())
where
go :: Either () (Diff a, a)
-> a
-> Either () (Diff a, a)
go (Left _ ) x = Right (id , x)
go (Right (ys, y)) x = Right (ys . (y:), x)
-- Challenge: (Bool -> a) is (a, a)
boolFunction1 :: Lens' (Bool -> a) a
boolFunction1 = Lens'
{ split = \f -> (f False, f True )
, unsplit = \(x, y) -> \case False -> x
True -> y
}
boolFunction2 :: Lens' (Bool -> a) a
boolFunction2 = Lens'
{ split = \f -> (f True , f False)
, unsplit = \(x, y) -> \case False -> y
True -> x
}
-- Challenge: mysteryPrisms
mysteryPrism1 :: Prism' (Bool, a) a
mysteryPrism1 = Prism'
{ match = \case
(False, x) -> Left x
(True , x) -> Right x
, inject = \case
Left x -> (False, x)
Right x -> (True , x)
}
mysteryPrism2 :: Prism' (Bool, a) a
mysteryPrism2 = Prism'
{ match = \case
(False, x) -> Right x
(True , x) -> Left x
, inject = \case
Left x -> (True , x)
Right x -> (False, x)
}
-- Challenge: compose prisms and lenses
data Lens' s a = forall q. Lens'
{ split :: s -> (a, q)
, unsplit :: (a, q) -> s
}
(.&.) :: Lens' a b
-> Lens' b c
-> Lens' a c
Lens' splitX unsplitX .&. Lens' splitY unsplitY = Lens'
{ split = \x ->
let (y, q) = splitX x
(z, r) = splitY y
in (z, (q, r))
, unsplit = \(z, (q, r)) ->
let y = unsplitY (z, r)
x = unsplitX (y, q)
in x
}
data Prism' s a = forall q. Prism'
{ match :: s -> Either a q
, inject :: Either a q -> s
}
(.|.) :: Prism' a b
-> Prism' b c
-> Prism' a c
Prism' matchX injectX .|. Prism' matchY injectY = Prism'
{ match = \x -> case matchX x of
Left y -> case matchY y of
Left z -> Left z
Right r -> Right (Right r)
Right q -> Right (Left q)
, inject = \case
Left z -> injectX (Left (injectY (Left z )))
Right (Left q) -> injectX (Right q)
Right (Right r) -> injectX (Left (injectY (Right r)))
}
-- Utility
view :: Lens' s a -> (s -> a)
view Lens'{..} = fst . split
set :: Lens' s a -> (a -> s -> s)
set Lens'{..} newVal x = case split x of
(_, q) -> unsplit (newVal, q) -- "replace" the `a`
overL :: Lens' s a -> (a -> a) -> (s -> s)
overL Lens'{..} f = unsplit . first f . split -- instance Bifunctor (,)
preview :: Prism' s a -> (s -> Maybe a)
preview Prism'{..} x = case match x of
Left y -> Just y
Right _ -> Nothing
review :: Prism' s a -> (a -> s)
review Prism'{..} = inject . Left
overP :: Prism' s a -> (a -> a) -> (s -> s)
overP Prism'{..} f = inject . first f . match -- instance Bifunctor Either
-- Miscellaneous lenses
data Person = P
{ _pName :: String
, _pAge :: Int
}
pName :: Lens' Person String
pName = Lens'
{ split = \(P n a) -> (n, a)
, unsplit = \(n, a) -> P n a
}
pAge :: Lens' Person Int
pAge = Lens'
{ split = \(P n a) -> (a, n)
, unsplit = \(a, n) -> P n a
}
identityL :: Lens' a a
identityL = Lens'
{ split = \x -> (x, ())
, unsplit = \(x, _) -> x
}
united :: Lens' a ()
united = Lens'
{ split = \x -> ((), x)
, unsplit = \((), x) -> x
}
mysteryLens1 :: Lens' (Either a a) Bool
mysteryLens1 = Lens'
{ split = \case
Left x -> (False, x)
Right x -> (True , x)
, unsplit = \case
(False, x) -> Left x
(True , x) -> Right x
}
mysteryLens2 :: Lens' (Either a a) a
mysteryLens2 = Lens'
{ split = \case
Left x -> (x, False)
Right x -> (x, True )
, unsplit = \case
(x, False) -> Left x
(x, True ) -> Right x
}
flipEither :: Either a a -> Either a a
flipEither = overL mysteryLens1 not
isRight :: Either a a -> Bool
isRight = view mysteryLens1
fromEither :: Either a a -> a
fromEither = view mysteryLens2
mapEither :: (a -> a) -> Either a a -> Either a a
mapEither = overL mysteryLens2
type CharButNotA = Char
containsA :: Lens' (S.Set Char) Bool
containsA = Lens'
{ split = \s ->
( 'a' `S.member` s
, 'a' `S.delete` s :: S.Set CharButNotA
)
, unsplit = \case
(False, s) -> s
(True , s) -> 'a' `S.insert` (s :: S.Set CharButNotA)
}
-- Miscellaneous prisms
data Shape = Circle Double -- radius
| RegPoly Natural Double -- number of sides, length of sides
data Void -- no constructors, no valid inhabitants
absurd :: Void -> a -- A useful helper function when working with `Void`
absurd = \case -- empty case statement because we have
-- no constructors of 'Void' we need to
-- match on
_Circle :: Prism' Shape Double
_Circle = Prism'
{ match = \case
Circle r -> Left r
RegPoly n s -> Right (n, s)
, inject = \case
Left r -> Circle r
Right (n, s) -> RegPoly n s
}
_RegPoly :: Prism' Shape (Natural, Double)
_RegPoly = Prism'
{ match = \case
Circle r -> Right r
RegPoly n s -> Left (n, s)
, inject = \case
Left (n, s) -> RegPoly n s
Right r -> Circle r
}
_Nil :: Prism' [a] ()
_Nil = Prism'
{ match = \case
[] -> Left ()
x:xs -> Right (x :| xs)
, inject = \case
Left _ -> []
Right (x :| xs) -> x:xs
}
_Cons :: Prism' [a] (NonEmpty a)
_Cons = Prism'
{ match = \case
[] -> Right ()
x:xs -> Left (x :| xs)
, inject = \case
Left (x :| xs) -> x:xs
Right _ -> []
}
_Nil' :: Prism' [a] ()
_Nil' = Prism'
{ match = \xs -> if null xs
then Left ()
else Right (init xs, last xs)
, inject = \case
Left _ -> []
Right (xs, x) -> xs ++ [x]
}
_Snoc :: Prism' [a] ([a], a)
_Snoc = Prism'
{ match = \xs -> if null xs
then Right ()
else Left (init xs, last xs)
, inject = \case
Left (xs, x) -> xs ++ [x]
Right _ -> []
}
identityP :: Prism' a a
identityP = Prism'
{ match = Left
, inject = \case
Left x -> x
Right v -> absurd v
}
_Void :: Prism' a Void
_Void = Prism'
{ match = Right
, inject = \case
Left v -> absurd v
Right x -> x
}
type Not4 = Refined (NotEqualTo 4) Int
only4 :: Prism' Int ()
only4 = Prism'
{ match = \n -> case refineFail n of
Nothing -> Left ()
Just x -> Right (x :: Not4)
, inject = \case
Left _ -> 4
Right x -> unrefine x
}
refined4 :: Prism' Int Not4
refined4 = Prism'
{ match = \n -> case refineFail n of
Nothing -> Right ()
Just x -> Left x
, inject = \case
Left x -> unrefine x
Right _ -> 4
}
isEqualTo4 :: Int -> Bool -- Checks if a value is 4
isEqualTo4 = isJust . preview only4
four :: Int -- Is simply `4`
four = review only4 ()
makeNot4 :: Int -> Maybe Not4
makeNot4 = preview refined4
fromNot4 :: Not4 -> Int
fromNot4 = review refined4
onlyA :: Prism' Char ()
onlyA = Prism'
{ match = \case
'a' -> Left ()
x -> Right (x :: CharButNotA)
, inject = \case
Left _ -> 'a'
Right x -> x -- Right contains a CharButNotA
}
-- Profunctor Optics
iso :: Profunctor p
=> (s -> a)
-> (a -> s)
-> p a a
-> p s s
iso = dimap
makeLens
:: Strong p
=> (s -> (a, q)) -- ^ split
-> ((a, q) -> s) -- ^ unsplit
-> p a a -- ^ relationship on a
-> p s s -- ^ relationship on s
makeLens split unsplit =
iso split unsplit -- ^ p (a, q) (a, q) -> p s s
. first' -- ^ p a a -> p (a, q) (a, q)
makePrism
:: Choice p
=> (s -> Either a q) -- ^ match
-> (Either a q -> s) -- ^ inject
-> p a a -- ^ relationship on a
-> p s s -- ^ relationship on s
makePrism match inject =
iso match inject -- ^ p (Either a q) (Either a q) -> p s s
. left' -- ^ p a a -> p (Either a q) (Either a q)
main :: IO ()
main = return ()