{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Grammar.Sequitur
-- Copyright   :  (c) Masahiro Sakai 2024
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- /SEQUITUR/ is a linear-time, online algorithm for producing a context-free
-- grammar from an input sequence. The resulting grammar is a compact representation
-- of the original sequence and can be used for data compression.
--
-- Example:
--
--   - Input string: @abcabcabcabcabc@
--
--   - Resulting grammar
--
--       - @S@ → @AAB@
--
--       - @A@ → @BB@
--
--       - @B@ → @abc@
--
-- /SEQUITUR/ consumes input symbols one-by-one and appends each symbol at the end of the
-- grammar's start production (@S@ in the above example), then substitutes repeating
-- patterns in the given sequence with new rules. /SEQUITUR/ maintains two invariants:
--
--   [/Digram Uniqueness/]: /SEQUITUR/ ensures that no digram
--   (a.k.a. bigram) occurs more than once in the grammar. If a digram
--   (e.g. @ab@) occurs twice, SEQUITUR introduces a fresh non-terminal
--   symbol (e.g. @M@) and a rule (e.g. @M@ → @ab@) and replaces the
--   original occurrences with the newly introduced non-terminal symbol.
--   One exception is the cases where two occurrences overlap.
--
--   [/Rule Utility/]: If a non-terminal symbol occurs only once,
--   /SEQUITUR/ removes the associated rule and substitutes the occurrence
--   with the right-hand side of the rule.
--
-- References:
--
--   - [Sequitur algorithm - Wikipedia](https://en.m.wikipedia.org/wiki/Sequitur_algorithm)
--
--   - [sequitur.info](http://www.sequitur.info/)
--
--   - Nevill-Manning, C.G. and Witten, I.H. (1997) "[Identifying
--     Hierarchical Structure in Sequences: A linear-time
--     algorithm](https://doi.org/10.1613/jair.374)," Journal of
--     Artificial Intelligence Research, 7, 67-82.
--
-----------------------------------------------------------------------------
module Language.Grammar.Sequitur
  (
  -- * Basic type definition
    Grammar (..)
  , Symbol (..)
  , NonTerminalSymbol
  , IsTerminalSymbol

  -- * Construction

  -- ** High-level API
  --
  -- | Use 'encode' if the entire sequence is given at once and you
  -- only need to create a single grammar from it.
  , encode

  -- ** Low-level monadic API
  --
  -- | Use these low-level monadic API if the input sequence is given
  -- incrementally, or you want to repeatedly construct grammars with
  -- newly added inputs.
  , Builder
  , newBuilder
  , add
  , build

  -- * Conversion to other types
  , decode
  , decodeToSeq
  , decodeToMonoid
  , decodeNonTerminalsToMonoid
  ) where

import Control.Exception
import Control.Monad
import Control.Monad.Primitive
import Control.Monad.ST
import Data.Either
import qualified Data.Foldable as F
import Data.Function (on)
import Data.Hashable
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Primitive.MutVar
#if MIN_VERSION_primitive(0,8,0)
import Data.Primitive.PrimVar
#endif
import qualified Data.HashTable.Class as H (toList)
import qualified Data.HashTable.ST.Cuckoo as H
import Data.Maybe
import Data.Semigroup (Endo (..))
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.String (IsString (..))
import GHC.Generics (Generic)
#if MIN_VERSION_base(4,17,0)
import qualified GHC.IsList as IsList (IsList (..))
#else
import qualified GHC.Exts as IsList (IsList (..))
#endif
import GHC.Stack

#if !MIN_VERSION_primitive(0,8,0)

type PrimVar s a = MutVar s a

{-# INLINE newPrimVar #-}
newPrimVar :: PrimMonad m => a -> m (PrimVar (PrimState m) a)
newPrimVar = newMutVar

{-# INLINE readPrimVar #-}
readPrimVar :: PrimMonad m => PrimVar (PrimState m) a -> m a
readPrimVar = readMutVar

{-# INLINE modifyPrimVar #-}
modifyPrimVar :: PrimMonad m => PrimVar (PrimState m) a -> (a -> a) -> m ()
modifyPrimVar = modifyMutVar'

#endif

-- -------------------------------------------------------------------

sanityCheck :: Bool
sanityCheck :: Bool
sanityCheck = Bool
False

-- -------------------------------------------------------------------

-- | Non-terminal symbols are represented by 'Int'.
--
-- The number @0@ is reserved for the start symbol of the grammar.
type NonTerminalSymbol = Int

-- | Internal alias of 'NonTerminalSymbol'
type RuleId = NonTerminalSymbol

-- | A symbol is either a terminal symbol (from a user-specified type)
-- or a non-terminal symbol.
data Symbol a
  = NonTerminal !NonTerminalSymbol
  | Terminal a
  deriving (Symbol a -> Symbol a -> Bool
(Symbol a -> Symbol a -> Bool)
-> (Symbol a -> Symbol a -> Bool) -> Eq (Symbol a)
forall a. Eq a => Symbol a -> Symbol a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Symbol a -> Symbol a -> Bool
== :: Symbol a -> Symbol a -> Bool
$c/= :: forall a. Eq a => Symbol a -> Symbol a -> Bool
/= :: Symbol a -> Symbol a -> Bool
Eq, Eq (Symbol a)
Eq (Symbol a) =>
(Symbol a -> Symbol a -> Ordering)
-> (Symbol a -> Symbol a -> Bool)
-> (Symbol a -> Symbol a -> Bool)
-> (Symbol a -> Symbol a -> Bool)
-> (Symbol a -> Symbol a -> Bool)
-> (Symbol a -> Symbol a -> Symbol a)
-> (Symbol a -> Symbol a -> Symbol a)
-> Ord (Symbol a)
Symbol a -> Symbol a -> Bool
Symbol a -> Symbol a -> Ordering
Symbol a -> Symbol a -> Symbol a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Symbol a)
forall a. Ord a => Symbol a -> Symbol a -> Bool
forall a. Ord a => Symbol a -> Symbol a -> Ordering
forall a. Ord a => Symbol a -> Symbol a -> Symbol a
$ccompare :: forall a. Ord a => Symbol a -> Symbol a -> Ordering
compare :: Symbol a -> Symbol a -> Ordering
$c< :: forall a. Ord a => Symbol a -> Symbol a -> Bool
< :: Symbol a -> Symbol a -> Bool
$c<= :: forall a. Ord a => Symbol a -> Symbol a -> Bool
<= :: Symbol a -> Symbol a -> Bool
$c> :: forall a. Ord a => Symbol a -> Symbol a -> Bool
> :: Symbol a -> Symbol a -> Bool
$c>= :: forall a. Ord a => Symbol a -> Symbol a -> Bool
>= :: Symbol a -> Symbol a -> Bool
$cmax :: forall a. Ord a => Symbol a -> Symbol a -> Symbol a
max :: Symbol a -> Symbol a -> Symbol a
$cmin :: forall a. Ord a => Symbol a -> Symbol a -> Symbol a
min :: Symbol a -> Symbol a -> Symbol a
Ord, NonTerminalSymbol -> Symbol a -> ShowS
[Symbol a] -> ShowS
Symbol a -> String
(NonTerminalSymbol -> Symbol a -> ShowS)
-> (Symbol a -> String) -> ([Symbol a] -> ShowS) -> Show (Symbol a)
forall a. Show a => NonTerminalSymbol -> Symbol a -> ShowS
forall a. Show a => [Symbol a] -> ShowS
forall a. Show a => Symbol a -> String
forall a.
(NonTerminalSymbol -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => NonTerminalSymbol -> Symbol a -> ShowS
showsPrec :: NonTerminalSymbol -> Symbol a -> ShowS
$cshow :: forall a. Show a => Symbol a -> String
show :: Symbol a -> String
$cshowList :: forall a. Show a => [Symbol a] -> ShowS
showList :: [Symbol a] -> ShowS
Show, (forall x. Symbol a -> Rep (Symbol a) x)
-> (forall x. Rep (Symbol a) x -> Symbol a) -> Generic (Symbol a)
forall x. Rep (Symbol a) x -> Symbol a
forall x. Symbol a -> Rep (Symbol a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Symbol a) x -> Symbol a
forall a x. Symbol a -> Rep (Symbol a) x
$cfrom :: forall a x. Symbol a -> Rep (Symbol a) x
from :: forall x. Symbol a -> Rep (Symbol a) x
$cto :: forall a x. Rep (Symbol a) x -> Symbol a
to :: forall x. Rep (Symbol a) x -> Symbol a
Generic)

instance (Hashable a) => Hashable (Symbol a)

-- | @since 0.2.0.0
instance Functor Symbol where
  fmap :: forall a b. (a -> b) -> Symbol a -> Symbol b
fmap a -> b
_ (NonTerminal NonTerminalSymbol
rid) = NonTerminalSymbol -> Symbol b
forall a. NonTerminalSymbol -> Symbol a
NonTerminal NonTerminalSymbol
rid
  fmap a -> b
f (Terminal a
a) = b -> Symbol b
forall a. a -> Symbol a
Terminal (a -> b
f a
a)

type Digram a = (Symbol a, Symbol a)

-- | Since a grammar generated by /SEQUITUR/ has exactly one rule for
-- each non-terminal symbol, a grammar is represented as a mapping
-- from non-terminal symbols (left-hand sides of the rules) to
-- sequences of symbols (right-hand side of the rules).
--
-- For example, a grammar
--
--   - @0@ → @1 1 2@
--
--   - @1@ → @2 2@
--
--   - @2@ → @a b c@
--
-- is represented as
--
-- @
-- Grammar (fromList
--   [ (0, [NonTerminal 1, NonTerminal 1, NonTerminal 2])
--   , (1, [NonTerminal 2, NonTerminal 2])
--   , (2, [Terminal \'a\', Terminal \'b\', Terminal \'c\'])
--   ])
-- @
--
-- Since a grammar generated by /SEQUITUR/ produces exactly one
-- sequence, we can identify the grammar with the produced
-- sequence. Therefore, 'Grammar' type is an instance of 'Foldable',
-- 'IsList.IsList', and 'IsString'.
newtype Grammar a = Grammar {forall a. Grammar a -> IntMap [Symbol a]
unGrammar :: IntMap [Symbol a]}
  deriving (Grammar a -> Grammar a -> Bool
(Grammar a -> Grammar a -> Bool)
-> (Grammar a -> Grammar a -> Bool) -> Eq (Grammar a)
forall a. Eq a => Grammar a -> Grammar a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Grammar a -> Grammar a -> Bool
== :: Grammar a -> Grammar a -> Bool
$c/= :: forall a. Eq a => Grammar a -> Grammar a -> Bool
/= :: Grammar a -> Grammar a -> Bool
Eq, NonTerminalSymbol -> Grammar a -> ShowS
[Grammar a] -> ShowS
Grammar a -> String
(NonTerminalSymbol -> Grammar a -> ShowS)
-> (Grammar a -> String)
-> ([Grammar a] -> ShowS)
-> Show (Grammar a)
forall a. Show a => NonTerminalSymbol -> Grammar a -> ShowS
forall a. Show a => [Grammar a] -> ShowS
forall a. Show a => Grammar a -> String
forall a.
(NonTerminalSymbol -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => NonTerminalSymbol -> Grammar a -> ShowS
showsPrec :: NonTerminalSymbol -> Grammar a -> ShowS
$cshow :: forall a. Show a => Grammar a -> String
show :: Grammar a -> String
$cshowList :: forall a. Show a => [Grammar a] -> ShowS
showList :: [Grammar a] -> ShowS
Show)

-- | @since 0.2.0.0
instance Functor Grammar where
  fmap :: forall a b. (a -> b) -> Grammar a -> Grammar b
fmap a -> b
f (Grammar IntMap [Symbol a]
m) = IntMap [Symbol b] -> Grammar b
forall a. IntMap [Symbol a] -> Grammar a
Grammar (([Symbol a] -> [Symbol b])
-> IntMap [Symbol a] -> IntMap [Symbol b]
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Symbol a -> Symbol b) -> [Symbol a] -> [Symbol b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Symbol a -> Symbol b
forall a b. (a -> b) -> Symbol a -> Symbol b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) IntMap [Symbol a]
m)

-- | @since 0.2.0.0
instance Foldable Grammar where
  foldMap :: forall m a. Monoid m => (a -> m) -> Grammar a -> m
foldMap = (a -> m) -> Grammar a -> m
forall m a. (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> m
decodeToMonoid

-- | @since 0.2.0.0
instance IsTerminalSymbol a => IsList.IsList (Grammar a) where
  type Item (Grammar a) = a
  fromList :: [Item (Grammar a)] -> Grammar a
fromList = [a] -> Grammar a
[Item (Grammar a)] -> Grammar a
forall a. IsTerminalSymbol a => [a] -> Grammar a
encode
  toList :: Grammar a -> [Item (Grammar a)]
toList = Grammar a -> [a]
Grammar a -> [Item (Grammar a)]
forall a. HasCallStack => Grammar a -> [a]
decode

-- | @since 0.2.0.0
instance  IsString (Grammar Char) where
  fromString :: String -> Grammar Char
fromString = String -> Grammar Char
forall a. IsTerminalSymbol a => [a] -> Grammar a
encode

-- | @IsTerminalSymbol@ is a class synonym for absorbing the difference
-- between @hashable@ @<1.4.0.0@ and @>=1.4.0.0@.
--
-- @hashable-1.4.0.0@ makes 'Eq' be a superclass of 'Hashable'.
-- Therefore we define
--
-- @
-- type IsTerminalSymbol a = Hashable a
-- @
--
-- on @hashable >=1.4.0.0@, while we define
--
-- @
-- type IsTerminalSymbol a = (Eq a, Hashable a)
-- @
--
-- on @hashable <1.4.0.0@.
--
-- Also, developers can temporarily add other classes (e.g. 'Show') to
-- ease debugging.
#if MIN_VERSION_hashable(1,4,0)
type IsTerminalSymbol a = Hashable a
#else
type IsTerminalSymbol a = (Eq a, Hashable a)
#endif

-- -------------------------------------------------------------------

data Node s a
  = Node
  { forall s a. Node s a -> MutVar s (Node s a)
nodePrev :: {-# UNPACK #-} !(MutVar s (Node s a))
  , forall s a. Node s a -> MutVar s (Node s a)
nodeNext :: {-# UNPACK #-} !(MutVar s (Node s a))
  , forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData :: Either RuleId (Symbol a)
  } deriving ((forall x. Node s a -> Rep (Node s a) x)
-> (forall x. Rep (Node s a) x -> Node s a) -> Generic (Node s a)
forall x. Rep (Node s a) x -> Node s a
forall x. Node s a -> Rep (Node s a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s a x. Rep (Node s a) x -> Node s a
forall s a x. Node s a -> Rep (Node s a) x
$cfrom :: forall s a x. Node s a -> Rep (Node s a) x
from :: forall x. Node s a -> Rep (Node s a) x
$cto :: forall s a x. Rep (Node s a) x -> Node s a
to :: forall x. Rep (Node s a) x -> Node s a
Generic)

instance Eq (Node s a) where
  == :: Node s a -> Node s a -> Bool
(==) = MutVar s (Node s a) -> MutVar s (Node s a) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (MutVar s (Node s a) -> MutVar s (Node s a) -> Bool)
-> (Node s a -> MutVar s (Node s a))
-> Node s a
-> Node s a
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Node s a -> MutVar s (Node s a)
forall s a. Node s a -> MutVar s (Node s a)
nodePrev

isGuardNode :: Node s a -> Bool
isGuardNode :: forall s a. Node s a -> Bool
isGuardNode Node s a
s = Either NonTerminalSymbol (Symbol a) -> Bool
forall a b. Either a b -> Bool
isLeft (Either NonTerminalSymbol (Symbol a) -> Bool)
-> Either NonTerminalSymbol (Symbol a) -> Bool
forall a b. (a -> b) -> a -> b
$ Node s a -> Either NonTerminalSymbol (Symbol a)
forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData Node s a
s

nodeSymbolMaybe :: Node s a -> Maybe (Symbol a)
nodeSymbolMaybe :: forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
node =
  case Node s a -> Either NonTerminalSymbol (Symbol a)
forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData Node s a
node of
    Left NonTerminalSymbol
_ -> Maybe (Symbol a)
forall a. Maybe a
Nothing
    Right Symbol a
sym -> Symbol a -> Maybe (Symbol a)
forall a. a -> Maybe a
Just Symbol a
sym

nodeSymbol :: HasCallStack => Node s a -> Symbol a
nodeSymbol :: forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node =
  case Node s a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
node of
    Maybe (Symbol a)
Nothing -> String -> Symbol a
forall a. HasCallStack => String -> a
error String
"nodeSymbol is called for guard node"
    Just Symbol a
sym -> Symbol a
sym

ruleOfGuardNode :: Node s a -> Maybe RuleId
ruleOfGuardNode :: forall s a. Node s a -> Maybe NonTerminalSymbol
ruleOfGuardNode Node s a
node =
  case Node s a -> Either NonTerminalSymbol (Symbol a)
forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData Node s a
node of
    Left NonTerminalSymbol
rule -> NonTerminalSymbol -> Maybe NonTerminalSymbol
forall a. a -> Maybe a
Just NonTerminalSymbol
rule
    Right Symbol a
_ -> Maybe NonTerminalSymbol
forall a. Maybe a
Nothing

getPrev :: Node s a -> ST s (Node s a)
getPrev :: forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
node = MutVar (PrimState (ST s)) (Node s a) -> ST s (Node s a)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar (Node s a -> MutVar s (Node s a)
forall s a. Node s a -> MutVar s (Node s a)
nodePrev Node s a
node)

getNext :: Node s a -> ST s (Node s a)
getNext :: forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node = MutVar (PrimState (ST s)) (Node s a) -> ST s (Node s a)
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar (Node s a -> MutVar s (Node s a)
forall s a. Node s a -> MutVar s (Node s a)
nodeNext Node s a
node)

setPrev :: Node s a -> Node s a -> ST s ()
setPrev :: forall s a. Node s a -> Node s a -> ST s ()
setPrev Node s a
node Node s a
prev = MutVar (PrimState (ST s)) (Node s a) -> Node s a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar (Node s a -> MutVar s (Node s a)
forall s a. Node s a -> MutVar s (Node s a)
nodePrev Node s a
node) Node s a
prev

setNext :: Node s a -> Node s a -> ST s ()
setNext :: forall s a. Node s a -> Node s a -> ST s ()
setNext Node s a
node Node s a
next = MutVar (PrimState (ST s)) (Node s a) -> Node s a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar (Node s a -> MutVar s (Node s a)
forall s a. Node s a -> MutVar s (Node s a)
nodeNext Node s a
node) Node s a
next

mkGuardNode :: RuleId -> ST s (Node s a)
mkGuardNode :: forall s a. NonTerminalSymbol -> ST s (Node s a)
mkGuardNode NonTerminalSymbol
rid = do
  MutVar s (Node s a)
prevRef <- Node s a -> ST s (MutVar (PrimState (ST s)) (Node s a))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Node s a
forall a. HasCallStack => a
undefined
  MutVar s (Node s a)
nextRef <- Node s a -> ST s (MutVar (PrimState (ST s)) (Node s a))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Node s a
forall a. HasCallStack => a
undefined
  let node :: Node s a
node = MutVar s (Node s a)
-> MutVar s (Node s a)
-> Either NonTerminalSymbol (Symbol a)
-> Node s a
forall s a.
MutVar s (Node s a)
-> MutVar s (Node s a)
-> Either NonTerminalSymbol (Symbol a)
-> Node s a
Node MutVar s (Node s a)
prevRef MutVar s (Node s a)
nextRef (NonTerminalSymbol -> Either NonTerminalSymbol (Symbol a)
forall a b. a -> Either a b
Left NonTerminalSymbol
rid)
  MutVar (PrimState (ST s)) (Node s a) -> Node s a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (Node s a)
MutVar (PrimState (ST s)) (Node s a)
prevRef Node s a
node
  MutVar (PrimState (ST s)) (Node s a) -> Node s a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar s (Node s a)
MutVar (PrimState (ST s)) (Node s a)
nextRef Node s a
node
  Node s a -> ST s (Node s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Node s a
node

-- -------------------------------------------------------------------

data Rule s a
  = Rule
  { forall s a. Rule s a -> NonTerminalSymbol
ruleId :: {-# UNPACK #-} !RuleId
  , forall s a. Rule s a -> Node s a
ruleGuardNode :: !(Node s a)
  , forall s a. Rule s a -> PrimVar s NonTerminalSymbol
ruleRefCounter :: {-# UNPACK #-} !(PrimVar s Int)
  }

instance Eq (Rule s a) where
  == :: Rule s a -> Rule s a -> Bool
(==) = NonTerminalSymbol -> NonTerminalSymbol -> Bool
forall a. Eq a => a -> a -> Bool
(==) (NonTerminalSymbol -> NonTerminalSymbol -> Bool)
-> (Rule s a -> NonTerminalSymbol) -> Rule s a -> Rule s a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Rule s a -> NonTerminalSymbol
forall s a. Rule s a -> NonTerminalSymbol
ruleId

instance Hashable (Rule s a) where
  hashWithSalt :: NonTerminalSymbol -> Rule s a -> NonTerminalSymbol
hashWithSalt NonTerminalSymbol
salt Rule s a
rule = NonTerminalSymbol -> NonTerminalSymbol -> NonTerminalSymbol
forall a. Hashable a => NonTerminalSymbol -> a -> NonTerminalSymbol
hashWithSalt NonTerminalSymbol
salt (Rule s a -> NonTerminalSymbol
forall s a. Rule s a -> NonTerminalSymbol
ruleId Rule s a
rule)

getFirstNodeOfRule :: Rule s a -> ST s (Node s a)
getFirstNodeOfRule :: forall s a. Rule s a -> ST s (Node s a)
getFirstNodeOfRule Rule s a
rule = Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext (Rule s a -> Node s a
forall s a. Rule s a -> Node s a
ruleGuardNode Rule s a
rule)

getLastNodeOfRule :: Rule s a -> ST s (Node s a)
getLastNodeOfRule :: forall s a. Rule s a -> ST s (Node s a)
getLastNodeOfRule Rule s a
rule = Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev (Rule s a -> Node s a
forall s a. Rule s a -> Node s a
ruleGuardNode Rule s a
rule)

mkRule :: RuleId -> ST s (Rule s a)
mkRule :: forall s a. NonTerminalSymbol -> ST s (Rule s a)
mkRule NonTerminalSymbol
rid = do
  Node s a
g <- NonTerminalSymbol -> ST s (Node s a)
forall s a. NonTerminalSymbol -> ST s (Node s a)
mkGuardNode NonTerminalSymbol
rid
  PrimVar s NonTerminalSymbol
refCounter <- NonTerminalSymbol
-> ST s (PrimVar (PrimState (ST s)) NonTerminalSymbol)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
a -> m (PrimVar (PrimState m) a)
newPrimVar NonTerminalSymbol
0
  Rule s a -> ST s (Rule s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rule s a -> ST s (Rule s a)) -> Rule s a -> ST s (Rule s a)
forall a b. (a -> b) -> a -> b
$ NonTerminalSymbol
-> Node s a -> PrimVar s NonTerminalSymbol -> Rule s a
forall s a.
NonTerminalSymbol
-> Node s a -> PrimVar s NonTerminalSymbol -> Rule s a
Rule NonTerminalSymbol
rid Node s a
g PrimVar s NonTerminalSymbol
refCounter

newRule :: Builder s a -> ST s (Rule s a)
newRule :: forall s a. Builder s a -> ST s (Rule s a)
newRule Builder s a
s = do
  NonTerminalSymbol
rid <- PrimVar (PrimState (ST s)) NonTerminalSymbol
-> ST s NonTerminalSymbol
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> m a
readPrimVar (Builder s a -> PrimVar s NonTerminalSymbol
forall s a. Builder s a -> PrimVar s NonTerminalSymbol
sRuleIdCounter Builder s a
s)
  PrimVar (PrimState (ST s)) NonTerminalSymbol
-> (NonTerminalSymbol -> NonTerminalSymbol) -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> (a -> a) -> m ()
modifyPrimVar (Builder s a -> PrimVar s NonTerminalSymbol
forall s a. Builder s a -> PrimVar s NonTerminalSymbol
sRuleIdCounter Builder s a
s) (NonTerminalSymbol -> NonTerminalSymbol -> NonTerminalSymbol
forall a. Num a => a -> a -> a
+ NonTerminalSymbol
1)
  Rule s a
rule <- NonTerminalSymbol -> ST s (Rule s a)
forall s a. NonTerminalSymbol -> ST s (Rule s a)
mkRule NonTerminalSymbol
rid
  HashTable s NonTerminalSymbol (Rule s a)
-> NonTerminalSymbol -> Rule s a -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules Builder s a
s) NonTerminalSymbol
rid Rule s a
rule
  Rule s a -> ST s (Rule s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Rule s a
rule

-- -------------------------------------------------------------------

-- | 'Builder' denotes an internal state of the /SEQUITUR/ algorithm.
data Builder s a
  = Builder
  { forall s a. Builder s a -> Rule s a
sRoot :: !(Rule s a)
  , forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams :: !(H.HashTable s (Digram a) (Node s a))
  , forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules :: !(H.HashTable s RuleId (Rule s a))
  , forall s a. Builder s a -> PrimVar s NonTerminalSymbol
sRuleIdCounter :: {-# UNPACK #-} !(PrimVar s Int)
  , forall s a. Builder s a -> Node s a
sDummyNode :: !(Node s a)
  }

-- | Create a new 'Builder'.
newBuilder :: PrimMonad m => m (Builder (PrimState m) a)
newBuilder :: forall (m :: * -> *) a. PrimMonad m => m (Builder (PrimState m) a)
newBuilder = ST (PrimState m) (Builder (PrimState m) a)
-> m (Builder (PrimState m) a)
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) (Builder (PrimState m) a)
 -> m (Builder (PrimState m) a))
-> ST (PrimState m) (Builder (PrimState m) a)
-> m (Builder (PrimState m) a)
forall a b. (a -> b) -> a -> b
$ do
  Rule (PrimState m) a
root <- NonTerminalSymbol -> ST (PrimState m) (Rule (PrimState m) a)
forall s a. NonTerminalSymbol -> ST s (Rule s a)
mkRule NonTerminalSymbol
0
  HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
digrams <- ST
  (PrimState m)
  (HashTable (PrimState m) (Digram a) (Node (PrimState m) a))
forall s k v. ST s (HashTable s k v)
H.new
  HashTable (PrimState m) NonTerminalSymbol (Rule (PrimState m) a)
rules <- ST
  (PrimState m)
  (HashTable (PrimState m) NonTerminalSymbol (Rule (PrimState m) a))
forall s k v. ST s (HashTable s k v)
H.new
  PrimVar (PrimState m) NonTerminalSymbol
counter <- NonTerminalSymbol
-> ST
     (PrimState m)
     (PrimVar (PrimState (ST (PrimState m))) NonTerminalSymbol)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
a -> m (PrimVar (PrimState m) a)
newPrimVar NonTerminalSymbol
1

  MutVar (PrimState m) (Node (PrimState m) a)
prevRef <- Node (PrimState m) a
-> ST
     (PrimState m)
     (MutVar (PrimState (ST (PrimState m))) (Node (PrimState m) a))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Node (PrimState m) a
forall a. HasCallStack => a
undefined
  MutVar (PrimState m) (Node (PrimState m) a)
nextRef <- Node (PrimState m) a
-> ST
     (PrimState m)
     (MutVar (PrimState (ST (PrimState m))) (Node (PrimState m) a))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar Node (PrimState m) a
forall a. HasCallStack => a
undefined
  let dummyNode :: Node (PrimState m) a
dummyNode = MutVar (PrimState m) (Node (PrimState m) a)
-> MutVar (PrimState m) (Node (PrimState m) a)
-> Either NonTerminalSymbol (Symbol a)
-> Node (PrimState m) a
forall s a.
MutVar s (Node s a)
-> MutVar s (Node s a)
-> Either NonTerminalSymbol (Symbol a)
-> Node s a
Node MutVar (PrimState m) (Node (PrimState m) a)
prevRef MutVar (PrimState m) (Node (PrimState m) a)
nextRef (NonTerminalSymbol -> Either NonTerminalSymbol (Symbol a)
forall a b. a -> Either a b
Left NonTerminalSymbol
0)
  MutVar (PrimState (ST (PrimState m))) (Node (PrimState m) a)
-> Node (PrimState m) a -> ST (PrimState m) ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Node (PrimState m) a)
MutVar (PrimState (ST (PrimState m))) (Node (PrimState m) a)
prevRef Node (PrimState m) a
dummyNode
  MutVar (PrimState (ST (PrimState m))) (Node (PrimState m) a)
-> Node (PrimState m) a -> ST (PrimState m) ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Node (PrimState m) a)
MutVar (PrimState (ST (PrimState m))) (Node (PrimState m) a)
nextRef Node (PrimState m) a
dummyNode

  Builder (PrimState m) a
-> ST (PrimState m) (Builder (PrimState m) a)
forall a. a -> ST (PrimState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder (PrimState m) a
 -> ST (PrimState m) (Builder (PrimState m) a))
-> Builder (PrimState m) a
-> ST (PrimState m) (Builder (PrimState m) a)
forall a b. (a -> b) -> a -> b
$ Rule (PrimState m) a
-> HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
-> HashTable (PrimState m) NonTerminalSymbol (Rule (PrimState m) a)
-> PrimVar (PrimState m) NonTerminalSymbol
-> Node (PrimState m) a
-> Builder (PrimState m) a
forall s a.
Rule s a
-> HashTable s (Digram a) (Node s a)
-> HashTable s NonTerminalSymbol (Rule s a)
-> PrimVar s NonTerminalSymbol
-> Node s a
-> Builder s a
Builder Rule (PrimState m) a
root HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
digrams HashTable (PrimState m) NonTerminalSymbol (Rule (PrimState m) a)
rules PrimVar (PrimState m) NonTerminalSymbol
counter Node (PrimState m) a
dummyNode

getRule :: HasCallStack => Builder s a -> RuleId -> ST s (Rule s a)
getRule :: forall s a.
HasCallStack =>
Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
getRule Builder s a
s NonTerminalSymbol
rid = do
  Maybe (Rule s a)
ret <- HashTable s NonTerminalSymbol (Rule s a)
-> NonTerminalSymbol -> ST s (Maybe (Rule s a))
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
H.lookup (Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules Builder s a
s) NonTerminalSymbol
rid
  case Maybe (Rule s a)
ret of
    Maybe (Rule s a)
Nothing -> String -> ST s (Rule s a)
forall a. HasCallStack => String -> a
error String
"getRule: invalid rule id"
    Just Rule s a
rule -> Rule s a -> ST s (Rule s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Rule s a
rule

-- | Add a new symbol to the end of grammar's start production,
-- and perform normalization to keep the invariants of the /SEQUITUR/ algorithm.
add :: (PrimMonad m, IsTerminalSymbol a) => Builder (PrimState m) a -> a -> m ()
add :: forall (m :: * -> *) a.
(PrimMonad m, IsTerminalSymbol a) =>
Builder (PrimState m) a -> a -> m ()
add Builder (PrimState m) a
s a
a = ST (PrimState m) () -> m ()
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Node (PrimState m) a
lastNode <- Rule (PrimState m) a -> ST (PrimState m) (Node (PrimState m) a)
forall s a. Rule s a -> ST s (Node s a)
getLastNodeOfRule (Builder (PrimState m) a -> Rule (PrimState m) a
forall s a. Builder s a -> Rule s a
sRoot Builder (PrimState m) a
s)
  Node (PrimState m) a
_ <- Builder (PrimState m) a
-> Node (PrimState m) a
-> Symbol a
-> ST (PrimState m) (Node (PrimState m) a)
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
insertAfter Builder (PrimState m) a
s Node (PrimState m) a
lastNode (a -> Symbol a
forall a. a -> Symbol a
Terminal a
a)
  Bool
_ <- Builder (PrimState m) a
-> Node (PrimState m) a -> ST (PrimState m) Bool
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> ST s Bool
check Builder (PrimState m) a
s Node (PrimState m) a
lastNode
  Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sanityCheck (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ do
    Builder (PrimState m) a -> ST (PrimState m) ()
forall a s. IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable Builder (PrimState m) a
s
    Builder (PrimState m) a -> ST (PrimState m) ()
forall s a. Builder s a -> ST s ()
checkRefCount Builder (PrimState m) a
s

-- | Retrieve a grammar (as a persistent data structure) from the 'Builder'\'s internal state.
build :: (PrimMonad m) => Builder (PrimState m) a -> m (Grammar a)
build :: forall (m :: * -> *) a.
PrimMonad m =>
Builder (PrimState m) a -> m (Grammar a)
build Builder (PrimState m) a
s = ST (PrimState m) (Grammar a) -> m (Grammar a)
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) (Grammar a) -> m (Grammar a))
-> ST (PrimState m) (Grammar a) -> m (Grammar a)
forall a b. (a -> b) -> a -> b
$ do
  [Symbol a]
root <- Node (PrimState m) a -> ST (PrimState m) [Symbol a]
forall a s. Node s a -> ST s [Symbol a]
freezeGuardNode (Node (PrimState m) a -> ST (PrimState m) [Symbol a])
-> Node (PrimState m) a -> ST (PrimState m) [Symbol a]
forall a b. (a -> b) -> a -> b
$ Rule (PrimState m) a -> Node (PrimState m) a
forall s a. Rule s a -> Node s a
ruleGuardNode (Builder (PrimState m) a -> Rule (PrimState m) a
forall s a. Builder s a -> Rule s a
sRoot Builder (PrimState m) a
s)
  [(NonTerminalSymbol, Rule (PrimState m) a)]
xs <- HashTable (PrimState m) NonTerminalSymbol (Rule (PrimState m) a)
-> ST (PrimState m) [(NonTerminalSymbol, Rule (PrimState m) a)]
forall (h :: * -> * -> * -> *) s k v.
HashTable h =>
h s k v -> ST s [(k, v)]
H.toList (Builder (PrimState m) a
-> HashTable (PrimState m) NonTerminalSymbol (Rule (PrimState m) a)
forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules Builder (PrimState m) a
s)
  [(NonTerminalSymbol, [Symbol a])]
m <- [(NonTerminalSymbol, Rule (PrimState m) a)]
-> ((NonTerminalSymbol, Rule (PrimState m) a)
    -> ST (PrimState m) (NonTerminalSymbol, [Symbol a]))
-> ST (PrimState m) [(NonTerminalSymbol, [Symbol a])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(NonTerminalSymbol, Rule (PrimState m) a)]
xs (((NonTerminalSymbol, Rule (PrimState m) a)
  -> ST (PrimState m) (NonTerminalSymbol, [Symbol a]))
 -> ST (PrimState m) [(NonTerminalSymbol, [Symbol a])])
-> ((NonTerminalSymbol, Rule (PrimState m) a)
    -> ST (PrimState m) (NonTerminalSymbol, [Symbol a]))
-> ST (PrimState m) [(NonTerminalSymbol, [Symbol a])]
forall a b. (a -> b) -> a -> b
$ \(NonTerminalSymbol
rid, Rule (PrimState m) a
rule) -> do
    [Symbol a]
ys <- Node (PrimState m) a -> ST (PrimState m) [Symbol a]
forall a s. Node s a -> ST s [Symbol a]
freezeGuardNode (Rule (PrimState m) a -> Node (PrimState m) a
forall s a. Rule s a -> Node s a
ruleGuardNode Rule (PrimState m) a
rule)
    (NonTerminalSymbol, [Symbol a])
-> ST (PrimState m) (NonTerminalSymbol, [Symbol a])
forall a. a -> ST (PrimState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonTerminalSymbol
rid, [Symbol a]
ys)
  Grammar a -> ST (PrimState m) (Grammar a)
forall a. a -> ST (PrimState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Grammar a -> ST (PrimState m) (Grammar a))
-> Grammar a -> ST (PrimState m) (Grammar a)
forall a b. (a -> b) -> a -> b
$ IntMap [Symbol a] -> Grammar a
forall a. IntMap [Symbol a] -> Grammar a
Grammar (IntMap [Symbol a] -> Grammar a) -> IntMap [Symbol a] -> Grammar a
forall a b. (a -> b) -> a -> b
$ NonTerminalSymbol
-> [Symbol a] -> IntMap [Symbol a] -> IntMap [Symbol a]
forall a. NonTerminalSymbol -> a -> IntMap a -> IntMap a
IntMap.insert NonTerminalSymbol
0 [Symbol a]
root (IntMap [Symbol a] -> IntMap [Symbol a])
-> IntMap [Symbol a] -> IntMap [Symbol a]
forall a b. (a -> b) -> a -> b
$ [(NonTerminalSymbol, [Symbol a])] -> IntMap [Symbol a]
forall a. [(NonTerminalSymbol, a)] -> IntMap a
IntMap.fromList [(NonTerminalSymbol, [Symbol a])]
m

freezeGuardNode :: forall a s. Node s a -> ST s [Symbol a]
freezeGuardNode :: forall a s. Node s a -> ST s [Symbol a]
freezeGuardNode Node s a
g = [Symbol a] -> Node s a -> ST s [Symbol a]
f [] (Node s a -> ST s [Symbol a]) -> ST s (Node s a) -> ST s [Symbol a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
g
  where
    f :: [Symbol a] -> Node s a -> ST s [Symbol a]
    f :: [Symbol a] -> Node s a -> ST s [Symbol a]
f [Symbol a]
ret Node s a
node = do
      if Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
node then
        [Symbol a] -> ST s [Symbol a]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Symbol a]
ret
      else do
        Node s a
node' <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
node
        [Symbol a] -> Node s a -> ST s [Symbol a]
f (Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node Symbol a -> [Symbol a] -> [Symbol a]
forall a. a -> [a] -> [a]
: [Symbol a]
ret) Node s a
node'

-- -------------------------------------------------------------------

link :: IsTerminalSymbol a => Builder s a -> Node s a -> Node s a -> ST s ()
link :: forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Node s a -> ST s ()
link Builder s a
s Node s a
left Node s a
right = do
  Node s a
leftPrev <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
left
  Node s a
leftNext <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
left
  Node s a
rightPrev <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
right
  Node s a
rightNext <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
right

  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
leftNext) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
    Builder s a -> Node s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> ST s ()
deleteDigram Builder s a
s Node s a
left

    -- これが不要なのは何故?
    -- unless (isGuardNode rightPrev) $ deleteDigram s rightPrev

    case (Node s a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
rightPrev, Node s a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
right, Node s a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
rightNext) of
      (Just Symbol a
sym1, Just Symbol a
sym2, Just Symbol a
sym3) | Symbol a
sym1 Symbol a -> Symbol a -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol a
sym2 Bool -> Bool -> Bool
&& Symbol a
sym2 Symbol a -> Symbol a -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol a
sym3 ->
        HashTable s (Digram a) (Node s a)
-> Digram a -> Node s a -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) (Symbol a
sym2, Symbol a
sym3) Node s a
right
      (Maybe (Symbol a), Maybe (Symbol a), Maybe (Symbol a))
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    case (Node s a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
leftPrev, Node s a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
left, Node s a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node s a
leftNext) of
      (Just Symbol a
sym1, Just Symbol a
sym2, Just Symbol a
sym3) | Symbol a
sym1 Symbol a -> Symbol a -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol a
sym2 Bool -> Bool -> Bool
&& Symbol a
sym2 Symbol a -> Symbol a -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol a
sym3 ->
        HashTable s (Digram a) (Node s a)
-> Digram a -> Node s a -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) (Symbol a
sym1, Symbol a
sym2) Node s a
leftPrev
      (Maybe (Symbol a), Maybe (Symbol a), Maybe (Symbol a))
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  Node s a -> Node s a -> ST s ()
forall s a. Node s a -> Node s a -> ST s ()
setNext Node s a
left Node s a
right
  Node s a -> Node s a -> ST s ()
forall s a. Node s a -> Node s a -> ST s ()
setPrev Node s a
right Node s a
left

insertAfter :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
insertAfter :: forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
insertAfter Builder s a
s Node s a
node Symbol a
sym = do
  MutVar s (Node s a)
prevRef <- Node s a -> ST s (MutVar (PrimState (ST s)) (Node s a))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (Builder s a -> Node s a
forall s a. Builder s a -> Node s a
sDummyNode Builder s a
s)
  MutVar s (Node s a)
nextRef <- Node s a -> ST s (MutVar (PrimState (ST s)) (Node s a))
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar (Builder s a -> Node s a
forall s a. Builder s a -> Node s a
sDummyNode Builder s a
s)
  let newNode :: Node s a
newNode = MutVar s (Node s a)
-> MutVar s (Node s a)
-> Either NonTerminalSymbol (Symbol a)
-> Node s a
forall s a.
MutVar s (Node s a)
-> MutVar s (Node s a)
-> Either NonTerminalSymbol (Symbol a)
-> Node s a
Node MutVar s (Node s a)
prevRef MutVar s (Node s a)
nextRef (Symbol a -> Either NonTerminalSymbol (Symbol a)
forall a b. b -> Either a b
Right Symbol a
sym)

  Node s a
next <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node
  Builder s a -> Node s a -> Node s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Node s a -> ST s ()
link Builder s a
s Node s a
newNode Node s a
next
  Builder s a -> Node s a -> Node s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Node s a -> ST s ()
link Builder s a
s Node s a
node Node s a
newNode

  case Symbol a
sym of
    Terminal a
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    NonTerminal NonTerminalSymbol
rid -> do
      Rule s a
rule <- Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
forall s a.
HasCallStack =>
Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
getRule Builder s a
s NonTerminalSymbol
rid
      PrimVar (PrimState (ST s)) NonTerminalSymbol
-> (NonTerminalSymbol -> NonTerminalSymbol) -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> (a -> a) -> m ()
modifyPrimVar (Rule s a -> PrimVar s NonTerminalSymbol
forall s a. Rule s a -> PrimVar s NonTerminalSymbol
ruleRefCounter Rule s a
rule) (NonTerminalSymbol -> NonTerminalSymbol -> NonTerminalSymbol
forall a. Num a => a -> a -> a
+ NonTerminalSymbol
1)

  Node s a -> ST s (Node s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Node s a
newNode

deleteDigram :: IsTerminalSymbol a => Builder s a -> Node s a -> ST s ()
deleteDigram :: forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> ST s ()
deleteDigram Builder s a
s Node s a
n
  | Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
n = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
      Node s a
next <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
n
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
next) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
        ()
_ <- HashTable s (Digram a) (Node s a)
-> Digram a
-> (Maybe (Node s a) -> (Maybe (Node s a), ()))
-> ST s ()
forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
H.mutate (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) (Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
n, Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
next) ((Maybe (Node s a) -> (Maybe (Node s a), ())) -> ST s ())
-> (Maybe (Node s a) -> (Maybe (Node s a), ())) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \case
          Just Node s a
n' | Node s a
n Node s a -> Node s a -> Bool
forall a. Eq a => a -> a -> Bool
/= Node s a
n' -> (Node s a -> Maybe (Node s a)
forall a. a -> Maybe a
Just Node s a
n', ())
          Maybe (Node s a)
_ -> (Maybe (Node s a)
forall a. Maybe a
Nothing, ())
        () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check :: IsTerminalSymbol a => Builder s a -> Node s a -> ST s Bool
check :: forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> ST s Bool
check Builder s a
s Node s a
node
  | Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
node = Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool
otherwise = do
      Node s a
next <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node
      if Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
next then
        Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      else do
        Maybe (Node s a)
ret <- HashTable s (Digram a) (Node s a)
-> Digram a
-> (Maybe (Node s a) -> (Maybe (Node s a), Maybe (Node s a)))
-> ST s (Maybe (Node s a))
forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
H.mutate (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) (Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node, Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
next) ((Maybe (Node s a) -> (Maybe (Node s a), Maybe (Node s a)))
 -> ST s (Maybe (Node s a)))
-> (Maybe (Node s a) -> (Maybe (Node s a), Maybe (Node s a)))
-> ST s (Maybe (Node s a))
forall a b. (a -> b) -> a -> b
$ \case
          Maybe (Node s a)
Nothing -> (Node s a -> Maybe (Node s a)
forall a. a -> Maybe a
Just Node s a
node, Maybe (Node s a)
forall a. Maybe a
Nothing)
          Just Node s a
node' -> (Node s a -> Maybe (Node s a)
forall a. a -> Maybe a
Just Node s a
node', Node s a -> Maybe (Node s a)
forall a. a -> Maybe a
Just Node s a
node')
        case Maybe (Node s a)
ret of
          Maybe (Node s a)
Nothing -> Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Just Node s a
node' -> do
             Node s a
next' <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node'
             if Node s a
node Node s a -> Node s a -> Bool
forall a. Eq a => a -> a -> Bool
== Node s a
next' then
               Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
             else do
               Builder s a -> Node s a -> Node s a -> ST s ()
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Node s a -> ST s ()
match Builder s a
s Node s a
node Node s a
node'
               Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

match :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> Node s a -> ST s ()
match :: forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Node s a -> ST s ()
match Builder s a
s Node s a
ss Node s a
m = do
  Node s a
mPrev <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
m
  Node s a
mNext <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
m
  Node s a
mNextNext <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
mNext

  Rule s a
rule <- case Node s a -> Maybe NonTerminalSymbol
forall s a. Node s a -> Maybe NonTerminalSymbol
ruleOfGuardNode Node s a
mPrev of
    Just NonTerminalSymbol
rid | Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
mNextNext -> do
      Rule s a
rule <- Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
forall s a.
HasCallStack =>
Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
getRule Builder s a
s NonTerminalSymbol
rid
      Builder s a -> Node s a -> Rule s a -> ST s ()
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Rule s a -> ST s ()
substitute Builder s a
s Node s a
ss Rule s a
rule
      Rule s a -> ST s (Rule s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Rule s a
rule
    Maybe NonTerminalSymbol
_ -> do
      Rule s a
rule <- Builder s a -> ST s (Rule s a)
forall s a. Builder s a -> ST s (Rule s a)
newRule  Builder s a
s
      Node s a
ss2 <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
ss
      Node s a
lastNode <- Rule s a -> ST s (Node s a)
forall s a. Rule s a -> ST s (Node s a)
getLastNodeOfRule Rule s a
rule
      Node s a
node1 <- Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
insertAfter Builder s a
s Node s a
lastNode (Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
ss)
      Node s a
node2 <- Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
insertAfter Builder s a
s Node s a
node1 (Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
ss2)
      Builder s a -> Node s a -> Rule s a -> ST s ()
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Rule s a -> ST s ()
substitute Builder s a
s Node s a
m Rule s a
rule
      Builder s a -> Node s a -> Rule s a -> ST s ()
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Rule s a -> ST s ()
substitute Builder s a
s Node s a
ss Rule s a
rule
      HashTable s (Digram a) (Node s a)
-> Digram a -> Node s a -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) (Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node1, Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node2) Node s a
node1
      Rule s a -> ST s (Rule s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Rule s a
rule

  Node s a
firstNode <- Rule s a -> ST s (Node s a)
forall s a. Rule s a -> ST s (Node s a)
getFirstNodeOfRule Rule s a
rule
  case Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
firstNode of
    Terminal a
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    NonTerminal NonTerminalSymbol
rid -> do
      Rule s a
rule2 <- Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
forall s a.
HasCallStack =>
Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
getRule Builder s a
s NonTerminalSymbol
rid
      NonTerminalSymbol
freq <- PrimVar (PrimState (ST s)) NonTerminalSymbol
-> ST s NonTerminalSymbol
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> m a
readPrimVar (Rule s a -> PrimVar s NonTerminalSymbol
forall s a. Rule s a -> PrimVar s NonTerminalSymbol
ruleRefCounter Rule s a
rule2)
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NonTerminalSymbol
freq NonTerminalSymbol -> NonTerminalSymbol -> Bool
forall a. Eq a => a -> a -> Bool
== NonTerminalSymbol
1) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ Builder s a -> Node s a -> Rule s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Rule s a -> ST s ()
expand Builder s a
s Node s a
firstNode Rule s a
rule2

  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sanityCheck (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
    let loop :: Node s a -> ST s ()
loop Node s a
node
          | Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
node = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | Bool
otherwise = do
              case Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node of
                Terminal a
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                NonTerminal NonTerminalSymbol
rid -> do
                  Rule s a
rule2 <- Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
forall s a.
HasCallStack =>
Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
getRule Builder s a
s NonTerminalSymbol
rid
                  NonTerminalSymbol
freq <- PrimVar (PrimState (ST s)) NonTerminalSymbol
-> ST s NonTerminalSymbol
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> m a
readPrimVar (Rule s a -> PrimVar s NonTerminalSymbol
forall s a. Rule s a -> PrimVar s NonTerminalSymbol
ruleRefCounter Rule s a
rule2)
                  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NonTerminalSymbol
freq NonTerminalSymbol -> NonTerminalSymbol -> Bool
forall a. Ord a => a -> a -> Bool
<= NonTerminalSymbol
1) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ String -> ST s ()
forall a. HasCallStack => String -> a
error String
"Sequitur.match: non-first node with refCount <= 1"
    Node s a -> ST s ()
loop (Node s a -> ST s ()) -> ST s (Node s a) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
firstNode

deleteNode :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> ST s ()
deleteNode :: forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> ST s ()
deleteNode Builder s a
s Node s a
node = do
  Bool -> ST s () -> ST s ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
node)) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Node s a
prev <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
node
  Node s a
next <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node
  Builder s a -> Node s a -> Node s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Node s a -> ST s ()
link Builder s a
s Node s a
prev Node s a
next
  Builder s a -> Node s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> ST s ()
deleteDigram Builder s a
s Node s a
node
  case Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node of
    Terminal a
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    NonTerminal NonTerminalSymbol
rid -> do
      Rule s a
rule <- Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
forall s a.
HasCallStack =>
Builder s a -> NonTerminalSymbol -> ST s (Rule s a)
getRule Builder s a
s NonTerminalSymbol
rid
      PrimVar (PrimState (ST s)) NonTerminalSymbol
-> (NonTerminalSymbol -> NonTerminalSymbol) -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> (a -> a) -> m ()
modifyPrimVar (Rule s a -> PrimVar s NonTerminalSymbol
forall s a. Rule s a -> PrimVar s NonTerminalSymbol
ruleRefCounter Rule s a
rule) (NonTerminalSymbol -> NonTerminalSymbol -> NonTerminalSymbol
forall a. Num a => a -> a -> a
subtract NonTerminalSymbol
1)

substitute :: (IsTerminalSymbol a, HasCallStack) => Builder s a -> Node s a -> Rule s a -> ST s ()
substitute :: forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Rule s a -> ST s ()
substitute Builder s a
s Node s a
node Rule s a
rule = do
  Node s a
prev <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
node
  Builder s a -> Node s a -> ST s ()
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> ST s ()
deleteNode Builder s a
s (Node s a -> ST s ()) -> ST s (Node s a) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
prev
  Builder s a -> Node s a -> ST s ()
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> ST s ()
deleteNode Builder s a
s (Node s a -> ST s ()) -> ST s (Node s a) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
prev
  Node s a
_ <- Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> Symbol a -> ST s (Node s a)
insertAfter Builder s a
s Node s a
prev (NonTerminalSymbol -> Symbol a
forall a. NonTerminalSymbol -> Symbol a
NonTerminal (Rule s a -> NonTerminalSymbol
forall s a. Rule s a -> NonTerminalSymbol
ruleId Rule s a
rule))
  Bool
ret <- Builder s a -> Node s a -> ST s Bool
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> ST s Bool
check Builder s a
s Node s a
prev
  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ret (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
    Node s a
next <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
prev
    Bool
_ <- Builder s a -> Node s a -> ST s Bool
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> ST s Bool
check Builder s a
s Node s a
next
    () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

expand :: IsTerminalSymbol a => Builder s a -> Node s a -> Rule s a -> ST s ()
expand :: forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Rule s a -> ST s ()
expand Builder s a
s Node s a
node Rule s a
rule = do
  Node s a
left <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
node
  Node s a
right <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node
  Builder s a -> Node s a -> ST s ()
forall a s.
(IsTerminalSymbol a, HasCallStack) =>
Builder s a -> Node s a -> ST s ()
deleteNode Builder s a
s Node s a
node

  Node s a
f <- Rule s a -> ST s (Node s a)
forall s a. Rule s a -> ST s (Node s a)
getFirstNodeOfRule Rule s a
rule
  Node s a
l <- Rule s a -> ST s (Node s a)
forall s a. Rule s a -> ST s (Node s a)
getLastNodeOfRule Rule s a
rule
  Builder s a -> Node s a -> Node s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Node s a -> ST s ()
link Builder s a
s Node s a
left Node s a
f
  Builder s a -> Node s a -> Node s a -> ST s ()
forall a s.
IsTerminalSymbol a =>
Builder s a -> Node s a -> Node s a -> ST s ()
link Builder s a
s Node s a
l Node s a
right

  Node s a
n <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
l
  let key :: Digram a
key = (Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
l, Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
n)
  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sanityCheck (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Node s a)
ret <- HashTable s (Digram a) (Node s a)
-> Digram a -> ST s (Maybe (Node s a))
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
H.lookup (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) Digram a
key
    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Node s a) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Node s a)
ret) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ String -> ST s ()
forall a. HasCallStack => String -> a
error String
"Sequitur.expand: the digram is already in the table"
  HashTable s (Digram a) (Node s a)
-> Digram a -> Node s a -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) Digram a
key Node s a
l
  HashTable s NonTerminalSymbol (Rule s a)
-> NonTerminalSymbol -> ST s ()
forall k s v. (Hashable k, Eq k) => HashTable s k v -> k -> ST s ()
H.delete (Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules Builder s a
s) (Rule s a -> NonTerminalSymbol
forall s a. Rule s a -> NonTerminalSymbol
ruleId Rule s a
rule)

-- -------------------------------------------------------------------

-- | Construct a grammar from a given sequence of symbols using /SEQUITUR/.
--
-- 'IsList.fromList' and 'fromString' can also be used.
encode :: IsTerminalSymbol a => [a] -> Grammar a
encode :: forall a. IsTerminalSymbol a => [a] -> Grammar a
encode [a]
xs = (forall s. ST s (Grammar a)) -> Grammar a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Grammar a)) -> Grammar a)
-> (forall s. ST s (Grammar a)) -> Grammar a
forall a b. (a -> b) -> a -> b
$ do
  Builder s a
e <- ST s (Builder s a)
ST s (Builder (PrimState (ST s)) a)
forall (m :: * -> *) a. PrimMonad m => m (Builder (PrimState m) a)
newBuilder
  (a -> ST s ()) -> [a] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Builder (PrimState (ST s)) a -> a -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, IsTerminalSymbol a) =>
