src/Symantic/Parser/Machine/Program.hs

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