src/Symantic/Parser/Machine/Program.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE TupleSections #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
   5 -- | Build the 'Instr'uction 'Program' of a 'Machine'
   6 -- from the 'Comb'inators of a 'Grammar'.
   7 -- 'Instr'uctions are kept introspectable
   8 -- to enable more optimizations made possible now because
   9 -- of a broader knowledge of the 'Instr'uctions around
  10 -- those generated (see for instance 'joinNext').
  11 module Symantic.Parser.Machine.Program where
  12
  13 import Control.DeepSeq (NFData)
  14 import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
  15 import Data.Bool (Bool(..))
  16 import Data.Eq (Eq)
  17 import Data.Function (($), (.))
  18 import Data.Ord (Ord)
  19 import Data.Maybe (Maybe(..))
  20 import Data.String (IsString(..))
  21 import Data.Either (Either (..))
  22 import Data.Semigroup (Semigroup(..))
  23 import System.IO (IO)
  24 import Text.Show (Show(..))
  25 import Type.Reflection (Typeable)
  26 import qualified Data.Functor as Functor
  27 import qualified Data.Traversable as Traversable
  28 import qualified Language.Haskell.TH as TH
  29 import qualified Language.Haskell.TH.Syntax as TH
  30 import qualified Language.Haskell.TH.Show as TH
  31 import qualified Symantic.Syntaxes.Classes as Prod
  32 import qualified Symantic.Semantics.Data as Prod
  33
  34 import Symantic.Syntaxes.Derive
  35 import Symantic.Semantics.Data (SomeData(..))
  36 import Symantic.Parser.Grammar
  37 import Symantic.Parser.Machine.Input
  38 import Symantic.Parser.Machine.Instructions
  39 import Symantic.Parser.Machine.Optimize
  40
  41 -- * Type 'Program'
  42 -- | A 'Program' is a tree of 'Instr'uctions generated from 'Comb'inators.
  43 -- Each 'Instr'uction is built by a continuation
  44 -- to be able to introspect, duplicate and/or change
  45 -- the next 'Instr'uction.
  46 data Program repr inp a = Program
  47   { programWriter :: WriteGrammar 'True a
  48   , unProgram ::
  49   forall vs ret.
  50   -- This is the next instruction.
  51   SomeInstr repr inp (a ': vs) ret ->
  52   -- This is the current instruction
  53   -- IO is needed for 'TH.newName'.
  54   IO (SomeInstr repr inp vs ret)
  55   }
  56
  57 -- | Build an interpreter of the 'Program' of the given 'Machinable'.
  58 optimizeMachine ::
  59   forall inp repr a.
  60   Machinable (InputToken inp) repr =>
  61   Program repr inp a ->
  62   IO (repr inp '[] a)
  63 optimizeMachine p = derive Functor.<$> unProgram p @'[] ret
  64
  65 -- * Class 'Machinable'
  66 -- | All the 'Instr'uctions.
  67 type Machinable tok repr =
  68   ( InstrBranchable repr
  69   , InstrComment repr
  70   , InstrExceptionable repr
  71   , InstrInputable repr
  72   , InstrJoinable repr
  73   , InstrCallable repr
  74   , InstrValuable repr
  75   , InstrReadable tok repr
  76   , InstrIterable repr
  77   , InstrRegisterable repr
  78   , Eq tok
  79   , Ord tok
  80   , TH.Lift tok
  81   , NFData tok
  82   , Show tok
  83   , Typeable tok
  84   )
  85
  86 instance
  87   ( Positionable (InputPosition inp)
  88   , InstrBranchable repr
  89   , InstrComment repr
  90   , InstrExceptionable repr
  91   , InstrInputable repr
  92   , InstrJoinable repr
  93   , InstrValuable repr
  94   ) => CombAlternable (Program repr inp) where
  95   alt exn lP rP = joinNext $ Program (alt exn (programWriter lP) (programWriter rP)) $ \next ->
  96     liftM2
  97       (catch exn)
  98       (unProgram lP $ commit exn next)
  99       (raiseAgainIfConsumed exn Functor.<$> unProgram rP next)
 100   throw exn = Program (throw exn) $ \_next -> return $ raise exn
 101   empty = Program empty $ \_next -> return $ fail $ FailModeNewFailure [||SomeFailure empty||]
 102   try xP = Program (try (programWriter xP)) $ \next ->
 103     liftM2
 104       (catch ExceptionFailure)
 105       (unProgram xP $ commit ExceptionFailure next)
 106       -- On 'ExceptionFailure', reset the input, and propagate the failure.
 107       (return $ loadInput $ fail $ FailModePreserve)
 108
 109 -- | @(raiseAgainIfConsumed exn ok)@
 110 -- compares the stacked input position with the current one,
 111 -- in case they're the same then continue with @(ok)@,
 112 -- otherwise, re-'raise' @(exn)@,
 113 -- without updating the farthest error
 114 -- (which is usually done when 'fail'ing).
 115 raiseAgainIfConsumed ::
 116   Positionable (InputPosition inp) =>
 117   InstrBranchable repr =>
 118   InstrComment repr =>
 119   InstrExceptionable repr =>
 120   InstrInputable repr =>
 121   InstrValuable repr =>
 122   Exception ->
 123   SomeInstr repr inp vs ret ->
 124   SomeInstr repr inp (InputPosition inp ': vs) ret
 125 raiseAgainIfConsumed exn ok =
 126   comment "raiseAgainIfConsumed" $
 127   saveInput $
 128   lift2Value (splice samePosition) $
 129   ifBranch ok $
 130     case exn of
 131       ExceptionLabel lbl -> raise lbl
 132       ExceptionFailure -> fail $ FailModePreserve
 133
 134 -- | @('joinNext' m)@ factorize the next 'Instr'uction
 135 -- to be able to reuse it multiple times without duplication.
 136 -- It does so by introducing a 'defJoin'
 137 -- and passing the corresponding 'refJoin'
 138 -- as next 'Instr'uction to @(m)@,
 139 -- unless factorizing is useless because the next 'Instr'uction
 140 -- is already a 'refJoin' or a 'ret'.
 141 -- It should be used each time the next 'Instr'uction
 142 -- is used multiple times.
 143 joinNext ::
 144   InstrJoinable repr =>
 145   Program repr inp v ->
 146   Program repr inp v
 147 joinNext xP = Program (programWriter xP) $ \case
 148   -- Double refJoin Optimization:
 149   -- If a join-node points directly to another join-node,
 150   -- then reuse it
 151   next@(Instr RefJoin{}) -> unProgram xP next
 152   -- If a join-node points directly to a 'jump',
 153   -- then reuse it.
 154   -- Because 'Jump' expects an empty 'valueStack',
 155   -- a 'PopValue' has to be here to drop
 156   -- the value normaly expected by the 'next' 'Instr'uction.
 157   next@(Instr (PopValue (Instr Jump{}))) -> unProgram xP next
 158   -- Terminal refJoin Optimization:
 159   -- If a join-node points directly to a terminal operation,
 160   -- then it's useless to introduce a join-node.
 161   next@(Instr Ret{}) -> unProgram xP next
 162   -- Introduce a join-node.
 163   next -> do
 164     !joinName <- TH.newName "join"
 165     defJoin (LetName joinName) next
 166       Functor.<$> unProgram xP (refJoin (LetName joinName))
 167
 168 instance
 169   InstrValuable repr =>
 170   CombApplicable (Program repr inp) where
 171   pure a = Program (pure a) $ return . pushValue (prodCode a)
 172   fP <*> xP = Program (programWriter fP <*> programWriter xP) $ (unProgram fP <=< unProgram xP) . applyValue
 173   liftA2 f xP yP = Program (liftA2 f (programWriter xP) (programWriter yP)) $ (unProgram xP <=< unProgram yP) . lift2Value (prodCode f)
 174   xP *> yP = Program (programWriter xP *> programWriter yP) (unProgram xP <=< return . popValue <=< unProgram yP)
 175   xP <* yP = Program (programWriter xP <* programWriter yP) (unProgram xP <=< unProgram yP <=< return . popValue)
 176 instance
 177   ( Positionable (InputPosition inp)
 178   , InstrBranchable repr
 179   , InstrCallable repr
 180   , InstrComment repr
 181   , InstrExceptionable repr
 182   , InstrInputable repr
 183   , InstrIterable repr
 184   , InstrJoinable repr
 185   , InstrRegisterable repr
 186   , InstrValuable repr
 187   ) => CombFoldable (Program repr inp) where
 188   chainPre opP doneP =
 189     new (pure Prod.id) $ \(Register r) -> Program (chainPre (programWriter opP) (programWriter doneP)) $ \next -> do
 190       !loopName <- TH.newName "loop"
 191       liftM2 (iter (LetName loopName))
 192         (unProgram opP $
 193           mapValue (Prod.flip Prod..@ (Prod..)) $
 194           modifyRegister r $
 195           jump True (LetName loopName) )
 196         (raiseAgainIfConsumed ExceptionFailure .
 197           readRegister r Functor.<$>
 198           (unProgram doneP (applyValue next)))
 199   chainPost doneP opP =
 200     new (pure Prod.id) $ \(Register r) -> Program (chainPost (programWriter doneP) (programWriter opP)) $ \next -> do
 201       !loopName <- TH.newName "loop"
 202       liftM2 (iter (LetName loopName))
 203         (unProgram opP $
 204           modifyRegister (UnscopedRegister (unUnscopedRegister r)) $
 205           -- recursive call
 206           jump True (LetName loopName) )
 207         (raiseAgainIfConsumed ExceptionFailure .
 208           readRegister r Functor.<$>
 209           (unProgram doneP (applyValue next)))
 210 instance
 211   InstrCallable repr =>
 212   Referenceable TH.Name (Program repr inp) where
 213   -- TODO: isRec should be passed to 'call' and 'jump'
 214   -- instead of redoing the work with 'CallTrace'.
 215   ref isRec name = Program (ref isRec name) $ \case
 216     -- Tail Call Optimization:
 217     -- returning just after a 'call' is useless:
 218     -- using 'jump' lets the 'ret' of the 'defLet'
 219     -- directly return where it would in two 'ret's.
 220     Instr Ret{} -> return $ jump isRec (LetName name)
 221     next -> return $ call isRec (LetName name) next
 222   {-
 223   refable n (Program sub) = Program $ \next -> do
 224     sub' <- sub ret
 225     return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
 226   -}
 227 instance
 228   InstrCallable repr =>
 229   Letsable TH.Name (Program repr inp) where
 230   lets defs bodyP = Program (lets ((\(SomeLet valP) -> SomeLet (programWriter valP)) Functor.<$> defs) (programWriter bodyP)) $ \next -> do
 231     -- Every definition becomes a 'call'able subroutine.
 232     defs' <- Traversable.traverse
 233       (\(SomeLet valP) -> liftM SomeLet (unProgram valP ret))
 234       defs
 235     liftM (defLet defs') (unProgram bodyP next)
 236 instance
 237   ( tok ~ InputToken inp
 238   , TH.Lift tok, Eq tok, Ord tok, Show tok, Typeable tok, NFData tok
 239   , Positionable (InputPosition inp)
 240   , InstrBranchable repr
 241   , InstrExceptionable repr
 242   , InstrInputable repr
 243   , InstrJoinable repr
 244   , InstrReadable tok repr
 245   , InstrValuable repr
 246   , InstrComment repr
 247   ) => CombLookable (Program repr inp) where
 248   look xP = Program (look (programWriter xP)) $ \next ->
 249     liftM (comment "look") $
 250     liftM saveInput $
 251     unProgram xP $
 252     swapValue $
 253     loadInput next
 254   -- FIXME: checkHorizon is enough instead of FailureAny
 255   eof = negLook item
 256   -- (negLook xP) always ignore the error information inside xP,
 257   -- which is the simplest approach, and also gives a consistent result for (negLook (negLook xP))
 258   negLook xP = Program (negLook (programWriter xP)) $ \next ->
 259     liftM (comment "negLook") $
 260     liftM2 (catch ExceptionFailure)
 261       -- On the success of x: discard the result,
 262       -- and replace this 'OnException' by a failure
 263       -- whose 'farthestExpecting' is negated,
 264       (
 265         liftM (comment "negLook.ahead") $
 266         liftM saveInput $
 267         unProgram xP $ -- if x fails, goes to negLook.reset
 268         popValue $
 269         commit ExceptionFailure $
 270         -- Rule: not.2
 271         -- Reset the input position to that when entering negLook,
 272         -- otherwise the overall failure of the parsing
 273         -- might be blamed on something in xP that, if corrected,
 274         -- still makes xP succeed and (negLook xP) fail.
 275         loadInput $
 276         -- Because of the previous 'commit',
 277         -- that failure is no longer caught by 'negLook''s 'catch'.
 278         fail $ FailModeNewFailure [||SomeFailure (WriteGrammar (\inh ->
 279           Just (fromString $$(TH.liftTypedString $ showsPrec 0
 280             (negLook (programWriter xP)) ""))))||]
 281       )
 282       -- On the failure of x: reset the input,
 283       -- and go on with the next 'Instr'uctions.
 284       (
 285         -- Rule: not.1
 286         liftM (comment "negLook.reset") $
 287         return $
 288           loadInput $
 289           pushValue Prod.unit next
 290       )
 291 instance
 292   ( InstrBranchable repr
 293   , InstrJoinable repr
 294   ) => CombMatchable (Program repr inp) where
 295   conditional aP bs dP = joinNext $ Program
 296     (conditional (programWriter aP) ((programWriter Functor.<$>) Functor.<$> bs) (programWriter dP)) $ \next -> do
 297     bs' <- Control.Monad.sequence $ (\(p, b) -> (prodCode p,) Functor.<$> unProgram b next) Functor.<$> bs
 298     unProgram aP =<< liftM (choicesBranch bs') (unProgram dP next)
 299 instance
 300   ( tok ~ InputToken inp
 301   , InstrReadable tok repr
 302   , InstrComment repr
 303   , Typeable tok
 304   ) => CombSatisfiable tok (Program repr inp) where
 305   satisfyOrFail pred = Program (satisfyOrFail pred) $ \next ->
 306     return $
 307       comment ("satisfy "<>showsPrec 11 (prodCode pred) "") $
 308       read (prodCode pred) next
 309 instance
 310   ( InstrBranchable repr
 311   , InstrJoinable repr
 312   , InstrValuable repr
 313   ) => CombSelectable (Program repr inp) where
 314   branch lrP lP rP = joinNext $ Program (branch (programWriter lrP) (programWriter lP) (programWriter rP)) $ \next ->
 315     unProgram lrP =<< liftM2 caseBranch
 316       (unProgram lP (swapValue (applyValue next)))
 317       (unProgram rP (swapValue (applyValue next)))
 318 instance
 319   ( InstrValuable repr
 320   , InstrRegisterable repr
 321   ) => CombRegisterable (Program repr inp) where
 322   new xP k = Program (new (programWriter xP) (programWriter . k)) $ \next -> do
 323     !regName <- TH.newName "reg"
 324     unProgram xP =<< liftM (newRegister (UnscopedRegister regName))
 325       (unProgram (k (Register (UnscopedRegister regName))) next)
 326   get reg@(Register r) = Program (get reg) $ \next ->
 327     return $ readRegister r next
 328   put reg@(Register r) xP = Program (put reg (programWriter xP)) $ \next ->
 329     unProgram xP $ writeRegister r $ pushValue Prod.unit next
 330 instance
 331   ( InstrValuable repr
 332   , InstrRegisterable repr
 333   ) => CombRegisterableUnscoped (Program repr inp) where
 334   newUnscoped r xP kP = Program (newUnscoped r (programWriter xP) (programWriter kP)) $ \next ->
 335     unProgram xP =<< liftM (newRegister r) (unProgram kP next)
 336   getUnscoped r = Program (getUnscoped r) $ return . readRegister r
 337   putUnscoped r xP = Program (putUnscoped r (programWriter xP)) $
 338     unProgram xP . writeRegister r . pushValue Prod.unit