src/Symantic/Parser/Machine/Program.hs

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