src/Symantic/Parser/Machine/Build.hs

   1 {-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
   2 -- | Build the 'Instr'uctions 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 'joinNextInstr').
   8 module Symantic.Parser.Machine.Build 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 'Machine'
  27 -- | A 'Machine' 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 the next 'Instr'uction.
  30 data Machine repr inp a = Machine { unMachine ::
  31     forall vs es ret.
  32     -- This is the next instruction
  33     SomeInstr repr inp (a ': vs) ('Succ es) ret ->
  34     -- This is the built instruction
  35     SomeInstr repr inp vs ('Succ es) ret
  36   }
  37
  38 -- | Build a 'Machine'.
  39 optimizeMachine ::
  40   forall inp es repr a.
  41   Executable (InputToken inp) repr =>
  42   Machine repr inp a ->
  43   repr inp '[] ('Succ es) a
  44 optimizeMachine (Machine m) = trans (m @'[] @es ret)
  45
  46 instance
  47   Stackable repr =>
  48   Applicable (Machine repr inp) where
  49   pure x = Machine (push (trans x))
  50   Machine f <*> Machine x = Machine (f . x . appI)
  51   liftA2 f (Machine x) (Machine y) =
  52     Machine (x . y . liftI2 (trans f))
  53   Machine x *> Machine y = Machine (x . pop . y)
  54   Machine x <* Machine y = Machine (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 (Machine repr inp) where
  63   empty = Machine $ \_next -> fail []
  64   Machine l <|> Machine r = joinNextInstr $ Machine $ \next ->
  65     catchFail
  66       (l (popFail next))
  67       (instrFailIfConsumed (r next))
  68   try (Machine x) = Machine $ \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 instrFailIfConsumed ::
  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 instrFailIfConsumed k = pushInput (liftI2 (H.Term sameOffset) (ifI k (fail [])))
  87
  88 -- | @('joinNextInstr' 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' to @(m)@,
  92 -- unless factorizing is useless because the next 'Instr'uction
  93 -- is already a 'RefJoin' or a 'Ret'.
  94 -- It should be used each time the next 'Instr'uction
  95 -- is used multiple times.
  96 joinNextInstr ::
  97   Joinable repr =>
  98   Machine repr inp v ->
  99   Machine repr inp v
 100 joinNextInstr (Machine m) = Machine $ \case
 101   -- Double RefJoin Optimization:
 102   -- If a join-node points directly to another join-node,
 103   -- then reuse it
 104   next@(Instr RefJoin{}) -> m next
 105   -- Terminal RefJoin Optimization:
 106   -- If a join-node points directly to a terminal operation,
 107   -- then it's useless to introduce a join-point.
 108   next@(Instr Ret{}) -> m next
 109   -- Introduce a join-node.
 110   next -> defJoin joinName next (m (refJoin joinName))
 111     where joinName = LetName $ unsafePerformIO $ TH.qNewName "join"
 112
 113 instance
 114   ( tok ~ InputToken inp
 115   , Readable tok repr
 116   , Typeable tok
 117   ) => Satisfiable tok (Machine repr inp) where
 118   satisfy es p = Machine $ read es (trans p)
 119 instance
 120   ( Branchable repr
 121   , Joinable repr
 122   , Stackable repr
 123   ) => Selectable (Machine repr inp) where
 124   branch (Machine lr) (Machine l) (Machine r) = joinNextInstr $ Machine $ \next ->
 125     lr (caseI
 126       (l (swap (appI next)))
 127       (r (swap (appI next))))
 128 instance
 129   ( Branchable repr
 130   , Joinable repr
 131   ) => Matchable (Machine repr inp) where
 132   conditional (Machine a) ps bs (Machine d) = joinNextInstr $ Machine $ \next ->
 133     a (choices
 134       (trans Functor.<$> ps)
 135       ((\(Machine b) -> b next) Functor.<$> bs)
 136       (d next))
 137 instance
 138   ( Ord (InputToken inp)
 139   , Cursorable (Cursor inp)
 140   , Branchable repr
 141   , Failable repr
 142   , Inputable repr
 143   , Joinable repr
 144   , Readable (InputToken inp) repr
 145   , Typeable (InputToken inp)
 146   , Stackable repr
 147   ) => Lookable (Machine repr inp) where
 148   look (Machine x) = Machine $ \next ->
 149     pushInput (x (swap (loadInput next)))
 150   eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))
 151         -- This sets a better failure message
 152         <|> (Machine $ \_k -> fail [ErrorItemEnd])
 153   negLook (Machine x) = Machine $ \next ->
 154     catchFail
 155       -- On x success, discard the result,
 156       -- and replace this 'CatchFail''s failure handler
 157       -- by a 'Fail'ure whose 'farthestExpecting' is negated,
 158       -- then a failure is raised from the input
 159       -- when entering 'negLook', to avoid odd cases:
 160       -- - where the failure that made (negLook x)
 161       --   succeed can get the blame for the overall
 162       --   failure of the grammar.
 163       -- - where the overall failure of
 164       --   the grammar might be blamed on something in x
 165       --   that, if corrected, still makes x succeed and
 166       --   (negLook x) fail.
 167       (pushInput (x (pop (popFail (loadInput (fail []))))))
 168       -- On x failure, reset the input,
 169       -- and go on with the next 'Instr'uctions.
 170       (loadInput (push H.unit next))
 171 instance
 172   Routinable repr =>
 173   Letable TH.Name (Machine repr inp) where
 174   def n (Machine v) = Machine $ \next ->
 175     subroutine (LetName n) (v ret) (call (LetName n) next)
 176   ref _isRec n = Machine $ \case
 177     -- Returning just after a 'call' is useless:
 178     -- using 'jump' lets the 'ret' of the 'subroutine'
 179     -- directly return where it would in two 'ret's.
 180     Instr Ret{} -> jump (LetName n)
 181     next -> call (LetName n) next
 182 instance
 183   ( Cursorable (Cursor inp)
 184   , Branchable repr
 185   , Failable repr
 186   , Inputable repr
 187   , Joinable repr
 188   , Stackable repr
 189   ) => Foldable (Machine repr inp) where
 190   {-
 191   chainPre op p = go <*> p
 192     where go = (H..) <$> op <*> go <|> pure H.id
 193   chainPost p op = p <**> go
 194     where go = (H..) <$> op <*> go <|> pure H.id
 195   -}