{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Language.Symantic.Grammar.Meta where import Data.Function (const) import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable) -- * Type 'Gram_Reader' class Gram_Reader st g where g_ask_before :: g (st -> a) -> g a g_ask_after :: g (st -> a) -> g a -- * Type 'Gram_State' class Gram_State st g where g_state_before :: g (st -> (st, a)) -> g a g_state_after :: g (st -> (st, a)) -> g a g_get_before :: g (st -> a) -> g a g_get_after :: g (st -> a) -> g a g_put :: g (st, a) -> g a default g_get_before :: Functor g => g (st -> a) -> g a default g_get_after :: Functor g => g (st -> a) -> g a default g_put :: Functor g => g (st, a) -> g a g_get_before g = g_state_before ((\f st -> (st, f st)) <$> g) g_get_after g = g_state_after ((\f st -> (st, f st)) <$> g) g_put g = g_state_after ((\(st, a) -> const (st, a)) <$> g) -- * Class 'Gram_Error' -- | Symantics for handling errors at the semantic level (not the syntaxic one). class Gram_Error err g where g_catch :: g (Either err a) -> g a -- * Class 'Inj_Error' class Inj_Error a b where inj_Error :: a -> b instance Inj_Error err e => Inj_Error err (Either e a) where inj_Error = Left . inj_Error lift_Error :: forall e0 err e1 a. Inj_Error e0 e1 => Inj_Error e1 err => Proxy e1 -> Either e0 a -> Either err a lift_Error _e1 (Right a) = Right a lift_Error _e1 (Left e) = Left $ inj_Error @e1 @err $ inj_Error @e0 @e1 e -- * Class 'Source' class Source src where noSource :: src instance Source () where noSource = () -- ** Class 'Inj_Source' class Source src => Inj_Source a src where inj_Source :: a -> src instance Inj_Source a () where inj_Source _ = () -- ** Type family 'SourceOf' type family SourceOf a -- ** Type 'Sourced' class Source (SourceOf a) => Sourced a where sourceOf :: a -> SourceOf a setSource :: a -> SourceOf a -> a infixl 5 `setSource` source :: Inj_Source src (SourceOf a) => Sourced a => a -> src -> a source a src = a `setSource` inj_Source src -- ** Type 'Source_Input' type family Source_Input (src :: *) :: * type instance Source_Input () = () -- ** Type 'Span' data Span src = Span { spanBegin :: !src , spanEnd :: !src } deriving (Eq, Ord, Show, Typeable) -- ** Class 'Gram_Source' class ( Gram_Reader (Source_Input src) g , Inj_Source (Span (Source_Input src)) src ) => Gram_Source src g where g_source :: Functor g => g (src -> a) -> g a g_source g = g_ask_after $ g_ask_before $ (\f (beg::Source_Input src) (end::Source_Input src) -> f (inj_Source $ Span beg end::src)) <$> g instance ( Gram_Reader (Source_Input src) g , Inj_Source (Span (Source_Input src)) src ) => Gram_Source src g -- ** Type 'At' -- | Attach a 'Source' to something. data At src a = At { at :: !src , unAt :: !a } deriving (Eq, Functor, Ord, Show, Typeable)