src/Symantic/Parser/Machine/Eval.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
   5 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
   6 module Symantic.Parser.Machine.Eval where
   7
   8 import Control.Monad (Monad(..))
   9 import Data.Bool (Bool)
  10 import Data.Char (Char)
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Function (($))
  14 -- import Data.Functor ((<$>))
  15 import Data.Int (Int)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord, Ordering(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Set (Set)
  21 import Language.Haskell.TH (CodeQ, Code(..))
  22 import Prelude (($!))
  23 import Text.Show (Show(..))
  24 import qualified Data.Eq as Eq
  25 import qualified Data.Set as Set
  26 import qualified Language.Haskell.TH.Syntax as TH
  27
  28 import Symantic.Univariant.Trans
  29 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
  30 import Symantic.Parser.Machine.Input
  31 import Symantic.Parser.Machine.Instructions
  32 import qualified Symantic.Parser.Staging as H
  33
  34 -- * Type 'Eval'
  35 -- | Generate the 'CodeQ' parsing the input.
  36 newtype Eval inp vs es a = Eval { unEval ::
  37   EvalCtx inp vs es a ->
  38   CodeQ (Either (ParsingError inp) a)
  39 }
  40
  41 -- ** Type 'ParsingError'
  42 data ParsingError inp
  43   =  ParsingErrorStandard
  44   {  parsingErrorOffset :: Offset
  45   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
  46   ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
  47   }
  48 deriving instance Show (InputToken inp) => Show (ParsingError inp)
  49
  50 -- ** Type 'Offset'
  51 type Offset = Int
  52
  53 -- ** Type 'Cont'
  54 type Cont inp v a =
  55   {-farthestInput-}Cursor inp ->
  56   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  57   v ->
  58   Cursor inp ->
  59   Either (ParsingError inp) a
  60
  61 -- ** Type 'SubRoutine'
  62 type SubRoutine inp v a =
  63   {-ok-}Cont inp v a ->
  64   Cursor inp ->
  65   {-ko-}FailHandler inp a ->
  66   Either (ParsingError inp) a
  67
  68 -- ** Type 'FailHandler'
  69 type FailHandler inp a =
  70   {-failureInput-}Cursor inp ->
  71   {-farthestInput-}Cursor inp ->
  72   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  73   Either (ParsingError inp) a
  74
  75 {-
  76 -- *** Type 'FarthestError'
  77 data FarthestError inp = FarthestError
  78   { farthestInput :: Cursor inp
  79   , farthestExpecting :: [ErrorItem (InputToken inp)]
  80   }
  81 -}
  82
  83 eval ::
  84   forall inp ret.
  85   Ord (InputToken inp) =>
  86   Show (InputToken inp) =>
  87   TH.Lift (InputToken inp) =>
  88   -- InputToken inp ~ Char =>
  89   Input inp =>
  90   CodeQ inp ->
  91   Show (Cursor inp) =>
  92   Eval inp '[] ('Succ 'Zero) ret ->
  93   CodeQ (Either (ParsingError inp) ret)
  94 eval input (Eval k) = [||
  95   let _ = "eval" in
  96   -- Pattern bindings containing unlifted types
  97   -- should use an outermost bang pattern.
  98   let !(# init, readMore, readNext #) = $$(cursorOf input) in
  99   let evalRet = \_farInp _farExp v _inp -> Right v in
 100   let evalFail _failInp !farInp !farExp =
 101         Left ParsingErrorStandard
 102         { parsingErrorOffset = offset farInp
 103         , parsingErrorUnexpected =
 104             if readMore farInp
 105             then Just (let (# c, _ #) = readNext farInp in c)
 106             else Nothing
 107         , parsingErrorExpecting = Set.fromList farExp
 108         } in
 109   $$(k EvalCtx
 110     { valueStack = ValueStackEmpty
 111     , failStack = FailStackCons [||evalFail||] FailStackEmpty
 112     , retCode = [||evalRet||]
 113     , input = [||init||]
 114     , nextInput = [||readNext||]
 115     , moreInput = [||readMore||]
 116     -- , farthestError = [||Nothing||]
 117     , farthestInput = [||init||]
 118     , farthestExpecting = [|| [] ||]
 119     })
 120   ||]
 121
 122 -- ** Type 'EvalCtx'
 123 -- | This is a context only present at compile-time.
 124 data EvalCtx inp vs (es::Peano) a =
 125   ( TH.Lift (InputToken inp)
 126   , Cursorable (Cursor inp)
 127   , Show (InputToken inp)
 128   -- , InputToken inp ~ Char
 129   ) => EvalCtx
 130   { valueStack :: ValueStack vs
 131   , failStack :: FailStack inp es a
 132   , retCode :: CodeQ (Cont inp a a)
 133   , input :: CodeQ (Cursor inp)
 134   , moreInput :: CodeQ (Cursor inp -> Bool)
 135   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 136   , farthestInput :: CodeQ (Cursor inp)
 137   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
 138   }
 139
 140 -- ** Type 'ValueStack'
 141 data ValueStack vs where
 142   ValueStackEmpty :: ValueStack '[]
 143   ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)
 144                     -- TODO: maybe use H.Haskell instead of CodeQ ?
 145                     -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
 146
 147 -- ** Type 'FailStack'
 148 data FailStack inp es a where
 149   FailStackEmpty :: FailStack inp 'Zero a
 150   FailStackCons ::
 151     CodeQ (FailHandler inp a) ->
 152     FailStack inp es a ->
 153     FailStack inp ('Succ es) a
 154
 155 instance Stackable Eval where
 156   push x k = Eval $ \inh -> unEval k inh
 157     { valueStack = ValueStackCons (liftCode x) (valueStack inh) }
 158   pop k = Eval $ \inh -> unEval k inh
 159     { valueStack = let ValueStackCons _ xs = valueStack inh in xs }
 160   liftI2 f k = Eval $ \inh -> unEval k inh
 161     { valueStack =
 162       let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
 163       ValueStackCons (liftCode2 f x y) xs
 164     }
 165   swap k = Eval $ \inh -> unEval k inh
 166     { valueStack =
 167         let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
 168         ValueStackCons x (ValueStackCons y xs)
 169     }
 170 instance Branchable Eval where
 171   case_ kx ky = Eval $ \inh ->
 172     let ValueStackCons v vs = valueStack inh in
 173     [||
 174       case $$v of
 175         Left  x -> $$(unEval kx inh{ valueStack = ValueStackCons [||x||] vs })
 176         Right y -> $$(unEval ky inh{ valueStack = ValueStackCons [||y||] vs })
 177     ||]
 178   choices fs ks kd = Eval $ \inh ->
 179     let ValueStackCons v vs = valueStack inh in
 180     go inh{valueStack = vs} v fs ks
 181     where
 182     go inh x (f:fs') (Eval k:ks') = [||
 183       if $$(liftCode1 f x) then $$(k inh)
 184       else $$(go inh x fs' ks')
 185       ||]
 186     go inh _ _ _ = unEval kd inh
 187 instance Failable Eval where
 188   fail failExp = Eval $ \inh@EvalCtx{} ->
 189     let FailStackCons e _es = failStack inh in
 190     [||
 191     let (# farInp, farExp #) =
 192           case $$compareOffset $$(farthestInput inh) $$(input inh) of
 193             LT -> (# $$(input inh), failExp #)
 194             EQ -> (# $$(farthestInput inh), ($$(farthestExpecting inh) <> failExp) #)
 195             GT -> (# $$(farthestInput inh), $$(farthestExpecting inh) #) in
 196     {-
 197     trace ("fail: "
 198       <>" failExp="<>show @[ErrorItem Char] failExp
 199       <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting inh))
 200       <>" farExp="<>show @[ErrorItem Char] farExp) $
 201     -}
 202     $$e $$(input inh) farInp farExp
 203     ||]
 204   popFail k = Eval $ \inh ->
 205     let FailStackCons _e es = failStack inh in
 206     unEval k inh{failStack = es}
 207   catchFail ok ko = Eval $ \inh@EvalCtx{} -> [||
 208     let _ = "catchFail" in $$(unEval ok inh
 209       { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
 210           -- trace ("catchFail: " <> "farExp="<>show farExp) $
 211           $$(unEval ko inh
 212             -- Push the input as it was when entering the catchFail.
 213             { valueStack = ValueStackCons (input inh) (valueStack inh)
 214             -- Move the input to the failing position.
 215             , input = [||failInp||]
 216             -- Set the farthestInput to the farthest computed by 'fail'
 217             , farthestInput = [||farInp||]
 218             , farthestExpecting = [||farExp||]
 219             })
 220         ||] (failStack inh)
 221       })
 222     ||]
 223 instance Inputable Eval where
 224   loadInput k = Eval $ \inh ->
 225     let ValueStackCons input vs = valueStack inh in
 226     unEval k inh{valueStack = vs, input}
 227   pushInput k = Eval $ \inh ->
 228     unEval k inh{valueStack = ValueStackCons (input inh) (valueStack inh)}
 229 instance Routinable Eval where
 230   call (LetName n) k = Eval $ \inh ->
 231     callWithContinuation
 232       {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 233       {-ok-}(suspend k inh)
 234       (input inh)
 235       {-ko-}(failStack inh)
 236   jump (LetName n) = Eval $ \inh ->
 237     callWithContinuation
 238       {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 239       {-ok-}(retCode inh)
 240       (input inh)
 241       {-ko-}(failStack inh)
 242   ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
 243   subroutine (LetName n) sub k = Eval $ \inh -> Code $ TH.unsafeTExpCoerce $ do
 244     val <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 245       \(!ok) (!inp) ko ->
 246         $$(unEval sub inh
 247           { valueStack = ValueStackEmpty
 248           , failStack = FailStackCons [||ko||] FailStackEmpty
 249           , input = [||inp||]
 250           , retCode = [||ok||]
 251           })
 252       ||]
 253     let decl = TH.FunD n [TH.Clause [] (TH.NormalB val) []]
 254     exp <- TH.unTypeQ (TH.examineCode (unEval k inh))
 255     return (TH.LetE [decl] exp)
 256
 257 callWithContinuation ::
 258   {-sub-}CodeQ (SubRoutine inp v a) ->
 259   {-ok-}CodeQ (Cont inp v a) ->
 260   CodeQ (Cursor inp) ->
 261   FailStack inp ('Succ es) a ->
 262   CodeQ (Either (ParsingError inp) a)
 263 callWithContinuation sub ok inp (FailStackCons ko _) =
 264   [|| let _ = "callWithContinuation" in $$sub $$ok $$inp $! $$ko ||]
 265
 266 suspend ::
 267   {-k-}Eval inp (v ': vs) es a ->
 268   EvalCtx inp vs es a ->
 269   CodeQ (Cont inp v a)
 270 suspend k inh = [|| let _ = "suspend" in \farInp farExp v !inp ->
 271   $$(unEval k inh
 272     { valueStack = ValueStackCons [||v||] (valueStack inh)
 273     , input = [||inp||]
 274     , farthestInput = [||farInp||]
 275     , farthestExpecting = [||farExp||]
 276     }
 277   )||]
 278
 279 resume :: CodeQ (Cont inp v a) -> Eval inp (v ': vs) es a
 280 resume k = Eval $ \inh ->
 281   let ValueStackCons v _ = valueStack inh in
 282   [|| let _ = "resume" in $$k $$(farthestInput inh) $$(farthestExpecting inh) $$v $$(input inh) ||]
 283
 284 instance Readable Eval Char where
 285   read farExp p k =
 286     -- TODO: piggy bank
 287     maybeEmitCheck (Just 1) k
 288     where
 289     maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
 290     maybeEmitCheck (Just n) ok = Eval $ \inh ->
 291       let FailStackCons e es = failStack inh in
 292       [||
 293       let readFail = $$(e) in -- Factorize failure code
 294       $$((`unEval` inh{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
 295         {-ok-}(sat (liftCode p) ok
 296           {-ko-}(fail farExp))
 297         {-ko-}(fail farExp))
 298       ||]
 299
 300 sat ::
 301   forall inp vs es a.
 302   -- Cursorable (Cursor inp) =>
 303   -- InputToken inp ~ Char =>
 304   Ord (InputToken inp) =>
 305   TH.Lift (InputToken inp) =>
 306   {-predicate-}CodeQ (InputToken inp -> Bool) ->
 307   {-ok-}Eval inp (InputToken inp ': vs) ('Succ es) a ->
 308   {-ko-}Eval inp vs ('Succ es) a ->
 309   Eval inp vs ('Succ es) a
 310 sat p ok ko = Eval $ \inh -> [||
 311   let !(# c, cs #) = $$(nextInput inh) $$(input inh) in
 312   if $$p c
 313   then $$(unEval ok inh
 314     { valueStack = ValueStackCons [||c||] (valueStack inh)
 315     , input = [||cs||]
 316     })
 317   else let _ = "sat.else" in $$(unEval ko inh)
 318   ||]
 319
 320 {-
 321 evalSat ::
 322   -- Cursorable inp =>
 323   -- HandlerOps inp =>
 324   InstrPure (Char -> Bool) ->
 325   Eval inp (Char ': vs) ('Succ es) a ->
 326   Eval inp vs ('Succ es) a
 327 evalSat p k = do
 328   bankrupt <- asks isBankrupt
 329   hasChange <- asks hasCoin
 330   if | bankrupt -> maybeEmitCheck (Just 1) <$> k
 331      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
 332      | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
 333   where
 334   maybeEmitCheck Nothing mk inh = sat (genDefunc p) mk (raise inh) inh
 335   maybeEmitCheck (Just n) mk inh =
 336     [|| let bad = $$(raise inh) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] inh)||]
 337 -}
 338
 339 emitLengthCheck ::
 340   TH.Lift (InputToken inp) =>
 341   Int -> Eval inp vs es a -> Eval inp vs es a -> Eval inp vs es a
 342 emitLengthCheck 0 ok _ko = ok
 343 emitLengthCheck 1 ok ko = Eval $ \inh -> [||
 344   if $$(moreInput inh) $$(input inh)
 345   then $$(unEval ok inh)
 346   else let _ = "sat.length-check.else" in $$(unEval ko inh)
 347   ||]
 348 {-
 349 emitLengthCheck n ok ko inh = Eval $ \inh -> [||
 350   if $$moreInput ($$shiftRight $$(input inh) (n - 1))
 351   then $$(unEval ok inh)
 352   else $$(unEval ko inh {farthestExpecting = [||farExp||]})
 353   ||]
 354 -}
 355
 356
 357 liftCode :: InstrPure a -> CodeQ a
 358 liftCode = trans
 359 {-# INLINE liftCode #-}
 360
 361 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
 362 liftCode1 p a = case p of
 363   InstrPureSameOffset -> [|| $$sameOffset $$a ||]
 364   InstrPureHaskell h -> go a h
 365   where
 366   go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
 367   go qa = \case
 368     (H.:$) -> [|| \x -> $$qa x ||]
 369     (H.:.) -> [|| \g x -> $$qa (g x) ||]
 370     H.Flip -> [|| \x y -> $$qa y x ||]
 371     (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
 372     H.Const -> [|| \_ -> $$qa ||]
 373     H.Flip H.:@ H.Const -> H.id
 374     h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
 375     H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
 376     H.Id -> qa
 377     h -> [|| $$(trans h) $$qa ||]
 378
 379 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
 380 liftCode2 p a b = case p of
 381   InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
 382   InstrPureHaskell h -> go a b h
 383   where
 384   go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
 385   go qa qb = \case
 386     (H.:$) -> [|| $$qa $$qb ||]
 387     (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
 388     H.Flip -> [|| \x -> $$qa x $$qb ||]
 389     H.Flip H.:@ H.Const -> [|| $$qb ||]
 390     H.Flip H.:@ f -> go qb qa f
 391     H.Const -> [|| $$qa ||]
 392     H.Cons -> [|| $$qa : $$qb ||]
 393     h -> [|| $$(trans h) $$qa $$qb ||]