{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Skylighting.Regex (
                Regex(..)
              , RE
              , pattern RE, reCaseSensitive, reMinimal, reString
              , compileRE
              , compileRegex
              , matchRegex
              , matchRegexWithGroups
              , testRegex
              , isWordChar
              ) where

import Data.Aeson
import Data.Binary (Binary(..))
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as BS
import Data.Data
import qualified Data.IntMap.Strict as M
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Regex.KDE

import Text.Read hiding (get)

-- | A representation of a regular expression.
data RE = RE'{
    RE -> ByteString
_reString        :: BS.ByteString
  , RE -> Bool
_reCaseSensitive :: Bool
  , RE -> Bool
_reMinimal       :: Bool
  , RE -> Either String (Regex, IntMap Regex)
_reCompiled      :: Either String (Regex, M.IntMap Regex)
} deriving Typeable

-- We define a smart constructor which also holds the compiled regex
-- and its capturing groups, to avoid recomputing them each time we
-- tokenize.

{-# COMPLETE RE #-}
pattern RE :: BS.ByteString -> Bool -> Bool -> RE
pattern $bRE :: ByteString -> Bool -> Bool -> RE
$mRE :: forall {r}.
RE -> (ByteString -> Bool -> Bool -> r) -> ((# #) -> r) -> r
RE {RE -> ByteString
reString, RE -> Bool
reCaseSensitive, RE -> Bool
reMinimal} <-
  RE' reString reCaseSensitive reMinimal _ where
  RE ByteString
str Bool
caseSensitive Bool
minimal =
    ByteString
-> Bool -> Bool -> Either String (Regex, IntMap Regex) -> RE
RE' ByteString
str Bool
caseSensitive Bool
minimal
        ((Regex -> (Regex, IntMap Regex))
-> Either String Regex -> Either String (Regex, IntMap Regex)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Regex
r -> (Regex
r, Regex -> IntMap Regex
extractCapturingGroups Regex
r))
              (Bool -> Bool -> ByteString -> Either String Regex
compileRegex Bool
caseSensitive Bool
minimal ByteString
str))

-- Unfortunately this means we need to derive all the instances ourselves.

instance Show RE where
  showsPrec :: Int -> RE -> ShowS
showsPrec Int
d (RE ByteString
str Bool
caseSensitive Bool
minimal) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"RE {reString = "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ByteString
str
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", reCaseSensitive = "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Bool
caseSensitive
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", reMinimal = "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Bool
minimal
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"

instance Read RE where
  readPrec :: ReadPrec RE
readPrec = ReadPrec RE -> ReadPrec RE
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec RE -> ReadPrec RE)
-> (ReadPrec RE -> ReadPrec RE) -> ReadPrec RE -> ReadPrec RE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReadPrec RE -> ReadPrec RE
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
10 (ReadPrec RE -> ReadPrec RE) -> ReadPrec RE -> ReadPrec RE
forall a b. (a -> b) -> a -> b
$ do
    Ident "RE" <- ReadPrec Lexeme
lexP
    Punc "{" <- lexP
    Ident "reString" <- lexP
    Punc "=" <- lexP
    str <- readPrec
    Punc "," <- lexP
    Ident "reCaseSensitive" <- lexP
    Punc "=" <- lexP
    caseSensitive <- readPrec
    Punc "," <- lexP
    Ident "reMinimal" <- lexP
    Punc "=" <- lexP
    minimal <- readPrec
    Punc "}" <- lexP
    pure (RE str caseSensitive minimal)

toComparisonKey :: RE -> (BS.ByteString, Bool, Bool)
toComparisonKey :: RE -> (ByteString, Bool, Bool)
toComparisonKey (RE ByteString
x Bool
y Bool
z) = (ByteString
x, Bool
y, Bool
z)

instance Eq RE where
  RE
x == :: RE -> RE -> Bool
== RE
y = RE -> (ByteString, Bool, Bool)
toComparisonKey RE
x (ByteString, Bool, Bool) -> (ByteString, Bool, Bool) -> Bool
forall a. Eq a => a -> a -> Bool
== RE -> (ByteString, Bool, Bool)
toComparisonKey RE
y

instance Ord RE where
  RE
x compare :: RE -> RE -> Ordering
`compare` RE
y = RE -> (ByteString, Bool, Bool)
toComparisonKey RE
x (ByteString, Bool, Bool) -> (ByteString, Bool, Bool) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` RE -> (ByteString, Bool, Bool)
toComparisonKey RE
y

conRE :: Constr
conRE :: Constr
conRE = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
tyRE String
"RE" [] Fixity
Prefix
tyRE :: DataType
tyRE :: DataType
tyRE   = String -> [Constr] -> DataType
mkDataType String
"Skylighting.Regex.RE" [Constr
conRE]

instance Data RE where
  gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RE -> c RE
gfoldl forall d b. Data d => c (d -> b) -> d -> c b
k forall g. g -> c g
z (RE ByteString
s Bool
c Bool
m) = (ByteString -> Bool -> Bool -> RE)
-> c (ByteString -> Bool -> Bool -> RE)
forall g. g -> c g
z ByteString -> Bool -> Bool -> RE
RE c (ByteString -> Bool -> Bool -> RE)
-> ByteString -> c (Bool -> Bool -> RE)
forall d b. Data d => c (d -> b) -> d -> c b
`k` ByteString
s c (Bool -> Bool -> RE) -> Bool -> c (Bool -> RE)
forall d b. Data d => c (d -> b) -> d -> c b
`k` Bool
c c (Bool -> RE) -> Bool -> c RE
forall d b. Data d => c (d -> b) -> d -> c b
`k` Bool
m
  gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RE
gunfold forall b r. Data b => c (b -> r) -> c r
k forall r. r -> c r
z Constr
_ = c (Bool -> RE) -> c RE
forall b r. Data b => c (b -> r) -> c r
k (c (Bool -> Bool -> RE) -> c (Bool -> RE)
forall b r. Data b => c (b -> r) -> c r
k (c (ByteString -> Bool -> Bool -> RE) -> c (Bool -> Bool -> RE)
forall b r. Data b => c (b -> r) -> c r
k ((ByteString -> Bool -> Bool -> RE)
-> c (ByteString -> Bool -> Bool -> RE)
forall r. r -> c r
z ByteString -> Bool -> Bool -> RE
RE)))
  toConstr :: RE -> Constr
toConstr RE
_ = Constr
conRE
  dataTypeOf :: RE -> DataType
dataTypeOf RE
_ = DataType
tyRE

instance Binary RE where
  put :: RE -> Put
put (RE ByteString
x Bool
y Bool
z) = ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Put
forall t. Binary t => t -> Put
put Bool
y Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Put
forall t. Binary t => t -> Put
put Bool
z
  get :: Get RE
get = ByteString -> Bool -> Bool -> RE
RE (ByteString -> Bool -> Bool -> RE)
-> Get ByteString -> Get (Bool -> Bool -> RE)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Binary t => Get t
get Get (Bool -> Bool -> RE) -> Get Bool -> Get (Bool -> RE)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Bool
forall t. Binary t => Get t
get Get (Bool -> RE) -> Get Bool -> Get RE
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Bool
forall t. Binary t => Get t
get

instance ToJSON RE where
  toJSON :: RE -> Value
toJSON RE
re = [Pair] -> Value
object [ Key
"reString"        Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
encodeToText (RE -> ByteString
reString RE
re)
                     , Key
"reCaseSensitive" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RE -> Bool
reCaseSensitive RE
re
                     , Key
"reMinimal"       Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RE -> Bool
reMinimal RE
re ]
instance FromJSON RE where
  parseJSON :: Value -> Parser RE
parseJSON = String -> (Object -> Parser RE) -> Value -> Parser RE
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RE" ((Object -> Parser RE) -> Value -> Parser RE)
-> (Object -> Parser RE) -> Value -> Parser RE
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    ByteString -> Bool -> Bool -> RE
RE (ByteString -> Bool -> Bool -> RE)
-> Parser ByteString -> Parser (Bool -> Bool -> RE)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reString") Parser Text -> (Text -> Parser ByteString) -> Parser ByteString
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Parser ByteString
forall (m :: * -> *).
(Monad m, MonadFail m) =>
Text -> m ByteString
decodeFromText)
       Parser (Bool -> Bool -> RE) -> Parser Bool -> Parser (Bool -> RE)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reCaseSensitive"
       Parser (Bool -> RE) -> Parser Bool -> Parser RE
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"reMinimal" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False

-- functions to marshall bytestrings to text

encodeToText :: BS.ByteString -> Text.Text
encodeToText :: ByteString -> Text
encodeToText = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode

decodeFromText :: (Monad m, MonadFail m) => Text.Text -> m BS.ByteString
decodeFromText :: forall (m :: * -> *).
(Monad m, MonadFail m) =>
Text -> m ByteString
decodeFromText = (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> m ByteString)
-> (Text -> Either String ByteString) -> Text -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base64.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8

-- | The compiled regex and its capturing groups (cached in the
-- 'RE' by the smart constructor).
compileRE :: RE -> Either String (Regex, M.IntMap Regex)
compileRE :: RE -> Either String (Regex, IntMap Regex)
compileRE = RE -> Either String (Regex, IntMap Regex)
_reCompiled