57 lines
1.9 KiB
Haskell
57 lines
1.9 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
|
|
module Data.Text.ICU.Extras (
|
|
match,
|
|
findAndReplace
|
|
) where
|
|
|
|
import Control.Applicative ((<$>), (*>), (<*>), (<|>))
|
|
import Control.Monad ((<=<))
|
|
import Control.Error (hush)
|
|
import Data.Attoparsec.Text (Parser, char, digit, takeWhile1, string, many', parseOnly)
|
|
import Data.Functor.Infix ((<$$>), (<&>))
|
|
import Data.Maybe (isJust, fromJust)
|
|
import Data.Monoid (Monoid(mappend,mconcat))
|
|
import Data.Text (Text)
|
|
import Data.Text.ICU (regex', find, group, Match)
|
|
|
|
match :: Text -> Maybe (Text -> Bool)
|
|
match = isJust <$$> find <$$> hush . regex' []
|
|
|
|
findAndReplace :: Text -> Text -> Maybe (Text -> Maybe Text)
|
|
findAndReplace pattern replacement = do
|
|
findAnd <- find <$$> hush $ regex' [] pattern
|
|
replace <- flip runReplacement <$> parseReplacement replacement
|
|
return $ replace <=< findAnd
|
|
|
|
type Replacement = [Segment]
|
|
|
|
data Segment = Reference Int | Literal Text deriving (Show)
|
|
|
|
parseReference :: Parser Segment
|
|
parseReference = char '$' *> digit <&> Reference . read . return
|
|
|
|
parseLiteral :: Parser Segment
|
|
parseLiteral = Literal <$> takeWhile1 (/= '$')
|
|
|
|
parseLiteralWithPrecedingDollar :: Parser Segment
|
|
parseLiteralWithPrecedingDollar = Literal <$$> mappend <$> string "$" <*> takeWhile1 (/= '$')
|
|
|
|
parseSegment :: Parser Segment
|
|
parseSegment = parseLiteral <|> parseReference <|> parseLiteralWithPrecedingDollar
|
|
|
|
parseReplacement :: Text -> Maybe Replacement
|
|
parseReplacement = hush . parseOnly (many' parseSegment)
|
|
|
|
runReplacement :: Match -> Replacement -> Maybe Text
|
|
runReplacement (flip group -> group) = mconcat <$$> invert . map dereference
|
|
where dereference = \case
|
|
Reference n -> group n
|
|
Literal str -> Just str
|
|
invert xs = if all isJust xs
|
|
then Just $ fromJust <$> xs
|
|
else Nothing
|