module Text.Regex.TDFA.Common where
import Text.Show.Functions()
import Data.Monoid(mempty,mappend)
import Data.Foldable(Foldable(..))
import Data.Array.IArray(Array)
import Data.IntSet.EnumSet2(EnumSet)
import qualified Data.IntSet.EnumSet2 as Set(toList)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IMap (findWithDefault,assocs,toList,null)
import Data.IntSet(IntSet)
import Data.IntMap.CharMap2(CharMap)
import qualified Data.IntMap.CharMap2 as Map (assocs,toAscList,null)
import Data.Sequence(Seq)
import Text.Regex.TDFA.IntArrTrieSet(TrieSet)
look :: Int -> IntMap a -> a
look key imap = IMap.findWithDefault (common_error "Text.Regex.DFA.Common" ("key "++show key++" not found in look")) key imap
common_error :: String -> String -> a
common_error moduleName message =
error ("Explict error in module "++moduleName++" : "++message)
on :: (t1 -> t1 -> t2) -> (t -> t1) -> t -> t -> t2
f `on` g = (\x y -> (g x) `f` (g y))
norep :: (Eq a) => [a]->[a]
norep [] = []
norep x@[_] = x
norep (a:bs@(c:cs)) | a==c = norep (a:cs)
| otherwise = a:norep bs
norepBy :: (a -> a -> Bool) -> [a] -> [a]
norepBy _ [] = []
norepBy _ x@[_] = x
norepBy eqF (a:bs@(c:cs)) | a `eqF` c = norepBy eqF (a:cs)
| otherwise = a:norepBy eqF bs
mapFst :: (Functor f) => (t -> t2) -> f (t, t1) -> f (t2, t1)
mapFst f = fmap (\ (a,b) -> (f a,b))
mapSnd :: (Functor f) => (t1 -> t2) -> f (t, t1) -> f (t, t2)
mapSnd f = fmap (\ (a,b) -> (a,f b))
fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,x,_) = x
thd3 :: (a,b,c) -> c
thd3 (_,_,x) = x
flipOrder :: Ordering -> Ordering
flipOrder GT = LT
flipOrder LT = GT
flipOrder EQ = EQ
noWin :: WinTags -> Bool
noWin = null
newtype DoPa = DoPa {dopaIndex :: Int} deriving (Eq,Ord)
instance Enum DoPa where
toEnum = DoPa
fromEnum = dopaIndex
instance Show DoPa where
showsPrec p (DoPa {dopaIndex=i}) = ('#':) . showsPrec p i
data CompOption = CompOption { caseSensitive :: Bool
, multiline :: Bool
, rightAssoc :: Bool
, lastStarGreedy :: Bool
} deriving (Read,Show)
data ExecOption = ExecOption { captureGroups :: Bool
, testMatch :: Bool
} deriving (Read,Show)
type Tag = Int
data OP = Maximize | Minimize | Orbit | Ignore deriving (Eq,Show)
type Index = Int
type SetIndex = IntSet
type Position = Int
type GroupIndex = Int
data GroupInfo = GroupInfo {thisIndex,parentIndex::GroupIndex
,startTag,stopTag,flagTag::Tag
} deriving Show
data Regex = Regex {regex_dfa :: DFA
,regex_init :: Index
,regex_b_index :: (Index,Index)
,regex_b_tags :: (Tag,Tag)
,regex_trie :: TrieSet DFA
,regex_tags :: Array Tag OP
,regex_groups :: Array GroupIndex [GroupInfo]
,regex_isFrontAnchored :: Bool
,regex_compOptions :: CompOption
,regex_execOptions :: ExecOption}
data WinEmpty = WinEmpty Instructions
| WinTest WhichTest (Maybe WinEmpty) (Maybe WinEmpty)
deriving Show
data QNFA = QNFA {q_id :: Index
,q_qt :: QT}
data QT = Simple {qt_win :: WinTags
,qt_trans :: CharMap QTrans
,qt_other :: QTrans
}
| Testing {qt_test :: WhichTest
,qt_dopas :: EnumSet DoPa
,qt_a,qt_b :: QT
}
type QTrans = IntMap [TagCommand]
data WhichTest = Test_BOL | Test_EOL deriving (Show,Eq,Ord,Enum)
data TagTask = TagTask | ResetGroupStopTask | SetGroupStopTask
| ResetOrbitTask | EnterOrbitTask | LeaveOrbitTask deriving (Show,Eq)
type TagTasks = [(Tag,TagTask)]
data TagUpdate = PreUpdate TagTask | PostUpdate TagTask deriving (Show,Eq)
type TagList = [(Tag,TagUpdate)]
type TagCommand = (DoPa,TagList)
type WinTags = TagList
data DFA = DFA { d_id :: SetIndex, d_dt :: DT } deriving(Show)
data Transition = Transition { trans_many :: DFA
, trans_single :: DFA
, trans_how :: DTrans
}
data DT = Simple' { dt_win :: IntMap Instructions
, dt_trans :: CharMap Transition
, dt_other :: Transition
}
| Testing' { dt_test :: WhichTest
, dt_dopas :: EnumSet DoPa
, dt_a,dt_b :: DT
}
type DTrans = IntMap (IntMap (DoPa,Instructions))
type DTrans' = [(Index, [(Index, (DoPa, ([(Tag, (Position,Bool))],[String])))])]
data Orbits = Orbits
{ inOrbit :: !Bool
, basePos :: Position
, ordinal :: (Maybe Int)
, getOrbits :: !(Seq Position)
} deriving (Show)
data Instructions = Instructions
{ newPos :: ![(Tag,Action)]
, newOrbits :: !(Maybe (Position -> OrbitTransformer))
} deriving (Show)
data Action = SetPre | SetPost | SetVal Int deriving (Show,Eq)
type OrbitTransformer = OrbitLog -> OrbitLog
type OrbitLog = IntMap Orbits
instance Show QNFA where
show (QNFA {q_id = i, q_qt = qt}) = "QNFA {q_id = "++show i
++"\n ,q_qt = "++ show qt
++"\n}"
instance Show QT where
show = showQT
showQT :: QT -> String
showQT (Simple win trans other) = "{qt_win=" ++ show win
++ "\n, qt_trans=" ++ show (foo trans)
++ "\n, qt_other=" ++ show (foo' other) ++ "}"
where foo :: CharMap QTrans -> [(Char,[(Index,[TagCommand])])]
foo = mapSnd foo' . Map.toAscList
foo' :: QTrans -> [(Index,[TagCommand])]
foo' = IMap.toList
showQT (Testing test dopas a b) = "{Testing "++show test++" "++show (Set.toList dopas)
++"\n"++indent' a
++"\n"++indent' b++"}"
where indent' = init . unlines . map (spaces++) . lines . showQT
spaces = replicate 9 ' '
instance Show DT where show = showDT
indent :: [String] -> String
indent = unlines . map (\x -> ' ':' ':x)
showDT :: DT -> String
showDT (Simple' w t o) =
"Simple' { dt_win = " ++ seeWin1
++ "\n , dt_trans = " ++ seeTrans1
++ "\n , dt_other = " ++ seeOther1 o
++ "\n }"
where
seeWin1 | IMap.null w = "No win"
| otherwise = indent . map show . IMap.assocs $ w
seeTrans1 :: String
seeTrans1 | Map.null t = "No (Char,Transition)"
| otherwise = ('\n':) . indent $
map (\(char,Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans}) ->
concat ["("
,show char
,", MANY "
,show (d_id dfa)
,", SINGLE "
,show (d_id dfa2)
,", \n"
,seeDTrans dtrans
,")"]) (Map.assocs t)
seeOther1 (Transition {trans_many=dfa,trans_single=dfa2,trans_how=dtrans}) =
concat ["(MANY "
,show (d_id dfa)
,", SINGLE "
,show (d_id dfa2)
,", \n"
,seeDTrans dtrans
,")"]
showDT (Testing' wt d a b) = "Testing' { dt_test = " ++ show wt
++ "\n , dt_dopas = " ++ show d
++ "\n , dt_a = " ++ indent' a
++ "\n , dt_b = " ++ indent' b
++ "\n }"
where indent' = init . unlines . (\(h:t) -> h : (map (spaces ++) t)) . lines . showDT
spaces = replicate 10 ' '
seeDTrans :: DTrans -> String
seeDTrans x | IMap.null x = "No DTrans"
seeDTrans x = concatMap seeSource (IMap.assocs x)
where seeSource (dest,srcMap) | IMap.null srcMap = indent [show (dest,"SPAWN")]
| otherwise = indent . map (\(source,ins) -> show (dest,source,ins) ) . IMap.assocs $ srcMap
data SList a = !a :! !(SList a) | SEnd
infixr :!
instance Functor SList where
fmap f = go where go SEnd = SEnd
go (a :! b) = f a :! go b
instance Foldable SList where
fold SEnd = mempty
fold (a :! b) = a `mappend` fold b
foldMap f = go where go SEnd = mempty
go (a :! b) = f a `mappend` go b
foldr f x = go where go (a :! b) = f a (go b)
go SEnd = x
foldr1 f = go where go (a :! SEnd) = a
go (a :! b) = f a (go b)
go SEnd = error "foldr1 on SEnd"
foldl f x = go x where go c (a :! b) = go (f c a) b
go c SEnd = c
foldl1 f = start where start SEnd = error "foldl1 on SEnd"
start (a :! b) = go a b
go c (a :! b) = go (f c a) b
go c SEnd = c