{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Text.Regex.Anagram.Types
  where

import           Control.DeepSeq (NFData(..), NFData1(..), rnf1)
import           Data.CaseInsensitive (FoldCase(..))
import           Data.Functor.Identity (Identity)
import qualified Data.IntMap.Strict as M
import qualified Data.IntSet as S
import           Data.Ord (comparing)
import           Data.Semigroup (stimes)
import qualified Data.Vector as V

-- |run-length encoding element (item and repeat count)
data RL a = RL
  { RL a -> a
unRL :: !a
  , RL a -> Int
rl :: !Int
  } deriving (RL a -> RL a -> Bool
(RL a -> RL a -> Bool) -> (RL a -> RL a -> Bool) -> Eq (RL a)
forall a. Eq a => RL a -> RL a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RL a -> RL a -> Bool
$c/= :: forall a. Eq a => RL a -> RL a -> Bool
== :: RL a -> RL a -> Bool
$c== :: forall a. Eq a => RL a -> RL a -> Bool
Eq, Eq (RL a)
Eq (RL a)
-> (RL a -> RL a -> Ordering)
-> (RL a -> RL a -> Bool)
-> (RL a -> RL a -> Bool)
-> (RL a -> RL a -> Bool)
-> (RL a -> RL a -> Bool)
-> (RL a -> RL a -> RL a)
-> (RL a -> RL a -> RL a)
-> Ord (RL a)
RL a -> RL a -> Bool
RL a -> RL a -> Ordering
RL a -> RL a -> RL 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 (RL a)
forall a. Ord a => RL a -> RL a -> Bool
forall a. Ord a => RL a -> RL a -> Ordering
forall a. Ord a => RL a -> RL a -> RL a
min :: RL a -> RL a -> RL a
$cmin :: forall a. Ord a => RL a -> RL a -> RL a
max :: RL a -> RL a -> RL a
$cmax :: forall a. Ord a => RL a -> RL a -> RL a
>= :: RL a -> RL a -> Bool
$c>= :: forall a. Ord a => RL a -> RL a -> Bool
> :: RL a -> RL a -> Bool
$c> :: forall a. Ord a => RL a -> RL a -> Bool
<= :: RL a -> RL a -> Bool
$c<= :: forall a. Ord a => RL a -> RL a -> Bool
< :: RL a -> RL a -> Bool
$c< :: forall a. Ord a => RL a -> RL a -> Bool
compare :: RL a -> RL a -> Ordering
$ccompare :: forall a. Ord a => RL a -> RL a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (RL a)
Ord, Int -> RL a -> ShowS
[RL a] -> ShowS
RL a -> String
(Int -> RL a -> ShowS)
-> (RL a -> String) -> ([RL a] -> ShowS) -> Show (RL a)
forall a. Show a => Int -> RL a -> ShowS
forall a. Show a => [RL a] -> ShowS
forall a. Show a => RL a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RL a] -> ShowS
$cshowList :: forall a. Show a => [RL a] -> ShowS
show :: RL a -> String
$cshow :: forall a. Show a => RL a -> String
showsPrec :: Int -> RL a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RL a -> ShowS
Show)

instance Functor RL where
  fmap :: (a -> b) -> RL a -> RL b
fmap a -> b
f (RL a
a Int
n) = b -> Int -> RL b
forall a. a -> Int -> RL a
RL (a -> b
f a
a) Int
n

newtype RLEof f a = RLE{ RLEof f a -> f (RL a)
unRLE :: f (RL a) }

-- |run-length encoded list
type RLE = RLEof []
type RLEV = RLEof V.Vector

deriving instance Show a => Show (RLE a)
deriving instance Show a => Show (RLEV a)

instance Functor f => Functor (RLEof f) where
  fmap :: (a -> b) -> RLEof f a -> RLEof f b
