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 Data.Proxy (Proxy(..))
  15 import System.IO (IO)
  16 import Type.Reflection (Typeable)
  17 import qualified Data.Functor as Functor
  18 import qualified Data.HashMap.Strict as HM
  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.qNewName'.
  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   ) => CombAlternable (Program repr inp) where
  59   empty = Program $ \_next -> return $ fail []
  60   Program l <|> Program r = joinNext $ Program $ \next ->
  61     liftM2 (catchException (Proxy @"fail"))
  62       (l (popException (Proxy @"fail") next))
  63       (failIfConsumed Functor.<$> r next)
  64   try (Program x) = Program $ \next ->
  65     liftM2 (catchException (Proxy @"fail"))
  66       (x (popException (Proxy @"fail") next))
  67       -- On exception, reset the input,
  68       -- and propagate the failure.
  69       (return $ loadInput (fail []))
  70
  71 -- | If no input has been consumed by the failing alternative
  72 -- then continue with the given continuation.
  73 -- Otherwise, propagate the failure.
  74 failIfConsumed ::
  75   Cursorable (Cursor inp) =>
  76   InstrBranchable repr =>
  77   InstrExceptionable repr =>
  78   InstrInputable repr =>
  79   InstrValuable repr =>
  80   SomeInstr repr inp vs ret ->
  81   SomeInstr repr inp (Cursor inp ': vs) ret
  82 failIfConsumed k =
  83   pushInput $
  84   lift2Value (H.Term sameOffset) $
  85   ifBranch k (fail [])
  86
  87 -- | @('joinNext' m)@ factorize the next 'Instr'uction
  88 -- to be able to reuse it multiple times without duplication.
  89 -- It does so by introducing a 'defJoin'
  90 -- and passing the corresponding 'refJoin'
  91 -- as next 'Instr'uction to @(m)@,
  92 -- unless factorizing is useless because the next 'Instr'uction
  93 -- is already a 'refJoin' or a 'ret'.
  94 -- It should be used each time the next 'Instr'uction
  95 -- is used multiple times.
  96 joinNext ::
  97   InstrJoinable repr =>
  98   Program repr inp v ->
  99   Program repr inp v
 100 joinNext (Program m) = Program $ \case
 101   -- Double refJoin Optimization:
 102   -- If a join-node points directly to another join-node,
 103   -- then reuse it
 104   next@(Instr RefJoin{}) -> m next
 105   -- Terminal refJoin Optimization:
 106   -- If a join-node points directly to a terminal operation,
 107   -- then it's useless to introduce a join-node.
 108   next@(Instr Ret{}) -> m next
 109   -- Introduce a join-node.
 110   next -> do
 111     !joinName <- TH.newName "join"
 112     defJoin (LetName joinName) next
 113       Functor.<$> m (refJoin (LetName joinName))
 114
 115 instance
 116   InstrValuable repr =>
 117   CombApplicable (Program repr inp) where
 118   pure x = Program $ return . pushValue (trans x)
 119   Program f <*> Program x = Program $ (f <=< x) . applyValue
 120   liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (trans f)
 121   Program x *> Program y = Program (x <=< return . popValue <=< y)
 122   Program x <* Program y = Program (x <=< y <=< return . popValue)
 123 instance
 124   ( Cursorable (Cursor inp)
 125   , InstrBranchable repr
 126   , InstrExceptionable repr
 127   , InstrInputable repr
 128   , InstrJoinable repr
 129   , InstrValuable repr
 130   ) => CombFoldable (Program repr inp) where
 131   {-
 132   chainPre op p = go <*> p
 133     where go = (H..) <$> op <*> go <|> pure H.id
 134   chainPost p op = p <**> go
 135     where go = (H..) <$> op <*> go <|> pure H.id
 136   -}
 137 instance
 138   InstrCallable repr =>
 139   Letable TH.Name (Program repr inp) where
 140   shareable n (Program sub) = Program $ \next -> do
 141     sub' <- sub ret
 142     return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
 143   ref _isRec n = Program $ \case
 144     -- Returning just after a 'call' is useless:
 145     -- using 'jump' lets the 'ret' of the 'defLet'
 146     -- directly return where it would in two 'ret's.
 147     Instr Ret{} -> return $ jump (LetName n)
 148     next -> return $ call (LetName n) next
 149 instance
 150   InstrCallable repr =>
 151   Letsable TH.Name (Program repr inp) where
 152   lets defs (Program x) = Program $ \next -> do
 153     defs' <- Traversable.traverse (\(SomeLet (Program val)) -> liftM SomeLet (val ret)) defs
 154     liftM (defLet defs') (x next)
 155 instance
 156   ( Ord (InputToken inp)
 157   , Cursorable (Cursor inp)
 158   , InstrBranchable repr
 159   , InstrExceptionable repr
 160   , InstrInputable repr
 161   , InstrJoinable repr
 162   , InstrReadable (InputToken inp) repr
 163   , Typeable (InputToken inp)
 164   , InstrValuable repr
 165   ) => CombLookable (Program repr inp) where
 166   look (Program x) = Program $ \next ->
 167     liftM pushInput (x (swapValue (loadInput next)))
 168   eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))
 169         -- This sets a better failure message
 170         <|> (Program $ \_next -> return $ fail [ErrorItemEnd])
 171   negLook (Program x) = Program $ \next ->
 172     liftM2 (catchException (Proxy @"fail"))
 173       -- On x success, discard the result,
 174       -- and replace this 'CatchException''s failure handler
 175       -- by a failure whose 'farthestExpecting' is negated,
 176       -- then a failure is raised from the input
 177       -- when entering 'negLook', to avoid odd cases:
 178       -- - where the failure that made (negLook x)
 179       --   succeed can get the blame for the overall
 180       --   failure of the grammar.
 181       -- - where the overall failure of
 182       --   the grammar might be blamed on something in x
 183       --   that, if corrected, still makes x succeed and
 184       --   (negLook x) fail.
 185       (liftM pushInput (x
 186         (popValue (popException (Proxy @"fail") (loadInput
 187           (fail []))))))
 188       -- On x failure, reset the input,
 189       -- and go on with the next 'Instr'uctions.
 190       (return $ loadInput $ pushValue H.unit next)
 191 instance
 192   ( InstrBranchable repr
 193   , InstrJoinable repr
 194   ) => CombMatchable (Program repr inp) where
 195   conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
 196     bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
 197     a =<< liftM (choicesBranch (trans Functor.<$> ps) bs') (d next)
 198 instance
 199   ( tok ~ InputToken inp
 200   , InstrReadable tok repr
 201   , Typeable tok
 202   ) => CombSatisfiable tok (Program repr inp) where
 203   satisfy es p = Program $ return . read es (trans p)
 204 instance
 205   ( InstrBranchable repr
 206   , InstrJoinable repr
 207   , InstrValuable repr
 208   ) => CombSelectable (Program repr inp) where
 209   branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
 210     lr =<< liftM2 caseBranch
 211       (l (swapValue (applyValue next)))
 212       (r (swapValue (applyValue next)))
 213 instance
 214   InstrExceptionable repr =>
 215   CombThrowable (Program repr inp) where
 216   throw lbl = Program $ \_next -> return $ raiseException lbl []