module Data.Trie.Pred.Step where
import Prelude hiding (lookup)
import Data.Trie.Class
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import Data.Typeable
import Data.Functor.Syntax
import Data.Monoid
data PredStep c s a = forall r. PredStep
{ predTag :: !T.Text
, predPred :: !(s -> Maybe r)
, predData :: !(Maybe (r -> a))
, predSub :: !(c s (r -> a))
} deriving (Typeable)
instance Show s => Show (PredStep c s a) where
show (PredStep t _ _ _) = "PredStep {predTag=" ++ show t ++ ", ...}"
instance Functor (c s) => Functor (PredStep c s) where
fmap f (PredStep i p mx xs) = (PredStep i p $! f <.$> mx) $! f <.$> xs
instance Trie NonEmpty s c => Trie NonEmpty s (PredStep c) where
lookup (t:|ts) (PredStep _ p mx xs) = do
r <- p t
if null ts then mx <$~> r
else lookup (NE.fromList ts) xs <$~> r
delete (t:|ts) xss@(PredStep i p mx xs) =
maybe xss
(const $ if null ts
then PredStep i p Nothing xs
else PredStep i p mx $! delete (NE.fromList ts) xs)
(p t)
singletonPred :: Monoid (c s (r -> a)) => T.Text -> (s -> Maybe r) -> (r -> a) -> PredStep c s a
singletonPred i p x = PredStep i p (Just x) mempty
newtype PredSteps c s a = PredSteps
{ unPredSteps :: [PredStep c s a]
} deriving (Show, Functor, Typeable)
instance Trie NonEmpty s c => Trie NonEmpty s (PredSteps c) where
lookup ts (PredSteps ps) = getFirst $! foldMap (First . lookup ts) ps
delete ts (PredSteps ps) = PredSteps $! fmap (delete ts) ps
instance Eq s => Monoid (PredSteps c s a) where
mempty = PredSteps []
mappend = unionPred
unionPred :: PredSteps c s a -> PredSteps c s a -> PredSteps c s a
unionPred (PredSteps (xss@(PredStep i _ _ _):pxs)) (PredSteps (yss@(PredStep j _ _ _):pys))
| i == j = PredSteps $ yss : (unPredSteps $! unionPred (PredSteps pxs) (PredSteps pys))
| otherwise = PredSteps $ xss : yss : (unPredSteps $! unionPred (PredSteps pxs) (PredSteps pys))
unionPred x (PredSteps []) = x
unionPred (PredSteps []) y = y