module Language.MSH.Selectors where
import Control.Applicative ((<$>))
import Control.Monad.Identity
import Control.Monad.State
data CallType = ExtCall
data RunnableQuery (ty :: CallType) obj st ctx r where
MkExtCall :: ctx (r, obj) -> RunnableQuery ExtCall obj st ctx r
class Functor ctx => CallCtx (ty :: CallType) ctx where
type CtxResult ty ctx r :: *
result :: RunnableQuery ty obj st ctx r -> CtxResult ty ctx r
object :: RunnableQuery ty obj st ctx r -> CtxResult ty ctx obj
instance (ctx ~ Identity) => CallCtx ExtCall ctx where
type CtxResult ExtCall ctx r = r
result (MkExtCall call) = fst $ runIdentity call
object (MkExtCall call) = snd $ runIdentity call
data MemberType = Mutable | Immutable
data FieldType = Method | Field
type family FieldComposeResult (lhs :: FieldType) (rhs :: FieldType) :: FieldType where
FieldComposeResult Method Method = Method
FieldComposeResult Method Field = Method
FieldComposeResult Field Method = Method
FieldComposeResult Field Field = Field
data Selector (ty :: FieldType) o s m a where
MkMethod :: StateT s m a ->
(o -> m (a, o)) ->
Selector Method o s m a
MkField :: (o -> m (a, o)) ->
StateT s m a ->
(o -> a -> m ((), o)) ->
(a -> StateT s m ()) ->
Selector Field o s m a
data This o s (m :: * -> *) a where
MkThis :: This o s m a
type family QueryObject obj :: *
type family QueryMonad obj (m :: * -> *) :: * -> *
type family QueryResult obj (ty :: FieldType) st (m :: * -> *) r :: *
infixr 8 .!
class Monad m => Object obj st m where
this :: This obj st m obj
this = MkThis
(.!) :: forall r ty.obj ->
Selector ty (QueryObject obj) st (QueryMonad obj m) r ->
QueryResult obj ty st m r
(.$) :: (Monad ctx, Functor f) => Selector lty obj st ctx (f a) -> Selector rty a st' Identity b -> Selector (FieldComposeResult lty rty) obj st ctx (f b)
(MkField eg ig es is) .$ (MkMethod ri re) = MkMethod
(ig >>= \x -> let p = fmap (runIdentity . re) x in is (fmap snd p) >> return (fmap fst p))
(\s -> eg s >>= \(x,s') -> let p = fmap (runIdentity . re) x in es s' (fmap snd p) >>= \(_,s'') -> return (fmap fst p, s''))
(MkField eg ig es is) .$ (MkField reg rig res ris) = MkField
undefined
undefined
undefined
undefined
(MkMethod li le) .$ (MkMethod ri re) = MkMethod
undefined
undefined
(MkMethod li le) .$ (MkField reg rig res ris) = MkMethod
undefined
undefined
type instance QueryMonad (Selector Method obj st ctx r) ctx' = ctx'
type instance QueryObject (Selector Method obj st ctx r) = r
type instance QueryResult (Selector Method obj st ctx r) ty st' m x =
Selector Method obj st ctx x
instance (Object obj st ctx, Object r st' Identity, m ~ Identity) =>
Object (Selector Method obj st ctx r) st' m where
(.!) (MkMethod li le) (MkMethod ri re) = MkMethod
(li >>= \r -> return $ fst $ runIdentity $ re r)
(\s -> le s >>= \(r, obj) -> return (fst $ runIdentity $ re r, obj))
(.!) (MkMethod li le) (MkField eg ig es is) = MkMethod
(li >>= \r -> return $ fst $ runIdentity $ eg r)
(\s -> le s >>= \(r, obj) -> return (fst $ runIdentity $ eg r, obj))
type instance QueryMonad (Selector Field obj st ctx r) ctx' = ctx'
type instance QueryObject (Selector Field obj st ctx r) = r
type instance QueryResult (Selector Field obj st ctx r) Method st' m x =
Selector Method obj st ctx x
type instance QueryResult (Selector Field obj st ctx r) Field st' m x =
Selector Field obj st ctx x
instance (Object obj st ctx, Object r st' Identity, m ~ Identity) =>
Object (Selector Field obj st ctx r) st' m where
(.!) (MkField eg ig es is) (MkMethod ri re) = MkMethod
(ig >>= \r -> let (r',s) = runIdentity (re r) in is s >> return r')
(\s -> eg s >>= \(r',s') -> let (r'',s'') = runIdentity (re r') in es s' s'' >>= \(_,s''') -> return (r'',s'''))
type instance QueryMonad (This obj st ctx r) ctx' = ctx'
type instance QueryObject (This obj st ctx r) = obj
type instance QueryResult (This obj st ctx r) ty st' m x = StateT st' ctx x
instance (Object obj st ctx, Object r st' ctx', ctx ~ ctx', st ~ st') =>
Object (This obj st ctx r) st' ctx' where
(.!) _ (MkMethod ri re) = ri
(.!) _ (MkField ge gi se si) = gi