fmap a -> b
f (RLE f (RL a)
l) = f (RL b) -> RLEof f b
forall (f :: * -> *) a. f (RL a) -> RLEof f a
RLE (f (RL b) -> RLEof f b) -> f (RL b) -> RLEof f b
forall a b. (a -> b) -> a -> b
$ (RL a -> RL b) -> f (RL a) -> f (RL b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> RL a -> RL b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (RL a)
l

deriving instance Semigroup (RLE a)
deriving instance Monoid (RLE a)

data Inf a
  = Fin !a
  | Inf
  deriving (Inf a -> Inf a -> Bool
(Inf a -> Inf a -> Bool) -> (Inf a -> Inf a -> Bool) -> Eq (Inf a)
forall a. Eq a => Inf a -> Inf a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Inf a -> Inf a -> Bool
$c/= :: forall a. Eq a => Inf a -> Inf a -> Bool
== :: Inf a -> Inf a -> Bool
$c== :: forall a. Eq a => Inf a -> Inf a -> Bool
Eq, Eq (Inf a)
Eq (Inf a)
-> (Inf a -> Inf a -> Ordering)
-> (Inf a -> Inf a -> Bool)
-> (Inf a -> Inf a -> Bool)
-> (Inf a -> Inf a -> Bool)
-> (Inf a -> Inf a -> Bool)
-> (Inf a -> Inf a -> Inf a)
-> (Inf a -> Inf a -> Inf a)
-> Ord (Inf a)
Inf a -> Inf a -> Bool
Inf a -> Inf a -> Ordering
Inf a -> Inf a -> Inf 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 (Inf a)
forall a. Ord a => Inf a -> Inf a -> Bool
forall a. Ord a => Inf a -> Inf a -> Ordering
forall a. Ord a => Inf a -> Inf a -> Inf a
min :: Inf a -> Inf a -> Inf a
$cmin :: forall a. Ord a => Inf a -> Inf a -> Inf a
max :: Inf a -> Inf a -> Inf a
$cmax :: forall a. Ord a => Inf a -> Inf a -> Inf a
>= :: Inf a -> Inf a -> Bool
$c>= :: forall a. Ord a => Inf a -> Inf a -> Bool
> :: Inf a -> Inf a -> Bool
$c> :: forall a. Ord a => Inf a -> Inf a -> Bool
<= :: Inf a -> Inf a -> Bool
$c<= :: forall a. Ord a => Inf a -> Inf a -> Bool
< :: Inf a -> Inf a -> Bool
$c< :: forall a. Ord a => Inf a -> Inf a -> Bool
compare :: Inf a -> Inf a -> Ordering
$ccompare :: forall a. Ord a => Inf a -> Inf a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Inf a)
Ord, Int -> Inf a -> ShowS
[Inf a] -> ShowS
Inf a -> String
(Int -> Inf a -> ShowS)
-> (Inf a -> String) -> ([Inf a] -> ShowS) -> Show (Inf a)
forall a. Show a => Int -> Inf a -> ShowS
forall a. Show a => [Inf a] -> ShowS
forall a. Show a => Inf a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inf a] -> ShowS
$cshowList :: forall a. Show a => [Inf a] -> ShowS
show :: Inf a -> String
$cshow :: forall a. Show a => Inf a -> String
showsPrec :: Int -> Inf a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Inf a -> ShowS
Show)

-- we don't really use this whole instance
instance (Eq a, Num a) => Num (Inf a) where
  Fin a
a + :: Inf a -> Inf a -> Inf a
+ Fin a
b = a -> Inf a
forall a. a -> Inf a
Fin (a -> Inf a) -> a -> Inf a
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a
b
  Inf a
Inf + Inf a
_ = Inf a
forall a. Inf a
Inf
  Inf a
_ + Inf a
Inf = Inf a
forall a. Inf a
Inf
  Fin a
a * :: Inf a -> Inf a -> Inf a
* Fin a
b = a -> Inf a
forall a. a -> Inf a
Fin (a -> Inf a) -> a -> Inf a
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
b
  Inf a
Inf * Fin a
0 = a -> Inf a
forall a. a -> Inf a
Fin a
0
  Inf a
