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