symantic-grammar/Language/Symantic/Grammar/Meta.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 module Language.Symantic.Grammar.Meta where
   8
   9 import Data.Proxy (Proxy(..))
  10 import Data.Typeable (Typeable)
  11
  12 -- * Type 'Gram_Reader'
  13 class Gram_Reader st g where
  14         g_ask_before :: g (st -> a) -> g a
  15         g_ask_after  :: g (st -> a) -> g a
  16
  17 -- * Type 'Gram_State'
  18 class Gram_State st g where
  19         g_state_before :: g (st -> (st, a)) -> g a
  20         g_state_after  :: g (st -> (st, a)) -> g a
  21         g_get_before   :: g (st -> a) -> g a
  22         g_get_after    :: g (st -> a) -> g a
  23         g_put          :: g (st, a) -> g a
  24         default g_get_before :: Functor g => g (st -> a) -> g a
  25         default g_get_after  :: Functor g => g (st -> a) -> g a
  26         default g_put        :: Functor g => g (st, a) -> g a
  27         g_get_before g = g_state_before ((\f -> \st -> (st, f st)) <$> g)
  28         g_get_after  g = g_state_after ((\f -> \st -> (st, f st)) <$> g)
  29         g_put        g = g_state_after ((\(st, a) -> \_st -> (st, a)) <$> g)
  30
  31 -- * Class 'Gram_Error'
  32 -- | Symantics for handling errors at the semantic level (not the syntaxic one).
  33 class Gram_Error err g where
  34         g_catch :: g (Either err a) -> g a
  35
  36 -- * Class 'Inj_Error'
  37 class Inj_Error a b where
  38         inj_Error :: a -> b
  39 instance Inj_Error err e => Inj_Error err (Either e a) where
  40         inj_Error = Left . inj_Error
  41
  42 lift_Error ::
  43  forall e0 err e1 a.
  44  Inj_Error e0 e1 =>
  45  Inj_Error e1 err =>
  46  Proxy e1 -> Either e0 a -> Either err a
  47 lift_Error _e1 (Right a) = Right a
  48 lift_Error _e1 (Left e)  = Left $ inj_Error @e1 @err $ inj_Error @e0 @e1 e
  49
  50 -- * Class 'Source'
  51 class Source src where
  52         noSource :: src
  53 instance Source () where
  54         noSource = ()
  55
  56 -- ** Class 'Inj_Source'
  57 class Source src => Inj_Source a src where
  58         inj_Source :: a -> src
  59 instance Inj_Source a () where
  60         inj_Source _ = ()
  61
  62 -- ** Type family 'SourceOf'
  63 type family SourceOf a
  64
  65 -- ** Type 'Sourced'
  66 class Source (SourceOf a) => Sourced a where
  67         sourceOf  :: a -> SourceOf a
  68         setSource :: a -> SourceOf a -> a
  69 infixl 5 `setSource`
  70
  71 source :: Inj_Source src (SourceOf a) => Sourced a => a -> src -> a
  72 source a src = a `setSource` inj_Source src
  73
  74 -- ** Type 'Source_Input'
  75 type family Source_Input (src :: *) :: *
  76 type instance Source_Input () = ()
  77
  78 -- ** Type 'Span'
  79 data Span src
  80  =   Span
  81  {   spanBegin :: !src
  82  ,   spanEnd   :: !src
  83  } deriving (Eq, Ord, Show, Typeable)
  84
  85 -- ** Class 'Gram_Source'
  86 class
  87  ( Gram_Reader (Source_Input src) g
  88  , Inj_Source (Span (Source_Input src)) src
  89  ) => Gram_Source src g where
  90         g_source :: Functor g => g (src -> a) -> g a
  91         g_source g =
  92                 g_ask_after $ g_ask_before $
  93                  (\f (beg::Source_Input src) (end::Source_Input src) ->
  94                         f (inj_Source $ Span beg end::src))
  95                  <$> g
  96 instance
  97  ( Gram_Reader (Source_Input src) g
  98  , Inj_Source (Span (Source_Input src)) src
  99  ) => Gram_Source src g
 100
 101 -- ** Type 'At'
 102 -- | Attach a 'Source' to something.
 103 data At src a
 104  =   At
 105  {   at   :: !src
 106  ,   unAt :: !a
 107  } deriving (Eq, Functor, Ord, Show, Typeable)