src/Symantic/Parser/Machine/Program.hs

   1 {-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
   2 -- | Build the 'Instr'uction 'Program' of a 'Machine'
   3 -- from the 'Comb'inators of a 'Grammar'.
   4 -- 'Instr'uctions are kept introspectable
   5 -- to enable more optimizations now possible because
   6 -- of a broader knowledge of the 'Instr'uctions around
   7 -- those generated (eg. by using 'joinNext').
   8 module Symantic.Parser.Machine.Program where
   9
  10 import Data.Bool (Bool(..))
  11 import Data.Ord (Ord)
  12 import Data.Function (($), (.))
  13 import Type.Reflection (Typeable)
  14 import Data.Proxy (Proxy(..))
  15 import System.IO.Unsafe (unsafePerformIO)
  16 import qualified Data.Functor as Functor
  17 import qualified Language.Haskell.TH as TH
  18 import qualified Language.Haskell.TH.Syntax as TH
  19 import qualified Symantic.Parser.Haskell as H
  20
  21 import Symantic.Parser.Grammar
  22 import Symantic.Parser.Machine.Input
  23 import Symantic.Parser.Machine.Instructions
  24 import Symantic.Parser.Machine.Optimize
  25 import Symantic.Univariant.Trans
  26
  27 -- * Type 'Program'
  28 -- | A 'Program' is a tree of 'Instr'uctions,
  29 -- where each 'Instr'uction is built by a continuation
  30 -- to be able to introspect, duplicate and/or change
  31 -- the next 'Instr'uction.
  32 data Program repr inp a = Program { unProgram ::
  33   forall vs ret.
  34   -- This is the next instruction
  35   SomeInstr repr inp (a ': vs) ret ->
  36   -- This is the current instruction
  37   SomeInstr repr inp vs ret }
  38
  39 -- | Build an interpreter of the 'Program' of the given 'Machine'.
  40 optimizeMachine ::
  41   forall inp repr a.
  42   Machine (InputToken inp) repr =>
  43   Program repr inp a ->
  44   repr inp '[] a
  45 optimizeMachine (Program f) = trans (f @'[] ret)
  46
  47 instance
  48   InstrValuable repr =>
  49   Applicable (Program repr inp) where
  50   pure x = Program (pushValue (trans x))
  51   Program f <*> Program x = Program (f . x . applyValue)
  52   liftA2 f (Program x) (Program y) =
  53     Program (x . y . lift2Value (trans f))
  54   Program x *> Program y = Program (x . popValue . y)
  55   Program x <* Program y = Program (x . y . popValue)
  56 instance
  57   ( Cursorable (Cursor inp)
  58   , InstrBranchable repr
  59   , InstrExceptionable repr
  60   , InstrInputable repr
  61   , InstrJoinable repr
  62   , InstrValuable repr
  63   ) => Alternable (Program repr inp) where
  64   empty = Program $ \_next -> fail []
  65   Program l <|> Program r = joinNext $ Program $ \next ->
  66     catchException (Proxy @"fail")
  67       (l (popException (Proxy @"fail") next))
  68       (failIfConsumed (r next))
  69   try (Program x) = Program $ \next ->
  70     catchException (Proxy @"fail")
  71       (x (popException (Proxy @"fail") next))
  72       -- On exception, reset the input,
  73       -- and propagate the failure.
  74       (loadInput (fail []))
  75
  76 -- | If no input has been consumed by the failing alternative
  77 -- then continue with the given continuation.
  78 -- Otherwise, propagate the failure.
  79 failIfConsumed ::
  80   Cursorable (Cursor inp) =>
  81   InstrBranchable repr =>
  82   InstrExceptionable repr =>
  83   InstrInputable repr =>
  84   InstrValuable repr =>
  85   SomeInstr repr inp vs ret ->
  86   SomeInstr repr inp (Cursor inp : vs) ret
  87 failIfConsumed k = pushInput (lift2Value (H.Term sameOffset) (ifBranch k (fail [])))
  88
  89 -- | @('joinNext' m)@ factorize the next 'Instr'uction
  90 -- to be able to reuse it multiple times without duplication.
  91 -- It does so by introducing a 'defJoin'
  92 -- and passing the corresponding 'refJoin'
  93 -- as next 'Instr'uction to @(m)@,
  94 -- unless factorizing is useless because the next 'Instr'uction
  95 -- is already a 'refJoin' or a 'ret'.
  96 -- It should be used each time the next 'Instr'uction
  97 -- is used multiple times.
  98 joinNext ::
  99   InstrJoinable repr =>
 100   Program repr inp v ->
 101   Program repr inp v
 102 joinNext (Program m) = Program $ \case
 103   -- Double refJoin Optimization:
 104   -- If a join-node points directly to another join-node,
 105   -- then reuse it
 106   next@(Instr RefJoin{}) -> m next
 107   -- Terminal refJoin Optimization:
 108   -- If a join-node points directly to a terminal operation,
 109   -- then it's useless to introduce a join-node.
 110   next@(Instr Ret{}) -> m next
 111   -- Introduce a join-node.
 112   next -> defJoin joinName next (m (refJoin joinName))
 113     where joinName = LetName $ unsafePerformIO $ TH.qNewName "join"
 114 instance
 115   InstrExceptionable repr =>
 116   Throwable (Program repr inp) where
 117   type ThrowableLabel (Program repr inp) lbl =
 118     ()
 119   throw lbl = Program $ \_next -> raiseException lbl []
 120 instance
 121   ( tok ~ InputToken inp
 122   , InstrReadable tok repr
 123   , Typeable tok
 124   ) => Satisfiable tok (Program repr inp) where
 125   satisfy es p = Program $ read es (trans p)
 126 instance
 127   ( InstrBranchable repr
 128   , InstrJoinable repr
 129   , InstrValuable repr
 130   ) => Selectable (Program repr inp) where
 131   branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
 132     lr (caseBranch
 133       (l (swapValue (applyValue next)))
 134       (r (swapValue (applyValue next))))
 135 instance
 136   ( InstrBranchable repr
 137   , InstrJoinable repr
 138   ) => Matchable (Program repr inp) where
 139   conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next ->
 140     a (choicesBranch
 141       (trans Functor.<$> ps)
 142       ((\(Program b) -> b next) Functor.<$> bs)
 143       (d next))
 144 instance
 145   ( Ord (InputToken inp)
 146   , Cursorable (Cursor inp)
 147   , InstrBranchable repr
 148   , InstrExceptionable repr
 149   , InstrInputable repr
 150   , InstrJoinable repr
 151   , InstrReadable (InputToken inp) repr
 152   , Typeable (InputToken inp)
 153   , InstrValuable repr
 154   ) => Lookable (Program repr inp) where
 155   look (Program x) = Program $ \next ->
 156     pushInput (x (swapValue (loadInput next)))
 157   eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))
 158         -- This sets a better failure message
 159         <|> (Program $ \_k -> fail [ErrorItemEnd])
 160   negLook (Program x) = Program $ \next ->
 161     catchException (Proxy @"fail")
 162       -- On x success, discard the result,
 163       -- and replace this 'CatchException''s failure handler
 164       -- by a failure whose 'farthestExpecting' is negated,
 165       -- then a failure is raised from the input
 166       -- when entering 'negLook', to avoid odd cases:
 167       -- - where the failure that made (negLook x)
 168       --   succeed can get the blame for the overall
 169       --   failure of the grammar.
 170       -- - where the overall failure of
 171       --   the grammar might be blamed on something in x
 172       --   that, if corrected, still makes x succeed and
 173       --   (negLook x) fail.
 174       (pushInput (x
 175         (popValue (popException (Proxy @"fail") (loadInput
 176           (fail []))))))
 177       -- On x failure, reset the input,
 178       -- and go on with the next 'Instr'uctions.
 179       (loadInput (pushValue H.unit next))
 180 instance
 181   InstrLetable repr =>
 182   Letable TH.Name (Program repr inp) where
 183   def n (Program v) = Program $ \next ->
 184     defLet (LetName n) (v ret) (call (LetName n) next)
 185   ref _isRec n = Program $ \case
 186     -- Returning just after a 'call' is useless:
 187     -- using 'jump' lets the 'ret' of the 'defLet'
 188     -- directly return where it would in two 'ret's.
 189     Instr Ret{} -> jump (LetName n)
 190     next -> call (LetName n) next
 191 instance
 192   ( Cursorable (Cursor inp)
 193   , InstrBranchable repr
 194   , InstrExceptionable repr
 195   , InstrInputable repr
 196   , InstrJoinable repr
 197   , InstrValuable repr
 198   ) => Foldable (Program repr inp) where
 199   {-
 200   chainPre op p = go <*> p
 201     where go = (H..) <$> op <*> go <|> pure H.id
 202   chainPost p op = p <**> go
 203     where go = (H..) <$> op <*> go <|> pure H.id
 204   -}