module MO.Base where
import MO.Run
import Prelude hiding (foldl)
import Data.Maybe
import Data.Typeable
import StringTable.Atom
import MO.Capture
import StringTable.AtomMap as AtomMap
import Data.Foldable (foldl)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
data (Typeable1 m, Monad m) => Invocant m
= forall a. (Show a, Eq a, Ord a, Typeable a) => MkInvocant
a
(AnyResponder m)
deriving Typeable
class Monad m => Codeable m c where
run :: c -> Arguments m -> m (Invocant m)
newtype NoCode m = NoCode (Invocant m)
instance (Typeable (NoCode m), Monad m) => Codeable m (NoCode m) where
run (NoCode obj) _ = return obj
instance Show (NoCode m) where
show _ = "<NoCode>"
newtype PureCode = PureCode (forall m. (Typeable1 m, Monad m) => Arguments m -> Invocant m)
instance (Typeable1 m, Monad m) => Codeable m PureCode where
run (PureCode f) a = return (f a)
instance Show PureCode where
show _ = "<PureCode>"
newtype Monad m => HsCode m = HsCode (Arguments m -> m (Invocant m))
instance (Typeable1 m, Monad m) => Codeable m (HsCode m) where
run (HsCode f) a = f a
instance Show (HsCode m) where
show _ = "<HsCode>"
type Arguments m = Capt (Invocant m)
withInvocant :: (Typeable1 m, Monad m) => Arguments m -> Invocant m -> Arguments m
withInvocant args x = CaptMeth{ c_invocant = x, c_feeds = c_feeds args }
getInvocant :: (Typeable1 m, Monad m) => Arguments m -> Maybe (Invocant m)
getInvocant CaptMeth{ c_invocant = x } = Just x
getInvocant _ = Nothing
namedArg :: (Typeable1 m, Monad m) => Arguments m -> Atom -> Maybe (Invocant m)
namedArg args key = foldl findArg Nothing (c_feeds args)
where
findArg Nothing MkFeed{ f_nameds = ns } = fmap (`Seq.index` 0) (AtomMap.lookup key ns)
findArg x _ = x
stubInvocant :: (Typeable1 m, Monad m) => Invocant m
stubInvocant = MkInvocant () emptyResponder