Builder (PrimState m) a -> a -> m ()
add Builder s a
Builder (PrimState (ST s)) a
e) [a]
xs
  Builder (PrimState (ST s)) a -> ST s (Grammar a)
forall (m :: * -> *) a.
PrimMonad m =>
Builder (PrimState m) a -> m (Grammar a)
build Builder s a
Builder (PrimState (ST s)) a
e

-- | Reconstruct an input sequence from a grammar.
--
-- It is lazy in the sense that you can consume from the beginning
-- before constructing the entire sequence. This function is suitable
-- if you just need to access the resulting sequence only once and
-- from beginning to end. If you need to use the resulting sequence in
-- a more complex way, 'decodeToSeq' would be more suitable.
--
-- This is a left-inverse of 'encode', and is equivalent to 'F.toList'
-- of 'Foldable' class and 'IsList.toList' of 'IsList.IsList'.
decode :: HasCallStack => Grammar a -> [a]
decode :: forall a. HasCallStack => Grammar a -> [a]
decode Grammar a
g = Endo [a] -> [a] -> [a]
forall a. Endo a -> a -> a
appEndo ((a -> Endo [a]) -> Grammar a -> Endo [a]
forall m a. (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> m
decodeToMonoid (\a
a -> ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) Grammar a
g) []

-- | A variant of 'decode' in which the result type is 'Seq'.
decodeToSeq :: HasCallStack => Grammar a -> Seq a
decodeToSeq :: forall a. HasCallStack => Grammar a -> Seq a
decodeToSeq = (a -> Seq a) -> Grammar a -> Seq a
forall m a. (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> m
decodeToMonoid a -> Seq a
forall a. a -> Seq a
Seq.singleton

-- | 'Monoid'-based folding over the decoded sequence.
--
-- This function is equivalent to the following definition but is more
-- efficient due to the utilization of sharing.
--
-- @
-- decodeToMonoid f = 'mconcat' . 'map' f . 'decode'
-- @
--
-- This is equivalent to 'F.foldMap' of 'Foldable' class.
decodeToMonoid :: (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> m
decodeToMonoid :: forall m a. (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> m
decodeToMonoid a -> m
e Grammar a
g =  NonTerminalSymbol -> IntMap m -> m
forall x. HasCallStack => NonTerminalSymbol -> IntMap x -> x
get NonTerminalSymbol
0 ((a -> m) -> Grammar a -> IntMap m
forall m a.
(Monoid m, HasCallStack) =>
(a -> m) -> Grammar a -> IntMap m
decodeNonTerminalsToMonoid a -> m
e Grammar a
g)

-- | 'Monoid'-based folding over the decoded sequence of each non-terminal symbol.
--
-- For example, in the following grammar
--
-- @
-- g = Grammar (IntMap.fromList
--   [ (0, [NonTerminal 1, Terminal \'c\', NonTerminal 1])
--   , (1, [Terminal \'a\', Terminal \'b\'])
--   ])
-- @
--
-- non-terminal symbol @0@ and @1@ produces @"abcab"@ and @"ab"@ respectively.
-- Therefore, @'decodeNonTerminalsToMonoid' f@ yields
--
-- @
-- IntMap.fromList
--   [ (0, mconcat (map f "abcab"))
--   , (1, mconcat (map f "ab"))
--   ]
-- @
decodeNonTerminalsToMonoid :: (Monoid m, HasCallStack) => (a -> m) -> Grammar a -> IntMap m
decodeNonTerminalsToMonoid :: forall m a.
(Monoid m, HasCallStack) =>
(a -> m) -> Grammar a -> IntMap m
decodeNonTerminalsToMonoid a -> m
e (Grammar IntMap [Symbol a]
m) = IntMap m
table
  where
    -- depends on the fact that fmap of IntMap is lazy
    table :: IntMap m
table = ([Symbol a] -> m) -> IntMap [Symbol a] -> IntMap m
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([m] -> m
forall a. Monoid a => [a] -> a
mconcat ([m] -> m) -> ([Symbol a] -> [m]) -> [Symbol a] -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol a -> m) -> [Symbol a] -> [m]
forall a b. (a -> b) -> [a] -> [b]
map Symbol a -> m
f) IntMap [Symbol a]
m

    f :: Symbol a -> m
f (Terminal a
a) = a -> m
e a
a
    f (NonTerminal NonTerminalSymbol
r) = NonTerminalSymbol -> IntMap m -> m
forall x. HasCallStack => NonTerminalSymbol -> IntMap x -> x
get NonTerminalSymbol
r IntMap m
table

get :: HasCallStack => RuleId -> IntMap x -> x
get :: forall x. HasCallStack => NonTerminalSymbol -> IntMap x -> x
get NonTerminalSymbol
r IntMap x
tbl =
  case NonTerminalSymbol -> IntMap x -> Maybe x
forall a. NonTerminalSymbol -> IntMap a -> Maybe a
IntMap.lookup NonTerminalSymbol
r IntMap x
tbl of
    Maybe x
Nothing -> String -> x
forall a. HasCallStack => String -> a
error (String
"rule " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonTerminalSymbol -> String
forall a. Show a => a -> String
show NonTerminalSymbol
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is missing")
    Just x
x -> x
x

-- -------------------------------------------------------------------

checkDigramTable :: IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable :: forall a s. IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable Builder s a
s = do
  Builder s a -> ST s ()
forall a s. IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable1 Builder s a
s
  Builder s a -> ST s ()
forall a s. IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable2 Builder s a
s

checkDigramTable1 :: IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable1 :: forall a s. IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable1 Builder s a
s = do
  [(Digram a, Node s a)]
ds <- HashTable s (Digram a) (Node s a) -> ST s [(Digram a, Node s a)]
forall (h :: * -> * -> * -> *) s k v.
HashTable h =>
h s k v -> ST s [(k, v)]
H.toList (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s)
  [(Digram a, Node s a)]
-> ((Digram a, Node s a) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Digram a, Node s a)]
ds (((Digram a, Node s a) -> ST s ()) -> ST s ())
-> ((Digram a, Node s a) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \((Symbol a
sym1, Symbol a
sym2), Node s a
node1) -> do
    Node s a
node2 <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node1
    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Node s a -> Either NonTerminalSymbol (Symbol a)
forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData Node s a
node1, Node s a -> Either NonTerminalSymbol (Symbol a)
forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData Node s a
node2) (Either NonTerminalSymbol (Symbol a),
 Either NonTerminalSymbol (Symbol a))
-> (Either NonTerminalSymbol (Symbol a),
    Either NonTerminalSymbol (Symbol a))
-> Bool
forall a. Eq a => a -> a -> Bool
== (Symbol a -> Either NonTerminalSymbol (Symbol a)
forall a b. b -> Either a b
Right Symbol a
sym1, Symbol a -> Either NonTerminalSymbol (Symbol a)
forall a b. b -> Either a b
Right Symbol a
sym2)) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
      String -> ST s ()
forall a. HasCallStack => String -> a
error String
"checkDigramTable1: an entry points to a different digram"
    let f :: Node s a -> ST s ()
f Node s a
n =
          case Node s a -> Either NonTerminalSymbol (Symbol a)
forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData Node s a
n of
            Right Symbol a
_ -> Node s a -> ST s ()
f (Node s a -> ST s ()) -> ST s (Node s a) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getPrev Node s a
n
            Left NonTerminalSymbol
rid -> do
              Rule s a
rule <- if NonTerminalSymbol
rid NonTerminalSymbol -> NonTerminalSymbol -> Bool
forall a. Eq a => a -> a -> Bool
== NonTerminalSymbol
0 then
                        Rule s a -> ST s (Rule s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder s a -> Rule s a
forall s a. Builder s a -> Rule s a
sRoot Builder s a
s)
                      else do
                        Maybe (Rule s a)
ret <- HashTable s NonTerminalSymbol (Rule s a)
-> NonTerminalSymbol -> ST s (Maybe (Rule s a))
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
H.lookup (Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules Builder s a
s) NonTerminalSymbol
rid
                        case Maybe (Rule s a)
ret of
                          Maybe (Rule s a)
Nothing -> String -> ST s (Rule s a)
forall a. HasCallStack => String -> a
error String
"checkDigramTable1: an entry points to a digram in an invalid rule"
                          Just Rule s a
rule -> Rule s a -> ST s (Rule s a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Rule s a
rule
              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Rule s a -> Node s a
forall s a. Rule s a -> Node s a
ruleGuardNode Rule s a
rule Node s a -> Node s a -> Bool
forall a. Eq a => a -> a -> Bool
== Node s a
n) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
                String -> ST s ()
forall a. HasCallStack => String -> a
error String
"checkDigramTable1: an entry points to a digram in a inconsistent rule"
    Node s a -> ST s ()
f Node s a
node1

checkDigramTable2 :: IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable2 :: forall a s. IsTerminalSymbol a => Builder s a -> ST s ()
checkDigramTable2 Builder s a
s = do
  [(NonTerminalSymbol, Rule s a)]
rules <- HashTable s NonTerminalSymbol (Rule s a)
-> ST s [(NonTerminalSymbol, Rule s a)]
forall (h :: * -> * -> * -> *) s k v.
HashTable h =>
h s k v -> ST s [(k, v)]
H.toList (Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules Builder s a
s)
  [Rule s a] -> (Rule s a -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Builder s a -> Rule s a
forall s a. Builder s a -> Rule s a
sRoot Builder s a
s Rule s a -> [Rule s a] -> [Rule s a]
forall a. a -> [a] -> [a]
: ((NonTerminalSymbol, Rule s a) -> Rule s a)
-> [(NonTerminalSymbol, Rule s a)] -> [Rule s a]
forall a b. (a -> b) -> [a] -> [b]
map (NonTerminalSymbol, Rule s a) -> Rule s a
forall a b. (a, b) -> b
snd [(NonTerminalSymbol, Rule s a)]
rules) ((Rule s a -> ST s ()) -> ST s ())
-> (Rule s a -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Rule s a
rule -> do
    let f :: Node s a -> ST s ()
f Node s a
node1 = do
          Node s a
node2 <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node1
          Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
node2) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
            let sym1 :: Symbol a
sym1 = Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node1
                sym2 :: Symbol a
sym2 = Node s a -> Symbol a
forall s a. HasCallStack => Node s a -> Symbol a
nodeSymbol Node s a
node2
                normalCase :: ST s ()
normalCase = do
                  Maybe (Node s a)
ret <- HashTable s (Digram a) (Node s a)
-> Digram a -> ST s (Maybe (Node s a))
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
H.lookup (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) (Symbol a
sym1, Symbol a
sym2)
                  case Maybe (Node s a)
ret of
                    Maybe (Node s a)
Nothing -> String -> ST s ()
forall a. HasCallStack => String -> a
error String
"checkDigramTable2: digram does not in the digram table"
                    Just Node s a
node | Node s a
node1 Node s a -> Node s a -> Bool
forall a. Eq a => a -> a -> Bool
/= Node s a
node -> String -> ST s ()
forall a. HasCallStack => String -> a
error String
"checkDigramTable2: digram entry points to a different node"
                    Just Node s a
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Node s a -> ST s ()
f Node s a
node2
            if Symbol a
sym1 Symbol a -> Symbol a -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol a
sym2 then do
              Node s a
node3 <- Node s a -> ST s (Node s a)
forall s a. Node s a -> ST s (Node s a)
getNext Node s a
node2
              case Node s a -> Either NonTerminalSymbol (Symbol a)
forall s a. Node s a -> Either NonTerminalSymbol (Symbol a)
nodeData Node s a
node3 of
                Right Symbol a
sym3 | Symbol a
sym1 Symbol a -> Symbol a -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol a
sym3 -> do
                  Maybe (Node s a)
ret <- HashTable s (Digram a) (Node s a)
-> Digram a -> ST s (Maybe (Node s a))
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
H.lookup (Builder s a -> HashTable s (Digram a) (Node s a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder s a
s) (Symbol a
sym1, Symbol a
sym2)
                  case Maybe (Node s a)
ret of
                    Maybe (Node s a)
Nothing -> String -> ST s ()
forall a. HasCallStack => String -> a
error String
"checkDigramTable2: digram does not in the digram table"
                    Just Node s a
node | Node s a
node1 Node s a -> Node s a -> Bool
forall a. Eq a => a -> a -> Bool
/= Node s a
node Bool -> Bool -> Bool
&& Node s a
node2 Node s a -> Node s a -> Bool
forall a. Eq a => a -> a -> Bool
/= Node s a
node -> String -> ST s ()
forall a. HasCallStack => String -> a
error String
"checkDigramTable2: digram entry points to a different node"
                    Just Node s a
_ -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Node s a -> ST s ()
f Node s a
node3
                Either NonTerminalSymbol (Symbol a)
_ -> ST s ()
normalCase
            else do
              ST s ()
normalCase
    Node s a -> ST s ()
f (Node s a -> ST s ()) -> ST s (Node s a) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rule s a -> ST s (Node s a)
forall s a. Rule s a -> ST s (Node s a)
getFirstNodeOfRule Rule s a
rule

checkRefCount :: forall s a. Builder s a -> ST s ()
checkRefCount :: forall s a. Builder s a -> ST s ()
checkRefCount Builder s a
s = do
  Grammar IntMap [Symbol a]
m <- Builder (PrimState (ST s)) a -> ST s (Grammar a)
forall (m :: * -> *) a.
PrimMonad m =>
Builder (PrimState m) a -> m (Grammar a)
build Builder s a
Builder (PrimState (ST s)) a
s
  let occurences :: IntMap NonTerminalSymbol
occurences = (NonTerminalSymbol -> NonTerminalSymbol -> NonTerminalSymbol)
-> [(NonTerminalSymbol, NonTerminalSymbol)]
-> IntMap NonTerminalSymbol
forall a. (a -> a -> a) -> [(NonTerminalSymbol, a)] -> IntMap a
IntMap.fromListWith NonTerminalSymbol -> NonTerminalSymbol -> NonTerminalSymbol
forall a. Num a => a -> a -> a
(+) [(NonTerminalSymbol
rid, NonTerminalSymbol
1) | [Symbol a]
body <- IntMap [Symbol a] -> [[Symbol a]]
forall a. IntMap a -> [a]
IntMap.elems IntMap [Symbol a]
m, NonTerminal NonTerminalSymbol
rid <- [Symbol a]
body]
      f :: (RuleId, Rule s a) -> ST s ()
      f :: (NonTerminalSymbol, Rule s a) -> ST s ()
f (NonTerminalSymbol
_r, Rule s a
rule) = do
        NonTerminalSymbol
actual <- PrimVar (PrimState (ST s)) NonTerminalSymbol
-> ST s NonTerminalSymbol
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
PrimVar (PrimState m) a -> m a
readPrimVar (Rule s a -> PrimVar s NonTerminalSymbol
forall s a. Rule s a -> PrimVar s NonTerminalSymbol
ruleRefCounter Rule s a
rule)
        let expected :: NonTerminalSymbol
expected = NonTerminalSymbol
-> NonTerminalSymbol
-> IntMap NonTerminalSymbol
-> NonTerminalSymbol
forall a. a -> NonTerminalSymbol -> IntMap a -> a
IntMap.findWithDefault NonTerminalSymbol
0 (Rule s a -> NonTerminalSymbol
forall s a. Rule s a -> NonTerminalSymbol
ruleId Rule s a
rule) IntMap NonTerminalSymbol
occurences
        Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NonTerminalSymbol
actual NonTerminalSymbol -> NonTerminalSymbol -> Bool
forall a. Eq a => a -> a -> Bool
== NonTerminalSymbol
expected) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
          String -> ST s ()
forall a. HasCallStack => String -> a
error (String
"rule " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonTerminalSymbol -> String
forall a. Show a => a -> String
show (Rule s a -> NonTerminalSymbol
forall s a. Rule s a -> NonTerminalSymbol
ruleId Rule s a
rule) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" occurs " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonTerminalSymbol -> String
forall a. Show a => a -> String
show NonTerminalSymbol
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" times,"
                 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but its reference counter is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonTerminalSymbol -> String
forall a. Show a => a -> String
show NonTerminalSymbol
actual)
  ((NonTerminalSymbol, Rule s a) -> ST s ())
-> HashTable s NonTerminalSymbol (Rule s a) -> ST s ()
forall k v s a. ((k, v) -> ST s a) -> HashTable s k v -> ST s ()
H.mapM_ (NonTerminalSymbol, Rule s a) -> ST s ()
f (Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
forall s a. Builder s a -> HashTable s NonTerminalSymbol (Rule s a)
sRules Builder s a
s)

-- -------------------------------------------------------------------