diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,5 @@ +Apache-2.0 OR MPL-2.0 + +--- + +See https://github.com/mizunashi-mana/ptera/blob/master/LICENSE diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# Ptera Core: A Generator for Parsers + +[![Hackage](https://img.shields.io/hackage/v/ptera-core.svg)](https://hackage.haskell.org/package/ptera-core) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctest" diff --git a/ptera-core.cabal b/ptera-core.cabal new file mode 100644 --- /dev/null +++ b/ptera-core.cabal @@ -0,0 +1,177 @@ +cabal-version: 3.0 +build-type: Custom + +name: ptera-core +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 + 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 + transformers >= 0.5.0 && < 0.6, + containers >= 0.6.0 && < 0.7, + enummapset-th >= 0.6.0 && < 0.7, + membership >= 0.0.1 && < 0.1, + unordered-containers >= 0.2.0 && < 0.3, + hashable >= 1.1 && < 1.4, + array >= 0.5.4 && < 0.6, + + autogen-modules: + Paths_ptera_core + other-modules: + Paths_ptera_core + +custom-setup + setup-depends: + base, + Cabal, + cabal-doctest, + +library + import: + general, + hs-source-dirs: + src + exposed-modules: + Language.Parser.Ptera.Prelude + Language.Parser.Ptera.Data.Alignable + Language.Parser.Ptera.Data.Alignable.Array + Language.Parser.Ptera.Data.Alignable.Map + Language.Parser.Ptera.Data.Alignable.Set + Language.Parser.Ptera.Data.Symbolic.IntSet + Language.Parser.Ptera.Data.Symbolic.IntMap + Language.Parser.Ptera.Data.IntMap.GreaterRestriction + Language.Parser.Ptera.Data.HFList + + Language.Parser.Ptera.Syntax.Grammar + Language.Parser.Ptera.Machine.PEG + Language.Parser.Ptera.Machine.PEG.Builder + Language.Parser.Ptera.Machine.LAPEG + Language.Parser.Ptera.Machine.LAPEG.Builder + Language.Parser.Ptera.Machine.SRB + Language.Parser.Ptera.Machine.SRB.Builder + Language.Parser.Ptera.Pipeline.Grammar2PEG + Language.Parser.Ptera.Pipeline.PEG2LAPEG + Language.Parser.Ptera.Pipeline.LAPEG2SRB + other-modules: + Language.Parser.Ptera.Prelude.Core + Language.Parser.Ptera.Prelude.Alias + +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-core, + + hspec, + QuickCheck, diff --git a/src/Language/Parser/Ptera/Data/Alignable.hs b/src/Language/Parser/Ptera/Data/Alignable.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/Alignable.hs @@ -0,0 +1,28 @@ +module Language.Parser.Ptera.Data.Alignable ( + T, + Alignable, + initialAlign, + nextAlign, + numIncrements, + Inst (..), +) where + +import Language.Parser.Ptera.Prelude + + +type T = Alignable + +class Coercible Int i => Alignable i + +initialAlign :: Alignable i => i +initialAlign = coerce (0 :: Int) + +nextAlign :: Alignable i => i -> i +nextAlign = coerce (succ :: Int -> Int) + +numIncrements :: Alignable i => i -> Int +numIncrements = coerce + +newtype Inst = Inst Int + +instance Alignable Inst diff --git a/src/Language/Parser/Ptera/Data/Alignable/Array.hs b/src/Language/Parser/Ptera/Data/Alignable/Array.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/Alignable/Array.hs @@ -0,0 +1,38 @@ +module Language.Parser.Ptera.Data.Alignable.Array where + +import Language.Parser.Ptera.Prelude + +import qualified Data.Array as DataArray +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.Alignable.Map as AlignableMap + + +type T = Array + +newtype Array n a = Array (DataArray.Array Int a) + deriving (Eq, Show, Functor, Foldable) + +fromTotalMap :: Alignable.T n => n -> AlignableMap.T n a -> Array n a +fromTotalMap b m = Array + do DataArray.array (0, pred do coerce b) do coerce do AlignableMap.toAscList m + +fromList :: forall n a. Alignable.T n => [a] -> Array n a +fromList xs = Array + do DataArray.listArray (0, length xs - 1) xs + +mapWithIx :: Alignable.T n => (n -> a -> a) -> Array n a -> Array n a +mapWithIx f (Array arr) = Array + do DataArray.listArray + do DataArray.bounds arr + do [ f (coerce i) x | (i, x) <- DataArray.assocs arr ] + +index :: forall n a. Alignable.T n => Array n a -> n -> Maybe a +index arr i = case Alignable.numIncrements i < length arr of + False -> Nothing + True -> Just do forceIndex arr i + +forceIndex :: forall n a. Alignable.T n => Array n a -> n -> a +forceIndex = coerce do (DataArray.!) @Int @a + +assocs :: forall n a. Alignable.T n => Array n a -> [(n, a)] +assocs = coerce do DataArray.assocs @Int @a diff --git a/src/Language/Parser/Ptera/Data/Alignable/Map.hs b/src/Language/Parser/Ptera/Data/Alignable/Map.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/Alignable/Map.hs @@ -0,0 +1,47 @@ +module Language.Parser.Ptera.Data.Alignable.Map ( + T, + Map, + empty, + singleton, + insert, + lookup, + assocs, + toAscList, + restrictGreaterOrEqual, +) where + +import Language.Parser.Ptera.Prelude hiding + (empty, + lookup) + +import qualified Data.IntMap.Strict as IntMap +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.IntMap.GreaterRestriction as GreaterRestriction + + +type T = Map + +newtype Map n a = Map (IntMap.IntMap a) + deriving (Eq, Show, Functor, Foldable, Traversable) + +empty :: Map n a +empty = Map IntMap.empty + +singleton :: forall n a. Alignable.T n => n -> a -> Map n a +singleton = coerce do IntMap.singleton @a + +insert :: forall n a. Alignable.T n => n -> a -> Map n a -> Map n a +insert = coerce do IntMap.insert @a + +lookup :: forall n a. Alignable.T n => n -> Map n a -> Maybe a +lookup = coerce do IntMap.lookup @a + +assocs :: forall n a. Alignable.T n => Map n a -> [(n, a)] +assocs = coerce do IntMap.assocs @a + +toAscList :: forall n a. Alignable.T n => Map n a -> [(n, a)] +toAscList = coerce do IntMap.toAscList @a + +restrictGreaterOrEqual :: forall n a. Alignable.T n => n -> Map n a -> Map n a +restrictGreaterOrEqual n (Map m) = Map do + GreaterRestriction.restrictGreater (coerce n - 1) m diff --git a/src/Language/Parser/Ptera/Data/Alignable/Set.hs b/src/Language/Parser/Ptera/Data/Alignable/Set.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/Alignable/Set.hs @@ -0,0 +1,65 @@ +module Language.Parser.Ptera.Data.Alignable.Set ( + T, + Set, + empty, + singleton, + insert, + delete, + fromList, + toList, + null, + intersection, + union, + difference, + length, + member, +) where + +import Language.Parser.Ptera.Prelude hiding (empty, length, + null, toList) + +import qualified Data.IntSet as IntSet +import qualified Language.Parser.Ptera.Data.Alignable as Alignable + + +type T = Set + +newtype Set n = Set IntSet.IntSet + deriving (Eq, Show) + deriving Semigroup via IntSet.IntSet + +empty :: Set n +empty = coerce IntSet.empty + +singleton :: Alignable.T n => n -> Set n +singleton = coerce IntSet.singleton + +insert :: Alignable.T n => n -> Set n -> Set n +insert = coerce IntSet.insert + +delete :: Alignable.T n => n -> Set n -> Set n +delete = coerce IntSet.delete + +fromList :: Alignable.T n => [n] -> Set n +fromList = coerce IntSet.fromList + +toList :: Alignable.T n => Set n -> [n] +toList = coerce IntSet.toList + +null :: Set n -> Bool +null = coerce IntSet.null + +intersection :: Set n -> Set n -> Set n +intersection = coerce IntSet.intersection + +difference :: Set n -> Set n -> Set n +difference = coerce IntSet.difference + +union :: Set n -> Set n -> Set n +union = coerce IntSet.union + +length :: Set n -> Int +length = coerce IntSet.size + +member :: Alignable.T n => n -> Set n -> Bool +member = coerce IntSet.member diff --git a/src/Language/Parser/Ptera/Data/HFList.hs b/src/Language/Parser/Ptera/Data/HFList.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/HFList.hs @@ -0,0 +1,131 @@ +module Language.Parser.Ptera.Data.HFList ( + T, + HFList (..), + Membership, + + Concat, + hconcat, + + hfoldrWithIndex, + htraverseWithIndex, + hmapWithIndex, + hfoldMWithIndex, + hforMWithIndex, + hfoldlWithIndex, + + DictF (..), +) where + +import Language.Parser.Ptera.Prelude + +import Type.Membership (Membership) +import qualified Unsafe.Coerce as Unsafe + + +type T = HFList + +data HFList :: (k -> Type) -> [k] -> Type where + HFNil :: HFList f '[] + HFCons :: f x -> HFList f xs -> HFList f (x ': xs) + + +type family Concat (xs1 :: [k]) (xs2 :: [k]) :: [k] where + Concat '[] xs2 = + xs2 + Concat (x ': xs1) xs2 = + x ': Concat xs1 xs2 + +hconcat :: HFList f xs1 -> HFList f xs2 -> HFList f (Concat xs1 xs2) +hconcat l1 l2 = case l1 of + HFNil -> + l2 + HFCons x l1' -> + HFCons x do hconcat l1' l2 + +hfoldrWithIndex + :: forall f r xs + . (forall x ys. Membership xs x -> f x -> r ys -> r (x ': ys)) -> r '[] + -> HFList f xs -> r xs +hfoldrWithIndex f z0 = go 0 where + go :: Int -> HFList f ys -> r ys + go m0 = \case + HFNil -> + z0 + HFCons y l -> do + let m1 = m0 + 1 + f + do unsafeMembership m0 + do y + do go m1 l + +htraverseWithIndex + :: forall m f g xs + . Applicative m + => (forall x. Membership xs x -> f x -> m (g x)) + -> HFList f xs -> m (HFList g xs) +htraverseWithIndex f = coerce go0 where + go0 = hfoldrWithIndex go do TraverseHFList do pure HFNil + + go + :: forall x ys. Membership xs x -> f x + -> TraverseHFList m g ys -> TraverseHFList m g (x ': ys) + go m x = \case + TraverseHFList acc0 -> + TraverseHFList do HFCons <$> f m x <*> acc0 + +newtype TraverseHFList m f xs = TraverseHFList (m (HFList f xs)) + +hmapWithIndex + :: (forall x. Membership xs x -> f x -> g x) + -> HFList f xs -> HFList g xs +hmapWithIndex f l = runIdentity + do htraverseWithIndex + do \m x -> Identity do f m x + do l + +hfoldMWithIndex :: forall m r f xs + . Monad m + => r -> (forall x. r -> Membership xs x -> f x -> m r) + -> HFList f xs -> m r +hfoldMWithIndex z0 f = go 0 z0 where + go :: Int -> r -> HFList f ys -> m r + go m1 z1 = \case + HFNil -> + pure z1 + HFCons y l -> do + z2 <- f z1 + do unsafeMembership m1 + do y + let m2 = m1 + 1 + go m2 z2 l + +hforMWithIndex + :: forall m f xs + . Applicative m + => HFList f xs -> (forall x. Membership xs x -> f x -> m ()) -> m () +hforMWithIndex l0 f = go 0 l0 where + go :: Int -> HFList f ys -> m () + go m1 = \case + HFNil -> + pure () + HFCons y l -> const + <$> f + do unsafeMembership m1 + do y + <*> go + do m1 + 1 + l + +hfoldlWithIndex + :: r -> (forall x. r -> Membership xs x -> f x -> r) + -> HFList f xs -> r +hfoldlWithIndex z0 f = coerce + do hfoldMWithIndex z0 \z m x -> Identity do f z m x + + +data DictF :: (k -> Constraint) -> k -> Type where + DictF :: c x => DictF c x + + +unsafeMembership :: Int -> Membership xs x +unsafeMembership = Unsafe.unsafeCoerce diff --git a/src/Language/Parser/Ptera/Data/IntMap/GreaterRestriction.hs b/src/Language/Parser/Ptera/Data/IntMap/GreaterRestriction.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/IntMap/GreaterRestriction.hs @@ -0,0 +1,37 @@ +module Language.Parser.Ptera.Data.IntMap.GreaterRestriction ( + restrictGreater, +) where + +import Language.Parser.Ptera.Prelude + +import Data.IntMap.Internal + + +restrictGreater :: Key -> IntMap a -> IntMap a +restrictGreater k t = case t of + Bin _ m l r | m < 0 -> + if k >= 0 -- handle negative numbers. + then go k l + else l `union` go k r + _ -> + go k t + where + go k' t' = case t' of + Bin p m l r + | nomatch k' p m -> + if k' > p + then Nil + else t' + | zero k' m -> + go k' l `union` r + | otherwise -> + go k' r + Tip ky _ + | k' > ky -> + Nil + | k' < ky -> + t' + | otherwise -> + Nil + Nil -> + Nil diff --git a/src/Language/Parser/Ptera/Data/Symbolic/IntMap.hs b/src/Language/Parser/Ptera/Data/Symbolic/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/Symbolic/IntMap.hs @@ -0,0 +1,372 @@ +module Language.Parser.Ptera.Data.Symbolic.IntMap where + +import Language.Parser.Ptera.Prelude + +import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap.Strict as DataIntMap +import qualified Data.IntSet as DataIntSet +import qualified Language.Parser.Ptera.Data.Symbolic.IntSet as IntSet + + +type T = IntMap + +type Key = Int + +data IntMap a = IntMap + { + intMapStraight :: DataIntMap.IntMap (Maybe a), + intMapNegative :: Maybe a + } + deriving (Show, Functor, Foldable, Traversable) + +empty :: IntMap a +empty = IntMap + { + intMapStraight = DataIntMap.empty, + intMapNegative = Nothing + } + +full :: a -> IntMap a +full v = IntMap + { + intMapStraight = DataIntMap.empty, + intMapNegative = Just v + } + +singleton :: Key -> a -> IntMap a +singleton k v = IntMap + { + intMapStraight = DataIntMap.singleton k do Just v, + intMapNegative = Nothing + } + +normalize :: Eq a => IntMap a -> IntMap a +normalize m = case intMapNegative m of + Nothing -> m + { + intMapStraight = DataIntMap.mapMaybe + do \x -> Just <$> x + do intMapStraight m + } + Just nx -> m + { + intMapStraight = DataIntMap.mapMaybe + do \case + Nothing -> + Just Nothing + Just x | x == nx -> + Nothing + jx@Just{} -> + Just jx + do intMapStraight m + } + +instance Eq a => Eq (IntMap a) where + m1 == m2 = intMapNegative m1 == intMapNegative m2 + && intMapStraight (normalize m1) == intMapStraight (normalize m2) + +insert :: Key -> a -> IntMap a -> IntMap a +insert k v m = m + { + intMapStraight = DataIntMap.insert k + do Just v + do intMapStraight m + } + +insertBulk :: IntSet.T -> a -> IntMap a -> IntMap a +insertBulk ss v m0 = case ss of + IntSet.StraightSet s -> do + let jv = Just v + IntMap + { intMapStraight = foldl' + do \m k -> DataIntMap.insert k jv m + do intMapStraight m0 + do DataIntSet.elems s + , intMapNegative = intMapNegative m0 + } + IntSet.NegativeSet s -> IntMap + { intMapStraight = DataIntMap.restrictKeys + do intMapStraight m0 + do s + , intMapNegative = Just v + } + +delete :: Key -> IntMap a -> IntMap a +delete k m = case intMapNegative m of + Nothing -> m + { + intMapStraight = DataIntMap.delete k do intMapStraight m + } + Just _ -> m + { + intMapStraight = DataIntMap.insert k Nothing do intMapStraight m + } + +update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a +update f k m = case DataIntMap.lookup k do intMapStraight m of + Just mv -> go mv + Nothing -> go do intMapNegative m + where + go = \case + Nothing -> m + Just v -> case f v of + Nothing -> m + jv@Just{} -> m + { + intMapStraight = DataIntMap.insert k jv do intMapStraight m + } + +alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a +alter f k m = case DataIntMap.lookup k do intMapStraight m of + Just mv -> go mv + Nothing -> go do intMapNegative m + where + go = \case + Nothing -> case f Nothing of + Nothing -> m + jv@Just{} -> m + { + intMapStraight = DataIntMap.insert k jv do intMapStraight m + } + jv0@Just{} -> m + { + intMapStraight = DataIntMap.insert k + do f jv0 + do intMapStraight m + } + +alterBulk :: (Maybe a -> Maybe a) -> IntSet.T -> IntMap a -> IntMap a +alterBulk f ks m0 = case ks of + IntSet.StraightSet s -> case intMapNegative m0 of + Nothing -> m0 + { + intMapStraight = foldl' + do \m k -> DataIntMap.alter + do \mmv -> case f do join mmv of + Nothing -> Nothing + jv@Just{} -> Just jv + k m + do intMapStraight m0 + do DataIntSet.elems s + } + njv@Just{} -> m0 + { + intMapStraight = foldl' + do \m k -> DataIntMap.alter + do \case + Nothing -> Just do f njv + Just mv -> Just do f mv + k m + do intMapStraight m0 + do DataIntSet.elems s + } + IntSet.NegativeSet s -> case intMapNegative m0 of + Nothing -> case f Nothing of + Nothing -> m0 + { + intMapStraight = DataIntMap.mapMaybeWithKey + do \k mv0 -> do + _ <- mv0 + if DataIntSet.member k s + then pure mv0 + else Just <$> f mv0 + do intMapStraight m0 + } + jv@Just{} -> IntMap + { intMapStraight = DataIntMap.mapMaybeWithKey + do \k mv0 -> if DataIntSet.member k s + then pure mv0 + else case mv0 of + Nothing -> pure jv + Just{} -> pure do f mv0 + do intMapStraight m0 + , intMapNegative = jv + } + njv0@Just{} -> case f njv0 of + Nothing -> IntMap + { intMapStraight = DataIntMap.mapMaybeWithKey + do \k mv0 -> if DataIntSet.member k s + then Just <$> mv0 + else Just <$> f mv0 + do intMapStraight m0 + , intMapNegative = Nothing + } + njv@Just{} -> IntMap + { intMapStraight = DataIntMap.mapMaybeWithKey + do \k mv0 -> if DataIntSet.member k s + then pure mv0 + else pure do f mv0 + do intMapStraight m0 + , intMapNegative = njv + } + +lookup :: Key -> IntMap a -> Maybe a +lookup k m = case DataIntMap.lookup k do intMapStraight m of + Just mv -> mv + Nothing -> intMapNegative m + +keys :: IntMap a -> IntSet.T +keys m = case intMapNegative m of + Just{} -> IntSet.NegativeSet + do DataIntSet.fromList + [ k + | (k, mv) <- DataIntMap.assocs do intMapStraight m + , case mv of { Nothing -> True; Just{} -> False } + ] + Nothing -> IntSet.StraightSet + do DataIntSet.fromList + [ k + | (k, mv) <- DataIntMap.assocs do intMapStraight m + , case mv of { Nothing -> False; Just{} -> True } + ] + +restrictKeys :: IntMap a -> IntSet.T -> IntMap a +restrictKeys m s = case intMapNegative m of + Nothing -> case s of + IntSet.StraightSet is -> + IntMap + { intMapNegative = Nothing + , intMapStraight = DataIntMap.restrictKeys + do intMapStraight m + do is + } + IntSet.NegativeSet is -> + IntMap + { intMapNegative = Nothing + , intMapStraight = DataIntMap.withoutKeys + do intMapStraight m + do is + } + notMx@Just{} -> case s of + IntSet.StraightSet is -> do + let notM = DataIntMap.fromSet + do \_ -> notMx + do is + IntMap + { intMapNegative = Nothing + , intMapStraight = DataIntMap.unionWith + do \x _ -> x + do intMapStraight m + do notM + } + IntSet.NegativeSet is -> do + let deleteM = DataIntMap.fromSet + do \_ -> Nothing + do is + IntMap + { intMapNegative = notMx + , intMapStraight = DataIntMap.unionWith + do \_ x -> x + do intMapStraight m + do deleteM + } + + + +merge :: (a -> b -> Maybe c) -> (a -> Maybe c) -> (b -> Maybe c) -> IntMap a -> IntMap b -> IntMap c +merge fab fa fb = \sma0 smb0 -> case intMapNegative sma0 of + Nothing -> case intMapNegative smb0 of + Nothing -> goMergeStraight sma0 smb0 + Just nb0 -> case fb nb0 of + Nothing -> goMergeStraight sma0 smb0 + Just nb1 -> goMergeNegative nb1 sma0 smb0 + Just na0 -> case intMapNegative smb0 of + Nothing -> case fa na0 of + Nothing -> goMergeStraight sma0 smb0 + Just na1 -> goMergeNegative na1 sma0 smb0 + Just nb0 -> case fab na0 nb0 of + Nothing -> goMergeStraight sma0 smb0 + Just nab1 -> goMergeNegative nab1 sma0 smb0 + where + goMergeStraight sma0 smb0 = IntMap + { intMapStraight = DataIntMap.mergeWithKey + do \_ mx my -> case mx of + Nothing -> case my of + Nothing -> Nothing + Just y -> Just <$> fb y + Just x -> case my of + Nothing -> Just <$> fa x + Just y -> Just <$> fab x y + do \ma -> case intMapNegative smb0 of + Nothing -> DataIntMap.mapMaybe + do \mx -> fmap Just do mx >>= fa + do ma + Just nb1 -> DataIntMap.mapMaybe + do \mx -> fmap Just do mx >>= \x -> fab x nb1 + do ma + do \mb -> case intMapNegative sma0 of + Nothing -> DataIntMap.mapMaybe + do \my -> fmap Just do my >>= fb + do mb + Just na1 -> DataIntMap.mapMaybe + do \my -> fmap Just do my >>= \y -> fab na1 y + do mb + do intMapStraight sma0 + do intMapStraight smb0 + , intMapNegative = Nothing + } + + goMergeNegative n1 sma0 smb0 = IntMap + { intMapStraight = DataIntMap.mergeWithKey + do \_ mx my -> case mx of + Nothing -> case my of + Nothing -> Just Nothing + Just y -> Just do fb y + Just x -> case my of + Nothing -> Just do fa x + Just y -> Just do fab x y + do \ma -> case intMapNegative smb0 of + Nothing -> fmap + do \mx -> mx >>= fa + do ma + Just nb1 -> fmap + do \mx -> mx >>= \x -> fab x nb1 + do ma + do \mb -> case intMapNegative sma0 of + Nothing -> fmap + do \my -> my >>= fb + do mb + Just na1 -> fmap + do \my -> my >>= \y -> fab na1 y + do mb + do intMapStraight sma0 + do intMapStraight smb0 + , intMapNegative = Just n1 + } + +groupBy :: Eq b => Hashable b => (a -> b) -> IntMap a -> HashMap.HashMap b IntSet.T +groupBy f m0 = case intMapNegative m0 of + Nothing -> foldl' + do \m (k, mv) -> case mv of + Nothing -> + m + Just v -> do + let fv = f v + HashMap.alter + do \case + Just ks -> Just do IntSet.insert k ks + Nothing -> Just do IntSet.singleton k + fv m + do HashMap.empty + do DataIntMap.assocs do intMapStraight m0 + Just nv -> do + let fnv = f nv + let (m1, nks1) = foldl' + do \(m, nks) (k, mv) -> case mv of + Nothing -> + (m, IntSet.delete k nks) + Just v -> do + let fv = f v + if fv == fnv + then (m, nks) + else + ( HashMap.alter + do \case + Just ks -> Just do IntSet.insert k ks + Nothing -> Just do IntSet.singleton k + fv m + , nks + ) + do (HashMap.empty, IntSet.full) + do DataIntMap.assocs do intMapStraight m0 + HashMap.insert fnv nks1 m1 diff --git a/src/Language/Parser/Ptera/Data/Symbolic/IntSet.hs b/src/Language/Parser/Ptera/Data/Symbolic/IntSet.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Data/Symbolic/IntSet.hs @@ -0,0 +1,68 @@ +module Language.Parser.Ptera.Data.Symbolic.IntSet where + +import Language.Parser.Ptera.Prelude hiding (empty) + +import qualified Data.IntSet as DataIntSet + + +type T = IntSet + +type Key = Int + +data IntSet + = StraightSet DataIntSet.IntSet + | NegativeSet DataIntSet.IntSet + deriving (Eq, Show) + +instance Semigroup IntSet where + (<>) = union + +instance Monoid IntSet where + mempty = StraightSet DataIntSet.empty + +full :: IntSet +full = NegativeSet DataIntSet.empty + +singleton :: Key -> IntSet +singleton k = StraightSet do DataIntSet.singleton k + +invert :: IntSet -> IntSet +invert = \case + StraightSet s -> NegativeSet s + NegativeSet s -> StraightSet s + +fromList :: [Key] -> IntSet +fromList ks = StraightSet do DataIntSet.fromList ks + +insert :: Key -> IntSet -> IntSet +insert k = \case + StraightSet s -> StraightSet do DataIntSet.insert k s + NegativeSet s -> NegativeSet do DataIntSet.delete k s + +delete :: Key -> IntSet -> IntSet +delete k = \case + StraightSet s -> StraightSet do DataIntSet.delete k s + NegativeSet s -> NegativeSet do DataIntSet.insert k s + +member :: Key -> IntSet -> Bool +member k = \case + StraightSet s -> DataIntSet.member k s + NegativeSet s -> not do DataIntSet.member k s + +union :: IntSet -> IntSet -> IntSet +union (StraightSet s1) (StraightSet s2) = StraightSet do DataIntSet.union s1 s2 +union (StraightSet s1) (NegativeSet s2) = NegativeSet do DataIntSet.difference s2 s1 +union (NegativeSet s1) (StraightSet s2) = NegativeSet do DataIntSet.difference s1 s2 +union (NegativeSet s1) (NegativeSet s2) = NegativeSet do DataIntSet.intersection s1 s2 + +intersection :: IntSet -> IntSet -> IntSet +intersection (StraightSet s1) (StraightSet s2) = StraightSet do DataIntSet.intersection s1 s2 +intersection (StraightSet s1) (NegativeSet s2) = StraightSet do DataIntSet.difference s1 s2 +intersection (NegativeSet s1) (StraightSet s2) = StraightSet do DataIntSet.difference s2 s1 +intersection (NegativeSet s1) (NegativeSet s2) = NegativeSet do DataIntSet.union s1 s2 + +difference :: IntSet -> IntSet -> IntSet +difference (StraightSet s1) (StraightSet s2) = StraightSet do DataIntSet.difference s1 s2 +difference (StraightSet s1) (NegativeSet s2) = StraightSet do DataIntSet.intersection s1 s2 +difference (NegativeSet s1) (StraightSet s2) = NegativeSet do DataIntSet.union s1 s2 +difference (NegativeSet s1) (NegativeSet s2) = StraightSet do DataIntSet.difference s2 s1 diff --git a/src/Language/Parser/Ptera/Machine/LAPEG.hs b/src/Language/Parser/Ptera/Machine/LAPEG.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Machine/LAPEG.hs @@ -0,0 +1,76 @@ +module Language.Parser.Ptera.Machine.LAPEG where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray +import qualified Language.Parser.Ptera.Data.Symbolic.IntSet as SymbolicIntSet +import qualified Language.Parser.Ptera.Machine.PEG as PEG + + +type T = LAPEG + +data LAPEG start varDoc altDoc a = LAPEG + { vars :: AlignableArray.T VarNum (PEG.Var varDoc) + , rules :: AlignableArray.T VarNum Rule + , alts :: AlignableArray.T AltNum (Alt altDoc a) + , initials :: EnumMap.EnumMap start VarNum + } + deriving (Eq, Show, Functor) + +newtype VarNum = VarNum Int + deriving (Eq, Show) + deriving Hashable via Int + deriving Alignable.T via Alignable.Inst + +newtype AltNum = AltNum Int + deriving (Eq, Show) + deriving Hashable via Int + deriving Alignable.T via Alignable.Inst + +data Rule = Rule + { ruleRange :: HeadRange + , ruleAlts :: [AltNum] + } + deriving (Eq, Show) + +data Alt altDoc a = Alt + { altVar :: VarNum + , altKind :: PEG.AltKind + , altUnitSeqWithLookAHead :: AlignableArray.T Position (HeadRange, Unit) + , altAction :: a + , altHelp :: altDoc + } + deriving (Eq, Show, Functor) + +newtype Position = Position Int + deriving (Eq, Show) + deriving Hashable via Int + deriving Alignable.T via Alignable.Inst + +data HeadRange = HeadRange + { headRangeEpsilon :: Bool + , headRangeConsume :: SymbolicIntSet.T + } + deriving (Eq, Show) + +instance Semigroup HeadRange where + hr1 <> hr2 = HeadRange + { headRangeEpsilon = headRangeEpsilon hr1 || headRangeEpsilon hr2 + , headRangeConsume = headRangeConsume hr1 <> headRangeConsume hr2 + } + +instance Monoid HeadRange where + mempty = HeadRange + { headRangeEpsilon = False + , headRangeConsume = mempty + } + +data Unit + = UnitTerminal Terminal + | UnitNonTerminal VarNum + | UnitNot + deriving (Eq, Show) + +type Terminal = Int diff --git a/src/Language/Parser/Ptera/Machine/LAPEG/Builder.hs b/src/Language/Parser/Ptera/Machine/LAPEG/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Machine/LAPEG/Builder.hs @@ -0,0 +1,87 @@ +module Language.Parser.Ptera.Machine.LAPEG.Builder where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray +import qualified Language.Parser.Ptera.Data.Alignable.Map as AlignableMap +import qualified Language.Parser.Ptera.Machine.LAPEG as LAPEG +import qualified Language.Parser.Ptera.Machine.PEG as PEG + + +type T start varDoc altDoc a = BuilderT start varDoc altDoc a + +type BuilderT start varDoc altDoc a = StateT (Context start varDoc altDoc a) + +data Context start varDoc altDoc a = Context + { ctxInitials :: EnumMap.EnumMap start LAPEG.VarNum + , ctxNextVarNum :: LAPEG.VarNum + , ctxNextAltNum :: LAPEG.AltNum + , ctxVars :: AlignableMap.T LAPEG.VarNum (PEG.Var varDoc) + , ctxRules :: AlignableMap.T LAPEG.VarNum LAPEG.Rule + , ctxAlts :: AlignableMap.T LAPEG.AltNum (LAPEG.Alt altDoc a) + } + deriving (Eq, Show, Functor) + +build :: Monad m + => BuilderT start varDoc altDoc a m () -> m (LAPEG.T start varDoc altDoc a) +build builder = do + finalCtx <- execStateT builder initialCtx + pure do + LAPEG.LAPEG + { initials = ctxInitials finalCtx + , rules = AlignableArray.fromTotalMap + do ctxNextVarNum finalCtx + do ctxRules finalCtx + , vars = AlignableArray.fromTotalMap + do ctxNextVarNum finalCtx + do ctxVars finalCtx + , alts = AlignableArray.fromTotalMap + do ctxNextAltNum finalCtx + do ctxAlts finalCtx + } + where + initialCtx = Context + { ctxInitials = EnumMap.empty + , ctxNextVarNum = Alignable.initialAlign + , ctxNextAltNum = Alignable.initialAlign + , ctxRules = AlignableMap.empty + , ctxVars = AlignableMap.empty + , ctxAlts = AlignableMap.empty + } + +genNewVar :: Monad m + => PEG.Var varDoc -> BuilderT start varDoc altDoc a m LAPEG.VarNum +genNewVar v = do + vn <- ctxNextVarNum <$> get + modify' \ctx -> ctx + { ctxNextVarNum = Alignable.nextAlign vn + , ctxVars = AlignableMap.insert vn v + do ctxVars ctx + } + pure vn + +genNewAlt :: Monad m + => LAPEG.Alt altDoc a -> BuilderT start varDoc altDoc a m LAPEG.AltNum +genNewAlt alt = do + altn <- ctxNextAltNum <$> get + modify' \ctx -> ctx + { ctxNextAltNum = Alignable.nextAlign altn + , ctxAlts = AlignableMap.insert altn alt + do ctxAlts ctx + } + pure altn + +addInitial :: Monad m => Enum start + => start -> LAPEG.VarNum -> BuilderT start varDoc altDoc a m () +addInitial i v = modify' \ctx -> ctx + { ctxInitials = EnumMap.insert i v do ctxInitials ctx + } + +addRule :: Monad m + => LAPEG.VarNum -> LAPEG.Rule -> BuilderT start varDoc altDoc a m () +addRule v e = modify' \ctx -> ctx + { ctxRules = AlignableMap.insert v e + do ctxRules ctx + } diff --git a/src/Language/Parser/Ptera/Machine/PEG.hs b/src/Language/Parser/Ptera/Machine/PEG.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Machine/PEG.hs @@ -0,0 +1,59 @@ +module Language.Parser.Ptera.Machine.PEG where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray + + +type T = PEG + +data PEG start varDoc altDoc a = PEG + { vars :: AlignableArray.T VarNum (Var varDoc) + , rules :: AlignableArray.T VarNum Rule + , alts :: AlignableArray.T AltNum (Alt altDoc a) + , initials :: EnumMap.EnumMap start VarNum + } + deriving (Eq, Show, Functor) + +newtype VarNum = VarNum Int + deriving (Eq, Show) + deriving Hashable via Int + deriving Alignable.T via Alignable.Inst + +newtype AltNum = AltNum Int + deriving (Eq, Show) + deriving Hashable via Int + deriving Alignable.T via Alignable.Inst + +newtype Rule = Rule + { ruleAlts :: [AltNum] + } + deriving (Eq, Show) + +newtype Var varDoc = Var + { varHelp :: varDoc + } + deriving (Eq, Show, Functor) + +data Alt altDoc a = Alt + { altKind :: AltKind + , altUnitSeq :: [Unit] + , altAction :: a + , altHelp :: altDoc + } + deriving (Eq, Show, Functor) + +data AltKind + = AltSeq + | AltNot + | AltAnd + deriving (Eq, Show) + +data Unit + = UnitTerminal Terminal + | UnitNonTerminal VarNum + deriving (Eq, Show) + +type Terminal = Int diff --git a/src/Language/Parser/Ptera/Machine/PEG/Builder.hs b/src/Language/Parser/Ptera/Machine/PEG/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Machine/PEG/Builder.hs @@ -0,0 +1,86 @@ +module Language.Parser.Ptera.Machine.PEG.Builder where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray +import qualified Language.Parser.Ptera.Data.Alignable.Map as AlignableMap +import qualified Language.Parser.Ptera.Machine.PEG as PEG + + +type T start varDoc altDoc a = BuilderT start varDoc altDoc a + +type BuilderT start varDoc altDoc a = StateT (Context start varDoc altDoc a) + +data Context start varDoc altDoc a = Context + { ctxInitials :: EnumMap.EnumMap start PEG.VarNum + , ctxNextVarNum :: PEG.VarNum + , ctxNextAltNum :: PEG.AltNum + , ctxVars :: AlignableMap.T PEG.VarNum (PEG.Var varDoc) + , ctxRules :: AlignableMap.T PEG.VarNum PEG.Rule + , ctxAlts :: AlignableMap.T PEG.AltNum (PEG.Alt altDoc a) + } + deriving (Eq, Show, Functor) + +build :: Monad m + => BuilderT start varDoc altDoc a m () -> m (PEG.T start varDoc altDoc a) +build builder = do + finalCtx <- execStateT builder initialCtx + pure do + PEG.PEG + { initials = ctxInitials finalCtx + , rules = AlignableArray.fromTotalMap + do ctxNextVarNum finalCtx + do ctxRules finalCtx + , vars = AlignableArray.fromTotalMap + do ctxNextVarNum finalCtx + do ctxVars finalCtx + , alts = AlignableArray.fromTotalMap + do ctxNextAltNum finalCtx + do ctxAlts finalCtx + } + where + initialCtx = Context + { ctxInitials = EnumMap.empty + , ctxNextVarNum = Alignable.initialAlign + , ctxNextAltNum = Alignable.initialAlign + , ctxRules = AlignableMap.empty + , ctxVars = AlignableMap.empty + , ctxAlts = AlignableMap.empty + } + +genNewVar :: Monad m + => PEG.Var varDoc -> BuilderT start varDoc altDoc a m PEG.VarNum +genNewVar v = do + vn <- ctxNextVarNum <$> get + modify' \ctx -> ctx + { ctxNextVarNum = Alignable.nextAlign vn + , ctxVars = AlignableMap.insert vn v + do ctxVars ctx + } + pure vn + +genNewAlt :: Monad m + => PEG.Alt altDoc a -> BuilderT start varDoc altDoc a m PEG.AltNum +genNewAlt alt = do + altn <- ctxNextAltNum <$> get + modify' \ctx -> ctx + { ctxNextAltNum = Alignable.nextAlign altn + , ctxAlts = AlignableMap.insert altn alt + do ctxAlts ctx + } + pure altn + +addInitial :: Monad m => Enum start + => start -> PEG.VarNum -> BuilderT start varDoc altDoc a m () +addInitial i v = modify' \ctx -> ctx + { ctxInitials = EnumMap.insert i v do ctxInitials ctx + } + +addRule :: Monad m + => PEG.VarNum -> PEG.Rule -> BuilderT start varDoc altDoc a m () +addRule v e = modify' \ctx -> ctx + { ctxRules = AlignableMap.insert v e + do ctxRules ctx + } diff --git a/src/Language/Parser/Ptera/Machine/SRB.hs b/src/Language/Parser/Ptera/Machine/SRB.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Machine/SRB.hs @@ -0,0 +1,54 @@ +module Language.Parser.Ptera.Machine.SRB where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +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 + + +type T = SRB + +data SRB start varDoc altDoc a = SRB + { initials :: EnumMap.EnumMap start StateNum + , states :: AlignableArray.T StateNum MState + , alts :: AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a) + , vars :: AlignableArray.T LAPEG.VarNum (PEG.Var varDoc) + } + deriving (Eq, Show, Functor) + +newtype StateNum = StateNum Int + deriving (Eq, Show) + deriving Hashable via Int + deriving Alignable.T via Alignable.Inst + +data MState = MState + { + stateNum :: StateNum, + stateTrans :: SymbolicIntMap.T Trans, + stateAltItems :: [AltItem] + } + deriving (Eq, Show) + +data Trans + = TransWithOps [TransOp] StateNum + | TransReduce LAPEG.AltNum + deriving (Eq, Show) + +data TransOp + = TransOpEnter LAPEG.VarNum Bool (Maybe StateNum) + | TransOpPushBackpoint StateNum + | TransOpHandleNot LAPEG.AltNum + | TransOpShift + deriving (Eq, Show, Generic) + +instance Hashable TransOp + +data AltItem = AltItem + { altItemAltNum :: LAPEG.AltNum + , altItemCurPos :: LAPEG.Position + } + deriving (Eq, Show) diff --git a/src/Language/Parser/Ptera/Machine/SRB/Builder.hs b/src/Language/Parser/Ptera/Machine/SRB/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Machine/SRB/Builder.hs @@ -0,0 +1,72 @@ +module Language.Parser.Ptera.Machine.SRB.Builder where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray +import qualified Language.Parser.Ptera.Data.Alignable.Map as AlignableMap +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 + + +type T start a = BuilderT start a + +type BuilderT start a = StateT (Context start a) + +data Context start a = Context + { + ctxInitials :: EnumMap.EnumMap start SRB.StateNum, + ctxNextStateNum :: SRB.StateNum, + ctxStates :: AlignableMap.T SRB.StateNum SRB.MState + } + deriving (Eq, Show) + +type Vars varDoc = AlignableArray.T LAPEG.VarNum (PEG.Var varDoc) +type Alts altDoc a = AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a) + +build :: Monad m + => Vars varDoc -> Alts altDoc a -> BuilderT start a m () + -> m (SRB.T start varDoc altDoc a) +build vars alts builder = do + finalCtx <- execStateT builder initialCtx + pure do + SRB.SRB + { initials = ctxInitials finalCtx + , states = AlignableArray.fromTotalMap + do ctxNextStateNum finalCtx + do ctxStates finalCtx + , alts = alts + , vars = vars + } + where + initialCtx = Context + { + ctxInitials = EnumMap.empty, + ctxNextStateNum = Alignable.initialAlign, + ctxStates = AlignableMap.empty + } + +genNewStateNum :: Monad m => BuilderT start a m SRB.StateNum +genNewStateNum = do + ctx <- get + let sn = ctxNextStateNum ctx + put do ctx { ctxNextStateNum = Alignable.nextAlign sn } + pure sn + +registerInitial :: Monad m => Enum start + => start -> SRB.StateNum -> BuilderT start a m () +registerInitial i v = modify' \ctx -> ctx + { + ctxInitials = EnumMap.insert i v do ctxInitials ctx + } + +addState :: Monad m => SRB.MState -> BuilderT s a m () +addState s = modify' \ctx -> ctx + { + ctxStates = AlignableMap.insert + do SRB.stateNum s + do s + do ctxStates ctx + } diff --git a/src/Language/Parser/Ptera/Pipeline/Grammar2PEG.hs b/src/Language/Parser/Ptera/Pipeline/Grammar2PEG.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Pipeline/Grammar2PEG.hs @@ -0,0 +1,122 @@ +module Language.Parser.Ptera.Pipeline.Grammar2PEG where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Machine.PEG as PEG +import qualified Language.Parser.Ptera.Machine.PEG.Builder as PEGBuilder +import qualified Language.Parser.Ptera.Syntax.Grammar as Grammar +import qualified Language.Parser.Ptera.Data.HFList as HFList + + +grammar2Peg :: Enum start => Enum nonTerminal => Enum terminal + => Grammar.FixedGrammar start nonTerminal terminal elem varDoc altDoc action + -> PEG.T start varDoc altDoc (Grammar.Action action) +grammar2Peg g = runIdentity do PEGBuilder.build builder where + builder = do + initialBuilderCtx <- get + let initialCtx = Context + { ctxBuilder = initialBuilderCtx + , ctxVarMap = EnumMap.empty + , ctxDisplayNonTerminals = Grammar.grammarDisplayNonTerminals g + } + let finalCtx = execState pipeline initialCtx + put do ctxBuilder finalCtx + + pipeline = do + forM_ do EnumMap.assocs do Grammar.grammarStarts g + do \(s, v) -> grammarStartPipeline s v + forM_ do EnumMap.assocs do Grammar.grammarRules g + do \(v, e) -> grammarRulePipeline v e + +type Pipeline start nonTerminal varDoc altDoc action = + State (Context start nonTerminal varDoc altDoc action) + +data Context start nonTerminal varDoc altDoc action = Context + { ctxBuilder :: PEGBuilder.Context start varDoc altDoc (Grammar.Action action) + , ctxVarMap :: EnumMap.EnumMap nonTerminal PEG.VarNum + , ctxDisplayNonTerminals :: EnumMap.EnumMap nonTerminal varDoc + } + +grammarStartPipeline :: Enum start => Enum nonTerminal + => start -> nonTerminal -> Pipeline start nonTerminal varDoc altDoc action () +grammarStartPipeline s v = do + newV <- getNewVar v + liftBuilder do PEGBuilder.addInitial s newV + +grammarRulePipeline :: Enum nonTerminal => Enum terminal + => nonTerminal -> Grammar.RuleExpr nonTerminal terminal elem altDoc action + -> Pipeline start nonTerminal varDoc altDoc action () +grammarRulePipeline v (Grammar.RuleExpr alts) = do + newV <- getNewVar v + newAlts <- forM alts \alt -> grammarAltPipeline alt + let newRule = PEG.Rule newAlts + liftBuilder do PEGBuilder.addRule newV newRule + +grammarAltPipeline :: Enum nonTerminal => Enum terminal + => Grammar.Alt nonTerminal terminal elem altDoc action r + -> Pipeline start nonTerminal varDoc altDoc action PEG.AltNum +grammarAltPipeline (Grammar.Alt e d act) = do + newUs <- grammarExprPipeline e + let newAct = Grammar.Action act + let newAlt = PEG.Alt + { altKind = PEG.AltSeq + , altUnitSeq = newUs + , altAction = newAct + , altHelp = d + } + liftBuilder do PEGBuilder.genNewAlt newAlt + +grammarExprPipeline :: forall start nonTerminal terminal elem varDoc altDoc action us + . Enum nonTerminal => Enum terminal + => Grammar.Expr nonTerminal terminal elem us + -> Pipeline start nonTerminal varDoc altDoc action [PEG.Unit] +grammarExprPipeline e = do + revUs <- HFList.hfoldMWithIndex [] + do \acc _ u -> do + newU <- grammarUnitPipeline u + pure do newU:acc + do e + pure do reverse revUs + +grammarUnitPipeline :: Enum nonTerminal => Enum terminal + => Grammar.Unit nonTerminal terminal elem u + -> Pipeline start nonTerminal varDoc altDoc action PEG.Unit +grammarUnitPipeline = \case + Grammar.UnitToken t -> + pure do PEG.UnitTerminal do fromEnum t + Grammar.UnitVar v -> do + newV <- getNewVar v + pure do PEG.UnitNonTerminal newV + +getNewVar :: Enum nonTerminal + => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action PEG.VarNum +getNewVar v = do + vmap <- ctxVarMap <$> get + case EnumMap.lookup v vmap of + Just newV -> + pure newV + Nothing -> do + displayNonTerminals <- ctxDisplayNonTerminals <$> get + let d = case EnumMap.lookup v displayNonTerminals of + Just x -> x + Nothing -> error "Not found any rules for a non-terminal." + newV <- liftBuilder + do PEGBuilder.genNewVar + do PEG.Var + { varHelp = d + } + modify' \ctx -> ctx + { ctxVarMap = EnumMap.insert v newV + do ctxVarMap ctx + } + pure newV + +liftBuilder + :: PEGBuilder.T start varDoc altDoc (Grammar.Action action) Identity r + -> Pipeline start nonTerminal varDoc altDoc action r +liftBuilder builder = do + ctx <- get + let (x, builderCtx) = runState builder do ctxBuilder ctx + put do ctx { ctxBuilder = builderCtx } + pure x diff --git a/src/Language/Parser/Ptera/Pipeline/LAPEG2SRB.hs b/src/Language/Parser/Ptera/Pipeline/LAPEG2SRB.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Pipeline/LAPEG2SRB.hs @@ -0,0 +1,413 @@ +module Language.Parser.Ptera.Pipeline.LAPEG2SRB where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List.NonEmpty as NonEmpty +import qualified Language.Parser.Ptera.Data.Alignable as Alignable +import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray +import qualified Language.Parser.Ptera.Data.Alignable.Map as AlignableMap +import qualified Language.Parser.Ptera.Data.Symbolic.IntMap as SymbolicIntMap +import qualified Language.Parser.Ptera.Data.Symbolic.IntSet as SymbolicIntSet +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.Machine.SRB.Builder as SRBBuilder + +laPeg2Srb :: Enum start + => LAPEG.T start varDoc altDoc a -> SRB.T start varDoc altDoc a +laPeg2Srb g = runIdentity do + SRBBuilder.build + do LAPEG.vars g + do LAPEG.alts g + do builder + where + builder = do + initialBuilderCtx <- get + let initialCtx = Context + { ctxBuilder = initialBuilderCtx + , ctxInitialVarState = AlignableMap.empty + , ctxReduceNotState = AlignableMap.empty + , ctxVarMap = AlignableMap.empty + , ctxStateMap = HashMap.empty + , ctxStateQueue = [] + , ctxOriginalRules = LAPEG.rules g + , ctxOriginalAlts = LAPEG.alts g + } + let finalCtx = execState pipeline initialCtx + put do ctxBuilder finalCtx + + pipeline = do + forM_ + do EnumMap.assocs do LAPEG.initials g + do \(s, v) -> laPegInitialPipeline s v + laPegStateQueuePipeline + +type Pipeline start altDoc a = State (Context start altDoc a) + +data Context start altDoc a = Context + { ctxBuilder :: SRBBuilder.Context start a + , ctxInitialVarState :: AlignableMap.T LAPEG.VarNum SRB.StateNum + , ctxReduceNotState :: AlignableMap.T LAPEG.AltNum SRB.StateNum + , ctxVarMap :: AlignableMap.T LAPEG.VarNum (SymbolicIntMap.T (Bool, SRB.StateNum)) + , ctxStateMap :: HashMap.HashMap (LAPEG.Position, NonEmpty LAPEG.AltNum) SRB.StateNum + , ctxStateQueue :: [(SRB.StateNum, LAPEG.Position, NonEmpty LAPEG.AltNum)] + , ctxOriginalRules :: AlignableArray.T LAPEG.VarNum LAPEG.Rule + , ctxOriginalAlts :: AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a) + } + +laPegInitialPipeline :: Enum start + => start -> LAPEG.VarNum -> Pipeline start altDoc a () +laPegInitialPipeline s v = do + m0 <- getCtx ctxInitialVarState + newSn <- case AlignableMap.lookup v m0 of + Just sn -> + pure sn + Nothing -> do + sn <- liftBuilder do SRBBuilder.genNewStateNum + modify' \ctx -> ctx + { + ctxInitialVarState = AlignableMap.insert v sn + do ctxInitialVarState ctx + } + m <- laPegVarPipeline v + let st = SRB.MState + { stateNum = sn + , stateTrans = fmap + do \(needBack, to) -> SRB.TransWithOps [SRB.TransOpEnter v needBack Nothing] to + do m + , stateAltItems = [] + } + liftBuilder do SRBBuilder.addState st + pure sn + liftBuilder do SRBBuilder.registerInitial s newSn + +laPegStateQueuePipeline :: Pipeline start altDoc a () +laPegStateQueuePipeline = do + ctx <- get + case ctxStateQueue ctx of + [] -> + pure () + (sn, p, alts):rest -> do + put do ctx { ctxStateQueue = rest } + laPegStatePipeline sn p alts + laPegStateQueuePipeline + +laPegVarPipeline + :: LAPEG.VarNum + -> Pipeline start altDoc a (SymbolicIntMap.T (Bool, SRB.StateNum)) +laPegVarPipeline v = do + varMap <- getCtx ctxVarMap + case AlignableMap.lookup v varMap of + Just ss -> + pure ss + Nothing -> do + rules <- getCtx ctxOriginalRules + let r = AlignableArray.forceIndex rules v + laPegRulePipeline v r + +laPegRulePipeline + :: LAPEG.VarNum -> LAPEG.Rule + -> Pipeline start altDoc a (SymbolicIntMap.T (Bool, SRB.StateNum)) +laPegRulePipeline v r = do + sm <- case LAPEG.ruleAlts r of + [] -> + pure SymbolicIntMap.empty + alt:alts -> + laPegEnterStatePipeline do alt :| alts + modify' \ctx -> ctx + { + ctxVarMap = AlignableMap.insert v sm + do ctxVarMap ctx + } + pure sm + +laPegEnterStatePipeline + :: NonEmpty LAPEG.AltNum + -> Pipeline start altDoc a (SymbolicIntMap.T (Bool, SRB.StateNum)) +laPegEnterStatePipeline = \alts -> go do revTails [] alts where + revTails accs = \case + alts@(_:|[]) -> + alts:accs + alts@(_:|alt1:rest) -> + revTails + do alts:accs + do alt1 :| rest + + go altss = do + m <- go1 SymbolicIntMap.empty altss + traverse + do \alts -> do + needBack <- isNeedBackAlts alts + sn <- getStateForAltItems Alignable.initialAlign alts + pure (needBack, sn) + do m + + go1 m = \case + [] -> + pure m + alts@(altn :| _):rest -> do + mru <- getUnitForAltItem Alignable.initialAlign altn + let s = case mru of + Nothing -> + SymbolicIntSet.full + Just (is, _) -> + is + go1 + do SymbolicIntMap.insertBulk s alts m + do rest + +laPegStatePipeline + :: SRB.StateNum -> LAPEG.Position -> NonEmpty LAPEG.AltNum + -> Pipeline start altDoc a () +laPegStatePipeline sn p alts = do + trans <- laPegTransPipeline p alts + let st = SRB.MState + { stateNum = sn + , stateTrans = trans + , stateAltItems = case alts of + alt :| alts' -> toAltItem alt:[toAltItem alt' | alt' <- alts'] + } + liftBuilder do SRBBuilder.addState st + where + toAltItem altn = SRB.AltItem + { + altItemAltNum = altn, + altItemCurPos = p + } + +laPegTransPipeline + :: LAPEG.Position -> NonEmpty LAPEG.AltNum + -> Pipeline start altDoc a (SymbolicIntMap.T SRB.Trans) +laPegTransPipeline p0 alts0 = do + m <- genAltMapForTrans p0 alts0 + let p1 = Alignable.nextAlign p0 + traverse + do \altItems -> toTrans p1 altItems + do m + where + toTrans p1 altItems = do + mbackOp <- case altItemsForTransRest altItems of + [] -> + pure Nothing + ralt:ralts -> do + sn <- getStateForAltItems p0 do ralt :| ralts + pure do Just do SRB.TransOpPushBackpoint sn + let withBackOp ops = case mbackOp of + Nothing -> + ops + Just backOp -> + backOp:ops + case altItemsForTransOp altItems of + AltItemsOpShift -> do + let alts = NonEmpty.reverse do altItemsForTransRevAlts altItems + sn <- getStateForAltItems p1 alts + pure do + SRB.TransWithOps + do withBackOp [SRB.TransOpShift] + do sn + AltItemsOpEnter v needBack enterSn -> do + let alts = NonEmpty.reverse do altItemsForTransRevAlts altItems + sn <- getStateForAltItems p1 alts + pure do + SRB.TransWithOps + do withBackOp [SRB.TransOpEnter v needBack do Just sn] + do enterSn + AltItemsOpNot -> do + let alts = NonEmpty.reverse do altItemsForTransRevAlts altItems + sn <- getStateForAltItems p1 alts + let notAlt = NonEmpty.head alts + pure do + SRB.TransWithOps + do withBackOp [SRB.TransOpHandleNot notAlt] + do sn + AltItemsOpReduce -> do + let altn = NonEmpty.last do altItemsForTransRevAlts altItems + pure do SRB.TransReduce altn + +genAltMapForTrans + :: LAPEG.Position -> NonEmpty LAPEG.AltNum + -> Pipeline start altDoc a (SymbolicIntMap.T AltItemsForTrans) +genAltMapForTrans p (alt0 :| alts0) = go SymbolicIntMap.empty do alt0:alts0 where + go m0 = \case + [] -> + pure m0 + alt:rest -> do + m1 <- goAlt m0 alt rest + go m1 rest + + goAlt m0 alt rest = getUnitForAltItem p alt >>= \case + Nothing -> do + let m1 = SymbolicIntMap.alterBulk + do \case + e@(Just altItems) | hasRest altItems -> + e + Just altItems -> Just do + altItems + { + altItemsForTransRest = alt:rest + } + Nothing -> Just do + AltMapForTrans + { altItemsForTransOp = AltItemsOpReduce + , altItemsForTransRevAlts = pure alt + , altItemsForTransRest = [] + } + do SymbolicIntSet.full + do m0 + pure m1 + Just (_, LAPEG.UnitTerminal t) -> do + let m1 = SymbolicIntMap.alter + do \case + e@(Just altItems) | hasRest altItems -> + e + Just altItems -> case altItemsForTransOp altItems of + AltItemsOpShift -> Just do + altItems + { + altItemsForTransRevAlts = NonEmpty.cons alt + do altItemsForTransRevAlts altItems + } + _ -> Just do + altItems + { + altItemsForTransRest = alt:rest + } + Nothing -> Just do + AltMapForTrans + { altItemsForTransOp = AltItemsOpShift + , altItemsForTransRevAlts = pure alt + , altItemsForTransRest = [] + } + do t + do m0 + pure m1 + Just (is, LAPEG.UnitNonTerminal v) -> do + vm <- laPegVarPipeline v + let m1 = SymbolicIntMap.merge + do \altItems (needBack, sn) -> case altItemsForTransOp altItems of + _ | hasRest altItems -> + Just altItems + transOp@AltItemsOpEnter{} | transOp == AltItemsOpEnter v needBack sn -> + Just do + altItems + { + altItemsForTransRevAlts = NonEmpty.cons alt + do altItemsForTransRevAlts altItems + } + _ -> Just do + altItems + { + altItemsForTransRest = alt:rest + } + do \altItems -> Just altItems + do \(needBack, sn) -> Just do + AltMapForTrans + { altItemsForTransOp = AltItemsOpEnter v needBack sn + , altItemsForTransRevAlts = pure alt + , altItemsForTransRest = [] + } + do m0 + do SymbolicIntMap.restrictKeys vm is + pure m1 + Just (is, LAPEG.UnitNot) -> do + let m1 = SymbolicIntMap.alterBulk + do \case + e@(Just altItems) | hasRest altItems -> + e + Just altItems -> Just do + altItems + { + altItemsForTransRest = alt:rest + } + Nothing -> Just do + AltMapForTrans + { altItemsForTransOp = AltItemsOpNot + , altItemsForTransRevAlts = pure alt + , altItemsForTransRest = rest + } + do is + do m0 + pure m1 + + hasRest altItems = not do null do altItemsForTransRest altItems + +data AltItemsForTrans = AltMapForTrans + { + altItemsForTransOp :: AltItemsOpForTrans, + altItemsForTransRevAlts :: NonEmpty LAPEG.AltNum, + altItemsForTransRest :: [LAPEG.AltNum] + } + deriving (Eq, Show) + +data AltItemsOpForTrans + = AltItemsOpShift + | AltItemsOpEnter LAPEG.VarNum Bool SRB.StateNum + | AltItemsOpNot + | AltItemsOpReduce + deriving (Eq, Show) + +getStateForAltItems + :: LAPEG.Position -> NonEmpty LAPEG.AltNum + -> Pipeline start altDoc a SRB.StateNum +getStateForAltItems p alts = do + m <- getCtx ctxStateMap + case HashMap.lookup (p, alts) m of + Just sn -> + pure sn + Nothing -> do + sn <- liftBuilder SRBBuilder.genNewStateNum + modify' \ctx -> ctx + { ctxStateMap = HashMap.insert (p, alts) sn + do ctxStateMap ctx + , ctxStateQueue = (sn, p, alts):ctxStateQueue ctx + } + pure sn + +isNeedBackAlts :: NonEmpty LAPEG.AltNum -> Pipeline start altDoc a Bool +isNeedBackAlts = \(altn :| rest) -> go altn rest where + go altn0 rest = do + alt0 <- getAlt altn0 + case LAPEG.altKind alt0 of + PEG.AltNot -> + pure True + PEG.AltAnd -> + pure True + PEG.AltSeq -> case rest of + [] -> + pure False + altn1:alts -> + go altn1 alts + +getUnitForAltItem + :: LAPEG.Position -> LAPEG.AltNum + -> Pipeline start altDoc a (Maybe (SymbolicIntSet.T, LAPEG.Unit)) +getUnitForAltItem p altn = do + alt <- getAlt altn + let us = LAPEG.altUnitSeqWithLookAHead alt + case AlignableArray.index us p of + Nothing -> + pure Nothing + Just (hr, u) -> do + let is = if LAPEG.headRangeEpsilon hr + then SymbolicIntSet.full + else LAPEG.headRangeConsume hr + pure do Just (is, u) + +getAlt :: LAPEG.AltNum -> Pipeline start altDoc a (LAPEG.Alt altDoc a) +getAlt altn = do + alts <- getCtx ctxOriginalAlts + let alt = AlignableArray.forceIndex alts altn + pure alt + +getCtx :: (Context start altDoc a -> r) -> Pipeline start altDoc a r +getCtx f = f <$> get + +liftBuilder :: SRBBuilder.T start a Identity r -> Pipeline start altDoc a r +liftBuilder builder = do + ctx <- get + let (x, builderCtx) = runIdentity + do runStateT builder do ctxBuilder ctx + put do ctx { ctxBuilder = builderCtx } + pure x diff --git a/src/Language/Parser/Ptera/Pipeline/PEG2LAPEG.hs b/src/Language/Parser/Ptera/Pipeline/PEG2LAPEG.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Pipeline/PEG2LAPEG.hs @@ -0,0 +1,337 @@ +module Language.Parser.Ptera.Pipeline.PEG2LAPEG 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.Alignable.Map as AlignableMap +import qualified Language.Parser.Ptera.Data.Alignable.Set as AlignableSet +import qualified Language.Parser.Ptera.Data.Symbolic.IntSet as SymbolicIntSet +import qualified Language.Parser.Ptera.Machine.LAPEG as LAPEG +import qualified Language.Parser.Ptera.Machine.LAPEG.Builder as LAPEGBuilder +import qualified Language.Parser.Ptera.Machine.PEG as PEG + + +peg2LaPeg :: Enum start + => PEG.T start varDoc altDoc a + -> Except (AlignableSet.T PEG.VarNum) (LAPEG.T start varDoc altDoc a) +peg2LaPeg g = LAPEGBuilder.build builder where + builder = do + initialCtxBuilder <- get + let initialCtx = Context + { ctxBuilder = initialCtxBuilder + , ctxVarMap = AlignableMap.empty + , ctxAvailableRuleRanges = AlignableMap.empty + , ctxUpdateRuleStack = [] + , ctxOriginalVars = PEG.vars g + , ctxOriginalRules = PEG.rules g + , ctxOriginalAlts = PEG.alts g + } + let (mx, finalCtx) = runState + do runExceptT do pipeline do PEG.initials g + do initialCtx + case mx of + Left vs -> lift do throwE vs + Right{} -> put do ctxBuilder finalCtx + + pipeline inits = do + rvs <- foldlM + do \vs1 (s, v) -> catchE + do + pegInitialPipeline s v + pure vs1 + \vs2 -> do + lift do + modify' \ctx -> ctx + { ctxAvailableRuleRanges = AlignableMap.empty + , ctxUpdateRuleStack = [] + } + pure do AlignableSet.union vs1 vs2 + do AlignableSet.empty + do EnumMap.assocs inits + if AlignableSet.null rvs + then pure () + else throwE rvs + +type Pipeline start varDoc altDoc a = + ExceptT (AlignableSet.T PEG.VarNum) (State (Context start varDoc altDoc a)) + +data Context start varDoc altDoc a = Context + { ctxBuilder :: LAPEGBuilder.Context start varDoc altDoc a + , ctxVarMap :: AlignableMap.T PEG.VarNum LAPEG.VarNum + , ctxAvailableRuleRanges :: AlignableMap.T LAPEG.VarNum (Maybe LAPEG.HeadRange) + , ctxUpdateRuleStack :: [(LAPEG.VarNum, LAPEG.HeadRange, [PEG.Alt altDoc a])] + , ctxOriginalVars :: AlignableArray.T PEG.VarNum (PEG.Var varDoc) + , ctxOriginalRules :: AlignableArray.T PEG.VarNum PEG.Rule + , ctxOriginalAlts :: AlignableArray.T PEG.AltNum (PEG.Alt altDoc a) + } + +pegInitialPipeline :: Enum start + => start -> PEG.VarNum -> Pipeline start varDoc altDoc a () +pegInitialPipeline s v = do + newV <- getAvailableVar v >>= \case + Just x -> + pure x + Nothing -> do + (x, _) <- pegVarPipeline v + pure x + pegRuleStackPipeline + liftBuilder do LAPEGBuilder.addInitial s newV + +pegRuleStackPipeline :: Pipeline start varDoc altDoc a () +pegRuleStackPipeline = popUpdateRuleItem >>= \case + Nothing -> + pure () + Just (newV, newRange, rule) -> do + pegRulePipeline newV newRange rule + pegRuleStackPipeline + +pegVarPipeline + :: PEG.VarNum -> Pipeline start varDoc altDoc a (LAPEG.VarNum, LAPEG.HeadRange) +pegVarPipeline v = do + newV <- getNewVar v + availableRuleRanges <- getCtx ctxAvailableRuleRanges + case AlignableMap.lookup newV availableRuleRanges of + Nothing -> + goVarUpdate newV + Just Nothing -> + throwV v + Just (Just hr) -> + pure (newV, hr) + where + goVarUpdate newV = do + pegRules <- getCtx ctxOriginalRules + let rule = AlignableArray.forceIndex pegRules v + hr <- pegRuleHeadRangePipeline newV rule + pure (newV, hr) + +pegRuleHeadRangePipeline + :: LAPEG.VarNum -> PEG.Rule + -> Pipeline start varDoc altDoc a LAPEG.HeadRange +pegRuleHeadRangePipeline newV (PEG.Rule altns) = do + originalAlts <- getCtx ctxOriginalAlts + let alts = [ AlignableArray.forceIndex originalAlts altn | altn <- altns ] + startUpdateAvailableRuleRange newV + newRange <- foldM + do \hr0 alt -> do + hr <- pegAltHeadRangePipeline alt + pure do hr0 <> hr + do mempty + do alts + saveNewRuleRange newV newRange + pushUpdateRuleItem newV newRange alts + pure newRange + +pegAltHeadRangePipeline + :: PEG.Alt altDoc a -> Pipeline start varDoc altDoc a LAPEG.HeadRange +pegAltHeadRangePipeline alt = + case PEG.altKind alt of + PEG.AltSeq -> goStraight + PEG.AltNot -> goNegative + PEG.AltAnd -> goStraight + where + goStraight = goUnits0 do PEG.altUnitSeq alt + + goNegative = do + hr <- goUnits0 do PEG.altUnitSeq alt + let notHr = if + | LAPEG.headRangeEpsilon hr -> + mempty + | otherwise -> + LAPEG.HeadRange + { headRangeEpsilon = True + , headRangeConsume = SymbolicIntSet.full + } + pure notHr + + goUnits0 us = goUnits mempty us + + goUnits consumeRange0 = \case + [] -> do + let hr = LAPEG.HeadRange + { headRangeEpsilon = True + , headRangeConsume = consumeRange0 + } + pure hr + u:us -> do + (_, hr) <- pegUnitPipeline u + let consumeRange1 = consumeRange0 <> LAPEG.headRangeConsume hr + if LAPEG.headRangeEpsilon hr + then + goUnits consumeRange1 us + else do + let hr1 = LAPEG.HeadRange + { headRangeEpsilon = False + , headRangeConsume = consumeRange1 + } + pure hr1 + +pegRulePipeline + :: LAPEG.VarNum -> LAPEG.HeadRange -> [PEG.Alt altDoc a] + -> Pipeline start varDoc altDoc a () +pegRulePipeline newV newRange alts = do + newAlts <- forM alts \alt -> pegAltPipeline newV alt + let newRule = LAPEG.Rule + { ruleRange = newRange + , ruleAlts = newAlts + } + liftBuilder do LAPEGBuilder.addRule newV newRule + +pegAltPipeline + :: LAPEG.VarNum -> PEG.Alt altDoc a + -> Pipeline start varDoc altDoc a LAPEG.AltNum +pegAltPipeline newV alt = + case PEG.altKind alt of + PEG.AltSeq -> goStraight + PEG.AltNot -> goNegative + PEG.AltAnd -> goStraight + where + goStraight = do + (_, newUs) <- goUnits do PEG.altUnitSeq alt + newAlt <- genNewAltNum newUs + pure newAlt + + goNegative = do + (hr, newUs) <- goUnits do PEG.altUnitSeq alt + let notHr = if + | LAPEG.headRangeEpsilon hr -> + mempty + | otherwise -> + LAPEG.HeadRange + { headRangeEpsilon = True + , headRangeConsume = SymbolicIntSet.full + } + newAlt <- genNewAltNum do (notHr, LAPEG.UnitNot):newUs + pure newAlt + + genNewAltNum newUs = do + let newAlt = LAPEG.Alt + { altVar = newV + , altUnitSeqWithLookAHead = AlignableArray.fromList newUs + , altKind = PEG.altKind alt + , altAction = PEG.altAction alt + , altHelp = PEG.altHelp alt + } + liftBuilder do LAPEGBuilder.genNewAlt newAlt + + goUnits us = do + let hr0 = LAPEG.HeadRange + { headRangeEpsilon = True + , headRangeConsume = mempty + } + goRevUnits hr0 [] do reverse us + + goRevUnits postRange newUs = \case + [] -> + pure (postRange, newUs) + u:revUs -> do + (newU, hrU) <- pegUnitPipeline u + let hrUWithPost = if LAPEG.headRangeEpsilon hrU + then LAPEG.HeadRange + { headRangeEpsilon = + LAPEG.headRangeEpsilon postRange + , headRangeConsume = + LAPEG.headRangeConsume hrU <> LAPEG.headRangeConsume postRange + } + else hrU + goRevUnits hrUWithPost ((hrUWithPost, newU):newUs) revUs + +pegUnitPipeline + :: PEG.Unit -> Pipeline start varDoc altDoc a (LAPEG.Unit, LAPEG.HeadRange) +pegUnitPipeline = \case + PEG.UnitTerminal t -> do + let hr = LAPEG.HeadRange + { headRangeEpsilon = False + , headRangeConsume = SymbolicIntSet.singleton t + } + pure (LAPEG.UnitTerminal t, hr) + PEG.UnitNonTerminal v -> do + (newV, hr) <- pegVarPipeline v + pure (LAPEG.UnitNonTerminal newV, hr) + +getNewVar :: PEG.VarNum -> Pipeline start varDoc altDoc a LAPEG.VarNum +getNewVar vn = do + vm0 <- getCtx ctxVarMap + case AlignableMap.lookup vn vm0 of + Just newV -> + pure newV + Nothing -> do + originalVars <- getCtx ctxOriginalVars + let v = AlignableArray.forceIndex originalVars vn + newV <- liftBuilder do LAPEGBuilder.genNewVar v + lift do + modify' \ctx -> ctx + { + ctxVarMap = AlignableMap.insert vn newV + do ctxVarMap ctx + } + pure newV + +startUpdateAvailableRuleRange :: LAPEG.VarNum -> Pipeline start varDoc altDoc a () +startUpdateAvailableRuleRange newV = lift do + modify' \ctx -> ctx + { ctxAvailableRuleRanges = AlignableMap.insert newV + do Nothing + do ctxAvailableRuleRanges ctx + } + +saveNewRuleRange + :: LAPEG.VarNum -> LAPEG.HeadRange + -> Pipeline start varDoc altDoc a () +saveNewRuleRange newV hr = lift do + modify' \ctx -> ctx + { ctxAvailableRuleRanges = AlignableMap.insert newV + do Just hr + do ctxAvailableRuleRanges ctx + } + +getAvailableVar + :: PEG.VarNum -> Pipeline start varDoc altDoc a (Maybe LAPEG.VarNum) +getAvailableVar v = do + ctx <- lift get + case AlignableMap.lookup v do ctxVarMap ctx of + Nothing -> + pure Nothing + Just newV -> case AlignableMap.lookup newV do ctxAvailableRuleRanges ctx of + Nothing -> + pure Nothing + Just Nothing -> + pure Nothing + Just Just{} -> + pure do Just newV + +popUpdateRuleItem + :: Pipeline start varDoc altDoc a (Maybe (LAPEG.VarNum, LAPEG.HeadRange, [PEG.Alt altDoc a])) +popUpdateRuleItem = do + updateRuleStack <- getCtx ctxUpdateRuleStack + case updateRuleStack of + [] -> + pure Nothing + item:items -> do + lift do modify' \ctx -> ctx { ctxUpdateRuleStack = items } + pure do Just item + +pushUpdateRuleItem + :: LAPEG.VarNum -> LAPEG.HeadRange -> [PEG.Alt altDoc a] + -> Pipeline start varDoc altDoc a () +pushUpdateRuleItem newV newRange alts = lift do + modify' \ctx -> ctx + { ctxUpdateRuleStack = (newV, newRange, alts):ctxUpdateRuleStack ctx + } + +getCtx + :: (Context start varDoc altDoc a -> r) + -> Pipeline start varDoc altDoc a r +getCtx f = f <$> lift get + +throwV :: PEG.VarNum -> Pipeline start varDoc altDoc a r +throwV v = throwE do AlignableSet.singleton v + +liftBuilder + :: LAPEGBuilder.T start varDoc altDoc a Identity r + -> Pipeline start varDoc altDoc a r +liftBuilder builder = do + ctx <- lift get + let (x, builderCtx) = runState builder do ctxBuilder ctx + lift do put do ctx { ctxBuilder = builderCtx } + pure x diff --git a/src/Language/Parser/Ptera/Prelude.hs b/src/Language/Parser/Ptera/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Prelude.hs @@ -0,0 +1,7 @@ +module Language.Parser.Ptera.Prelude ( + module Language.Parser.Ptera.Prelude.Core, + module Language.Parser.Ptera.Prelude.Alias, +) where + +import Language.Parser.Ptera.Prelude.Alias +import Language.Parser.Ptera.Prelude.Core diff --git a/src/Language/Parser/Ptera/Prelude/Alias.hs b/src/Language/Parser/Ptera/Prelude/Alias.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Prelude/Alias.hs @@ -0,0 +1,20 @@ +module Language.Parser.Ptera.Prelude.Alias ( + StringLit, + debugTrace, + debugTraceShow, + debugTraceShowId, +) where + +import qualified Debug.Trace as Debug +import qualified Prelude + +type StringLit = Prelude.String + +debugTrace :: StringLit -> a -> a +debugTrace = Debug.trace + +debugTraceShow :: Prelude.Show a => a -> b -> b +debugTraceShow = Debug.traceShow + +debugTraceShowId :: Prelude.Show a => a -> a +debugTraceShowId = Debug.traceShowId diff --git a/src/Language/Parser/Ptera/Prelude/Core.hs b/src/Language/Parser/Ptera/Prelude/Core.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Prelude/Core.hs @@ -0,0 +1,63 @@ +module Language.Parser.Ptera.Prelude.Core ( + module Prelude, + module Control.Applicative, + module Control.Monad, + module Control.Monad.IO.Class, + module Control.Monad.Trans.Class, + module Control.Monad.Trans.Maybe, + module Control.Monad.Trans.Except, + module Control.Monad.Trans.State.Strict, + module Data.Coerce, + module Data.Foldable, + module Data.Function, + module Data.Functor, + module Data.Functor.Identity, + module Data.Functor.Compose, + module Data.Hashable, + module Data.Ix, + module Data.Kind, + module Data.List.NonEmpty, + module Data.Ord, + module Data.Proxy, + module Data.Typeable, + module Data.Word, + module GHC.Exts, + module GHC.Generics, + module GHC.OverloadedLabels, + module GHC.Records, + module GHC.TypeLits, +) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except hiding (liftCallCC, + liftListen, liftPass) +import Control.Monad.Trans.Maybe hiding (liftCallCC, liftCatch, + liftListen, liftPass) +import Control.Monad.Trans.State.Strict hiding (liftCallCC, liftCatch, + liftListen, liftPass, modify) +import Data.Coerce +import Data.Foldable hiding (foldl, foldr') +import Data.Function hiding (($)) +import Data.Functor +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Hashable (Hashable) +import Data.Ix (Ix) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Ord (Down (..)) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Data.Word (Word, Word8) +import GHC.Exts (Proxy#, proxy#) +import GHC.Generics (Generic) +import GHC.OverloadedLabels +import GHC.Records +import GHC.TypeLits (KnownNat, KnownSymbol, Nat, + Symbol, natVal, natVal', + symbolVal, symbolVal') +import Prelude hiding (String, foldl, foldr, + head, pi, tail, ($)) diff --git a/src/Language/Parser/Ptera/Syntax/Grammar.hs b/src/Language/Parser/Ptera/Syntax/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Language/Parser/Ptera/Syntax/Grammar.hs @@ -0,0 +1,97 @@ +module Language.Parser.Ptera.Syntax.Grammar ( + T, + + GrammarT, + Context (..), + fixGrammarT, + FixedGrammar (..), + + Action (..), + RuleExpr (..), + Alt (..), + Expr, + Unit (..), + + initialT, + ruleT, +) where + +import Language.Parser.Ptera.Prelude + +import qualified Data.EnumMap.Strict as EnumMap +import qualified Language.Parser.Ptera.Data.HFList as HFList + + +type T start nonTerminal terminal elem varDoc altDoc action = + GrammarT start nonTerminal terminal elem varDoc altDoc action + +type GrammarT start nonTerminal terminal elem varDoc altDoc action = + StateT (Context start nonTerminal terminal elem varDoc altDoc action) + +data Context start nonTerminal terminal elem varDoc altDoc action = Context + { ctxStarts :: EnumMap.EnumMap start nonTerminal + , ctxRules :: EnumMap.EnumMap nonTerminal (RuleExpr nonTerminal terminal elem altDoc action) + , ctxDisplayNonTerminals :: EnumMap.EnumMap nonTerminal varDoc + } + +fixGrammarT :: Monad m + => GrammarT start nonTerminal terminal elem varDoc altDoc action m () + -> m (FixedGrammar start nonTerminal terminal elem varDoc altDoc action) +fixGrammarT builder = do + finalCtx <- execStateT builder initialCtx + pure do fromCtx finalCtx + where + initialCtx = Context + { ctxStarts = EnumMap.empty + , ctxRules = EnumMap.empty + , ctxDisplayNonTerminals = EnumMap.empty + } + + fromCtx ctx = FixedGrammar + { grammarStarts = ctxStarts ctx + , grammarRules = ctxRules ctx + , grammarDisplayNonTerminals = ctxDisplayNonTerminals ctx + } + +data FixedGrammar start nonTerminal terminal elem varDoc altDoc action = FixedGrammar + { grammarStarts :: EnumMap.EnumMap start nonTerminal + , grammarRules :: EnumMap.EnumMap nonTerminal (RuleExpr nonTerminal terminal elem altDoc action) + , grammarDisplayNonTerminals :: EnumMap.EnumMap nonTerminal varDoc + } + +data Action (action :: [Type] -> Type -> Type) where + Action :: action us a -> Action action + +data RuleExpr nonTerminal terminal elem altDoc action where + RuleExpr + :: [Alt nonTerminal terminal elem altDoc action a] + -> RuleExpr nonTerminal terminal elem altDoc action + +data Alt nonTerminal terminal elem altDoc action a where + Alt :: Expr nonTerminal terminal elem us -> altDoc -> action us a + -> Alt nonTerminal terminal elem altDoc action a + +type Expr nonTerminal terminal elem = HFList.T (Unit nonTerminal terminal elem) + +data Unit nonTerminal terminal elem u where + UnitToken :: terminal -> Unit nonTerminal terminal elem elem + UnitVar :: nonTerminal -> Unit nonTerminal terminal elem u + +initialT :: Enum start => Monad m + => start -> nonTerminal + -> GrammarT start nonTerminal terminal elem varDoc altDoc action m () +initialT s v = modify' \ctx -> ctx + { + ctxStarts = EnumMap.insert s v + do ctxStarts ctx + } + +ruleT :: Enum nonTerminal => Monad m + => nonTerminal -> varDoc -> RuleExpr nonTerminal terminal elem altDoc action + -> GrammarT start nonTerminal terminal elem varDoc altDoc action m () +ruleT v d e = modify' \ctx -> ctx + { ctxRules = EnumMap.insert v e + do ctxRules ctx + , ctxDisplayNonTerminals = EnumMap.insert v d + do ctxDisplayNonTerminals ctx + } diff --git a/test/doctest/Doctest.hs b/test/doctest/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest/Doctest.hs @@ -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 diff --git a/test/spec/HSpecDriver.hs b/test/spec/HSpecDriver.hs new file mode 100644 --- /dev/null +++ b/test/spec/HSpecDriver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}