src/Symantic/Parser/Automaton/Eval.hs

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