src/Symantic/Parser/Machine/Gen.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.Gen 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.Eq (Eq(..))
  13 import Data.Function (($))
  14 -- import Data.Functor ((<$>))
  15 import Data.Int (Int)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  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.Set as Set
  26 import qualified Language.Haskell.TH.Syntax as TH
  27
  28 import Symantic.Univariant.Trans
  29 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
  30 import Symantic.Parser.Machine.Input
  31 import Symantic.Parser.Machine.Instructions
  32 import qualified Symantic.Parser.Staging as H
  33
  34 -- * Type 'Gen'
  35 -- | Generate the 'CodeQ' parsing the input.
  36 newtype Gen inp vs es a = Gen { unGen ::
  37   GenCtx inp vs es a ->
  38   CodeQ (Either (ParsingError inp) a)
  39 }
  40
  41 -- ** Type 'ParsingError'
  42 data ParsingError inp
  43   =  ParsingErrorStandard
  44   {  parsingErrorOffset :: Offset
  45   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
  46   ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
  47   }
  48 deriving instance Show (InputToken inp) => Show (ParsingError inp)
  49
  50 -- ** Type 'Offset'
  51 type Offset = Int
  52
  53 -- ** Type 'Cont'
  54 type Cont inp v a =
  55   {-farthestInput-}Cursor inp ->
  56   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  57   v ->
  58   Cursor inp ->
  59   Either (ParsingError inp) a
  60
  61 -- ** Type 'SubRoutine'
  62 type SubRoutine inp v a =
  63   {-ok-}Cont inp v a ->
  64   Cursor inp ->
  65   {-ko-}FailHandler inp a ->
  66   Either (ParsingError inp) a
  67
  68 -- ** Type 'FailHandler'
  69 type FailHandler inp a =
  70   {-failureInput-}Cursor inp ->
  71   {-farthestInput-}Cursor inp ->
  72   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  73   Either (ParsingError inp) a
  74
  75 {-
  76 -- *** Type 'FarthestError'
  77 data FarthestError inp = FarthestError
  78   { farthestInput :: Cursor inp
  79   , farthestExpecting :: [ErrorItem (InputToken inp)]
  80   }
  81 -}
  82
  83 -- | @('generate' input mach)@ generates @TemplateHaskell@ code
  84 -- parsing given 'input' according to given 'mach'ine.
  85 generate ::
  86   forall inp ret.
  87   Ord (InputToken inp) =>
  88   Show (InputToken inp) =>
  89   TH.Lift (InputToken inp) =>
  90   -- InputToken inp ~ Char =>
  91   Input inp =>
  92   CodeQ inp ->
  93   Show (Cursor inp) =>
  94   Gen inp '[] ('Succ 'Zero) ret ->
  95   CodeQ (Either (ParsingError inp) ret)
  96 generate input (Gen k) = [||
  97   -- Pattern bindings containing unlifted types
  98   -- should use an outermost bang pattern.
  99   let !(# init, readMore, readNext #) = $$(cursorOf input) in
 100   let genRet = \_farInp _farExp v _inp -> Right v in
 101   let genFail _failInp !farInp !farExp =
 102         Left ParsingErrorStandard
 103         { parsingErrorOffset = offset farInp
 104         , parsingErrorUnexpected =
 105             if readMore farInp
 106             then Just (let (# c, _ #) = readNext farInp in c)
 107             else Nothing
 108         , parsingErrorExpecting = Set.fromList farExp
 109         } in
 110   $$(k GenCtx
 111     { valueStack = ValueStackEmpty
 112     , failStack = FailStackCons [||genFail||] FailStackEmpty
 113     , retCode = [||genRet||]
 114     , input = [||init||]
 115     , nextInput = [||readNext||]
 116     , moreInput = [||readMore||]
 117     -- , farthestError = [||Nothing||]
 118     , farthestInput = [||init||]
 119     , farthestExpecting = [|| [] ||]
 120     })
 121   ||]
 122
 123 -- ** Type 'GenCtx'
 124 -- | This is a context only present at compile-time.
 125 data GenCtx inp vs (es::Peano) a =
 126   ( TH.Lift (InputToken inp)
 127   , Cursorable (Cursor inp)
 128   , Show (InputToken inp)
 129   -- , InputToken inp ~ Char
 130   ) => GenCtx
 131   { valueStack :: ValueStack vs
 132   , failStack :: FailStack inp es a
 133   , retCode :: CodeQ (Cont inp a a)
 134   , input :: CodeQ (Cursor inp)
 135   , moreInput :: CodeQ (Cursor inp -> Bool)
 136   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 137   , farthestInput :: CodeQ (Cursor inp)
 138   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
 139   }
 140
 141 -- ** Type 'ValueStack'
 142 data ValueStack vs where
 143   ValueStackEmpty :: ValueStack '[]
 144   ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)
 145                     -- TODO: maybe use H.Haskell instead of CodeQ ?
 146                     -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
 147
 148 -- ** Type 'FailStack'
 149 data FailStack inp es a where
 150   FailStackEmpty :: FailStack inp 'Zero a
 151   FailStackCons ::
 152     CodeQ (FailHandler inp a) ->
 153     FailStack inp es a ->
 154     FailStack inp ('Succ es) a
 155
 156 instance Stackable Gen where
 157   push x k = Gen $ \ctx -> unGen k ctx
 158     { valueStack = ValueStackCons (liftCode x) (valueStack ctx) }
 159   pop k = Gen $ \ctx -> unGen k ctx
 160     { valueStack = let ValueStackCons _ xs = valueStack ctx in xs }
 161   liftI2 f k = Gen $ \ctx -> unGen k ctx
 162     { valueStack =
 163       let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 164       ValueStackCons (liftCode2 f x y) xs
 165     }
 166   swap k = Gen $ \ctx -> unGen k ctx
 167     { valueStack =
 168         let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 169         ValueStackCons x (ValueStackCons y xs)
 170     }
 171 instance Branchable Gen where
 172   case_ kx ky = Gen $ \ctx ->
 173     let ValueStackCons v vs = valueStack ctx in
 174     [||
 175       case $$v of
 176         Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons [||x||] vs })
 177         Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons [||y||] vs })
 178     ||]
 179   choices fs ks kd = Gen $ \ctx ->
 180     let ValueStackCons v vs = valueStack ctx in
 181     go ctx{valueStack = vs} v fs ks
 182     where
 183     go ctx x (f:fs') (Gen k:ks') = [||
 184       if $$(liftCode1 f x) then $$(k ctx)
 185       else $$(go ctx x fs' ks')
 186       ||]
 187     go ctx _ _ _ = unGen kd ctx
 188 instance Failable Gen where
 189   fail failExp = Gen $ \ctx@GenCtx{} ->
 190     let FailStackCons e _es = failStack ctx in
 191     [||
 192     let (# farInp, farExp #) =
 193           case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 194             LT -> (# $$(input ctx), failExp #)
 195             EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
 196             GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
 197     {-
 198     trace ("fail: "
 199       <>" failExp="<>show @[ErrorItem Char] failExp
 200       <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting ctx))
 201       <>" farExp="<>show @[ErrorItem Char] farExp) $
 202     -}
 203     $$e $$(input ctx) farInp farExp
 204     ||]
 205   popFail k = Gen $ \ctx ->
 206     let FailStackCons _e es = failStack ctx in
 207     unGen k ctx{failStack = es}
 208   catchFail ok ko = Gen $ \ctx@GenCtx{} -> [||
 209     let _ = "catchFail" in $$(unGen ok ctx
 210       { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
 211           -- trace ("catchFail: " <> "farExp="<>show farExp) $
 212           $$(unGen ko ctx
 213             -- Push the input as it was when entering the catchFail.
 214             { valueStack = ValueStackCons (input ctx) (valueStack ctx)
 215             -- Move the input to the failing position.
 216             , input = [||failInp||]
 217             -- Set the farthestInput to the farthest computed by 'fail'
 218             , farthestInput = [||farInp||]
 219             , farthestExpecting = [||farExp||]
 220             })
 221         ||] (failStack ctx)
 222       })
 223     ||]
 224 instance Inputable Gen where
 225   loadInput k = Gen $ \ctx ->
 226     let ValueStackCons input vs = valueStack ctx in
 227     unGen k ctx{valueStack = vs, input}
 228   pushInput k = Gen $ \ctx ->
 229     unGen k ctx{valueStack = ValueStackCons (input ctx) (valueStack ctx)}
 230 instance Routinable Gen where
 231   call (LetName n) k = Gen $ \ctx ->
 232     callWithContinuation
 233       {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 234       {-ok-}(suspend k ctx)
 235       (input ctx)
 236       {-ko-}(failStack ctx)
 237   jump (LetName n) = Gen $ \ctx ->
 238     callWithContinuation
 239       {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 240       {-ok-}(retCode ctx)
 241       (input ctx)
 242       {-ko-}(failStack ctx)
 243   ret = Gen $ \ctx -> unGen (resume (retCode ctx)) ctx
 244   subroutine (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do
 245     val <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 246       \(!ok) (!inp) ko ->
 247         $$(unGen sub ctx
 248           { valueStack = ValueStackEmpty
 249           , failStack = FailStackCons [||ko||] FailStackEmpty
 250           , input = [||inp||]
 251           , retCode = [||ok||]
 252           })
 253       ||]
 254     let decl = TH.FunD n [TH.Clause [] (TH.NormalB val) []]
 255     exp <- TH.unTypeQ (TH.examineCode (unGen k ctx))
 256     return (TH.LetE [decl] exp)
 257
 258 callWithContinuation ::
 259   {-sub-}CodeQ (SubRoutine inp v a) ->
 260   {-ok-}CodeQ (Cont inp v a) ->
 261   CodeQ (Cursor inp) ->
 262   FailStack inp ('Succ es) a ->
 263   CodeQ (Either (ParsingError inp) a)
 264 callWithContinuation sub ok inp (FailStackCons ko _) =
 265   [|| let _ = "callWithContinuation" in $$sub $$ok $$inp $! $$ko ||]
 266
 267 suspend ::
 268   {-k-}Gen inp (v ': vs) es a ->
 269   GenCtx inp vs es a ->
 270   CodeQ (Cont inp v a)
 271 suspend k ctx = [|| let _ = "suspend" in \farInp farExp v !inp ->
 272   $$(unGen k ctx
 273     { valueStack = ValueStackCons [||v||] (valueStack ctx)
 274     , input = [||inp||]
 275     , farthestInput = [||farInp||]
 276     , farthestExpecting = [||farExp||]
 277     }
 278   )||]
 279
 280 resume :: CodeQ (Cont inp v a) -> Gen inp (v ': vs) es a
 281 resume k = Gen $ \ctx ->
 282   let ValueStackCons v _ = valueStack ctx in
 283   [|| let _ = "resume" in $$k $$(farthestInput ctx) $$(farthestExpecting ctx) $$v $$(input ctx) ||]
 284
 285 instance Readable Gen Char where
 286   read farExp p k =
 287     -- TODO: piggy bank
 288     maybeEmitCheck (Just 1) k
 289     where
 290     maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
 291     maybeEmitCheck (Just n) ok = Gen $ \ctx ->
 292       let FailStackCons e es = failStack ctx in
 293       [||
 294       let readFail = $$(e) in -- Factorize failure code
 295       $$((`unGen` ctx{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
 296         {-ok-}(sat (liftCode p) ok
 297           {-ko-}(fail farExp))
 298         {-ko-}(fail farExp))
 299       ||]
 300
 301 sat ::
 302   forall inp vs es a.
 303   -- Cursorable (Cursor inp) =>
 304   -- InputToken inp ~ Char =>
 305   Ord (InputToken inp) =>
 306   TH.Lift (InputToken inp) =>
 307   {-predicate-}CodeQ (InputToken inp -> Bool) ->
 308   {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
 309   {-ko-}Gen inp vs ('Succ es) a ->
 310   Gen inp vs ('Succ es) a
 311 sat p ok ko = Gen $ \ctx -> [||
 312   let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 313   if $$p c
 314   then $$(unGen ok ctx
 315     { valueStack = ValueStackCons [||c||] (valueStack ctx)
 316     , input = [||cs||]
 317     })
 318   else let _ = "sat.else" in $$(unGen ko ctx)
 319   ||]
 320
 321 {-
 322 evalSat ::
 323   -- Cursorable inp =>
 324   -- HandlerOps inp =>
 325   InstrPure (Char -> Bool) ->
 326   Gen inp (Char ': vs) ('Succ es) a ->
 327   Gen inp vs ('Succ es) a
 328 evalSat p k = do
 329   bankrupt <- asks isBankrupt
 330   hasChange <- asks hasCoin
 331   if | bankrupt -> maybeEmitCheck (Just 1) <$> k
 332      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
 333      | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
 334   where
 335   maybeEmitCheck Nothing mk ctx = sat (genDefunc p) mk (raise ctx) ctx
 336   maybeEmitCheck (Just n) mk ctx =
 337     [|| let bad = $$(raise ctx) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] ctx)||]
 338 -}
 339
 340 emitLengthCheck ::
 341   TH.Lift (InputToken inp) =>
 342   Int -> Gen inp vs es a -> Gen inp vs es a -> Gen inp vs es a
 343 emitLengthCheck 0 ok _ko = ok
 344 emitLengthCheck 1 ok ko = Gen $ \ctx -> [||
 345   if $$(moreInput ctx) $$(input ctx)
 346   then $$(unGen ok ctx)
 347   else let _ = "sat.length-check.else" in $$(unGen ko ctx)
 348   ||]
 349 {-
 350 emitLengthCheck n ok ko ctx = Gen $ \ctx -> [||
 351   if $$moreInput ($$shiftRight $$(input ctx) (n - 1))
 352   then $$(unGen ok ctx)
 353   else $$(unGen ko ctx {farthestExpecting = [||farExp||]})
 354   ||]
 355 -}
 356
 357
 358 liftCode :: InstrPure a -> CodeQ a
 359 liftCode = trans
 360 {-# INLINE liftCode #-}
 361
 362 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
 363 liftCode1 p a = case p of
 364   InstrPureSameOffset -> [|| $$sameOffset $$a ||]
 365   InstrPureHaskell h -> go a h
 366   where
 367   go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
 368   go qa = \case
 369     (H.:$) -> [|| \x -> $$qa x ||]
 370     (H.:.) -> [|| \g x -> $$qa (g x) ||]
 371     H.Flip -> [|| \x y -> $$qa y x ||]
 372     (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
 373     H.Const -> [|| \_ -> $$qa ||]
 374     H.Flip H.:@ H.Const -> H.id
 375     h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
 376     H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
 377     H.Id -> qa
 378     h -> [|| $$(trans h) $$qa ||]
 379
 380 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
 381 liftCode2 p a b = case p of
 382   InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
 383   InstrPureHaskell h -> go a b h
 384   where
 385   go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
 386   go qa qb = \case
 387     (H.:$) -> [|| $$qa $$qb ||]
 388     (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
 389     H.Flip -> [|| \x -> $$qa x $$qb ||]
 390     H.Flip H.:@ H.Const -> [|| $$qb ||]
 391     H.Flip H.:@ f -> go qb qa f
 392     H.Const -> [|| $$qa ||]
 393     H.Cons -> [|| $$qa : $$qb ||]
 394     h -> [|| $$(trans h) $$qa $$qb ||]