ptera (empty) → 0.1.0.0
raw patch · 18 files changed
+1692/−0 lines, 18 filesdep +QuickCheckdep +basedep +containersbuild-type:Customsetup-changed
Dependencies added: QuickCheck, base, containers, doctest, enummapset-th, hspec, membership, ptera, ptera-core, unordered-containers
Files
- CHANGELOG.md +0/−0
- LICENSE +5/−0
- README.md +67/−0
- Setup.hs +6/−0
- ptera.cabal +168/−0
- src/Language/Parser/Ptera.hs +25/−0
- src/Language/Parser/Ptera/Data/HEnum.hs +25/−0
- src/Language/Parser/Ptera/Pipeline/Grammar2Runner.hs +19/−0
- src/Language/Parser/Ptera/Pipeline/SRB2Parser.hs +121/−0
- src/Language/Parser/Ptera/Pipeline/SafeGrammar2SRB.hs +27/−0
- src/Language/Parser/Ptera/Runner.hs +52/−0
- src/Language/Parser/Ptera/Runner/Parser.hs +70/−0
- src/Language/Parser/Ptera/Runner/RunT.hs +638/−0
- src/Language/Parser/Ptera/Scanner.hs +42/−0
- src/Language/Parser/Ptera/Syntax.hs +160/−0
- src/Language/Parser/Ptera/Syntax/SafeGrammar.hs +243/−0
- test/doctest/Doctest.hs +23/−0
- test/spec/HSpecDriver.hs +1/−0
+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,5 @@+Apache-2.0 OR MPL-2.0++---++See https://github.com/mizunashi-mana/ptera/blob/master/LICENSE
+ README.md view
@@ -0,0 +1,67 @@+# Ptera: A Generator for Parsers++[](https://hackage.haskell.org/package/ptera)++## Installation++Add dependencies on `package.cabal`:++```+build-depends:+ base,+ bytestring,+ ptera, -- main+ ptera-th, -- for outputing parser with Template Haskell+ charset,+ template-haskell,+```++## Usage++Write parser rules:++```haskell+data Terminal+ = Digit+ | SymPlus+ | SymMulti+ deriving (Eq, Show, Enum)++data NonTerminal+ | Expr+ | Sum+ | Product+ | Value+ deriving (Eq, Show, Enum)++type ParseRule = Rule Terminal NonTerminal+++data Ast+ = GenValue+ | GenSum (NonEmpty Ast)+ | GenProduct Ast Ast++rExpr :: ParseRule Ast+rExpr = rule Expr rSum++rSum :: ParseRule Ast+rSum = rule Sum do+ (rProduct <,> manyP do token SymPlus *> rProduct) <&> \(e, es) -> GenSum do e :| es++rProduct :: ParseRule Ast+rProduct = rule Product do+ orP+ [+ (rValue <* token SymMulti <,> rProduct) <&> \(e1, e2) -> GenProduct e1 e2,+ rValue+ ]++rValue :: ParseRule Ast+rValue = rule Value do token Digit *> pure GenValue+```++## Examples++* Small language: https://github.com/mizunashi-mana/ptera/tree/master/example/small-lang+* Haskell2010: https://github.com/mizunashi-mana/ptera/tree/master/example/haskell2010
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctest"
+ ptera.cabal view
@@ -0,0 +1,168 @@+cabal-version: 3.0+build-type: Custom++name: ptera+version: 0.1.0.0+license: Apache-2.0 OR MPL-2.0+license-file: LICENSE+copyright: (c) 2021 Mizunashi Mana+author: Mizunashi Mana+maintainer: mizunashi-mana@noreply.git++category: Parsing+homepage: https://github.com/mizunashi-mana/ptera+bug-reports: https://github.com/mizunashi-mana/ptera/issues+synopsis: A parser generator+description:+ Ptera is haskell libraries and toolchains for generating parser.++extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/mizunashi-mana/ptera.git++flag develop+ default: False+ manual: True+ description: Turn on some options for development++common general+ default-language:+ Haskell2010+ default-extensions:+ NoImplicitPrelude+ BangPatterns+ BinaryLiterals+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DerivingVia+ DuplicateRecordFields+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ InstanceSigs+ LambdaCase+ MagicHash+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NegativeLiterals+ NumericUnderscores+ OverloadedLabels+ PackageImports+ PatternSynonyms+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ Strict+ TypeApplications+ TypeFamilies+ TypeOperators+ UnboxedSums+ UnboxedTuples++ if flag(develop)+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Wmonomorphism-restriction+ -Wpartial-fields++ -fprint-explicit-foralls+ -frefinement-level-hole-fits=1++ -dcore-lint++ build-depends:+ base >= 4.14.0 && < 5,++ -- project depends+ ptera-core >= 0.1.0 && < 0.2,+ containers >= 0.6.0 && < 0.7,+ unordered-containers >= 0.2.0 && < 0.3,+ membership >= 0.0.1 && < 0.1,+ enummapset-th >= 0.6.0 && < 0.7,++ autogen-modules:+ Paths_ptera+ other-modules:+ Paths_ptera++custom-setup+ setup-depends:+ base,+ Cabal,+ cabal-doctest,++library+ import:+ general,+ hs-source-dirs:+ src+ exposed-modules:+ Language.Parser.Ptera++ Language.Parser.Ptera.Syntax+ Language.Parser.Ptera.Syntax.SafeGrammar+ Language.Parser.Ptera.Scanner+ Language.Parser.Ptera.Runner+ Language.Parser.Ptera.Runner.Parser+ Language.Parser.Ptera.Runner.RunT+ Language.Parser.Ptera.Pipeline.Grammar2Runner+ Language.Parser.Ptera.Pipeline.SafeGrammar2SRB+ Language.Parser.Ptera.Pipeline.SRB2Parser++ Language.Parser.Ptera.Data.HEnum+ reexported-modules:+ Language.Parser.Ptera.Data.HFList++test-suite doctest+ import:+ general,+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test/doctest+ main-is:+ Doctest.hs+ build-depends:+ doctest,+ QuickCheck,+ autogen-modules:+ Build_doctests+ other-modules:+ Build_doctests++test-suite spec+ import:+ general,+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test/spec+ main-is:+ HSpecDriver.hs+ ghc-options:+ -Wno-missing-home-modules+ build-tool-depends:+ hspec-discover:hspec-discover,+ build-depends:+ ptera,++ hspec,+ QuickCheck,
+ src/Language/Parser/Ptera.hs view
@@ -0,0 +1,25 @@+module Language.Parser.Ptera (+ module Language.Parser.Ptera.Syntax,+ module Language.Parser.Ptera.Runner,+ module Language.Parser.Ptera.Scanner,++ Parser,+ genRunner,+) where++import Language.Parser.Ptera.Prelude++import qualified Language.Parser.Ptera.Pipeline.Grammar2Runner as Grammar2Runner+import Language.Parser.Ptera.Runner (ParseResult (..),+ Result,+ runParser)+import qualified Language.Parser.Ptera.Runner as Runner+import Language.Parser.Ptera.Scanner hiding (T)+import Language.Parser.Ptera.Syntax hiding (T, semAct, semActM)++type Parser = Runner.T++genRunner :: GrammarToken tokens elem+ => GrammarM ctx rules tokens elem initials+ -> Either [StringLit] (Parser ctx rules elem initials)+genRunner g = Grammar2Runner.grammar2Runner g
+ src/Language/Parser/Ptera/Data/HEnum.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Language.Parser.Ptera.Data.HEnum where++import Language.Parser.Ptera.Prelude++import qualified Type.Membership as Membership+import qualified Type.Membership.Internal as MembershipInternal++type T = HEnum++newtype HEnum (as :: [k]) = UnsafeHEnum+ {+ unsafeHEnum :: Int+ }+ deriving (Eq, Show)++henum :: forall a as. Membership.Membership as a -> HEnum as+henum m = UnsafeHEnum do Membership.getMemberId m++henumA :: forall a as. Membership.Member as a => HEnum as+henumA = henum do MembershipInternal.membership @as @a++unHEnum :: forall a as. Membership.Membership as a -> HEnum as -> Bool+unHEnum m (UnsafeHEnum i) = Membership.getMemberId m == i
+ src/Language/Parser/Ptera/Pipeline/Grammar2Runner.hs view
@@ -0,0 +1,19 @@+module Language.Parser.Ptera.Pipeline.Grammar2Runner where++import Language.Parser.Ptera.Prelude++import qualified Language.Parser.Ptera.Pipeline.SRB2Parser as SRB2Parser+import qualified Language.Parser.Ptera.Pipeline.SafeGrammar2SRB as SafeGrammar2SRB+import qualified Language.Parser.Ptera.Runner as Runner+import qualified Language.Parser.Ptera.Syntax as Syntax++grammar2Runner :: forall initials ctx rules tokens elem+ . Syntax.GrammarToken tokens elem+ => Syntax.GrammarM ctx rules tokens elem initials+ -> Either [StringLit] (Runner.T ctx rules elem initials)+grammar2Runner g = do+ srb <- SafeGrammar2SRB.safeGrammar2Srb g+ let parser = SRB2Parser.srb2Parser+ do Proxy @tokens+ do srb+ pure do Runner.UnsafeRunnerM parser
+ src/Language/Parser/Ptera/Pipeline/SRB2Parser.hs view
@@ -0,0 +1,121 @@+module Language.Parser.Ptera.Pipeline.SRB2Parser where++import Language.Parser.Ptera.Prelude++import qualified Data.EnumMap.Strict as EnumMap+import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray+import qualified Language.Parser.Ptera.Data.HEnum as HEnum+import qualified Language.Parser.Ptera.Data.Symbolic.IntMap as SymbolicIntMap+import qualified Language.Parser.Ptera.Machine.LAPEG as LAPEG+import qualified Language.Parser.Ptera.Machine.PEG as PEG+import qualified Language.Parser.Ptera.Machine.SRB as SRB+import qualified Language.Parser.Ptera.Runner.Parser as Parser+import qualified Language.Parser.Ptera.Syntax as Syntax+import qualified Language.Parser.Ptera.Syntax.Grammar as Grammar+import qualified Unsafe.Coerce as Unsafe++type Action ctx = Grammar.Action (Syntax.SemActM ctx)++srb2Parser :: forall ctx tokens elem altHelp+ . Syntax.GrammarToken tokens elem+ => Proxy tokens -> SRB.T Int StringLit (Maybe altHelp) (Action ctx)+ -> Parser.T ctx elem altHelp+srb2Parser p srb = Parser.RunnerParser+ { parserInitial = \s -> coerce do EnumMap.lookup s do SRB.initials srb+ , parserGetTokenNum = \tok ->+ HEnum.unsafeHEnum do Syntax.tokenToTerminal p tok+ , parserTrans = \s0 t -> if s0 < 0+ then Parser.Trans+ {+ transState = -1,+ transOps = []+ }+ else+ let srbSt = AlignableArray.forceIndex+ do SRB.states srb+ do SRB.StateNum s0+ in buildTrans t srbSt+ , parserAltKind = \alt -> LAPEG.altKind+ do AlignableArray.forceIndex+ do SRB.alts srb+ do LAPEG.AltNum alt+ , parserAction = \alt -> runAction+ do LAPEG.altAction+ do AlignableArray.forceIndex+ do SRB.alts srb+ do LAPEG.AltNum alt+ , parserStateHelp = \s ->+ let srbSt = AlignableArray.forceIndex+ do SRB.states srb+ do SRB.StateNum s+ in buildStateHelp do SRB.stateAltItems srbSt+ , parserAltHelp = \alt ->+ let vn = LAPEG.altVar+ do AlignableArray.forceIndex+ do SRB.alts srb+ do LAPEG.AltNum alt+ v = AlignableArray.forceIndex+ do SRB.vars srb+ do vn+ in (PEG.varHelp v, Nothing)+ }++buildTrans :: Int -> SRB.MState -> Parser.Trans+buildTrans t srbSt = case SymbolicIntMap.lookup t do SRB.stateTrans srbSt of+ Nothing ->+ Parser.Trans+ {+ transState = -1,+ transOps = []+ }+ Just (SRB.TransWithOps ops (SRB.StateNum s1)) ->+ Parser.Trans+ {+ transState = s1,+ transOps = transOp <$> ops+ }+ Just (SRB.TransReduce (LAPEG.AltNum alt)) ->+ Parser.Trans+ {+ transState = -1,+ transOps = [Parser.TransOpReduce alt]+ }++buildStateHelp :: [SRB.AltItem] -> [(Parser.AltNum, Int)]+buildStateHelp altItems =+ [+ ( coerce do SRB.altItemAltNum altItem+ , coerce do SRB.altItemCurPos altItem+ )+ | altItem <- altItems+ ]++transOp :: SRB.TransOp -> Parser.TransOp+transOp = \case+ SRB.TransOpEnter (LAPEG.VarNum v) needBack mEnterSn ->+ let enterSn = case mEnterSn of+ Nothing ->+ -1+ Just (SRB.StateNum x) ->+ x+ in Parser.TransOpEnter v needBack enterSn+ SRB.TransOpPushBackpoint (SRB.StateNum backSn) ->+ Parser.TransOpPushBackpoint backSn+ SRB.TransOpHandleNot (LAPEG.AltNum alt) ->+ Parser.TransOpHandleNot alt+ SRB.TransOpShift ->+ Parser.TransOpShift++runAction :: Action ctx -> Parser.ActionM ctx+runAction (Grammar.Action (Syntax.SemActM f)) = Parser.ActionM \l ->+ Parser.ReduceArgument <$> f do goL l+ where+ goL = \case+ [] ->+ unsafeCoerceHList Syntax.HNil+ Parser.ReduceArgument x:xs ->+ unsafeCoerceHList do x Syntax.:* goL xs++ unsafeCoerceHList :: Syntax.HList us1 -> Syntax.HList us2+ unsafeCoerceHList = Unsafe.unsafeCoerce+
+ src/Language/Parser/Ptera/Pipeline/SafeGrammar2SRB.hs view
@@ -0,0 +1,27 @@+module Language.Parser.Ptera.Pipeline.SafeGrammar2SRB where++import Language.Parser.Ptera.Prelude++import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray+import qualified Language.Parser.Ptera.Data.Alignable.Set as AlignableSet+import qualified Language.Parser.Ptera.Machine.PEG as PEG+import qualified Language.Parser.Ptera.Machine.SRB as SRB+import qualified Language.Parser.Ptera.Pipeline.Grammar2PEG as Grammar2PEG+import qualified Language.Parser.Ptera.Pipeline.LAPEG2SRB as LAPEG2SRB+import qualified Language.Parser.Ptera.Pipeline.PEG2LAPEG as PEG2LAPEG+import qualified Language.Parser.Ptera.Syntax.Grammar as Grammar+import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar++safeGrammar2Srb :: SafeGrammar.T action rules tokens elem initials+ -> Either [StringLit] (SRB.T Int StringLit (Maybe ()) (Grammar.Action action))+safeGrammar2Srb (SafeGrammar.UnsafeGrammar g) = do+ let peg = Grammar2PEG.grammar2Peg g+ laPeg <- case runExcept do PEG2LAPEG.peg2LaPeg peg of+ Right x -> Right x+ Left vns -> do+ let vs = PEG.vars peg+ Left+ [ PEG.varHelp do AlignableArray.forceIndex vs vn+ | vn <- AlignableSet.toList vns+ ]+ pure do LAPEG2SRB.laPeg2Srb laPeg
+ src/Language/Parser/Ptera/Runner.hs view
@@ -0,0 +1,52 @@+module Language.Parser.Ptera.Runner (+ T,++ RunnerM (..),+ Result,+ RunT.ParseResult (..),+ runParserM,+ runParser,+) where++import Language.Parser.Ptera.Prelude++import qualified Language.Parser.Ptera.Runner.Parser as Parser+import qualified Language.Parser.Ptera.Runner.RunT as RunT+import qualified Language.Parser.Ptera.Scanner as Scanner+import qualified Language.Parser.Ptera.Syntax as Syntax+import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar+import qualified Type.Membership as Membership+import qualified Type.Membership.Internal as MembershipInternal++type T = RunnerM++type RunnerM :: Type -> Type -> Type -> [Symbol] -> Type+newtype RunnerM ctx rules elem initials = UnsafeRunnerM+ { unRunnerM :: Parser.T ctx elem ()+ }++type Runner = RunnerM ()++type Result posMark = RunT.ParseResult posMark ()++runParserM :: forall v initials ctx posMark m rules elem proxy+ . Membership.Member initials v => Scanner.T posMark elem m+ => proxy v -> RunnerM ctx rules elem initials -> ctx+ -> m (Result posMark (Syntax.RuleExprReturnType rules v))+runParserM _ (UnsafeRunnerM p) customCtx0 =+ case RunT.initialContext p customCtx0 pos of+ Nothing ->+ error "Not found the start point."+ Just initialCtx ->+ evalStateT+ do RunT.unRunT RunT.runT+ initialCtx+ where+ pos = SafeGrammar.genStartPoint+ do MembershipInternal.membership @initials @v++runParser :: forall v initials posMark m rules elem proxy+ . Membership.Member initials v => Scanner.T posMark elem m+ => proxy v -> Runner rules elem initials+ -> m (Result posMark (Syntax.RuleExprReturnType rules v))+runParser p r = runParserM p r ()
+ src/Language/Parser/Ptera/Runner/Parser.hs view
@@ -0,0 +1,70 @@+module Language.Parser.Ptera.Runner.Parser (+ T,++ StartNum,+ StateNum,+ TokenNum,+ VarNum,+ AltNum,+ AltKind (..),++ RunnerParser (..),+ Syntax.GrammarToken (..),+ ActionM (..),+ ReduceArgument (..),+ Syntax.ActionTask (..),+ Syntax.getAction,+ Syntax.modifyAction,+ Syntax.failAction,+ Trans (..),+ TransOp (..),++ eosToken,+) where++import Language.Parser.Ptera.Prelude++import Language.Parser.Ptera.Machine.PEG (AltKind (..))+import qualified Language.Parser.Ptera.Syntax as Syntax++type StartNum = Int+type StateNum = Int+type TokenNum = Int+type VarNum = Int+type AltNum = Int++type T = RunnerParser++newtype ActionM ctx = ActionM+ { runActionM :: [ReduceArgument] -> Syntax.ActionTask ctx ReduceArgument+ }++data ReduceArgument where+ ReduceArgument :: a -> ReduceArgument++data RunnerParser ctx elem altHelp = RunnerParser+ { parserInitial :: StartNum -> Maybe StateNum+ , parserGetTokenNum :: elem -> TokenNum+ , parserTrans :: StateNum -> TokenNum -> Trans+ , parserAltKind :: AltNum -> AltKind+ , parserStateHelp :: StateNum -> [(AltNum, Int)]+ , parserAltHelp :: AltNum -> (StringLit, Maybe altHelp)+ , parserAction :: AltNum -> ActionM ctx+ }++data Trans = Trans+ { transState :: StateNum+ , transOps :: [TransOp]+ }+ deriving (Eq, Show)++data TransOp+ = TransOpEnter VarNum Bool StateNum+ | TransOpPushBackpoint StateNum+ | TransOpHandleNot AltNum+ | TransOpShift+ | TransOpReduce AltNum+ deriving (Eq, Show)++eosToken :: TokenNum+eosToken = -1
+ src/Language/Parser/Ptera/Runner/RunT.hs view
@@ -0,0 +1,638 @@+{-# LANGUAGE CPP #-}++module Language.Parser.Ptera.Runner.RunT (+ T,++ RunT (..),+ runT,++ ParseResult (..),+ Context (..),+ initialContext,+ Position (..),+) where++import Language.Parser.Ptera.Prelude++import qualified Data.IntMap.Strict as IntMap+import qualified Language.Parser.Ptera.Data.Alignable as Alignable+import qualified Language.Parser.Ptera.Data.Alignable.Map as AlignableMap+import qualified Language.Parser.Ptera.Machine.PEG as PEG+import qualified Language.Parser.Ptera.Runner.Parser as Parser+import qualified Language.Parser.Ptera.Scanner as Scanner+import qualified Language.Parser.Ptera.Syntax as Syntax+import qualified Unsafe.Coerce as Unsafe++#define DEBUG 0++type T = RunT++newtype RunT ctx posMark elem altHelp m a = RunT+ {+ unRunT :: StateT (Context ctx posMark elem altHelp) m a+ }+ deriving Functor+ deriving (+ Applicative,+ Monad+ ) via (StateT (Context ctx posMark elem altHelp) m)++instance MonadTrans (RunT ctx posMark elem altHelp) where+ lift mx = RunT do lift mx++runT :: forall ctx posMark elem altHelp m a. Scanner.T posMark elem m+ => RunT ctx posMark elem altHelp m (ParseResult posMark altHelp a)+runT = go where+ go = do+ (tok, _) <- consumeIfNeeded+ sn <- getCtx ctxState+ if sn < 0+ then goResult tok+ else transByInput tok >>= \case+ ContParse ->+ go+ CantContParse ->+ goFailed++ goResult+ :: Parser.TokenNum+ -> RunT ctx posMark elem altHelp m (ParseResult posMark altHelp a)+ goResult tok = getCtx ctxItemStack >>= \case+ [ItemArgument (Parser.ReduceArgument x)] ->+ pure do Parsed do Unsafe.unsafeCoerce x+ _ -> do+ if tok >= 0+ then reportError FailedByEarlyParsed+ else reportError FailedByNotEnoughInput+ goFailed++ goFailed :: RunT ctx posMark elem altHelp m (ParseResult posMark altHelp a)+ goFailed = getCtx ctxDeepestError >>= \case+ Just (_, posMark0, failedReason) ->+ pure do ParseFailed posMark0 failedReason+ Nothing ->+ error "unreachable: any errors are available."++data ParseResult posMark altHelp a+ = Parsed a+ | ParseFailed posMark (FailedReason altHelp)+ deriving (Show, Functor)++data FailedReason altHelp+ = FailedWithHelp [(StringLit, Maybe altHelp, Maybe Int)]+ | FailedToStart+ | FailedByEarlyParsed+ | FailedByNotEnoughInput+ deriving (Show, Functor)++data Context ctx posMark elem altHelp = Context+ { ctxParser :: Parser.T ctx elem altHelp+ , ctxState :: Parser.StateNum+ , ctxItemStack :: [Item posMark ctx]+ , ctxLookAHeadToken :: Maybe (Position, posMark, Parser.TokenNum, Maybe elem)+ , ctxNextPosition :: Position+ , ctxDeepestError :: Maybe (Position, posMark, FailedReason altHelp)+ , ctxMemoTable :: AlignableMap.T Position (IntMap.IntMap (MemoItem posMark))+ , ctxNeedBackItemsCount :: Int+ , ctxCustomContext :: ctx+ }++newtype Position = Position Int+ deriving (Eq, Ord, Show)+ deriving Alignable.T via Alignable.Inst++data MemoItem posMark+ = MemoItemParsed Position posMark Parser.ReduceArgument+ | MemoItemFailed++data Item posMark ctx+ = ItemEnter Position (Maybe posMark) Parser.VarNum Parser.StateNum+ | ItemHandleNot Parser.AltNum+ | ItemBackpoint Position posMark Parser.StateNum+ | ItemArgument Parser.ReduceArgument+ | ItemModifyCustomContext ctx++data RunningResult+ = ContParse+ | CantContParse+ deriving (Eq, Show)++initialContext+ :: Parser.T ctx elem altHelp -> ctx -> Parser.StartNum+ -> Maybe (Context ctx posMark elem altHelp)+initialContext parser ctx0 s0 = do+ sn0 <- Parser.parserInitial parser s0+ pure do+ Context+ { ctxParser = parser+ , ctxState = sn0+ , ctxLookAHeadToken = Nothing+ , ctxItemStack = []+ , ctxNextPosition = Alignable.initialAlign+ , ctxMemoTable = AlignableMap.empty+ , ctxNeedBackItemsCount = 0+ , ctxCustomContext = ctx0+ , ctxDeepestError = Nothing+ }++transByInput :: forall ctx posMark elem altHelp m+ . Scanner.T posMark elem m+ => Parser.TokenNum -> RunT ctx posMark elem altHelp m RunningResult+transByInput tok = go where+ go = do+ parser <- getCtx ctxParser+ sn0 <- getCtx ctxState+ let trans1 = Parser.parserTrans parser sn0 tok+ let sn1 = Parser.transState trans1+ setNextState sn1+#if DEBUG+ (pos0, _) <- getCurrentPosition+ itemStackShow <- prettyShowItemStack+ debugTraceShow ("transByInput", sn0, pos0, tok, trans1, itemStackShow) do pure ()+#endif+ case Parser.transOps trans1 of+ ops@(_:_) ->+ goTransOps ops+ []+ | sn1 < 0 ->+ parseFailWithState sn0+ | otherwise ->+ pure ContParse++ goTransOps :: [Parser.TransOp]+ -> RunT ctx posMark elem altHelp m RunningResult+ goTransOps = \case+ [] ->+ pure ContParse+ op:ops -> do+ result <- runTransOp op+ case result of+ ContParse ->+ goTransOps ops+ CantContParse ->+ pure CantContParse++#if DEBUG+prettyShowItemStack :: Monad m => RunT ctx posMark elem altHelp m [StringLit]+prettyShowItemStack = do+ itemStack <- getCtx ctxItemStack+ pure [ showItem item | item <- itemStack ]+ where+ showItem = \case+ ItemEnter p _ v s ->+ "ItemEnter " <> show (p, v, s)+ ItemHandleNot alt ->+ "ItemHandleNot " <> show alt+ ItemBackpoint p _ s ->+ "ItemBackpoint " <> show (p, s)+ ItemArgument _ ->+ "ItemArgument"+ ItemModifyCustomContext _ ->+ "ItemModifyCustomContext"+#endif++runTransOp :: Scanner.T posMark elem m+ => Parser.TransOp -> RunT ctx posMark elem altHelp m RunningResult+runTransOp = \case+ Parser.TransOpEnter v needBack enterSn ->+ runEnter v needBack enterSn+ Parser.TransOpPushBackpoint backSn -> do+ (pos, mark) <- getCurrentPosition+ pushItem do ItemBackpoint pos mark backSn+ pure ContParse+ Parser.TransOpHandleNot alt -> do+ pushItem do ItemHandleNot alt+ pure ContParse+ Parser.TransOpShift -> consumeIfNeeded >>= \case+ (_, Nothing) ->+ parseFail do Just FailedByNotEnoughInput+ (_, Just x) -> do+ pushItem do ItemArgument do Parser.ReduceArgument x+ shift+ pure ContParse+ Parser.TransOpReduce alt ->+ runReduce alt++runEnter :: Scanner.T posMark elem m+ => Parser.VarNum -> Bool -> Parser.StateNum+ -> RunT ctx posMark elem altHelp m RunningResult+runEnter v needBack enterSn = do+ (pos0, mark0) <- getCurrentPosition+ memoTable <- getCtx ctxMemoTable+ let vm = case AlignableMap.lookup pos0 memoTable of+ Nothing -> IntMap.empty+ Just m -> m+ case IntMap.lookup v vm of+ Nothing -> do+ let mmark0 = if needBack+ then Just mark0+ else Nothing+ pushItem do ItemEnter pos0 mmark0 v enterSn+ pure ContParse+ Just memoItem -> case memoItem of+ MemoItemParsed pos1 mark1 x -> do+#if DEBUG+ debugTraceShow ("runEnter / MemoItemParsed", v, enterSn, pos1) do pure ()+#endif+ setNextState enterSn+ pushItem do ItemArgument x+ seekToMark pos1 mark1+ pure ContParse+ MemoItemFailed -> do+#if DEBUG+ debugTraceShow ("runEnter / MemoItemFailed", v, enterSn) do pure ()+#endif+ parseFail Nothing++#if DEBUG+debugShowHelpAlt :: Monad m+ => StringLit -> Parser.AltNum -> RunT ctx posMark elem altHelp m ()+debugShowHelpAlt msg alt = do+ parser <- getCtx ctxParser+ let (dv, _) = Parser.parserAltHelp parser alt+ debugTraceShow (msg, alt, dv) do pure ()+#endif++runReduce :: forall ctx posMark elem altHelp m+ . Scanner.T posMark elem m+ => Parser.AltNum -> RunT ctx posMark elem altHelp m RunningResult+runReduce alt = go0 where+ go0 = do+#if DEBUG+ debugShowHelpAlt "runReduce" alt+#endif+ capturedCtxForFail <- captureCtx+ go capturedCtxForFail Nothing []++ go capturedCtxForFail mrollbackCustomCtx0 args = popItem >>= \case+ Nothing ->+ pure CantContParse+ Just item -> case item of+ ItemArgument x -> do+ go capturedCtxForFail mrollbackCustomCtx0 do x:args+ ItemModifyCustomContext customCtx ->+ go capturedCtxForFail+ do Just customCtx+ do args+ ItemBackpoint{} -> do+ go capturedCtxForFail mrollbackCustomCtx0 args+ ItemHandleNot{} -> do+ forM_ mrollbackCustomCtx0 \customCtx -> updateCustomContext customCtx+ parseFailWithAlt alt+ ItemEnter pos mmark v enterSn ->+ goEnter capturedCtxForFail mrollbackCustomCtx0 args pos mmark v enterSn++ goEnter capturedCtxForFail mrollbackCustomCtx args pos0 mmark0 v enterSn = do+ parser <- getCtx ctxParser+ case Parser.parserAltKind parser alt of+ PEG.AltSeq -> runActionAndSaveEnterResult v pos0 mrollbackCustomCtx alt args >>= \case+ False -> do+ restoreCtx capturedCtxForFail+ parseFailWithAlt alt+ True -> do+ setNextState enterSn+ pure ContParse+ PEG.AltAnd -> runActionAndSaveEnterResult v pos0 mrollbackCustomCtx alt args >>= \case+ False -> do+ restoreCtx capturedCtxForFail+ parseFailWithAlt alt+ True -> do+ let mark0 = case mmark0 of+ Nothing ->+ error "unreachable: no mark with and alternative"+ Just x ->+ x+ seekToMark pos0 mark0+ setNextState enterSn+ pure ContParse+ PEG.AltNot ->+ pure CantContParse++parseFailWithAlt :: forall ctx posMark elem altHelp m+ . Scanner.T posMark elem m+ => Parser.AltNum -> RunT ctx posMark elem altHelp m RunningResult+parseFailWithAlt alt = do+ parser <- getCtx ctxParser+ let (varHelp, altHelp) = Parser.parserAltHelp parser alt+ parseFail do Just do FailedWithHelp [(varHelp, altHelp, Nothing)]++parseFailWithState :: forall ctx posMark elem altHelp m+ . Scanner.T posMark elem m+ => Parser.StateNum -> RunT ctx posMark elem altHelp m RunningResult+parseFailWithState sn = do+ parser <- getCtx ctxParser+ let altItems = Parser.parserStateHelp parser sn+ let helps =+ [+ ( varHelp+ , altHelp+ , Just pos+ )+ | (alt, pos) <- altItems+ , let (varHelp, altHelp) = Parser.parserAltHelp parser alt+ ]+ parseFail do Just do FailedWithHelp helps++parseFail :: forall ctx posMark elem altHelp m+ . Scanner.T posMark elem m+ => Maybe (FailedReason altHelp) -> RunT ctx posMark elem altHelp m RunningResult+parseFail = go0 where+ go0 :: Maybe (FailedReason altHelp) -> RunT ctx posMark elem altHelp m RunningResult+ go0 mayFailedReason = do+#if DEBUG+ debugTraceShow ("parseFail", fmap (const ()) <$> mayFailedReason) do pure ()+#endif+ case mayFailedReason of+ Nothing ->+ pure ()+ Just failedReason -> do+ reportError failedReason+ go Nothing++ go :: Maybe ctx -> RunT ctx posMark elem altHelp m RunningResult+ go mrollbackCustomCtx0 = popItem >>= \case+ Nothing ->+ pure CantContParse+ Just item -> case item of+ ItemBackpoint pos p backSn -> do+ forM_ mrollbackCustomCtx0 \customCtx -> updateCustomContext customCtx+ setNextState backSn+ seekToMark pos p+ pure ContParse+ ItemHandleNot alt -> do+ forM_ mrollbackCustomCtx0 \customCtx -> updateCustomContext customCtx+ capturedCtxForFail <- captureCtx+ goHandleNot capturedCtxForFail Nothing alt+ ItemModifyCustomContext customCtx ->+ go do Just customCtx+ ItemArgument{} ->+ go mrollbackCustomCtx0+ ItemEnter pos0 _ v _ -> do+ saveFailedEnterAction v pos0+ go mrollbackCustomCtx0++ goHandleNot capturedCtxForFail mrollbackCustomCtx0 alt = popItem >>= \case+ Nothing ->+ pure CantContParse+ Just item -> case item of+ ItemEnter pos0 mmark0 v enterSn ->+ goEnter capturedCtxForFail mrollbackCustomCtx0 alt pos0 mmark0 v enterSn+ ItemArgument{} ->+ goHandleNot capturedCtxForFail mrollbackCustomCtx0 alt+ ItemBackpoint{} ->+ goHandleNot capturedCtxForFail mrollbackCustomCtx0 alt+ ItemHandleNot{} ->+ pure CantContParse+ ItemModifyCustomContext customCtx ->+ goHandleNot capturedCtxForFail+ do Just customCtx+ do alt++ goEnter+ :: Context ctx posMark elem altHelp -> Maybe ctx+ -> Parser.AltNum -> Position -> Maybe posMark -> Parser.VarNum -> Parser.StateNum+ -> RunT ctx posMark elem altHelp m RunningResult+ goEnter capturedCtxForFail mrollbackCustomCtx alt pos0 mmark0 v enterSn = do+ parser <- getCtx ctxParser+ case Parser.parserAltKind parser alt of+ PEG.AltSeq ->+ error "unreachable: a not handling with seq alternative"+ PEG.AltAnd ->+ error "unreachable: a not handling with and alternative"+ PEG.AltNot -> runActionAndSaveEnterResult v pos0 mrollbackCustomCtx alt [] >>= \case+ False -> do+ restoreCtx capturedCtxForFail+ parseFailWithAlt alt+ True -> do+ let mark0 = case mmark0 of+ Nothing ->+ error "unreachable: no mark with not alternative"+ Just x ->+ x+ seekToMark pos0 mark0+ setNextState enterSn+ pure ContParse++runActionAndSaveEnterResult+ :: Scanner.T posMark elem m+ => Parser.VarNum -> Position+ -> Maybe ctx -> Parser.AltNum -> [Parser.ReduceArgument]+ -> RunT ctx posMark elem altHelp m Bool+runActionAndSaveEnterResult v pos0 mrollbackCustomCtx alt args =+ runAction alt args >>= \case+ Syntax.ActionTaskFail ->+ pure False+ Syntax.ActionTaskResult res -> do+ saveParsedEnterAction v pos0 mrollbackCustomCtx Nothing res+ pure True+ Syntax.ActionTaskModifyResult ctx1 res -> do+ saveParsedEnterAction v pos0 mrollbackCustomCtx (Just ctx1) res+ pure True++runAction :: Scanner.T posMark elem m+ => Parser.AltNum -> [Parser.ReduceArgument]+ -> RunT ctx posMark elem altHelp m (Syntax.ActionTaskResult ctx Parser.ReduceArgument)+runAction alt args = do+ parser <- getCtx ctxParser+ ctx0 <- getCtx ctxCustomContext+ let actionTask = Parser.runActionM+ do Parser.parserAction parser alt+ do args+ pure do Syntax.runActionTask actionTask ctx0++saveParsedEnterAction+ :: Scanner.T posMark elem m+ => Parser.VarNum -> Position -> Maybe ctx -> Maybe ctx -> Parser.ReduceArgument+ -> RunT ctx posMark elem altHelp m ()+saveParsedEnterAction v pos0 mrollbackCustomCtx mactionCustomCtx res = do+ forM_ mrollbackCustomCtx \customCtx -> do+ needBack <- isNeedBack+ when needBack do+ pushItem do ItemModifyCustomContext customCtx+ case mactionCustomCtx of+ Just customCtx ->+ updateCustomContext customCtx+ Nothing -> insertMemoItemIfNeeded v pos0 do+ (pos1, pm1) <- getCurrentPosition+ pure do MemoItemParsed pos1 pm1 res+ pushItem do ItemArgument res++saveFailedEnterAction+ :: Monad m+ => Parser.VarNum -> Position -> RunT ctx posMark elem altHelp m ()+saveFailedEnterAction v pos = insertMemoItemIfNeeded v pos do+ pure MemoItemFailed++reportError+ :: Scanner.T posMark elem m+ => FailedReason altHelp -> RunT ctx posMark elem altHelp m ()+reportError failedReason = do+ (pos0, posMark0) <- getCurrentPosition+ RunT do+ modify' \ctx -> ctx+ { ctxDeepestError = case ctxDeepestError ctx of+ oldErr@(Just (pos1, _, _)) | pos0 < pos1 ->+ oldErr+ _ ->+ Just (pos0, posMark0, failedReason)+ }++insertMemoItemIfNeeded+ :: Monad m+ => Parser.VarNum -> Position+ -> RunT ctx posMark elem altHelp m (MemoItem posMark)+ -> RunT ctx posMark elem altHelp m ()+insertMemoItemIfNeeded v pos mitem = do+ needBack <- isNeedBack+ when needBack do+ memoItem <- mitem+ RunT do+ modify' \ctx -> ctx+ { ctxMemoTable = AlignableMap.insert pos+ do case AlignableMap.lookup pos do ctxMemoTable ctx of+ Nothing -> IntMap.singleton v memoItem+ Just vm -> IntMap.insert v memoItem vm+ do ctxMemoTable ctx+ }++updateCustomContext :: Monad m => ctx -> RunT ctx posMark elem altHelp m ()+updateCustomContext customCtx = RunT do+ modify' \ctx -> ctx+ { ctxMemoTable = AlignableMap.empty+ , ctxCustomContext = customCtx+ }++setNextState :: Monad m => Parser.StateNum -> RunT ctx posMark elem altHelp m ()+setNextState sn = RunT do+ modify' \ctx -> ctx+ { ctxState = sn+ }++getCtx :: Monad m+ => (Context ctx posMark elem altHelp -> a)+ -> RunT ctx posMark elem altHelp m a+getCtx f = RunT do f <$> get+{-# INLINE getCtx #-}++captureCtx :: Monad m => RunT ctx posMark elem altHelp m (Context ctx posMark elem altHelp)+captureCtx = RunT get++restoreCtx :: Monad m => Context ctx posMark elem altHelp -> RunT ctx posMark elem altHelp m ()+restoreCtx ctx = RunT do put ctx++getCurrentPosition :: Scanner.T posMark elem m+ => RunT ctx posMark elem altHelp m (Position, posMark)+getCurrentPosition = getCtx ctxLookAHeadToken >>= \case+ Just (pos, pm, _, _) ->+ pure (pos, pm)+ Nothing -> do+ pm <- lift Scanner.getPosMark+ pos <- getCtx ctxNextPosition+ pure (pos, pm)++consumeIfNeeded :: Scanner.T posMark elem m+ => RunT ctx posMark elem altHelp m (Parser.TokenNum, Maybe elem)+consumeIfNeeded = getCtx ctxLookAHeadToken >>= \case+ Just (_, _, tn, mt) ->+ pure (tn, mt)+ Nothing -> do+ pm <- lift Scanner.getPosMark+ r@(tn, mt) <- lift Scanner.consumeInput >>= \case+ Nothing ->+ pure (Parser.eosToken, Nothing)+ Just t -> do+ parser <- getCtx ctxParser+ let tn = Parser.parserGetTokenNum parser t+ pure (tn, Just t)+ RunT do+ modify' \ctx -> ctx+ { ctxNextPosition = Alignable.nextAlign+ do ctxNextPosition ctx+ , ctxLookAHeadToken = Just+ (ctxNextPosition ctx, pm, tn, mt)+ }+ pure r++shift :: Monad m => RunT ctx posMark elem altHelp m ()+shift = getCtx ctxLookAHeadToken >>= \case+ Nothing ->+ error "Must consume before shift"+ Just (_, _, _, Nothing) ->+ error "No more shift"+ Just (_, _, _, Just{}) ->+ RunT do+ modify' \ctx -> ctx+ {+ ctxLookAHeadToken = Nothing+ }++seekToMark :: Scanner.T posMark elem m+ => Position -> posMark -> RunT ctx posMark elem altHelp m ()+seekToMark pos pm = do+ RunT do+ modify' \ctx -> ctx+ { ctxLookAHeadToken = Nothing+ , ctxNextPosition = pos+ }+ lift do Scanner.seekToPosMark pm++isNeedBack :: Monad m => RunT ctx posMark elem altHelp m Bool+isNeedBack = do+ needBackItemsCount <- getCtx ctxNeedBackItemsCount+ pure do needBackItemsCount > 0++pushItem+ :: Scanner.T posMark elem m+ => Item posMark ctx -> RunT ctx posMark elem altHelp m ()+pushItem item = do+ (pos, p) <- getCurrentPosition+ bc0 <- getCtx ctxNeedBackItemsCount+ let bc1 = if isNeedBackItem item then bc0 + 1 else bc0+ when do bc0 == 0 && bc1 > 0+ do lift do Scanner.scanMode do Scanner.ScanModeNeedBack p+ RunT do+ modify' \ctx -> ctx+ { ctxItemStack = item:ctxItemStack ctx+ , ctxNeedBackItemsCount = bc1+ , ctxMemoTable = if bc0 == 0 && bc1 > 0+ then do+ AlignableMap.restrictGreaterOrEqual+ do pos+ do ctxMemoTable ctx+ else+ ctxMemoTable ctx+ }++popItem+ :: Scanner.T posMark elem m+ => RunT ctx posMark elem altHelp m (Maybe (Item posMark ctx))+popItem = getCtx ctxItemStack >>= \case+ [] ->+ pure Nothing+ item:rest -> do+ bc0 <- getCtx ctxNeedBackItemsCount+ let bc1 = if isNeedBackItem item then bc0 - 1 else bc0+ when do bc1 == 0+ do lift do Scanner.scanMode Scanner.ScanModeNoBack+ RunT do+ modify' \ctx -> ctx+ { ctxItemStack = rest+ , ctxNeedBackItemsCount = bc1+ }+ pure do Just item++isNeedBackItem :: Item posMark ctx -> Bool+isNeedBackItem = \case+ ItemHandleNot{} ->+ False+ ItemBackpoint{} ->+ True+ ItemModifyCustomContext{} ->+ False+ ItemEnter _ mmark _ _ -> case mmark of+ Nothing ->+ False+ Just{} ->+ True+ ItemArgument{} ->+ False
+ src/Language/Parser/Ptera/Scanner.hs view
@@ -0,0 +1,42 @@+module Language.Parser.Ptera.Scanner where++import Language.Parser.Ptera.Prelude+++type T = Scanner++class Monad m => Scanner posMark elem m | m -> posMark, m -> elem where+ consumeInput :: m (Maybe elem)+ getPosMark :: m posMark+ seekToPosMark :: posMark -> m ()+ scanMode :: ScanMode posMark -> m ()++data ScanMode posMark+ = ScanModeNoBack+ | ScanModeNeedBack posMark+ deriving (Eq, Show)+++newtype ListScanner e a = ListScanner+ {+ unListScanner :: State [e] a+ }+ deriving (Functor, Applicative, Monad) via State [e]++runListScanner :: ListScanner e a -> [e] -> a+runListScanner (ListScanner scanner) xs = evalState scanner xs++instance Scanner [e] e (ListScanner e) where+ consumeInput = ListScanner do+ get >>= \case+ [] ->+ pure Nothing+ x:xs -> do+ put xs+ pure do Just x++ getPosMark = ListScanner get++ seekToPosMark xs = ListScanner do put xs++ scanMode _ = pure ()
+ src/Language/Parser/Ptera/Syntax.hs view
@@ -0,0 +1,160 @@+module Language.Parser.Ptera.Syntax (+ T,++ HasField (..),+ SafeGrammar.HasRuleExprField (..),+ SafeGrammar.TokensTag,+ SafeGrammar.RulesTag,+ SafeGrammar.RuleExprType,++ GrammarM,+ SafeGrammar.MemberInitials (..),+ SafeGrammar.Rules (..),+ SafeGrammar.GrammarToken (..),+ RuleExprM,+ AltM,+ SafeGrammar.Expr,+ HFList.HFList (..),+ HFList.DictF (..),+ HList,+ pattern HNil,+ pattern (:*),+ SemActM (..),+ semActM,+ ActionTask (..),+ ActionTaskResult (..),+ getAction,+ modifyAction,+ failAction,++ Grammar,+ RuleExpr,+ Alt,+ SemAct,+ semAct,++ SafeGrammar.fixGrammar,+ SafeGrammar.ruleExpr,+ (SafeGrammar.<^>),+ (<:>),+ eps,+ (<::>),+ epsM,+ SafeGrammar.var,+ SafeGrammar.varA,+ SafeGrammar.tok,+ SafeGrammar.TokensMember (..),+ SafeGrammar.tokA,+) where++import Language.Parser.Ptera.Prelude++import qualified Language.Parser.Ptera.Data.HFList as HFList+import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar+++type T ctx = GrammarM ctx++type GrammarM ctx = SafeGrammar.Grammar (SemActM ctx)+type RuleExprM ctx = SafeGrammar.RuleExpr (SemActM ctx)+type AltM ctx = SafeGrammar.Alt (SemActM ctx)++type Grammar = GrammarM ()+type RuleExpr = RuleExprM ()+type Alt = AltM ()+++(<:>)+ :: SafeGrammar.Expr rules tokens elem us -> (HList us -> a)+ -> AltM ctx rules tokens elem a+e <:> act = e SafeGrammar.<:> semAct act++infixl 4 <:>++eps :: (HList '[] -> a) -> AltM ctx rules tokens elem a+eps act = SafeGrammar.eps do semAct act++(<::>)+ :: SafeGrammar.Expr rules tokens elem us -> (HList us -> ActionTask ctx a)+ -> AltM ctx rules tokens elem a+e <::> act = e SafeGrammar.<:> semActM act++infixl 4 <::>++epsM :: (HList '[] -> ActionTask ctx a) -> AltM ctx rules tokens elem a+epsM act = SafeGrammar.eps do semActM act+++type HList = HFList.T Identity++pattern HNil :: HList '[]+pattern HNil = HFList.HFNil++pattern (:*) :: u -> HList us -> HList (u ': us)+pattern x :* xs = HFList.HFCons (Identity x) xs++infixr 6 :*+++newtype SemActM ctx us a = SemActM+ { semanticAction :: HList us -> ActionTask ctx a+ }+ deriving Functor++type SemAct = SemActM ()++semActM :: (HList us -> ActionTask ctx a) -> SemActM ctx us a+semActM = SemActM++semAct :: (HList us -> a) -> SemActM ctx us a+semAct f = SemActM \l -> pure do f l+++newtype ActionTask ctx a = ActionTask+ { runActionTask :: ctx -> ActionTaskResult ctx a+ }+ deriving Functor++data ActionTaskResult ctx a+ = ActionTaskFail+ | ActionTaskResult a+ | ActionTaskModifyResult ctx a+ deriving (Eq, Show, Functor)++getAction :: ActionTask ctx ctx+getAction = ActionTask \ctx0 -> ActionTaskResult ctx0++modifyAction :: (ctx -> ctx) -> ActionTask ctx ()+modifyAction f = ActionTask \ctx0 -> ActionTaskModifyResult (f ctx0) ()++failAction :: ActionTask ctx a+failAction = ActionTask \_ -> ActionTaskFail++instance Applicative (ActionTask ctx) where+ pure x = ActionTask \_ -> ActionTaskResult x+ ActionTask mf <*> ActionTask mx = ActionTask \ctx0 -> case mf ctx0 of+ ActionTaskFail ->+ ActionTaskFail+ ActionTaskResult f -> case mx ctx0 of+ ActionTaskFail ->+ ActionTaskFail+ ActionTaskResult x ->+ ActionTaskResult do f x+ ActionTaskModifyResult ctx1 x ->+ ActionTaskModifyResult ctx1 do f x+ ActionTaskModifyResult ctx1 f -> case mx ctx1 of+ ActionTaskFail ->+ ActionTaskFail+ ActionTaskResult x ->+ ActionTaskModifyResult ctx1 do f x+ ActionTaskModifyResult ctx2 x ->+ ActionTaskModifyResult ctx2 do f x++instance Monad (ActionTask ctx) where+ ActionTask mx >>= f = ActionTask \ctx0 -> case mx ctx0 of+ ActionTaskFail ->+ ActionTaskFail+ ActionTaskResult x ->+ runActionTask (f x) ctx0+ ActionTaskModifyResult ctx1 x ->+ runActionTask (f x) ctx1
+ src/Language/Parser/Ptera/Syntax/SafeGrammar.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++module Language.Parser.Ptera.Syntax.SafeGrammar (+ T,++ Grammar (..),+ TokensTag,+ RulesTag,+ RuleExprType,+ GrammarToken (..),+ fixGrammar,++ StartPoint,+ Terminal,+ NonTerminal,+ HasRuleExprField (..),+ MemberInitials (..),+ Rules (..),+ genStartPoint,++ RuleExpr (..),+ Alt (..),+ Expr (..),+ ruleExpr,+ (<^>),+ (<:>),+ eps,+ var,+ varA,+ tok,+ TokensMember (..),+ tokA,+) where++import Language.Parser.Ptera.Prelude++import qualified Data.HashMap.Strict as HashMap+import qualified Language.Parser.Ptera.Data.HEnum as HEnum+import qualified Language.Parser.Ptera.Data.HFList as HFList+import qualified Language.Parser.Ptera.Syntax.Grammar as SyntaxGrammar+import Prelude (String)+import qualified Type.Membership as Membership+++type T = Grammar++type Grammar+ :: ([Type] -> Type -> Type) -> Type -> Type -> Type -> [Symbol]+ -> Type+newtype Grammar action rules tokens elem initials = UnsafeGrammar+ {+ unsafeGrammar :: SyntaxGrammar.FixedGrammar+ StartPoint+ NonTerminal+ Terminal+ elem+ StringLit+ (Maybe ())+ action+ }++type family TokensTag (tokens :: Type) :: [Symbol]+type family RulesTag (rules :: Type) :: [Symbol]+type family RuleExprType (rules :: Type) :: Type -> Type++class GrammarToken tokens elem where+ tokenToTerminal :: Proxy tokens -> elem -> HEnum.T (TokensTag tokens)++class+ ( KnownSymbol v+ , HasField v rules ((RuleExprType rules) (RuleExprReturnType rules v))+ ) => HasRuleExprField rules v where+ type RuleExprReturnType rules v :: Type++ nonTerminalName :: rules -> proxy v -> String+ nonTerminalName _ p = symbolVal p++type GrammarMForFixGrammar elem action = SyntaxGrammar.GrammarT+ StartPoint+ NonTerminal+ Terminal+ elem+ StringLit+ (Maybe ())+ action+ Identity++fixGrammar+ :: forall initials action rules tokens elem+ . MemberInitials rules initials+ => Rules rules => RuleExprType rules ~ RuleExpr action rules tokens elem+ => rules -> Grammar action rules tokens elem initials+fixGrammar ruleDefs = UnsafeGrammar do+ runIdentity do+ SyntaxGrammar.fixGrammarT do+ HFList.hforMWithIndex+ memberInitials+ fixInitial+ HFList.hforMWithIndex+ generateRules+ fixRule+ where+ fixInitial+ :: Membership.Membership initials v+ -> HFList.DictF (HasRuleExprField rules) v+ -> GrammarMForFixGrammar elem action ()+ fixInitial m HFList.DictF = do+ let sn = genStartPoint m+ let vn = getNewV do symbolVal m+ SyntaxGrammar.initialT sn vn++ fixRule+ :: forall v+ . Membership.Membership (RulesTag rules) v+ -> HFList.DictF (HasRuleExprField rules) v+ -> GrammarMForFixGrammar elem action ()+ fixRule m HFList.DictF = do+ let vn = getNewV do symbolVal m+ let d = nonTerminalName ruleDefs m+ SyntaxGrammar.ruleT vn d do+ fixRuleExpr do getField @v ruleDefs++ fixRuleExpr :: RuleExpr action rules tokens elem a+ -> SyntaxGrammar.RuleExpr NonTerminal Terminal elem (Maybe ()) action+ fixRuleExpr = \case+ RuleExpr alts -> SyntaxGrammar.RuleExpr+ [ fixAlt origAlt | origAlt <- alts ]++ fixAlt :: Alt action rules tokens elem a+ -> SyntaxGrammar.Alt NonTerminal Terminal elem (Maybe ()) action a+ fixAlt (UnsafeAlt origAlt) = case origAlt of+ SyntaxGrammar.Alt e h act -> SyntaxGrammar.Alt+ do fixExpr e+ do h+ do act++ fixExpr :: SyntaxGrammar.Expr IntermNonTerminal Terminal elem us+ -> SyntaxGrammar.Expr NonTerminal Terminal elem us+ fixExpr = HFList.hmapWithIndex+ do \_ u1 -> fixUnit u1++ fixUnit :: SyntaxGrammar.Unit IntermNonTerminal Terminal elem u+ -> SyntaxGrammar.Unit NonTerminal Terminal elem u+ fixUnit u = case u of+ SyntaxGrammar.UnitToken t ->+ SyntaxGrammar.UnitToken t+ SyntaxGrammar.UnitVar v ->+ SyntaxGrammar.UnitVar do getNewV v++ rulesTag = genRulesTagMap do proxy# @rules++ getNewV v = case HashMap.lookup v rulesTag of+ Just newV ->+ newV+ Nothing ->+ error "unreachable: rulesTag must include v."++type StartPoint = Int+type Terminal = Int+type NonTerminal = Int+type IntermNonTerminal = String+++class MemberInitials rules initials where+ memberInitials :: HFList.T (HFList.DictF (HasRuleExprField rules)) initials++class Rules rules where+ generateRules :: HFList.T (HFList.DictF (HasRuleExprField rules)) (RulesTag rules)+++genStartPoint :: forall initials v. Membership.Membership initials v -> StartPoint+genStartPoint m = Membership.getMemberId m++genRulesTagMap :: forall rules.+ Rules rules => Proxy# rules -> HashMap.HashMap IntermNonTerminal NonTerminal+genRulesTagMap _ = HFList.hfoldlWithIndex HashMap.empty go generateRules where+ go :: forall v+ . HashMap.HashMap IntermNonTerminal NonTerminal+ -> Membership.Membership (RulesTag rules) v+ -> HFList.DictF (HasRuleExprField rules) v+ -> HashMap.HashMap IntermNonTerminal NonTerminal+ go vMap m HFList.DictF = HashMap.insert+ do symbolVal' do proxy# @v+ do Membership.getMemberId m+ do vMap++type RuleExpr :: ([Type] -> Type -> Type) -> Type -> Type -> Type -> Type -> Type+newtype RuleExpr action rules tokens elem a = RuleExpr+ { unRuleExpr :: [Alt action rules tokens elem a]+ }++type Alt :: ([Type] -> Type -> Type) -> Type -> Type -> Type -> Type -> Type+newtype Alt action rules tokens elem a = UnsafeAlt+ { unsafeAlt+ :: SyntaxGrammar.Alt IntermNonTerminal Terminal elem (Maybe ()) action a+ }++type Expr :: Type -> Type -> Type -> [Type] -> Type+newtype Expr rules tokens elem us = UnsafeExpr+ { unsafeExpr :: SyntaxGrammar.Expr IntermNonTerminal Terminal elem us+ }++class TokensMember tokens t where+ tokensMembership :: Proxy# '(tokens, t) -> Membership.Membership (TokensTag tokens) t++ruleExpr :: [Alt action rules tokens elem a] -> RuleExpr action rules tokens elem a+ruleExpr alts = RuleExpr alts++(<:>)+ :: Expr rules tokens elem us -> action us a+ -> Alt action rules tokens elem a+UnsafeExpr e <:> act = UnsafeAlt do SyntaxGrammar.Alt e Nothing act++infixl 4 <:>++eps :: action '[] a -> Alt action rules tokens elem a+eps act = UnsafeAlt do SyntaxGrammar.Alt HFList.HFNil Nothing act++(<^>)+ :: Expr rules tokens elem us1 -> Expr rules tokens elem us2+ -> Expr rules tokens elem (HFList.Concat us1 us2)+UnsafeExpr e1 <^> UnsafeExpr e2 = UnsafeExpr do HFList.hconcat e1 e2++infixr 5 <^>++var :: KnownSymbol v => proxy v -> Expr rules tokens elem '[RuleExprReturnType rules v]+var p = UnsafeExpr do HFList.HFCons u HFList.HFNil where+ u = SyntaxGrammar.UnitVar do symbolVal p++varA :: forall v rules tokens elem.+ KnownSymbol v => Expr rules tokens elem '[RuleExprReturnType rules v]+varA = var do Proxy @v++tok :: Membership.Membership (TokensTag tokens) t -> Expr rules tokens elem '[elem]+tok p = UnsafeExpr do HFList.HFCons u HFList.HFNil where+ u = SyntaxGrammar.UnitToken+ do HEnum.unsafeHEnum do HEnum.henum p++tokA :: forall t rules tokens elem.+ TokensMember tokens t => Expr rules tokens elem '[elem]+tokA = tok do tokensMembership do proxy# @'(tokens, t)
+ test/doctest/Doctest.hs view
@@ -0,0 +1,23 @@+module Main where++import Prelude++import qualified Build_doctests as BuildF+import qualified Control.Exception as Exception+import Control.Monad+import qualified System.Environment as IO+import qualified System.IO as IO+import qualified Test.DocTest as DocTest++main :: IO ()+main = forM_ BuildF.components \(BuildF.Component name flags pkgs sources) -> do+ putStrLn "============================================="+ print name+ putStrLn "---------------------------------------------"+ IO.hFlush IO.stdout+ let args = flags ++ pkgs ++ sources+ IO.unsetEnv "GHC_ENVIRONMENT"+ DocTest.doctest args `Exception.catch`+ \(e :: Exception.SomeException) -> print e+ putStrLn "============================================="+ IO.hFlush IO.stdout
+ test/spec/HSpecDriver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}