Inf * Inf a
_ = Inf a
forall a. Inf a
Inf
  Fin a
0 * Inf a
Inf = a -> Inf a
forall a. a -> Inf a
Fin a
0
  Inf a
_ * Inf a
Inf = Inf a
forall a. Inf a
Inf
  abs :: Inf a -> Inf a
abs (Fin a
a) = a -> Inf a
forall a. a -> Inf a
Fin a
a
  abs Inf a
Inf = Inf a
forall a. Inf a
Inf
  signum :: Inf a -> Inf a
signum (Fin a
a) = a -> Inf a
forall a. a -> Inf a
Fin (a -> a
forall a. Num a => a -> a
signum a
a)
  signum Inf a
Inf = a -> Inf a
forall a. a -> Inf a
Fin a
1
  negate :: Inf a -> Inf a
negate (Fin a
a) = a -> Inf a
forall a. a -> Inf a
Fin (a -> a
forall a. Num a => a -> a
negate a
a)
  negate Inf a
Inf = String -> Inf a
forall a. HasCallStack => String -> a
error String
"negate Inf"
  fromInteger :: Integer -> Inf a
fromInteger = a -> Inf a
forall a. a -> Inf a
Fin (a -> Inf a) -> (Integer -> a) -> Integer -> Inf a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger

-- |We use Int for all Chars, mainly to use IntSet.
type Chr = Int
type ChrSet = S.IntSet
-- |A permuted string: a bag of characters mapping character to repeat count.
type ChrStr = M.IntMap Int

-- |Match for a single character.
data PatChar
  = PatChr !Chr -- ^literal single character
  | PatSet ChrSet -- ^one of a set "[a-z]"
  | PatNot ChrSet -- ^not one of a set "[^a-z]"
  deriving (PatChar -> PatChar -> Bool
(PatChar -> PatChar -> Bool)
-> (PatChar -> PatChar -> Bool) -> Eq PatChar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PatChar -> PatChar -> Bool
$c/= :: PatChar -> PatChar -> Bool
== :: PatChar -> PatChar -> Bool
$c== :: PatChar -> PatChar -> Bool
Eq, Int -> PatChar -> ShowS
[PatChar] -> ShowS
PatChar -> String
(Int -> PatChar -> ShowS)
-> (PatChar -> String) -> ([PatChar] -> ShowS) -> Show PatChar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PatChar] -> ShowS
$cshowList :: [PatChar] -> ShowS
show :: PatChar -> String
$cshow :: PatChar -> String
showsPrec :: Int -> PatChar -> ShowS
$cshowsPrec :: Int -> PatChar -> ShowS
Show)

instance Semigroup PatChar where
  PatSet ChrSet
s <> :: PatChar -> PatChar -> PatChar
<> PatChar
x | ChrSet -> Bool
S.null ChrSet
s = PatChar
x -- opt
  PatSet ChrSet
s <> PatChr Int
c = ChrSet -> PatChar
PatSet (Int -> ChrSet -> ChrSet
S.insert Int
c ChrSet
s)
  PatSet ChrSet
s <> PatSet ChrSet
t = ChrSet -> PatChar
PatSet (ChrSet -> ChrSet -> ChrSet
S.union ChrSet
s ChrSet
t)
  PatSet ChrSet
s <> PatNot ChrSet
n = ChrSet -> PatChar
PatNot (ChrSet -> ChrSet -> ChrSet
S.difference ChrSet
n ChrSet
s)
  PatChr Int
c <> PatChr Int
d
    | Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
d = Int -> PatChar
PatChr Int
c
    | Bool
otherwise = ChrSet -> PatChar
PatSet ([Int] -> ChrSet
S.fromList [Int
c,Int
d])
  PatChr Int
c <> PatNot ChrSet
n = ChrSet -> PatChar
PatNot (Int -> ChrSet -> ChrSet
S.delete Int
c ChrSet
n)
  PatNot ChrSet
