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 -- | @('generate' input mach)@ generates @TemplateHaskell@ code
 106 -- parsing given 'input' according to given 'mach'ine.
 107 generate ::
 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 generate 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 es a
 157   , retCode :: CodeQ (Cont inp a a)
 158   , input :: CodeQ (Cursor inp)
 159   , moreInput :: CodeQ (Cursor inp -> Bool)
 160   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 161   , farthestInput :: CodeQ (Cursor inp)
 162   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
 163     -- | Remaining horizon
 164   , horizon :: Offset
 165     -- | Horizon for each 'call' or 'jump'.
 166   , horizonByName :: Map TH.Name Offset
 167   }
 168
 169 -- ** Type 'ValueStack'
 170 data ValueStack vs where
 171   ValueStackEmpty :: ValueStack '[]
 172   ValueStackCons ::
 173     { valueStackHead :: TermInstr v
 174     , valueStackTail :: ValueStack vs
 175     } -> ValueStack (v ': vs)
 176
 177 -- ** Type 'FailStack'
 178 data FailStack inp es a where
 179   FailStackEmpty :: FailStack inp 'Zero a
 180   FailStackCons ::
 181     { failStackHead :: CodeQ (FailHandler inp a)
 182     , failStackTail :: FailStack inp es a
 183     } ->
 184     FailStack inp ('Succ es) a
 185
 186 instance Stackable Gen where
 187   push x k = k
 188     { unGen = \ctx -> unGen k ctx
 189       { valueStack = ValueStackCons x (valueStack ctx) }
 190     }
 191   pop k = k
 192     { unGen = \ctx -> unGen k ctx
 193       { valueStack = valueStackTail (valueStack ctx) }
 194     }
 195   liftI2 f k = k
 196     { unGen = \ctx -> unGen k ctx
 197       { valueStack =
 198         let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 199         ValueStackCons (f H.:@ x H.:@ y) xs
 200       }
 201     }
 202   swap k = k
 203     { unGen = \ctx -> unGen k ctx
 204       { valueStack =
 205           let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 206           ValueStackCons x (ValueStackCons y xs)
 207       }
 208     }
 209 instance Branchable Gen where
 210   case_ kx ky = Gen
 211     { minHorizon = \ls ->
 212       minHorizon kx ls `min` minHorizon ky ls
 213     , unGen = \ctx ->
 214       let ValueStackCons v vs = valueStack ctx in
 215       [||
 216         case $$(genCode v) of
 217           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })
 218           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })
 219       ||]
 220     }
 221   choices fs ks kd = Gen
 222     { minHorizon = \ls -> minimum $
 223         minHorizon kd ls :
 224         (($ ls) . minHorizon <$> ks)
 225     , unGen = \ctx ->
 226       let ValueStackCons v vs = valueStack ctx in
 227       go ctx{valueStack = vs} v fs ks
 228     }
 229     where
 230     go ctx x (f:fs') (k:ks') = [||
 231       if $$(genCode (f H.:@ x))
 232       then $$(unGen k ctx)
 233       else $$(go ctx x fs' ks')
 234       ||]
 235     go ctx _ _ _ = unGen kd ctx
 236 instance Failable Gen where
 237   fail failExp = Gen
 238     { minHorizon = \_hs -> 0
 239     , unGen = \ctx@GenCtx{} -> [||
 240       let (# farInp, farExp #) =
 241             case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 242               LT -> (# $$(input ctx), failExp #)
 243               EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
 244               GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
 245       $$(failStackHead (failStack ctx))
 246         $$(input ctx) farInp farExp
 247       ||]
 248     }
 249   popFail k = k
 250     { unGen = \ctx ->
 251       let FailStackCons _e es = failStack ctx in
 252       unGen k ctx{failStack = es}
 253     }
 254   catchFail ok ko = Gen
 255     { minHorizon = \ls -> minHorizon ok ls `min` minHorizon ko ls
 256     , unGen = \ctx@GenCtx{} -> [||
 257       let _ = "catchFail" in $$(unGen ok ctx
 258         { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
 259             -- trace ("catchFail: " <> "farExp="<>show farExp) $
 260             $$(unGen ko ctx
 261               -- Push the input as it was when entering the catchFail.
 262               { valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)
 263               -- Move the input to the failing position.
 264               , input = [||failInp||]
 265               -- Set the farthestInput to the farthest computed by 'fail'
 266               , farthestInput = [||farInp||]
 267               , farthestExpecting = [||farExp||]
 268               })
 269           ||] (failStack ctx)
 270         })
 271       ||]
 272     }
 273 instance Inputable Gen where
 274   loadInput k = k
 275     { unGen = \ctx ->
 276       let ValueStackCons input vs = valueStack ctx in
 277       unGen k ctx
 278         { valueStack = vs
 279         , input = genCode input
 280         , horizon = 0
 281         }
 282     }
 283   pushInput k = k
 284     { unGen = \ctx ->
 285       unGen k ctx{valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)}
 286     }
 287 instance Routinable Gen where
 288   call (LetName n) k = k
 289     { minHorizon = (Map.! n)
 290     , unGen = \ctx -> [||
 291       let _ = "call" in
 292       $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 293         {-ok-}$$(generateSuspend k ctx)
 294         $$(input ctx)
 295         $! $$(failStackHead (failStack ctx))
 296       ||]
 297     }
 298   jump (LetName n) = Gen
 299     { minHorizon = (Map.! n)
 300     , unGen = \ctx -> [||
 301       let _ = "jump" in
 302       $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 303         {-ok-}$$(retCode ctx)
 304         $$(input ctx)
 305         $! $$(failStackHead (failStack ctx))
 306       ||]
 307     }
 308   ret = Gen
 309     { minHorizon = \_hs -> 0
 310     , unGen = \ctx -> unGen (generateResume (retCode ctx)) ctx
 311     }
 312   subroutine (LetName n) sub k = Gen
 313     { minHorizon = \hs ->
 314         minHorizon k $
 315           Map.insert n (minHorizon sub (Map.insert n 0 hs)) hs
 316     , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
 317       body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 318         -- SubRoutine
 319         -- Why using $! at call site and not ! here on ko?
 320         \ !ok !inp ko ->
 321           $$(unGen sub ctx
 322             { valueStack = ValueStackEmpty
 323             , failStack = FailStackCons [||ko||] FailStackEmpty
 324             , input = [||inp||]
 325             , retCode = [||ok||]
 326             -- , farthestInput = [|inp|]
 327             -- , farthestExpecting = [|| [] ||]
 328             , horizon = 0
 329             , horizonByName = Map.insert n 0 (horizonByName ctx)
 330             })
 331         ||]
 332       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 333       expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
 334         { horizonByName =
 335             Map.insert n
 336               (minHorizon sub
 337                 (Map.insert n 0 (horizonByName ctx)))
 338               (horizonByName ctx)
 339         }))
 340       return (TH.LetE [decl] expr)
 341     }
 342
 343 -- | Generate a continuation to be called with 'generateResume',
 344 -- used when 'call' 'ret'urns.
 345 generateSuspend ::
 346   {-k-}Gen inp (v ': vs) es a ->
 347   GenCtx inp vs es a ->
 348   CodeQ (Cont inp v a)
 349 generateSuspend k ctx = [||
 350   let _ = "suspend" in
 351   \farInp farExp v !inp ->
 352     $$(unGen k ctx
 353       { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
 354       , input = [||inp||]
 355       , farthestInput = [||farInp||]
 356       , farthestExpecting = [||farExp||]
 357       , horizon = 0
 358       }
 359     )
 360   ||]
 361
 362 -- | Generate a call to the 'generateSuspend' continuation,
 363 -- used when 'call' 'ret'urns.
 364 generateResume ::
 365   CodeQ (Cont inp v a) ->
 366   Gen inp (v ': vs) es a
 367 generateResume k = Gen
 368   { minHorizon = \_hs -> 0
 369   , unGen = \ctx -> [||
 370     let _ = "resume" in
 371     $$k
 372       $$(farthestInput ctx)
 373       $$(farthestExpecting ctx)
 374       (let _ = "resume.genCode" in $$(genCode (valueStackHead (valueStack ctx))))
 375       $$(input ctx)
 376     ||]
 377   }
 378
 379 instance Joinable Gen where
 380   defJoin (LetName n) sub k = k
 381     { minHorizon = \hs ->
 382         minHorizon k $
 383           Map.insert n (minHorizon sub (Map.insert n 0 hs)) hs
 384     , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
 385       body <- TH.unTypeQ $ TH.examineCode $ [||
 386         \farInp farExp v !inp ->
 387           $$(unGen sub ctx
 388             { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
 389             , input = [||inp||]
 390             , farthestInput = [||farInp||]
 391             , farthestExpecting = [||farExp||]
 392             , horizon = 0
 393             , horizonByName = Map.insert n 0 (horizonByName ctx)
 394             })
 395         ||]
 396       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 397       expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
 398         { horizonByName =
 399             Map.insert n
 400               (minHorizon sub
 401                 (Map.insert n 0 (horizonByName ctx)))
 402               (horizonByName ctx)
 403         }))
 404       return (TH.LetE [decl] expr)
 405     }
 406   refJoin (LetName n) = (generateResume (Code (TH.unsafeTExpCoerce (return (TH.VarE n)))))
 407     { minHorizon = (Map.! n)
 408     }
 409 instance Readable Gen Char where
 410   read farExp p = checkHorizon . checkToken farExp p
 411
 412 checkHorizon ::
 413   TH.Lift (InputToken inp) =>
 414   {-ok-}Gen inp vs ('Succ es) a ->
 415   Gen inp vs ('Succ es) a
 416 checkHorizon ok = ok
 417   { minHorizon = \hs -> 1 + minHorizon ok hs
 418   , unGen = \ctx0@GenCtx{failStack = FailStackCons e es} -> [||
 419       -- Factorize failure code
 420       let readFail = $$(e) in
 421       $$(
 422         let ctx = ctx0{ failStack = FailStackCons [||readFail||] es } in
 423         if horizon ctx >= 1
 424         then unGen ok ctx0{horizon = horizon ctx - 1}
 425         else let minHoz = minHorizon ok (horizonByName ctx) in
 426           [||
 427           if $$(moreInput ctx)
 428                $$(if minHoz > 0
 429                  then [||$$shiftRight minHoz $$(input ctx)||]
 430                  else input ctx)
 431           then $$(unGen ok ctx{horizon = minHoz})
 432           else let _ = "checkHorizon.else" in
 433             $$(unGen (fail [ErrorItemHorizon (minHoz + 1)]) ctx)
 434           ||]
 435       )
 436     ||]
 437   }
 438
 439 checkToken ::
 440   forall inp vs es a.
 441   Ord (InputToken inp) =>
 442   TH.Lift (InputToken inp) =>
 443   [ErrorItem (InputToken inp)] ->
 444   {-predicate-}TermInstr (InputToken inp -> Bool) ->
 445   {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
 446   Gen inp vs ('Succ es) a
 447 checkToken farExp p ok = ok
 448   { unGen = \ctx -> [||
 449     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 450     if $$(genCode p) c
 451     then $$(unGen ok ctx
 452       { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
 453       , input = [||cs||]
 454       })
 455     else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)
 456     ||]
 457   }
 458