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   , InstrExceptionable repr
  62   , InstrInputable repr
  63   , InstrJoinable repr
  64   , InstrCallable repr
  65   , InstrValuable repr
  66   , InstrReadable tok repr
  67   , InstrIterable repr
  68   , InstrRegisterable repr
  69   , Eq tok
  70   , Ord tok
  71   , TH.Lift tok
  72   , NFData tok
  73   , Show tok
  74   , Typeable tok
  75   )
  76
  77 instance
  78   ( Cursorable (Cursor inp)
  79   , InstrBranchable repr
  80   , InstrExceptionable repr
  81   , InstrInputable repr
  82   , InstrJoinable repr
  83   , InstrValuable repr
  84   ) => CombAlternable (Program repr inp) where
  85   alt exn (Program l) (Program r) = joinNext $ Program $ \next ->
  86     liftM2 (catch exn)
  87       (l (commit exn next))
  88       (raiseAgainIfConsumed exn Functor.<$> r next)
  89   throw exn = Program $ \_next -> return $ raise exn
  90   failure flr = Program $ \_next -> return $ fail (Set.singleton flr)
  91   empty = Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEmpty))
  92   try (Program x) = Program $ \next ->
  93     liftM2 (catch ExceptionFailure)
  94       (x (commit ExceptionFailure next))
  95       -- On exception, reset the input, and propagate the failure.
  96       (return $ loadInput $ fail Set.empty)
  97
  98 -- | @(raiseAgainIfConsumed exn ok)@
  99 -- compares the stacked input position with the current one,
 100 -- in case they're the same then continue with @(ok)@,
 101 -- otherwise, re-'raise' @(exn)@,
 102 -- without updating the farthest error
 103 -- (which is usually done when 'fail'ing).
 104 raiseAgainIfConsumed ::
 105   Cursorable (Cursor inp) =>
 106   InstrBranchable repr =>
 107   InstrExceptionable repr =>
 108   InstrInputable repr =>
 109   InstrValuable repr =>
 110   Exception ->
 111   SomeInstr repr inp vs ret ->
 112   SomeInstr repr inp (Cursor inp ': vs) ret
 113 raiseAgainIfConsumed exn ok =
 114   pushInput $
 115   lift2Value (splice sameOffset) $
 116   ifBranch ok $
 117     case exn of
 118       ExceptionLabel lbl -> raise lbl
 119       ExceptionFailure -> fail Set.empty
 120
 121 -- | @('joinNext' m)@ factorize the next 'Instr'uction
 122 -- to be able to reuse it multiple times without duplication.
 123 -- It does so by introducing a 'defJoin'
 124 -- and passing the corresponding 'refJoin'
 125 -- as next 'Instr'uction to @(m)@,
 126 -- unless factorizing is useless because the next 'Instr'uction
 127 -- is already a 'refJoin' or a 'ret'.
 128 -- It should be used each time the next 'Instr'uction
 129 -- is used multiple times.
 130 joinNext ::
 131   InstrJoinable repr =>
 132   Program repr inp v ->
 133   Program repr inp v
 134 joinNext (Program m) = Program $ \case
 135   -- Double refJoin Optimization:
 136   -- If a join-node points directly to another join-node,
 137   -- then reuse it
 138   next@(Instr RefJoin{}) -> m next
 139   -- If a join-node points directly to a 'jump',
 140   -- then reuse it.
 141   -- Because 'Jump' expects an empty 'valueStack',
 142   -- a 'PopValue' has to be here to drop
 143   -- the value normaly expected by the 'next' 'Instr'uction.
 144   next@(Instr (PopValue (Instr Jump{}))) -> m next
 145   -- Terminal refJoin Optimization:
 146   -- If a join-node points directly to a terminal operation,
 147   -- then it's useless to introduce a join-node.
 148   next@(Instr Ret{}) -> m next
 149   -- Introduce a join-node.
 150   next -> do
 151     !joinName <- TH.newName "join"
 152     defJoin (LetName joinName) next
 153       Functor.<$> m (refJoin (LetName joinName))
 154
 155 instance
 156   InstrValuable repr =>
 157   CombApplicable (Program repr inp) where
 158   pure x = Program $ return . pushValue (prodCode x)
 159   Program f <*> Program x = Program $ (f <=< x) . applyValue
 160   liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (prodCode f)
 161   Program x *> Program y = Program (x <=< return . popValue <=< y)
 162   Program x <* Program y = Program (x <=< y <=< return . popValue)
 163 instance
 164   ( Cursorable (Cursor inp)
 165   , InstrBranchable repr
 166   , InstrCallable repr
 167   , InstrExceptionable repr
 168   , InstrInputable repr
 169   , InstrIterable repr
 170   , InstrJoinable repr
 171   , InstrRegisterable repr
 172   , InstrValuable repr
 173   ) => CombFoldable (Program repr inp) where
 174   chainPre (Program op) (Program done) =
 175     new (pure Prod.id) $ \(Register r) -> Program $ \next -> do
 176       !loopName <- TH.newName "loop"
 177       liftM2 (iter (LetName loopName))
 178         (op $
 179           mapValue (Prod.flip Prod..@ (Prod..)) $
 180           modifyRegister r $
 181           jump True (LetName loopName) )
 182         (raiseAgainIfConsumed ExceptionFailure .
 183           readRegister r Functor.<$>
 184           (done (applyValue next)))
 185   chainPost (Program done) (Program op) =
 186     new (pure Prod.id) $ \(Register r) -> Program $ \next -> do
 187       !loopName <- TH.newName "loop"
 188       liftM2 (iter (LetName loopName))
 189         (op $
 190           modifyRegister (UnscopedRegister (unUnscopedRegister r)) $
 191           jump True (LetName loopName) )
 192         (raiseAgainIfConsumed ExceptionFailure .
 193           readRegister r Functor.<$>
 194           (done (applyValue next)))
 195 instance
 196   InstrCallable repr =>
 197   Referenceable TH.Name (Program repr inp) where
 198   -- TODO: isRec should be passed to 'call' and 'jump'
 199   -- instead of redoing the work with 'CallTrace'.
 200   ref isRec name = Program $ \case
 201     -- Tail Call Optimization:
 202     -- returning just after a 'call' is useless:
 203     -- using 'jump' lets the 'ret' of the 'defLet'
 204     -- directly return where it would in two 'ret's.
 205     Instr Ret{} -> return $ jump isRec (LetName name)
 206     next -> return $ call isRec (LetName name) next
 207   {-
 208   refable n (Program sub) = Program $ \next -> do
 209     sub' <- sub ret
 210     return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
 211   -}
 212 instance
 213   InstrCallable repr =>
 214   Letsable TH.Name (Program repr inp) where
 215   lets defs (Program body) = Program $ \next -> do
 216     -- Every definition becomes a 'call'able subroutine.
 217     defs' <- Traversable.traverse
 218       (\(SomeLet (Program val)) -> liftM SomeLet (val ret))
 219       defs
 220     liftM (defLet defs') (body next)
 221 instance
 222   ( Eq (InputToken inp)
 223   , Cursorable (Cursor inp)
 224   , InstrBranchable repr
 225   , InstrExceptionable repr
 226   , InstrInputable repr
 227   , InstrJoinable repr
 228   , InstrReadable (InputToken inp) repr
 229   , Typeable (InputToken inp)
 230   , InstrValuable repr
 231   ) => CombLookable (Program repr inp) where
 232   look (Program x) = Program $ \next ->
 233     liftM pushInput (x (swapValue (loadInput next)))
 234   eof = negLook (satisfy (Prod.const Prod..@ Prod.bool True))
 235         -- This sets a better failure message
 236         <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
 237   negLook (Program x) = Program $ \next ->
 238     liftM2 (catch ExceptionFailure)
 239       -- On x success, discard the result,
 240       -- and replace this 'Catcher' by a failure whose 'farthestExpecting' is negated,
 241       -- then a failure is raised from the input
 242       -- when entering 'negLook', to avoid odd cases:
 243       -- - where the failure that made (negLook x)
 244       --   succeed can get the blame for the overall
 245       --   failure of the grammar.
 246       -- - where the overall failure of
 247       --   the grammar might be blamed on something in x
 248       --   that, if corrected, still makes x succeed
 249       --   and (negLook x) fail.
 250       (liftM pushInput $ x $
 251         popValue $ commit ExceptionFailure $
 252           loadInput $ fail Set.empty)
 253       -- On x failure, reset the input,
 254       -- and go on with the next 'Instr'uctions.
 255       (return $ loadInput $ pushValue Prod.unit next)
 256 instance
 257   ( InstrBranchable repr
 258   , InstrJoinable repr
 259   ) => CombMatchable (Program repr inp) where
 260   conditional (Program a) bs (Program d) = joinNext $ Program $ \next -> do
 261     bs' <- Control.Monad.sequence $ (\(p, b) -> (prodCode p,) Functor.<$> unProgram b next) Functor.<$> bs
 262     a =<< liftM (choicesBranch bs') (d next)
 263 instance
 264   ( tok ~ InputToken inp
 265   , InstrReadable tok repr
 266   , Typeable tok
 267   ) => CombSatisfiable tok (Program repr inp) where
 268   -- Note: 'read' is left with the responsability
 269   -- to apply 'normalOrderReduction' if need be.
 270   satisfyOrFail fs p = Program $ return . read fs (prodCode p)
 271 instance
 272   ( InstrBranchable repr
 273   , InstrJoinable repr
 274   , InstrValuable repr
 275   ) => CombSelectable (Program repr inp) where
 276   branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
 277     lr =<< liftM2 caseBranch
 278       (l (swapValue (applyValue next)))
 279       (r (swapValue (applyValue next)))
 280 instance
 281   ( InstrValuable repr
 282   , InstrRegisterable repr
 283   ) => CombRegisterable (Program repr inp) where
 284   new (Program p) k = Program $ \next -> do
 285     !regName <- TH.newName "reg"
 286     p =<< liftM (newRegister (UnscopedRegister regName))
 287       (unProgram (k (Register (UnscopedRegister regName))) next)
 288   get (Register r) = Program $ \next ->
 289     return $ readRegister r next
 290   put (Register r) (Program k) = Program $ \next ->
 291     k $ writeRegister r $ pushValue Prod.unit next
 292 instance
 293   ( InstrValuable repr
 294   , InstrRegisterable repr
 295   ) => CombRegisterableUnscoped (Program repr inp) where
 296   newUnscoped r (Program p) k = Program $ \next ->
 297     p =<< liftM (newRegister r) (unProgram k next)
 298   getUnscoped r = Program $ return . readRegister r
 299   putUnscoped r (Program k) = Program $
 300     k . writeRegister r . pushValue Prod.unit