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