ptera-th (empty) → 0.1.0.0
raw patch · 14 files changed
+1252/−0 lines, 14 filesdep +QuickCheckdep +arraydep +basebuild-type:Customsetup-changed
Dependencies added: QuickCheck, array, base, containers, doctest, enummapset-th, ghc-prim, hspec, membership, ptera, ptera-core, ptera-th, template-haskell, unordered-containers
Files
- CHANGELOG.md +0/−0
- LICENSE +5/−0
- README.md +67/−0
- Setup.hs +6/−0
- ptera-th.cabal +166/−0
- src/Language/Parser/Ptera/TH.hs +57/−0
- src/Language/Parser/Ptera/TH/Data/Bits/MaxBit.hs +17/−0
- src/Language/Parser/Ptera/TH/ParserLib.hs +86/−0
- src/Language/Parser/Ptera/TH/Pipeline/Grammar2ParserDec.hs +49/−0
- src/Language/Parser/Ptera/TH/Pipeline/SRB2ParserDec.hs +408/−0
- src/Language/Parser/Ptera/TH/Syntax.hs +151/−0
- src/Language/Parser/Ptera/TH/Util.hs +216/−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-th.cabal view
@@ -0,0 +1,166 @@+cabal-version: 3.0+build-type: Custom++name: ptera-th+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,+ ptera >= 0.1.0 && < 0.2,+ ghc-prim >= 0.6.1 && < 0.7,+ containers >= 0.6.0 && < 0.7,+ unordered-containers >= 0.2.0 && < 0.3,+ array >= 0.5.4 && < 0.6,+ membership >= 0.0.1 && < 0.1,+ enummapset-th >= 0.6.0 && < 0.7,+ template-haskell >= 2.16.0 && < 2.17,++ autogen-modules:+ Paths_ptera_th+ other-modules:+ Paths_ptera_th++custom-setup+ setup-depends:+ base,+ Cabal,+ cabal-doctest,++library+ import:+ general,+ hs-source-dirs:+ src+ exposed-modules:+ Language.Parser.Ptera.TH+ Language.Parser.Ptera.TH.ParserLib++ Language.Parser.Ptera.TH.Data.Bits.MaxBit++ Language.Parser.Ptera.TH.Syntax+ Language.Parser.Ptera.TH.Util+ Language.Parser.Ptera.TH.Pipeline.SRB2ParserDec+ Language.Parser.Ptera.TH.Pipeline.Grammar2ParserDec++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-th,++ hspec,+ QuickCheck,
+ src/Language/Parser/Ptera/TH.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Parser.Ptera.TH (+ module Language.Parser.Ptera.TH.Syntax,+ module Language.Parser.Ptera.Scanner,+ module Language.Parser.Ptera.Runner,+ module Language.Parser.Ptera.TH.ParserLib,+ module Language.Parser.Ptera.TH.Util,+ genRunner,+ GenParam (..),+ defaultCustomCtxTy,+) where++import Language.Parser.Ptera.Prelude++import qualified Language.Haskell.TH as TH+import Language.Parser.Ptera.Runner (ParseResult (..),+ Result,+ runParser,+ runParserM)+import Language.Parser.Ptera.Scanner hiding (T)+import Language.Parser.Ptera.TH.ParserLib+import qualified Language.Parser.Ptera.TH.Pipeline.Grammar2ParserDec as Grammar2ParserDec+import Language.Parser.Ptera.TH.Syntax hiding (T,+ UnsafeSemActM,+ unsafeSemanticAction, semAct, semActM)+import Language.Parser.Ptera.TH.Util (GenRulesTypes (..),+ genGrammarToken,+ genRules,+ genParsePoints)+import qualified Type.Membership as Membership++genRunner :: forall initials rules tokens ctx elem+ . GrammarToken tokens elem => Membership.Generate (TokensTag tokens)+ => GenParam -> GrammarM ctx rules tokens elem initials -> TH.Q [TH.Dec]+genRunner param g = Grammar2ParserDec.grammar2ParserDec+ do Grammar2ParserDec.PipelineParam+ {+ startsTy = startsTy param,+ rulesTy = rulesTy param,+ tokensTy = tokensTy param,+ tokenTy = tokenTy param,+ customCtxTy = customCtxTy param+ }+ do g++data GenParam = GenParam+ {+ startsTy :: TH.Q TH.Type,+ rulesTy :: TH.Q TH.Type,+ tokensTy :: TH.Q TH.Type,+ tokenTy :: TH.Q TH.Type,+ customCtxTy :: TH.Q TH.Type+ }++defaultCustomCtxTy :: TH.Q TH.Type+defaultCustomCtxTy = [t|()|]
+ src/Language/Parser/Ptera/TH/Data/Bits/MaxBit.hs view
@@ -0,0 +1,17 @@+module Language.Parser.Ptera.TH.Data.Bits.MaxBit (+ maxBitSize,+) where++import Language.Parser.Ptera.Prelude++import qualified Data.Bits as Bits+++maxBitSize :: Bits.FiniteBits a => Ord a => Num a => a -> Int+maxBitSize n = go 1 2 where+ go i m+ | n < m = i+ | i >= Bits.finiteBitSize n = i+ | otherwise = go+ do i + 1+ do m * 2
+ src/Language/Parser/Ptera/TH/ParserLib.hs view
@@ -0,0 +1,86 @@+module Language.Parser.Ptera.TH.ParserLib (+ module Language.Parser.Ptera.Runner.Parser,+ module Data.Proxy,+ Parser,+ pteraTHTokenToTerminal,+ pteraTHArrayIndex,+ pteraTHArrayFromList,+ pteraTHLookupTable8,+ pteraTHLookupTable16,+ pteraTHLookupTable32,+ pteraTHUnsafeExtractReduceArgument,+ pteraTHUnsafeRunner,+ pteraTHAction,+ pteraTHActionTaskPure,+) where++import Language.Parser.Ptera.Prelude++import qualified Data.Array as Array+import qualified Data.Bits as Bits+import Data.Proxy (Proxy (..))+import qualified GHC.Prim as Prim+import qualified GHC.ST as ST+import qualified GHC.Types as Types+import qualified Language.Parser.Ptera.Data.HEnum as HEnum+import qualified Language.Parser.Ptera.Runner as Runner+import Language.Parser.Ptera.Runner.Parser (ActionM (..), ActionTask,+ AltKind (..),+ GrammarToken (..),+ ReduceArgument (..),+ RunnerParser (..),+ Trans (..), TransOp (..),+ failAction, getAction,+ modifyAction)+import qualified Unsafe.Coerce as Unsafe++type Parser = Runner.T++pteraTHTokenToTerminal :: GrammarToken tokens elem => Proxy tokens -> elem -> Int+pteraTHTokenToTerminal p t = HEnum.unsafeHEnum do tokenToTerminal p t++pteraTHArrayIndex :: Array.Array Int e -> Int -> e+pteraTHArrayIndex arr i = arr Array.! i++pteraTHArrayFromList :: Int -> [e] -> Array.Array Int e+pteraTHArrayFromList b l = Array.listArray (0, b) l++pteraTHLookupTable8 :: Int -> Prim.Addr# -> Int -> Int -> Int+pteraTHLookupTable8 offset table# s c = do+ let !(Types.I# i#) = s `Bits.shiftL` offset + c+ ST.runST do+ ST.ST \s0# -> do+ let !(# s1#, r# #) = Prim.readWord8OffAddr# table# i# s0#+ case r# of+ 255## -> (# s1#, -1 #)+ _ -> (# s1#, Types.I# do Prim.word2Int# r# #)++pteraTHLookupTable16 :: Int -> Prim.Addr# -> Int -> Int -> Int+pteraTHLookupTable16 offset table# s c = do+ let !(Types.I# i#) = s `Bits.shiftL` offset + c+ ST.runST do+ ST.ST \s0# -> do+ let !(# s1#, r# #) = Prim.readWord16OffAddr# table# i# s0#+ case r# of+ 65535## -> (# s1#, -1 #)+ _ -> (# s1#, Types.I# do Prim.word2Int# r# #)++pteraTHLookupTable32 :: Int -> Prim.Addr# -> Int -> Int -> Int+pteraTHLookupTable32 offset table# s c = do+ let !(Types.I# i#) = s `Bits.shiftL` offset + c+ ST.runST do+ ST.ST \s0# -> do+ let !(# s1#, r# #) = Prim.readInt32OffAddr# table# i# s0#+ (# s1#, Types.I# r# #)++pteraTHUnsafeExtractReduceArgument :: ReduceArgument -> a+pteraTHUnsafeExtractReduceArgument (ReduceArgument x) = Unsafe.unsafeCoerce x++pteraTHUnsafeRunner :: RunnerParser ctx elem () -> Parser ctx rules elem initials+pteraTHUnsafeRunner p = Runner.UnsafeRunnerM p++pteraTHAction :: ([ReduceArgument] -> ActionTask ctx b) -> ActionM ctx+pteraTHAction f = ActionM do \args -> ReduceArgument <$> f args++pteraTHActionTaskPure :: a -> ActionTask ctx a+pteraTHActionTaskPure x = pure x
+ src/Language/Parser/Ptera/TH/Pipeline/Grammar2ParserDec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE UndecidableInstances #-}++module Language.Parser.Ptera.TH.Pipeline.Grammar2ParserDec where++import Language.Parser.Ptera.Prelude++import qualified Language.Haskell.TH as TH+import qualified Language.Parser.Ptera.Pipeline.SafeGrammar2SRB as SafeGrammar2SRB+import qualified Language.Parser.Ptera.TH.Pipeline.SRB2ParserDec as SRB2ParserDec+import qualified Language.Parser.Ptera.TH.Syntax as Syntax+import qualified Type.Membership as Membership++grammar2ParserDec+ :: forall initials rules tokens ctx elem+ . Syntax.GrammarToken tokens elem+ => Membership.Generate (Syntax.TokensTag tokens)+ => PipelineParam+ -> Syntax.GrammarM ctx rules tokens elem initials+ -> TH.Q [TH.Dec]+grammar2ParserDec param g = do+ srb <- case SafeGrammar2SRB.safeGrammar2Srb g of+ Right x -> pure x+ Left vs -> do+ let errorMsg = "Failed to generate parser. "+ <> "Detect left recursions at " <> show vs <> "."+ fail errorMsg+ SRB2ParserDec.srb2QParser+ do SRB2ParserDec.PipelineParam+ {+ startsTy = startsTy param,+ rulesTy = rulesTy param,+ tokensTy = tokensTy param,+ tokenTy = tokenTy param,+ customCtxTy = customCtxTy param,+ tokenBounds =+ ( 0+ , Membership.hcount do Proxy @(Syntax.TokensTag tokens)+ )+ }+ do srb++data PipelineParam = PipelineParam+ {+ startsTy :: TH.Q TH.Type,+ rulesTy :: TH.Q TH.Type,+ tokensTy :: TH.Q TH.Type,+ tokenTy :: TH.Q TH.Type,+ customCtxTy :: TH.Q TH.Type+ }
+ src/Language/Parser/Ptera/TH/Pipeline/SRB2ParserDec.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Parser.Ptera.TH.Pipeline.SRB2ParserDec where++import Language.Parser.Ptera.Prelude++import qualified Data.Bits as Bits+import qualified Data.EnumMap.Strict as EnumMap+import qualified Data.HashMap.Strict as HashMap+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray+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.Syntax.Grammar as Grammar+import qualified Language.Parser.Ptera.TH.Data.Bits.MaxBit as Bits+import Language.Parser.Ptera.TH.ParserLib+import qualified Language.Parser.Ptera.TH.Syntax as Syntax++type SemanticAction ctx = Grammar.Action (Syntax.SemActM ctx)++data PipelineParam = PipelineParam+ {+ startsTy :: TH.Q TH.Type,+ rulesTy :: TH.Q TH.Type,+ tokensTy :: TH.Q TH.Type,+ tokenTy :: TH.Q TH.Type,+ customCtxTy :: TH.Q TH.Type,+ tokenBounds :: (Int, Int)+ }++srb2QParser+ :: PipelineParam+ -> SRB.T Int StringLit (Maybe altDoc) (SemanticAction ctx)+ -> TH.Q [TH.Dec]+srb2QParser param srb = do+ let runnerFnName = TH.mkName "pteraTHRunner"+ let parserInitialFnName = TH.mkName "pteraTHParserInitial"+ let parserGetTokenNumFnName = TH.mkName "pteraTHParserGetTokenNum"+ let parserTransFnName = TH.mkName "pteraTHParserTrans"+ let parserAltKindFnName = TH.mkName "pteraTHParserAltKind"+ let parserStateHelpFnName = TH.mkName "pteraTHParserStateHelp"+ let parserAltHelpFnName = TH.mkName "pteraTHParserAltHelp"+ let parserActionFnName = TH.mkName "pteraTHParserAction"++ sequence+ [ TH.SigD parserInitialFnName <$>+ [t|Int -> Maybe Int|]+ , outputParserInitialFn parserInitialFnName do SRB.initials srb++ , TH.SigD parserGetTokenNumFnName <$>+ [t|$(tokenTy param) -> Int|]+ , TH.ValD do TH.VarP parserGetTokenNumFnName+ <$> fmap TH.NormalB [e|\t ->+ pteraTHTokenToTerminal (Proxy :: Proxy $(tokensTy param)) t+ |]+ <*> pure []++ , TH.SigD parserTransFnName <$>+ [t|Int -> Int -> Trans|]+ , outputParserTransFn parserTransFnName+ do tokenBounds param+ do SRB.states srb++ , TH.SigD parserAltKindFnName <$>+ [t|Int -> AltKind|]+ , outputParserAltKindFn parserAltKindFnName do SRB.alts srb++ , TH.SigD parserStateHelpFnName <$>+ [t|Int -> [(Int, Int)]|]+ , outputParserStateHelpFn parserStateHelpFnName+ do SRB.states srb++ , TH.SigD parserAltHelpFnName <$>+ [t|Int -> (StringLit, Maybe ())|]+ , outputParserAltHelpFn parserAltHelpFnName+ do SRB.alts srb+ do SRB.vars srb++ , TH.SigD parserActionFnName <$>+ [t|Int -> ActionM $(customCtxTy param)|]+ , outputParserActionFn parserActionFnName do SRB.alts srb++ , TH.SigD runnerFnName <$>+ [t|Parser+ $(customCtxTy param)+ $(rulesTy param)+ $(tokenTy param)+ $(startsTy param)+ |]+ , outputRunnerFn runnerFnName+ parserInitialFnName+ parserGetTokenNumFnName+ parserTransFnName+ parserAltKindFnName+ parserStateHelpFnName+ parserAltHelpFnName+ parserActionFnName+ ]++outputParserInitialFn :: TH.Name -> EnumMap.EnumMap Int SRB.StateNum -> TH.Q TH.Dec+outputParserInitialFn parserInitialFnName initials =+ TH.ValD do TH.VarP parserInitialFnName+ <$> fmap TH.NormalB [e|\s ->+ if s <= $(TH.lift ub)+ then pteraTHArrayIndex table s+ else Nothing+ |]+ <*> [d|+ table = pteraTHArrayFromList $(TH.lift ub) $(TH.ListE <$> qes)+ |]+ where+ ub = if EnumMap.null initials+ then -1+ else let (i, _) = EnumMap.findMax initials in i++ qes = traverse+ do \i -> case EnumMap.lookup i initials of+ Nothing ->+ [e|Nothing|]+ Just (SRB.StateNum s) ->+ [e|Just $(TH.lift s)|]+ [0..ub]++outputParserTransFn :: TH.Name+ -> (Int, Int)+ -> AlignableArray.T SRB.StateNum SRB.MState+ -> TH.Q TH.Dec+outputParserTransFn parserTransFnName (minTokBound, maxTokBound) states = if+ | tokBitSize + stateBitSize > 29 ->+ error "exceed over bit size limited"+ | otherwise ->+ TH.ValD do TH.VarP parserTransFnName+ <$> fmap TH.NormalB [e|\s0 c0 ->+ let c1 = if c0 >= 0+ then c0 - $(TH.lift minTokBound)+ else $(TH.lift maxTokBound) + 1+ s1 = $(stateTableLookupFn)+ $(TH.lift tokBitSize)+ stateTable+ s0 c1+ opsNum = $(opsNumTableLookupFn)+ $(TH.lift tokBitSize)+ opsNumTable+ s0 c1+ ops = pteraTHArrayIndex opsArr opsNum+ in Trans s1 ops+ |]+ <*> [d|+ stateTable = $(tableAddrExp stateByteSize+ do reverse do outTransReprStates outTrans)+ opsNumTable = $(tableAddrExp opsNumByteSize+ do reverse do outTransReprOpsNums outTrans)+ opsArr = pteraTHArrayFromList $(TH.lift opsNumMax)+ $(TH.ListE <$>+ do sequence do reverse do outTransReprTransOps outTrans)+ |]+ where+ tokBitSize = Bits.maxBitSize+ -- input tokens + special tokens (-1)+ do maxTokBound - minTokBound + 1+ tokMax = (1 `Bits.shiftL` tokBitSize) - 1+ stateBitSize = Bits.maxBitSize do length states - 1+ stateByteSize = if+ | stateBitSize <= 8 -> 1+ | stateBitSize <= 16 -> 2+ | otherwise -> 4+ stateTableLookupFn = if+ | stateBitSize <= 8 -> [e|pteraTHLookupTable8|]+ | stateBitSize <= 16 -> [e|pteraTHLookupTable16|]+ | otherwise -> [e|pteraTHLookupTable32|]++ outTrans = genOutTransRepr tokMax states+ opsNumMax = outTransReprNextOpsNum outTrans - 1+ opsNumBitSize = Bits.maxBitSize opsNumMax+ opsNumByteSize = if+ | opsNumBitSize <= 8 -> 1+ | opsNumBitSize <= 16 -> 2+ | otherwise -> 4+ opsNumTableLookupFn = if+ | opsNumBitSize <= 8 -> [e|pteraTHLookupTable8|]+ | opsNumBitSize <= 16 -> [e|pteraTHLookupTable16|]+ | otherwise -> [e|pteraTHLookupTable32|]++genOutTransRepr :: Int -> AlignableArray.T SRB.StateNum SRB.MState -> OutTransRepr+genOutTransRepr tokMax states = foldl'+ do \acc0 srbState -> do+ let srbTrans = SRB.stateTrans srbState+ foldl'+ do \acc1 i -> do+ let (toSn, opsRepr) = case SymbolicIntMap.lookup i srbTrans of+ Just (SRB.TransWithOps ops (SRB.StateNum x)) -> do+ (x, OutTransWithOpsRepr ops)+ Just (SRB.TransReduce alt) ->+ (-1, OutTransReduce alt)+ Nothing ->+ (-1, OutTransWithOpsRepr [])+ let opsMap0 = outTransReprOpsMap acc1+ let nextOpsNum0 = outTransReprNextOpsNum acc1+ let transOps0 = outTransReprTransOps acc1+ let (opsNum, opsMap1, nextOpsNum1, transOps1) =+ case HashMap.lookup opsRepr opsMap0 of+ Just x ->+ ( x+ , opsMap0+ , nextOpsNum0+ , transOps0+ )+ Nothing ->+ ( nextOpsNum0+ , HashMap.insert opsRepr nextOpsNum0 opsMap0+ , nextOpsNum0 + 1+ , toTransOpsExp opsRepr:transOps0+ )+ OutTransRepr+ { outTransReprStates = toSn:outTransReprStates acc1+ , outTransReprOpsNums = opsNum:outTransReprOpsNums acc1+ , outTransReprTransOps = transOps1+ , outTransReprNextOpsNum = nextOpsNum1+ , outTransReprOpsMap = opsMap1+ }+ do acc0+ do [0..tokMax]+ do OutTransRepr+ {+ outTransReprStates = [],+ outTransReprOpsNums = [],+ outTransReprTransOps = [],+ outTransReprNextOpsNum = 0,+ outTransReprOpsMap = HashMap.empty+ }+ do toList states++tableAddrExp :: Int -> [Int] -> TH.Q TH.Exp+tableAddrExp unitSize ns = pure+ do TH.LitE+ do TH.StringPrimL+ do concatMap+ do \sn -> addrCodeUnitsLE unitSize+ do fromEnum sn+ do ns++-- | Should correspond @pteraTHLookupTable*@+addrCodeUnitsLE :: Int -> Int -> [Word8]+addrCodeUnitsLE unitSize n+ | n >= 0 = take unitSize+ do map+ do \m -> fromInteger do toInteger do mod8bit m+ do iterate (`Bits.shiftR` 8) n+ | n == -1 = replicate unitSize 0xFF+ | otherwise = error "unsupported"+ where+ mod8bit = case Bits.bitSizeMaybe n of+ Nothing -> \x -> x Bits..&. 0xFF+ Just bs+ | bs <= 8 -> \x -> x+ | otherwise -> \x -> x Bits..&. 0xFF++toTransOpsExp :: OutTransOpsRepr -> TH.Q TH.Exp+toTransOpsExp = \case+ OutTransWithOpsRepr ops ->+ TH.ListE <$> traverse toTransOpExp ops+ OutTransReduce (LAPEG.AltNum alt) ->+ [e|[TransOpReduce $(TH.lift alt)]|]++toTransOpExp :: SRB.TransOp -> TH.Q TH.Exp+toTransOpExp = \case+ SRB.TransOpEnter (LAPEG.VarNum v) needBack msn -> do+ let sn = case msn of+ Nothing ->+ -1+ Just (SRB.StateNum x) ->+ x+ [e|TransOpEnter $(TH.lift v) $(TH.lift needBack) $(TH.lift sn)|]+ SRB.TransOpPushBackpoint (SRB.StateNum s) ->+ [e|TransOpPushBackpoint $(TH.lift s)|]+ SRB.TransOpHandleNot (LAPEG.AltNum alt) ->+ [e|TransOpHandleNot $(TH.lift alt)|]+ SRB.TransOpShift ->+ [e|TransOpShift|]++data OutTransRepr = OutTransRepr+ {+ outTransReprStates :: [Int],+ outTransReprOpsNums :: [Int],+ outTransReprTransOps :: [TH.Q TH.Exp],+ outTransReprNextOpsNum :: Int,+ outTransReprOpsMap :: HashMap.HashMap OutTransOpsRepr Int+ }++data OutTransOpsRepr+ = OutTransWithOpsRepr [SRB.TransOp]+ | OutTransReduce LAPEG.AltNum+ deriving (Eq, Show, Generic)++instance Hashable OutTransOpsRepr++outputParserAltKindFn+ :: TH.Name -> AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a)+ -> TH.Q TH.Dec+outputParserAltKindFn parserAltKindFnName alts = TH.ValD+ do TH.VarP parserAltKindFnName+ <$> fmap TH.NormalB [e|+ let arr = pteraTHArrayFromList $(TH.lift do length alts - 1)+ $(TH.ListE <$> traverse altKindExp do toList alts)+ in \i -> pteraTHArrayIndex arr i+ |]+ <*> pure []+ where+ altKindExp alt = case LAPEG.altKind alt of+ AltSeq -> [e|AltSeq|]+ AltAnd -> [e|AltAnd|]+ AltNot -> [e|AltNot|]++outputParserStateHelpFn+ :: TH.Name+ -> AlignableArray.T SRB.StateNum SRB.MState+ -> TH.Q TH.Dec+outputParserStateHelpFn fnName states = TH.ValD+ do TH.VarP fnName+ <$> fmap TH.NormalB [e|+ let arr = pteraTHArrayFromList $(TH.lift do length states - 1)+ $(TH.ListE <$> traverse stateHelpExp do toList states)+ in \i -> pteraTHArrayIndex arr i+ |]+ <*> pure []+ where+ stateHelpExp st =+ let altItems = SRB.stateAltItems st+ in TH.ListE <$> forM altItems \altItem -> do+ let altNum :: Int = coerce do SRB.altItemAltNum altItem+ pos :: Int = coerce do SRB.altItemCurPos altItem+ [e|($(TH.lift altNum), $(TH.lift pos))|]++outputParserAltHelpFn+ :: TH.Name+ -> AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a)+ -> AlignableArray.T LAPEG.VarNum (PEG.Var StringLit)+ -> TH.Q TH.Dec+outputParserAltHelpFn parserAltHelpFnName alts vars = TH.ValD+ do TH.VarP parserAltHelpFnName+ <$> fmap TH.NormalB [e|+ let arr = pteraTHArrayFromList $(TH.lift do length alts - 1)+ $(TH.ListE <$> traverse altHelpExp do toList alts)+ in \i -> pteraTHArrayIndex arr i+ |]+ <*> pure []+ where+ altHelpExp alt =+ let v = AlignableArray.forceIndex vars do LAPEG.altVar alt+ in [e|($(TH.lift do PEG.varHelp v), Nothing)|]++outputParserActionFn+ :: TH.Name+ -> AlignableArray.T LAPEG.AltNum (LAPEG.Alt altHelp (SemanticAction ctx))+ -> TH.Q TH.Dec+outputParserActionFn parserActionFnName alts = TH.ValD+ do TH.VarP parserActionFnName+ <$> fmap TH.NormalB [e|+ let arr = pteraTHArrayFromList $(TH.lift do length alts - 1)+ $(pure do+ TH.ListE+ [ TH.VarE do altActionForAltFnName n+ | (n, _) <- AlignableArray.assocs alts+ ]+ )+ in \i -> pteraTHArrayIndex arr i+ |]+ <*> traverse+ do \(n, alt) -> TH.ValD+ do TH.VarP do altActionForAltFnName n+ <$> do TH.NormalB <$> altActionExp alt+ <*> pure []+ do AlignableArray.assocs alts+ where+ altActionForAltFnName (LAPEG.AltNum n) = TH.mkName+ do "pteraTHParserActionForAlt" ++ show n++ altActionExp alt = case LAPEG.altAction alt of+ Grammar.Action act -> [e|+ pteraTHAction $(Syntax.unsafeSemanticAction act)+ |]++outputRunnerFn+ :: TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name+ -> TH.Q TH.Dec+outputRunnerFn runnerFnName = \+ parserInitialFnName+ parserGetTokenNumFnName+ parserTransFnName+ parserAltKindFnName+ parserStateHelpFnName+ parserAltHelpFnName+ parserActionFnName+ -> TH.ValD do TH.VarP runnerFnName+ <$> fmap TH.NormalB [e|pteraTHUnsafeRunner parser|]+ <*> [d|+ parser = RunnerParser+ $(pure do TH.VarE parserInitialFnName)+ $(pure do TH.VarE parserGetTokenNumFnName)+ $(pure do TH.VarE parserTransFnName)+ $(pure do TH.VarE parserAltKindFnName)+ $(pure do TH.VarE parserStateHelpFnName)+ $(pure do TH.VarE parserAltHelpFnName)+ $(pure do TH.VarE parserActionFnName)+ |]
+ src/Language/Parser/Ptera/TH/Syntax.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Parser.Ptera.TH.Syntax (+ T,++ HasField (..),+ SafeGrammar.HasRuleExprField (..),+ SafeGrammar.TokensTag,+ SafeGrammar.RulesTag,+ SafeGrammar.RuleExprType,++ GrammarM,+ SafeGrammar.MemberInitials (..),+ SafeGrammar.Rules (..),+ SafeGrammar.GrammarToken (..),+ RuleExprM,+ AltM,+ SafeGrammar.Expr,+ SemActM (..),+ semActM,+ HFList.HFList (..),+ HFList.DictF (..),+ HTExpList,+ pattern HNil,+ pattern (:*),+ TExpQ (..),+ Syntax.ActionTask (..),+ Syntax.ActionTaskResult (..),+ Syntax.getAction,+ Syntax.modifyAction,+ Syntax.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.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import qualified Language.Parser.Ptera.Syntax as Syntax+import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar+import Language.Parser.Ptera.TH.ParserLib+import qualified Language.Parser.Ptera.Data.HFList as HFList+++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 -> (HTExpList us -> TH.Q (TH.TExp a))+ -> AltM ctx rules tokens elem a+e@(SafeGrammar.UnsafeExpr ue) <:> act = e SafeGrammar.<:> semAct act ue++infixl 4 <:>++eps :: (HTExpList '[] -> TH.Q (TH.TExp a)) -> AltM ctx rules tokens elem a+eps act = SafeGrammar.eps do semAct act HFList.HFNil++(<::>)+ :: SafeGrammar.Expr rules tokens elem us+ -> (HTExpList us -> TH.Q (TH.TExp (ActionTask ctx a)))+ -> AltM ctx rules tokens elem a+e@(SafeGrammar.UnsafeExpr ue) <::> act = e SafeGrammar.<:> semActM act ue++infixl 4 <::>++epsM+ :: (HTExpList '[] -> TH.Q (TH.TExp (ActionTask ctx a)))+ -> AltM ctx rules tokens elem a+epsM act = SafeGrammar.eps do semActM act HFList.HFNil+++type HTExpList = HFList.T TExpQ++newtype TExpQ a = TExpQ+ { unTExpQ :: TH.Q (TH.TExp a)+ }++pattern HNil :: HTExpList '[]+pattern HNil = HFList.HFNil++pattern (:*) :: TH.Q (TH.TExp u) -> HTExpList us -> HTExpList (u ': us)+pattern e :* es = HFList.HFCons (TExpQ e) es++infixr 6 :*+++type SemActM :: Type -> [Type] -> Type -> Type+newtype SemActM ctx us a = UnsafeSemActM+ { unsafeSemanticAction :: TH.Q TH.Exp+ }++type SemAct = SemActM ()++semActM+ :: (HTExpList us -> TH.Q (TH.TExp (Syntax.ActionTask ctx a)))+ -> HFList.T f us -> SemActM ctx us a+semActM f xs0 = UnsafeSemActM go where+ go = do+ (ns, args) <- actArgs xs0+ l <- TH.newName "pteraTHSemActArgs"+ let lp = pure do TH.VarP l+ let le = pure do TH.VarE l+ let lp0 = pure do TH.ListP [TH.VarP n | n <- ns]+ [e|\ $(lp) -> case $(le) of+ $(lp0) ->+ $(TH.unType <$> f args)+ _ ->+ error "unreachable: unexpected arguments"+ |]++ actArgs :: HFList.T f us -> TH.Q ([TH.Name], HTExpList us)+ actArgs = \case+ HFList.HFNil ->+ pure ([], HNil)+ HFList.HFCons _ xs -> do+ n <- TH.newName "pteraTHSemActArg"+ let ne = TH.unsafeTExpCoerce do pure do TH.VarE n+ let arg = [||pteraTHUnsafeExtractReduceArgument $$(ne)||]+ (ns, args) <- actArgs xs+ pure (n:ns, arg :* args)++semAct+ :: (HTExpList us -> TH.Q (TH.TExp a))+ -> HFList.T f us -> SemActM ctx us a+semAct f = semActM do \us -> [||pteraTHActionTaskPure $$(f us)||]
+ src/Language/Parser/Ptera/TH/Util.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Parser.Ptera.TH.Util (+ genGrammarToken,+ GenRulesTypes (..),+ genRules,+ genParsePoints,+ module Language.Parser.Ptera.Data.HEnum,+ unsafeMembership,+) where++import Language.Parser.Ptera.Prelude++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import Language.Parser.Ptera.Data.HEnum (HEnum (..))+import Language.Parser.Ptera.TH.Syntax+import Prelude (String)+import qualified Type.Membership as Membership+import qualified Unsafe.Coerce as Unsafe++genGrammarToken :: TH.Name -> TH.Q TH.Type -> [(String, TH.Q TH.Pat)] -> TH.Q [TH.Dec]+genGrammarToken tyName tokenTy tokens = do+ grammarTokenInstD <- grammarTokenInstDQ+ tokensTagInstD <- tokensTagInstDQ+ tokensMemberInstDs <- tokensMemberInstDsQ+ pure do [tokensTyD, grammarTokenInstD, tokensTagInstD] ++ tokensMemberInstDs+ where+ tokensTyD = TH.DataD [] tyName [] Nothing [] []++ grammarTokenInstDQ = TH.InstanceD Nothing []+ <$> [t|GrammarToken $(pure do TH.ConT tyName) $(tokenTy)|]+ <*> sequence+ [ TH.FunD+ do TH.mkName "tokenToTerminal"+ <$> sequence [tokenToTerminalClause]+ ]++ tokensTagInstDQ = TH.TySynInstD+ <$> do+ TH.TySynEqn Nothing+ <$> [t|TokensTag $(tokensTy)|]+ <*> foldr+ do \(tokenName, _) ty -> do+ let tokenLitTy = TH.LitT do TH.StrTyLit tokenName+ [t|$(pure tokenLitTy) ': $(ty)|]+ do [t|'[]|]+ do tokens++ tokensMemberInstDsQ = buildTokensMemberInstDsQ+ do 0 :: Int+ do []+ do tokens++ tokenToTerminalClause = do+ paramTokenName <- TH.newName "token"+ TH.Clause+ <$> sequence [[p|Proxy|], pure do TH.VarP paramTokenName]+ <*> do TH.NormalB <$> TH.CaseE+ do TH.VarE paramTokenName+ <$> buildTokenToTerminalMatchesQ+ do 0 :: Int+ do []+ do tokens+ <*> pure []++ buildTokensMemberInstDsQ n ds = \case+ [] ->+ pure ds+ (tokenName, _):ts -> do+ let tokenLitTy = TH.LitT do TH.StrTyLit tokenName+ tokenDs <- [d|+ instance TokensMember $(tokensTy) $(pure tokenLitTy) where+ tokensMembership _ = unsafeMembership $(TH.lift n)+ |]+ buildTokensMemberInstDsQ+ do n + 1+ do tokenDs ++ ds+ do ts++ buildTokenToTerminalMatchesQ n ms = \case+ [] ->+ pure ms+ (_, tokenPat):ts -> do+ m <- TH.Match+ <$> tokenPat+ <*> do TH.NormalB <$>+ [e|UnsafeHEnum $(TH.lift n)|]+ <*> pure []+ buildTokenToTerminalMatchesQ+ do n + 1+ do m:ms+ do ts++ tokensTy = pure do TH.ConT tyName++data GenRulesTypes = GenRulesTypes+ { genRulesCtxTy :: TH.Q TH.Type+ , genRulesTokensTy :: TH.Q TH.Type+ , genRulesTokenTy :: TH.Q TH.Type+ }++genRules :: TH.Name -> GenRulesTypes -> [(TH.Name, String, TH.Q TH.Type)] -> TH.Q [TH.Dec]+genRules rulesTyName genRulesTypes ruleDefs+ = (:) <$> rulesTyD <*>+ do (:) <$> rulesTagInstD <*>+ do (:) <$> ruleExprTypeTyD <*>+ do (++) <$> rulesInstD <*> hasFieldDs+ where+ rulesTyD = TH.DataD [] rulesTyName [] Nothing+ <$> sequence+ [ TH.RecC rulesTyName+ <$> buildRuleFields [] ruleDefs+ ]+ <*> pure []++ rulesTagInstD = TH.TySynInstD+ <$> do+ TH.TySynEqn Nothing+ <$> [t|RulesTag $(rulesTy)|]+ <*> buildNonTerminalSymList [t|'[]|] ruleDefs++ rulesInstD =+ [d|+ instance Rules $(rulesTy) where+ generateRules =+ $(foldl'+ do \l _ -> [|HFCons DictF $(l)|]+ do [|HFNil|]+ ruleDefs+ )+ |]++ ruleExprTypeTyD = TH.TySynInstD+ <$> do+ TH.TySynEqn Nothing+ <$> [t|RuleExprType $(rulesTy)|]+ <*> ruleExprTy++ hasFieldDs = buildHasFieldInstances [] ruleDefs++ buildRuleFields acc = \case+ [] ->+ pure acc+ (fieldName, _, ty):rs -> do+ fieldTy <- [t|$(ruleExprTy) $(ty)|]+ buildRuleFields+ do (fieldName, fieldBang, fieldTy):acc+ do rs++ buildNonTerminalSymList acc = \case+ [] ->+ acc+ (_, name, _):rs -> do+ let nameTy = TH.LitT do TH.StrTyLit name+ buildNonTerminalSymList+ [t|$(pure nameTy) ': $(acc)|] rs++ buildHasFieldInstances acc = \case+ [] ->+ pure acc+ (fieldName, name, ty):rs -> do+ let nameTy = pure do TH.LitT do TH.StrTyLit name+ insts <-+ [d|+ instance HasField $(nameTy) $(rulesTy) ($(ruleExprTy) $(ty)) where+ getField x = $(pure do TH.VarE fieldName) x+ instance HasRuleExprField $(rulesTy) $(nameTy) where+ type RuleExprReturnType $(rulesTy) $(nameTy) = $(ty)+ |]+ buildHasFieldInstances+ do insts ++ acc+ do rs++ fieldBang = TH.Bang+ TH.NoSourceUnpackedness+ TH.SourceStrict++ rulesTy = pure do TH.ConT rulesTyName++ ruleExprTy =+ [t|RuleExprM+ $(genRulesCtxTy genRulesTypes)+ $(rulesTy)+ $(genRulesTokensTy genRulesTypes)+ $(genRulesTokenTy genRulesTypes)+ |]++genParsePoints :: TH.Name -> TH.Name -> [String] -> TH.Q [TH.Dec]+genParsePoints tyName rulesTyName initials = (:) <$> parsePointsTyD <*> memberInitialsInstD where+ parsePointsTyD = TH.TySynD tyName [] <$> buildParsePointsSymList initials++ memberInitialsInstD =+ [d|+ instance MemberInitials $(rulesTy) $(parsePointsTy) where+ memberInitials =+ $(foldl'+ do \l _ -> [|HFCons DictF $(l)|]+ do [|HFNil|]+ do initials+ )+ |]++ buildParsePointsSymList = \case+ [] ->+ [t|'[]|]+ n:ns -> do+ let nameTy = TH.LitT do TH.StrTyLit n+ [t|$(pure nameTy) ': $(buildParsePointsSymList ns)|]++ parsePointsTy = pure do TH.ConT tyName++ rulesTy = pure do TH.ConT rulesTyName++unsafeMembership :: Int -> Membership.Membership xs x+unsafeMembership = Unsafe.unsafeCoerce
+ 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 #-}