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