src/Symantic/Parser/Machine/Program.hs

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