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