diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016-2017, Chris Dornan + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Iris Connect nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/RE.hs b/Text/RE.hs new file mode 100644 --- /dev/null +++ b/Text/RE.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + +module Text.RE + ( module Text.RE.Capture + , module Text.RE.CaptureID + , module Text.RE.Edit + , module Text.RE.IsRegex + , module Text.RE.LineNo + , module Text.RE.Options + , module Text.RE.Parsers + , module Text.RE.Replace + ) where + +import Text.RE.Capture +import Text.RE.CaptureID +import Text.RE.Edit +import Text.RE.IsRegex +import Text.RE.LineNo +import Text.RE.Options +import Text.RE.Parsers +import Text.RE.Replace diff --git a/Text/RE/Capture.lhs b/Text/RE/Capture.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Capture.lhs @@ -0,0 +1,252 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +\end{code} + +\begin{code} +module Text.RE.Capture + ( Matches(..) + , Match(..) + , Capture(..) + -- Matches functions + , anyMatches + , countMatches + , matches + , mainCaptures + -- Match functions + , matched + , matchedText + , matchCapture + , matchCaptures + , captureText + , captureTextMaybe + , capture + , captureMaybe + -- Capture functions + , hasCaptured + , capturePrefix + , captureSuffix + ) where +\end{code} + +\begin{code} +import Data.Array +import Data.Maybe +import Text.Regex.Base +import Text.RE.CaptureID +\end{code} + + + +\begin{code} +-- | the result type to use when every match is needed, not just the +-- first match of the RE against the source +data Matches a = + Matches + { matchesSource :: !a -- ^ the source text being matched + , allMatches :: [Match a] -- ^ all captures found, left to right + } + deriving (Show,Eq) +\end{code} + +\begin{code} +-- | the result of matching a RE to a text once, listing the text that +-- was matched and the named captures in the RE and all of the substrings +-- matched, with the text captured by the whole RE; a complete failure +-- to match will be represented with an empty array (with bounds (0,-1)) +data Match a = + Match + { matchSource :: !a -- ^ the whole source text + , captureNames :: CaptureNames -- ^ the RE's capture names + , matchArray :: !(Array CaptureOrdinal (Capture a)) + -- ^ 0..n-1 captures, + -- starting with the + -- text matched by the + -- whole RE + } + deriving (Show,Eq) +\end{code} + +\begin{code} +-- | the matching of a single sub-expression against part of the source +-- text +data Capture a = + Capture + { captureSource :: !a -- ^ the whole text that was searched + , capturedText :: !a -- ^ the text that was matched + , captureOffset :: !Int -- ^ the number of characters preceding the + -- match with -1 used if no text was captured + -- by the RE (not even the empty string) + , captureLength :: !Int -- ^ the number of chacter in the captured + -- sub-string + } + deriving (Show,Eq) +\end{code} + +\begin{code} +instance Functor Matches where + fmap f Matches{..} = + Matches + { matchesSource = f matchesSource + , allMatches = map (fmap f) allMatches + } + +instance Functor Match where + fmap f Match{..} = + Match + { matchSource = f matchSource + , captureNames = captureNames + , matchArray = fmap (fmap f) matchArray + } + +instance Functor Capture where + fmap f c@Capture{..} = + c + { captureSource = f captureSource + , capturedText = f capturedText + } +\end{code} + +\begin{code} +-- | tests whether the RE matched the source text at all +anyMatches :: Matches a -> Bool +anyMatches = not . null . allMatches + +-- | count the matches +countMatches :: Matches a -> Int +countMatches = length . allMatches + +matches :: Matches a -> [a] +matches = map capturedText . mainCaptures + +-- | extract the main capture from each match +mainCaptures :: Matches a -> [Capture a] +mainCaptures ac = [ capture c0 cs | cs<-allMatches ac ] + where + c0 = CID_ordinal $ CaptureOrdinal 0 +\end{code} + + + +\begin{code} +-- | tests whether the RE matched the source text at all +matched :: Match a -> Bool +matched = isJust . matchCapture + +-- | tests whether the RE matched the source text at all +matchedText :: Match a -> Maybe a +matchedText = fmap capturedText . matchCapture + +-- | the top-level capture if the source text matched the RE, +-- Nothing otherwise +matchCapture :: Match a -> Maybe (Capture a) +matchCapture = fmap fst . matchCaptures + +-- | the top-level capture and the sub captures if the text matched +-- the RE, Nothing otherwise +matchCaptures :: Match a -> Maybe (Capture a,[Capture a]) +matchCaptures Match{..} = case rangeSize (bounds matchArray) == 0 of + True -> Nothing + False -> Just (matchArray!0,drop 1 $ elems matchArray) + +-- | look up the text of the nth capture, 0 being the match of the whole +-- RE against the source text, 1, the first bracketed sub-expression to +-- be matched and so on +captureText :: CaptureID -> Match a -> a +captureText cid mtch = capturedText $ capture cid mtch + +-- | look up the text of the nth capture (0 being the match of the +-- whole), returning Nothing if the Match doesn't contain the capture +captureTextMaybe :: CaptureID -> Match a -> Maybe a +captureTextMaybe cid mtch = do + cap <- captureMaybe cid mtch + case hasCaptured cap of + True -> Just $ capturedText cap + False -> Nothing + +-- | look up the nth capture, 0 being the match of the whole RE against +-- the source text, 1, the first bracketed sub-expression to be matched +-- and so on +capture :: CaptureID -> Match a -> Capture a +capture cid mtch = fromMaybe oops $ captureMaybe cid mtch + where + oops = error $ "capture: out of bounds (" ++ show cid ++ ")" + +-- | look up the nth capture, 0 being the match of the whole RE against +-- the source text, 1, the first bracketed sub-expression to be matched +-- and so on, returning Nothing if there is no such capture, or if the +-- capture failed to capture anything (being in a failed alternate) +captureMaybe :: CaptureID -> Match a -> Maybe (Capture a) +captureMaybe cid mtch@Match{..} = do + cap <- case bounds matchArray `inRange` CaptureOrdinal i of + True -> Just $ matchArray ! CaptureOrdinal i + False -> Nothing + case hasCaptured cap of + True -> Just cap + False -> Nothing + where + i = lookupCaptureID cid mtch + +lookupCaptureID :: CaptureID -> Match a -> Int +lookupCaptureID cid Match{..} = findCaptureID cid captureNames +\end{code} + + +\begin{code} +-- | test if the capture has matched any text +hasCaptured :: Capture a -> Bool +hasCaptured = (>=0) . captureOffset + +-- | returns the text preceding the match +capturePrefix :: Extract a => Capture a -> a +capturePrefix Capture{..} = before captureOffset captureSource + +-- | returns the text after the match +captureSuffix :: Extract a => Capture a -> a +captureSuffix Capture{..} = after (captureOffset+captureLength) captureSource +\end{code} + + + + +\begin{code} +-- | for matching just the first RE against the source text +instance RegexContext regex source (AllTextSubmatches (Array Int) (source,(Int,Int))) => + RegexContext regex source (Match source) where + match r s = cvt s $ getAllTextSubmatches $ match r s + matchM r s = do + y <- matchM r s + return $ cvt s $ getAllTextSubmatches y + +-- | for matching all REs against the source text +instance RegexContext regex source [MatchText source] => + RegexContext regex source (Matches source) where + match r s = Matches s $ map (cvt s) $ match r s + matchM r s = do + y <- matchM r s + return $ Matches s $ map (cvt s) y +\end{code} + +\begin{code} +cvt :: source -> MatchText source -> Match source +cvt hay arr = + Match + { matchSource = hay + , captureNames = noCaptureNames + , matchArray = + ixmap (CaptureOrdinal lo,CaptureOrdinal hi) getCaptureOrdinal $ + fmap f arr + } + where + (lo,hi) = bounds arr + + f (ndl,(off,len)) = + Capture + { captureSource = hay + , capturedText = ndl + , captureOffset = off + , captureLength = len + } +\end{code} diff --git a/Text/RE/CaptureID.hs b/Text/RE/CaptureID.hs new file mode 100644 --- /dev/null +++ b/Text/RE/CaptureID.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.RE.CaptureID where + +import Data.Ix +import Data.Hashable +import qualified Data.HashMap.Strict as HMS +import Data.Maybe +import qualified Data.Text as T + + +data CaptureID + = CID_ordinal CaptureOrdinal + | CID_name CaptureName + deriving (Show,Ord,Eq) + +type CaptureNames = HMS.HashMap CaptureName CaptureOrdinal + +noCaptureNames :: CaptureNames +noCaptureNames = HMS.empty + +newtype CaptureName = CaptureName { getCaptureName :: T.Text } + deriving (Show,Ord,Eq) + +instance Hashable CaptureName where + hashWithSalt i = hashWithSalt i . getCaptureName + +newtype CaptureOrdinal = CaptureOrdinal { getCaptureOrdinal :: Int } + deriving (Show,Ord,Eq,Enum,Ix,Num) + +findCaptureID :: CaptureID -> CaptureNames -> Int +findCaptureID (CID_ordinal o) _ = getCaptureOrdinal o +findCaptureID (CID_name n) hms = + getCaptureOrdinal $ fromMaybe oops $ HMS.lookup n hms + where + oops = error $ unlines $ + ("lookupCaptureID: " ++ T.unpack t ++ " not found in:") : + [ " "++T.unpack (getCaptureName nm) | nm <- HMS.keys hms ] + t = getCaptureName n diff --git a/Text/RE/Edit.lhs b/Text/RE/Edit.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Edit.lhs @@ -0,0 +1,94 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} + +module Text.RE.Edit + ( LineNo + , Edits(..) + , Edit(..) + , LineEdit(..) + , applyEdits + , applyEdit + , applyLineEdit + ) where + +import Control.Applicative +import Data.Maybe +import Data.Monoid +import Text.RE.Capture +import Text.RE.IsRegex +import Text.RE.LineNo +import Text.RE.Replace + + +data Edits m re s + = Select [(re,Edit m s)] + | Pipe [(re,Edit m s)] + +data Edit m s + = EDIT_tpl s + | EDIT_phi (Phi s) + | EDIT_fun Context (LineNo->Match s->Location->Capture s->m (Maybe s)) + | EDIT_gen (LineNo->Matches s->m (LineEdit s)) + +data LineEdit s + = NoEdit + | ReplaceWith s + | Delete + deriving (Show) + +applyEdits :: (IsRegex re s,Monad m,Functor m) + => LineNo + -> Edits m re s + -> s + -> m s +applyEdits lno ez0 s0 = case ez0 of + Select ez -> select_edit_scripts lno ez s0 + Pipe ez -> pipe_edit_scripts lno ez s0 + +applyEdit :: (IsRegex re s,Monad m,Functor m) + => (s->s) + -> LineNo + -> re + -> Edit m s + -> s + -> m (Maybe s) +applyEdit anl lno re edit s = + case allMatches acs of + [] -> return Nothing + _ -> fmap Just $ case edit of + EDIT_tpl tpl -> return $ anl $ replaceAll tpl acs + EDIT_phi phi -> return $ anl $ replaceAllCaptures phi acs + EDIT_fun ctx f -> anl <$> replaceAllCapturesM replace_ ctx (f lno) acs + EDIT_gen g -> fromMaybe s' . applyLineEdit anl <$> g lno acs + where + s' = anl s + acs = matchMany re s + +applyLineEdit :: Monoid s => (s->s) -> LineEdit s -> Maybe s +applyLineEdit _ NoEdit = Nothing +applyLineEdit anl (ReplaceWith s) = Just $ anl s +applyLineEdit _ Delete = Just $ mempty + +select_edit_scripts :: (IsRegex re s,Monad m,Functor m) + => LineNo + -> [(re,Edit m s)] + -> s + -> m s +select_edit_scripts lno ps0 s = select ps0 + where + select [] = return $ appendNewline s + select ((re,es):ps) = + applyEdit appendNewline lno re es s >>= maybe (select ps) return + +pipe_edit_scripts :: (IsRegex re s,Monad m,Functor m) + => LineNo + -> [(re,Edit m s)] + -> s + -> m s +pipe_edit_scripts lno ez s0 = + appendNewline <$> foldr f (return s0) ez + where + f (re,es) act = do + s <- act + fromMaybe s <$> applyEdit id lno re es s +\end{code} diff --git a/Text/RE/Internal/AddCaptureNames.hs b/Text/RE/Internal/AddCaptureNames.hs new file mode 100644 --- /dev/null +++ b/Text/RE/Internal/AddCaptureNames.hs @@ -0,0 +1,11 @@ +module Text.RE.Internal.AddCaptureNames where + +import Text.RE + + +addCaptureNamesToMatches :: CaptureNames -> Matches a -> Matches a +addCaptureNamesToMatches cnms mtchs = + mtchs { allMatches = map (addCaptureNamesToMatch cnms) $ allMatches mtchs } + +addCaptureNamesToMatch :: CaptureNames -> Match a -> Match a +addCaptureNamesToMatch cnms mtch = mtch { captureNames = cnms } diff --git a/Text/RE/Internal/NamedCaptures.lhs b/Text/RE/Internal/NamedCaptures.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Internal/NamedCaptures.lhs @@ -0,0 +1,271 @@ +\begin{code} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +module Text.RE.Internal.NamedCaptures + ( cp + , extractNamedCaptures + , namedCapturesTestTree + ) + where + +import Data.Char +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import GHC.Generics +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote +import Test.SmallCheck.Series +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.SmallCheck as SC +import Text.Heredoc +import Text.RE +import Text.RE.Internal.PreludeMacros +import Text.RE.Internal.QQ +import Text.RE.Tools.Lex +import Text.Regex.PCRE + + +cp :: QuasiQuoter +cp = + (qq0 "re_") + { quoteExp = parse_capture + } + +extractNamedCaptures :: String -> Either String (CaptureNames,String) +extractNamedCaptures s = Right (analyseTokens tks,formatTokens tks) + where + tks = scan s + +namedCapturesTestTree :: TestTree +namedCapturesTestTree = localOption (SmallCheckDepth 4) $ + testGroup "NamedCaptures" + [ formatScanTestTree + , analyseTokensTestTree + ] +\end{code} + + +Token +----- + +\begin{code} +data Token + = ECap (Maybe String) + | PGrp + | PCap + | Bra + | BS Char + | Other Char + deriving (Show,Generic,Eq) + +instance Monad m => Serial m Token + +validToken :: Token -> Bool +validToken tkn = case tkn of + ECap mb -> maybe True check_ecap mb + PGrp -> True + PCap -> True + Bra -> True + BS c -> is_dot c + Other c -> is_dot c + where + check_ecap s = not (null s) && all not_br s + is_dot c = c/='\n' + not_br c = not $ c `elem` "{}\n" + +\end{code} + + +Analysing [Token] -> CaptureNames +--------------------------------- + +\begin{code} +analyseTokens :: [Token] -> CaptureNames +analyseTokens = HM.fromList . count_em 1 + where + count_em _ [] = [] + count_em n (tk:tks) = bd ++ count_em (n `seq` n+d) tks + where + (d,bd) = case tk of + ECap (Just nm) -> (,) 1 [(CaptureName $ T.pack nm,CaptureOrdinal n)] + ECap Nothing -> (,) 1 [] + PGrp -> (,) 0 [] + PCap -> (,) 1 [] + Bra -> (,) 1 [] + BS _ -> (,) 0 [] + Other _ -> (,) 0 [] +\end{code} + + +Scanning Regex Strings +---------------------- + +\begin{code} +scan :: String -> [Token] +scan = alex' match al oops + where + al :: [(Regex,Match String->Maybe Token)] + al = + [ mk [here|\$\{([^{}]+)\}\(|] $ ECap . Just . x_1 + , mk [here|\$\(|] $ const $ ECap Nothing + , mk [here|\(\?:|] $ const PGrp + , mk [here|\(\?|] $ const PCap + , mk [here|\(|] $ const Bra + , mk [here|\\(.)|] $ BS . s2c . x_1 + , mk [here|(.)|] $ Other . s2c . x_1 + ] + + x_1 = captureText $ CID_ordinal $ CaptureOrdinal 1 + + s2c [c] = c + s2c _ = error "scan:s2c:internal error" + + mk s f = (either error id $ makeRegexM s,Just . f) + + oops = error "reScanner" +\end{code} + + +Parsing captures +---------------- + +\begin{code} +parse_capture :: String -> TH.Q TH.Exp +parse_capture s = case all isDigit s of + True -> [|CID_ordinal $ CaptureOrdinal $ read s|] + False -> [|CID_name $ CaptureName $ T.pack s|] +\end{code} + + +Formatting [Token] +------------------ + +\begin{code} +formatTokens :: [Token] -> String +formatTokens = formatTokens' defFormatTokenOptions + +data FormatTokenOptions = + FormatTokenOptions + { _fto_regex_type :: Maybe RegexType + , _fto_min_caps :: Bool + , _fto_incl_caps :: Bool + } + deriving (Show) + +defFormatTokenOptions :: FormatTokenOptions +defFormatTokenOptions = + FormatTokenOptions + { _fto_regex_type = Nothing + , _fto_min_caps = False + , _fto_incl_caps = False + } + +idFormatTokenOptions :: FormatTokenOptions +idFormatTokenOptions = + FormatTokenOptions + { _fto_regex_type = Nothing + , _fto_min_caps = False + , _fto_incl_caps = True + } + +formatTokens' :: FormatTokenOptions -> [Token] -> String +formatTokens' FormatTokenOptions{..} = foldr f "" + where + f tk tl = t_s ++ tl + where + t_s = case tk of + ECap mb -> ecap mb + PGrp -> if _fto_regex_type == Just TDFA then "(" else "(?:" + PCap -> "(?" + Bra -> bra _fto_min_caps + BS c -> "\\" ++ [c] + Other c -> [c] + + ecap mb = case _fto_incl_caps of + True -> case mb of + Nothing -> "$(" + Just nm -> "${"++nm++"}(" + False -> bra _fto_min_caps + + bra mc = case mc && _fto_regex_type == Just PCRE of + True -> "(?:" + False -> "(" +\end{code} + +\begin{code} +-- this is a reference of formatTokens defFormatTokenOptions, +-- used for testing the latter +formatTokens0 :: [Token] -> String +formatTokens0 = foldr f "" + where + f tk tl = t_s ++ tl + where + t_s = case tk of + ECap _ -> "(" + PGrp -> "(?:" + PCap -> "(?" + Bra -> "(" + BS c -> "\\" ++ [c] + Other c -> [c] +\end{code} + + +Testing : FormatToken/Scan Properties +------------------------------------- + +\begin{code} +formatScanTestTree :: TestTree +formatScanTestTree = + testGroup "FormatToken/Scan Properties" + [ localOption (SmallCheckDepth 4) $ + SC.testProperty "formatTokens == formatTokens0" $ + \tks -> formatTokens tks == formatTokens0 tks + , localOption (SmallCheckDepth 4) $ + SC.testProperty "scan . formatTokens' idFormatTokenOptions == id" $ + \tks -> all validToken tks ==> + scan (formatTokens' idFormatTokenOptions tks) == tks + ] +\end{code} + + +Testing : Analysing [Token] Unit Tests +-------------------------------------- + +\begin{code} +analyseTokensTestTree :: TestTree +analyseTokensTestTree = + testGroup "Analysing [Token] Unit Tests" + [ tc [here|foobar|] [] + , tc [here||] [] + , tc [here|$([0-9]{4})|] [] + , tc [here|${x}()|] [(1,"x")] + , tc [here|${}()|] [] + , tc [here|${}()${foo}()|] [(2,"foo")] + , tc [here|${x}(${y()})|] [(1,"x")] + , tc [here|${x}(${y}())|] [(1,"x"),(2,"y")] + , tc [here|${a}(${b{}())|] [(1,"a")] + , tc [here|${y}([0-9]{4})-${m}([0-9]{2})-${d}([0-9]{2})|] [(1,"y"),(2,"m"),(3,"d")] + , tc [here|@$(@|\{${name}([^{}]+)\})|] [(2,"name")] + , tc [here|${y}[0-9]{4}|] [] + , tc [here|${}([0-9]{4})|] [] + ] + where + tc s al = + testCase s $ assertEqual "CaptureNames" + (xnc s) + (HM.fromList + [ (CaptureName $ T.pack n,CaptureOrdinal i) + | (i,n)<-al + ] + ) + + xnc = either oops fst . extractNamedCaptures + where + oops = error "analyseTokensTestTree: unexpected parse failure" +\end{code} diff --git a/Text/RE/Internal/PreludeMacros.hs b/Text/RE/Internal/PreludeMacros.hs new file mode 100644 --- /dev/null +++ b/Text/RE/Internal/PreludeMacros.hs @@ -0,0 +1,852 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.RE.Internal.PreludeMacros + ( RegexType(..) + , WithCaptures(..) + , MacroDescriptor(..) + , RegexSource(..) + , PreludeMacro(..) + , preludeMacros + , preludeMacroTable + , preludeMacroSummary + , preludeMacroSources + , preludeMacroSource + , preludeMacroEnv + , preludeMacroDescriptor + ) where + +import Control.Applicative +import Data.Array +import qualified Data.HashMap.Lazy as HML +import Data.List +import Data.Maybe +import Data.Time +import System.Posix.Syslog +import Text.RE.Options +import Text.RE.Parsers +import Text.RE.TestBench + + +preludeMacros :: (Monad m,Functor m) + => (String->m r) + -> RegexType + -> WithCaptures + -> m (Macros r) +preludeMacros prs rty wc = mkMacros prs rty wc $ preludeMacroEnv rty + +preludeMacroTable :: RegexType -> String +preludeMacroTable rty = formatMacroTable rty $ preludeMacroEnv rty + +preludeMacroSummary :: RegexType -> PreludeMacro -> String +preludeMacroSummary rty = + formatMacroSummary rty (preludeMacroEnv rty) . prelude_macro_id + +preludeMacroSources :: RegexType -> String +preludeMacroSources rty = + formatMacroSources rty ExclCaptures $ preludeMacroEnv rty + +preludeMacroSource :: RegexType -> PreludeMacro -> String +preludeMacroSource rty = + formatMacroSource rty ExclCaptures (preludeMacroEnv rty) . prelude_macro_id + +preludeMacroEnv :: RegexType -> MacroEnv +preludeMacroEnv TDFA = prelude_macro_env_tdfa +preludeMacroEnv PCRE = prelude_macro_env_pcre + +prelude_macro_env_pcre :: MacroEnv +prelude_macro_env_pcre = fix $ prelude_macro_env PCRE + +prelude_macro_env_tdfa :: MacroEnv +prelude_macro_env_tdfa = fix $ prelude_macro_env TDFA + +prelude_macro_env :: RegexType -> MacroEnv -> MacroEnv +prelude_macro_env rty env = HML.fromList $ catMaybes + [ (,) (prelude_macro_id pm) <$> preludeMacroDescriptor rty env pm + | pm<-[minBound..maxBound] + ] + +preludeMacroDescriptor :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +preludeMacroDescriptor rty env pm = case pm of + PM_natural -> natural_macro rty env pm + PM_natural_hex -> natural_hex_macro rty env pm + PM_integer -> integer_macro rty env pm + PM_decimal -> decimal_macro rty env pm + PM_string -> string_macro rty env pm + PM_string_simple -> string_simple_macro rty env pm + PM_id -> id_macro rty env pm + PM_id' -> id'_macro rty env pm + PM_date -> date_macro rty env pm + PM_date_slashes -> date_slashes_macro rty env pm + PM_time -> time_macro rty env pm + PM_timezone -> timezone_macro rty env pm + PM_datetime -> datetime_macro rty env pm + PM_datetime_8601 -> datetime_8601_macro rty env pm + PM_datetime_clf -> datetime_clf_macro rty env pm + PM_shortmonth -> shortmonth_macro rty env pm + PM_address_ipv4 -> address_ipv4_macros rty env pm + PM_email_simple -> email_simple_macro rty env pm + PM_url -> url_macro rty env pm + PM_syslog_severity -> syslog_severity_macro rty env pm + +-- | an enumeration of all of the prelude macros +data PreludeMacro + -- numbers + = PM_natural + | PM_natural_hex + | PM_integer + | PM_decimal + -- strings + | PM_string + | PM_string_simple + -- identifiers + | PM_id + | PM_id' + -- dates & times + | PM_date + | PM_date_slashes + | PM_time + | PM_timezone + | PM_datetime + | PM_datetime_8601 + | PM_datetime_clf + | PM_shortmonth + -- addresses + | PM_address_ipv4 + | PM_email_simple + | PM_url + -- syslog + | PM_syslog_severity + deriving (Bounded,Enum,Ord,Eq,Show) + +-- | naming the macros +presentPreludeMacro :: PreludeMacro -> String +presentPreludeMacro = (prelude_prefix++) . map tr . drop 3 . show + where + tr '_' = '.' + tr c = c + +-- | all prelude macros are prefixed with this +prelude_prefix :: String +prelude_prefix = "%" + +prelude_macro_id :: PreludeMacro -> MacroID +prelude_macro_id = MacroID . presentPreludeMacro + +natural_macro :: RegexType -> MacroEnv -> PreludeMacro -> Maybe MacroDescriptor +natural_macro rty env pm = Just $ run_tests rty parseInteger samples env pm + MacroDescriptor + { _md_source = "[0-9]+" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseInteger" + , _md_description = "a string of one or more decimal digits" + } + where + samples :: [(String,Int)] + samples = + [ (,) "0" 0 + , (,) "1234567890" 1234567890 + , (,) "00" 0 + , (,) "01" 1 + ] + + counter_samples = + [ "" + , "0A" + , "-1" + ] + +natural_hex_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +natural_hex_macro rty env pm = Just $ run_tests rty parseHex samples env pm + MacroDescriptor + { _md_source = "[0-9a-fA-F]+" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseHex" + , _md_description = "a string of one or more hexadecimal digits" + } + where + samples :: [(String,Int)] + samples = + [ (,) "0" 0x0 + , (,) "12345678" 0x12345678 + , (,) "90abcdef" 0x90abcdef + , (,) "90ABCDEF" 0x90abcdef + , (,) "00" 0x0 + , (,) "010" 0x10 + ] + + counter_samples = + [ "" + , "0x10" + , "0z" + , "-1a" + ] + +integer_macro :: RegexType -> MacroEnv -> PreludeMacro -> Maybe MacroDescriptor +integer_macro rty env pm = Just $ run_tests rty parseInteger samples env pm + MacroDescriptor + { _md_source = "-?[0-9]+" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseInteger" + , _md_description = "a decimal integer" + } + where + samples :: [(String,Int)] + samples = + [ (,) "0" 0 + , (,) "1234567890" 1234567890 + , (,) "00" 0 + , (,) "01" 1 + , (,) "-1" $ -1 + , (,) "-0" 0 + ] + + counter_samples = + [ "" + , "0A" + , "+0" + ] + +-- | a digit string macro +decimal_macro :: RegexType -> MacroEnv -> PreludeMacro -> Maybe MacroDescriptor +decimal_macro rty env pm = Just $ run_tests rty parseDouble samples env pm + MacroDescriptor + { _md_source = "-?[0-9]+(?:\\.[0-9]+)?" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseInteger" + , _md_description = "a decimal integer" + } + where + samples :: [(String,Double)] + samples = + [ (,) "0" 0 + , (,) "1234567890" 1234567890 + , (,) "00" 0 + , (,) "01" 1 + , (,) "-1" $ -1 + , (,) "-0" 0 + , (,) "0.1234567890" 0.1234567890 + , (,) "-1.0" $ -1.0 + ] + + counter_samples = + [ "" + , "0A" + , "+0" + , "0." + , ".0" + , "." + , "-" + , "-." + , "-1." + , "-.1" + ] + +string_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +string_macro PCRE _ _ = Nothing +string_macro rty@TDFA env pm = + Just $ run_tests rty parseString samples env pm + MacroDescriptor + { _md_source = "\"(?:[^\"\\]+|\\\\[\\\"])*\"" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseString" + , _md_description = "a double-quote string, with simple \\ escapes for \\s and \"s" + } + where + samples :: [(String,String)] + samples = + [ (,) "\"\"" "" + , (,) "\"foo\"" "foo" + , (,) "\"\\\"\"" "\"" + , (,) "\"\\\"\\\"\"" "\"\"" + , (,) "\"\\\"\\\\\\\"\"" "\"\\\"" + , (,) "\"\\\"foo\\\"\"" "\"foo\"" + , (,) "\"\"" "" + ] + + counter_samples = + [ "\"" + , "\"aa" + ] + +string_simple_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +string_simple_macro rty env pm = + Just $ run_tests rty parseSimpleString samples env pm + MacroDescriptor + { _md_source = "\"[^\"[:cntrl:]]*\"" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseSimpleString" + , _md_description = "a decimal integer" + } + where + samples :: [(String,String)] + samples = + [ (,) "\"\"" "" + , (,) "\"foo\"" "foo" + , (,) "\"\\\"" "\\" + , (,) "\"\"" "" + ] + + counter_samples = + [ "" + , "\"" + , "\"\\\"\"" + , "\"\\\"\\\"\"" + , "\"\\\"\\\\\\\"\"" + , "\"\\\"foo\\\"\"" + , "\"aa" + ] + +id_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +id_macro rty env pm = + Just $ run_tests rty Just samples env pm + MacroDescriptor + { _md_source = "_*[a-zA-Z][a-zA-Z0-9_]*" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Nothing + , _md_description = "a standard C-style alphanumeric identifier (with _s)" + } + where + samples :: [(String,String)] + samples = + [ f "a" + , f "A" + , f "A1" + , f "a_" + , f "a1_B2" + , f "_abc" + , f "__abc" + ] + where + f s = (s,s) + + counter_samples = + [ "" + , "1" + , "_" + , "__" + , "__1" + , "1a" + , "a'" + ] + +id'_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +id'_macro rty env pm = + Just $ run_tests rty Just samples env pm + MacroDescriptor + { _md_source = "_*[a-zA-Z][a-zA-Z0-9_']*" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Nothing + , _md_description = "a standard Haskell-style alphanumeric identifier (with '_'s and '''s)" + } + where + samples :: [(String,String)] + samples = + [ f "a" + , f "A" + , f "A1" + , f "a_" + , f "a1_B2" + , f "_abc" + , f "__abc" + , f "a'" + , f "_a'" + , f "a'b" + ] + where + f s = (s,s) + + counter_samples = + [ "" + , "1" + , "_" + , "__" + , "__1" + , "1a" + , "'" + , "'a" + , "_'" + , "_1'" + ] + +date_macro :: RegexType -> MacroEnv -> PreludeMacro -> Maybe MacroDescriptor +date_macro rty env pm = + Just $ run_tests rty parseDate samples env pm + MacroDescriptor + { _md_source = "[0-9]{4}-[0-9]{2}-[0-9]{2}" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseDate" + , _md_description = "a YYYY-MM-DD format date" + } + where + samples :: [(String,Day)] + samples = + [ f "2016-12-31" + , f "0001-01-01" + , f "1000-01-01" + ] + where + f s = (s,read s) + + counter_samples = + [ "" + , "2016/01/31" + , "2016-1-31" + , "2016-01-1" + , "2016-001-01" + ] + +date_slashes_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +date_slashes_macro rty env pm = + Just $ run_tests rty parseSlashesDate samples env pm + MacroDescriptor + { _md_source = "[0-9]{4}/[0-9]{2}/[0-9]{2}" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseSlashesDate" + , _md_description = "a YYYY/MM/DD format date" + } + where + samples :: [(String,Day)] + samples = + [ f "2016/12/31" + , f "0001/01/01" + , f "1000/01/01" + ] + where + f s = (s,read $ map tr s) + where + tr '/' = '-' + tr c = c + + counter_samples = + [ "" + , "2016-01-31" + , "2016/1/31" + , "2016/01/1" + , "2016/001/01" + ] + +time_macro :: RegexType -> MacroEnv -> PreludeMacro -> Maybe MacroDescriptor +time_macro rty env pm = + Just $ run_tests rty parseTimeOfDay samples env pm + MacroDescriptor + { _md_source = "[0-9]{2}:[0-9]{2}:[0-9]{2}(?:[.][0-9]+)?" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseTimeOfDay" + , _md_description = "a HH:MM:SS[.Q+]" + } + where + samples :: [(String,TimeOfDay)] + samples = + [ f "00:00:00" 00 00 0 + , f "23:59:59" 23 59 59000000000000 + , f "00:00:00.1234567890" 00 00 00123456789000 + ] + where + f s h m ps = (s,TimeOfDay h m $ toEnum ps) + + counter_samples = + [ "" + , "235959" + , "10:20" + , "A00:00:00" + , "00:00:00A" + , "23:59:59." + ] + +timezone_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +timezone_macro rty env pm = + Just $ run_tests rty parseTimeZone samples env pm + MacroDescriptor + { _md_source = "(?:Z|[+-][0-9]{2}:?[0-9]{2})" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseTimeZone" + , _md_description = "an IOS-8601 TZ specification" + } + where + samples :: [(String,TimeZone)] + samples = + [ f "Z" $ minutesToTimeZone 0 + , f "+00:00" $ minutesToTimeZone 0 + , f "+0000" $ minutesToTimeZone 0 + , f "+0200" $ minutesToTimeZone 120 + , f "-0100" $ minutesToTimeZone $ -60 + ] + where + f = (,) + + counter_samples = + [ "" + , "00" + , "A00:00" + , "UTC" + , "EST" + , " EST" + ] + +datetime_macro :: RegexType -> MacroEnv -> PreludeMacro -> Maybe MacroDescriptor +datetime_macro rty env pm = Just $ run_tests rty parseDateTime samples env pm + MacroDescriptor + { _md_source = "@{%date}[ T]@{%time}(?:@{%timezone}| UTC)?" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseDateTime" + , _md_description = "ISO-8601 format date and time + simple variants" + } + where + samples :: [(String,UTCTime)] + samples = + [ f "2016-12-31 23:37:22.525343 UTC" "2016-12-31 23:37:22.525343Z" + , f "2016-12-31 23:37:22.525343" "2016-12-31 23:37:22.525343Z" + , f "2016-12-31 23:37:22" "2016-12-31 23:37:22Z" + , f "2016-12-31T23:37:22+0100" "2016-12-31 23:37:22+0100" + , f "2016-12-31T23:37:22-01:00" "2016-12-31 23:37:22-0100" + , f "2016-12-31T23:37:22-23:59" "2016-12-31 23:37:22-2359" + , f "2016-12-31T23:37:22Z" "2016-12-31 23:37:22Z" + ] + where + f :: String -> String -> (String,UTCTime) + f s r_s = (s,read r_s) + + counter_samples = + [ "" + , "2016-12-31 23:37:22.525343 EST" + ] + +datetime_8601_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +datetime_8601_macro rty env pm = + Just $ run_tests rty parseDateTime samples env pm + MacroDescriptor + { _md_source = "@{%date}T@{%time}@{%timezone}" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseDateTime8601" + , _md_description = "YYYY-MM-DDTHH:MM:SS[.Q*](Z|[+-]HHMM) format date and time" + } + where + samples :: [(String,UTCTime)] + samples = + [ f "2016-12-31T23:37:22.343Z" "2016-12-31 23:37:22.343Z" + , f "2016-12-31T23:37:22-0100" "2016-12-31 23:37:22-0100" + , f "2016-12-31T23:37:22+23:59" "2016-12-31 23:37:22+2359" + ] + where + f :: String -> String -> (String,UTCTime) + f s r_s = (s,read r_s) + + counter_samples = + [ "" + , "2016-12-31 23:37:22.525343 EST" + ] + +datetime_clf_macro :: RegexType -> MacroEnv -> PreludeMacro -> Maybe MacroDescriptor +datetime_clf_macro rty env pm = + Just $ run_tests rty parseDateTimeCLF samples env pm + MacroDescriptor + { _md_source = re + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseDateTimeCLF" + , _md_description = "Common Log Format date+time: %d/%b/%Y:%H:%M:%S %z" + } + where + samples :: [(String,UTCTime)] + samples = + [ f "10/Oct/2000:13:55:36 -0700" "2000-10-10 13:55:36-0700" + , f "10/Oct/2000:13:55:36 +07:00" "2000-10-10 13:55:36+0700" + ] + where + f :: String -> String -> (String,UTCTime) + f s r_s = (s,read r_s) + + counter_samples = + [ "" + , "2016-12-31T23:37+0100" + , "10/Oct/2000:13:55:36-0700" + , "10/OCT/2000:13:55:36 -0700" + , "10/Oct/2000:13:55 -0700" + , "10/Oct/2000:13:55Z" + ] + + re = RegexSource $ unwords + [ "[0-9]{2}/@{%shortmonth}/[0-9]{4}:[0-9]{2}:[0-9]{2}:[0-9]{2}" + , "[+-][0-9]{2}:?[0-9]{2}" + ] + +shortmonth_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +shortmonth_macro rty env pm = + Just $ run_tests rty parseShortMonth samples env pm + MacroDescriptor + { _md_source = bracketedRegexSource $ + intercalate "|" $ elems shortMonthArray + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseShortMonth" + , _md_description = "three letter month name: Jan-Dec" + } + where + samples :: [(String,Int)] + samples = + [ f "Jan" 1 + , f "Feb" 2 + , f "Dec" 12 + ] + where + f = (,) + + counter_samples = + [ "" + , "jan" + , "DEC" + , "January" + , "01" + , "1" + ] + +address_ipv4_macros :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +address_ipv4_macros rty env pm = + Just $ run_tests rty parseIPv4Address samples env pm + MacroDescriptor + { _md_source = "[0-9]{1,3}[.][0-9]{1,3}[.][0-9]{1,3}[.][0-9]{1,3}" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseSyslogSeverity" + , _md_description = "an a.b.c.d IPv4 address" + } + where + samples :: [(String,IPV4Address)] + samples = + [ f "0.0.0.0" ( 0, 0, 0, 0) + , f "123.45.6.78" (123, 45, 6, 78) + , f "9.9.9.9" ( 9, 9, 9, 9) + , f "255.255.255.255" (255,255,255,255) + ] + where + f = (,) + + counter_samples = + [ "" + , "foo" + , "1234.0.0.0" + , "1.2.3" + , "1.2.3." + , "1.2..4" + , "www.example.com" + , "2001:0db8:85a3:0000:0000:8a2e:0370:7334" + ] + +syslog_severity_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +syslog_severity_macro rty env pm = + Just $ run_tests rty parseSyslogSeverity samples env pm + MacroDescriptor + { _md_source = re + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Just "parseSyslogSeverity" + , _md_description = "syslog severity keyword (debug-emerg)" + } + where + samples :: [(String,Priority)] + samples = + [ f "emerg" Emergency + , f "panic" Emergency + , f "alert" Alert + , f "crit" Critical + , f "err" Error + , f "error" Error + , f "warn" Warning + , f "warning" Warning + , f "notice" Notice + , f "info" Info + , f "debug" Debug + ] + where + f = (,) + + counter_samples = + [ "" + , "Emergency" + , "ALERT" + ] + + re = case rty of + PCRE -> re_pcre + TDFA -> re_tdfa + + re_tdfa = bracketedRegexSource $ + intercalate "|" $ + [ kw + | (kw0,kws) <- map syslogSeverityKeywords [minBound..maxBound] + , kw <- kw0:kws + ] + + re_pcre = bracketedRegexSource $ + intercalate "|" $ + [ kw + | (kw0,kws) <- map syslogSeverityKeywords $ + filter (/=Error) [minBound..maxBound] + , kw <- kw0:kws + ] ++ ["err(?:or)?"] + +email_simple_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +email_simple_macro rty env pm = + Just $ run_tests rty Just samples env pm + MacroDescriptor + { _md_source = "[a-zA-Z0-9%_.+-]+@[a-zA-Z0-9-]+\\.[a-zA-Z0-9.-]+" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Nothing + , _md_description = "an email address" + } + where + samples :: [(String,String)] + samples = + [ f "user-name%foo.bar.com@an-example.com" + ] + where + f s = (s,s) + + counter_samples = + [ "" + , "not-an-email-address" + , "@not-an-email-address" + ] +-- | see https://mathiasbynens.be/demo/url-regex +-- (based on @stephenhay URL) +url_macro :: RegexType + -> MacroEnv + -> PreludeMacro + -> Maybe MacroDescriptor +url_macro rty env pm = + Just $ run_tests rty Just samples env pm + MacroDescriptor + { _md_source = "([hH][tT][tT][pP][sS]?|[fF][tT][pP])://[^[:space:]/$.?#].[^[:space:]]*" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = test_stub pm + , _md_parser = Nothing + , _md_description = "a URL" + } + where + samples :: [(String,String)] + samples = + [ f "https://mathiasbynens.be/demo/url-regex" + , f "http://foo.com/blah_blah" + , f "http://foo.com/blah_blah/" + , f "http://foo.com/blah_blah_(wikipedia)" + , f "http://foo.com/blah_blah_(wikipedia)_(again)" + , f "http://www.example.com/wpstyle/?p=364" + , f "HTTPS://foo.bar/?q=Test%20URL-encoded%20stuff" + , f "HTTP://223.255.255.254" + , f "ftp://223.255.255.254" + , f "FTP://223.255.255.254" + ] + where + f s = (s,s) + + counter_samples = + [ "" + , "http://" + , "http://." + , "http://.." + , "http://../" + , "http://?" + , "http://??" + , "http://foo.bar?q=Spaces should be encoded" + , "//" + , "http://##/" + , "http://##" + , "http://##/" + ] + +test_stub :: PreludeMacro -> [TestResult] +test_stub pm = + error $ "test_stub: tests missing: " ++ presentPreludeMacro pm + +run_tests :: (Eq a,Show a) + => RegexType + -> (String->Maybe a) + -> [(String,a)] + -> MacroEnv + -> PreludeMacro + -> MacroDescriptor + -> MacroDescriptor +run_tests rty parser vector env = + runTests rty parser vector env . prelude_macro_id + +bracketedRegexSource :: String -> RegexSource +bracketedRegexSource re_s = RegexSource $ "(?:" ++ re_s ++ ")" + +fix :: (a->a) -> a +fix f = f (fix f) diff --git a/Text/RE/Internal/QQ.hs b/Text/RE/Internal/QQ.hs new file mode 100644 --- /dev/null +++ b/Text/RE/Internal/QQ.hs @@ -0,0 +1,21 @@ +module Text.RE.Internal.QQ where + +import Language.Haskell.TH.Quote + + +qq0 :: String -> QuasiQuoter +qq0 nm = + QuasiQuoter + { quoteExp = const $ error $ oops "an expression" + , quotePat = const $ error $ oops "a pattern" + , quoteType = const $ error $ oops "a type" + , quoteDec = const $ error $ oops "a declaration" + } + where + oops sc = unwords + [ "`" + , nm + , "` QuasiQuoter has been used in" + , sc + , "context but it should be used in an expresion context." + ] diff --git a/Text/RE/IsRegex.lhs b/Text/RE/IsRegex.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/IsRegex.lhs @@ -0,0 +1,16 @@ +\begin{code} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Text.RE.IsRegex where + +import Text.RE.Capture +import Text.RE.Replace +\end{code} + + +\begin{code} +class Replace s => IsRegex re s where + matchOnce :: re -> s -> Match s + matchMany :: re -> s -> Matches s + regexSource :: re -> String +\end{code} diff --git a/Text/RE/LineNo.hs b/Text/RE/LineNo.hs new file mode 100644 --- /dev/null +++ b/Text/RE/LineNo.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.RE.LineNo where + + +newtype LineNo = + ZeroBasedLineNo { getZeroBasedLineNo :: Int } + deriving (Show,Enum) + + +firstLine :: LineNo +firstLine = ZeroBasedLineNo 0 + +getLineNo :: LineNo -> Int +getLineNo = (+1) . getZeroBasedLineNo + +lineNo :: Int -> LineNo +lineNo = ZeroBasedLineNo . (\x->x-1) diff --git a/Text/RE/Options.lhs b/Text/RE/Options.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Options.lhs @@ -0,0 +1,77 @@ +\begin{code} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Text.RE.Options where + +import Data.Hashable +import qualified Data.HashMap.Strict as HM +import Data.String +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +\end{code} + +\begin{code} +data Options_ r c e = + Options + { _options_mode :: Mode + , _options_macs :: Macros r + , _options_comp :: c + , _options_exec :: e + } + deriving (Show) +\end{code} + +\begin{code} +class IsOption o r c e | + e -> r, c -> e , e -> c, r -> c, c -> r, r -> e where + makeOptions :: o -> Options_ r c e +\end{code} + +\begin{code} +data Mode + = Simple + | Block + deriving (Bounded,Enum,Ord,Eq,Show) +\end{code} + +\begin{code} +newtype MacroID = + MacroID { _MacroID :: String } + deriving (IsString,Ord,Eq,Show) +\end{code} + +\begin{code} +instance Hashable MacroID where + hashWithSalt i = hashWithSalt i . _MacroID +\end{code} + +\begin{code} +type Macros r = HM.HashMap MacroID r +\end{code} + +\begin{code} +emptyMacros :: Macros r +emptyMacros = HM.empty +\end{code} + +\begin{code} +data SimpleRegexOptions + = MultilineSensitive + | MultilineInsensitive + | BlockSensitive + | BlockInsensitive + deriving (Bounded,Enum,Eq,Ord,Show) +\end{code} + +\begin{code} +instance Lift SimpleRegexOptions where + lift sro = case sro of + MultilineSensitive -> conE 'MultilineSensitive + MultilineInsensitive -> conE 'MultilineInsensitive + BlockSensitive -> conE 'BlockSensitive + BlockInsensitive -> conE 'BlockInsensitive +\end{code} diff --git a/Text/RE/PCRE.hs b/Text/RE/PCRE.hs new file mode 100644 --- /dev/null +++ b/Text/RE/PCRE.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + +module Text.RE.PCRE + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.PCRE.RE + , module Text.RE.PCRE.ByteString + , module Text.RE.PCRE.ByteString.Lazy + , module Text.RE.PCRE.Sequence + , module Text.RE.PCRE.String + + ) where + + +import qualified Text.Regex.Base as B +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.PCRE.RE +import qualified Text.Regex.PCRE as PCRE +import Text.RE.PCRE.ByteString() +import Text.RE.PCRE.ByteString.Lazy() +import Text.RE.PCRE.Sequence() +import Text.RE.PCRE.String() + + +(*=~) :: IsRegex RE s + => s + -> RE + -> Matches s +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ matchMany rex bs + +(?=~) :: IsRegex RE s + => s + -> RE + -> Match s +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ matchOnce rex bs + +(=~) :: ( B.RegexContext PCRE.Regex s a + , B.RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption s + ) + => s + -> RE + -> a +(=~) bs rex = B.match (reRegex rex) bs + +(=~~) :: ( Monad m + , B.RegexContext PCRE.Regex s a + , B.RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption s + ) + => s + -> RE + -> m a +(=~~) bs rex = B.matchM (reRegex rex) bs diff --git a/Text/RE/PCRE/ByteString.hs b/Text/RE/PCRE/ByteString.hs new file mode 100644 --- /dev/null +++ b/Text/RE/PCRE/ByteString.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.PCRE.ByteString + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.PCRE.RE + ) where + +import qualified Data.ByteString as B +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.PCRE.RE +import qualified Text.Regex.PCRE as PCRE + + +(*=~) :: B.ByteString + -> RE + -> Matches B.ByteString +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: B.ByteString + -> RE + -> Match B.ByteString +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext PCRE.Regex B.ByteString a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => B.ByteString + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext PCRE.Regex B.ByteString a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => B.ByteString + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE B.ByteString where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/PCRE/ByteString/Lazy.hs b/Text/RE/PCRE/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/Text/RE/PCRE/ByteString/Lazy.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.PCRE.ByteString.Lazy + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.PCRE.RE + ) where + +import qualified Data.ByteString.Lazy as LBS +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.PCRE.RE +import qualified Text.Regex.PCRE as PCRE + + +(*=~) :: LBS.ByteString + -> RE + -> Matches LBS.ByteString +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: LBS.ByteString + -> RE + -> Match LBS.ByteString +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext PCRE.Regex LBS.ByteString a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => LBS.ByteString + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext PCRE.Regex LBS.ByteString a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => LBS.ByteString + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE LBS.ByteString where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/PCRE/RE.hs b/Text/RE/PCRE/RE.hs new file mode 100644 --- /dev/null +++ b/Text/RE/PCRE/RE.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.PCRE.RE + ( re + , reMS + , reMI + , reBS + , reBI + , reMultilineSensitive + , reMultilineInsensitive + , reBlockSensitive + , reBlockInsensitive + , re_ + , cp + , regexType + , RE + , reOptions + , reSource + , reCaptureNames + , reRegex + , Options + , prelude + , preludeEnv + , preludeTestsFailing + , preludeTable + , preludeSummary + , preludeSources + , preludeSource + , noPreludeOptions + , defaultOptions + , unpackSimpleRegexOptions + , compileRegex + ) where + +import Control.Applicative +import Data.Bits +import Data.Functor.Identity +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Text.RE +import Text.RE.Internal.NamedCaptures +import Text.RE.Internal.PreludeMacros +import Text.RE.Internal.QQ +import Text.RE.TestBench +import Text.Regex.PCRE + + +re + , reMS + , reMI + , reBS + , reBI + , reMultilineSensitive + , reMultilineInsensitive + , reBlockSensitive + , reBlockInsensitive + , re_ :: QuasiQuoter + +re = re' $ Just minBound +reMS = reMultilineSensitive +reMI = reMultilineInsensitive +reBS = reBlockSensitive +reBI = reBlockInsensitive +reMultilineSensitive = re' $ Just MultilineSensitive +reMultilineInsensitive = re' $ Just MultilineInsensitive +reBlockSensitive = re' $ Just BlockSensitive +reBlockInsensitive = re' $ Just BlockInsensitive +re_ = re' Nothing + +regexType :: RegexType +regexType = PCRE + +data RE = + RE + { _re_options :: Options + , _re_source :: String + , _re_cnames :: CaptureNames + , _re_regex :: Regex + } + +reOptions :: RE -> Options +reOptions = _re_options + +reSource :: RE -> String +reSource = _re_source + +reCaptureNames :: RE -> CaptureNames +reCaptureNames = _re_cnames + +reRegex :: RE -> Regex +reRegex = _re_regex + +type Options = Options_ RE CompOption ExecOption + +instance IsOption SimpleRegexOptions RE CompOption ExecOption where + makeOptions = unpackSimpleRegexOptions + +instance IsOption Mode RE CompOption ExecOption where + makeOptions md = Options md prelude def_comp_option def_exec_option + +instance IsOption (Macros RE) RE CompOption ExecOption where + makeOptions ms = Options minBound ms def_comp_option def_exec_option + +instance IsOption CompOption RE CompOption ExecOption where + makeOptions co = Options minBound prelude co def_exec_option + +instance IsOption ExecOption RE CompOption ExecOption where + makeOptions eo = Options minBound prelude def_comp_option eo + +instance IsOption Options RE CompOption ExecOption where + makeOptions = id + +instance IsOption () RE CompOption ExecOption where + makeOptions _ = unpackSimpleRegexOptions minBound + +def_comp_option :: CompOption +def_comp_option = _options_comp defaultOptions + +def_exec_option :: ExecOption +def_exec_option = _options_exec defaultOptions + +noPreludeOptions :: Options +noPreludeOptions = defaultOptions { _options_macs = emptyMacros } + +defaultOptions :: Options +defaultOptions = makeOptions (minBound::SimpleRegexOptions) + +unpackSimpleRegexOptions :: SimpleRegexOptions -> Options +unpackSimpleRegexOptions sro = + Options + { _options_mode = minBound + , _options_macs = prelude + , _options_comp = comp + , _options_exec = defaultExecOpt + } + where + comp = + wiggle ml compMultiline $ + wiggle ci compCaseless + defaultCompOpt + + wiggle True m v = v .|. m + wiggle False m v = v .&. complement m + + (ml,ci) = case sro of + MultilineSensitive -> (,) True False + MultilineInsensitive -> (,) True True + BlockSensitive -> (,) False False + BlockInsensitive -> (,) False True + +compileRegex :: ( IsOption o RE CompOption ExecOption + , Functor m + , Monad m + ) + => o + -> String + -> m RE +compileRegex = compileRegex_ . makeOptions + +compileRegex_ :: ( Functor m , Monad m ) + => Options + -> String + -> m RE +compileRegex_ os re_s = uncurry mk <$> compileRegex' os re_s + where + mk cnms rex = + RE + { _re_options = os + , _re_source = re_s + , _re_cnames = cnms + , _re_regex = rex + } + + Options{..} = os + +re' :: Maybe SimpleRegexOptions -> QuasiQuoter +re' mb = case mb of + Nothing -> + (qq0 "re_") + { quoteExp = parse minBound (\rs->[|flip unsafeCompileRegex rs|]) + } + Just sro -> + (qq0 "re") + { quoteExp = parse sro (\rs->[|unsafeCompileRegexSimple sro rs|]) + } + where + parse :: SimpleRegexOptions -> (String->Q Exp) -> String -> Q Exp + parse sro mk rs = either error (\_->mk rs) $ compileRegex_ os rs + where + os = unpackSimpleRegexOptions sro + +unsafeCompileRegexSimple :: SimpleRegexOptions -> String -> RE +unsafeCompileRegexSimple sro re_s = unsafeCompileRegex os re_s + where + os = unpackSimpleRegexOptions sro + +unsafeCompileRegex :: IsOption o RE CompOption ExecOption + => o + -> String + -> RE +unsafeCompileRegex = unsafeCompileRegex_ . makeOptions + +unsafeCompileRegex_ :: Options -> String -> RE +unsafeCompileRegex_ os = either oops id . compileRegex os + where + oops = error . ("unsafeCompileRegex: " ++) + +compileRegex' :: (Functor m,Monad m) + => Options + -> String + -> m (CaptureNames,Regex) +compileRegex' Options{..} s0 = do + (cnms,s2) <- either fail return $ extractNamedCaptures s1 + (,) cnms <$> makeRegexOptsM _options_comp _options_exec s2 + where + s1 = expandMacros reSource _options_mode _options_macs s0 + +prelude :: Macros RE +prelude = runIdentity $ preludeMacros mk PCRE ExclCaptures + where + mk = Identity . unsafeCompileRegex_ noPreludeOptions + +preludeTestsFailing :: [MacroID] +preludeTestsFailing = badMacros preludeEnv + +preludeEnv :: MacroEnv +preludeEnv = preludeMacroEnv PCRE + +preludeTable :: String +preludeTable = preludeMacroTable PCRE + +preludeSummary :: PreludeMacro -> String +preludeSummary = preludeMacroSummary PCRE + +preludeSources :: String +preludeSources = preludeMacroSources PCRE + +preludeSource :: PreludeMacro -> String +preludeSource = preludeMacroSource PCRE diff --git a/Text/RE/PCRE/Sequence.hs b/Text/RE/PCRE/Sequence.hs new file mode 100644 --- /dev/null +++ b/Text/RE/PCRE/Sequence.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.PCRE.Sequence + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.PCRE.RE + ) where + +import qualified Data.Sequence as S +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.PCRE.RE +import qualified Text.Regex.PCRE as PCRE + + +(*=~) :: (S.Seq Char) + -> RE + -> Matches (S.Seq Char) +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: (S.Seq Char) + -> RE + -> Match (S.Seq Char) +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext PCRE.Regex (S.Seq Char) a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => (S.Seq Char) + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext PCRE.Regex (S.Seq Char) a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => (S.Seq Char) + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE (S.Seq Char) where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/PCRE/String.hs b/Text/RE/PCRE/String.hs new file mode 100644 --- /dev/null +++ b/Text/RE/PCRE/String.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.PCRE.String + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.PCRE.RE + ) where + + +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.PCRE.RE +import qualified Text.Regex.PCRE as PCRE + + +(*=~) :: String + -> RE + -> Matches String +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: String + -> RE + -> Match String +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext PCRE.Regex String a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => String + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext PCRE.Regex String a + , RegexMaker PCRE.Regex PCRE.CompOption PCRE.ExecOption String + ) + => String + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE String where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/Parsers.hs b/Text/RE/Parsers.hs new file mode 100644 --- /dev/null +++ b/Text/RE/Parsers.hs @@ -0,0 +1,156 @@ +module Text.RE.Parsers + ( parseInteger + , parseHex + , parseDouble + , parseString + , parseSimpleString + , parseDate + , parseSlashesDate + , parseTimeOfDay + , parseTimeZone + , parseDateTime + , parseDateTime8601 + , parseDateTimeCLF + , parseShortMonth + , shortMonthArray + , IPV4Address + , parseIPv4Address + , parseSyslogSeverity + , syslogSeverityKeywords + ) where + +import Data.Array +import qualified Data.HashMap.Strict as HM +import Data.Maybe +import Data.Time +import Data.Word +import System.Posix.Syslog +import Text.Printf +import Text.Read +import Text.RE.Replace + + +parseInteger :: Replace a => a -> Maybe Int +parseInteger = readMaybe . unpack_ + +parseHex :: Replace a => a -> Maybe Int +parseHex = readMaybe . ("0x"++) . unpack_ + +parseDouble :: Replace a => a -> Maybe Double +parseDouble = readMaybe . unpack_ + +parseString :: Replace a => a -> Maybe String +parseString = readMaybe . unpack_ + +parseSimpleString :: Replace a => a -> Maybe String +parseSimpleString = topntail . unpack_ + where + topntail ('"':t) = topntail' $ reverse t + topntail _ = Nothing + + topntail' ('"':rt) = Just $ reverse rt + topntail' _ = Nothing + +date_templates, time_templates, timezone_templates, + date_time_8601_templates, date_time_templates :: [String] +date_templates = ["%F"] +time_templates = ["%H:%M:%S","%H:%M:%S%Q","%H:%M"] +timezone_templates = ["Z","%z"] +date_time_8601_templates = + [ printf "%sT%s%s" dt tm tz + | dt <- date_templates + , tm <- time_templates + , tz <- timezone_templates + ] +date_time_templates = + [ printf "%s%c%s%s" dt sc tm tz + | dt <- date_templates + , sc <- ['T',' '] + , tm <- time_templates + , tz <- timezone_templates ++ [" UTC",""] + ] + +parseDate :: Replace a => a -> Maybe Day +parseDate = parse_time date_templates + +parseSlashesDate :: Replace a => a -> Maybe Day +parseSlashesDate = parse_time ["%Y/%m/%d"] + +parseTimeOfDay :: Replace a => a -> Maybe TimeOfDay +parseTimeOfDay = parse_time time_templates + +parseTimeZone :: Replace a => a -> Maybe TimeZone +parseTimeZone = parse_time timezone_templates + +parseDateTime :: Replace a => a -> Maybe UTCTime +parseDateTime = parse_time date_time_templates + +parseDateTime8601 :: Replace a => a -> Maybe UTCTime +parseDateTime8601 = parse_time date_time_8601_templates + +parseDateTimeCLF :: Replace a => a -> Maybe UTCTime +parseDateTimeCLF = parse_time ["%d/%b/%Y:%H:%M:%S %z"] + +parseShortMonth :: Replace a => a -> Maybe Int +parseShortMonth = flip HM.lookup short_month_hm . unpack_ + +parse_time :: (ParseTime t,Replace s) => [String] -> s -> Maybe t +parse_time tpls = prs . unpack_ + where + prs s = listToMaybe $ catMaybes + [ parseTimeM False defaultTimeLocale fmt s + | fmt<-tpls + ] + +short_month_hm :: HM.HashMap String Int +short_month_hm = HM.fromList [ (shortMonthArray!i,i) | i<-[1..12] ] + +shortMonthArray :: Array Int String +shortMonthArray = listArray (1,12) $ + words "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" + +type IPV4Address = (Word8,Word8,Word8,Word8) + +parseIPv4Address :: Replace a => a -> Maybe IPV4Address +parseIPv4Address = prs . words_by (=='.') . unpack_ + where + prs [a_s,b_s,c_s,d_s] = do + a <- readMaybe a_s + b <- readMaybe b_s + c <- readMaybe c_s + d <- readMaybe d_s + case all is_o [a,b,c,d] of + True -> Just (toEnum a,toEnum b,toEnum c,toEnum d) + False -> Nothing + prs _ = Nothing + + is_o x = 0 <= x && x <= 255 + +parseSyslogSeverity :: Replace a => a -> Maybe Priority +parseSyslogSeverity = flip HM.lookup syslog_severity_hm . unpack_ + +syslog_severity_hm :: HM.HashMap String Priority +syslog_severity_hm = HM.fromList + [ (kw,pri) + | pri<-[minBound..maxBound] + , let (kw0,kws) = syslogSeverityKeywords pri + , kw <- kw0:kws + ] + +syslogSeverityKeywords :: Priority -> (String,[String]) +syslogSeverityKeywords pri = case pri of + Emergency -> (,) "emerg" ["panic"] + Alert -> (,) "alert" [] + Critical -> (,) "crit" [] + Error -> (,) "err" ["error"] + Warning -> (,) "warning" ["warn"] + Notice -> (,) "notice" [] + Info -> (,) "info" [] + Debug -> (,) "debug" [] + +words_by :: (Char->Bool) -> String -> [String] +words_by f s = case dropWhile f s of + "" -> [] + s' -> w : words_by f s'' + where + (w, s'') = break f s' diff --git a/Text/RE/Replace.lhs b/Text/RE/Replace.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Replace.lhs @@ -0,0 +1,496 @@ +\begin{code} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Text.RE.Replace + ( Replace(..) + , Replace_(..) + , replace_ + , Phi(..) + , Context(..) + , Location(..) + , isTopLocation + , replace + , replaceAll + , replaceAllCaptures + , replaceAllCaptures' + , replaceAllCaptures_ + , replaceAllCapturesM + , replaceCaptures + , replaceCaptures' + , replaceCaptures_ + , replaceCapturesM + , expandMacros + , expandMacros' + ) where + +import Control.Applicative +import Data.Array +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Char +import qualified Data.Foldable as F +import Data.Functor.Identity +import qualified Data.HashMap.Strict as HM +import Data.Maybe +import Data.Monoid +import qualified Data.Sequence as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as LT +import Text.Heredoc +import Text.RE.Capture +import Text.RE.CaptureID +import Text.RE.Options +import Text.Regex.TDFA +import Text.Regex.TDFA.Text() +import Text.Regex.TDFA.Text.Lazy() +\end{code} + +\begin{code} +-- | Replace provides the missing methods needed to replace the matched +-- text; length_ is the minimum implementation +class (Extract a,Monoid a) => Replace a where + -- | length function for a + length_ :: a -> Int + -- | inject String into a + pack_ :: String -> a + -- | project a onto a String + unpack_ :: a -> String + -- | inject into Text + textify :: a -> T.Text + -- | project Text onto a + detextify :: T.Text -> a + -- | append a newline + appendNewline :: a -> a + -- | apply a substitution function to a Capture + subst :: (a->a) -> Capture a -> a + -- | convert a template containing $0, $1, etc., in the first + -- argument, into a 'phi' replacement function for use with + -- replaceAllCaptures' and replaceCaptures' + parse_tpl :: a -> Match a -> Location -> Capture a -> Maybe a + + textify = T.pack . unpack_ + detextify = pack_ . T.unpack + appendNewline = (<> pack_ "\n") + + subst f m@Capture{..} = + capturePrefix m <> f capturedText <> captureSuffix m +\end{code} + +\begin{code} +-- | a selction of the Replace methods can be encapsulated with Replace_ +-- for the higher-order replacement functions +data Replace_ a = + Replace_ + { _r_length :: a -> Int + , _r_subst :: (a->a) -> Capture a -> a + } + +-- | replace_ encapsulates Replace_ a from a Replace a context +replace_ :: Replace a => Replace_ a +replace_ = + Replace_ + { _r_length = length_ + , _r_subst = subst + } +\end{code} + +\begin{code} +-- | @Phi@ specifies the substitution function for procesing the substrings +-- captured by the regular expression. +data Phi a = + Phi + { _phi_context :: Context -- ^ the context for applying + -- the substitution + , _phi_phi :: Location -> a -> a -- ^ the substitution function + -- takes the location and + -- the text to be replaced and + -- returns the replacement + -- text to be substituted + } + +-- | @Context@ specifies which contexts the substitutions should be applied +data Context + = TOP -- ^ substitutions should be applied to the top-level only, + -- the text that matched the whole RE + | SUB -- ^ substitutions should only be applied to the text + -- captured by bracketed sub-REs + | ALL -- ^ the substitution function should be applied to all + -- captures, the top level and the sub-expression captures + deriving (Show) + +-- | the @Location@ information passed into the substitution function +-- specifies which sub-expression is being substituted +data Location = + Location + { _loc_match :: Int -- ^ the zero-based, i-th string to be + -- matched, when matching all strings, + -- zero when only the first string is + -- being matched + , _loc_capture :: CaptureOrdinal + -- ^ 0, when matching the top-level + -- string matched by the whole RE, 1 + -- for the top-most, left-most redex + -- captured by bracketed sub-REs, etc. + } + deriving (Show) +\end{code} + +\begin{code} +-- | True iff the location references a complete match +-- (i.e., not a bracketed capture) +isTopLocation :: Location -> Bool +isTopLocation = (==0) . _loc_capture +\end{code} + +\begin{code} +-- | replace all with a template, $0 for whole text, $1 for first +-- capture, etc. +replaceAll :: Replace a + => a + -> Matches a + -> a +replaceAll tpl ac = replaceAllCaptures' TOP (parse_tpl tpl) ac +\end{code} + +\begin{code} +-- | substitutes the PHI substitutions through the Matches +replaceAllCaptures :: Replace a + => Phi a + -> Matches a + -> a +replaceAllCaptures = mk_phi replaceAllCaptures' +\end{code} + +\begin{code} +-- | substitutes using a function that takes the full Match +-- context and returns the same replacement text as the _phi_phi +-- context. +replaceAllCaptures' :: Replace a + => Context + -> (Match a->Location->Capture a->Maybe a) + -> Matches a + -> a +\end{code} + +\begin{code} +replaceAllCaptures' = replaceAllCaptures_ replace_ +\end{code} + +\begin{code} +-- | replaceAllCaptures_ is like like replaceAllCaptures' but takes the +-- Replace methods through the Replace_ argument +replaceAllCaptures_ :: Extract a + => Replace_ a + -> Context + -> (Match a->Location->Capture a->Maybe a) + -> Matches a + -> a +replaceAllCaptures_ s ctx phi ac = + runIdentity $ replaceAllCapturesM s ctx (lift_phi phi) ac +\end{code} + +\begin{code} +-- | replaceAllCapturesM is just a monadically generalised version of +-- replaceAllCaptures_ +replaceAllCapturesM :: (Extract a,Monad m) + => Replace_ a + -> Context + -> (Match a->Location->Capture a->m (Maybe a)) + -> Matches a + -> m a +replaceAllCapturesM r ctx phi_ Matches{..} = + replaceCapturesM r ALL phi $ Match matchesSource cnms arr + where + phi _ (Location _ i) = case arr_c!i of + Just caps -> phi_ caps . uncurry Location $ arr_i ! i + Nothing -> const $ return Nothing + + arr_c = listArray bds $ + concat $ + [ repl (rangeSize $ bounds $ matchArray cs) cs + | cs <- allMatches + ] + + arr_i = listArray bds j_ks + + arr = listArray bds $ + [ arr_ ! k + | arr_ <- map matchArray allMatches + , k <- indices arr_ + ] + + bds = (0,CaptureOrdinal $ length j_ks-1) + + j_ks = + [ (j,k) + | (j,arr_) <- zip [0..] $ map matchArray allMatches + , k <- indices arr_ + ] + + repl 0 _ = [] + repl n x = case ctx of + TOP -> Just x : replicate (n-1) Nothing + SUB -> Nothing : replicate (n-1) (Just x) + ALL -> replicate n $ Just x + + cnms = fromMaybe noCaptureNames $ listToMaybe $ map captureNames allMatches +\end{code} + +\begin{code} +-- | replace with a template containing $0 for whole text, +-- $1 for first capture, etc. +replace :: Replace a + => Match a + -> a + -> a +replace c tpl = replaceCaptures' TOP (parse_tpl tpl) c +\end{code} + +\begin{code} +-- | substitutes the PHI substitutions through the Match +replaceCaptures :: Replace a + => Phi a + -> Match a + -> a +replaceCaptures = mk_phi replaceCaptures' +\end{code} + +\begin{code} +-- | substitutes using a function that takes the full Match +-- context and returns the same replacement text as the _phi_phi +-- context. +replaceCaptures' :: Replace a + => Context + -> (Match a->Location->Capture a->Maybe a) + -> Match a + -> a +replaceCaptures' = replaceCaptures_ replace_ +\end{code} + +\begin{code} +-- | replaceCaptures_ is like replaceCaptures' but takes the Replace methods +-- through the Replace_ argument +replaceCaptures_ :: Extract a + => Replace_ a + -> Context + -> (Match a->Location->Capture a->Maybe a) + -> Match a + -> a +replaceCaptures_ s ctx phi caps = + runIdentity $ replaceCapturesM s ctx (lift_phi phi) caps +\end{code} + +\begin{code} +-- | replaceCapturesM is just a monadically generalised version of +-- replaceCaptures_ +replaceCapturesM :: (Monad m,Extract a) + => Replace_ a + -> Context + -> (Match a->Location->Capture a->m (Maybe a)) + -> Match a + -> m a +replaceCapturesM Replace_{..} ctx phi_ caps@Match{..} = do + (hay',_) <- foldr sc (return (matchSource,[])) $ + zip [0..] $ elems matchArray + return hay' + where + sc (i,cap0) act = do + (hay,ds) <- act + let ndl = capturedText cap + cap = adj hay ds cap0 + mb <- phi i cap + case mb of + Nothing -> return (hay,ds) + Just ndl' -> + return + ( _r_subst (const ndl') cap + , (captureOffset cap,len'-len) : ds + ) + where + len' = _r_length ndl' + len = _r_length ndl + + adj hay ds cap = + Capture + { captureSource = hay + , capturedText = before len $ after off0 hay + , captureOffset = off0 + , captureLength = len + } + where + len = len0 + sum + [ delta + | (off,delta) <- ds + , off < off0 + len0 + ] + len0 = captureLength cap + off0 = captureOffset cap + + phi i cap = case ctx of + TOP | i/=0 -> return Nothing + SUB | i==0 ->return Nothing + _ -> + case not $ hasCaptured cap of + True -> return Nothing + False -> phi_ caps (Location 0 i) cap +\end{code} + +\begin{code} +-- the Replace instances + +instance Replace [Char] where + length_ = length + pack_ = id + unpack_ = id + textify = T.pack + detextify = T.unpack + appendNewline = (<>"\n") + parse_tpl = parse_tpl_ id + +instance Replace B.ByteString where + length_ = B.length + pack_ = B.pack + unpack_ = B.unpack + textify = TE.decodeUtf8 + detextify = TE.encodeUtf8 + appendNewline = (<>"\n") + parse_tpl = parse_tpl_ B.unpack + +instance Replace LBS.ByteString where + length_ = fromEnum . LBS.length + pack_ = LBS.pack + unpack_ = LBS.unpack + textify = TE.decodeUtf8 . LBS.toStrict + detextify = LBS.fromStrict . TE.encodeUtf8 + appendNewline = (<>"\n") + parse_tpl = parse_tpl_ LBS.unpack + +instance Replace (S.Seq Char) where + length_ = S.length + pack_ = S.fromList + unpack_ = F.toList + parse_tpl = parse_tpl_ F.toList + +instance Replace T.Text where + length_ = T.length + pack_ = T.pack + unpack_ = T.unpack + textify = id + detextify = id + appendNewline = (<>"\n") + parse_tpl = parse_tpl_ T.unpack + +instance Replace LT.Text where + length_ = fromEnum . LT.length + pack_ = LT.pack + unpack_ = LT.unpack + textify = LT.toStrict + detextify = LT.fromStrict + appendNewline = (<>"\n") + parse_tpl = parse_tpl_ LT.unpack +\end{code} + +\begin{code} +-- | expand all of the @{..} macros in the RE in the argument String +-- according to the Macros argument, preprocessing the RE String +-- according to the Mode argument (used internally) +expandMacros :: (r->String) -> Mode -> Macros r -> String -> String +expandMacros x_src md hm s0 = + case HM.null hm of + True -> s + False -> expandMacros' (fmap x_src . flip HM.lookup hm) s + where + s = case md of + Simple -> s0 + Block -> concat $ map clean $ lines s0 + + clean = reverse . dropWhile isSpace . reverse . dropWhile isSpace +\end{code} + +\begin{code} +-- | expand the @{..} macos in the argument string using the given +-- function +expandMacros' :: (MacroID->Maybe String) -> String -> String +expandMacros' lu = fixpoint e_m + where + e_m re_s = replaceAllCaptures' TOP phi $ re_s $=~ [here|@(@|\{([^{}]+)\})|] + where + phi mtch _ cap = case txt == "@@" of + True -> Just "@" + False -> Just $ fromMaybe txt $ lu ide + where + txt = capturedText cap + ide = MacroID $ capturedText $ capture c2 mtch + c2 = CID_ordinal $ CaptureOrdinal 2 +\end{code} + +\begin{code} +lift_phi :: Monad m + => (Match a->Location->Capture a->Maybe a) + -> (Match a->Location->Capture a->m (Maybe a)) +lift_phi phi_ = phi + where + phi caps' loc' cap' = return $ phi_ caps' loc' cap' + +mk_phi :: (Context->(Match a->Location->Capture a->Maybe a)->b) + -> Phi a + -> b +mk_phi f phi@Phi{..} = f _phi_context $ mk_phi' phi + +mk_phi' :: Phi a -> Match a -> Location -> Capture a -> Maybe a +mk_phi' Phi{..} _ loc = Just . _phi_phi loc . capturedText +\end{code} + +\begin{code} +parse_tpl_ :: ( Replace a + , RegexContext Regex a (Matches a) + , RegexMaker Regex CompOption ExecOption String + ) + => (a->String) + -> a + -> Match a + -> Location + -> Capture a + -> Maybe a +parse_tpl_ unpack tpl mtch _ _ = + Just $ replaceAllCaptures' TOP phi $ + tpl $=~ [here|\$(\$|[0-9]+|\{([^{}]+)\})|] + where + phi t_mtch _ _ = case captureMaybe c2 t_mtch of + Just cap -> this $ CID_name $ CaptureName txt + where + txt = T.pack $ unpack $ capturedText cap + Nothing -> case s == "$" of + True -> Just t + False -> this $ CID_ordinal $ CaptureOrdinal $ read s + where + s = unpack t + t = capturedText $ capture c1 t_mtch + + this cid = capturedText <$> captureMaybe cid mtch + + c1 = CID_ordinal $ CaptureOrdinal 1 + c2 = CID_ordinal $ CaptureOrdinal 2 +\end{code} + +\begin{code} +fixpoint :: (Eq a) => (a->a) -> a -> a +fixpoint f = chk . iterate f + where + chk (x:x':_) | x==x' = x + chk xs = chk $ tail xs +\end{code} + +\begin{code} +($=~) :: ( RegexContext Regex source target + , RegexMaker Regex CompOption ExecOption String + ) + => source -> String -> target +($=~) = (=~) + +\end{code} diff --git a/Text/RE/TDFA.hs b/Text/RE/TDFA.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + +module Text.RE.TDFA + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.TDFA.RE + , module Text.RE.TDFA.ByteString + , module Text.RE.TDFA.ByteString.Lazy + , module Text.RE.TDFA.Sequence + , module Text.RE.TDFA.String + , module Text.RE.TDFA.Text + , module Text.RE.TDFA.Text.Lazy + ) where + + +import qualified Text.Regex.Base as B +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.TDFA.RE +import qualified Text.Regex.TDFA as TDFA +import Text.RE.TDFA.ByteString() +import Text.RE.TDFA.ByteString.Lazy() +import Text.RE.TDFA.Sequence() +import Text.RE.TDFA.String() +import Text.RE.TDFA.Text() +import Text.RE.TDFA.Text.Lazy() + + +(*=~) :: IsRegex RE s + => s + -> RE + -> Matches s +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ matchMany rex bs + +(?=~) :: IsRegex RE s + => s + -> RE + -> Match s +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ matchOnce rex bs + +(=~) :: ( B.RegexContext TDFA.Regex s a + , B.RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption s + ) + => s + -> RE + -> a +(=~) bs rex = B.match (reRegex rex) bs + +(=~~) :: ( Monad m + , B.RegexContext TDFA.Regex s a + , B.RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption s + ) + => s + -> RE + -> m a +(=~~) bs rex = B.matchM (reRegex rex) bs diff --git a/Text/RE/TDFA/ByteString.hs b/Text/RE/TDFA/ByteString.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA/ByteString.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.TDFA.ByteString + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.TDFA.RE + ) where + +import qualified Data.ByteString as B +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.TDFA.RE +import qualified Text.Regex.TDFA as TDFA + + +(*=~) :: B.ByteString + -> RE + -> Matches B.ByteString +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: B.ByteString + -> RE + -> Match B.ByteString +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext TDFA.Regex B.ByteString a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => B.ByteString + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext TDFA.Regex B.ByteString a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => B.ByteString + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE B.ByteString where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/TDFA/ByteString/Lazy.hs b/Text/RE/TDFA/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA/ByteString/Lazy.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.TDFA.ByteString.Lazy + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.TDFA.RE + ) where + +import qualified Data.ByteString.Lazy.Char8 as LBS +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.TDFA.RE +import qualified Text.Regex.TDFA as TDFA + + +(*=~) :: LBS.ByteString + -> RE + -> Matches LBS.ByteString +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: LBS.ByteString + -> RE + -> Match LBS.ByteString +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext TDFA.Regex LBS.ByteString a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => LBS.ByteString + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext TDFA.Regex LBS.ByteString a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => LBS.ByteString + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE LBS.ByteString where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/TDFA/RE.hs b/Text/RE/TDFA/RE.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA/RE.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.TDFA.RE + ( re + , reMS + , reMI + , reBS + , reBI + , reMultilineSensitive + , reMultilineInsensitive + , reBlockSensitive + , reBlockInsensitive + , re_ + , cp + , regexType + , RE + , reOptions + , reSource + , reCaptureNames + , reRegex + , Options + , noPreludeOptions + , defaultOptions + , prelude + , preludeEnv + , preludeTestsFailing + , preludeTable + , preludeSummary + , preludeSources + , preludeSource + , unpackSimpleRegexOptions + , compileRegex + ) where + +import Control.Applicative +import Data.Functor.Identity +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Text.RE +import Text.RE.Internal.NamedCaptures +import Text.RE.Internal.PreludeMacros +import Text.RE.Internal.QQ +import Text.RE.TestBench +import Text.Regex.TDFA + + +re + , reMS + , reMI + , reBS + , reBI + , reMultilineSensitive + , reMultilineInsensitive + , reBlockSensitive + , reBlockInsensitive + , re_ :: QuasiQuoter + +re = re' $ Just minBound +reMS = reMultilineSensitive +reMI = reMultilineInsensitive +reBS = reBlockSensitive +reBI = reBlockInsensitive +reMultilineSensitive = re' $ Just MultilineSensitive +reMultilineInsensitive = re' $ Just MultilineInsensitive +reBlockSensitive = re' $ Just BlockSensitive +reBlockInsensitive = re' $ Just BlockInsensitive +re_ = re' Nothing + +regexType :: RegexType +regexType = TDFA + +data RE = + RE + { _re_options :: Options + , _re_source :: String + , _re_cnames :: CaptureNames + , _re_regex :: Regex + } + +reOptions :: RE -> Options +reOptions = _re_options + +reSource :: RE -> String +reSource = _re_source + +reCaptureNames :: RE -> CaptureNames +reCaptureNames = _re_cnames + +reRegex :: RE -> Regex +reRegex = _re_regex + +type Options = Options_ RE CompOption ExecOption + +instance IsOption SimpleRegexOptions RE CompOption ExecOption where + makeOptions = unpackSimpleRegexOptions + +instance IsOption Mode RE CompOption ExecOption where + makeOptions md = Options md prelude def_comp_option def_exec_option + +instance IsOption (Macros RE) RE CompOption ExecOption where + makeOptions ms = Options minBound ms def_comp_option def_exec_option + +instance IsOption CompOption RE CompOption ExecOption where + makeOptions co = Options minBound prelude co def_exec_option + +instance IsOption ExecOption RE CompOption ExecOption where + makeOptions eo = Options minBound prelude def_comp_option eo + +instance IsOption Options RE CompOption ExecOption where + makeOptions = id + +instance IsOption () RE CompOption ExecOption where + makeOptions _ = unpackSimpleRegexOptions minBound + +def_comp_option :: CompOption +def_comp_option = _options_comp defaultOptions + +def_exec_option :: ExecOption +def_exec_option = _options_exec defaultOptions + +noPreludeOptions :: Options +noPreludeOptions = defaultOptions { _options_macs = emptyMacros } + +defaultOptions :: Options +defaultOptions = makeOptions (minBound::SimpleRegexOptions) + +unpackSimpleRegexOptions :: SimpleRegexOptions -> Options +unpackSimpleRegexOptions sro = + Options + { _options_mode = minBound + , _options_macs = prelude + , _options_comp = comp + , _options_exec = defaultExecOpt + } + where + comp = defaultCompOpt + { caseSensitive = cs + , multiline = ml + } + + (ml,cs) = case sro of + MultilineSensitive -> (,) True True + MultilineInsensitive -> (,) True False + BlockSensitive -> (,) False True + BlockInsensitive -> (,) False False + +compileRegex :: ( IsOption o RE CompOption ExecOption + , Functor m + , Monad m + ) + => o + -> String + -> m RE +compileRegex = compileRegex_ . makeOptions + +compileRegex_ :: (Functor m,Monad m) + => Options + -> String + -> m RE +compileRegex_ os re_s = uncurry mk <$> compileRegex' os re_s + where + mk cnms rx = + RE + { _re_options = os + , _re_source = re_s + , _re_cnames = cnms + , _re_regex = rx + } + + Options{..} = os + +re' :: Maybe SimpleRegexOptions -> QuasiQuoter +re' mb = case mb of + Nothing -> + (qq0 "re_") + { quoteExp = parse minBound (\rs->[|flip unsafeCompileRegex rs|]) + } + Just sro -> + (qq0 "re") + { quoteExp = parse sro (\rs->[|unsafeCompileRegexSimple sro rs|]) + } + where + parse :: SimpleRegexOptions -> (String->Q Exp) -> String -> Q Exp + parse sro mk rs = either error (\_->mk rs) $ compileRegex_ os rs + where + os = unpackSimpleRegexOptions sro + +unsafeCompileRegexSimple :: SimpleRegexOptions -> String -> RE +unsafeCompileRegexSimple sro re_s = unsafeCompileRegex_ os re_s + where + os = unpackSimpleRegexOptions sro + +unsafeCompileRegex :: IsOption o RE CompOption ExecOption + => o + -> String + -> RE +unsafeCompileRegex = unsafeCompileRegex_ . makeOptions + +unsafeCompileRegex_ :: Options -> String -> RE +unsafeCompileRegex_ os = either oops id . compileRegex_ os + where + oops = error . ("unsafeCompileRegex: " ++) + +compileRegex' :: (Functor m,Monad m) + => Options + -> String + -> m (CaptureNames,Regex) +compileRegex' Options{..} s0 = do + (cnms,s2) <- either fail return $ extractNamedCaptures s1 + (,) cnms <$> makeRegexOptsM _options_comp _options_exec s2 + where + s1 = expandMacros reSource _options_mode _options_macs s0 + +prelude :: Macros RE +prelude = runIdentity $ preludeMacros mk TDFA ExclCaptures + where + mk = Identity . unsafeCompileRegex_ noPreludeOptions + +preludeEnv :: MacroEnv +preludeEnv = preludeMacroEnv TDFA + +preludeTestsFailing :: [MacroID] +preludeTestsFailing = badMacros $ preludeMacroEnv TDFA + +preludeTable :: String +preludeTable = preludeMacroTable TDFA + +preludeSummary :: PreludeMacro -> String +preludeSummary = preludeMacroSummary TDFA + +preludeSources :: String +preludeSources = preludeMacroSources TDFA + +preludeSource :: PreludeMacro -> String +preludeSource = preludeMacroSource TDFA diff --git a/Text/RE/TDFA/Sequence.hs b/Text/RE/TDFA/Sequence.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA/Sequence.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.TDFA.Sequence + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.TDFA.RE + ) where + +import qualified Data.Sequence as S +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.TDFA.RE +import qualified Text.Regex.TDFA as TDFA + + +(*=~) :: (S.Seq Char) + -> RE + -> Matches (S.Seq Char) +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: (S.Seq Char) + -> RE + -> Match (S.Seq Char) +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext TDFA.Regex (S.Seq Char) a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => (S.Seq Char) + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext TDFA.Regex (S.Seq Char) a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => (S.Seq Char) + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE (S.Seq Char) where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/TDFA/String.hs b/Text/RE/TDFA/String.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA/String.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.TDFA.String + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.TDFA.RE + ) where + + +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.TDFA.RE +import qualified Text.Regex.TDFA as TDFA + + +(*=~) :: String + -> RE + -> Matches String +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: String + -> RE + -> Match String +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext TDFA.Regex String a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => String + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext TDFA.Regex String a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => String + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE String where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/TDFA/Text.hs b/Text/RE/TDFA/Text.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA/Text.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.TDFA.Text + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.TDFA.RE + ) where + +import qualified Data.Text as T +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.TDFA.RE +import qualified Text.Regex.TDFA as TDFA + + +(*=~) :: T.Text + -> RE + -> Matches T.Text +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: T.Text + -> RE + -> Match T.Text +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext TDFA.Regex T.Text a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => T.Text + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext TDFA.Regex T.Text a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => T.Text + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE T.Text where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/TDFA/Text/Lazy.hs b/Text/RE/TDFA/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/Text/RE/TDFA/Text/Lazy.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.RE.TDFA.Text.Lazy + ( (*=~) + , (?=~) + , (=~) + , (=~~) + , module Text.RE + , module Text.RE.TDFA.RE + ) where + +import qualified Data.Text.Lazy as TL +import Text.Regex.Base +import Text.RE +import Text.RE.Internal.AddCaptureNames +import Text.RE.TDFA.RE +import qualified Text.Regex.TDFA as TDFA + + +(*=~) :: TL.Text + -> RE + -> Matches TL.Text +(*=~) bs rex = addCaptureNamesToMatches (reCaptureNames rex) $ match (reRegex rex) bs + +(?=~) :: TL.Text + -> RE + -> Match TL.Text +(?=~) bs rex = addCaptureNamesToMatch (reCaptureNames rex) $ match (reRegex rex) bs + +(=~) :: ( RegexContext TDFA.Regex TL.Text a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => TL.Text + -> RE + -> a +(=~) bs rex = match (reRegex rex) bs + +(=~~) :: ( Monad m + , RegexContext TDFA.Regex TL.Text a + , RegexMaker TDFA.Regex TDFA.CompOption TDFA.ExecOption String + ) + => TL.Text + -> RE + -> m a +(=~~) bs rex = matchM (reRegex rex) bs + +instance IsRegex RE TL.Text where + matchOnce = flip (?=~) + matchMany = flip (*=~) + regexSource = reSource diff --git a/Text/RE/TestBench.lhs b/Text/RE/TestBench.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/TestBench.lhs @@ -0,0 +1,557 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.RE.TestBench + ( MacroID(..) + , RegexType(..) + , MacroEnv + , WithCaptures(..) + , MacroDescriptor(..) + , TestResult(..) + , RegexSource(..) + , FunctionID(..) + , mkMacros + , testMacroEnv + , badMacros + , runTests + , runTests' + , formatMacroTable + , dumpMacroTable + , formatMacroSummary + , formatMacroSources + , formatMacroSource + , testMacroDescriptors + , regexSource + ) where + +import Data.Array +import Control.Applicative +import qualified Data.HashMap.Lazy as HML +import Data.List +import Data.Maybe +import Data.Ord +import Data.String +import Text.Printf +import Text.RE.Capture +import Text.RE.Options +import Text.RE.Replace +import qualified Text.Regex.PCRE as PCRE +import qualified Text.Regex.TDFA as TDFA +\end{code} + +Types +----- + +\begin{code} +-- | what kind of back end will be compiling the RE +data RegexType + = TDFA -- the TDFA back end + | PCRE -- the PCRE back end + deriving (Eq,Ord,Show) + +-- | do we need the captures in the RE or whould they be stripped out +-- where possible +data WithCaptures + = InclCaptures + | ExclCaptures + deriving (Eq,Ord,Show) + +-- | each macro can reference others, the whole environment being +-- required for each macro, so we use a Lazy HashMap +type MacroEnv = HML.HashMap MacroID MacroDescriptor + +-- | describes a macro, giving the text of the RE and a si=ummary +-- description +data MacroDescriptor = + MacroDescriptor + { _md_source :: RegexSource -- ^ the RE + , _md_samples :: [String] -- ^ some sample matches + , _md_counter_samples :: [String] -- ^ some sample non-matches + , _md_test_results :: [TestResult] -- ^ validation test results + , _md_parser :: Maybe FunctionID -- ^ WA, the parser function + , _md_description :: String -- ^ summary comment + } + deriving (Show) + +-- | list of failures on a validation run +newtype TestResult = + TestResult { _TestResult :: String } + deriving (IsString,Show) + +-- | a RE that should work for POSIX and PCRE with open brackets ('(') +-- represented as follows: +-- \( mere symbol +-- (?: used for grouping only, not for captures +-- (}: used for captures only, not for grouping +-- (]: used for captures and grouping +-- ( do not modify +newtype RegexSource = + RegexSource { _RegexSource :: String } + deriving (IsString,Show) + +-- | name of the Haskell parser function for parsing the text matched +-- by a macro +newtype FunctionID = + FunctionID { _FunctionID :: String } + deriving (IsString,Show) + +-- | we are only interested in the open parentheses used for +-- grouping and/or capturing; if neither grouping or capturing then +-- there is no initial '(' or '(?:', just the suffic text +data REToken = + REToken + { _ret_prefix :: String -- ^ following text optional ( or (?: + , _ret_fixed :: Bool -- ^ a '(' that is not safe to modify + , _ret_grouping :: Bool -- ^ is this a grouping group + , _ret_capturing :: Bool -- ^ is this a capturing group + } + deriving (Show) +\end{code} + + +mkMacros +-------- + +\begin{code} +mkMacros :: (Monad m,Functor m) + => (String->m r) + -> RegexType + -> WithCaptures + -> MacroEnv + -> m (Macros r) +mkMacros prs rty wc env = + HML.fromList <$> mapM (uncurry mk) (HML.toList env) + where + mk mid md = (,) mid <$> prs (mdRegexSource rty wc env md) +\end{code} + + +testMacroEnv, badMacros +----------------------- + +\begin{code} +testMacroEnv :: String -> RegexType -> MacroEnv -> IO Bool +testMacroEnv lab rty m_env = case badMacros m_env of + [] -> return True + fails -> do + putStrLn $ lab' ++ " has failing tests for these macros: " + putStr $ unlines $ [ " "++_MacroID mid | mid<-fails ] + putStrLn $ "The whole table:" + putStrLn $ "========================================================" + putStr $ formatMacroTable rty m_env + putStrLn $ "========================================================" + return False + where + lab' = lab ++ " [" ++ show rty ++"]" + +badMacros :: MacroEnv -> [MacroID] +badMacros m_env = + [ mid + | (mid,MacroDescriptor{..}) <- HML.toList m_env + , not $ null _md_test_results + ] + +runTests :: (Eq a,Show a) + => RegexType + -> (String->Maybe a) + -> [(String,a)] + -> MacroEnv + -> MacroID + -> MacroDescriptor + -> MacroDescriptor +runTests rty parser = runTests' rty parser' + where + parser' caps = fmap capturedText (matchCapture caps) >>= parser + +runTests' :: (Eq a,Show a) + => RegexType + -> (Match String->Maybe a) + -> [(String,a)] + -> MacroEnv + -> MacroID + -> MacroDescriptor + -> MacroDescriptor +runTests' rty parser vector env mid md@MacroDescriptor{..} = + md { _md_test_results = test_results } + where + test_results = concat + [ concat $ map test vector + , concat $ map test_neg _md_counter_samples + ] + + test (src,x) = test' mid rty parser x $ match_ src env md + + test_neg src = test_neg' mid rty parser $ match_ src env md + + match_ = case rty of + TDFA -> match_tdfa + PCRE -> match_pcre +\end{code} + + +dumpMacroTable, formatMacroTable, formatMacroSummary, formatMacroSources, formatMacroSource +------------------------------------------------------------------------------------------- + +\begin{code} +dumpMacroTable :: String -> RegexType -> MacroEnv -> IO () +dumpMacroTable lab rty m_env = do + writeFile fp_t $ formatMacroTable rty m_env + writeFile fp_s $ formatMacroSources rty ExclCaptures m_env + where + fp_t = "tables/" ++ lab ++ "-" ++ show rty ++ ".md" + fp_s = "tables/" ++ lab ++ "-" ++ show rty ++ ".txt" +\end{code} + +\begin{code} +formatMacroTable :: RegexType -> MacroEnv -> String +formatMacroTable rty env = unlines $ + format_table macro_table_hdr + [ macro_table_row rty mid md + | (mid,md) <- sortBy (comparing fst) $ HML.toList env + ] +\end{code} + +\begin{code} +formatMacroSummary :: RegexType -> MacroEnv -> MacroID -> String +formatMacroSummary rty env mid = maybe oops prep $ HML.lookup mid env + where + prep :: MacroDescriptor -> String + prep md = unlines $ concat $ map (fmt md) [minBound..maxBound] + + fmt :: MacroDescriptor -> Col -> [String] + fmt md c = + [ printf "%-15s : %s" (present_col c) ini + ] ++ map (" "++) lns + where + (ini,lns) = case macro_attribute rty mid md c of + [] -> (,) "" [] + [ln] -> (,) ln [] + lns_ -> (,) "" lns_ + + oops = error $ _MacroID mid ++ ": macro not defined in this environment" +\end{code} + +\begin{code} +formatMacroSources :: RegexType + -> WithCaptures + -> MacroEnv + -> String +formatMacroSources rty wc env = unlines $ + [ printf "%-20s : %s" (_MacroID mid) $ formatMacroSource rty wc env mid + | mid <- sort $ HML.keys env + ] +\end{code} + +\begin{code} +formatMacroSource :: RegexType + -> WithCaptures + -> MacroEnv + -> MacroID + -> String +formatMacroSource rty wc env mid = + mdRegexSource rty wc env $ fromMaybe oops $ HML.lookup mid env + where + oops = error $ "formatMacroSource: not found: " ++ _MacroID mid +\end{code} + + +testMacroDescriptors, regexSource +--------------------------------- + +\begin{code} +testMacroDescriptors :: [MacroDescriptor] -> [TestResult] +testMacroDescriptors = concat . map _md_test_results + +regexSource :: RegexType -> WithCaptures -> RegexSource -> String +regexSource rty wc = format_tokens rty wc . scan_re +\end{code} + + +Formatting helpers +------------------ + +\begin{code} +type TableRow = Array Col [String] + +data Col + = C_name + | C_caps + | C_regex + | C_examples + | C_anti_examples + | C_fails + | C_parser + | C_comment + deriving (Ix,Bounded,Enum,Ord,Eq,Show) + +present_col :: Col -> String +present_col = map tr . drop 2 . show + where + tr '_' = '-' + tr c = c + +macro_table_hdr :: TableRow +macro_table_hdr = listArray (minBound,maxBound) + [ [present_col c] + | c<-[minBound..maxBound] + ] + +macro_table_row :: RegexType -> MacroID -> MacroDescriptor -> TableRow +macro_table_row rty mid md = + listArray (minBound,maxBound) $ + map (macro_attribute rty mid md) [minBound..maxBound] + +macro_attribute :: RegexType + -> MacroID + -> MacroDescriptor + -> Col + -> [String] +macro_attribute rty mid MacroDescriptor{..} c = + case c of + C_name -> [_MacroID mid] + C_caps -> [show $ min_captures rty $ scan_re _md_source] + C_regex -> [regexSource rty ExclCaptures _md_source] + C_examples -> _md_samples + C_anti_examples -> _md_counter_samples + C_fails -> map _TestResult _md_test_results + C_parser -> [maybe "-" _FunctionID _md_parser] + C_comment -> [_md_description] + +format_table :: TableRow -> [TableRow] -> [String] +format_table hdr rows0 = concat + [ format_row cws hdr' + , format_row cws dsh + , concat $ map (format_row cws) rows + ] + where + dsh = listArray (minBound,maxBound) + [ [replicate n '-'] | n<-elems cws ] + + hdr' = hdr // [(,) C_regex $ [take n $ concat $ repeat "regex="] ] + where + n = min 29 $ cws!C_regex + + cws = widths $ hdr : rows + + rows = map wrap_row rows0 + +field_width :: Int +field_width = 40 + +wrap_row :: TableRow -> TableRow +wrap_row = fmap $ concat . map f + where + f, g :: String -> [String] + + f cts = (ini ++ ['\\' | not (null rst)]) : g rst + where + (ini,rst) = splitAt (1+field_width) cts + + g "" = [] + g cts = ('\\' : ini ++ ['\\' | not (null rst)]) : g rst + where + (ini,rst) = splitAt field_width cts + + +widths :: [TableRow] -> Array Col Int +widths rows = listArray (minBound,maxBound) + [ maximum $ concat [ map length $ row!c | row<-rows ] + | c<-[minBound..maxBound] + ] + +format_row :: Array Col Int -> TableRow -> [String] +format_row cw_arr row = + [ ("|"++) $ intercalate "|" + [ field cw_arr row c i | c<-[minBound..maxBound] ] + | i <- [0..depth-1] + ] + where + depth = maximum [ length $ row!c | c<-[minBound..maxBound] ] + +field :: Array Col Int -> TableRow -> Col -> Int -> String +field cws row c i = ljust (cws!c) $ sel i $ row!c + +sel :: Int -> [String] -> String +sel i ss = case drop i ss of + [] -> "" + s:_ -> s + +ljust :: Int -> String -> String +ljust w s = s ++ replicate n ' ' + where + n = max 0 $ w - length s + +min_captures :: RegexType -> [REToken] -> Int +min_captures rty rets = length + [ () + | REToken{..}<-rets + , _ret_fixed || (_ret_grouping && rty==TDFA) + ] +\end{code} + + +Formatting tokens +----------------- + +\begin{code} +format_tokens :: RegexType -> WithCaptures -> [REToken] -> String +format_tokens rty wc = foldr f "" + where + f REToken{..} rst = _ret_prefix ++ bra ++ xket rst + where + bra = case _ret_fixed of + True -> "(" + False -> + case (,) _ret_grouping (_ret_capturing && wc==InclCaptures) of + (False,False) -> "" + (True ,False) -> if rty==PCRE then "(?:" else "(" + (False,True ) -> "(" + (True ,True ) -> "(" + + xket = + case not _ret_grouping && _ret_capturing && wc==ExclCaptures of + True -> delete_ket 0 + False -> id + +delete_ket :: Int -> String -> String +delete_ket _ "" = error "delete_ket: end of input" +delete_ket n (c:t) = case c of + '\\' -> case t of + "" -> error "delete_ket: end of input" + c':t' -> c : c' : delete_ket n t' + ')' -> case n of + 0 -> t + _ -> c : delete_ket (n-1) t + '(' -> c : delete_ket (n+1) t + _ -> c : delete_ket n t +\end{code} + + +scan_re +------- + +\begin{code} +scan_re :: RegexSource -> [REToken] +scan_re (RegexSource src0) = loop src0 + where + loop "" = [] + loop src = + case rst of + '\\':t -> case t of + "" -> REToken (ini++['\\']) False False False : [] + c':t' -> REToken (ini++['\\',c']) False False False : loop t' + '(' :t -> case t of + c:':':t' + | c=='?' -> REToken ini False True False : loop t' + | c=='}' -> REToken ini False False True : loop t' + | c==']' -> REToken ini False True True : loop t' + _ -> REToken ini True True True : loop t + _ -> [REToken src False False False] + where + (ini,rst) = break chk src + + chk '\\' = True + chk '(' = True + chk _ = False +\end{code} + + +scan_re +------- + +\begin{code} +match_tdfa :: String -> MacroEnv -> MacroDescriptor -> Matches String +match_tdfa txt env md = txt TDFA.=~ mdRegexSource TDFA ExclCaptures env md + +match_pcre :: String -> MacroEnv -> MacroDescriptor -> Matches String +match_pcre txt env md = txt PCRE.=~ mdRegexSource PCRE ExclCaptures env md +\end{code} + + +mdRegexSource +------------- + +\begin{code} +mdRegexSource :: RegexType + -> WithCaptures + -> MacroEnv + -> MacroDescriptor + -> String +mdRegexSource rty wc env md = + expandMacros' lu $ regexSource rty wc $ _md_source md + where + lu = fmap (regexSource rty wc . _md_source) . + flip HML.lookup env +\end{code} + + +test', test_neg' +---------------- + +\begin{code} +test' :: (Eq a,Show a) + => MacroID + -> RegexType + -> (Match String->Maybe a) + -> a + -> Matches String + -> [TestResult] +test' mid rty prs x Matches{..} = either (:[]) (const []) $ do + cs <- case allMatches of + [cs] -> return cs + _ -> oops "RE failed to parse" + mtx <- case matchCapture cs of + Nothing -> oops $ "RE parse failure: " ++ show cs + Just c -> return $ capturedText c + case mtx == matchesSource of + True -> return () + False -> oops "RE failed to match the whole text" + x' <- case prs cs of + Nothing -> oops "matched text failed to parse" + Just x' -> return x' + case x'==x of + True -> return () + False -> oops "parser failed to yield the expected result" + where + oops = Left . test_diagnostic mid False rty matchesSource + +test_neg' :: MacroID + -> RegexType + -> (Match String->Maybe a) + -> Matches String + -> [TestResult] +test_neg' mid rty prs Matches{..} = either id (const []) $ do + case allMatches of + [] -> return () + cz -> case ms of + [] -> return () + _ -> Left [oops "RE parse succeeded"] + where + ms = + [ () + | cs <- cz + , Just c <- [matchCapture cs] + , let t = capturedText c + , t == matchesSource + , isJust $ prs cs + ] + + where + oops = test_diagnostic mid True rty matchesSource + +test_diagnostic :: MacroID + -> Bool + -> RegexType + -> String + -> String + -> TestResult +test_diagnostic mid is_neg rty tst msg = + TestResult $ + printf "%-20s [%s %s] : %s (%s)" mid_s neg_s rty_s msg tst + where + mid_s = _MacroID mid + neg_s = if is_neg then "-ve" else "+ve" :: String + rty_s = show rty +\end{code} diff --git a/Text/RE/Tools/Grep.lhs b/Text/RE/Tools/Grep.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Tools/Grep.lhs @@ -0,0 +1,58 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + +module Text.RE.Tools.Grep + ( grep + , grepLines + , GrepScript + , grepScript + ) where + +import Control.Applicative +import qualified Data.ByteString.Lazy.Char8 as LBS +import Text.Printf +import Text.RE.Capture +import Text.RE.IsRegex +import Text.RE.LineNo + + +data Line = + Line + { _ln_no :: LineNo + , _ln_matches :: Matches LBS.ByteString + } + deriving (Show) + +grep :: IsRegex re LBS.ByteString => re -> FilePath -> IO () +grep rex fp = grepLines rex fp >>= putStr . report + +grepLines :: IsRegex re LBS.ByteString => re -> FilePath -> IO [Line] +grepLines rex fp = + grepScript [(rex,mk)] . LBS.lines <$> LBS.readFile fp + where + mk i mtchs = Just $ Line i mtchs + +type GrepScript re s t = [(re,LineNo -> Matches s -> Maybe t)] + +grepScript :: IsRegex re s => GrepScript re s t -> [s] -> [t] +grepScript scr = loop firstLine + where + loop _ [] = [] + loop i (ln:lns) = seq i $ choose i ln lns scr + + choose i _ lns [] = loop (succ i) lns + choose i ln lns ((rex,f):scr') = case f i $ matchMany rex ln of + Nothing -> choose i ln lns scr' + Just t -> t : loop (succ i) lns + +report :: [Line] -> String +report = unlines . map fmt . lines_matched + where + fmt Line{..} = + printf "%05d %s" (getLineNo _ln_no) $ + LBS.unpack $ matchesSource _ln_matches + +lines_matched :: [Line] -> [Line] +lines_matched = filter $ anyMatches . _ln_matches +\end{code} diff --git a/Text/RE/Tools/Lex.lhs b/Text/RE/Tools/Lex.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Tools/Lex.lhs @@ -0,0 +1,35 @@ +\begin{code} +module Text.RE.Tools.Lex where + +import Control.Applicative +import Text.RE + + +alex :: IsRegex re s => [(re,Match s->Maybe t)] -> t -> s -> [t] +alex = alex' matchOnce + +alex' :: Replace s + => (re->s->Match s) + -> [(re,Match s->Maybe t)] + -> t + -> s + -> [t] +alex' mo al t_err = loop + where + loop s = case length_ s == 0 of + True -> [] + False -> choose al s + + choose [] _ = [t_err] + choose ((re,f):al') s = case mb_p of + Just (s',t) -> t : loop s' + _ -> choose al' s + where + mb_p = do + cap <- matchCapture mtch + case captureOffset cap == 0 of + True -> (,) (captureSuffix cap) <$> f mtch + False -> Nothing + + mtch = mo re s +\end{code} diff --git a/Text/RE/Tools/Sed.lhs b/Text/RE/Tools/Sed.lhs new file mode 100644 --- /dev/null +++ b/Text/RE/Tools/Sed.lhs @@ -0,0 +1,50 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + +module Text.RE.Tools.Sed + ( SedScript + , sed + , sed' + ) where + +import Control.Applicative +import qualified Data.ByteString.Lazy.Char8 as LBS +import Text.RE.Edit +import Text.RE.LineNo +import Text.RE.IsRegex + + +type SedScript re = Edits IO re LBS.ByteString + +sed :: IsRegex re LBS.ByteString + => SedScript re + -> FilePath + -> FilePath + -> IO () +sed as i_fp o_fp = do + lns <- LBS.lines <$> read_file i_fp + lns' <- sequence + [ applyEdits lno as s + | (lno,s)<-zip [firstLine..] lns + ] + write_file o_fp $ LBS.concat lns' + +sed' :: (IsRegex re LBS.ByteString,Monad m,Functor m) + => Edits m re LBS.ByteString + -> LBS.ByteString + -> m LBS.ByteString +sed' as lbs = do + LBS.concat <$> sequence + [ applyEdits lno as s + | (lno,s)<-zip [firstLine..] $ LBS.lines lbs + ] + +read_file :: FilePath -> IO LBS.ByteString +read_file "-" = LBS.getContents +read_file fp = LBS.readFile fp + +write_file :: FilePath -> LBS.ByteString ->IO () +write_file "-" = LBS.putStr +write_file fp = LBS.writeFile fp +\end{code} diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,4 @@ +-*-change-log-*- + +0.0.0.1 Chris Dornan Feb 2014 + * First public release diff --git a/examples/TestKit.lhs b/examples/TestKit.lhs new file mode 100644 --- /dev/null +++ b/examples/TestKit.lhs @@ -0,0 +1,94 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestKit + ( Test + , runTests + , checkThis + , test_pp + ) where + +import Control.Exception +import qualified Data.Text as T +import qualified Shelly as SH +import System.Environment +import System.Exit +import System.IO +\end{code} + +\begin{code} +data Test = + Test + { testLabel :: String + , testExpected :: String + , testResult :: String + , testPassed :: Bool + } + deriving (Show) + +runTests :: [Test] -> IO () +runTests tests = do + as <- getArgs + case as of + [] -> return () + _ -> do + pn <- getProgName + putStrLn $ "usage:\n "++pn++" --help" + exitWith $ ExitFailure 1 + case filter (not . testPassed) tests of + [] -> putStrLn $ "All "++show (length tests)++" tests passed." + fts -> do + mapM_ (putStr . present_test) fts + putStrLn $ show (length fts) ++ " tests failed." + exitWith $ ExitFailure 1 + +checkThis :: (Show a,Eq a) => String -> a -> a -> Test +checkThis lab ref val = + Test + { testLabel = lab + , testExpected = show ref + , testResult = show val + , testPassed = ref == val + } + +present_test :: Test -> String +present_test Test{..} = unlines + [ "test: " ++ testLabel + , " expected : " ++ testExpected + , " result : " ++ testResult + , " passed : " ++ (if testPassed then "passed" else "**FAILED**") + ] +\end{code} + +\begin{code} +test_pp :: String + -> (FilePath->FilePath->IO()) + -> FilePath + -> FilePath + -> IO () +test_pp lab loop test_file gold_file = do + loop test_file tmp_pth + ok <- cmp (T.pack tmp_pth) (T.pack gold_file) + case ok of + True -> return () + False -> do + putStrLn $ lab ++ ": mismatch with " ++ gold_file + exitWith $ ExitFailure 1 + where + tmp_pth = "tmp/mod.lhs" +\end{code} + +\begin{code} +cmp :: T.Text -> T.Text -> IO Bool +cmp src dst = handle hdl $ do + _ <- SH.shelly $ SH.verbosely $ + SH.run "cmp" [src,dst] + return True + where + hdl :: SomeException -> IO Bool + hdl se = do + hPutStrLn stderr $ + "testing results against model answers failed: " ++ show se + return False +\end{code} diff --git a/examples/re-gen-modules.lhs b/examples/re-gen-modules.lhs new file mode 100644 --- /dev/null +++ b/examples/re-gen-modules.lhs @@ -0,0 +1,127 @@ +\begin{code} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Applicative +import Control.Exception +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Text as T +import qualified Shelly as SH +import System.Directory +import System.Environment +import System.Exit +import System.IO +import Text.RE.TDFA.ByteString.Lazy +import Text.RE.Tools.Sed + + +main :: IO () +main = do + (pn,as) <- (,) <$> getProgName <*> getArgs + case as of + [] -> test + ["test"] -> test + ["gen"] -> gen + _ -> do + hPutStrLn stderr $ "usage: " ++ pn ++ " [test|gen]" + exitWith $ ExitFailure 1 + +test :: IO () +test = do + createDirectoryIfMissing False "tmp" + tdfa_ok <- and <$> mapM test' tdfa_edits + pcre_ok <- and <$> mapM test' pcre_edits + case tdfa_ok && pcre_ok of + True -> return () + False -> exitWith $ ExitFailure 1 + +test' :: (ModPath,SedScript RE) -> IO Bool +test' (mp,scr) = do + putStrLn mp + sed scr (mod_filepath source_mp) tmp_pth + cmp (T.pack tmp_pth) (T.pack $ mod_filepath mp) + where + tmp_pth = "tmp/prog.hs" + +gen :: IO () +gen = do + mapM_ gen' tdfa_edits + mapM_ gen' pcre_edits + +gen' :: (ModPath,SedScript RE) -> IO () +gen' (mp,scr) = do + putStrLn mp + sed scr (mod_filepath source_mp) (mod_filepath mp) + +tdfa_edits :: [(ModPath,SedScript RE)] +tdfa_edits = + [ tdfa_edit "Text.RE.TDFA.ByteString" "B.ByteString" "import qualified Data.ByteString as B" + , tdfa_edit "Text.RE.TDFA.Sequence" "(S.Seq Char)" "import qualified Data.Sequence as S" + , tdfa_edit "Text.RE.TDFA.String" "String" "" + , tdfa_edit "Text.RE.TDFA.Text" "T.Text" "import qualified Data.Text as T" + , tdfa_edit "Text.RE.TDFA.Text.Lazy" "TL.Text" "import qualified Data.Text.Lazy as TL" + ] + +pcre_edits :: [(ModPath,SedScript RE)] +pcre_edits = + [ pcre_edit "Text.RE.PCRE.ByteString" "B.ByteString" "import qualified Data.ByteString as B" + , pcre_edit "Text.RE.PCRE.ByteString.Lazy" "LBS.ByteString" "import qualified Data.ByteString.Lazy as LBS" + , pcre_edit "Text.RE.PCRE.Sequence" "(S.Seq Char)" "import qualified Data.Sequence as S" + , pcre_edit "Text.RE.PCRE.String" "String" "" + ] + +tdfa_edit :: ModPath + -> LBS.ByteString + -> LBS.ByteString + -> (ModPath,SedScript RE) +tdfa_edit mp bs_lbs import_lbs = + (,) mp $ Pipe + [ (,) module_re $ EDIT_tpl $ LBS.pack mp + , (,) import_re $ EDIT_tpl import_lbs + , (,) bs_re $ EDIT_tpl bs_lbs + ] + +pcre_edit :: ModPath + -> LBS.ByteString + -> LBS.ByteString + -> (ModPath,SedScript RE) +pcre_edit mp bs_lbs import_lbs = + (,) mp $ Pipe + [ (,) tdfa_re $ EDIT_tpl "PCRE" + , (,) module_re $ EDIT_tpl $ LBS.pack mp + , (,) import_re $ EDIT_tpl import_lbs + , (,) bs_re $ EDIT_tpl bs_lbs + ] + +type ModPath = String + +source_mp :: ModPath +source_mp = "Text.RE.TDFA.ByteString.Lazy" + +tdfa_re, module_re, import_re, bs_re :: RE +tdfa_re = [re|TDFA|] +module_re = [re|Text.RE.TDFA.ByteString.Lazy|] +import_re = [re|import qualified Data.ByteString.Lazy.Char8 *as LBS|] +bs_re = [re|LBS.ByteString|] + +mod_filepath :: ModPath -> FilePath +mod_filepath mp = map tr mp ++ ".hs" + where + tr '.' = '/' + tr c = c + +cmp :: T.Text -> T.Text -> IO Bool +cmp src dst = handle hdl $ do + _ <- SH.shelly $ SH.verbosely $ + SH.run "cmp" [src,dst] + return True + where + hdl :: SomeException -> IO Bool + hdl se = do + hPutStrLn stderr $ + "testing results against model answers failed: " ++ show se + return False +\end{code} diff --git a/examples/re-include.lhs b/examples/re-include.lhs new file mode 100644 --- /dev/null +++ b/examples/re-include.lhs @@ -0,0 +1,138 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Control.Applicative +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe +import System.Environment +import TestKit +import Text.RE.Edit +import Text.RE.TDFA.ByteString.Lazy +import Text.RE.Tools.Grep +import Text.RE.Tools.Sed +\end{code} + +\begin{code} +main :: IO () +main = do + as <- getArgs + case as of + [] -> test + ["test"] -> test + [fn,fn'] | is_file fn -> loop fn fn' + _ -> usage + where + is_file = not . (== "--") . take 2 + + usage = do + prg <- getProgName + putStr $ unlines + [ "usage:" + , " "++prg++" [test]" + , " "++prg++" (-|) (-|)" + ] +\end{code} + + +The Sed Script +-------------- + +\begin{code} +loop :: FilePath -> FilePath -> IO () +loop = + sed $ Select + [ (,) [re|^%include ${file}(@{%string}) ${rex}(@{%string})$|] $ EDIT_fun TOP include + , (,) [re|^.*$|] $ EDIT_fun TOP $ \_ _ _ _->return Nothing + ] +\end{code} + +\begin{code} +include :: LineNo + -> Match LBS.ByteString + -> Location + -> Capture LBS.ByteString + -> IO (Maybe LBS.ByteString) +include _ mtch _ _ = fmap Just $ + extract fp =<< compileRegex () re_s + where + fp = prs_s $ captureText [cp|file|] mtch + re_s = prs_s $ captureText [cp|rex|] mtch + + prs_s = fromMaybe (error "includeDoc") . parseString +\end{code} + + +Extracting a Literate Fragment from a Haskell Program Text +---------------------------------------------------------- + +\begin{code} +extract :: FilePath -> RE -> IO LBS.ByteString +extract fp rex = extr . LBS.lines <$> LBS.readFile fp + where + extr lns = + case parse $ scan rex lns of + Nothing -> oops + Just (lno,n) -> LBS.unlines $ (hdr :) $ (take n $ drop i lns) ++ [ftr] + where + i = getZeroBasedLineNo lno + + oops = error $ concat + [ "failed to locate fragment matching " + , show $ reSource rex + , " in file " + , show fp + ] + + hdr = "
" + ftr = "
" +\end{code} + +\begin{code} +parse :: [Token] -> Maybe (LineNo,Int) +parse [] = Nothing +parse (tk:tks) = case (tk,tks) of + (Bra b_ln,Hit:Ket k_ln:_) -> Just (b_ln,count_lines_incl b_ln k_ln) + _ -> parse tks +\end{code} + +\begin{code} +count_lines_incl :: LineNo -> LineNo -> Int +count_lines_incl b_ln k_ln = + getZeroBasedLineNo k_ln + 1 - getZeroBasedLineNo b_ln +\end{code} + +\begin{code} +data Token = Bra LineNo | Hit | Ket LineNo deriving (Show) +\end{code} + +\begin{code} +scan :: RE -> [LBS.ByteString] -> [Token] +scan rex = grepScript + [ (,) [re|\\begin\{code\}|] $ \i -> chk $ Bra i + , (,) rex $ \_ -> chk Hit + , (,) [re|\\end\{code\}|] $ \i -> chk $ Ket i + ] + where + chk x mtchs = case anyMatches mtchs of + True -> Just x + False -> Nothing +\end{code} + + +Testing +------- + +\begin{code} +test :: IO () +test = do + test_pp "include" loop "data/pp-test.lhs" "data/include-result.lhs" + putStrLn "tests passed" +\end{code} diff --git a/examples/re-nginx-log-processor.lhs b/examples/re-nginx-log-processor.lhs new file mode 100644 --- /dev/null +++ b/examples/re-nginx-log-processor.lhs @@ -0,0 +1,592 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + -- development + , parse_a + , parse_e + ) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.HashMap.Lazy as HML +import Data.Functor.Identity +import Data.Maybe +import Data.String +import qualified Data.Text as T +import Data.Time +import qualified Shelly as SH +import System.Directory +import System.Environment +import System.Posix.Syslog +import System.Exit +import System.IO +import Text.RE.Options +import Text.RE.Parsers +import Text.RE.TestBench +import Text.RE.PCRE.ByteString.Lazy +import qualified Text.RE.PCRE.String as S +import Text.RE.Tools.Sed +import Text.Printf +\end{code} + +\begin{code} +main :: IO () +main = do + as <- getArgs + case as of + ["--macro" ] -> putStr lp_macro_table + ["--macro",mid_s] -> putStrLn $ lp_macro_summary $ MacroID mid_s + ["--regex" ] -> putStr lp_macro_sources + ["--regex",mid_s] -> putStrLn $ lp_macro_source $ MacroID mid_s + ["--test" ] -> test + [] -> test + [in_file ] | is_file in_file -> go True in_file "-" + [in_file,out_file ] | is_file in_file -> go True in_file out_file + _ -> usage + where + is_file = not . (== "--") . take 2 + + usage = do + pnm <- getProgName + let prg = ((pnm++" ")++) + putStr $ unlines + [ "usage:" + , prg " --help" + , prg " --macro" + , prg " --macro " + , prg " --regex" + , prg " --regex " + , prg "[--test]" + , prg "(-|) [-|]" + ] +\end{code} + +\begin{code} + +-- +-- go +-- + +test :: IO () +test = do + putStrLn "============================================================" + putStrLn "Testing the macro environment." + putStrLn "nginx-log-processor" + dumpMacroTable "nginx-log-processor" regexType lp_env + me_ok <- testMacroEnv "nginx-log-processor" regexType lp_env + putStrLn "============================================================" + putStrLn "Testing the log processor on reference data." + putStrLn "" + lp_ok <- test_log_processor + putStrLn "============================================================" + case me_ok && lp_ok of + True -> return () + False -> exitWith $ ExitFailure 1 + + +test_log_processor :: IO Bool +test_log_processor = do + createDirectoryIfMissing False "tmp" + go False "data/access-errors.log" "tmp/events.log" + cmp "tmp/events.log" "data/events.log" +\end{code} + +\begin{code} + +-- +-- go +-- + +go :: Bool -> FilePath -> FilePath -> IO () +go rprt_flg in_file out_file = do + ctx <- setup rprt_flg + sed (script ctx) in_file out_file +\end{code} + +\begin{code} +script :: Ctx -> SedScript RE +script ctx = Select + [ on [re_|@{access}|] Acc parse_access + , on [re_|@{access_deg}|] AcQ parse_deg_access + , on [re_|@{error}|] Err parse_error + , on [re_|.*|] QQQ parse_def + ] + where + on rex src prs = + (,) (rex lpo) $ EDIT_fun TOP $ process_line ctx src prs + + parse_def = fmap capturedText . matchCapture +\end{code} + +\begin{code} +process_line :: IsEvent a + => Ctx + -> Source + -> (Match LBS.ByteString->Maybe a) + -> LineNo + -> Match LBS.ByteString + -> Location + -> Capture LBS.ByteString + -> IO (Maybe LBS.ByteString) +process_line ctx src prs lno cs _ _ = do + when (event_is_notifiable event) $ + flag_event ctx event + return $ Just $ presentEvent event + where + event = maybe def_event (mkEvent lno src) $ prs cs + + def_event = + Event + { _event_line = lno + , _event_source = src + , _event_utc = read "1970-01-01 00:00:00" + , _event_severity = Nothing + , _event_address = (0,0,0,0) + , _event_details = "" + } + + +-- +-- Ctx, setup, event_is_notifiable, flag_event +-- + +type Ctx = Bool + +setup :: Bool -> IO Ctx +setup = return + +event_is_notifiable :: Event -> Bool +event_is_notifiable Event{..} = + fromEnum (fromMaybe Debug _event_severity) <= fromEnum Error + +flag_event :: Ctx -> Event -> IO () +flag_event False = const $ return () +flag_event True = LBS.hPutStrLn stderr . presentEvent + + +-- +-- Event, presentEvent, IsEvent +-- + +data Event = + Event + { _event_line :: LineNo + , _event_source :: Source + , _event_utc :: UTCTime + , _event_severity :: Maybe Priority + , _event_address :: IPV4Address + , _event_details :: LBS.ByteString + } + deriving (Show) + +data Source = Acc | AcQ | Err | QQQ + deriving (Show,Read) + +presentEvent :: Event -> LBS.ByteString +presentEvent Event{..} = LBS.pack $ + printf "%04d %s %s %-7s %3d.%3d.%3d.%3d [%s]" + (getLineNo _event_line ) + (show _event_source ) + (show _event_utc ) + (maybe "-" svrty_kw _event_severity) + a b c d + (LBS.unpack _event_details ) + where + (a,b,c,d) = _event_address + + svrty_kw = fst . syslogSeverityKeywords + +class IsEvent a where + mkEvent :: LineNo -> Source -> a -> Event + +instance IsEvent Access where + mkEvent lno src Access{..} = + Event + { _event_line = lno + , _event_source = src + , _event_utc = _a_time_local + , _event_severity = Nothing + , _event_address = _a_remote_addr + , _event_details = LBS.pack $ + printf "%s %d %d %s %s %s" + _a_request + _a_status + _a_body_bytes + _a_http_referrer + _a_http_user_agent + _a_other + } + +instance IsEvent Error where + mkEvent lno src ERROR{..} = + Event + { _event_line = lno + , _event_source = src + , _event_utc = UTCTime _e_date $ timeOfDayToTime _e_time + , _event_severity = Just _e_severity + , _event_address = (0,0,0,0) + , _event_details = LBS.pack $ printf "%d#%d: %s" pid tid $ LBS.unpack _e_other + } + where + (pid,tid) = _e_pid_tid + +instance IsEvent LBS.ByteString where + mkEvent lno src lbs = + Event + { _event_line = lno + , _event_source = src + , _event_utc = read "1970-01-01 00:00:00" + , _event_severity = Nothing + , _event_address = (0,0,0,0) + , _event_details = lbs + } + + +-- +-- Options and Prelude +-- + +lpo :: Options +lpo = makeOptions lp_prelude + +lp_prelude :: Macros RE +lp_prelude = runIdentity $ mkMacros mk regexType ExclCaptures lp_env + where + mk = maybe oops Identity . compileRegex noPreludeOptions + + oops = error "lp_prelude" + +lp_macro_table :: String +lp_macro_table = formatMacroTable regexType lp_env + +lp_macro_summary :: MacroID -> String +lp_macro_summary = formatMacroSummary regexType lp_env + +lp_macro_sources :: String +lp_macro_sources = formatMacroSources regexType ExclCaptures lp_env + +lp_macro_source :: MacroID -> String +lp_macro_source = formatMacroSource regexType ExclCaptures lp_env + +lp_env :: MacroEnv +lp_env = preludeEnv `HML.union` HML.fromList + [ f "user" user_macro + , f "pid#tid:" pid_tid_macro + , f "access" access_macro + , f "access_deg" access_deg_macro + , f "error" error_macro + ] + where + f mid mk = (mid, mk lp_env mid) + + +-- +-- The Macro Descriptors +-- + +user_macro :: MacroEnv -> MacroID -> MacroDescriptor +user_macro env mid = + runTests regexType parse_user samples env mid + MacroDescriptor + { _md_source = "(?:-|[^[:space:]]+)" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = def_test_results + , _md_parser = Just "parse_user" + , _md_description = "a user ident (per RFC1413)" + } + where + samples :: [(String,User)] + samples = + [ f "joe" + ] + where + f nm = (nm,User $ LBS.pack nm) + + counter_samples = + [ "joe user" + ] + +pid_tid_macro :: MacroEnv -> MacroID -> MacroDescriptor +pid_tid_macro env mid = + runTests regexType parse_pid_tid samples env mid + MacroDescriptor + { _md_source = "(?:@{%natural})#(?:@{%natural}):" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = def_test_results + , _md_parser = Just "parse_pid_tid" + , _md_description = "#:" + } + where + samples :: [(String,(Int,Int))] + samples = + [ f "1378#0:" (1378,0) + ] + where + f = (,) + + counter_samples = + [ "" + , "24#:" + , "24.365:" + ] + +access_macro :: MacroEnv -> MacroID -> MacroDescriptor +access_macro env mid = + runTests' regexType (parse_access . fmap LBS.pack) samples env mid + MacroDescriptor + { _md_source = access_re + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = def_test_results + , _md_parser = Just "parse_a" + , _md_description = "an Nginx access log file line" + } + where + samples :: [(String,Access)] + samples = + [ (,) "192.168.100.200 - - [12/Jan/2016:12:08:36 +0000] \"GET / HTTP/1.1\" 200 3700 \"-\" \"My Agent\" \"-\"" + Access + { _a_remote_addr = (192,168,100,200) + , _a_remote_user = "-" + , _a_time_local = read "2016-01-12 12:08:36 UTC" + , _a_request = "GET / HTTP/1.1" + , _a_status = 200 + , _a_body_bytes = 3700 + , _a_http_referrer = "-" + , _a_http_user_agent = "My Agent" + , _a_other = "-" + } + ] + + counter_samples = + [ "" + , " - [] \"\" \"\" \"\" \"\"" + ] + +access_deg_macro :: MacroEnv -> MacroID -> MacroDescriptor +access_deg_macro env mid = + runTests' regexType (parse_deg_access . fmap LBS.pack) samples env mid + MacroDescriptor + { _md_source = " - \\[\\] \"\" \"\" \"\" \"\"" + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = def_test_results + , _md_parser = Nothing + , _md_description = "a degenerate Nginx access log file line" + } + where + samples :: [(String,Access)] + samples = + [ (,) " - [] \"\" \"\" \"\" \"\"" deg_access + ] + + counter_samples = + [ "" + , "foo" + ] + +error_macro :: MacroEnv -> MacroID -> MacroDescriptor +error_macro env mid = + runTests' regexType (parse_error . fmap LBS.pack) samples env mid + MacroDescriptor + { _md_source = error_re + , _md_samples = map fst samples + , _md_counter_samples = counter_samples + , _md_test_results = def_test_results + , _md_parser = Just "parse_e" + , _md_description = "an Nginx error log file line" + } + where + samples :: [(String,Error)] + samples = + [ (,) "2016/12/21 11:53:35 [emerg] 1378#0: foo" + ERROR + { _e_date = read "2016-12-21" + , _e_time = read "11:53:35" + , _e_severity = Emergency + , _e_pid_tid = (1378,0) + , _e_other = " foo" + } + , (,) "2017/01/04 05:40:19 [error] 31623#0: *1861296 no \"ssl_certificate\" is defined in server listening on SSL port while SSL handshaking, client: 192.168.31.38, server: 0.0.0.0:80" + ERROR + { _e_date = read "2017-01-04" + , _e_time = read "05:40:19" + , _e_severity = Error + , _e_pid_tid = (31623,0) + , _e_other = " *1861296 no \"ssl_certificate\" is defined in server listening on SSL port while SSL handshaking, client: 192.168.31.38, server: 0.0.0.0:80" + } + ] + + counter_samples = + [ "" + , "foo" + ] + +def_test_results :: [TestResult] +def_test_results = error "def_test_results" +\end{code} + +\begin{code} + +-- +-- Access, access_re, deg_access, parse_deg_access, parse_access +-- + +data Access = + Access + { _a_remote_addr :: IPV4Address + , _a_remote_user :: User + , _a_time_local :: UTCTime + , _a_request :: String + , _a_status :: Int + , _a_body_bytes :: Int + , _a_http_referrer :: String + , _a_http_user_agent :: String + , _a_other :: String + } + deriving (Eq,Show) +\end{code} + +\begin{code} +access_re :: RegexSource +access_re = RegexSource $ unwords + [ "(@{%address.ipv4})" + , "-" + , "(@{user})" + , "\\[(@{%datetime.clf})\\]" + , "(@{%string.simple})" + , "(@{%natural})" + , "(@{%natural})" + , "(@{%string.simple})" + , "(@{%string.simple})" + , "(@{%string.simple})" + ] +\end{code} + +\begin{code} +deg_access :: Access +deg_access = + Access + { _a_remote_addr = (0,0,0,0) + , _a_remote_user = "-" + , _a_time_local = read "1970-01-01 00:00:00" + , _a_request = "" + , _a_status = 0 + , _a_body_bytes = 0 + , _a_http_referrer = "" + , _a_http_user_agent = "" + , _a_other = "" + } + +parse_deg_access :: Match LBS.ByteString -> Maybe Access +parse_deg_access Match{..} = + case matchSource == " - [] \"\" \"\" \"\" \"\"" of + True -> Just deg_access + False -> Nothing + +parse_a :: LBS.ByteString -> Maybe Access +parse_a lbs = parse_access $ lbs ?=~ [re_|@{access}|] lpo + +parse_access :: Match LBS.ByteString -> Maybe Access +parse_access cs = + Access + <$> f parseIPv4Address [cp|1|] + <*> f parse_user [cp|2|] + <*> f parseDateTimeCLF [cp|3|] + <*> f parseSimpleString [cp|4|] + <*> f parseInteger [cp|5|] + <*> f parseInteger [cp|6|] + <*> f parseSimpleString [cp|7|] + <*> f parseSimpleString [cp|8|] + <*> f parseSimpleString [cp|9|] + where + f psr i = psr $ capturedText $ capture i cs + + +-- +-- Error, error_re, parse_error +-- + +data Error = + ERROR + { _e_date :: Day + , _e_time :: TimeOfDay + , _e_severity :: Priority + , _e_pid_tid :: (Int,Int) + , _e_other :: LBS.ByteString + } + deriving (Eq,Show) + +error_re :: RegexSource +error_re = RegexSource $ unwords + [ "(@{%date.slashes})" + , "(@{%time})" + , "\\[(@{%syslog.severity})\\]" + , "(@{pid#tid:})(.*)" + ] + +parse_e :: LBS.ByteString -> Maybe Error +parse_e lbs = parse_error $ lbs ?=~ [re_|@{error}|] lpo + +parse_error :: Match LBS.ByteString -> Maybe Error +parse_error cs = + ERROR + <$> f parseSlashesDate [cp|1|] + <*> f parseTimeOfDay [cp|2|] + <*> f parseSyslogSeverity [cp|3|] + <*> f parse_pid_tid [cp|4|] + <*> f Just [cp|5|] + where + f psr i = psr $ capturedText $ capture i cs + + +-- +-- User, parseUser +-- + +newtype User = + User { _User :: LBS.ByteString } + deriving (IsString,Ord,Eq,Show) + +parse_user :: Replace a => a -> Maybe User +parse_user = Just . User . LBS.pack . unpack_ + + +-- +-- parse_pid_tid +-- + +parse_pid_tid :: Replace a => a -> Maybe (Int,Int) +parse_pid_tid x = case allMatches $ unpack_ x S.*=~ [re|@{%natural}|] of + [cs,cs'] -> (,) <$> p cs <*> p cs' + _ -> Nothing + where + p cs = matchCapture cs >>= parseInteger . capturedText + + +-- +-- cmp +-- + +cmp :: T.Text -> T.Text -> IO Bool +cmp src dst = handle hdl $ do + _ <- SH.shelly $ SH.verbosely $ + SH.run "cmp" [src,dst] + return True + where + hdl :: SomeException -> IO Bool + hdl se = do + hPutStrLn stderr $ + "testing results against model answers failed: " ++ show se + return False +\end{code} diff --git a/examples/re-pp.lhs b/examples/re-pp.lhs new file mode 100644 --- /dev/null +++ b/examples/re-pp.lhs @@ -0,0 +1,459 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Control.Applicative +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IORef +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import qualified Shelly as SH +import System.Directory +import System.Environment +import TestKit +import Text.Printf +import Text.RE.Edit +import Text.RE.TDFA.ByteString.Lazy +import Text.RE.TDFA.Text as T +import Text.RE.Tools.Grep +import Text.RE.Tools.Sed +\end{code} + +\begin{code} +main :: IO () +main = do + as <- getArgs + case as of + [] -> test + ["test"] -> test + ["doc",fn,fn'] | is_file fn -> doc fn fn' + ["gen",fn,fn'] | is_file fn -> gen fn fn' + ["all"] -> gen_all + _ -> usage + where + is_file = not . (== "--") . take 2 + + doc fn fn' = docMode >>= \dm -> loop dm fn fn' + gen fn fn' = genMode >>= \gm -> loop gm fn fn' + + usage = do + pnm <- getProgName + let prg = ((pnm++" ")++) + putStr $ unlines + [ "usage:" + , " "++prg "--help" + , " "++prg "[test]" + , " "++prg "all" + , " "++prg "doc (-|) (-|)" + , " "++prg "gen (-|) (-|)" + ] +\end{code} + + +The Sed Script +-------------- + +\begin{code} +-- | the MODE determines whether we are generating documentation +-- or a Haskell testsuite and includes any IO-accessible state +-- needed by the relevant processor +data MODE + = Doc DocState -- ^ document-generation state + | Gen GenState -- ^ adjusting-the-program-for-testing state +\end{code} + +The `DocState` is initialised to `Outside` and flips though the different +states as it traverses a code block, so that we can wrap code +blocks in special
blocks when their +first line indicates that it contains a REPL calculation, which the +style sheet can pick up and present accordingly. + +\begin{code} +data DocMode + = Outside -- not inside a begin{code} ... \end{code} block + | Beginning -- at the start of a begin{code} ... \end{code} block + | InsideRepl -- inside a REPL code block + | InsideProg -- inside a non-REPL code block + deriving (Eq,Show) + +type DocState = IORef DocMode + +genMode :: IO MODE +genMode = Gen <$> newIORef [] +\end{code} + +\begin{code} +-- | the state is the accumulated test function identifiers for +-- generating the list of them gets added to the end of the programme +type GenState = IORef [String] + +docMode :: IO MODE +docMode = Doc <$> newIORef Outside +\end{code} + + +\begin{code} +loop :: MODE -> FilePath -> FilePath -> IO () +loop mode = + sed $ Select + [ (,) [re|^%include ${file}(@{%string}) ${rex}(@{%string})$|] $ EDIT_fun TOP $ include mode + , (,) [re|^%main ${arg}(top|bottom)$|] $ EDIT_gen $ main_ mode + , (,) [re|^\\begin\{code\}$|] $ EDIT_gen $ begin mode + , (,) [re|^${fn}(evalme@{%id}) = checkThis ${arg}(@{%string}).*$|] $ EDIT_fun TOP $ evalme mode + , (,) [re|^\\end\{code\}$|] $ EDIT_fun TOP $ end mode + , (,) [re|^.*$|] $ EDIT_fun TOP $ other mode + ] +\end{code} + +\begin{code} +include, evalme, end, + other :: MODE + -> LineNo + -> Match LBS.ByteString + -> Location + -> Capture LBS.ByteString + -> IO (Maybe LBS.ByteString) + +main_, + begin :: MODE + -> LineNo + -> Matches LBS.ByteString + -> IO (LineEdit LBS.ByteString) + +include (Doc _ ) = includeDoc +include (Gen _ ) = passthru + +main_ (Doc _ ) = mainDoc +main_ (Gen gs) = mainGen gs + +begin (Doc ds) = beginDoc ds +begin (Gen _ ) = passthru_g + +evalme (Doc ds) = evalmeDoc ds +evalme (Gen gs) = evalmeGen gs + +end (Doc ds) = endDoc ds +end (Gen _ ) = passthru + +other (Doc ds) = otherDoc ds +other (Gen _ ) = passthru + +passthru :: LineNo + -> Match LBS.ByteString + -> Location + -> Capture LBS.ByteString + -> IO (Maybe LBS.ByteString) +passthru _ _ _ _ = return Nothing + +passthru_g :: LineNo + -> Matches LBS.ByteString + -> IO (LineEdit LBS.ByteString) +passthru_g _ _ = return NoEdit +\end{code} + + +Script to Generate All Tutorial Tests and Docs +---------------------------------------------- + +\begin{code} +gen_all :: IO () +gen_all = do + -- prepare HTML docs for the (literate) tools + pd "re-gen-modules" + pd "re-include" + pd "re-nginx-log-processor" + pd "re-pp" + pd "re-tests" + pd "TestKit" + pd "RE/Capture" + pd "RE/Edit" + pd "RE/IsRegex" + pd "RE/Options" + pd "RE/Replace" + pd "RE/TestBench" + pd "RE/Tools/Grep" + pd "RE/Tools/Lex" + pd "RE/Tools/Sed" + pd "RE/Internal/NamedCaptures" + -- render the tutorial in HTML + dm <- docMode + loop dm "examples/re-tutorial-master.lhs" "tmp/re-tutorial.lhs" + createDirectoryIfMissing False "tmp" + pandoc' + "re-tutorial.lhs" + "examples/re-tutorial.lhs" + "tmp/re-tutorial.lhs" + "docs/re-tutorial.html" + -- generate the tutorial-based tests + gm <- genMode + loop gm "examples/re-tutorial-master.lhs" "examples/re-tutorial.lhs" + putStrLn ">> examples/re-tutorial.lhs" + where + pd fnm = case captureTextMaybe [cp|mnm|] $ fnm T.?=~ [re|^RE/(Tools/|Internal/)?${mnm}(@{%id})|] of + Just mnm -> pandoc fnm ("Text/"<>fnm<>".lhs") ("docs/"<>mnm<>".html") + Nothing -> pandoc fnm ( "examples/"<>fnm<>".lhs") ("docs/"<>fnm<>".html") +\end{code} + + +Generating the Tutorial +----------------------- + +\begin{code} +includeDoc :: LineNo + -> Match LBS.ByteString + -> Location + -> Capture LBS.ByteString + -> IO (Maybe LBS.ByteString) +includeDoc _ mtch _ _ = fmap Just $ + extract fp =<< compileRegex () re_s + where + fp = prs_s $ captureText [cp|file|] mtch + re_s = prs_s $ captureText [cp|rex|] mtch + + prs_s = fromMaybe (error "includeDoc") . parseString +\end{code} + +\begin{code} +mainDoc :: LineNo + -> Matches LBS.ByteString + -> IO (LineEdit LBS.ByteString) +mainDoc _ _ = return Delete +\end{code} + +\begin{code} +beginDoc :: DocState + -> LineNo + -> Matches LBS.ByteString + -> IO (LineEdit LBS.ByteString) +beginDoc ds _ _ = writeIORef ds Beginning >> return Delete +\end{code} + +\begin{code} +evalmeDoc, endDoc, otherDoc :: DocState + -> LineNo + -> Match LBS.ByteString + -> Location + -> Capture LBS.ByteString + -> IO (Maybe LBS.ByteString) + +evalmeDoc ds lno _ _ _ = do + dm <- readIORef ds + when (dm/=Beginning) $ + bad_state "evalme" lno dm + writeIORef ds InsideRepl + return $ Just $ "
\n"<>begin_code + +endDoc ds lno _ _ _ = do + dm <- readIORef ds + case dm of + Outside -> bad_state "end" lno dm + Beginning -> return $ Just $ begin_code <> "\n" <> end_code + InsideRepl -> return $ Just $ end_code <> "\n
" + InsideProg -> return Nothing + +otherDoc ds _ mtch _ _ = do + dm <- readIORef ds + case dm of + Beginning -> do + writeIORef ds InsideProg + return $ Just $ begin_code <> "\n" <> matchSource mtch + _ -> return Nothing + +bad_state :: String -> LineNo -> DocMode -> IO a +bad_state lab lno dm = error $ + printf "Bad document syntax: %s: %d: %s" lab (getLineNo lno) $ show dm +\end{code} + + +Generating the Tests +-------------------- + +\begin{code} +evalmeGen :: GenState + -> LineNo + -> Match LBS.ByteString + -> Location + -> Capture LBS.ByteString + -> IO (Maybe LBS.ByteString) +evalmeGen gs _ mtch0 _ _ = Just <$> + replaceCapturesM replace_ ALL f mtch0 + where + f mtch loc cap = case _loc_capture loc of + 2 -> do + modifyIORef gs (ide:) + return $ Just $ LBS.pack $ show ide + where + ide = LBS.unpack $ captureText [cp|fn|] mtch + _ -> return $ Just $ capturedText cap +\end{code} + +How are we doing? + +\begin{code} +mainGen :: GenState + -> LineNo + -> Matches LBS.ByteString + -> IO (LineEdit LBS.ByteString) +mainGen gs _ mtchs = case allMatches mtchs of + [mtch] -> + case captureText [cp|arg|] $ mtch of + "top" -> return $ ReplaceWith $ LBS.unlines $ + [ begin_code + , "module Main(main) where" + , end_code + , "" + , "*********************************************************" + , "*" + , "* WARNING: this is generated from pp-tutorial-master.lhs " + , "*" + , "*********************************************************" + ] + "bottom" -> do + fns <- readIORef gs + return $ ReplaceWith $ LBS.unlines $ + [ begin_code + , "main :: IO ()" + , "main = runTests" + ] ++ mk_list fns ++ + [ end_code + ] + _ -> error "mainGen (b)" + _ -> error "mainGen (a)" +\end{code} + +We cannot place these strings inline without confusing pandoc so we +use these definitions instead. + +\begin{code} +begin_code, end_code :: LBS.ByteString +begin_code = "\\"<>"begin{code}" +end_code = "\\"<>"end{code}" +\end{code} + + + +\begin{code} +mk_list :: [String] -> [LBS.ByteString] +mk_list [] = ["[]"] +mk_list (ide0:ides) = f "[" ide0 $ foldr (f ",") [" ]"] ides + where + f pfx ide t = (" "<>pfx<>" "<>LBS.pack ide) : t +\end{code} + + +Extracting a Literate Fragment from a Haskell Program Text +---------------------------------------------------------- + +\begin{code} +extract :: FilePath -> RE -> IO LBS.ByteString +extract fp rex = extr . LBS.lines <$> LBS.readFile fp + where + extr lns = + case parse $ scan rex lns of + Nothing -> oops + Just (lno,n) -> LBS.unlines $ (hdr :) $ (take n $ drop i lns) ++ [ftr] + where + i = getZeroBasedLineNo lno + + oops = error $ concat + [ "failed to locate fragment matching " + , show $ reSource rex + , " in file " + , show fp + ] + + hdr = "
" + ftr = "
" +\end{code} + +\begin{code} +parse :: [Token] -> Maybe (LineNo,Int) +parse [] = Nothing +parse (tk:tks) = case (tk,tks) of + (Bra b_ln,Hit:Ket k_ln:_) -> Just (b_ln,count_lines_incl b_ln k_ln) + _ -> parse tks +\end{code} + +\begin{code} +count_lines_incl :: LineNo -> LineNo -> Int +count_lines_incl b_ln k_ln = + getZeroBasedLineNo k_ln + 1 - getZeroBasedLineNo b_ln +\end{code} + +\begin{code} +data Token = Bra LineNo | Hit | Ket LineNo deriving (Show) +\end{code} + +\begin{code} +scan :: RE -> [LBS.ByteString] -> [Token] +scan rex = grepScript + [ (,) [re|\\begin\{code\}|] $ \i -> chk $ Bra i + , (,) rex $ \_ -> chk Hit + , (,) [re|\\end\{code\}|] $ \i -> chk $ Ket i + ] + where + chk x mtchs = case anyMatches mtchs of + True -> Just x + False -> Nothing +\end{code} + + +pandoc +------ + +\begin{code} +pandoc :: T.Text -> T.Text -> T.Text -> IO () +pandoc title in_file = pandoc' title in_file in_file + +pandoc' :: T.Text -> T.Text -> T.Text -> T.Text -> IO () +pandoc' title repo_path in_file out_file = do + writeFile "tmp/bc.html" bc + fmap (const ()) $ + SH.shelly $ SH.verbosely $ + SH.run "pandoc" + [ "-f", "markdown+lhs+grid_tables" + , "-t", "html" + , "-s" + , "-B", "tmp/bc.html" + , "-c", "lib/styles.css" + , "-c", "lib/bs.css" + , "-o", out_file + , in_file + ] + where + bc = concat + [ "
  1. " + , "Home
    2. > " + , T.unpack title + , "
" + ] + + repo_url = concat + [ "https://github.com/iconnect/regex/blob/master/" + , T.unpack repo_path + ] +\end{code} + +testing +------- + +\begin{code} +test :: IO () +test = do + dm <- docMode + test_pp "pp-doc" (loop dm) "data/pp-test.lhs" "data/pp-result-doc.lhs" + gm <- genMode + test_pp "pp-gen" (loop gm) "data/pp-test.lhs" "data/pp-result-gen.lhs" + putStrLn "tests passed" +\end{code} diff --git a/examples/re-tests.lhs b/examples/re-tests.lhs new file mode 100644 --- /dev/null +++ b/examples/re-tests.lhs @@ -0,0 +1,257 @@ +\begin{code} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main (main) where + +import Control.Applicative +import Data.Array +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Foldable +import Data.Monoid +import qualified Data.Sequence as S +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Test.Tasty +import Test.Tasty.HUnit +import Text.RE +import Text.RE.Internal.NamedCaptures +import qualified Text.RE.PCRE as PCRE +import Text.RE.TDFA as TDFA +import Text.RE.TestBench + +import Text.RE.TDFA.String() + + +main :: IO () +main = defaultMain $ + testGroup "Tests" + [ prelude_tests + , parsing_tests + , core_tests + , replace_tests + , options_tests + , namedCapturesTestTree + ] + +prelude_tests :: TestTree +prelude_tests = testGroup "Prelude" + [ tc TDFA TDFA.preludeEnv + , tc PCRE PCRE.preludeEnv + ] + where + tc rty m_env = + testCase (show rty) $ do + dumpMacroTable "prelude" rty m_env + assertBool "testMacroEnv" =<< testMacroEnv "prelude" rty m_env + +str, str' :: String +str = "a bbbb aa b" +str' = "foo" + +regex_, regex_alt :: RE +regex_ = [re|(a+) (b+)|] +regex_alt = [re|(a+)|(b+)|] + +regex_str_matches :: Matches String +regex_str_matches = + Matches + { matchesSource = "a bbbb aa b" + , allMatches = + [ regex_str_match + , regex_str_match_2 + ] + } + +regex_str_match :: Match String +regex_str_match = + Match + { matchSource = "a bbbb aa b" + , captureNames = noCaptureNames + , matchArray = array (0,2) + [ (0,Capture {captureSource = "a bbbb aa b", capturedText = "a bbbb", captureOffset = 0, captureLength = 6}) + , (1,Capture {captureSource = "a bbbb aa b", capturedText = "a" , captureOffset = 0, captureLength = 1}) + , (2,Capture {captureSource = "a bbbb aa b", capturedText = "bbbb" , captureOffset = 2, captureLength = 4}) + ] + } + +regex_str_match_2 :: Match String +regex_str_match_2 = + Match + { matchSource = "a bbbb aa b" + , captureNames = noCaptureNames + , matchArray = array (0,2) + [ (0,Capture {captureSource = "a bbbb aa b", capturedText = "aa b", captureOffset = 7 , captureLength = 4}) + , (1,Capture {captureSource = "a bbbb aa b", capturedText = "aa" , captureOffset = 7 , captureLength = 2}) + , (2,Capture {captureSource = "a bbbb aa b", capturedText = "b" , captureOffset = 10, captureLength = 1}) + ] + } + +regex_alt_str_matches :: Matches String +regex_alt_str_matches = + Matches + { matchesSource = "a bbbb aa b" + , allMatches = + [ Match + { matchSource = "a bbbb aa b" + , captureNames = noCaptureNames + , matchArray = array (0,2) + [ (0,Capture {captureSource = "a bbbb aa b", capturedText = "a", captureOffset = 0, captureLength = 1}) + , (1,Capture {captureSource = "a bbbb aa b", capturedText = "a", captureOffset = 0, captureLength = 1}) + , (2,Capture {captureSource = "a bbbb aa b", capturedText = "", captureOffset = -1, captureLength = 0}) + ] + } + , Match + { matchSource = "a bbbb aa b" + , captureNames = noCaptureNames + , matchArray = array (0,2) + [ (0,Capture {captureSource = "a bbbb aa b", capturedText = "bbbb", captureOffset = 2 , captureLength = 4}) + , (1,Capture {captureSource = "a bbbb aa b", capturedText = "" , captureOffset = -1, captureLength = 0}) + , (2,Capture {captureSource = "a bbbb aa b", capturedText = "bbbb", captureOffset = 2 , captureLength = 4}) + ] + } + , Match + { matchSource = "a bbbb aa b" + , captureNames = noCaptureNames + , matchArray = array (0,2) + [ (0,Capture {captureSource = "a bbbb aa b", capturedText = "aa", captureOffset = 7 , captureLength = 2}) + , (1,Capture {captureSource = "a bbbb aa b", capturedText = "aa", captureOffset = 7 , captureLength = 2}) + , (2,Capture {captureSource = "a bbbb aa b", capturedText = "" , captureOffset = -1, captureLength = 0}) + ] + } + , Match + { matchSource = "a bbbb aa b" + , captureNames = noCaptureNames + , matchArray = array (0,2) + [ (0,Capture {captureSource = "a bbbb aa b", capturedText = "b", captureOffset = 10, captureLength = 1}) + , (1,Capture {captureSource = "a bbbb aa b", capturedText = "" , captureOffset = -1, captureLength = 0}) + , (2,Capture {captureSource = "a bbbb aa b", capturedText = "b", captureOffset = 10, captureLength = 1}) + ] + } + ] + } + +parsing_tests :: TestTree +parsing_tests = testGroup "Parsing" + [ testCase "complete check (matchM/ByteString)" $ do + r <- compileRegex () $ reSource regex_ + assertEqual "Match" (B.pack <$> regex_str_match) $ B.pack str ?=~ r + , testCase "matched (matchM/Text)" $ do + r <- compileRegex () $ reSource regex_ + assertEqual "matched" True $ matched $ T.pack str ?=~ r + ] + +core_tests :: TestTree +core_tests = testGroup "Match" + [ testCase "text (=~~Text.Lazy)" $ do + txt <- LT.pack str =~~ [re|(a+) (b+)|] :: IO (LT.Text) + assertEqual "text" txt "a bbbb" + , testCase "multi (=~~/String)" $ do + let sm = str =~ regex_ :: Match String + m = capture [cp|0|] sm + assertEqual "captureSource" "a bbbb aa b" $ captureSource m + assertEqual "capturedText" "a bbbb" $ capturedText m + assertEqual "capturePrefix" "" $ capturePrefix m + assertEqual "captureSuffix" " aa b" $ captureSuffix m + , testCase "complete (=~~/ByteString)" $ do + mtch <- B.pack str =~~ regex_ :: IO (Match B.ByteString) + assertEqual "Match" mtch $ B.pack <$> regex_str_match + , testCase "complete (all,String)" $ do + let mtchs = str =~ regex_ :: Matches String + assertEqual "Matches" mtchs regex_str_matches + , testCase "complete (all,reg_alt)" $ do + let mtchs = str =~ regex_alt :: Matches String + assertEqual "Matches" mtchs regex_alt_str_matches + , testCase "complete (=~~,all)" $ do + mtchs <- str =~~ regex_ :: IO (Matches String) + assertEqual "Matches" mtchs regex_str_matches + , testCase "fail (all)" $ do + let mtchs = str' =~ regex_ :: Matches String + assertEqual "not.anyMatches" False $ anyMatches mtchs + ] + +replace_tests :: TestTree +replace_tests = testGroup "Replace" + [ testCase "String/single" $ do + let m = str =~ regex_ :: Match String + r = replaceCaptures' ALL fmt m + assertEqual "replaceCaptures'" r "(0:0:(0:1:a) (0:2:bbbb)) aa b" + , testCase "String/alt" $ do + let ms = str =~ regex_ :: Matches String + r = replaceAllCaptures' ALL fmt ms + chk r + , testCase "String" $ do + let ms = str =~ regex_ :: Matches String + r = replaceAllCaptures' ALL fmt ms + chk r + , testCase "ByteString" $ do + let ms = B.pack str =~ regex_ :: Matches B.ByteString + r = replaceAllCaptures' ALL fmt ms + chk r + , testCase "LBS.ByteString" $ do + let ms = LBS.pack str =~ regex_ :: Matches LBS.ByteString + r = replaceAllCaptures' ALL fmt ms + chk r + , testCase "Seq Char" $ do + let ms = S.fromList str =~ regex_ :: Matches (S.Seq Char) + f = \_ (Location i j) Capture{..} -> Just $ S.fromList $ + "(" <> show i <> ":" <> show_co j <> ":" <> + toList capturedText <> ")" + r = replaceAllCaptures' ALL f ms + assertEqual "replaceAllCaptures'" r $ + S.fromList "(0:0:(0:1:a) (0:2:bbbb)) (1:0:(1:1:aa) (1:2:b))" + , testCase "Text" $ do + let ms = T.pack str =~ regex_ :: Matches T.Text + r = replaceAllCaptures' ALL fmt ms + chk r + , testCase "LT.Text" $ do + let ms = LT.pack str =~ regex_ :: Matches LT.Text + r = replaceAllCaptures' ALL fmt ms + chk r + ] + where + chk r = + assertEqual + "replaceAllCaptures'" + r + "(0:0:(0:1:a) (0:2:bbbb)) (1:0:(1:1:aa) (1:2:b))" + + fmt :: (IsString s,Replace s) => a -> Location -> Capture s -> Maybe s + fmt _ (Location i j) Capture{..} = Just $ "(" <> pack_ (show i) <> ":" <> + pack_ (show_co j) <> ":" <> capturedText <> ")" + + show_co (CaptureOrdinal j) = show j + +options_tests :: TestTree +options_tests = testGroup "Simple Options" + [ testGroup "TDFA Simple Options" + [ testCase "default (MultilineSensitive)" $ assertEqual "#" 2 $ + countMatches $ s TDFA.*=~ [TDFA.re|[0-9a-f]{2}$|] + , testCase "MultilineSensitive" $ assertEqual "#" 2 $ + countMatches $ s TDFA.*=~ [TDFA.reMultilineSensitive|[0-9a-f]{2}$|] + , testCase "MultilineInsensitive" $ assertEqual "#" 4 $ + countMatches $ s TDFA.*=~ [TDFA.reMultilineInsensitive|[0-9a-f]{2}$|] + , testCase "BlockSensitive" $ assertEqual "#" 0 $ + countMatches $ s TDFA.*=~ [TDFA.reBlockSensitive|[0-9a-f]{2}$|] + , testCase "BlockInsensitive" $ assertEqual "#" 1 $ + countMatches $ s TDFA.*=~ [TDFA.reBlockInsensitive|[0-9a-f]{2}$|] + ] + , testGroup "PCRE Simple Options" + [ testCase "default (MultilineSensitive)" $ assertEqual "#" 2 $ + countMatches $ s PCRE.*=~ [PCRE.re|[0-9a-f]{2}$|] + , testCase "MultilineSensitive" $ assertEqual "#" 2 $ + countMatches $ s PCRE.*=~ [PCRE.reMultilineSensitive|[0-9a-f]{2}$|] + , testCase "MultilineInsensitive" $ assertEqual "#" 4 $ + countMatches $ s PCRE.*=~ [PCRE.reMultilineInsensitive|[0-9a-f]{2}$|] + , testCase "BlockSensitive" $ assertEqual "#" 0 $ + countMatches $ s PCRE.*=~ [PCRE.reBlockSensitive|[0-9a-f]{2}$|] + , testCase "BlockInsensitive" $ assertEqual "#" 1 $ + countMatches $ s PCRE.*=~ [PCRE.reBlockInsensitive|[0-9a-f]{2}$|] + ] + ] + where + s = "0a\nbb\nFe\nA5" :: String +\end{code} diff --git a/examples/re-tutorial.lhs b/examples/re-tutorial.lhs new file mode 100644 --- /dev/null +++ b/examples/re-tutorial.lhs @@ -0,0 +1,859 @@ +The Regex Tutorial +================== + +This is a literate Haskell programme lightly processed to produce this +web presentation and also to generate a test suite that verifies that +each of the example calculations are generating the expected results. +You can load it into ghci and try out the examples either by running +_ghci_ itself from the root folder of the regex package: +```bash +ghci examples/re-tutorial.lhs +``` +or using `cabal repl`: +``` +cabal configure --enable-tests +cabal repl examples/re-tutorial.lhs +``` + +Depending upon how you have configured and run `ghci` you may need to +set one of _ghci_'s interctive settings — the topic of the next +section. + + +Setting Up: The Pragmas +----------------------- + +Haskell programs typically start with a few compiler pragmas to switch +on the language extensions needed by the module. Because regex uses +Template Haskell to check regular expressions at compile time `QuasiQuotes` +should be enabled. + +\begin{code} +{-# LANGUAGE QuasiQuotes #-} +\end{code} + +Use this command to configure ghci accordingly (not necessary if you +have launched ghci with `cabal repl`): +``` +:seti -XQuasiQuotes +``` + +[Overloaded string +literals](https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/guide-to-ghc-extensions/basic-syntax-extensions#overloadedstrings) +are usually enabled in modern Haskell and we do so here. +\begin{code} +{-# LANGUAGE OverloadedStrings #-} +\end{code} + +Because we are mimicking the REPL in this tutorial we will leave off the type +signatures on the example calculations and disable the compiler +warnings about missing type signatures. +\begin{code} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +\end{code} + + +Loading Up: The Imports +----------------------- + +\begin{code} +module Main(main) where +\end{code} + +********************************************************* +* +* WARNING: this is generated from pp-tutorial-master.lhs +* +********************************************************* + +We have two things to consider in the import to access the regex +goodies, which will take the form: +```haskell +import Text.RE..? +``` + + * Which [flavour of regular expressions](https://wiki.haskell.org/Regular_expressions) do I need? + + `PCRE` : [Perl-style](https://en.wikibooks.org/wiki/Regular_Expressions/Perl-Compatible_Regular_Expressions) regular expressions; + + `TDFA`: [Posix-style](https://en.wikipedia.org/wiki/Regular_expression#POSIX_extended) regular expressions. + + * And which type of text am I matching? + + `String` : low-performing, classic Haskell strings; + + `ByteString` : raw bytestrings; + + `ByteString.Lazy` : raw lazy bytestrings; + + `Text`: efficient text (currently available for `TDFA` only); + + `Text.Lazy` : efficient, lazy text (currently available for + `TDFA` only); + + polymorphic: if you need matching operators that work with all + available text types then do not specify the `` in + the import path. + +For this tutorial we will use classic Haskell strings but any application +dealing with bulk text will probably want to choose one of the other +options. +\begin{code} +import Text.RE.TDFA.String +\end{code} +If you are predominantly matching against a single type in your module +then you will probably find it more convenient to use the relevant module +rather than than the more polymorphic opertors but it is really a +matter of convenience. + +We will also need access to a small selection of common libraries for +our examples. +\begin{code} +import Control.Applicative +import Data.Maybe +import qualified Data.Text as T +import Text.Printf +\end{code} + +And finally we will import a small specail toolkit will be used to help +manage the example calculations. +\begin{code} +import TestKit +\end{code} +This allows simple calculations to be defined stylistically +in the source program, presented as calculations when rendered +in HTML and tested that they have the expected result. +\begin{code} +evalme_LOA_00 = checkThis "evalme_LOA_00" 0 $ + length [] +\end{code} +This trivial example calculation will be tested for equality to 0. + + +Matching with the regex-base Operators +-------------------------------------- + +regex supports the regex-base polymorphic match operators. Used in a +`Bool` context `=~` will evaluate to True iff the string on the left matches +the RE on the right. +\begin{code} +evalme_TRD_00 = checkThis "evalme_TRD_00" True $ + ("2016-01-09 2015-12-5 2015-10-05" =~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] :: Bool) +\end{code} +Note that we enclose the RE itself in `[re|` ... `|]` quasi quote brackets, +allowing the compiler to run some regex code at compile time to verify that +the RE conforms to the correct syntax for the chosen RE flavour of choice +(`TDFA` in this case). The above expression should evaluate to `True` as the +string contains a matching sub-string. + +Used in an `Int` context `=~` will count the number of matches in the target string. +\begin{code} +evalme_TRD_01 = checkThis "evalme_TRD_01" 2 $ + ("2016-01-09 2015-12-5 2015-10-05" =~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] :: Int) +\end{code} + +To determine the string that has matched the modaic `=~~` operator can be used +in a `Maybe` context. +\begin{code} +evalme_TRD_02 = checkThis "evalme_TRD_02" (Just "2016-01-09") $ + ("2016-01-09 2015-12-5 2015-10-05" =~~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] :: Maybe String) +\end{code} +This should evaluate to `Just "2016-01-09"`. + +A `=~` in a `[[String]]` extracts all of the matched substrings: +\begin{code} +evalme_TRD_04 = checkThis "evalme_TRD_04" [["2016-01-09"],["2015-10-05"]] $ + ("2016-01-09 2015-12-5 2015-10-05" =~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] :: [[String]]) +\end{code} +yields `[["2016-01-09"],["2015-10-05"]]`. + +regex provides special operators and types for extracting the first +match or all of the non-overlapping substrings matching a regular expression +which provide a little more structure that the flexible, venerable regex-base +match operators. + + +Single Matches with `?=~` +------------------------- + +regex also provides two matching operators: one for looking for the first +match in its search string and the other for finding all of the matches. The +first-match operator, `?=~`, yields the result of attempting to find the first +match. (It's result type will be explained below.) The boolean `matched` +function can be used to test whether a match was found. +\begin{code} +evalme_SGL_01 = checkThis "evalme_SGL_01" True $ + matched $ "2016-01-09 2015-12-5 2015-10-05" ?=~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] +\end{code} +This should yield `True`. + +To get the matched text use `matchText`, which returns `Nothing` if no match was +found in the search string. +\begin{code} +evalme_SGL_02 = checkThis "evalme_SGL_02" (Just "2016-01-09") $ + matchedText $ "2016-01-09 2015-12-5 2015-10-05" ?=~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] +\end{code} +This should yield `Just "2016-01-09"`. + + +Multiple Matches with `*=~` +--------------------------- + +Use `*=~` to locate all of the non-overlapping substrings that matches a RE. +`anyMatches` will return `True` iff any matches are found (and they will be). +\begin{code} +evalme_MLT_01 = checkThis "evalme_MLT_01" True $ + anyMatches $ "2016-01-09 2015-12-5 2015-10-05" *=~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] +\end{code} + +`countMatches` will tell us how many sub-strings matched (2). +\begin{code} +evalme_MLT_02 = checkThis "evalme_MLT_02" 2 $ + countMatches $ "2016-01-09 2015-12-5 2015-10-05" *=~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] +\end{code} + +`matches` will return all of the matches. +\begin{code} +evalme_MLT_03 = checkThis "evalme_MLT_03" ["2016-01-09","2015-10-05"] $ + matches $ "2016-01-09 2015-12-5 2015-10-05" *=~ [re|[0-9]{4}-[0-9]{2}-[0-9]{2}|] +\end{code} +This should yield `["2016-01-09","2015-10-05"]`. + + +Simple Text Replacement +----------------------- + +regex supports the replacement of matched text with alternative text. This +section will cover replacement text specified with templates. More flexible +tools that allow functions calculate the replacement text are covered below. + +_Capture_ sub-expressions, whose matched text can be inserted into the +replacement template, can be specified as follows: + + * `$(` ... `)` identifies a capture that can be identified by its + left-to-right position relative to the other captures in the replacement + template, with `$1` being used to represent the leftmost capture, `$2` the + next leftmost capture, and so on; + + * `${foo}(` ... `)` can be used to identify a capture by name. Such captures + can be identified either by their left-to-right position in the regular + expression or by `${foo}` in the template. + +A function to convert ISO format dates into a UK-format date could be written +thus: +\begin{code} +uk_dates :: String -> String +uk_dates src = + replaceAll "${d}/${m}/${y}" $ src *=~ [re|${y}([0-9]{4})-${m}([0-9]{2})-${d}([0-9]{2})|] +\end{code} +with +\begin{code} +evalme_RPL_01 = checkThis "evalme_RPL_01" "09/01/2016 2015-12-5 05/10/2015" $ + uk_dates "2016-01-09 2015-12-5 2015-10-05" +\end{code} +yielding `"09/01/2016 2015-12-5 05/10/2015"`. + +The same function written with numbered captures: +\begin{code} +uk_dates' :: String -> String +uk_dates' src = + replaceAll "$3/$2/$1" $ src *=~ [re|$([0-9]{4})-$([0-9]{2})-$([0-9]{2})|] +\end{code} +with +\begin{code} +evalme_RPL_02 = checkThis "evalme_RPL_02" "09/01/2016 2015-12-5 05/10/2015" $ + uk_dates' "2016-01-09 2015-12-5 2015-10-05" +\end{code} +yielding the same result. + +(Most regex conventions use plain parentheses, `(` ... `)`, to mark +captures but we would like to reserve those exclusively for grouping +in regex REs.) + + +Matches/Match/Capture +--------------------- + +The types returned by the `?=~` and `*=~` form the foundations of the +package. Understandingv these simple types is the key to understanding +the package. + +The type of `*=~` in this module (imported from +`Text.RE.TDFA.String`) is: +
+``` +(*=~) :: String -> RE -> Matches String +``` +
+with `Matches` defined in `Text.RE.Capture` thus: + +%include "Text/RE/Capture.lhs" "^data Matches " + +The critical component of the `Matches` type is the `[Match a]` in +`allMatches`, containing the details all of each substring matched by +the RE. The `matchSource` component also retains a copy of the original +search string but the critical information is in `allmatches`. + +The type of `?=~` in this module (imported from +`Text.RE.TDFA.String`) is: +
+``` +(?=~) :: String -> RE -> Match String +``` +
+with `Match` (referenced in the definition of `Matches` above) defined +in `Text.RE.Capture` thus: + +%include "Text/RE/Capture.lhs" "^data Match " + +Like `matchesSource` above, `matchSource` retains the original search +string, but also a `CaptureNames` field listing all of the capture +names in the RE (needed by the text replacemnt tools). + +But the 'real' content of `Match` is to be found in the `MatchArray`, +enumerating all of the substrings captured by this match, starting with +`0` for the substring captured by the whole RE, `1` for the leftmost +explicit capture in the RE, `2` for the next leftmost capture, and so +on. + +Each captured substring is represented by the following `Capture` type: + +%include "Text/RE/Capture.lhs" "^data Capture " + +Here we list the whole original search string in `captureSource` and +the text of the sub-string captured in `capturedText`. `captureOffset` +contains the number of characters preceding the captured substring, or +is negative if no substring was captured (which is a different +situation from epsilon, the empty string, being captured). +`captureLength` gives the length of the captured string in +`capturedText`. + +The test suite in [examples/re-tests.lhs](re-tests.html) contains extensive +worked-out examples of these `Matches`/`Match`/`Capture` types. + + +Simple Options +-------------- + +By default regular expressions are of the multi-line case-sensitive +variety so this query +\begin{code} +evalme_SOP_01 = checkThis "evalme_SOP_01" 2 $ + countMatches $ "0a\nbb\nFe\nA5" *=~ [re|[0-9a-f]{2}$|] +\end{code} +finds 2 matches, the '$' anchor matching each of the newlines, but only +the first two lowercase hex numbers matching the RE. The case sensitivity +and multiline-ness can be controled by selecting alternative parsers. + ++--------------------------+-------------+-----------+----------------+ +| long name | short forms | multiline | case sensitive | ++==========================+=============+===========+================+ +| reMultilineSensitive | reMS, re | yes | yes | ++--------------------------+-------------+-----------+----------------+ +| reMultilineInsensitive | reMI | yes | no | ++--------------------------+-------------+-----------+----------------+ +| reBlockSensitive | reBS | no | yes | ++--------------------------+-------------+-----------+----------------+ +| reBlockInsensitive | reBI | no | no | ++--------------------------+-------------+-----------+----------------+ + +So while the default setup +\begin{code} +evalme_SOP_02 = checkThis "evalme_SOP_02" 2 $ + countMatches $ "0a\nbb\nFe\nA5" *=~ [reMultilineSensitive|[0-9a-f]{2}$|] +\end{code} +finds 2 matches, a case-insensitive RE +\begin{code} +evalme_SOP_03 = checkThis "evalme_SOP_03" 4 $ + countMatches $ "0a\nbb\nFe\nA5" *=~ [reMultilineInsensitive|[0-9a-f]{2}$|] +\end{code} +finds 4 matches, while a non-multiline RE +\begin{code} +evalme_SOP_04 = checkThis "evalme_SOP_04" 0 $ + countMatches $ "0a\nbb\nFe\nA5" *=~ [reBlockSensitive|[0-9a-f]{2}$|] +\end{code} +finds no matches but a non-multiline, case-insensitive match +\begin{code} +evalme_SOP_05 = checkThis "evalme_SOP_05" 1 $ + countMatches $ "0a\nbb\nFe\nA5" *=~ [reBlockInsensitive|[0-9a-f]{2}$|] +\end{code} +finds the final match. + +For the hard of typing the shortforms are available. +\begin{code} +evalme_SOP_06 = checkThis "evalme_SOP_06" True $ + matched $ "SuperCaliFragilisticExpialidocious" ?=~ [reMI|supercalifragilisticexpialidocious|] +\end{code} + + +Using Functions to Replace Text +------------------------------- + +Sometimes you will need to process each string captured by an RE with a +function. `replaceAllCaptures` takes a `Phi` and a `Matches` and +applies the function to each captured substring according to the +`Context` specified in `Phi`, as we can see in the following example function +to clean up all of the mis-formatted dates in the argument string, +\begin{code} +fixup_dates :: String -> String +fixup_dates src = + replaceAllCaptures phi $ src *=~ [re|([0-9]+)-([0-9]+)-([0-9]+)|] + where + phi = Phi SUB $ \loc s -> case _loc_capture loc of + 1 -> printf "%04d" (read s :: Int) + 2 -> printf "%02d" (read s :: Int) + 3 -> printf "%02d" (read s :: Int) + _ -> error "fixup_date" +\end{code} +which will fix up our running example +\begin{code} +evalme_RPF_01 = checkThis "evalme_RPF_01" "2016-01-09 2015-12-05 2015-10-05" $ + fixup_dates "2016-01-09 2015-12-5 2015-10-05" +\end{code} +returning `"2016-01-09 2015-12-05 2015-10-05"`. + +The `Phi`, `Context` and `Location` types are defined in +`Text.RE.Replace` as follows. + +%include "Text/RE/Replace.lhs" "^data Phi" + +The processing function gets applied to the captures specified by the +`Context`, which can be directed to process `ALL` of the captures, +including the substring captured by the whole RE and all of the +subsidiary capture, or just the `TOP`, `0` capture that the whole RE +matches, or just the `SUB` (subsidiary) captures, as was the case above. + +If this doesn't provide enough flexibility, the `replaceAllCaptures'` +function accepts a processing function that takes the full `Match` +context for each capture along with the `Location` and the `Capture` +itself. + +%include "Text/RE/Replace.lhs" "replaceAllCaptures' ::" + +The above fixup function can be extended to enclose whole date in +square brackets and rewritten with the above more general replacement +function. +\begin{code} +fixup_and_reformat_dates :: String -> String +fixup_and_reformat_dates src = + replaceAllCaptures' ALL f $ src *=~ [re|([0-9]+)-([0-9]+)-([0-9]+)|] + where + f _ loc cap = Just $ case _loc_capture loc of + 0 -> printf "[%s]" txt + 1 -> printf "%04d" (read txt :: Int) + 2 -> printf "%02d" (read txt :: Int) + 3 -> printf "%02d" (read txt :: Int) + _ -> error "fixup_date" + where + txt = capturedText cap +\end{code} +The `fixup_and_reformat_dates` applied to our running example, +\begin{code} +evalme_RPF_02 = checkThis "evalme_RPF_02" "[2016-01-09] [2015-12-05] [2015-10-05]" $ + fixup_and_reformat_dates "2016-01-09 2015-12-5 2015-10-05" +\end{code} +yields `"[2016-01-09] [2015-12-05] [2015-10-05]"`. + +`Text.RE.Replace` provides analagous functions for replacing the +test of a single `Match` returned from `?=~`. + + +Macros and Parsers +------------------ + +regex supports macros in regular expressions. There are a bunch of +standard macros and you can define your own. + +RE macros are enclosed in `@{` ... '}'. By convention the macros in +the standard environment start with a '%'. `@{%date}` will match an +ISO 8601 date, this +\begin{code} +evalme_MAC_00 = checkThis "evalme_MAC_00" 2 $ + countMatches $ "2016-01-09 2015-12-5 2015-10-05" *=~ [re|@{%date}|] +\end{code} +picking out the two dates. + +See the tables listing the standard macros in the tables folder of +the distribution. + +See the log-processor example and the `Text.RE.TestBench` for +more on how you can develop, document and test RE macros with the +regex test bench. + + +Compiling REs with the Complete Options +--------------------------------------- + +Each type of RE — TDFA and PCRE — has it own complile-time +options and execution-time options, called in each case `CompOption` and +`ExecOption`. The above simple options selected with the RE +parser (`reMultilineSensitive`, etc.) configures the RE backend +accordingly so that you don't have to, but you may need full access to +you chosen back end's options, or you may need to supply a different +set of macros to those provided in the standard environment. In which +case you will need to know about the `Options` type, defined by each of +the back ends in terms of the `Options_` type of `Text.RE.Options` +as follows. +
+``` +type Options = Options_ RE CompOption ExecOption +``` +
+(Bear in mind that `CompOption` and `ExecOption` will be different +types for each back end.) + +The `Options_` type is defined in `Text.RE.Options` as follows: + +%include "Text/RE/Options.lhs" "data Options_" + + * `_options_mode` is an experimental feature that controls the RE + parser. + + * `_options_macs` contains the macro definitions used to compile + the REs (see above Macros section); + + * `_options_comp` contains the back end compile-time options; + + * `_options_exec` contains the back end execution-time options. + +(For more information on the options provided by the back ends see the +decumentation for `regex-tdfa` and `regex-pcre` as apropriate.) + +Each backend provides a function to compile REs from some options and a +string containing the RE as follows: +
+``` +compileRegex :: ( IsOption o RE CompOption ExecOption + , Functor m + , Monad m + ) + => o + -> String + -> m RE +``` +
+where `o` is some type that is recognised as a type that can configure +REs. Your configuration-type options are: + + * `()` (the unit type) means just use the default multi-line + case-sensitive that we get with the `re` parser. + + * `SimpleRegexOptions` this is just a simple enum type that we use to + encode the standard options: + +%include "Text/RE/Options.lhs" "^data SimpleRegexOptions" + + * `Mode`: you can specify the parser mode; + + * `Macros RE`: you can specify the macros use instead of the standard + environment; + + * `CompOption`: you can specify the compile-time options for the back + end; + + * `ExecOption`: you can specify the execution-time options for the + back end; + + * `Options`: you can specify all of the options. + +The compilation may fail so it is expressed monadically. For the +following examples we will use the following helper to just `error` +the failure. +\begin{code} +check_for_failure :: Either String a -> a +check_for_failure = either error id +\end{code} + +\begin{code} +evalme_OPT_00 = checkThis "evalme_OPT_00" 2 $ + countMatches $ + "2016-01-09 2015-12-5 2015-10-05" *=~ + check_for_failure + (compileRegex () "@{%date}") +\end{code} +\begin{code} +evalme_OPT_01 = checkThis "evalme_OPT_01" 1 $ + countMatches $ + "0a\nbb\nFe\nA5" *=~ + check_for_failure + (compileRegex BlockInsensitive "[0-9a-f]{2}$") +\end{code} + +This will allow you to compile regular expressions when the either the +text to be compiled or the options have been dynamically determined. + + +Specifying Options with `re_` +----------------------------- + +If you just need to specify some non-standard options while statically +checking the validity of the RE (with the default options) then you can +use the `re_` parser: +\begin{code} +evalme_REU_01 = checkThis "evalme_REU_01" 1 $ + countMatches $ + "0a\nbb\nFe\nA5" *=~ [re_|[0-9a-f]{2}$|] BlockInsensitive +\end{code} +Any option `o` such that `IsOption o RE CompOption ExecOption` (i.e., +any option type accepted by `compileRegex` above) can be used with +`[re_` ..`|]`. + + +The Tools: 'grep', 'lex' and 'sed' +---------------------------------- + +The classic tools assocciated with regular expressions have inspired some +regex conterparts. + + * [Text.RE.Tools.Grep}(Grep.html): takes a regular expression and a + file or lazy ByteString (depending upon the variant) and returns all of the + matching lines. (Used in the [include](re-include.html) example.) + + * [Text.RE.Tools.Lex}(Lex.html): takes an association list of REs and + token-generating functions and the input text and returns a list of tokens. + This should never be used where performance is important (use Alex), + except as a development prototype (used internally in + [Text.RE.Internal.NamedCaptures](NamedCaptures.html)). + + * [Text.RE.Tools.Lex}(Sed.html) using [Text.RE.Edit](Edit.html): + takes an association list of regular expressions and substitution actions, + some input text and invokes the associated action on each line of the file + that matches one of the REs, substituting the text returned from the action + in the output stream. (Used in the [include](re-include.html), + [gen-modules](re-gen-modules.html), + [log-processor](re-nginx-log-processor.html) and [tutorial-pp](re-pp) + examples.) + + +The Examples +------------ + +The remaining sections have been given over to various standalone +examples. All bar the first are taken from the package itself, each +contributing to either the API or the tools used to prepare the +documentation and test suites. + + +Example: log processor: development with macros +----------------------------------------------- + +To test regex at scale — which is to say, developing with +relatively complex REs — +[a preprocessor](re-nginx-log-processor.html) for parsing NGINX access +and error logs has been written. Each line of input may be either a line +from an NGINX access log or the event log, producing a standard-format +event log on the output. + +As a taster, here is the main script, where each type of line is +recognised by a high-level macro. + +%include "examples/re-nginx-log-processor.lhs" "script ::" + +Thes macros are based on the standard macros, using +`Text.RE.TestBench` to build the up into the above high-level +scanners with the apropriate +[tests and documentation](https://github.com/iconnect/regex/tree/master/tables). + +The RE for recognising the access-log lines is built up here. + +%include "examples/re-nginx-log-processor.lhs" "access_re ::" + +(N.B., The Test Bench currently requires that we write our REs in Haskell +strings.) + +See [the log-processor program sources](re-nginx-log-processor.html) for details. + + +Example: Scanning REs: Named Captures +------------------------------------- + +This package needs to recognise all captures in a regular expression so +that it can associate the named captures with their cature ordinal. + +Here is the prototype scanner. + +%include "Text/RE/Internal/NamedCaptures.lhs" "scan ::" + +Once the package has stabilised it should be rewritten with Alex. + +See [Text.RE.Internal.NamedCaptures](NamedCaptures.html) for +details. + + +Anti-Example: Scanning REs in the TestBench +------------------------------------------- + +The [Text.RE.TestBench](TestBench.html) contains an almost +identical parser to the above, written with recursive functions. + +%include "Text/RE/TestBench.lhs" "scan_re ::" + +Once some technical issues have been ersolved it will use the above +scanner in [Text.RE.Internal.NamedCaptures](NamedCaptures.html). + + +Example: filename analysis +-------------------------- + +The preprocessor used to prepare the literate programs for this +package's website uses the following 'gen_all' diriver which uses +REs to analyse file paths. + +%include "examples/re-pp.lhs" "^gen_all ::" + +See [examples/re-pp.lhs](re-pp.html) + + +Example: parsing RE macros +-------------------------- + +The regex RE macros are parsed with code that looks similar to +this. + +\begin{code} +-- | expand the @{..} macos in the argument string using the given +-- function +expandMacros_ :: (MacroID->Maybe String) -> String -> String +expandMacros_ lu = fixpoint e_m + where + e_m re_s = + replaceAllCaptures' TOP phi $ re_s *=~ [re|@$(@|\{${name}([^{}]+)\})|] + + phi mtch _ cap = case txt == "@@" of + True -> Just "@" + False -> Just $ fromMaybe txt $ lu ide + where + txt = capturedText cap + ide = MacroID $ capturedText $ capture [cp|name|] mtch + +fixpoint :: (Eq a) => (a->a) -> a -> a +fixpoint f = chk . iterate f + where + chk (x:x':_) | x==x' = x + chk xs = chk $ tail xs +\end{code} + +For example: +\begin{code} +evalme_PMC_00 = checkThis "evalme_PMC_00" "foo MacroID {_MacroID = \"bar\"} baz" $ + expandMacros_ (Just . show) "foo @{bar} baz" +\end{code} + +See [Text.RE.Replace](Replace.html) for details. + + +Example: Parsing Replace Templates +---------------------------------- + +The regex replacement templates are parsed with code similar to this. + +\begin{code} +type Template = String + +parse_tpl_ :: Template + -> Match String + -> Location + -> Capture String + -> Maybe String +parse_tpl_ tpl mtch _ _ = + Just $ replaceAllCaptures' TOP phi $ + tpl *=~ [re|\$${arg}(\$|[0-9]+|\{${name}([^{}]+)\})|] + where + phi t_mtch _ _ = case captureMaybe [cp|name|] t_mtch of + Just cap -> this $ CID_name $ CaptureName txt + where + txt = T.pack $ capturedText cap + Nothing -> case t == "$" of + True -> Just t + False -> this $ CID_ordinal $ CaptureOrdinal $ read t + where + t = capturedText $ capture [cp|arg|] t_mtch + + this cid = capturedText <$> captureMaybe cid mtch + +my_replace :: RE -> Template-> String -> String +my_replace rex tpl src = replaceAllCaptures' TOP (parse_tpl_ tpl) $ src *=~ rex +\end{code} + +It can be tested with our date-reformater example. + +\begin{code} +date_reformat :: String -> String +date_reformat = my_replace [re|${y}([0-9]{4})-${m}([0-9]{2})-${d}([0-9]{2})|] "${y}/${m}/${d}" +\end{code} + +This should yield `"2016/01/11"`: + +\begin{code} +evalme_TPL_00 = checkThis "evalme_TPL_00" "2016/01/11" $ + date_reformat "2016-01-11" +\end{code} + +See [Text.RE.Replace](Replace.html) + + +Example: include preprocessor +----------------------------- + +The 'include' preprocessor for extracting literate programming fragments +(used in this and most of the other sections of the tutorial) has been +lifted out of the main preprocessor into its own example. + +Here is sed script that makes up the main loop. + +%include "examples/re-include.lhs" "loop ::" + +The `extract` action takes the path to the file containing the fragment +and the RE that will match a line in the fragment and returns the text +of the fragment (wrapped in a simple styling div). + +%include "examples/re-include.lhs" "extract ::" + +And here is the scanner for recognising the literate fragments. + +%include "examples/re-include.lhs" "scan ::" + +See [examples/re-include.lhs](re-include.html) + + +Example: literate preprocessor +------------------------------ + +The preprocessor that converts this literate Haskell program into a web +page and a test suite that makes plenty of use of regex is in +[examples/re-pp.lhs](re-pp.html). + + +Example: gen-modules +-------------------- + +The many TDFA and PCRE API modules (but _not_ the `RE` modules) are all +generated from `Text.RE.TDFA.ByteString.Lazy` with +[examples/re-gen-modules.lhs](re-gen-modules.html) which is also an +application of regex. + + +\begin{code} +main :: IO () +main = runTests + [ evalme_TPL_00 + , evalme_PMC_00 + , evalme_REU_01 + , evalme_OPT_01 + , evalme_OPT_00 + , evalme_MAC_00 + , evalme_RPF_02 + , evalme_RPF_01 + , evalme_SOP_06 + , evalme_SOP_05 + , evalme_SOP_04 + , evalme_SOP_03 + , evalme_SOP_02 + , evalme_SOP_01 + , evalme_RPL_02 + , evalme_RPL_01 + , evalme_MLT_03 + , evalme_MLT_02 + , evalme_MLT_01 + , evalme_SGL_02 + , evalme_SGL_01 + , evalme_TRD_04 + , evalme_TRD_02 + , evalme_TRD_01 + , evalme_TRD_00 + , evalme_LOA_00 + ] +\end{code} + diff --git a/regex.cabal b/regex.cabal new file mode 100644 --- /dev/null +++ b/regex.cabal @@ -0,0 +1,317 @@ +Name: regex +Version: 0.0.0.1 +Synopsis: A Regular Expression Toolkit for regex-base +Description: A Regular Expression Toolkit for regex-base with + Compile-time checking of RE syntax, data types for + matches and captures, a text replacement toolkit, + portable options, high-level Awk-like tools + for building text processing apps, regular expression + macros and test bench, a tutorial and copious examples. +Homepage: https://iconnect.github.io/regex +Author: Chris Dornan +License: BSD3 +license-file: LICENSE +Maintainer: chris.dornan@irisconnect.co.uk +Copyright: Chris Dornan +Category: Text +Build-type: Simple +Stability: rfc +Extra-source-files: changelog +bug-reports: https://github.com/iconnect/regex/issues + +Cabal-version: >= 1.14 + +Source-repository head + type: git + location: git://github.com/iconnect/regex.git + +Source-Repository this + Type: git + Location: git://github.com/iconnect/regex.git + Tag: 0.0.0.1 + +Library + Exposed-modules: + Text.RE + Text.RE.Capture + Text.RE.CaptureID + Text.RE.Edit + Text.RE.Internal.NamedCaptures + Text.RE.IsRegex + Text.RE.LineNo + Text.RE.Options + Text.RE.Parsers + Text.RE.PCRE + Text.RE.PCRE.ByteString + Text.RE.PCRE.ByteString.Lazy + Text.RE.PCRE.RE + Text.RE.PCRE.Sequence + Text.RE.PCRE.String + Text.RE.Replace + Text.RE.TDFA + Text.RE.TDFA.ByteString + Text.RE.TDFA.ByteString.Lazy + Text.RE.TDFA.RE + Text.RE.TDFA.Sequence + Text.RE.TDFA.String + Text.RE.TDFA.Text + Text.RE.TDFA.Text.Lazy + Text.RE.TestBench + Text.RE.Tools.Grep + Text.RE.Tools.Lex + Text.RE.Tools.Sed + + Other-modules: + Text.RE.Internal.AddCaptureNames + Text.RE.Internal.PreludeMacros + Text.RE.Internal.QQ + + Build-depends: + array >= 0.4 , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + containers >= 0.4 , + hashable >= 1.2.3.3 , + heredoc >= 0.2.0.0 , + hsyslog >= 2 , + regex-base >= 0.93.2 , + regex-tdfa >= 1.2.1 , + regex-tdfa-text >= 1.0.0.3 , + regex-pcre-builtin >= 0.94.4.8.8.35 , + smallcheck >= 1.1.1 , + tasty >= 0.10.1.2 , + tasty-hunit >= 0.9.2 , + tasty-smallcheck >= 0.8.1 , + template-haskell >= 2.7 , + transformers >= 0.2.2 , + text >= 1.2.1.3 , + time >= 1.5.0.1 , + unordered-containers >= 0.2.5.1 + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + +Executable re-gen-modules + Hs-Source-Dirs: examples + + Main-is: re-gen-modules.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Build-depends: + regex , + array >= 0.4 , + bytestring >= 0.10.2.0 , + base >= 4 , + directory >= 1.2.1.0 , + regex-base >= 0.93.2 , + regex-tdfa >= 1.2.0 , + shelly >= 1.6.3.4 , + text >= 1.2.1.3 + + +Executable re-include + Hs-Source-Dirs: examples + + Main-is: re-include.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Build-depends: + regex , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + shelly >= 1.6.3.4 , + text >= 1.2.1.3 + + +Test-Suite re-include-test + type: exitcode-stdio-1.0 + Hs-Source-Dirs: examples + + Main-is: re-include.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Build-depends: + regex , + bytestring >= 0.10.2.0 , + base >= 4 , + shelly >= 1.6.3.4 , + text >= 1.2.1.3 + + +Test-Suite re-gen-modules-test + type: exitcode-stdio-1.0 + Hs-Source-Dirs: examples + + Main-is: re-gen-modules.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Build-depends: + regex , + array >= 0.4 , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + directory >= 1.2.1.0 , + regex-base >= 0.93.2 , + regex-tdfa >= 1.2.0 , + shelly >= 1.6.3.4 , + text >= 1.2.1.3 + + +Test-Suite re-nginx-log-processor + type: exitcode-stdio-1.0 + Hs-Source-Dirs: examples + + Main-is: re-nginx-log-processor.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Build-depends: + regex , + array >= 0.4 , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + directory >= 1.2.1.0 , + hsyslog >= 2.0 , + regex-base >= 0.93.2 , + regex-tdfa >= 1.2.0 , + shelly >= 1.6.3.4 , + text >= 1.2.1.3 , + time >= 1.5.0.1 , + transformers >= 0.3.0.0 , + unordered-containers >= 0.2.5.1 + + +Executable re-pp + Hs-Source-Dirs: examples + + Main-is: re-pp.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Other-modules: + TestKit + + Build-depends: + regex , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + directory >= 1.2.1.0 , + shelly >= 1.6.3.4 , + text >= 1.2.1.3 + + +Test-Suite re-pp-test + type: exitcode-stdio-1.0 + Hs-Source-Dirs: examples + + Main-is: re-pp.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Other-modules: + TestKit + + Build-depends: + regex , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + directory >= 1.2.1.0 , + shelly >= 1.6.3.4 , + text >= 1.2.1.3 + + +Test-Suite re-tests + type: exitcode-stdio-1.0 + Hs-Source-Dirs: examples + + Main-is: re-tests.lhs + + Default-Language: Haskell2010 + GHC-Options: + -Wall + -fwarn-tabs + + Other-modules: + TestKit + + Build-depends: + regex , + array >= 0.4 , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + containers >= 0.4 , + regex-base >= 0.93.2 , + regex-tdfa >= 1.2.0 , + regex-tdfa-text >= 1.0.0.3 , + regex-pcre-builtin >= 0.94.4.8.8.35 , + tasty >= 0.10.1.2 , + tasty-hunit >= 0.9.2 , + text >= 1.2.1.3 + + +Test-Suite re-tutorial + type: exitcode-stdio-1.0 + Hs-Source-Dirs: examples . + + Main-is: re-tutorial.lhs + + Other-modules: + TestKit + + Default-Language: Haskell2010 + Default-Extensions: QuasiQuotes + GHC-Options: + -Wall + -fwarn-tabs + + Build-depends: + regex , + array >= 0.4 , + bytestring >= 0.10.2.0 , + base >= 4 && < 5 , + containers >= 0.4 , + hashable >= 1.2.3.3 , + heredoc >= 0.2.0.0 , + hsyslog >= 2 , + regex-base >= 0.93.2 , + regex-tdfa >= 1.2.1 , + regex-tdfa-text >= 1.0.0.3 , + regex-pcre-builtin >= 0.94.4.8.8.35 , + shelly >= 1.6.3.4 , + smallcheck >= 1.1.1 , + tasty >= 0.10.1.2 , + tasty-hunit >= 0.9.2 , + tasty-smallcheck >= 0.8.1 , + template-haskell >= 2.7 , + transformers >= 0.2.2 , + text >= 1.2.1.3 , + time >= 1.5.0.1 , + unordered-containers >= 0.2.5.1