packages feed

ptera-core (empty) → 0.1.0.0

raw patch · 28 files changed

+2494/−0 lines, 28 filesdep +QuickCheckdep +arraydep +basebuild-type:Customsetup-changed

Dependencies added: QuickCheck, array, base, containers, doctest, enummapset-th, hashable, hspec, membership, ptera-core, transformers, unordered-containers

Files

+ 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,3 @@+# Ptera Core: A Generator for Parsers++[![Hackage](https://img.shields.io/hackage/v/ptera-core.svg)](https://hackage.haskell.org/package/ptera-core)
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import           Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctest"
+ ptera-core.cabal view
@@ -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,
+ src/Language/Parser/Ptera/Data/Alignable.hs view
@@ -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
+ src/Language/Parser/Ptera/Data/Alignable/Array.hs view
@@ -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
+ src/Language/Parser/Ptera/Data/Alignable/Map.hs view
@@ -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
+ src/Language/Parser/Ptera/Data/Alignable/Set.hs view
@@ -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
+ src/Language/Parser/Ptera/Data/HFList.hs view
@@ -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
+ src/Language/Parser/Ptera/Data/IntMap/GreaterRestriction.hs view
@@ -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
+ src/Language/Parser/Ptera/Data/Symbolic/IntMap.hs view
@@ -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
+ src/Language/Parser/Ptera/Data/Symbolic/IntSet.hs view
@@ -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
+ src/Language/Parser/Ptera/Machine/LAPEG.hs view
@@ -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
+ src/Language/Parser/Ptera/Machine/LAPEG/Builder.hs view
@@ -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+    }
+ src/Language/Parser/Ptera/Machine/PEG.hs view
@@ -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
+ src/Language/Parser/Ptera/Machine/PEG/Builder.hs view
@@ -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+    }
+ src/Language/Parser/Ptera/Machine/SRB.hs view
@@ -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)
+ src/Language/Parser/Ptera/Machine/SRB/Builder.hs view
@@ -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+    }
+ src/Language/Parser/Ptera/Pipeline/Grammar2PEG.hs view
@@ -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
+ src/Language/Parser/Ptera/Pipeline/LAPEG2SRB.hs view
@@ -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
+ src/Language/Parser/Ptera/Pipeline/PEG2LAPEG.hs view
@@ -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
+ src/Language/Parser/Ptera/Prelude.hs view
@@ -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
+ src/Language/Parser/Ptera/Prelude/Alias.hs view
@@ -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
+ src/Language/Parser/Ptera/Prelude/Core.hs view
@@ -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, ($))
+ src/Language/Parser/Ptera/Syntax/Grammar.hs view
@@ -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+    }
+ 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 #-}