{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- 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 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 append 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 introduce a fresh non-terminal
--   symbol (e.g. @M@) and a rule (e.g. @M@ → @ab@) and replace
--   original occurences with the newly introduced non-terminals.  One
--   exception is the cases where two occurrence overlap.
--
--   [/Rule Utility/]: If a non-terminal symbol occurs only once,
--   /SEQUITUR/ removes the associated rule and substitute the occurence
--   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
  , RuleId
  , Symbol (..)

  -- * High-level API
  --
  -- Use these APIs if the entire sequence is given at once and you
  -- only need to create a single grammar from it.
  , encode
  , decode
  , decodeLazy
  , decodeToSeq
  , decodeToMonoid

  -- * Low-level monadic API
  --
  -- Use these low-level monadic API if the input sequence is given
  -- incrementally, or you want to re-construct grammar after you
  -- receive additinal inputs.
  , Builder
  , newBuilder
  , add
  , build
  ) 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
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 GHC.Generics (Generic)
import GHC.Stack

-- TODO:
--
-- * Use PrimVar after dropping support for primitive <0.8.0.0
--
-- * Remove Eq requirements after dropping support for hashable <1.4.0.0

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

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

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

-- | A non-terminal symbol is represented by an 'Int'.
--
-- The number @0@ is reserved for the start symbol of the grammar.
type RuleId = Int

-- | A symbol is either a terminal symbol (from user-specified type)
-- or a non-terminal symbol which we represent using 'RuleId' type.
data Symbol a
  = NonTerminal !RuleId
  | 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, RuleId -> Symbol a -> ShowS
[Symbol a] -> ShowS
Symbol a -> String
(RuleId -> Symbol a -> ShowS)
-> (Symbol a -> String) -> ([Symbol a] -> ShowS) -> Show (Symbol a)
forall a. Show a => RuleId -> Symbol a -> ShowS
forall a. Show a => [Symbol a] -> ShowS
forall a. Show a => Symbol a -> String
forall a.
(RuleId -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => RuleId -> Symbol a -> ShowS
showsPrec :: RuleId -> 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)

type Digram a = (Symbol a, Symbol a)

