src/Symantic/Parser/Automaton/Eval.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 module Symantic.Parser.Automaton.Eval where
   3
   4 import Control.Monad (Monad(..))
   5 import Data.Bool (Bool)
   6 import Data.Char (Char)
   7 import Data.Either (Either(..))
   8 import Data.Function (($))
   9 import Data.String (String)
  10 import Language.Haskell.TH (CodeQ, Code(..))
  11 import Prelude (($!))
  12 import qualified Data.Eq as Eq
  13 import qualified Language.Haskell.TH.Syntax as TH
  14
  15 import Symantic.Univariant.Trans
  16 import Symantic.Parser.Automaton.Input
  17 import Symantic.Parser.Automaton.Instructions
  18 import qualified Symantic.Parser.Staging as H
  19
  20 -- * Type 'Eval'
  21 newtype Eval inp vs es ret a = Eval { unEval ::
  22   EvalCtx inp vs es ret a -> CodeQ (Either ParsingError a)
  23 }
  24
  25 type Cont inp a x = x -> inp -> Either ParsingError a
  26 type SubRoutine inp a x = Cont inp a x -> inp -> ExceptionHandler inp a -> Either ParsingError a
  27 type ParsingError = String
  28 type ExceptionHandler inp a = inp -> Either ParsingError a
  29
  30 -- ** Type 'EvalCtx'
  31 data EvalCtx inp vs (es::Peano) r a = EvalCtx
  32   { valueStack :: ValueStack vs
  33   , exceptionStack :: ExceptionStack inp es a
  34   , input :: CodeQ inp
  35   , inputOps :: InputOps inp
  36   , retCode :: CodeQ (Cont inp a r)
  37   }
  38
  39 -- ** Type 'ValueStack'
  40 data ValueStack vs where
  41   ValueStackEmpty :: ValueStack '[]
  42   ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)
  43
  44 -- ** Type 'ExceptionStack'
  45 data ExceptionStack inp es a where
  46   ExceptionStackEmpty :: ExceptionStack inp 'Zero a
  47   ExceptionStackCons :: CodeQ (ExceptionHandler inp a) -> ExceptionStack inp es a -> ExceptionStack inp ('Succ es) a
  48
  49 instance Stackable Eval where
  50   push x k = Eval $ \inh -> unEval k inh
  51     { valueStack = ValueStackCons (liftCode x) (valueStack inh) }
  52   pop k = Eval $ \inh -> unEval k inh
  53     { valueStack = let ValueStackCons _ xs = valueStack inh in xs }
  54   liftI2 f k = Eval $ \inh -> unEval k inh
  55     { valueStack =
  56       let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
  57       ValueStackCons (liftCode2 f x y) xs
  58     }
  59   swap k = Eval $ \inh -> unEval k inh
  60     { valueStack =
  61         let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
  62         ValueStackCons x (ValueStackCons y xs)
  63     }
  64 instance Branchable Eval where
  65   case_ kx ky = Eval $ \inh ->
  66     let ValueStackCons v vs = valueStack inh in
  67     [||
  68       case $$v of
  69         Left  x -> $$(unEval kx inh{ valueStack = ValueStackCons [||x||] vs })
  70         Right y -> $$(unEval ky inh{ valueStack = ValueStackCons [||y||] vs })
  71     ||]
  72   choices fs ks kd = Eval $ \inh ->
  73     let ValueStackCons v vs = valueStack inh in
  74     go inh{valueStack = vs} v fs ks
  75     where
  76     go inh x (f:fs') (Eval k:ks') = [||
  77       if $$(liftCode1 f x) then $$(k inh)
  78       else $$(go inh x fs' ks')
  79       ||]
  80     go inh _ _ _ = unEval kd inh
  81 instance Exceptionable Eval where
  82   fail = Eval $ \inh ->
  83     let ExceptionStackCons e _es = exceptionStack inh in
  84     [|| $$e $$(input inh) ||]
  85   commit k = Eval $ \inh ->
  86     let ExceptionStackCons _e es = exceptionStack inh in
  87     unEval k inh{exceptionStack = es}
  88   catch k h = Eval $ \inh ->
  89     setupHandler inh (buildHandler inh h) k
  90 instance Inputable Eval where
  91   seek k = Eval $ \inh ->
  92     let ValueStackCons input vs = valueStack inh in
  93     unEval k inh{valueStack = vs, input}
  94   tell k = Eval $ \inh ->
  95     unEval k inh{valueStack = ValueStackCons (input inh) (valueStack inh)}
  96 instance Routinable Eval where
  97   call (Label n) k = Eval $ \inh ->
  98     callWithContinuation (Code $ TH.unsafeTExpCoerce (return (TH.VarE n))) (suspend k inh) (input inh) (exceptionStack inh)
  99   jump (Label n) = Eval $ \inh ->
 100     callWithContinuation (Code $ TH.unsafeTExpCoerce (return (TH.VarE n))) (retCode inh) (input inh) (exceptionStack inh)
 101   ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
 102   subroutine _n _v k = k
 103 instance Readable Eval where
 104   read p k = sat (liftCode p) k fail
 105
 106 {-
 107 evalSat ::
 108   -- InputPosition inp =>
 109   -- HandlerOps inp =>
 110   InstrPure (Char -> Bool) ->
 111   Eval inp (Char ': vs) ('Succ es) r a ->
 112   Eval inp vs ('Succ es) r a
 113 evalSat p k = do
 114   bankrupt <- asks isBankrupt
 115   hasChange <- asks hasCoin
 116   if | bankrupt -> maybeEmitCheck (Just 1) <$> k
 117      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
 118      | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
 119   where
 120   maybeEmitCheck Nothing mk inh = sat (genDefunc p) mk (raise inh) inh
 121   maybeEmitCheck (Just n) mk inh =
 122     [|| let bad = $$(raise inh) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] inh)||]
 123 -}
 124
 125 sat ::
 126   CodeQ (Char -> Bool) ->
 127   Eval inp (Char ': vs) es r a ->
 128   Eval inp vs es r a ->
 129   Eval inp vs es r a
 130 sat p k bad = Eval $ \inh ->
 131   next (inputOps inh) (input inh) $ \c inp -> [||
 132     if $$p $$c
 133     then $$(unEval k inh
 134       { valueStack = ValueStackCons c (valueStack inh)
 135       , input = inp
 136       })
 137     else $$(unEval bad inh)
 138   ||]
 139
 140
 141 callWithContinuation ::
 142   CodeQ (SubRoutine inp a x) ->
 143   CodeQ (Cont inp a x) ->
 144   CodeQ inp ->
 145   ExceptionStack inp ('Succ es) a ->
 146   CodeQ (Either ParsingError a)
 147 callWithContinuation sub r inp (ExceptionStackCons h _) =
 148   [|| $$sub $$r $$inp $! $$h ||]
 149
 150 suspend ::
 151   Eval inp (x ': xs) es r a ->
 152   EvalCtx inp xs es r a ->
 153   CodeQ (Cont inp a x)
 154 suspend k inh = [|| \x !inp ->
 155   $$(unEval k inh
 156     { valueStack = ValueStackCons [||x||] (valueStack inh)
 157     , input = [||inp||]
 158     }
 159   )||]
 160
 161 resume :: CodeQ (Cont inp a x) -> Eval inp (x ': xs) es r a
 162 resume k = Eval $ \inh ->
 163   let ValueStackCons x _ = valueStack inh in
 164   [|| $$k $$x $$(input inh) ||]
 165
 166 setupHandler ::
 167   EvalCtx inp vs es r a ->
 168   (CodeQ inp -> CodeQ (ExceptionHandler inp a)) ->
 169   Eval inp vs ('Succ es) r a ->
 170   CodeQ (Either ParsingError a)
 171 setupHandler inh handler k = [||
 172   $$(unEval k inh
 173     { exceptionStack = ExceptionStackCons
 174       (handler (input inh))
 175       (exceptionStack inh)
 176     })
 177   ||]
 178 buildHandler ::
 179   EvalCtx inp vs es r a ->
 180   Eval inp (inp ': vs) es r a ->
 181   CodeQ inp -> CodeQ (ExceptionHandler inp a)
 182 buildHandler inh handler e = [|| \inp ->
 183   $$(unEval handler inh
 184     { valueStack = ValueStackCons e (valueStack inh)
 185     , input = [||inp||]
 186     })
 187   ||]
 188
 189 liftCode :: InstrPure a -> CodeQ a
 190 liftCode = trans
 191 {-# INLINE liftCode #-}
 192
 193 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
 194 liftCode1 p a = case p of
 195   InstrPureSameOffset -> [|| $$same $$a ||]
 196   InstrPureHaskell h -> go a h
 197   where
 198   go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
 199   go qa = \case
 200     (H.:$) -> [|| \x -> $$qa x ||]
 201     (H.:.) -> [|| \g x -> $$qa (g x) ||]
 202     H.Flip -> [|| \x y -> $$qa y x ||]
 203     (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
 204     H.Const -> [|| \_ -> $$qa ||]
 205     H.Flip H.:@ H.Const -> H.id
 206     h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
 207     H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
 208     H.Id -> qa
 209     h -> [|| $$(trans h) $$qa ||]
 210
 211 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
 212 liftCode2 p a b = case p of
 213   InstrPureSameOffset -> [|| $$same $$a $$b ||]
 214   InstrPureHaskell h -> go a b h
 215   where
 216   go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
 217   go qa qb = \case
 218     (H.:$) -> [|| $$qa $$qb ||]
 219     (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
 220     H.Flip -> [|| \x -> $$qa x $$qb ||]
 221     H.Flip H.:@ H.Const -> [|| $$qb ||]
 222     H.Flip H.:@ f -> go qb qa f
 223     H.Const -> [|| $$qa ||]
 224     H.Cons -> [|| $$qa : $$qb ||]
 225     h -> [|| $$(trans h) $$qa $$qb ||]