src/Symantic/Parser/Automaton/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.Automaton.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.Automaton.Input
  31 import Symantic.Parser.Automaton.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 'Hints'
  51 newtype Hints inp = Hints [Set (ErrorItem (InputToken inp))]
  52 instance Semigroup (Hints t) where
  53   Hints xs <> Hints ys = Hints $ xs <> ys
  54 instance Monoid (Hints t) where
  55   mempty = Hints mempty
  56
  57 {-
  58 accHints ::
  59   -- | 'Hints' to add
  60   Hints t ->
  61   -- | An “OK” continuation to alter
  62   (a -> State s e -> Hints t -> m b) ->
  63   -- | Altered “OK” continuation
  64   (a -> State s e -> Hints t -> m b)
  65 accHints hs1 c x s hs2 = c x s (hs1 <> hs2)
  66 -}
  67
  68 toHints :: Offset -> ParsingError inp -> Hints inp
  69 toHints curOff = \case
  70   ParsingErrorStandard errOff _ es ->
  71     if curOff == errOff
  72     then Hints (if Set.null es then [] else [es])
  73     else mempty
  74
  75 {-
  76 withHints ::
  77   Stream s =>
  78   -- | Hints to use
  79   Hints (Token s) ->
  80   -- | Continuation to influence
  81   (ParseError s e -> State s e -> m b) ->
  82   -- | First argument of resulting continuation
  83   ParseError s e ->
  84   -- | Second argument of resulting continuation
  85   State s e ->
  86   m b
  87 withHints (Hints hs) c e =
  88   case e of
  89     ParsingErrorStandard pos us es -> c (ParsingErrorStandard pos us (Set.unions (es : hs)))
  90 {-# INLINE withHints #-}
  91 -}
  92
  93 -- ** Type 'Offset'
  94 type Offset = Int
  95
  96 -- ** Type 'Cont'
  97 type Cont inp v a =
  98   {-farthestInput-}Cursor inp ->
  99   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
 100   v ->
 101   Cursor inp ->
 102   Either (ParsingError inp) a
 103
 104 -- ** Type 'SubRoutine'
 105 type SubRoutine inp v a =
 106   {-ok-}Cont inp v a ->
 107   Cursor inp ->
 108   {-ko-}FailHandler inp a ->
 109   Either (ParsingError inp) a
 110
 111 -- ** Type 'FailHandler'
 112 type FailHandler inp a =
 113   {-failureInput-}Cursor inp ->
 114   {-farthestInput-}Cursor inp ->
 115   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
 116   Either (ParsingError inp) a
 117
 118 {-
 119 -- *** Type 'FarthestError'
 120 data FarthestError inp = FarthestError
 121   { farthestInput :: Cursor inp
 122   , farthestExpecting :: [ErrorItem (InputToken inp)]
 123   }
 124 -}
 125
 126 eval ::
 127   forall inp ret.
 128   Ord (InputToken inp) =>
 129   Show (InputToken inp) =>
 130   TH.Lift (InputToken inp) =>
 131   -- InputToken inp ~ Char =>
 132   Input inp =>
 133   CodeQ inp ->
 134   Show (Cursor inp) =>
 135   Eval inp '[] ('Succ 'Zero) ret ->
 136   CodeQ (Either (ParsingError inp) ret)
 137 eval input (Eval k) = [||
 138   let _ = "eval" in
 139   -- Pattern bindings containing unlifted types
 140   -- should use an outermost bang pattern.
 141   let !(# init, readMore, readNext #) = $$(cursorOf input) in
 142   let evalRet = \_farInp _farExp v _inp -> Right v in
 143   let evalFail _failInp !farInp !farExp =
 144         Left ParsingErrorStandard
 145         { parsingErrorOffset = offset farInp
 146         , parsingErrorUnexpected =
 147             if readMore farInp
 148             then Just (let (# c, _ #) = readNext farInp in c)
 149             else Nothing
 150         , parsingErrorExpecting = Set.fromList farExp
 151         } in
 152   $$(k EvalCtx
 153     { valueStack = ValueStackEmpty
 154     , failStack = FailStackCons [||evalFail||] FailStackEmpty
 155     , retCode = [||evalRet||]
 156     , input = [||init||]
 157     , nextInput = [||readNext||]
 158     , moreInput = [||readMore||]
 159     -- , farthestError = [||Nothing||]
 160     , farthestInput = [||init||]
 161     , farthestExpecting = [|| [] ||]
 162     })
 163   ||]
 164
 165 -- ** Type 'EvalCtx'
 166 -- | This is a context only present at compile-time.
 167 data EvalCtx inp vs (es::Peano) a =
 168   ( TH.Lift (InputToken inp)
 169   , Cursorable (Cursor inp)
 170   , Show (InputToken inp)
 171   -- , InputToken inp ~ Char
 172   ) => EvalCtx
 173   { valueStack :: ValueStack vs
 174   , failStack :: FailStack inp es a
 175   , retCode :: CodeQ (Cont inp a a)
 176   , input :: CodeQ (Cursor inp)
 177   , moreInput :: CodeQ (Cursor inp -> Bool)
 178   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 179   , farthestInput :: CodeQ (Cursor inp)
 180   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
 181   }
 182
 183 -- ** Type 'ValueStack'
 184 data ValueStack vs where
 185   ValueStackEmpty :: ValueStack '[]
 186   ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)
 187                     -- TODO: maybe use H.Haskell instead of CodeQ ?
 188                     -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
 189
 190 -- ** Type 'FailStack'
 191 data FailStack inp es a where
 192   FailStackEmpty :: FailStack inp 'Zero a
 193   FailStackCons ::
 194     CodeQ (FailHandler inp a) ->
 195     FailStack inp es a ->
 196     FailStack inp ('Succ es) a
 197
 198 instance Stackable Eval where
 199   push x k = Eval $ \inh -> unEval k inh
 200     { valueStack = ValueStackCons (liftCode x) (valueStack inh) }
 201   pop k = Eval $ \inh -> unEval k inh
 202     { valueStack = let ValueStackCons _ xs = valueStack inh in xs }
 203   liftI2 f k = Eval $ \inh -> unEval k inh
 204     { valueStack =
 205       let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
 206       ValueStackCons (liftCode2 f x y) xs
 207     }
 208   swap k = Eval $ \inh -> unEval k inh
 209     { valueStack =
 210         let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
 211         ValueStackCons x (ValueStackCons y xs)
 212     }
 213 instance Branchable Eval where
 214   case_ kx ky = Eval $ \inh ->
 215     let ValueStackCons v vs = valueStack inh in
 216     [||
 217       case $$v of
 218         Left  x -> $$(unEval kx inh{ valueStack = ValueStackCons [||x||] vs })
 219         Right y -> $$(unEval ky inh{ valueStack = ValueStackCons [||y||] vs })
 220     ||]
 221   choices fs ks kd = Eval $ \inh ->
 222     let ValueStackCons v vs = valueStack inh in
 223     go inh{valueStack = vs} v fs ks
 224     where
 225     go inh x (f:fs') (Eval k:ks') = [||
 226       if $$(liftCode1 f x) then $$(k inh)
 227       else $$(go inh x fs' ks')
 228       ||]
 229     go inh _ _ _ = unEval kd inh
 230 instance Failable Eval where
 231   fail failExp = Eval $ \inh@EvalCtx{} ->
 232     let FailStackCons e _es = failStack inh in
 233     [||
 234     let (# farInp, farExp #) =
 235           case $$compareOffset $$(farthestInput inh) $$(input inh) of
 236             LT -> (# $$(input inh), failExp #)
 237             EQ -> (# $$(farthestInput inh), ($$(farthestExpecting inh) <> failExp) #)
 238             GT -> (# $$(farthestInput inh), $$(farthestExpecting inh) #) in
 239     {-
 240     trace ("fail: "
 241       <>" failExp="<>show @[ErrorItem Char] failExp
 242       <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting inh))
 243       <>" farExp="<>show @[ErrorItem Char] farExp) $
 244     -}
 245     $$e $$(input inh) farInp farExp
 246     ||]
 247   popFail k = Eval $ \inh ->
 248     let FailStackCons _e es = failStack inh in
 249     unEval k inh{failStack = es}
 250   catchFail ok ko = Eval $ \inh@EvalCtx{} -> [||
 251     let _ = "catchFail" in $$(unEval ok inh
 252       { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
 253           -- trace ("catchFail: " <> "farExp="<>show farExp) $
 254           $$(unEval ko inh
 255             -- Push the input as it was when entering the catchFail.
 256             { valueStack = ValueStackCons (input inh) (valueStack inh)
 257             -- Move the input to the failing position.
 258             , input = [||failInp||]
 259             -- Set the farthestInput to the farthest computed by 'fail'
 260             , farthestInput = [||farInp||]
 261             , farthestExpecting = [||farExp||]
 262             })
 263         ||] (failStack inh)
 264       })
 265     ||]
 266 instance Inputable Eval where
 267   loadInput k = Eval $ \inh ->
 268     let ValueStackCons input vs = valueStack inh in
 269     unEval k inh{valueStack = vs, input}
 270   pushInput k = Eval $ \inh ->
 271     unEval k inh{valueStack = ValueStackCons (input inh) (valueStack inh)}
 272 instance Routinable Eval where
 273   call (LetName n) k = Eval $ \inh ->
 274     callWithContinuation
 275       {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 276       {-ok-}(suspend k inh)
 277       (input inh)
 278       {-ko-}(failStack inh)
 279   jump (LetName n) = Eval $ \inh ->
 280     callWithContinuation
 281       {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 282       {-ok-}(retCode inh)
 283       (input inh)
 284       {-ko-}(failStack inh)
 285   ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
 286   subroutine (LetName n) sub k = Eval $ \inh -> Code $ TH.unsafeTExpCoerce $ do
 287     val <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 288       \(!ok) (!inp) ko ->
 289         $$(unEval sub inh
 290           { valueStack = ValueStackEmpty
 291           , failStack = FailStackCons [||ko||] FailStackEmpty
 292           , input = [||inp||]
 293           , retCode = [||ok||]
 294           })
 295       ||]
 296     let decl = TH.FunD n [TH.Clause [] (TH.NormalB val) []]
 297     exp <- TH.unTypeQ (TH.examineCode (unEval k inh))
 298     return (TH.LetE [decl] exp)
 299
 300 callWithContinuation ::
 301   {-sub-}CodeQ (SubRoutine inp v a) ->
 302   {-ok-}CodeQ (Cont inp v a) ->
 303   CodeQ (Cursor inp) ->
 304   FailStack inp ('Succ es) a ->
 305   CodeQ (Either (ParsingError inp) a)
 306 callWithContinuation sub ok inp (FailStackCons ko _) =
 307   [|| let _ = "callWithContinuation" in $$sub $$ok $$inp $! $$ko ||]
 308
 309 suspend ::
 310   {-k-}Eval inp (v ': vs) es a ->
 311   EvalCtx inp vs es a ->
 312   CodeQ (Cont inp v a)
 313 suspend k inh = [|| let _ = "suspend" in \farInp farExp v !inp ->
 314   $$(unEval k inh
 315     { valueStack = ValueStackCons [||v||] (valueStack inh)
 316     , input = [||inp||]
 317     , farthestInput = [||farInp||]
 318     , farthestExpecting = [||farExp||]
 319     }
 320   )||]
 321
 322 resume :: CodeQ (Cont inp v a) -> Eval inp (v ': vs) es a
 323 resume k = Eval $ \inh ->
 324   let ValueStackCons v _ = valueStack inh in
 325   [|| let _ = "resume" in $$k $$(farthestInput inh) $$(farthestExpecting inh) $$v $$(input inh) ||]
 326
 327 instance Readable Eval Char where
 328   read farExp p k =
 329     -- TODO: piggy bank
 330     maybeEmitCheck (Just 1) k
 331     where
 332     maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
 333     maybeEmitCheck (Just n) ok = Eval $ \inh ->
 334       let FailStackCons e es = failStack inh in
 335       [||
 336       let readFail = $$(e) in -- Factorize failure code
 337       $$((`unEval` inh{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
 338         {-ok-}(sat (liftCode p) ok
 339           {-ko-}(fail farExp))
 340         {-ko-}(fail farExp))
 341       ||]
 342
 343 sat ::
 344   forall inp vs es a.
 345   -- Cursorable (Cursor inp) =>
 346   -- InputToken inp ~ Char =>
 347   Ord (InputToken inp) =>
 348   TH.Lift (InputToken inp) =>
 349   {-predicate-}CodeQ (InputToken inp -> Bool) ->
 350   {-ok-}Eval inp (InputToken inp ': vs) ('Succ es) a ->
 351   {-ko-}Eval inp vs ('Succ es) a ->
 352   Eval inp vs ('Succ es) a
 353 sat p ok ko = Eval $ \inh -> [||
 354   let !(# c, cs #) = $$(nextInput inh) $$(input inh) in
 355   if $$p c
 356   then $$(unEval ok inh
 357     { valueStack = ValueStackCons [||c||] (valueStack inh)
 358     , input = [||cs||]
 359     })
 360   else let _ = "sat.else" in $$(unEval ko inh)
 361   ||]
 362
 363 {-
 364 evalSat ::
 365   -- Cursorable inp =>
 366   -- HandlerOps inp =>
 367   InstrPure (Char -> Bool) ->
 368   Eval inp (Char ': vs) ('Succ es) a ->
 369   Eval inp vs ('Succ es) a
 370 evalSat p k = do
 371   bankrupt <- asks isBankrupt
 372   hasChange <- asks hasCoin
 373   if | bankrupt -> maybeEmitCheck (Just 1) <$> k
 374      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
 375      | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
 376   where
 377   maybeEmitCheck Nothing mk inh = sat (genDefunc p) mk (raise inh) inh
 378   maybeEmitCheck (Just n) mk inh =
 379     [|| let bad = $$(raise inh) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] inh)||]
 380 -}
 381
 382 emitLengthCheck ::
 383   TH.Lift (InputToken inp) =>
 384   Int -> Eval inp vs es a -> Eval inp vs es a -> Eval inp vs es a
 385 emitLengthCheck 0 ok _ko = ok
 386 emitLengthCheck 1 ok ko = Eval $ \inh -> [||
 387   if $$(moreInput inh) $$(input inh)
 388   then $$(unEval ok inh)
 389   else let _ = "sat.length-check.else" in $$(unEval ko inh)
 390   ||]
 391 {-
 392 emitLengthCheck n ok ko inh = Eval $ \inh -> [||
 393   if $$moreInput ($$shiftRight $$(input inh) (n - 1))
 394   then $$(unEval ok inh)
 395   else $$(unEval ko inh {farthestExpecting = [||farExp||]})
 396   ||]
 397 -}
 398
 399
 400 liftCode :: InstrPure a -> CodeQ a
 401 liftCode = trans
 402 {-# INLINE liftCode #-}
 403
 404 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
 405 liftCode1 p a = case p of
 406   InstrPureSameOffset -> [|| $$sameOffset $$a ||]
 407   InstrPureHaskell h -> go a h
 408   where
 409   go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
 410   go qa = \case
 411     (H.:$) -> [|| \x -> $$qa x ||]
 412     (H.:.) -> [|| \g x -> $$qa (g x) ||]
 413     H.Flip -> [|| \x y -> $$qa y x ||]
 414     (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
 415     H.Const -> [|| \_ -> $$qa ||]
 416     H.Flip H.:@ H.Const -> H.id
 417     h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
 418     H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
 419     H.Id -> qa
 420     h -> [|| $$(trans h) $$qa ||]
 421
 422 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
 423 liftCode2 p a b = case p of
 424   InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
 425   InstrPureHaskell h -> go a b h
 426   where
 427   go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
 428   go qa qb = \case
 429     (H.:$) -> [|| $$qa $$qb ||]
 430     (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
 431     H.Flip -> [|| \x -> $$qa x $$qb ||]
 432     H.Flip H.:@ H.Const -> [|| $$qb ||]
 433     H.Flip H.:@ f -> go qb qa f
 434     H.Const -> [|| $$qa ||]
 435     H.Cons -> [|| $$qa : $$qb ||]
 436     h -> [|| $$(trans h) $$qa $$qb ||]