packages feed

anagrep (empty) → 0.1.0.0

raw patch · 12 files changed

+994/−0 lines, 12 filesdep +QuickCheckdep +anagrepdep +basesetup-changed

Dependencies added: QuickCheck, anagrep, base, bytestring, case-insensitive, containers, criterion, deepseq, ghc-prim, hspec, integer-gmp, regex-tdfa, vector

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Regex/Anagram.hs view
@@ -0,0 +1,26 @@+-- |The basic use of this module is to first parse a regular expression string (like @"[mn]{2,5}[eio]+s?"@) into an 'Anagrex' with 'makeAnagrex'.+-- This can then be used to efficiently test candidate strings with 'testAnagrex'.+module Text.Regex.Anagram+  ( Anagrex+  , makeAnagrex+  , makeAnagrexCI+  , testAnagrex+  , testAnagrexCI+  ) where++import qualified Data.CaseInsensitive as CI+import qualified Data.CaseInsensitive.Unsafe as CI++import Text.Regex.Anagram.Parse+import Text.Regex.Anagram.Compile+import Text.Regex.Anagram.Test++-- |Build a case-insensitive version of a pattern.+-- This is more efficient than 'CI.mk' since it avoids the complication of the case-sensitive version as well.+-- Uses 'CI.unsafeMk' so the 'CI.original' version is also case-folded.+makeAnagrexCI :: String -> Either String (CI.CI Anagrex)+makeAnagrexCI = fmap (CI.unsafeMk . compileAnagrex . CI.foldCase) . parseAnaPattern++-- |Test a case-insensitive pattern against a case-insensitive string.  You can also directly use 'Data.CaseInsensitive.foldCase' on both the pattern and the string to test.+testAnagrexCI :: CI.CI Anagrex -> CI.CI String -> Bool+testAnagrexCI p = testAnagrex (CI.foldedCase p) . CI.foldedCase
+ Text/Regex/Anagram/Bits.hs view
@@ -0,0 +1,58 @@+-- |Some extra functionality for Bits instances, specifically an optimized version of 'findBits' on 'Natural' (using 'countTrailingZeros').+-- Mainly exposed for testing purposes, but may be useful on its own.+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MagicHash #-}++module Text.Regex.Anagram.Bits+  where++import           Data.Bits+import           Data.Int+import           Data.Word+import           Numeric.Natural (Natural)++#ifdef VERSION_ghc_prim+import qualified GHC.Integer.GMP.Internals as GHC+import qualified GHC.Natural as GHC+import qualified GHC.Types as GHC+#include "MachDeps.h"+#endif++-- |value with all lower n bits set+allBits :: (Enum b, Bits b) => Int -> b+allBits = pred . bit++class Bits b => FindBits b where+  -- |list of all set bits in a value+  findBits :: b -> [Int]+  default findBits :: FiniteBits b => b -> [Int]+  findBits w+    | i == finiteBitSize w = []+    | otherwise = i : findBits (clearBit w i)+    where i = countTrailingZeros w++instance FindBits Int+instance FindBits Int8+instance FindBits Int16+instance FindBits Int32+instance FindBits Int64+instance FindBits Word+instance FindBits Word8+instance FindBits Word16+instance FindBits Word32+instance FindBits Word64++instance FindBits Natural where+#ifdef VERSION_ghc_prim+  findBits (GHC.NatS# w) = findBits (GHC.W# w)+  findBits (GHC.NatJ# b) = concatMap fbi [0..pred (GHC.I# (GHC.sizeofBigNat# b))]+    where+    fbi i@(GHC.I# i#) = let w = GHC.W# (GHC.indexBigNat# b i#) in map (i*finiteBitSize w+) $ findBits w+#else+  findBits = fb 0 . unBitVec where+    fb i x+      | x == B.zeroBits = []+      | B.testBit x i = i : fb (succ i) (B.clearBit x i)+      | otherwise = fb (succ i) x+#endif
+ Text/Regex/Anagram/Compile.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE RecordWildCards #-}++module Text.Regex.Anagram.Compile+  ( AnaPat(..)+  , Anagrex(..)+  , compileAnagrex+  , makeAnagrex+  ) where++import           Control.DeepSeq (NFData(..))+import           Control.Monad (mfilter)+import           Data.CaseInsensitive (FoldCase(..))+import           Data.Foldable (fold)+import           Data.Functor.Identity (Identity(Identity))+import qualified Data.IntSet as S+import           Data.List (sort)+import           Data.Maybe (mapMaybe)+import           Data.String (IsString(..))++import Text.Regex.Anagram.Types+import Text.Regex.Anagram.Util+import Text.Regex.Anagram.Parse++-- |Compiled matching pattern+data AnaPat = AnaPat+  { patUncompiled :: PatChars -- ^original, uncompiled pattern (only for CI)+  , patChars :: PatCharsOf RLE+  , patSets :: PatCharsOf Identity+  , patMin :: Int -- ^minimum length+  , patMax :: Inf Int -- ^maximum length+  } deriving (Show)++-- |A compiled regular expression pattern to match anagrams.+-- Represented as an (expanded) list of alternative 'AnaPat's.+newtype Anagrex = Anagrex [AnaPat]+  deriving (Show)++compilePat :: PatChars -> AnaPat+compilePat p@PatChars{..} = AnaPat+  { patUncompiled = p+  , patChars = PatChars+    { patReqs = rle $ sort patReqs+    , patOpts = rle $ sort opts+    , patStar = patStar+    }+  , patSets = PatChars+    { patReqs = Identity rs+    , patOpts = Identity os+    , patStar = os <> patStar+    }+  , patMin = rlen+  , patMax = case patStar of+      PatSet s | S.null s -> Fin $ rlen + length opts+      _ -> Inf+  }+  where+  rs = fold patReqs+  os = rs <> fold opts+  rlen = length patReqs+  opts = mapMaybe (mfilter (not . nullChar) . Just . intersectChar (notChar patStar)) patOpts++compileAlts :: [PatChars] -> [AnaPat]+compileAlts = map compilePat++-- |Compile an already-parsed 'AnaPattern' into an 'Anagrex'.+compileAnagrex :: AnaPattern -> Anagrex+compileAnagrex (AnaPattern l) = Anagrex $ compileAlts l++-- |Build a regular expression for matching anagrams from a string, returning 'Left' error for invalid or unsupported regular expressions.+-- (Uses 'Text.Regex.TDFA.ReadRegex.parseRegex'.)+-- This works by first expanding out a list of alternative patterns (like @"a|(b(c|d))"@ into @["a","bc","bd"]@) and then creating optimized pattern represenations for each.+makeAnagrex :: String -> Either String Anagrex+makeAnagrex = fmap compileAnagrex . parseAnaPattern++instance FoldCase AnaPat where+  foldCase AnaPat{ patUncompiled = p } = compilePat $ foldCase p++-- |Used to create a case-insensitive version of a pattern.+-- Note that this involves a re-compilation of the parsed 'AnaPattern'.  You can avoid this by using 'Text.Regex.Anagram.makeAnagrexCI'.+instance FoldCase Anagrex where+  foldCase (Anagrex l) = Anagrex $ map foldCase l++instance IsString Anagrex where+  fromString = either error id . makeAnagrex++instance NFData AnaPat where+  rnf (AnaPat _ c s i j) = rnf c `seq` rnf s `seq` rnf i `seq` rnf j+instance NFData Anagrex where+  rnf (Anagrex l) = rnf l
+ Text/Regex/Anagram/Parse.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE RecordWildCards #-}++module Text.Regex.Anagram.Parse+  ( AnaPattern(..)+  , parseAnaPattern+  ) where++import           Data.CaseInsensitive (FoldCase(..))+import qualified Data.IntSet as S+import qualified Data.Set as Set+import           Data.String (IsString(..))+import qualified Text.Regex.TDFA.Pattern as R+import qualified Text.Regex.TDFA.ReadRegex as R++import Text.Regex.Anagram.Types+import Text.Regex.Anagram.Util++-- |A parsed intermediate representation of regular expression pattern to match anagrams.+-- This is exposed mainly to make case-insensitive matches more efficient, so that 'foldCase' can be performed on the 'AnaPattern' to avoid unnecessary compilation.+-- Represented as an (expanded) list of alternative 'PatChars'.+newtype AnaPattern = AnaPattern [PatChars]+  deriving (Show)++chrSet :: Set.Set Char -> ChrSet+chrSet = S.fromAscList . map fromEnum . Set.toAscList++charPat :: PatChar -> PatChars+charPat p = mempty{ patReqs = [p] }++makeChar :: R.Pattern -> Maybe PatChar+makeChar R.PDot{} = return $ PatNot S.empty+makeChar R.PChar{ R.getPatternChar = c } = return $ PatChr $ fromEnum c+makeChar R.PEscape{ R.getPatternChar = c }+  | c `notElem` "`'<>bB" = return $ PatChr $ fromEnum c+-- TODO: use R.decodePatternSet+makeChar R.PAny{ R.getPatternSet = R.PatternSet (Just s) Nothing Nothing Nothing } =+  return $ PatSet $ chrSet s+makeChar R.PAnyNot{ R.getPatternSet = R.PatternSet (Just s) Nothing Nothing Nothing } =+  return $ PatNot $ chrSet s+makeChar _ = Nothing++makePattern :: R.Pattern -> Maybe PatChars+makePattern (R.PGroup _ r) = makePattern r+makePattern (R.PNonCapture r) = makePattern r+makePattern (R.POr [r]) = makePattern r+makePattern (R.PConcat l) = foldMapM makePattern l+makePattern (R.PQuest r) = do+  p <- makeChar r+  return mempty{ patOpts = [p] }+makePattern (R.PPlus r) = do+  p <- makeChar r+  return mempty{ patReqs = [p], patStar = p }+makePattern (R.PStar _ r) = do+  p <- makeChar r+  return mempty{ patStar = p }+makePattern (R.PBound i j' r) = do+  p <- makeChar r+  let ip = mempty{ patReqs = replicate i p }+  return $ maybe+    ip{ patStar = p }+    (\j -> ip{ patOpts = replicate (j - i) p })+    j'+makePattern R.PEmpty = return mempty+makePattern r = charPat <$> makeChar r++makeAlts :: R.Pattern -> Maybe [PatChars]+makeAlts (R.PGroup _ r) = makeAlts r+makeAlts (R.PNonCapture r) = makeAlts r+makeAlts (R.POr o) = concatMapM makeAlts o+makeAlts (R.PConcat c) = cross <$> mapM makeAlts c where+  cross [] = [mempty]+  cross (l:r) = do+    a <- l+    b <- cross r+    return (a <> b)+makeAlts r = return <$> makePattern r++-- |Parse a string as a regular expression for matching anagrams, returning 'Left' error for invalid or unsupported regular expressions.  (Uses 'R.parseRegex'.)+parseAnaPattern :: String -> Either String AnaPattern+parseAnaPattern r = case R.parseRegex r of+  Left e -> Left (show e)+  Right (p, _) -> maybe (Left "regexp contains features not supported for anagrams")+    (Right . AnaPattern) $ makeAlts $ R.dfsPattern R.simplify' p++instance FoldCase AnaPattern where+  foldCase (AnaPattern l) = AnaPattern (map foldCase l)++instance IsString AnaPattern where+  fromString = either error id . parseAnaPattern
+ Text/Regex/Anagram/Test.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++module Text.Regex.Anagram.Test+  ( testAnagrex+  ) where++import           Control.Arrow (second)+import           Control.Monad (join)+import qualified Data.Bits as B+import           Data.Functor.Identity (runIdentity)+import qualified Data.IntMap.Strict as M+import           Data.List (mapAccumL)+import           Data.Maybe (isJust, fromJust)+import           Data.Ord (comparing)+import qualified Data.Vector as V+import           Numeric.Natural (Natural)++import Text.Regex.Anagram.Types+import Text.Regex.Anagram.Util+import Text.Regex.Anagram.Compile+import Text.Regex.Anagram.Bits++-- |All subsets of a given length (choose p)+subsets :: Int -> RLE a -> [RLE a]+subsets size list = map RLE $ ss size (rleLength list) (unRLE list) where+  ss 0 _ _ = [[]]+  ss n s l = case compare n s of+    GT -> []+    EQ -> [l]+    LT -> do+      let ~(RL x r:m) = l+      i <- [max 0 (n+r-s)..min n r]+      (if i > 0 then (RL x i :) else id) <$> ss (n-i) (s-r) m++newtype BitVec = BitVec{ unBitVec :: Natural }+  deriving (Eq, B.Bits, FindBits, Show)++instance Semigroup BitVec where+  BitVec x <> BitVec y = BitVec $ x B..|. y+instance Monoid BitVec where+  mempty = BitVec 0++instance Ord BitVec where+  compare (BitVec x) (BitVec y) = comparing B.popCount x y <> compare x y++allBitv :: RLEV a -> BitVec+allBitv = BitVec . allBits . V.length . unRLE++data Pat+  = Req !BitVec+  | Opt+  | Star+  deriving (Eq, Ord, Show)++-- |just a lens+class HasBitVec a where+  getBitVec :: a -> BitVec+  mapBitVec :: (BitVec -> BitVec) -> a -> a++instance HasBitVec BitVec where+  getBitVec = id+  mapBitVec = id++instance HasBitVec (a, BitVec) where+  getBitVec = snd+  mapBitVec = second++instance HasBitVec Pat where+  getBitVec ~(Req a) = a+  mapBitVec f (Req a) = Req (f a)+  mapBitVec _ p = p++instance HasBitVec a => HasBitVec (RL a) where+  getBitVec = getBitVec . unRL+  mapBitVec f = fmap (mapBitVec f)++transpose' :: (HasBitVec a, HasBitVec b) => RLEV a -> RLEV b -> RLEV b+transpose' (RLE al) (RLE bl) =+  (RLE $ V.imap (fmap . tp) bl)+  where+  tp i = mapBitVec $ const $ V.ifoldl' (\y j v -> if B.testBit (getBitVec v) i then B.setBit y j else y) mempty al++data Matrix a b = Matrix+  { matCols :: !(RLEV a)+  , matRows :: !(RLEV b)+  } deriving (Show)++transpose :: Matrix a b -> Matrix b a+transpose (Matrix a b) = Matrix b a++data PatMatrix = PatMatrix+  { patMatrix :: !(Matrix BitVec Pat)+  , patMatReq :: !(Maybe Int)+  } deriving (Show)++initMatrix :: PatCharsOf RLE -> ChrStr -> Maybe PatMatrix+initMatrix PatChars{..} cs =+  guard' (all ((mempty /=) . unRL) $ unRLE reqv) $+    PatMatrix (Matrix (transpose' pv $ mempty <$ cv) (fmap fst pv)) (Just $ length $ unRLE reqs)+  where+  cv = withRLE V.fromList $ chrStrRLE cs+  si = M.fromAscList $ V.toList $ V.imap (\i (RL c _) -> (c,i)) $ unRLE cv+  pv = withRLE V.fromList $ reqs <> opts <> stars+  reqv =                         fmap vp patReqs+  optv = filterRLE (mempty /=) $ fmap vp patOpts+  reqs = fmap (join ((,) . Req)) $ sortRLE reqv+  opts = fmap       ((,)   Opt)  $ sortRLE optv+  stars+    | nullChar patStar || vps == mempty = RLE []+    | otherwise = RLE [RL (Star, vps) (B.unsafeShiftR maxBound 1)]+    where vps = vp patStar+  vp (PatChr c) = maybe mempty B.bit $ M.lookup c si+  vp (PatSet s) = M.foldl' B.setBit   mempty       $ M.restrictKeys si s+  vp (PatNot n) = M.foldl' B.clearBit (allBitv cv) $ M.restrictKeys si n+    -- M.foldl' B.setBit mempty $ M.withoutKeys si n++decrRows :: (HasBitVec a, HasBitVec b) => Int -> Matrix a b -> RLE (Int, RL b) -> Matrix a b+decrRows i (Matrix cm rm) l = Matrix+  { matCols = withRLE (V.map (mapBitVec (m B..&.))) cm+  , matRows = withRLE (V.// u) rm+  }+  where+  (m, u) = mapAccumL (\x (RL (j, RL jp jr) r) -> if jr == r+      then (B.clearBit x j, (j, RL (mapBitVec (const mempty)   jp) 0))+      else (           x,   (j, RL (mapBitVec (`B.clearBit` i) jp) (jr - r))))+    (allBitv rm) $ unRLE l++tryCol :: (HasBitVec a, HasBitVec b) => Int -> RL a -> Matrix a b -> [Matrix a b]+tryCol i iv m = map (decrRows i m')+  $ subsets (rl iv)+    $ RLE $ map (\j ->+      let jr = V.unsafeIndex (unRLE $ matRows m) j in+      RL (j, jr) (rl jr))+    $ findBits $ getBitVec iv+  where+  m' = m{ matCols = withRLE (V.// [(i, iv{ rl = 0 })]) $ matCols m }++tryPat :: Int -> RL Pat    -> PatMatrix -> [PatMatrix]+tryChr :: Int -> RL BitVec -> PatMatrix -> [PatMatrix]+tryPat i iv pm = map (\m -> pm{ patMatrix = transpose m }) $ tryCol i iv $ transpose $ patMatrix pm+tryChr i iv pm = map (\m -> pm{ patMatrix = m })           $ tryCol i iv             $ patMatrix pm++prio :: HasBitVec a => RL a -> RL a -> Ordering+prio (RL _ 0) (RL _ 0) = EQ+prio (RL _ 0) _        = GT+prio _        (RL _ 0) = LT+prio (RL a r) (RL b s) = comparing (B.popCount . getBitVec) a b <> compare s r++doneReq :: PatMatrix -> [PatMatrix]+doneReq (PatMatrix m@(Matrix cm pm) ~(Just pr))+  | RL Star _ <- V.last (unRLE pm) = next j $ Matrix+    (withRLE (V.map ts) cm)+    (withRLE V.init pm)+  | otherwise = next (succ j) m+  where+  next j' m' = (if pr >= j' then return else tryMatrix) $ PatMatrix m' Nothing+  ts v@(RL x _)+    | B.testBit x j = RL mempty 0+    | otherwise = v+  j = pred $ V.length $ unRLE pm++tryMatrix :: PatMatrix -> [PatMatrix]+tryMatrix m@(PatMatrix (Matrix cm pm) pr)+  | isJust pr && (pr == Just 0 || jr == 0) = doneReq m+  | isJust pr && (B.popCount y <= 1 || B.popCount x > 1) =+    tryMatrix =<< tryPat j jv m+  | isJust pr && ir == 0 = []+  |              ir == 0 = [m]+  | x == mempty = []+  | otherwise =+    tryMatrix =<< tryChr i iv m+  where+  i = V.minIndexBy prio $                        unRLE cm+  j = V.minIndexBy prio $ V.take (fromJust pr) $ unRLE pm+  iv@(RL       x  ir) = V.unsafeIndex (unRLE cm) i+  jv@(RL ~(Req y) jr) = V.unsafeIndex (unRLE pm) j++testPat :: Int -> ChrStr -> AnaPat -> Bool+testPat l s AnaPat{ .. }+  | l < patMin = False+  | Fin l > patMax = False+  | not $ allChrs (patStar patSets) s = False+  | M.null s' = null $ unRLE $ patReqs patChars+  | otherwise = maybe False+    (any (V.all ((0 ==) . rl) . unRLE . matCols . patMatrix)+      . tryMatrix) $ initMatrix patChars s'+  where+  s' = intersectChrStr (runIdentity $ patOpts patSets) s++-- |Check if any permutations of a string matches a parsed regular expression.  Always matches the full string.+testAnagrex :: Anagrex -> String -> Bool+testAnagrex (Anagrex l) s = any (testPat (length s) $ chrStr $ map fromEnum s) l
+ Text/Regex/Anagram/Types.hs view
@@ -0,0 +1,155 @@+{-# 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+  { unRL :: !a+  , rl :: !Int+  } deriving (Eq, Ord, Show)++instance Functor RL where+  fmap f (RL a n) = RL (f a) n++newtype RLEof f a = RLE{ 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 f (RLE l) = RLE $ fmap (fmap f) l++deriving instance Semigroup (RLE a)+deriving instance Monoid (RLE a)++data Inf a+  = Fin !a+  | Inf+  deriving (Eq, Ord, Show)++-- we don't really use this whole instance+instance (Eq a, Num a) => Num (Inf a) where+  Fin a + Fin b = Fin $ a + b+  Inf + _ = Inf+  _ + Inf = Inf+  Fin a * Fin b = Fin $ a * b+  Inf * Fin 0 = Fin 0+  Inf * _ = Inf+  Fin 0 * Inf = Fin 0+  _ * Inf = Inf+  abs (Fin a) = Fin a+  abs Inf = Inf+  signum (Fin a) = Fin (signum a)+  signum Inf = Fin 1+  negate (Fin a) = Fin (negate a)+  negate Inf = error "negate Inf"+  fromInteger = Fin . 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 (Eq, Show)++instance Semigroup PatChar where+  PatSet s <> x | S.null s = x -- opt+  PatSet s <> PatChr c = PatSet (S.insert c s)+  PatSet s <> PatSet t = PatSet (S.union s t)+  PatSet s <> PatNot n = PatNot (S.difference n s)+  PatChr c <> PatChr d+    | c == d = PatChr c+    | otherwise = PatSet (S.fromList [c,d])+  PatChr c <> PatNot n = PatNot (S.delete c n)+  PatNot n <> PatNot m = PatNot (S.intersection n m)+  a <> b = b <> a++instance Monoid PatChar where+  mempty = PatSet S.empty++instance Ord PatChar where+  compare (PatChr c1) (PatChr c2) = compare c1 c2+  compare (PatSet s1) (PatSet s2) = comparing S.size s1 s2 <> compare s1 s2+  compare (PatNot s1) (PatNot s2) = comparing S.size s2 s1 <> compare s1 s2+  compare (PatChr _) _ = LT+  compare (PatSet _) (PatNot _) = LT+  compare _ _ = GT++-- |The parsed characters from a regex pattern+data PatCharsOf f = PatChars+  { patReqs :: f PatChar -- ^requried chars+  , patOpts :: f PatChar -- ^optional chars (x?)+  , 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 l1 o1 e1 <> PatChars l2 o2 e2 =+    PatChars (l1 <> l2) (o1 <> o2) (e1 <> e2)+  stimes n (PatChars l o e) = PatChars (stimes n l) (stimes n o) e++instance Monoid PatChars where+  mempty = PatChars mempty mempty mempty+++foldCaseChr :: Chr -> Chr+foldCaseChr c = fromEnum (foldCase (toEnum c :: Char))++instance FoldCase PatChar where+  foldCase (PatChr c) = PatChr (foldCaseChr c)+  foldCase (PatSet s) = PatSet (S.map foldCaseChr s)+  foldCase (PatNot s) = PatNot (S.map foldCaseChr s)++instance Functor f => FoldCase (PatCharsOf f) where+  foldCase p@PatChars{..} = p+    { patReqs = fmap foldCase patReqs+    , patOpts = fmap foldCase patOpts+    , patStar = foldCase patStar+    }++instance NFData1 RL where+  liftRnf f (RL a _) = f a++instance NFData1 f => NFData1 (RLEof f) where+  liftRnf f (RLE l) = liftRnf (liftRnf f) l++instance NFData PatChar where+  rnf (PatChr _) = ()+  rnf (PatSet s) = rnf s+  rnf (PatNot n) = rnf n++instance NFData1 f => NFData (PatCharsOf f) where+  rnf (PatChars l o s) = rnf1 l `seq` rnf1 o `seq` rnf s++instance NFData a => NFData (Inf a) where+  rnf (Fin a) = rnf a+  rnf Inf = ()
+ Text/Regex/Anagram/Util.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TupleSections #-}++module Text.Regex.Anagram.Util+  where++import           Control.Applicative (Alternative, empty)+import           Data.Foldable (foldlM)+import           Data.Function (on)+import qualified Data.IntMap.Strict as M+import qualified Data.IntSet as S+import           Data.List (group, groupBy, sortOn)+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Bundle as VB+import qualified Data.Vector.Fusion.Bundle.Size as VBS+import qualified Data.Vector.Fusion.Stream.Monadic as VS+import qualified Data.Vector.Generic as VG++import Text.Regex.Anagram.Types++guard' :: Alternative m => Bool -> a -> m a+guard' True = pure+guard' False = const empty++foldMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b+-- foldMapM f = fmap fold . mapM f+foldMapM f = foldlM (\b a -> (b <>) <$> f a) mempty++concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+-- concatMapM = foldMapM+concatMapM f = fmap concat . mapM f++{-# INLINE withRLE #-}+withRLE :: (f (RL a) -> g (RL b)) -> RLEof f a -> RLEof g b+withRLE f = RLE . f . unRLE++rleLength :: RLE a -> Int+rleLength = foldl (\l (RL _ r) -> l + r) 0 . unRLE++rle :: Eq a => [a] -> RLE a+rle = RLE . map (\(x:l) -> RL x (succ $ length l)) . group++rleV :: Eq a => V.Vector a -> RLEV a+rleV = RLE . VG.unstream . VB.inplace rles VBS.toMax . VG.stream where+  rles (VS.Stream step st) = VS.Stream step' (Nothing, st) where+    step' (m, s) = do+      t <- step s+      case t of+        VS.Yield x s' -> case m of+          Nothing -> return $ VS.Skip (Just (RL x 1), s')+          Just r@(RL y n)+            | x == y -> return $ VS.Skip (Just (RL x $ succ n), s')+            | otherwise -> return $ VS.Yield r (Just (RL x 1), s')+        VS.Skip s' -> return $ VS.Skip (m, s')+        VS.Done -> return $ maybe VS.Done (\r -> VS.Yield r (Nothing, s)) m++sortRLE :: Ord a => RLE a -> RLE a+sortRLE = withRLE $ map (\(RL x r:l) -> RL x (r + rleLength (RLE l))) . groupBy ((==) `on` unRL) . sortOn unRL++filterRLE :: (a -> Bool) -> RLE a -> RLE a+filterRLE f = withRLE $ filter (f . unRL)++chrStr :: [Chr] -> ChrStr+chrStr = M.fromListWith (+) . map (, 1)++chrStrRLE :: ChrStr -> RLE Chr+chrStrRLE = RLE . map (uncurry RL) . M.toList++nullChar :: PatChar -> Bool+nullChar (PatSet s) = S.null s+nullChar _ = False++notChar :: PatChar -> PatChar+notChar (PatChr c) = PatNot (S.singleton c)+notChar (PatSet s) = PatNot s+notChar (PatNot s) = PatSet s++intersectChrStr :: PatChar -> ChrStr -> ChrStr+intersectChrStr (PatSet s) t = M.restrictKeys t s+intersectChrStr (PatNot n) t = M.withoutKeys t n+intersectChrStr (PatChr c) t = foldMap (M.singleton c) $ M.lookup c t++allChrs :: PatChar -> ChrStr -> Bool+allChrs p = M.null . intersectChrStr (notChar p)++intersectChr :: ChrSet -> PatChar -> PatChar+intersectChr s p@(PatChr c)+  | S.member c s = p+  | otherwise = mempty+intersectChr s (PatSet t) = PatSet $ S.intersection s t+intersectChr s (PatNot n) = PatSet $ S.difference s n++differenceChr :: ChrSet -> PatChar -> PatChar+differenceChr n p@(PatChr c)+  | S.member c n = mempty+  | otherwise = p+differenceChr n (PatSet s) = PatSet $ S.difference s n+differenceChr n (PatNot m) = PatNot $ S.union m n++intersectChar :: PatChar -> PatChar -> PatChar+intersectChar (PatSet s) p =  intersectChr s p+intersectChar (PatNot n) p = differenceChr n p+intersectChar p@(PatChr c) (PatChr d)+  | c == d = p+  | otherwise = mempty+intersectChar a b = intersectChar b a
+ anagrep.cabal view
@@ -0,0 +1,80 @@+cabal-version:       >=1.10+name:                anagrep+version:             0.1.0.0+synopsis:            Find strings with permutations (anagrams) that match a regular expression+description:         +  Given a regular expression, determine if it matches any permutation of a given string.  For example, @"lt[aeiou]*"@ would match all strings with one \'l\', one \'t\', and vowels (like \"elate\", \"tail\", \"tl\", etc.).+  Regular expression parsing is based on <//hackage.haskell.org/package/regex-tdfa regex-tdfa> and generally follows those semantics, but not all regular expression features are supported.  For example, repeat modifiers cannot be applied to groups (such as "(abc)*").+  The goal is for matching to be fairly efficient in most cases, given that this problem is NP-complete.+license:             BSD3+author:              Dylan Simon+maintainer:          dylan@dylex.net+copyright:           2020, Dylan Simon+category:            Text+build-type:          Simple++source-repository head+  type:     git+  location: git://github.com/dylex/anagrep++flag ghc+  description: Enable ghc-specific optimizations (on internal Natural representation)+  default: True++library+  exposed-modules:+    Text.Regex.Anagram+    Text.Regex.Anagram.Bits+  other-modules:+    Text.Regex.Anagram.Types+    Text.Regex.Anagram.Util+    Text.Regex.Anagram.Parse+    Text.Regex.Anagram.Compile+    Text.Regex.Anagram.Test+  build-depends:       +    base < 5,+    containers,+    vector,+    regex-tdfa,+    case-insensitive,+    deepseq+  if flag(ghc)+    build-depends: ghc-prim, integer-gmp+  default-language:    Haskell2010+  ghc-options: -Wall++executable anagrep+  hs-source-dirs: src+  main-is:  anagrep.hs+  build-depends:       +    base < 5,+    anagrep,+    bytestring,+    case-insensitive+  default-language:    Haskell2010+  ghc-options: -Wall++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:  Main.hs+  build-depends:+    base < 5,+    anagrep,+    case-insensitive,+    hspec,+    QuickCheck+  default-language:    Haskell2010+  ghc-options: -Wall++benchmark bench+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:  Bench.hs+  build-depends:+    base < 5,+    anagrep,+    bytestring,+    criterion+  default-language:    Haskell2010+  ghc-options: -Wall
+ src/anagrep.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE RecordWildCards #-}++import qualified Data.ByteString.Lazy.Char8 as BSLC+import           Data.CaseInsensitive (FoldCase, foldCase)+import qualified System.Console.GetOpt as Opt+import           System.Environment (getArgs, getProgName)+import           System.Exit (exitFailure)+import           System.IO (hPutStrLn, stderr)++import Text.Regex.Anagram++data Opts = Opts+  { optText, optCI :: Bool }++defOpts :: Opts+defOpts = Opts True False++options :: [Opt.OptDescr (Opts -> Opts)]+options =+  [ Opt.Option "b" []+      (Opt.NoArg (\o -> o{ optText = False }))+      "treat input as raw byte sequence (uses locale encoding by default)"+  , Opt.Option "i" []+      (Opt.NoArg (\o -> o{ optCI = True }))+      "ignore case distinctions in patterns and data"+  ]++main :: IO ()+main = do+  prog <- getProgName+  args <- getArgs+  (Opts{..}, pat, files) <- case Opt.getOpt Opt.Permute options args of+    (o, r:f, []) -> case makeAnagrex r of+      Right p -> return (foldl (flip ($)) defOpts o, p, f)+      Left e -> do+        hPutStrLn stderr e+        exitFailure+    (_, _, e) -> do+      mapM_ (hPutStrLn stderr) e+      hPutStrLn stderr $ Opt.usageInfo ("Usage: " ++ prog ++ " REGEXP [FILE]...\nPrint lines in each FILE (or stdin) for which some permuatation (anagram) matches the given REGEXP.") options+      exitFailure+  let ci :: FoldCase a => a -> a+      ci+        | optCI = foldCase+        | otherwise = id+      grex = ci pat+      test = testAnagrex grex . ci+      proc f+        | optText = mapM_ putStrLn . filter test . lines =<< maybe getContents readFile f+        | otherwise = mapM_ BSLC.putStrLn . filter (test . BSLC.unpack) . BSLC.lines =<< maybe BSLC.getContents BSLC.readFile f+  case files of+    [] -> proc Nothing+    _ -> mapM_ (proc . Just) files
+ test/Bench.hs view
@@ -0,0 +1,28 @@+import qualified Criterion.Main as C+import qualified Data.ByteString.Char8 as BSC++import Text.Regex.Anagram++dicts :: [String]+dicts = +  [ "lt[aoeui]*"+  , "[lt]*[aoeui]{5,10}"+  , "[a-e][f-j][k-o][p-t][u-z]*"+  , "[abc][def][ghi][jkl][mno][pqr][stu][vwx][yz]"+  , "[a-e]?[f-j]?[k-o]?[p-t]?[u-z]*"+  , "[a-z]?[a-m]?[n-z]?[a-e]?[f-j]?[k-o]?[p-t]?[u-z]?"+  , "[a-m]{2,4}[a-g]{2,4}[a-d]{2,4}"+  , "[a-g][a-fz][a-ey-z][a-dx-z][a-cw-z][a-bv-z][au-z]"+  , "[a-g]?[a-fz]?[a-ey-z]?[a-dx-z]?[a-cw-z]?[a-bv-z]?[au-z]?"+  ]++main :: IO ()+main = C.defaultMain+  [ C.bgroup "parse" $ map (\d ->+      C.bench d $ C.nf makeAnagrex d)+      dicts+  , C.env (map BSC.unpack . BSC.lines <$> BSC.readFile "/usr/share/dict/words") $ \dict ->+    C.bgroup "dict" $ map (\d ->+      C.bench d $ C.nf (\(Right p) -> length $ filter (testAnagrex p) dict) (makeAnagrex d))+      dicts+  ]
+ test/Main.hs view
@@ -0,0 +1,114 @@+import           Control.Monad (forM_)+import qualified Data.Bits as B+import qualified Data.CaseInsensitive as CI+import           Data.Either (isRight)+import           Numeric.Natural (Natural)+import           Test.Hspec+import qualified Test.QuickCheck as Q++import Text.Regex.Anagram+import qualified Text.Regex.Anagram.Bits as B++tests :: [(Bool, String, [String], [String])]+tests =+  [ (False, "a*", ["","a","aa","aaa","aaaaaaaaaaaaaa"],+      ["b","ab","bad","A"])+  , (False, "a+b", ["ba","ab","baaaa","aaba"],+      ["","bab","abc","b"])+  , (False, "a[ab]+b", ["baa","aab","aba","abb","bba","bab","aaaba","bbba"],+      ["","ab","aa","aaa","b","xabb"])+  , (False, "a[ab]*b?", ["baa","aab","aba","abb","bba","bab","aaaba","bbba","aa","ab","aaa","a"],+      ["","bbb","b","abc"])+  , (False, "ba{2,}", ["aba","aaab","baaaa","aaaaabaaa"],+      ["a","ab","baac"])+  , (False, "[^a]", ["b","c","d"],+      ["","a","bb","ba"])+  , (False, "[^a-d]*", ["ee","xyz",""],+      ["a","xa","fce"])+  , (False, "[^a][^ab][^abc]", ["bcd","cde","xyz","ccd"],+      ["","a","ab","abc","aaa","bbb","ccc"])+  , (False, "[a-c][^a-c]", ["ad","xc"],+      ["","a","cc","aa","xy","ab"])+  , (False, "[abc]?[ab]?a?", ["","a","b","c","aa","ab","ba","ac","ca","aaa","abc","cab"],+      ["bbc","abcabcabcabc","aaaaa","abcdefg","x"])+  , (False, "[efg][def][cde][bcd][abc]", ["abcde","ccffc","gfedc","defbc"],+      ["","ddd","aaaaa","ccccc","cccae"])+  , (False, "[efg][^def][cde][^bcd][abc]", ["abcde","ccffc","gfedc","defbc","cccae"],+      ["","ddd","aaaaa","ccccc"])+  , (False, "[a-m]{10}", ["abcdefghij","cdfmeadljb","eeeeeeeeee","aaaabbbaaa"],+      ["a","mnopqrstuv","abcdefghix","aaaaaaaaan","abcdefghijklm"])+  , (False, "[a-m]{10}a?", ["abcdefghij","cdfmeadljb","aeeeeeeeeee","aaaabbbaaa","abcdefghijk"],+      ["a","mnopqrstuv","abcdefghix","aaaaaaaaan","abcdefghijklm","abcdefghij1"])+  , (False, "[a-m]{1,10}", ["a","b","m","cde","abcdefghij","cdfmeadljb","eeeeeeeeee","aaaabbb"],+      ["","xyz","abcdefghix","aaaaaxaaaa","abcdefghijklm","aabbccddeeffgghhiijj","abcx"])+  , (False, "[a-m]{13,26}", ["abcdefghijklm","cdfmeadljbjmeab","eeeeeeeeeeeeeeeeeeee","aaaabbbaaaccccaaddddaa","abcdefghijklmmlkjihgfedcba"],+      ["a","mnopqrstuvwxyz","abcdefghijklmabcdefgh1","aaaaaaaaaaaaaaaan","abcdefghijklmmmmmmmmmmn"])+  , (False, "[a-m][a-ln][a-kn-o][a-jn-p][a-in-q][a-hn-r][a-gn-s][a-fn-t][a-en-u][a-dn-v][a-cn-w][a-bn-x][an-y][n-z]", ["abcdefghijklmn", "bcdefghijklmno", "mnopqrstuvwxyz"],+      -- pathologically slow+      ["aaaaaaaaaaaaaa","abcdefghijklm","nnnnnnnnnnnnn","abcdefghijklma"])+  , (False, "[0-9]?[0-8a]?[0-7a-b]?[0-6a-c]?[0-5a-d]?[0-4a-e]?[0-3a-f]?[0-2a-g]?[0-1a-h]?[0a-i]?", ["0123456789", "123456789i", "0000000000", "abcdefghi9", "000000000", "abcdefghi", "", "i", "fab9"],+      ["1111111111","1234567899"])+  , (True, "a*", ["","a","A","aAa"],+      ["b"])+  , (True, "[^A]", ["b"],+      ["","a","A"])+  , (True, "[A-C][^a-c]", ["ad","xc","Ad","XC"],+      ["","a","cc","aa","xy","aA","AA"])+  ]++totals :: [(String, [String])]+totals =+  [ ("()", [""])+  , ("abc", ["abc","acb","bac","bca","cab","cba"])+  , ("[a-d]", ["a","b","c","d"])+  , ("[ab][bc]", ["ab","ac","bb","bc","ca","cb"])+  , ("[ab][ac]", ["aa","ac","ba","bc","ca","cb"])+  , ("a[ab]b", ["baa","aab","aba","abb","bba","bab"])+  , ("a[ab]?b?", ["a","ab","aa","baa","aab","aba","abb","bba","bab"])+  , ("[ab]a?", ["a","b","aa","ab","ba"])+  , ("[ab]{2}a?", ["aa","ab","ba","bb","aaa","aab","aba","baa","abb","bab","bba"])+  , ("(a|b)c", ["ac","ca","bc","cb"])+  , ("(ab|cd)", ["ab","ba","cd","dc"])+  , ("(a|b(b?|c))", ["a","b","bb","bc","cb"])+  , ("a{2,4}", ["aa","aaa","aaaa"])+  ]++props :: [(String, String, CI.CI Anagrex -> Q.Property)]+props =+  [ (".*", "match everything", \p -> Q.property $+      test False p)+  , (".+", "match anything", \p -> Q.property $+      \s -> test False p s Q.=/= null s)+  , (".*x", "match anything with an x", \p -> Q.property $+      \s -> test False p s Q.=== ('x' `elem` s))+  , ("a.*x", "match anything with an a and x", \p -> Q.property $+      \s -> test False p s Q.=== ('x' `elem` s && 'a' `elem` s))+  , (".", "match single chars", \p -> Q.property $+      \s -> test False p s Q.=== (length s == 1))+  , (".{2}", "match two chars", \p -> Q.property $+      \s -> test False p s Q.=== (length s == 2))+  ]++parse :: String -> (CI.CI Anagrex -> Spec) -> Spec+parse r t = describe ("pattern " ++ show r) $ do+  let pp = makeAnagrex r+      Right p = pp+  it "should parse" $ pp `shouldSatisfy` isRight+  t $ CI.mk p++test :: Bool -> CI.CI Anagrex -> String -> Bool+test False p s = testAnagrex (CI.original p) s+test True p s = testAnagrexCI p (CI.mk s)++main :: IO ()+main = hspec $ describe "Text.Regex.Anagram" $ do+  describe "findBits" $ do+    it "should find one bit" $ Q.forAll (Q.choose (0, 255)) $ \i -> B.findBits (B.bit i     :: Natural) Q.=== [i]+    it "should find all bit" $ Q.forAll (Q.choose (0, 255)) $ \i -> B.findBits (B.allBits i :: Natural) Q.=== [0..pred i]+  forM_ tests $ \(ci, r, y, n) -> parse r $ \p -> do+    forM_ y $ \s -> it ("should match " ++ show s) $ test ci p s+    forM_ n $ \s -> it ("should not match " ++ show s) $ not $ test ci p s+  forM_ totals $ \(r, y) -> parse r $ \p -> do+    forM_ y $ \s -> it ("should match " ++ show s) $ test False p s+    it "should not match anything else" $ Q.property $ \s -> test False p s Q.=== (s `elem` y)+  forM_ props $ \(r, d, t) -> parse r $ it ("should " ++ d) . t