module Generics.OneLiner.ADT1 (
module Generics.OneLiner.Info
, Constraint
, ADT1(..)
, ADT1Record(..)
, For(..)
, Extract(..)
, (:~>)(..)
, (!)
, (!~)
, at
, param
, component
, builds
, mbuilds
, build
) where
import Generics.OneLiner.Info
import GHC.Prim (Constraint)
import Control.Applicative
import Data.Functor.Identity
import Data.Functor.Constant
import Data.Monoid
import Data.Maybe (fromJust)
newtype f :~> g = Nat { getNat :: forall x. f x -> g x }
newtype Extract f = Extract { getExtract :: forall x. f x -> x }
data For (c :: (* -> *) -> Constraint) = For
class ADT1 t where
ctorIndex :: t a -> Int
ctorIndex _ = 0
ctorInfo :: t a -> Int -> CtorInfo
type Constraints t (c :: (* -> *) -> Constraint) :: Constraint
buildsA :: (Constraints t c, Applicative f)
=> for c
-> (FieldInfo (Extract t) -> f b)
-> (forall s. c s => FieldInfo (t :~> s) -> f (s b))
-> [f (t b)]
default buildsA :: (c t, Constraints t c, Applicative f)
=> for c
-> (FieldInfo (Extract t) -> f b)
-> (forall s. c s => FieldInfo (t :~> s) -> f (s b))
-> [f (t b)]
buildsA for param sub = buildsRecA for param sub sub
buildsRecA :: (Constraints t c, Applicative f)
=> for c
-> (FieldInfo (Extract t) -> f b)
-> (forall s. c s => FieldInfo (t :~> s) -> f (s b))
-> (FieldInfo (t :~> t) -> f (t b))
-> [f (t b)]
buildsRecA for param sub _ = buildsA for param sub
class ADT1 t => ADT1Record t where
builds :: (ADT1 t, Constraints t c)
=> for c
-> (FieldInfo (Extract t) -> b)
-> (forall s. c s => FieldInfo (t :~> s) -> s b)
-> [t b]
builds for f g = runIdentity <$> buildsA for (Identity . f) (Identity . g)
mbuilds :: forall t c m for. (ADT1 t, Constraints t c, Monoid m)
=> for c
-> (FieldInfo (Extract t) -> m)
-> (forall s. c s => FieldInfo (t :~> s) -> m)
-> [m]
mbuilds for f g = getConstant <$> (buildsA for (Constant . f) (Constant . g) :: [Constant m (t b)])
build :: (ADT1Record t, Constraints t c)
=> for c
-> (FieldInfo (Extract t) -> b)
-> (forall s. c s => FieldInfo (t :~> s) -> s b)
-> t b
build for f g = head $ builds for f g
at :: ADT1 t => [a] -> t b -> a
at as t = as !! ctorIndex t
param :: (forall a. t a -> a) -> FieldInfo (Extract t)
param f = FieldInfo (Extract f)
component :: (forall a. t a -> s a) -> FieldInfo (t :~> s)
component f = FieldInfo (Nat f)
infixl 9 !
(!) :: t a -> FieldInfo (Extract t) -> a
t ! info = getExtract (project info) t
infixl 9 !~
(!~) :: t a -> FieldInfo (t :~> s) -> s a
t !~ info = getNat (project info) t
instance ADT1 Maybe where
ctorIndex Nothing = 0
ctorIndex Just{} = 1
ctorInfo _ 0 = ctor "Nothing"
ctorInfo _ 1 = ctor "Just"
type Constraints Maybe c = ()
buildsA _ f _ =
[ pure Nothing
, Just <$> f (param fromJust)
]
instance ADT1 [] where
ctorIndex [] = 0
ctorIndex (_:_) = 1
ctorInfo _ 0 = ctor "[]"
ctorInfo _ 1 = CtorInfo ":" False (Infix RightAssociative 5)
type Constraints [] c = c []
buildsRecA _ p _ r =
[ pure []
, (:) <$> p (param head) <*> r (component tail)
]