{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
{-# LANGUAGE DeriveLift #-} -- For TH.Lift (Exception tok)
{-# LANGUAGE DerivingStrategies #-} -- For UnscopedRegister
-{-# LANGUAGE PatternSynonyms #-} -- For Failure
{-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-} -- For unSomeFailure
-- | Semantic of the grammar combinators used to express parsers,
-- in the convenient tagless-final encoding.
module Symantic.Parser.Grammar.Combinators where
import Data.Int (Int)
import Data.Kind (Type, Constraint)
import Data.Maybe (Maybe(..))
-import Data.Set (Set)
import Data.String (String)
+import Data.Semigroup (Semigroup(..))
import Text.Show (Show(..))
import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..), SomeTypeRep(..))
import qualified Data.Functor as Functor
import qualified Data.List as List
-import qualified Data.Set as Set
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
throw = liftDerived . throw
try = liftDerived1 try
- failure :: SomeFailure -> repr a
- default failure ::
- FromDerived CombAlternable repr =>
- SomeFailure -> repr a
- failure = liftDerived . failure
-
-- | @(empty)@ parses nothing, always failing to return a value.
empty :: repr a
- empty = failure (SomeFailure FailureEmpty)
-
-data instance Failure CombAlternable
- = FailureEmpty
- deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
-
--- ** Data family 'Failure'
--- | 'Failure's of the 'Grammar'.
--- This is an extensible data-type.
-data family Failure
- (comb :: ReprComb -> Constraint)
- :: Type
-
-{-
--- | Convenient utility to pattern-match a 'SomeFailure'.
-pattern Failure :: Typeable comb => Failure comb -> SomeFailure
-pattern Failure x <- (unSomeFailure -> Just x)
--}
-
--- ** Type 'SomeFailure'
-data SomeFailure =
- forall comb.
- ( Eq (Failure comb)
- , Ord (Failure comb)
- , Show (Failure comb)
- , TH.Lift (Failure comb)
- , NFData (Failure comb)
- , Typeable comb
- ) => SomeFailure (Failure comb {-repr a-})
-instance Eq SomeFailure where
- SomeFailure (x::Failure x) == SomeFailure (y::Failure y) =
- case typeRep @x `eqTypeRep` typeRep @y of
- Just HRefl -> x == y
- Nothing -> False
-instance Ord SomeFailure where
- SomeFailure (x::Failure x) `compare` SomeFailure (y::Failure y) =
- -- WARNING: this ordering is convenient to make a 'Set' of 'SomeFailure's
- -- but it is based upon a hash which changes with packages' ABI
- -- and also if the install is "inplace" or not.
- -- Therefore this 'Ord' is not stable enough to put 'SomeFailure'
- -- in golden tests.
- let xT = typeRep @x in
- let yT = typeRep @y in
- case SomeTypeRep xT `compare` SomeTypeRep yT of
- EQ | Just HRefl <- xT `eqTypeRep` yT -> compare x y
- o -> o
-instance Show SomeFailure where
- showsPrec p (SomeFailure x) = showsPrec p x
-instance TH.Lift SomeFailure where
- liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]
-instance NFData SomeFailure where
- rnf (SomeFailure x) = rnf x
-
-{-
-instance Derivable (SomeFailure repr) where
- derive (SomeFailure x) = derive x
--}
-
--- | @(unSomeFailure c :: 'Maybe' ('Failure' comb repr a))@
--- extract the data-constructor from the given 'SomeFailure'
--- iif. it belongs to the @('Failure' comb repr a)@ data-instance.
-unSomeFailure :: forall comb. Typeable comb => SomeFailure -> Maybe (Failure comb)
-unSomeFailure (SomeFailure (c::Failure c)) =
- case typeRep @comb `eqTypeRep` typeRep @c of
- Just HRefl -> Just c
- Nothing -> Nothing
+ default empty ::
+ FromDerived CombAlternable repr =>
+ repr a
+ empty = liftDerived empty
-- ** Type 'Exception'
data Exception
liftA2 f x = (<*>) (f <$> x)
infixl 4 <*>, <*, *>, <**>
-data instance Failure CombApplicable
{-# INLINE (<:>) #-}
chainPre op p = flip (foldr ($)) <$> many op <*> p
chainPost p op = foldl' (flip ($)) <$> p <*> many op
-}
-data instance Failure CombFoldable
{-
conditional :: CombSelectable repr => [(Production '[] (a -> Bool), repr b)] -> repr a -> repr b -> repr b
default conditional ::
FromDerived1 CombMatchable repr => Derivable repr =>
repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
-data instance Failure CombMatchable
match ::
CombMatchable repr =>
-- * Class 'CombSatisfiable'
class CombSatisfiable tok repr where
- -- | Like 'satisfyOrFail' but with no custom failure.
satisfy :: Production '[] (tok -> Bool) -> repr tok
- satisfy = satisfyOrFail Set.empty
- -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
- satisfyOrFail ::
- Set SomeFailure ->
- Production '[] (tok -> Bool) -> repr tok
- default satisfyOrFail ::
+ default satisfy ::
FromDerived (CombSatisfiable tok) repr =>
- Set SomeFailure ->
Production '[] (tok -> Bool) -> repr tok
- satisfyOrFail fs = liftDerived . satisfyOrFail fs
-
-data instance Failure (CombSatisfiable tok)
- = FailureAny
- -- FIXME: this 'Failure' is a bit special since multiple ones
- -- with different 'Horizon's makes no sense.
- -- This should likely be treated separately in 'ParsingError'.
- | FailureHorizon Int -- FIXME: use Natural?
- | FailureLabel String
- | FailureToken tok
- deriving (Eq, Ord, Show, Typeable, Generic, NFData)
+ satisfy = liftDerived . satisfy
+
-- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
-- from TemplateHaskell code.
inputTokenProxy :: TH.Name
inputTokenProxy = TH.mkName "inputToken"
-instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
- liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
- liftTyped x = [||
- case
- $$(let inputToken :: TH.Code m (Proxy tok) =
- TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
- in inputToken) of
- (Proxy :: Proxy tok') ->
- $$(case x of
- FailureAny -> [|| FailureAny @tok' ||]
- FailureHorizon h -> [|| FailureHorizon @tok' h ||]
- FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
- FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
- )
- ||]
char ::
CombApplicable repr =>
CombSatisfiable Char repr =>
Char -> repr Char
-char c = satisfyOrFail
- (Set.singleton (SomeFailure (FailureToken c)))
- (Prod.equal Prod..@ Prod.constant c)
- $> Prod.constant c
+char c = satisfy (Prod.equal Prod..@ Prod.constant c) $> Prod.constant c
item :: forall tok repr.
Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
CombSatisfiable tok repr => repr tok
-item = satisfyOrFail
- (Set.singleton (SomeFailure (FailureAny @tok)))
- (Prod.const Prod..@ Prod.constant True)
+item = satisfy (Prod.const Prod..@ Prod.constant True)
anyChar ::
CombAlternable repr =>
Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
CombSatisfiable tok repr =>
[tok] -> repr tok
-oneOf ts = satisfyOrFail
- (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
- (production
- (`List.elem` ts)
- [||\t -> $$(ofChars ts [||t||])||])
+oneOf ts = satisfy (production (`List.elem` ts) [||\t -> $$(ofChars ts [||t||])||])
noneOf ::
- TH.Lift tok => Eq tok =>
+ (Ord tok, Show tok, TH.Lift tok, NFData tok, Typeable tok) =>
CombSatisfiable tok repr =>
[tok] -> repr tok
-noneOf cs = satisfy (production
- (not . (`List.elem` cs))
- [||\c -> not $$(ofChars cs [||c||])||])
+noneOf ts = satisfy (production (not . (`List.elem` ts)) [||\c -> not $$(ofChars ts [||c||])||])
ofChars ::
TH.Lift tok => Eq tok =>
more = look (void (item @Char))
token ::
- TH.Lift tok => Show tok => Eq tok => Typeable tok =>
+ (Ord tok, Show tok, TH.Lift tok, NFData tok, Typeable tok) =>
CombAlternable repr =>
CombApplicable repr =>
CombSatisfiable tok repr =>
-- token tok = satisfy [ExceptionToken tok] (Prod.eq Prod..@ Prod.qual Prod..@ Prod.char tok) $> Prod.char tok
tokens ::
- TH.Lift tok => Eq tok => Show tok => Typeable tok =>
+ (Ord tok, Show tok, TH.Lift tok, NFData tok, Typeable tok) =>
CombApplicable repr => CombAlternable repr =>
CombSatisfiable tok repr => [tok] -> repr [tok]
tokens = try . traverse token
FromDerived3 CombSelectable repr =>
repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
branch = liftDerived3 branch
-data instance Failure CombSelectable
when ::
CombMatchable repr =>
-- * Class 'CombLookable'
class CombLookable repr where
look :: repr a -> repr a
+ -- |
+ -- Note: following [Error Reporting in Parsing Expression Grammars](https://arxiv.org/abs/1405.6646v3)
+ -- what happens inside a 'negLook' does not take part in error reporting at
+ -- all, which is the simplest approach, and also gives a consistent result
+ -- for: @(negLook . negLook)@.
negLook :: repr a -> repr ()
default look ::
FromDerived1 CombLookable repr =>
repr ()
-- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
-- (item @Char)
-data instance Failure CombLookable
- = FailureEnd
- deriving (Eq, Ord, Show, Typeable, TH.Lift, Generic, NFData)
-- Composite Combinators
-- someTill :: repr a -> repr b -> repr [a]
import Data.Function (($), (.))
import Data.Kind (Constraint)
import Data.Maybe (Maybe(..))
-import Data.Set (Set)
import Data.Functor.Identity (Identity(..))
import Unsafe.Coerce (unsafeCoerce)
import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
data instance Comb CombAlternable repr a where
Alt :: Exception -> SimplComb repr a -> SimplComb repr a -> Comb CombAlternable repr a
Empty :: Comb CombAlternable repr a
- Failure :: SomeFailure -> Comb CombAlternable repr a
Throw :: ExceptionLabel -> Comb CombAlternable repr a
Try :: SimplComb repr a -> Comb CombAlternable repr a
instance CombAlternable repr => Derivable (Comb CombAlternable repr) where
derive = \case
Alt exn x y -> alt exn (derive x) (derive y)
Empty -> empty
- Failure sf -> failure sf
Throw exn -> throw exn
Try x -> try (derive x)
instance
, combInline = True
, combRefs = HS.empty
}
- failure sf = SimplComb
- { combData = Failure sf
- , combInline = True
- , combRefs = HS.empty
- }
alt _exn p@(Comb Pure{}) _ = p
-- & trace "Left Catch Law"
-- CombSatisfiable
data instance Comb (CombSatisfiable tok) repr a where
- -- | To include the @('Set' 'SomeFailure')@ is a little kludge
- -- it would be cleaner to be able to pattern-match
- -- on @(alt exn (Comb 'Satisfy'{}) (Failure{}))@
- -- when generating 'Program', but this is not easily possible then
- -- because data types have already been converted back to class methods,
- -- hence pattern-matching is no longer possible
- -- (at least not without reintroducing data types).
- SatisfyOrFail ::
+ Satisfy ::
CombSatisfiable tok repr =>
- Set SomeFailure ->
Production '[] (tok -> Bool) ->
Comb (CombSatisfiable tok) repr tok
instance
CombSatisfiable tok repr =>
Derivable (Comb (CombSatisfiable tok) repr) where
derive = \case
- SatisfyOrFail fs p -> satisfyOrFail fs p
+ Satisfy p -> satisfy p
instance
(CombSatisfiable tok repr, Typeable tok) =>
CombSatisfiable tok (SimplComb repr) where
- satisfyOrFail fs p = SimplComb
- { combData = SatisfyOrFail fs p
+ satisfy p = SimplComb
+ { combData = Satisfy p
, combInline = False -- TODO: True? depending on p?
, combRefs = HS.empty
}
{-# LANGUAGE ConstraintKinds #-} -- For Machine
{-# LANGUAGE DeriveLift #-} -- For TH.Lift (Failure tok)
{-# LANGUAGE DerivingStrategies #-} -- For Show (LetName a)
+{-# LANGUAGE DeriveAnyClass #-} -- For NFData
+{-# LANGUAGE DeriveGeneric #-} -- For Generic
+{-# LANGUAGE TemplateHaskell #-} -- For TH.Lift
-- | Semantic of the parsing instructions used
-- to make the parsing control-flow explicit,
-- in the convenient tagless-final encoding.
module Symantic.Parser.Machine.Instructions where
+import Control.DeepSeq (NFData(..))
import Data.Bool (Bool(..))
import Data.Either (Either)
import Data.Eq (Eq(..))
import Data.Function ((.))
+import Data.Int (Int)
import Data.Kind (Type)
-import Data.Set (Set)
-import Text.Show (Show(..))
+import Data.Ord (Ord(..))
import Data.String (String)
-import qualified Language.Haskell.TH as TH
+import Text.Show (Show(..), showParen, showString, shows)
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import qualified Symantic.Syntaxes.Classes as Prod
import qualified Symantic.Semantics.Data as Sym
+import qualified Language.Haskell.TH as TH
-- * Type 'Splice'
type Splice = Sym.SomeData TH.CodeQ
--- | Lift a 'TH.CodeQ' into a 'Sym.SomeData'.
+-- | Lift a 'TH.CodeQ' into an opaque 'Sym.SomeData'.
splice :: TH.CodeQ a -> Splice a
splice x = Sym.SomeData (Sym.Var x)
repr inp (x ': (x -> y) ': vs) a
applyValue = lift2Value (Prod.$)
+-- ** Type 'FailMode'
+data FailMode
+ = FailModePreserve
+ -- ^ Fail preserving any current farthest error.
+ -- Useful in 'alt' or 'try'.
+ | FailModeNewFailure (TH.CodeQ SomeFailure)
+ -- ^ Fail preserving, merging or replacing any current farthest error,
+ -- depending on its input position and the current input position.
+
+data SomeFailure
+ = forall a. SomeFailure (WriteGrammar 'True a)
+ | SomeFailureHorizon Int
+instance NFData SomeFailure where
+ rnf (SomeFailure x) = rnf x
+ rnf (SomeFailureHorizon x) = rnf x
+instance Show SomeFailure where
+ showsPrec p (SomeFailure x) = showsPrec p x
+ showsPrec p (SomeFailureHorizon x) = showParen (p > 10) (showString "SomeFailureHorizon " . shows x)
+--instance TH.Lift SomeFailure where
+-- liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]
+--instance Semigroup SomeFailure where
+-- x <> y = SomeFailure (FailureOr x y)
+
-- ** Class 'InstrExceptionable'
class InstrExceptionable (repr::ReprInstr) where
-- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
raise :: ExceptionLabel -> repr inp vs a
- -- | @('fail' fs)@ raises 'ExceptionFailure' @(exn)@.
- -- As a special case, giving an empty 'Set' of failures
- -- raises 'ExceptionFailure' without using the current position
- -- to update the farthest error.
- fail :: Set SomeFailure -> repr inp vs a
+ -- | @('fail' fs)@ raises 'ExceptionFailure'.
+ -- As a special case, giving 'Left'
+ fail :: FailMode -> repr inp vs a
-- | @('commit' exn k)@ removes the 'OnException'
-- from the 'onExceptionStackByLabel' for the given 'Exception' @(exn)@,
-- and continues with the next 'Instr'uction @(k)@.
-- otherwise 'fail'.
read ::
tok ~ InputToken inp =>
- Set SomeFailure ->
Splice (tok -> Bool) ->
repr inp (tok ': vs) a ->
repr inp vs a
sourcephile / git / haskell / symantic-parser.git / commitdiff