# mstksg/inCode

Switch branches/tags
Nothing to show
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 ()