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