-- | A grammar is a mappping from non-terminal (left-hand side of the
-- rule) to sequnce of symbols (right hand side of the rule).
--
-- Non-terminal is represented as a 'RuleId'.
type Grammar a = IntMap [Symbol a]

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

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 RuleId (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 RuleId (Symbol a) -> Bool
forall a b. Either a b -> Bool
isLeft (Either RuleId (Symbol a) -> Bool)
-> Either RuleId (Symbol a) -> Bool
forall a b. (a -> b) -> a -> b
$ Node s a -> Either RuleId (Symbol a)
forall s a. Node s a -> Either RuleId (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 RuleId (Symbol a)
forall s a. Node s a -> Either RuleId (Symbol a)
nodeData Node s a
node of
    Left RuleId
_ -> 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 RuleId
ruleOfGuardNode Node s a
node =
  case Node s a -> Either RuleId (Symbol a)
forall s a. Node s a -> Either RuleId (Symbol a)
nodeData Node s a
node of
    Left RuleId
rule -> RuleId -> Maybe RuleId
forall a. a -> Maybe a
Just RuleId
rule
    Right Symbol a
_ -> Maybe RuleId
forall a. Maybe a
Nothing

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

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

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

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

mkGuardNode :: PrimMonad m => RuleId -> m (Node (PrimState m) a)
mkGuardNode :: forall (m :: * -> *) a.
PrimMonad m =>
RuleId -> m (Node (PrimState m) a)
mkGuardNode RuleId
rid = do
  MutVar (PrimState m) (Node (PrimState m) a)
prevRef <- Node (PrimState m) a
-> m (MutVar (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
-> m (MutVar (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 node :: Node (PrimState m) a
node = MutVar (PrimState m) (Node (PrimState m) a)
-> MutVar (PrimState m) (Node (PrimState m) a)
-> Either RuleId (Symbol a)
-> Node (PrimState m) a
forall s a.
MutVar s (Node s a)
-> MutVar s (Node s a) -> Either RuleId (Symbol a) -> Node s a
Node MutVar (PrimState m) (Node (PrimState m) a)
prevRef MutVar (PrimState m) (Node (PrimState m) a)
nextRef (RuleId -> Either RuleId (Symbol a)
forall a b. a -> Either a b
Left RuleId
rid)
  MutVar (PrimState m) (Node (PrimState m) a)
-> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Node (PrimState m) a)
prevRef Node (PrimState m) a
node
  MutVar (PrimState m) (Node (PrimState m) a)
-> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Node (PrimState m) a)
nextRef Node (PrimState m) a
node
  Node (PrimState m) a -> m (Node (PrimState m) a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Node (PrimState m) a
node

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

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

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

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

getFirstNodeOfRule :: PrimMonad m => Rule (PrimState m) a -> m (Node (PrimState m) a)
getFirstNodeOfRule :: forall (m :: * -> *) a.
PrimMonad m =>
Rule (PrimState m) a -> m (Node (PrimState m) a)
getFirstNodeOfRule Rule (PrimState m) a
rule = Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext (Rule (PrimState m) a -> Node (PrimState m) a
forall s a. Rule s a -> Node s a
ruleGuardNode Rule (PrimState m) a
rule)

getLastNodeOfRule :: PrimMonad m => Rule (PrimState m) a -> m (Node (PrimState m) a)
getLastNodeOfRule :: forall (m :: * -> *) a.
PrimMonad m =>
Rule (PrimState m) a -> m (Node (PrimState m) a)
getLastNodeOfRule Rule (PrimState m) a
rule = Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getPrev (Rule (PrimState m) a -> Node (PrimState m) a
forall s a. Rule s a -> Node s a
ruleGuardNode Rule (PrimState m) a
rule)

mkRule :: PrimMonad m => RuleId -> m (Rule (PrimState m) a)
mkRule :: forall (m :: * -> *) a.
PrimMonad m =>
RuleId -> m (Rule (PrimState m) a)
mkRule RuleId
rid = do
  Node (PrimState m) a
g <- RuleId -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
RuleId -> m (Node (PrimState m) a)
mkGuardNode RuleId
rid
  MutVar (PrimState m) RuleId
refCounter <- RuleId -> m (MutVar (PrimState m) RuleId)
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar RuleId
0
  Rule (PrimState m) a -> m (Rule (PrimState m) a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rule (PrimState m) a -> m (Rule (PrimState m) a))
-> Rule (PrimState m) a -> m (Rule (PrimState m) a)
forall a b. (a -> b) -> a -> b
$ RuleId
-> Node (PrimState m) a
-> MutVar (PrimState m) RuleId
-> Rule (PrimState m) a
forall s a. RuleId -> Node s a -> MutVar s RuleId -> Rule s a
Rule RuleId
rid Node (PrimState m) a
g MutVar (PrimState m) RuleId
refCounter

newRule :: PrimMonad m => Builder (PrimState m) a -> m (Rule (PrimState m) a)
newRule :: forall (m :: * -> *) a.
PrimMonad m =>
Builder (PrimState m) a -> m (Rule (PrimState m) a)
newRule Builder (PrimState m) a
s = do
  RuleId
rid <- MutVar (PrimState m) RuleId -> m RuleId
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar (Builder (PrimState m) a -> MutVar (PrimState m) RuleId
forall s a. Builder s a -> MutVar s RuleId
sRuleIdCounter Builder (PrimState m) a
s)
  MutVar (PrimState m) RuleId -> (RuleId -> RuleId) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> a) -> m ()
modifyMutVar' (Builder (PrimState m) a -> MutVar (PrimState m) RuleId
forall s a. Builder s a -> MutVar s RuleId
sRuleIdCounter Builder (PrimState m) a
s) (RuleId -> RuleId -> RuleId
forall a. Num a => a -> a -> a
+ RuleId
1)
  Rule (PrimState m) a
rule <- RuleId -> m (Rule (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
RuleId -> m (Rule (PrimState m) a)
mkRule RuleId
rid
  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
$ HashTable (PrimState m) RuleId (Rule (PrimState m) a)
-> RuleId -> Rule (PrimState m) a -> ST (PrimState m) ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder (PrimState m) a
-> HashTable (PrimState m) RuleId (Rule (PrimState m) a)
forall s a. Builder s a -> HashTable s RuleId (Rule s a)
sRules Builder (PrimState m) a
s) RuleId
rid Rule (PrimState m) a
rule
  Rule (PrimState m) a -> m (Rule (PrimState m) a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Rule (PrimState m) a
rule

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

-- | 'Builder' denotes a 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 RuleId (Rule s a)
sRules :: !(H.HashTable s RuleId (Rule s a))
  , forall s a. Builder s a -> MutVar s RuleId
sRuleIdCounter :: {-# UNPACK #-} !(MutVar 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 = do
  Rule (PrimState m) a
root <- RuleId -> m (Rule (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
RuleId -> m (Rule (PrimState m) a)
mkRule RuleId
0
  HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
digrams <- ST
  (PrimState m)
  (HashTable (PrimState m) (Digram a) (Node (PrimState m) a))
-> m (HashTable (PrimState m) (Digram a) (Node (PrimState m) a))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST
   (PrimState m)
   (HashTable (PrimState m) (Digram a) (Node (PrimState m) a))
 -> m (HashTable (PrimState m) (Digram a) (Node (PrimState m) a)))
-> ST
     (PrimState m)
     (HashTable (PrimState m) (Digram a) (Node (PrimState m) a))
-> m (HashTable (PrimState m) (Digram a) (Node (PrimState m) a))
forall a b. (a -> b) -> a -> b
$ 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) RuleId (Rule (PrimState m) a)
rules <- ST
  (PrimState m)
  (HashTable (PrimState m) RuleId (Rule (PrimState m) a))
-> m (HashTable (PrimState m) RuleId (Rule (PrimState m) a))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST
   (PrimState m)
   (HashTable (PrimState m) RuleId (Rule (PrimState m) a))
 -> m (HashTable (PrimState m) RuleId (Rule (PrimState m) a)))
-> ST
     (PrimState m)
     (HashTable (PrimState m) RuleId (Rule (PrimState m) a))
-> m (HashTable (PrimState m) RuleId (Rule (PrimState m) a))
forall a b. (a -> b) -> a -> b
$ ST
  (PrimState m)
  (HashTable (PrimState m) RuleId (Rule (PrimState m) a))
forall s k v. ST s (HashTable s k v)
H.new
  MutVar (PrimState m) RuleId
counter <- RuleId -> m (MutVar (PrimState m) RuleId)
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar RuleId
1

  MutVar (PrimState m) (Node (PrimState m) a)
prevRef <- Node (PrimState m) a
-> m (MutVar (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
-> m (MutVar (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 RuleId (Symbol a)
-> Node (PrimState m) a
forall s a.
MutVar s (Node s a)
-> MutVar s (Node s a) -> Either RuleId (Symbol a) -> Node s a
Node MutVar (PrimState m) (Node (PrimState m) a)
prevRef MutVar (PrimState m) (Node (PrimState m) a)
nextRef (RuleId -> Either RuleId (Symbol a)
forall a b. a -> Either a b
Left RuleId
0)
  MutVar (PrimState m) (Node (PrimState m) a)
-> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Node (PrimState m) a)
prevRef Node (PrimState m) a
dummyNode
  MutVar (PrimState m) (Node (PrimState m) a)
-> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> a -> m ()
writeMutVar MutVar (PrimState m) (Node (PrimState m) a)
nextRef Node (PrimState m) a
dummyNode

  Builder (PrimState m) a -> m (Builder (PrimState m) a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder (PrimState m) a -> m (Builder (PrimState m) a))
-> Builder (PrimState m) a -> 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) RuleId (Rule (PrimState m) a)
-> MutVar (PrimState m) RuleId
-> Node (PrimState m) a
-> Builder (PrimState m) a
forall s a.
Rule s a
-> HashTable s (Digram a) (Node s a)
-> HashTable s RuleId (Rule s a)
-> MutVar s RuleId
-> 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) RuleId (Rule (PrimState m) a)
rules MutVar (PrimState m) RuleId
counter Node (PrimState m) a
dummyNode

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

-- | Add a new symbol to the end of grammar's start production,
-- and perform normalization to keep the invariants of /SEQUITUR/ algorithm.
add :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> a -> m ()
add :: forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a -> a -> m ()
add Builder (PrimState m) a
s a
a = do
  Node (PrimState m) a
lastNode <- Rule (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Rule (PrimState m) a -> m (Node (PrimState m) 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 -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a, HasCallStack) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Symbol a -> m (Node (PrimState m) 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 -> m Bool
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a -> Node (PrimState m) a -> m Bool
check Builder (PrimState m) a
s Node (PrimState m) a
lastNode
  () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Retrieve a grammar (as a persistent data structure) from '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 = do
  [Symbol a]
root <- Node (PrimState m) a -> m [Symbol a]
forall a (m :: * -> *).
PrimMonad m =>
Node (PrimState m) a -> m [Symbol a]
freezeGuardNode (Node (PrimState m) a -> m [Symbol a])
-> Node (PrimState m) a -> 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)
  [(RuleId, Rule (PrimState m) a)]
xs <- ST (PrimState m) [(RuleId, Rule (PrimState m) a)]
-> m [(RuleId, Rule (PrimState m) a)]
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState m) [(RuleId, Rule (PrimState m) a)]
 -> m [(RuleId, Rule (PrimState m) a)])
-> ST (PrimState m) [(RuleId, Rule (PrimState m) a)]
-> m [(RuleId, Rule (PrimState m) a)]
forall a b. (a -> b) -> a -> b
$ HashTable (PrimState m) RuleId (Rule (PrimState m) a)
-> ST (PrimState m) [(RuleId, 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) RuleId (Rule (PrimState m) a)
forall s a. Builder s a -> HashTable s RuleId (Rule s a)
sRules Builder (PrimState m) a
s)
  [(RuleId, [Symbol a])]
m <- [(RuleId, Rule (PrimState m) a)]
-> ((RuleId, Rule (PrimState m) a) -> m (RuleId, [Symbol a]))
-> m [(RuleId, [Symbol a])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RuleId, Rule (PrimState m) a)]
xs (((RuleId, Rule (PrimState m) a) -> m (RuleId, [Symbol a]))
 -> m [(RuleId, [Symbol a])])
-> ((RuleId, Rule (PrimState m) a) -> m (RuleId, [Symbol a]))
-> m [(RuleId, [Symbol a])]
forall a b. (a -> b) -> a -> b
$ \(RuleId
rid, Rule (PrimState m) a
rule) -> do
    [Symbol a]
ys <- Node (PrimState m) a -> m [Symbol a]
forall a (m :: * -> *).
PrimMonad m =>
Node (PrimState m) a -> m [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)
    (RuleId, [Symbol a]) -> m (RuleId, [Symbol a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((RuleId, [Symbol a]) -> m (RuleId, [Symbol a]))
-> (RuleId, [Symbol a]) -> m (RuleId, [Symbol a])
forall a b. (a -> b) -> a -> b
$ (RuleId
rid, [Symbol a]
ys)
  Grammar a -> m (Grammar a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Grammar a -> m (Grammar a)) -> Grammar a -> m (Grammar a)
forall a b. (a -> b) -> a -> b
$ RuleId -> [Symbol a] -> Grammar a -> Grammar a
forall a. RuleId -> a -> IntMap a -> IntMap a
IntMap.insert RuleId
0 [Symbol a]
root (Grammar a -> Grammar a) -> Grammar a -> Grammar a
forall a b. (a -> b) -> a -> b
$ [(RuleId, [Symbol a])] -> Grammar a
forall a. [(RuleId, a)] -> IntMap a
IntMap.fromList [(RuleId, [Symbol a])]
m

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

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

link :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> Node (PrimState m) a -> Node (PrimState m) a -> m ()
link :: forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
link Builder (PrimState m) a
s Node (PrimState m) a
left Node (PrimState m) a
right = do
  Node (PrimState m) a
leftPrev <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getPrev Node (PrimState m) a
left
  Node (PrimState m) a
leftNext <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext Node (PrimState m) a
left
  Node (PrimState m) a
rightPrev <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getPrev Node (PrimState m) a
right
  Node (PrimState m) a
rightNext <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext Node (PrimState m) a
right

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node (PrimState m) a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node (PrimState m) a
leftNext) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Builder (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a -> Node (PrimState m) a -> m ()
deleteDigram Builder (PrimState m) a
s Node (PrimState m) a
left

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

    case (Node (PrimState m) a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node (PrimState m) a
rightPrev, Node (PrimState m) a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node (PrimState m) a
right, Node (PrimState m) a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node (PrimState m) 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 ->
        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
$ HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
-> Digram a -> Node (PrimState m) a -> ST (PrimState m) ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder (PrimState m) a
-> HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder (PrimState m) a
s) (Symbol a
sym2, Symbol a
sym3) Node (PrimState m) a
right
      (Maybe (Symbol a), Maybe (Symbol a), Maybe (Symbol a))
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    case (Node (PrimState m) a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node (PrimState m) a
leftPrev, Node (PrimState m) a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node (PrimState m) a
left, Node (PrimState m) a -> Maybe (Symbol a)
forall s a. Node s a -> Maybe (Symbol a)
nodeSymbolMaybe Node (PrimState m) 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 ->
        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
$ HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
-> Digram a -> Node (PrimState m) a -> ST (PrimState m) ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
H.insert (Builder (PrimState m) a
-> HashTable (PrimState m) (Digram a) (Node (PrimState m) a)
forall s a. Builder s a -> HashTable s (Digram a) (Node s a)
sDigrams Builder (PrimState m) a
s) (Symbol a
sym1, Symbol a
sym2) Node (PrimState m) a
leftPrev
      (Maybe (Symbol a), Maybe (Symbol a), Maybe (Symbol a))
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  Node (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> Node (PrimState m) a -> m ()
setNext Node (PrimState m) a
left Node (PrimState m) a
right
  Node (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> Node (PrimState m) a -> m ()
setPrev Node (PrimState m) a
right Node (PrimState m) a
left

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

  Node (PrimState m) a
next <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext Node (PrimState m) a
node
  Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
link Builder (PrimState m) a
s Node (PrimState m) a
newNode Node (PrimState m) a
next
  Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
link Builder (PrimState m) a
s Node (PrimState m) a
node Node (PrimState m) a
newNode

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

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

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

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

match :: (PrimMonad m, Eq a, Hashable a, HasCallStack) => Builder (PrimState m) a -> Node (PrimState m) a -> Node (PrimState m) a -> m ()
match :: forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a, HasCallStack) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
match Builder (PrimState m) a
s Node (PrimState m) a
ss Node (PrimState m) a
m = do
  Node (PrimState m) a
mPrev <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getPrev Node (PrimState m) a
m
  Node (PrimState m) a
mNext <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext Node (PrimState m) a
m
  Node (PrimState m) a
mNextNext <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext Node (PrimState m) a
mNext

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

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

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sanityCheck (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let loop :: Node s a -> m ()
loop Node s a
node
          | Node s a -> Bool
forall s a. Node s a -> Bool
isGuardNode Node s a
node = () -> m ()
forall a. a -> m 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
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                NonTerminal RuleId
rid -> do
                  Rule (PrimState m) a
rule2 <- Builder (PrimState m) a -> RuleId -> m (Rule (PrimState m) a)
forall (m :: * -> *) a.
(PrimMonad m, HasCallStack) =>
Builder (PrimState m) a -> RuleId -> m (Rule (PrimState m) a)
getRule Builder (PrimState m) a
Builder (PrimState m) a
s RuleId
rid
                  RuleId
freq <- MutVar (PrimState m) RuleId -> m RuleId
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar (Rule (PrimState m) a -> MutVar (PrimState m) RuleId
forall s a. Rule s a -> MutVar s RuleId
ruleRefCounter Rule (PrimState m) a
rule2)
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RuleId
freq RuleId -> RuleId -> Bool
forall a. Ord a => a -> a -> Bool
<= RuleId
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. HasCallStack => String -> a
error String
"Sequitur.match: non-first node with refCount <= 1"
    Node (PrimState m) a -> m ()
forall {m :: * -> *} {s} {a}.
(PrimState m ~ PrimState m, PrimMonad m) =>
Node s a -> m ()
loop (Node (PrimState m) a -> m ()) -> m (Node (PrimState m) a) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext Node (PrimState m) a
firstNode

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

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

expand :: (PrimMonad m, Eq a, Hashable a) => Builder (PrimState m) a -> Node (PrimState m) a -> Rule (PrimState m) a -> m ()
expand :: forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Rule (PrimState m) a -> m ()
expand Builder (PrimState m) a
s Node (PrimState m) a
node Rule (PrimState m) a
rule = do
  Node (PrimState m) a
left <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getPrev Node (PrimState m) a
node
  Node (PrimState m) a
right <- Node (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Node (PrimState m) a -> m (Node (PrimState m) a)
getNext Node (PrimState m) a
node
  Builder (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a, HasCallStack) =>
Builder (PrimState m) a -> Node (PrimState m) a -> m ()
deleteNode Builder (PrimState m) a
s Node (PrimState m) a
node

  Node (PrimState m) a
f <- Rule (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Rule (PrimState m) a -> m (Node (PrimState m) a)
getFirstNodeOfRule Rule (PrimState m) a
rule
  Node (PrimState m) a
l <- Rule (PrimState m) a -> m (Node (PrimState m) a)
forall (m :: * -> *) a.
PrimMonad m =>
Rule (PrimState m) a -> m (Node (PrimState m) a)
getLastNodeOfRule Rule (PrimState m) a
rule
  Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
link Builder (PrimState m) a
s Node (PrimState m) a
left Node (PrimState m) a
f
  Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Eq a, Hashable a) =>
Builder (PrimState m) a
-> Node (PrimState m) a -> Node (PrimState m) a -> m ()
link Builder (PrimState m) a
s Node (PrimState m) a
l Node (PrimState m) a
right

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

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

-- | Construct a grammer from a given sequence of symbols using /SEQUITUR/.
encode :: (Eq a, Hashable a) => [a] -> Grammar a
encode :: forall a. (Eq a, Hashable 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, Eq a, Hashable 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 a input sequence from a grammar.
--
-- This is a left-inverse of 'encode'.
--
-- This function is implemented as
--
-- @
-- decode = 'F.toList' . 'decodeToSeq'
-- @
--
-- and provided just for convenience.
-- For serious usage, use 'decodeToSeq' or 'decodeLazy'.
decode :: HasCallStack => Grammar a -> [a]
decode :: forall a. HasCallStack => Grammar a -> [a]
decode = Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq a -> [a]) -> (Grammar a -> Seq a) -> Grammar a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar a -> Seq a
forall a. HasCallStack => Grammar a -> Seq a
decodeToSeq

-- | A variant of 'decode' with possibly better performance.
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

-- | A variant of 'decode' but you can consume from the beginning
-- before constructing entire sequence.
decodeLazy :: HasCallStack => Grammar a -> [a]
decodeLazy :: forall a. HasCallStack => Grammar a -> [a]
decodeLazy 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) []

-- | 'Monoid'-based folding over the decoded sequence.
--
-- This function is equivalent to the following definition, is more
-- efficent due to the utilization of sharing.b
--
-- @
-- decodeToMonoid f = 'mconcat' . 'map' f . 'decode'
-- @
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 = RuleId -> IntMap m -> m
forall {a}. RuleId -> IntMap a -> a
get RuleId
0 IntMap m
table
  where
    -- depends on the fact that fmap of IntMap is lazy
    table :: IntMap m
table = ([Symbol a] -> m) -> Grammar 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) Grammar a
g

    f :: Symbol a -> m
f (Terminal a
a) = a -> m
e a
a
    f (NonTerminal RuleId
r) = RuleId -> IntMap m -> m
forall {a}. RuleId -> IntMap a -> a
get RuleId
r IntMap m
table

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

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