Skip to content

Instantly share code, notes, and snippets.

@jkachmar
Created May 13, 2020 17:41
Show Gist options
  • Save jkachmar/927c00817fffe5661981197359d4bb8c to your computer and use it in GitHub Desktop.
Save jkachmar/927c00817fffe5661981197359d4bb8c to your computer and use it in GitHub Desktop.
Total prism matching
import Control.Lens hiding (from, to)
import GHC.Generics
class Empty a where
impossible :: a -> x
default impossible :: (Generic a, GEmpty (Rep a)) => a -> x
impossible = gimpossible . from
instance Empty Void where
impossible = absurd
instance (Empty a, Empty b) => Empty (Either a b) where
impossible (Left a) = impossible a
impossible (Right b) = impossible b
instance Empty a => Empty ((,) a b) where
impossible (a, _) = impossible a
class GEmpty f where
gimpossible :: f a -> x
instance GEmpty V1 where
gimpossible _ = undefined
instance (GEmpty a, GEmpty b) => GEmpty (a :+: b) where
gimpossible (L1 l) = gimpossible l
gimpossible (R1 r) = gimpossible r
instance Empty a => GEmpty (K1 i a) where
gimpossible (K1 k) = impossible k
instance GEmpty a => GEmpty (M1 i c a) where
gimpossible (M1 m) = gimpossible m
instance GEmpty a => GEmpty (a :*: b) where
gimpossible (a :*: _) = gimpossible a
_case :: Empty a => a -> x
_case = impossible
_default :: x -> a -> x
_default x _ = x
on ::
APrism s t a Void ->
(a -> o) ->
(t -> o) ->
s ->
o
on thisPrism onMatch nonMatch input = case (matching thisPrism input) of
Left l -> nonMatch l
Right r -> onMatch r
example :: Either Char Int -> String
example =
_case
& on _Left (\c -> replicate 3 c)
& on _Right (\n -> replicate n '!')
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment