-- those generated (see for instance 'joinNext').
module Symantic.Parser.Machine.Program where
-import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
-import Data.Function (($))
-import System.IO (IO)
-import Type.Reflection (Typeable)
import Control.DeepSeq (NFData)
+import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
import Data.Bool (Bool(..))
import Data.Eq (Eq)
-import Data.Function ((.))
+import Data.Function (($), (.))
import Data.Ord (Ord)
+import Data.Semigroup (Semigroup(..))
+import System.IO (IO)
import Text.Show (Show(..))
+import Type.Reflection (Typeable)
import qualified Data.Functor as Functor
import qualified Data.Set as Set
import qualified Data.Traversable as Traversable
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Lang as Prod
+import qualified Symantic.Syntaxes.Classes as Prod
-import Symantic.Derive
+import Symantic.Syntaxes.Derive
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
-- where each 'Instr'uction is built by a continuation
-- to be able to introspect, duplicate and/or change
-- the next 'Instr'uction.
-data Program repr inp a = Program { unProgram ::
+newtype Program repr inp a = Program { unProgram ::
forall vs ret.
-- This is the next instruction.
SomeInstr repr inp (a ': vs) ret ->
)
instance
- ( Cursorable (Cursor inp)
+ ( Positionable (InputPosition inp)
, InstrBranchable repr
+ , InstrComment repr
, InstrExceptionable repr
, InstrInputable repr
, InstrJoinable repr
, InstrValuable repr
) => CombAlternable (Program repr inp) where
alt exn (Program l) (Program r) = joinNext $ Program $ \next ->
- liftM2 (catch exn)
- (l (commit exn next))
+ liftM2
+ (catch exn)
+ (l $ commit exn next)
(raiseAgainIfConsumed exn Functor.<$> r next)
throw exn = Program $ \_next -> return $ raise exn
failure flr = Program $ \_next -> return $ fail (Set.singleton flr)
empty = Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEmpty))
try (Program x) = Program $ \next ->
- liftM2 (catch ExceptionFailure)
- (x (commit ExceptionFailure next))
- -- On exception, reset the input, and propagate the failure.
+ liftM2
+ (catch ExceptionFailure)
+ (x $ commit ExceptionFailure next)
+ -- On 'ExceptionFailure', reset the input, and propagate the failure.
(return $ loadInput $ fail Set.empty)
-- | @(raiseAgainIfConsumed exn ok)@
-- without updating the farthest error
-- (which is usually done when 'fail'ing).
raiseAgainIfConsumed ::
- Cursorable (Cursor inp) =>
+ Positionable (InputPosition inp) =>
InstrBranchable repr =>
+ InstrComment repr =>
InstrExceptionable repr =>
InstrInputable repr =>
InstrValuable repr =>
Exception ->
SomeInstr repr inp vs ret ->
- SomeInstr repr inp (Cursor inp ': vs) ret
+ SomeInstr repr inp (InputPosition inp ': vs) ret
raiseAgainIfConsumed exn ok =
- pushInput $
- lift2Value (splice sameOffset) $
+ comment "raiseAgainIfConsumed" $
+ saveInput $
+ lift2Value (splice samePosition) $
ifBranch ok $
case exn of
ExceptionLabel lbl -> raise lbl
Program x *> Program y = Program (x <=< return . popValue <=< y)
Program x <* Program y = Program (x <=< y <=< return . popValue)
instance
- ( Cursorable (Cursor inp)
+ ( Positionable (InputPosition inp)
, InstrBranchable repr
, InstrCallable repr
+ , InstrComment repr
, InstrExceptionable repr
, InstrInputable repr
, InstrIterable repr
liftM (defLet defs') (body next)
instance
( Eq (InputToken inp)
- , Cursorable (Cursor inp)
+ , Positionable (InputPosition inp)
, InstrBranchable repr
, InstrExceptionable repr
, InstrInputable repr
) => CombLookable (Program repr inp) where
look (Program x) = Program $ \next ->
liftM (comment "look") $
- liftM pushInput (x (swapValue (loadInput next)))
+ liftM saveInput $
+ x $
+ swapValue $
+ loadInput next
eof =
- negLook (satisfy (Prod.const Prod..@ Prod.bool True))
+ negLook (satisfy (Prod.const Prod..@ Prod.constant True))
-- This sets a better failure message
<|> (Program $ \_next ->
- return $ comment "eof.fail" $ fail (Set.singleton (SomeFailure FailureEnd)))
+ return $
+ comment "eof.fail" $
+ fail (Set.singleton (SomeFailure FailureEnd)))
negLook (Program x) = Program $ \next ->
liftM (comment "negLook") $
liftM2 (catch ExceptionFailure)
-- On x success, discard the result,
- -- and replace this 'Catcher' by a failure whose 'farthestExpecting' is negated,
+ -- and replace this 'OnException' by a failure
+ -- whose 'farthestExpecting' is negated,
-- then a failure is raised from the input
-- when entering 'negLook', to avoid odd cases:
-- - where the failure that made (negLook x)
-- and (negLook x) fail.
(
liftM (comment "negLook.ahead") $
- liftM pushInput $ x $
- popValue $ commit ExceptionFailure $
- loadInput $ fail Set.empty
+ liftM saveInput $
+ x $
+ popValue $
+ commit ExceptionFailure $
+ loadInput $
+ fail Set.empty
)
- -- On x failure, reset the input,
+ -- On the failure of x: reset the input,
-- and go on with the next 'Instr'uctions.
(
liftM (comment "negLook.reset") $
- return $ loadInput $ pushValue Prod.unit next
+ return $
+ loadInput $
+ pushValue Prod.unit next
)
instance
( InstrBranchable repr
) => CombSatisfiable tok (Program repr inp) where
satisfyOrFail fs p = Program $ \next ->
return $
- comment "satisfy" $
+ comment ("satisfy "<>showsPrec 11 (prodCode p) "") $
read fs (prodCode p) next
instance
( InstrBranchable repr
sourcephile / git / haskell / symantic-parser.git / blobdiff