n <> PatNot ChrSet
m = ChrSet -> PatChar
PatNot (ChrSet -> ChrSet -> ChrSet
S.intersection ChrSet
n ChrSet
m)
  PatChar
a <> PatChar
b = PatChar
b PatChar -> PatChar -> PatChar
forall a. Semigroup a => a -> a -> a
<> PatChar
a

instance Monoid PatChar where
  mempty :: PatChar
mempty = ChrSet -> PatChar
PatSet ChrSet
S.empty

instance Ord PatChar where
  compare :: PatChar -> PatChar -> Ordering
compare (PatChr Int
c1) (PatChr Int
c2) = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
c1 Int
c2
  compare (PatSet ChrSet
s1) (PatSet ChrSet
s2) = (ChrSet -> Int) -> ChrSet -> ChrSet -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ChrSet -> Int
S.size ChrSet
s1 ChrSet
s2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> ChrSet -> ChrSet -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ChrSet
s1 ChrSet
s2
  compare (PatNot ChrSet
s1) (PatNot ChrSet
s2) = (ChrSet -> Int) -> ChrSet -> ChrSet -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ChrSet -> Int
S.size ChrSet
s2 ChrSet
s1 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> ChrSet -> ChrSet -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ChrSet
s1 ChrSet
s2
  compare (PatChr Int
_) PatChar
_ = Ordering
LT
  compare (PatSet ChrSet
_) (PatNot ChrSet
_) = Ordering
LT
  compare PatChar
_ PatChar
_ = Ordering
GT

-- |The parsed characters from a regex pattern
data PatCharsOf f = PatChars
  { PatCharsOf f -> f PatChar
patReqs :: f PatChar -- ^requried chars
  , PatCharsOf f -> f PatChar
patOpts :: f PatChar -- ^optional chars (x?)
  , PatCharsOf f -> PatChar
patStar :: PatChar -- ^extra chars (x*)
  }

type PatChars = PatCharsOf []

deriving instance Show PatChars
deriving instance Show (PatCharsOf RLE)
deriving instance Show (PatCharsOf Identity)

instance Semigroup PatChars where
  PatChars [PatChar]
l1 [PatChar]
o1 PatChar
e1 <> :: PatChars -> PatChars -> PatChars
<> PatChars [PatChar]
l2 [PatChar]
o2 PatChar
e2 =
    [PatChar] -> [PatChar] -> PatChar -> PatChars
forall (f :: * -> *).
f PatChar -> f PatChar -> PatChar -> PatCharsOf f
PatChars ([PatChar]
l1 [PatChar] -> [PatChar] -> [PatChar]
forall a. Semigroup a => a -> a -> a
<> [PatChar]
l2) ([PatChar]
o1 [PatChar] -> [PatChar] -> [PatChar]
forall a. Semigroup a => a -> a -> a
<> [PatChar]
o2) (PatChar
e1 PatChar -> PatChar -> PatChar
forall a. Semigroup a => a -> a -> a
<> PatChar
e2)
  stimes :: b -> PatChars -> PatChars
stimes b
n (PatChars [PatChar]
l [PatChar]
o PatChar
e) = [PatChar] -> [PatChar] -> PatChar -> PatChars
forall (f :: * -> *).
f PatChar -> f PatChar -> PatChar -> PatCharsOf f
PatChars (b -> [PatChar] -> [PatChar]
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes b
n [PatChar]
l) (b -> [PatChar] -> [PatChar]
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes b
n [PatChar]
o) PatChar
e

instance Monoid PatChars where
  mempty :: PatChars
mempty = [PatChar] -> [PatChar] -> PatChar -> PatChars
forall (f :: * -> *).
f PatChar -> f PatChar -> PatChar -> PatCharsOf f
PatChars [PatChar]
forall a. Monoid a => a
mempty [PatChar]
forall a. Monoid a => a
mempty PatChar
forall a. Monoid a => a
mempty


