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.Univariant.Lang as H
  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.Univariant.Trans
  33 import Debug.Trace
  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' in 'joinNext'.
  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) = trans 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   , Eq tok
  68   , TH.Lift tok
  69   , NFData tok
  70   , Show tok
  71   , Typeable tok
  72   )
  73
  74 instance
  75   ( Cursorable (Cursor inp)
  76   , InstrBranchable repr
  77   , InstrExceptionable repr
  78   , InstrInputable repr
  79   , InstrJoinable repr
  80   , InstrValuable repr
  81   , InstrReadable (InputToken inp) repr
  82   , Typeable (InputToken inp)
  83   ) =>
  84   Trans (Comb CombAlternable (Program repr inp)) (Program repr inp) where
  85   trans = \case
  86     Alt ExceptionFailure
  87       (Comb (SatisfyOrFail _fs p :: Comb (CombSatisfiable (InputToken inp)) (Program repr inp) a))
  88       (Comb (Failure sf)) ->
  89       Program $ return . trace "trans.read" . read (Set.singleton sf) (trace "read.prodCode" (prodCode p))
  90     Alt exn x y -> alt exn (trans x) (trans y)
  91     Empty -> empty
  92     Failure sf -> failure sf
  93     Throw exn -> throw exn
  94     Try x -> try (trans x)
  95
  96 instance
  97   ( Cursorable (Cursor inp)
  98   , InstrBranchable repr
  99   , InstrExceptionable repr
 100   , InstrInputable repr
 101   , InstrJoinable repr
 102   , InstrValuable repr
 103   ) => CombAlternable (Program repr inp) where
 104   alt exn (Program l) (Program r) = joinNext $ Program $ \next ->
 105     liftM2 (catch exn)
 106       (l (commit exn next))
 107       (failIfConsumed exn Functor.<$> r next)
 108   throw exn = Program $ \_next -> return $ raise exn
 109   failure flr = Program $ \_next -> return $ fail (Set.singleton flr)
 110   empty = Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEmpty))
 111   try (Program x) = Program $ \next ->
 112     liftM2 (catch ExceptionFailure)
 113       (x (commit ExceptionFailure next))
 114       -- On exception, reset the input, and propagate the failure.
 115       (return $ loadInput $ fail Set.empty)
 116
 117 -- | If no input has been consumed by the failing alternative
 118 -- then continue with the given continuation.
 119 -- Otherwise, propagate the failure.
 120 failIfConsumed ::
 121   Cursorable (Cursor inp) =>
 122   InstrBranchable repr =>
 123   InstrExceptionable repr =>
 124   InstrInputable repr =>
 125   InstrValuable repr =>
 126   Exception ->
 127   SomeInstr repr inp vs ret ->
 128   SomeInstr repr inp (Cursor inp ': vs) ret
 129 failIfConsumed exn k =
 130   pushInput $
 131   lift2Value (splice sameOffset) $
 132   ifBranch k $
 133     case exn of
 134       ExceptionLabel lbl -> raise lbl
 135       ExceptionFailure -> fail Set.empty
 136
 137 -- | @('joinNext' m)@ factorize the next 'Instr'uction
 138 -- to be able to reuse it multiple times without duplication.
 139 -- It does so by introducing a 'defJoin'
 140 -- and passing the corresponding 'refJoin'
 141 -- as next 'Instr'uction to @(m)@,
 142 -- unless factorizing is useless because the next 'Instr'uction
 143 -- is already a 'refJoin' or a 'ret'.
 144 -- It should be used each time the next 'Instr'uction
 145 -- is used multiple times.
 146 joinNext ::
 147   InstrJoinable repr =>
 148   Program repr inp v ->
 149   Program repr inp v
 150 joinNext (Program m) = Program $ \case
 151   -- Double refJoin Optimization:
 152   -- If a join-node points directly to another join-node,
 153   -- then reuse it
 154   next@(Instr RefJoin{}) -> m next
 155   -- Terminal refJoin Optimization:
 156   -- If a join-node points directly to a terminal operation,
 157   -- then it's useless to introduce a join-node.
 158   next@(Instr Ret{}) -> m next
 159   -- Introduce a join-node.
 160   next -> do
 161     !joinName <- TH.newName "join"
 162     defJoin (LetName joinName) next
 163       Functor.<$> m (refJoin (LetName joinName))
 164
 165 instance
 166   InstrValuable repr =>
 167   CombApplicable (Program repr inp) where
 168   pure x = Program $ return . pushValue (prodCode (trace "pushValue.prodCode" x))
 169   Program f <*> Program x = Program $ (f <=< x) . applyValue
 170   liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (prodCode f)
 171   Program x *> Program y = Program (x <=< return . popValue <=< y)
 172   Program x <* Program y = Program (x <=< y <=< return . popValue)
 173 instance
 174   ( Cursorable (Cursor inp)
 175   , InstrBranchable repr
 176   , InstrExceptionable repr
 177   , InstrInputable repr
 178   , InstrJoinable repr
 179   , InstrValuable repr
 180   ) => CombFoldable (Program repr inp) where
 181   {-
 182   chainPre op p = go <*> p
 183     where go = (H..) <$> op <*> go <|> pure H.id
 184   chainPost p op = p <**> go
 185     where go = (H..) <$> op <*> go <|> pure H.id
 186   -}
 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   ( Eq (InputToken inp)
 207   , Cursorable (Cursor inp)
 208   , InstrBranchable repr
 209   , InstrExceptionable repr
 210   , InstrInputable repr
 211   , InstrJoinable repr
 212   , InstrReadable (InputToken inp) repr
 213   , Typeable (InputToken inp)
 214   , InstrValuable repr
 215   ) => CombLookable (Program repr inp) where
 216   look (Program x) = Program $ \next ->
 217     liftM pushInput (x (swapValue (loadInput next)))
 218   eof = negLook (satisfy (H.lam1 (\_x -> H.bool True)))
 219         -- This sets a better failure message
 220         <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
 221   negLook (Program x) = Program $ \next ->
 222     liftM2 (catch ExceptionFailure)
 223       -- On x success, discard the result,
 224       -- and replace this 'Catcher' by a failure whose 'farthestExpecting' is negated,
 225       -- then a failure is raised from the input
 226       -- when entering 'negLook', to avoid odd cases:
 227       -- - where the failure that made (negLook x)
 228       --   succeed can get the blame for the overall
 229       --   failure of the grammar.
 230       -- - where the overall failure of
 231       --   the grammar might be blamed on something in x
 232       --   that, if corrected, still makes x succeed
 233       --   and (negLook x) fail.
 234       (liftM pushInput $ x $
 235         popValue $ commit ExceptionFailure $
 236           loadInput $ fail Set.empty)
 237       -- On x failure, reset the input,
 238       -- and go on with the next 'Instr'uctions.
 239       (return $ loadInput $ pushValue H.unit next)
 240 instance
 241   ( InstrBranchable repr
 242   , InstrJoinable repr
 243   ) => CombMatchable (Program repr inp) where
 244   conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
 245     bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
 246     a =<< liftM (choicesBranch (prodCode Functor.<$> ps) bs') (d next)
 247 instance
 248   ( tok ~ InputToken inp
 249   , InstrReadable tok repr
 250   , Typeable tok
 251   ) => CombSatisfiable tok (Program repr inp) where
 252   satisfyOrFail fs p = Program $ return . read fs (trace "satisfyOrFail.read.prodCode" (prodCode p))
 253 instance
 254   ( InstrBranchable repr
 255   , InstrJoinable repr
 256   , InstrValuable repr
 257   ) => CombSelectable (Program repr inp) where
 258   branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
 259     lr =<< liftM2 caseBranch
 260       (l (swapValue (applyValue next)))
 261       (r (swapValue (applyValue next)))