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.Parser.Haskell 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
  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) (trans 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 (H.Term 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   -- Terminal refJoin Optimization:
 155   -- If a join-node points directly to a terminal operation,
 156   -- then it's useless to introduce a join-node.
 157   next@(Instr Ret{}) -> m next
 158   -- Introduce a join-node.
 159   next -> do
 160     !joinName <- TH.newName "join"
 161     defJoin (LetName joinName) next
 162       Functor.<$> m (refJoin (LetName joinName))
 163
 164 instance
 165   InstrValuable repr =>
 166   CombApplicable (Program repr inp) where
 167   pure x = Program $ return . pushValue (trans x)
 168   Program f <*> Program x = Program $ (f <=< x) . applyValue
 169   liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (trans f)
 170   Program x *> Program y = Program (x <=< return . popValue <=< y)
 171   Program x <* Program y = Program (x <=< y <=< return . popValue)
 172 instance
 173   ( Cursorable (Cursor inp)
 174   , InstrBranchable repr
 175   , InstrExceptionable repr
 176   , InstrInputable repr
 177   , InstrJoinable repr
 178   , InstrValuable repr
 179   ) => CombFoldable (Program repr inp) where
 180   {-
 181   chainPre op p = go <*> p
 182     where go = (H..) <$> op <*> go <|> pure H.id
 183   chainPost p op = p <**> go
 184     where go = (H..) <$> op <*> go <|> pure H.id
 185   -}
 186 instance
 187   InstrCallable repr =>
 188   Letable TH.Name (Program repr inp) where
 189   shareable n (Program sub) = Program $ \next -> do
 190     sub' <- sub ret
 191     return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
 192   ref _isRec n = Program $ \case
 193     -- Returning just after a 'call' is useless:
 194     -- using 'jump' lets the 'ret' of the 'defLet'
 195     -- directly return where it would in two 'ret's.
 196     Instr Ret{} -> return $ jump (LetName n)
 197     next -> return $ call (LetName n) next
 198 instance
 199   InstrCallable repr =>
 200   Letsable TH.Name (Program repr inp) where
 201   lets defs (Program x) = Program $ \next -> do
 202     defs' <- Traversable.traverse (\(SomeLet (Program val)) -> liftM SomeLet (val ret)) defs
 203     liftM (defLet defs') (x next)
 204 instance
 205   ( Eq (InputToken inp)
 206   , Cursorable (Cursor inp)
 207   , InstrBranchable repr
 208   , InstrExceptionable repr
 209   , InstrInputable repr
 210   , InstrJoinable repr
 211   , InstrReadable (InputToken inp) repr
 212   , Typeable (InputToken inp)
 213   , InstrValuable repr
 214   ) => CombLookable (Program repr inp) where
 215   look (Program x) = Program $ \next ->
 216     liftM pushInput (x (swapValue (loadInput next)))
 217   eof = negLook (satisfy (H.lam1 (\_x -> H.bool True)))
 218         -- This sets a better failure message
 219         <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
 220   negLook (Program x) = Program $ \next ->
 221     liftM2 (catch ExceptionFailure)
 222       -- On x success, discard the result,
 223       -- and replace this 'Catcher' by a failure whose 'farthestExpecting' is negated,
 224       -- then a failure is raised from the input
 225       -- when entering 'negLook', to avoid odd cases:
 226       -- - where the failure that made (negLook x)
 227       --   succeed can get the blame for the overall
 228       --   failure of the grammar.
 229       -- - where the overall failure of
 230       --   the grammar might be blamed on something in x
 231       --   that, if corrected, still makes x succeed
 232       --   and (negLook x) fail.
 233       (liftM pushInput $ x $
 234         popValue $ commit ExceptionFailure $
 235           loadInput $ fail Set.empty)
 236       -- On x failure, reset the input,
 237       -- and go on with the next 'Instr'uctions.
 238       (return $ loadInput $ pushValue H.unit next)
 239 instance
 240   ( InstrBranchable repr
 241   , InstrJoinable repr
 242   ) => CombMatchable (Program repr inp) where
 243   conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
 244     bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
 245     a =<< liftM (choicesBranch (trans Functor.<$> ps) bs') (d next)
 246 instance
 247   ( tok ~ InputToken inp
 248   , InstrReadable tok repr
 249   , Typeable tok
 250   ) => CombSatisfiable tok (Program repr inp) where
 251   satisfyOrFail fs p = Program $ return . read fs (trans p)
 252 instance
 253   ( InstrBranchable repr
 254   , InstrJoinable repr
 255   , InstrValuable repr
 256   ) => CombSelectable (Program repr inp) where
 257   branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
 258     lr =<< liftM2 caseBranch
 259       (l (swapValue (applyValue next)))
 260       (r (swapValue (applyValue next)))