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.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.Haskell 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 finalRet = \_farInp _farExp v _inp -> Right v in
  99   let finalFail _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 [||finalFail||] FailStackEmpty
 111     , retCode = [||finalRet||]
 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 ::
 143     -- TODO: maybe use H.Haskell instead of CodeQ ?
 144     -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
 145     { valueStackHead :: CodeQ v
 146     , valueStackTail :: ValueStack vs
 147     } -> ValueStack (v ': vs)
 148
 149 -- ** Type 'FailStack'
 150 data FailStack inp es a where
 151   FailStackEmpty :: FailStack inp 'Zero a
 152   FailStackCons ::
 153     { failStackHead :: CodeQ (FailHandler inp a)
 154     , failStackTail :: FailStack inp es a
 155     } ->
 156     FailStack inp ('Succ es) a
 157
 158 instance Stackable Gen where
 159   push x k = Gen $ \ctx -> unGen k ctx
 160     { valueStack = ValueStackCons (liftCode x) (valueStack ctx) }
 161   pop k = Gen $ \ctx -> unGen k ctx
 162     { valueStack = valueStackTail (valueStack ctx) }
 163   liftI2 f k = Gen $ \ctx -> unGen k ctx
 164     { valueStack =
 165       let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 166       ValueStackCons (liftCode2 f x y) xs
 167     }
 168   swap k = Gen $ \ctx -> unGen k ctx
 169     { valueStack =
 170         let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 171         ValueStackCons x (ValueStackCons y xs)
 172     }
 173 instance Branchable Gen where
 174   case_ kx ky = Gen $ \ctx ->
 175     let ValueStackCons v vs = valueStack ctx in
 176     [||
 177       case $$v of
 178         Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons [||x||] vs })
 179         Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons [||y||] vs })
 180     ||]
 181   choices fs ks kd = Gen $ \ctx ->
 182     let ValueStackCons v vs = valueStack ctx in
 183     go ctx{valueStack = vs} v fs ks
 184     where
 185     go ctx x (f:fs') (Gen k:ks') = [||
 186       if $$(liftCode1 f x) then $$(k ctx)
 187       else $$(go ctx x fs' ks')
 188       ||]
 189     go ctx _ _ _ = unGen kd ctx
 190 instance Failable Gen where
 191   fail failExp = Gen $ \ctx@GenCtx{} -> [||
 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     $$(failStackHead (failStack ctx))
 204       $$(input ctx) farInp farExp
 205     ||]
 206   popFail k = Gen $ \ctx ->
 207     let FailStackCons _e es = failStack ctx in
 208     unGen k ctx{failStack = es}
 209   catchFail ok ko = Gen $ \ctx@GenCtx{} -> [||
 210     let _ = "catchFail" in $$(unGen ok ctx
 211       { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
 212           -- trace ("catchFail: " <> "farExp="<>show farExp) $
 213           $$(unGen ko ctx
 214             -- Push the input as it was when entering the catchFail.
 215             { valueStack = ValueStackCons (input ctx) (valueStack ctx)
 216             -- Move the input to the failing position.
 217             , input = [||failInp||]
 218             -- Set the farthestInput to the farthest computed by 'fail'
 219             , farthestInput = [||farInp||]
 220             , farthestExpecting = [||farExp||]
 221             })
 222         ||] (failStack ctx)
 223       })
 224     ||]
 225 instance Inputable Gen where
 226   loadInput k = Gen $ \ctx ->
 227     let ValueStackCons input vs = valueStack ctx in
 228     unGen k ctx{valueStack = vs, input}
 229   pushInput k = Gen $ \ctx ->
 230     unGen k ctx{valueStack = ValueStackCons (input ctx) (valueStack ctx)}
 231 instance Routinable Gen where
 232   call (LetName n) k = Gen $ \ctx -> [||
 233     let _ = "call" in
 234     $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 235       $$(suspend k ctx)
 236       $$(input ctx)
 237       $! $$(failStackHead (failStack ctx))
 238     ||]
 239   jump (LetName n) = Gen $ \ctx -> [||
 240     let _ = "jump" in
 241     $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 242       $$(retCode ctx)
 243       $$(input ctx)
 244       $! $$(failStackHead (failStack ctx))
 245     ||]
 246   ret = Gen $ \ctx -> unGen (resume (retCode ctx)) ctx
 247   subroutine (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do
 248     body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 249       -- SubRoutine
 250       -- Why using $! at call site and not ! here on ko?
 251       \ !ok !inp ko ->
 252         $$(unGen sub ctx
 253           { valueStack = ValueStackEmpty
 254           , failStack = FailStackCons [||ko||] FailStackEmpty
 255           , input = [||inp||]
 256           , retCode = [||ok||]
 257           -- , farthestInput = [|inp|]
 258           -- , farthestExpecting = [|| [] ||]
 259           })
 260       ||]
 261     let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 262     expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))
 263     return (TH.LetE [decl] expr)
 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 = [||
 270   let _ = "suspend" in
 271   \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
 281 resume :: CodeQ (Cont inp v a) -> Gen inp (v ': vs) es a
 282 resume k = Gen $ \ctx -> [||
 283   let _ = "resume" in
 284   $$k
 285     $$(farthestInput ctx)
 286     $$(farthestExpecting ctx)
 287     $$(valueStackHead (valueStack ctx))
 288     $$(input ctx)
 289   ||]
 290
 291 instance Joinable Gen where
 292   defJoin (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do
 293     body <- TH.unTypeQ $ TH.examineCode $ [||
 294       \farInp farExp v !inp ->
 295         $$(unGen sub ctx
 296           { valueStack = ValueStackCons [||v||] (valueStack ctx)
 297           , input = [||inp||]
 298           , farthestInput = [||farInp||]
 299           , farthestExpecting = [||farExp||]
 300           })
 301       ||]
 302     let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 303     expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))
 304     return (TH.LetE [decl] expr)
 305   refJoin (LetName n) =
 306     resume (Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 307 instance Readable Gen Char where
 308   read farExp p k =
 309     -- TODO: piggy bank
 310     maybeEmitCheck (Just 1) k
 311     where
 312     maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
 313     maybeEmitCheck (Just n) ok = Gen $ \ctx ->
 314       let FailStackCons e es = failStack ctx in
 315       [||
 316       let readFail = $$(e) in -- Factorize failure code
 317       $$((`unGen` ctx{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
 318         {-ok-}(sat (liftCode p) ok
 319           {-ko-}(fail farExp))
 320         {-ko-}(fail farExp))
 321       ||]
 322
 323 sat ::
 324   forall inp vs es a.
 325   -- Cursorable (Cursor inp) =>
 326   -- InputToken inp ~ Char =>
 327   Ord (InputToken inp) =>
 328   TH.Lift (InputToken inp) =>
 329   {-predicate-}CodeQ (InputToken inp -> Bool) ->
 330   {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
 331   {-ko-}Gen inp vs ('Succ es) a ->
 332   Gen inp vs ('Succ es) a
 333 sat p ok ko = Gen $ \ctx -> [||
 334   let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 335   if $$p c
 336   then $$(unGen ok ctx
 337     { valueStack = ValueStackCons [||c||] (valueStack ctx)
 338     , input = [||cs||]
 339     })
 340   else let _ = "sat.else" in $$(unGen ko ctx)
 341   ||]
 342
 343 {-
 344 evalSat ::
 345   -- Cursorable inp =>
 346   -- HandlerOps inp =>
 347   InstrPure (Char -> Bool) ->
 348   Gen inp (Char ': vs) ('Succ es) a ->
 349   Gen inp vs ('Succ es) a
 350 evalSat p k = do
 351   bankrupt <- asks isBankrupt
 352   hasChange <- asks hasCoin
 353   if | bankrupt -> maybeEmitCheck (Just 1) <$> k
 354      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
 355      | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
 356   where
 357   maybeEmitCheck Nothing mk ctx = sat (genDefunc p) mk (raise ctx) ctx
 358   maybeEmitCheck (Just n) mk ctx =
 359     [|| let bad = $$(raise ctx) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] ctx)||]
 360 -}
 361
 362 emitLengthCheck ::
 363   TH.Lift (InputToken inp) =>
 364   Int -> Gen inp vs es a -> Gen inp vs es a -> Gen inp vs es a
 365 emitLengthCheck 0 ok _ko = ok
 366 emitLengthCheck 1 ok ko = Gen $ \ctx -> [||
 367   if $$(moreInput ctx) $$(input ctx)
 368   then $$(unGen ok ctx)
 369   else let _ = "sat.length-check.else" in $$(unGen ko ctx)
 370   ||]
 371 {-
 372 emitLengthCheck n ok ko ctx = Gen $ \ctx -> [||
 373   if $$moreInput ($$shiftRight $$(input ctx) (n - 1))
 374   then $$(unGen ok ctx)
 375   else $$(unGen ko ctx {farthestExpecting = [||farExp||]})
 376   ||]
 377 -}
 378
 379
 380 liftCode :: InstrPure a -> CodeQ a
 381 liftCode = trans
 382 {-# INLINE liftCode #-}
 383
 384 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
 385 liftCode1 p a = case p of
 386   InstrPureSameOffset -> [|| $$sameOffset $$a ||]
 387   InstrPureHaskell h -> go a h
 388   where
 389   go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
 390   go qa = \case
 391     (H.:$) -> [|| \x -> $$qa x ||]
 392     (H.:.) -> [|| \g x -> $$qa (g x) ||]
 393     H.Flip -> [|| \x y -> $$qa y x ||]
 394     (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
 395     H.Const -> [|| \_ -> $$qa ||]
 396     H.Flip H.:@ H.Const -> H.id
 397     h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
 398     H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
 399     H.Id -> qa
 400     h -> [|| $$(trans h) $$qa ||]
 401
 402 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
 403 liftCode2 p a b = case p of
 404   InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
 405   InstrPureHaskell h -> go a b h
 406   where
 407   go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
 408   go qa qb = \case
 409     (H.:$) -> [|| $$qa $$qb ||]
 410     (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
 411     H.Flip -> [|| \x -> $$qa x $$qb ||]
 412     H.Flip H.:@ H.Const -> [|| $$qb ||]
 413     H.Flip H.:@ f -> go qb qa f
 414     H.Const -> [|| $$qa ||]
 415     H.Cons -> [|| $$qa : $$qb ||]
 416     h -> [|| $$(trans h) $$qa $$qb ||]