foldCaseChr :: Chr -> Chr
foldCaseChr :: Int -> Int
foldCaseChr Int
c = Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char -> Char
forall s. FoldCase s => s -> s
foldCase (Int -> Char
forall a. Enum a => Int -> a
toEnum Int
c :: Char))

instance FoldCase PatChar where
  foldCase :: PatChar -> PatChar
foldCase (PatChr Int
c) = Int -> PatChar
PatChr (Int -> Int
foldCaseChr Int
c)
  foldCase (PatSet ChrSet
s) = ChrSet -> PatChar
PatSet ((Int -> Int) -> ChrSet -> ChrSet
S.map Int -> Int
foldCaseChr ChrSet
s)
  foldCase (PatNot ChrSet
s) = ChrSet -> PatChar
PatNot ((Int -> Int) -> ChrSet -> ChrSet
S.map Int -> Int
foldCaseChr ChrSet
s)

instance Functor f => FoldCase (PatCharsOf f) where
  foldCase :: PatCharsOf f -> PatCharsOf f
foldCase p :: PatCharsOf f
p@PatChars{f PatChar
PatChar
patStar :: PatChar
patOpts :: f PatChar
patReqs :: f PatChar
patStar :: forall (f :: * -> *). PatCharsOf f -> PatChar
patOpts :: forall (f :: * -> *). PatCharsOf f -> f PatChar
patReqs :: forall (f :: * -> *). PatCharsOf f -> f PatChar
..} = PatCharsOf f
p
    { patReqs :: f PatChar
patReqs = (PatChar -> PatChar) -> f PatChar -> f PatChar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatChar -> PatChar
forall s. FoldCase s => s -> s
foldCase f PatChar
patReqs
    , patOpts :: f PatChar
patOpts = (PatChar -> PatChar) -> f PatChar -> f PatChar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatChar -> PatChar
forall s. FoldCase s => s -> s
foldCase f PatChar
patOpts
    , patStar :: PatChar
patStar = PatChar -> PatChar
forall s. FoldCase s => s -> s
foldCase PatChar
patStar
    }

instance NFData1 RL where
  liftRnf :: (a -> ()) -> RL a -> ()
liftRnf a -> ()
f (RL a
a Int
_) = a -> ()
f a
a

instance NFData1 f => NFData1 (RLEof f) where
  liftRnf :: (a -> ()) -> RLEof f a -> ()
liftRnf a -> ()
f (RLE f (RL a)
l) = (RL a -> ()) -> f (RL a) -> ()
forall (f :: * -> *) a. NFData1 f => (a -> ()) -> f a -> ()
liftRnf ((a -> ()) -> RL a -> ()
forall (f :: * -> *) a. NFData1 f => (a -> ()) -> f a -> ()
liftRnf a -> ()
f) f (RL a)
l

instance NFData PatChar where
  rnf :: PatChar -> ()
rnf (PatChr Int
_) = ()
  rnf (PatSet ChrSet
s) = ChrSet -> ()
forall a. NFData a => a -> ()
rnf ChrSet
s
  rnf (PatNot ChrSet
n) = ChrSet -> ()
forall a. NFData a => a -> ()
rnf ChrSet
n

instance NFData1 f => NFData (PatCharsOf f) where
  rnf :: PatCharsOf f -> ()
rnf (PatChars f PatChar
l f PatChar
o PatChar
s) = f PatChar -> ()
forall (f :: * -> *) a. (NFData1 f, NFData a) => f a -> ()
rnf1 f PatChar
l () -> () -> ()
`seq` f PatChar -> ()
forall (f :: * -> *) a. (NFData1 f, NFData a) => f a -> ()
rnf1 f PatChar
o () -> () -> ()
`seq` PatChar -> ()
forall a. NFData a => a -> ()
rnf PatChar
s

instance NFData a => NFData (Inf a) where
  rnf :: Inf a -> ()
rnf (Fin a
a) = a -> ()
forall a. NFData a => a -> ()
rnf a
a
  rnf Inf a
Inf = ()