src/Symantic/Parser/Machine/Generate.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.Generate 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.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.List (minimum)
  16 import Data.Map (Map)
  17 import Data.Maybe (Maybe(..))
  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.Map.Strict as Map
  26 import qualified Data.Set as Set
  27 import qualified Language.Haskell.TH.Syntax as TH
  28 -- import qualified Control.Monad.Trans.Writer as Writer
  29
  30 import Symantic.Univariant.Trans
  31 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
  32 import Symantic.Parser.Machine.Input
  33 import Symantic.Parser.Machine.Instructions
  34 import qualified Symantic.Parser.Grammar.Pure as H
  35
  36 -- * Type 'Gen'
  37 -- | Generate the 'CodeQ' parsing the input.
  38 data Gen inp vs es a = Gen
  39   { minHorizon :: Map TH.Name Horizon -> Horizon
  40   , unGen ::
  41       GenCtx inp vs es a ->
  42       CodeQ (Either (ParsingError inp) a)
  43   }
  44
  45 -- ** Type 'ParsingError'
  46 data ParsingError inp
  47   =  ParsingErrorStandard
  48   {  parsingErrorOffset :: Offset
  49     -- | Note that if an 'ErrorItemHorizon' greater than 1
  50     -- is amongst the 'parsingErrorExpecting'
  51     -- then this is only the 'InputToken'
  52     -- at the begining of the expected 'Horizon'.
  53   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
  54   ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
  55   }
  56 deriving instance Show (InputToken inp) => Show (ParsingError inp)
  57
  58 -- ** Type 'Offset'
  59 type Offset = Int
  60
  61 -- ** Type 'Horizon'
  62 -- | Synthetized minimal input length
  63 -- required for a successful parsing.
  64 -- Used with 'horizon' to factorize input length checks,
  65 -- instead of checking the input length
  66 -- one 'InputToken' by one 'InputToken' at each 'read'.
  67 type Horizon = Offset
  68
  69 -- ** Type 'Cont'
  70 type Cont inp v a =
  71   {-farthestInput-}Cursor inp ->
  72   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  73   v ->
  74   Cursor inp ->
  75   Either (ParsingError inp) a
  76
  77 -- ** Type 'SubRoutine'
  78 type SubRoutine inp v a =
  79   {-ok-}Cont inp v a ->
  80   Cursor inp ->
  81   {-ko-}FailHandler inp a ->
  82   Either (ParsingError inp) a
  83
  84 -- ** Type 'FailHandler'
  85 type FailHandler inp a =
  86   {-failureInput-}Cursor inp ->
  87   {-farthestInput-}Cursor inp ->
  88   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  89   Either (ParsingError inp) a
  90
  91 {-
  92 -- *** Type 'FarthestError'
  93 data FarthestError inp = FarthestError
  94   { farthestInput :: Cursor inp
  95   , farthestExpecting :: [ErrorItem (InputToken inp)]
  96   }
  97 -}
  98
  99 -- | @('generate' input mach)@ generates @TemplateHaskell@ code
 100 -- parsing given 'input' according to given 'mach'ine.
 101 generate ::
 102   forall inp ret.
 103   Ord (InputToken inp) =>
 104   Show (InputToken inp) =>
 105   TH.Lift (InputToken inp) =>
 106   -- InputToken inp ~ Char =>
 107   Input inp =>
 108   CodeQ inp ->
 109   Show (Cursor inp) =>
 110   Gen inp '[] ('Succ 'Zero) ret ->
 111   CodeQ (Either (ParsingError inp) ret)
 112 generate input k = [||
 113   -- Pattern bindings containing unlifted types
 114   -- should use an outermost bang pattern.
 115   let !(# init, readMore, readNext #) = $$(cursorOf input) in
 116   let finalRet = \_farInp _farExp v _inp -> Right v in
 117   let finalFail _failInp !farInp !farExp =
 118         Left ParsingErrorStandard
 119         { parsingErrorOffset = offset farInp
 120         , parsingErrorUnexpected =
 121             if readMore farInp
 122             then Just (let (# c, _ #) = readNext farInp in c)
 123             else Nothing
 124         , parsingErrorExpecting = Set.fromList farExp
 125         } in
 126   $$(unGen k GenCtx
 127     { valueStack = ValueStackEmpty
 128     , failStack = FailStackCons [||finalFail||] FailStackEmpty
 129     , retCode = [||finalRet||]
 130     , input = [||init||]
 131     , nextInput = [||readNext||]
 132     , moreInput = [||readMore||]
 133     -- , farthestError = [||Nothing||]
 134     , farthestInput = [||init||]
 135     , farthestExpecting = [|| [] ||]
 136     , horizon = 0
 137     , horizonByName = Map.empty
 138     })
 139   ||]
 140
 141 -- ** Type 'GenCtx'
 142 -- | This is a context only present at compile-time.
 143 data GenCtx inp vs (es::Peano) a =
 144   ( TH.Lift (InputToken inp)
 145   , Cursorable (Cursor inp)
 146   , Show (InputToken inp)
 147   -- , InputToken inp ~ Char
 148   ) => GenCtx
 149   { valueStack :: ValueStack vs
 150   , failStack :: FailStack inp es a
 151   , retCode :: CodeQ (Cont inp a a)
 152   , input :: CodeQ (Cursor inp)
 153   , moreInput :: CodeQ (Cursor inp -> Bool)
 154   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 155   , farthestInput :: CodeQ (Cursor inp)
 156   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
 157     -- | Remaining horizon
 158   , horizon :: Offset
 159     -- | Horizon for each 'call' or 'jump'.
 160   , horizonByName :: Map TH.Name Offset
 161   }
 162
 163 -- ** Type 'ValueStack'
 164 data ValueStack vs where
 165   ValueStackEmpty :: ValueStack '[]
 166   ValueStackCons ::
 167     -- TODO: maybe use H.CombPure instead of CodeQ ?
 168     -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
 169     { valueStackHead :: CodeQ v
 170     , valueStackTail :: ValueStack vs
 171     } -> ValueStack (v ': vs)
 172
 173 -- ** Type 'FailStack'
 174 data FailStack inp es a where
 175   FailStackEmpty :: FailStack inp 'Zero a
 176   FailStackCons ::
 177     { failStackHead :: CodeQ (FailHandler inp a)
 178     , failStackTail :: FailStack inp es a
 179     } ->
 180     FailStack inp ('Succ es) a
 181
 182 instance Stackable Gen where
 183   push x k = k
 184     { unGen = \ctx -> unGen k ctx
 185       { valueStack = ValueStackCons (liftCode x) (valueStack ctx) }
 186     }
 187   pop k = k
 188     { unGen = \ctx -> unGen k ctx
 189       { valueStack = valueStackTail (valueStack ctx) }
 190     }
 191   liftI2 f k = k
 192     { unGen = \ctx -> unGen k ctx
 193       { valueStack =
 194         let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 195         ValueStackCons (liftCode2 f x y) xs
 196       }
 197     }
 198   swap k = k
 199     { unGen = \ctx -> unGen k ctx
 200       { valueStack =
 201           let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 202           ValueStackCons x (ValueStackCons y xs)
 203       }
 204     }
 205 instance Branchable Gen where
 206   case_ kx ky = Gen
 207     { minHorizon = \ls ->
 208       minHorizon kx ls `min` minHorizon ky ls
 209     , unGen = \ctx ->
 210       let ValueStackCons v vs = valueStack ctx in
 211       [||
 212         case $$v of
 213           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons [||x||] vs })
 214           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons [||y||] vs })
 215       ||]
 216     }
 217   choices fs ks kd = Gen
 218     { minHorizon = \ls -> minimum $
 219         minHorizon kd ls :
 220         (($ ls) . minHorizon <$> ks)
 221     , unGen = \ctx ->
 222       let ValueStackCons v vs = valueStack ctx in
 223       go ctx{valueStack = vs} v fs ks
 224     }
 225     where
 226     go ctx x (f:fs') (k:ks') = [||
 227       if $$(liftCode1 f x) then $$(unGen k ctx)
 228       else $$(go ctx x fs' ks')
 229       ||]
 230     go ctx _ _ _ = unGen kd ctx
 231 instance Failable Gen where
 232   fail failExp = Gen
 233     { minHorizon = \_hs -> 0
 234     , unGen = \ctx@GenCtx{} -> [||
 235       let (# farInp, farExp #) =
 236             case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 237               LT -> (# $$(input ctx), failExp #)
 238               EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
 239               GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
 240       $$(failStackHead (failStack ctx))
 241         $$(input ctx) farInp farExp
 242       ||]
 243     }
 244   popFail k = k
 245     { unGen = \ctx ->
 246       let FailStackCons _e es = failStack ctx in
 247       unGen k ctx{failStack = es}
 248     }
 249   catchFail ok ko = Gen
 250     { minHorizon = \ls -> minHorizon ok ls `min` minHorizon ko ls
 251     , unGen = \ctx@GenCtx{} -> [||
 252       let _ = "catchFail" in $$(unGen ok ctx
 253         { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
 254             -- trace ("catchFail: " <> "farExp="<>show farExp) $
 255             $$(unGen ko ctx
 256               -- Push the input as it was when entering the catchFail.
 257               { valueStack = ValueStackCons (input ctx) (valueStack ctx)
 258               -- Move the input to the failing position.
 259               , input = [||failInp||]
 260               -- Set the farthestInput to the farthest computed by 'fail'
 261               , farthestInput = [||farInp||]
 262               , farthestExpecting = [||farExp||]
 263               })
 264           ||] (failStack ctx)
 265         })
 266       ||]
 267     }
 268 instance Inputable Gen where
 269   loadInput k = k
 270     { unGen = \ctx ->
 271       let ValueStackCons input vs = valueStack ctx in
 272       unGen k ctx
 273         { valueStack = vs
 274         , input
 275         , horizon = 0
 276         }
 277     }
 278   pushInput k = k
 279     { unGen = \ctx ->
 280       unGen k ctx{valueStack = ValueStackCons (input ctx) (valueStack ctx)}
 281     }
 282 instance Routinable Gen where
 283   call (LetName n) k = k
 284     { minHorizon = \hs -> hs Map.! n
 285     , unGen = \ctx -> [||
 286       let _ = "call" in
 287       $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 288         {-ok-}$$(generateSuspend k ctx)
 289         $$(input ctx)
 290         $! $$(failStackHead (failStack ctx))
 291       ||]
 292     }
 293   jump (LetName n) = Gen
 294     { minHorizon = \hs -> hs Map.! n
 295     , unGen = \ctx -> [||
 296       let _ = "jump" in
 297       $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 298         {-ok-}$$(retCode ctx)
 299         $$(input ctx)
 300         $! $$(failStackHead (failStack ctx))
 301       ||]
 302     }
 303   ret = Gen
 304     { minHorizon = \_hs -> 0
 305     , unGen = \ctx -> unGen (generateResume (retCode ctx)) ctx
 306     }
 307   subroutine (LetName n) sub k = Gen
 308     { minHorizon = \hs ->
 309         minHorizon k $
 310           Map.insert n (minHorizon sub (Map.insert n 0 hs)) hs
 311     , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
 312       body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 313         -- SubRoutine
 314         -- Why using $! at call site and not ! here on ko?
 315         \ !ok !inp ko ->
 316           $$(unGen sub ctx
 317             { valueStack = ValueStackEmpty
 318             , failStack = FailStackCons [||ko||] FailStackEmpty
 319             , input = [||inp||]
 320             , retCode = [||ok||]
 321             -- , farthestInput = [|inp|]
 322             -- , farthestExpecting = [|| [] ||]
 323             , horizon = 0
 324             , horizonByName = Map.insert n 0 (horizonByName ctx)
 325             })
 326         ||]
 327       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 328       expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
 329         { horizonByName =
 330             Map.insert n
 331               (minHorizon sub
 332                 (Map.insert n 0 (horizonByName ctx)))
 333               (horizonByName ctx)
 334         }))
 335       return (TH.LetE [decl] expr)
 336     }
 337
 338 -- | Generate a continuation to be called with 'generateResume',
 339 -- used when 'call' 'ret'urns.
 340 generateSuspend ::
 341   {-k-}Gen inp (v ': vs) es a ->
 342   GenCtx inp vs es a ->
 343   CodeQ (Cont inp v a)
 344 generateSuspend k ctx = [||
 345   let _ = "suspend" in
 346   \farInp farExp v !inp ->
 347     $$(unGen k ctx
 348       { valueStack = ValueStackCons [||v||] (valueStack ctx)
 349       , input = [||inp||]
 350       , farthestInput = [||farInp||]
 351       , farthestExpecting = [||farExp||]
 352       , horizon = 0
 353       }
 354     )
 355   ||]
 356
 357 -- | Generate a call to the 'generateSuspend' continuation,
 358 -- used when 'call' 'ret'urns.
 359 generateResume ::
 360   CodeQ (Cont inp v a) ->
 361   Gen inp (v ': vs) es a
 362 generateResume k = Gen
 363   { minHorizon = \_hs -> 0
 364   , unGen = \ctx -> [||
 365     let _ = "resume" in
 366     $$k
 367       $$(farthestInput ctx)
 368       $$(farthestExpecting ctx)
 369       $$(valueStackHead (valueStack ctx))
 370       $$(input ctx)
 371     ||]
 372   }
 373
 374 instance Joinable Gen where
 375   defJoin (LetName n) sub k = k
 376     { minHorizon = \hs ->
 377         minHorizon k $
 378           Map.insert n (minHorizon sub (Map.insert n 0 hs)) hs
 379     , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
 380       body <- TH.unTypeQ $ TH.examineCode $ [||
 381         \farInp farExp v !inp ->
 382           $$(unGen sub ctx
 383             { valueStack = ValueStackCons [||v||] (valueStack ctx)
 384             , input = [||inp||]
 385             , farthestInput = [||farInp||]
 386             , farthestExpecting = [||farExp||]
 387             , horizon = 0
 388             , horizonByName = Map.insert n 0 (horizonByName ctx)
 389             })
 390         ||]
 391       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 392       expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
 393         { horizonByName =
 394             Map.insert n
 395               (minHorizon sub
 396                 (Map.insert n 0 (horizonByName ctx)))
 397               (horizonByName ctx)
 398         }))
 399       return (TH.LetE [decl] expr)
 400     }
 401   refJoin (LetName n) =
 402     generateResume (Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 403 instance Readable Gen Char where
 404   read farExp p = checkHorizon . checkToken farExp (liftCode p)
 405
 406 checkHorizon ::
 407   TH.Lift (InputToken inp) =>
 408   {-ok-}Gen inp vs ('Succ es) a ->
 409   Gen inp vs ('Succ es) a
 410 checkHorizon ok = ok
 411   { minHorizon = \hs -> 1 + minHorizon ok hs
 412   , unGen = \ctx0@GenCtx{failStack = FailStackCons e es} -> [||
 413       -- Factorize failure code
 414       let readFail = $$(e) in
 415       $$(
 416         let ctx = ctx0{ failStack = FailStackCons [||readFail||] es } in
 417         if horizon ctx >= 1
 418         then unGen ok ctx0{horizon = horizon ctx - 1}
 419         else let minHoz = minHorizon ok (horizonByName ctx) in
 420           [||
 421           if $$(moreInput ctx)
 422                $$(if minHoz > 0
 423                  then [||$$shiftRight minHoz $$(input ctx)||]
 424                  else input ctx)
 425           then $$(unGen ok ctx{horizon = minHoz})
 426           else let _ = "checkHorizon.else" in
 427             $$(unGen (fail [ErrorItemHorizon (minHoz + 1)]) ctx)
 428           ||]
 429       )
 430     ||]
 431   }
 432
 433 checkToken ::
 434   forall inp vs es a.
 435   Ord (InputToken inp) =>
 436   TH.Lift (InputToken inp) =>
 437   [ErrorItem (InputToken inp)] ->
 438   {-predicate-}CodeQ (InputToken inp -> Bool) ->
 439   {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
 440   Gen inp vs ('Succ es) a
 441 checkToken farExp p ok = ok
 442   { unGen = \ctx -> [||
 443     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 444     if $$p c
 445     then $$(unGen ok ctx
 446       { valueStack = ValueStackCons [||c||] (valueStack ctx)
 447       , input = [||cs||]
 448       })
 449     else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)
 450     ||]
 451   }
 452
 453 liftCode :: InstrPure a -> CodeQ a
 454 liftCode x = trans x
 455 {-
 456 liftCode p = case p of
 457   InstrPureSameOffset -> [|| $$sameOffset ||]
 458   InstrPureHaskell h -> go h
 459   where
 460   go :: H.CombPure a -> CodeQ a
 461   go = \case
 462     ((H.:.) H.:@ f) H.:@ (H.Const H.:@ x) -> [|| $$(go f) $$(go x) ||]
 463     a -> trans a
 464 -}
 465 -- {-# INLINE liftCode #-}
 466
 467 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
 468 liftCode1 p a = case p of
 469   InstrPureSameOffset f -> [|| $$f $$a ||]
 470   InstrPureHaskell h -> go a h
 471   where
 472   go :: CodeQ a -> H.CombPure (a -> b) -> CodeQ b
 473   go qa = \case
 474     (H.:$) -> [|| \x -> $$qa x ||]
 475     (H.:.) -> [|| \g x -> $$qa (g x) ||]
 476     H.Flip -> [|| \x y -> $$qa y x ||]
 477     -- ((H.:.) H.:@ f) H.:@ (H.Const H.@ x) -> [|| $$(go (go qa g) f) ||]
 478     (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
 479     H.Cons -> [|| ($$qa :) ||]
 480     H.Const -> [|| \_ -> $$qa ||]
 481     H.Flip H.:@ H.Const -> H.id
 482     h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
 483     H.Id H.:@ x -> go qa x
 484     H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
 485     H.Id -> qa
 486     H.CombPure (H.ValueCode _a2b qa2b) -> [|| $$qa2b $$qa ||]
 487     -- h -> [|| $$(liftCode h) $$qa ||]
 488
 489 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
 490 liftCode2 p a b = case p of
 491   InstrPureSameOffset f -> [|| $$f $$a $$b ||]
 492   InstrPureHaskell h -> go a b h
 493   where
 494   go :: CodeQ a -> CodeQ b -> H.CombPure (a -> b -> c) -> CodeQ c
 495   go qa qb = \case
 496     (H.:$) -> [|| $$qa $$qb ||]
 497     (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
 498     H.Flip -> [|| \x -> $$qa x $$qb ||]
 499     H.Flip H.:@ H.Const -> [|| $$qb ||]
 500     H.Flip H.:@ f -> go qb qa f
 501     H.Id H.:@ x -> go qa qb x
 502     H.Id -> [|| $$qa $$qb ||]
 503     H.Cons -> [|| $$qa : $$qb ||]
 504     H.Const -> [|| $$qa ||]
 505     H.CombPure (H.ValueCode _a2b2c qa2b2c) -> [|| $$qa2b2c $$qa $$qb ||]
 506     --h -> [|| $$(trans h) $$qa $$qb ||]