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