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

module Skylighting.Regex (
                Regex(..)
              , RE
              , pattern RE, reCaseSensitive, reString
              , compileRE
              , compileRegex
              , matchRegex
              , 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.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 -> Either String Regex
_reCompiled      :: Either String Regex
} deriving Typeable

-- We define a smart constructor which also holds the compiled regex, to avoid
-- recompiling each time we tokenize.

{-# COMPLETE RE #-}
pattern RE :: BS.ByteString -> Bool  -> RE
pattern $mRE :: forall {r}. RE -> (ByteString -> Bool -> r) -> ((# #) -> r) -> r
$bRE :: ByteString -> Bool -> RE
RE {RE -> ByteString
reString, RE -> Bool
reCaseSensitive} <- RE' reString reCaseSensitive _ where
  RE ByteString
str Bool
caseSensitive = ByteString -> Bool -> Either String Regex -> RE
RE' ByteString
str Bool
caseSensitive (Bool -> ByteString -> Either String Regex
compileRegex Bool
caseSensitive 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 -> 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
"}"

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 String
"RE" <- ReadPrec Lexeme
lexP
    Punc String
"{" <- ReadPrec Lexeme
lexP
    Ident String
"reString" <- ReadPrec Lexeme
lexP
    Punc String
"=" <- ReadPrec Lexeme
lexP
    ByteString
str <- ReadPrec ByteString
forall a. Read a => ReadPrec a
readPrec
    Punc String
"," <- ReadPrec Lexeme
lexP
    Ident String
"reCaseSensitive" <- ReadPrec Lexeme
lexP
    Punc String
"=" <- ReadPrec Lexeme
lexP
    Bool
caseSensitive <- ReadPrec Bool
forall a. Read a => ReadPrec a
readPrec
    Punc String
"}" <- ReadPrec Lexeme
lexP
    RE -> ReadPrec RE
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Bool -> RE
RE ByteString
str Bool
caseSensitive)

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

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

instance Ord RE where
  RE
x compare :: RE -> RE -> Ordering
`compare` RE
y = RE -> (ByteString, Bool)
toComparisonKey RE
x (ByteString, Bool) -> (ByteString, Bool) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` RE -> (ByteString, 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) = (ByteString -> Bool -> RE) -> c (ByteString -> Bool -> RE)
forall g. g -> c g
z ByteString -> Bool -> RE
RE c (ByteString -> Bool -> RE) -> ByteString -> c (Bool -> RE)
forall d b. Data d => c (d -> b) -> d -> c b
`k` ByteString
s c (Bool -> RE) -> Bool -> c RE
forall d b. Data d => c (d -> b) -> d -> c b
`k` Bool
c
  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 (ByteString -> Bool -> RE) -> c (Bool -> RE)
forall b r. Data b => c (b -> r) -> c r
k ((ByteString -> Bool -> RE) -> c (ByteString -> Bool -> RE)
forall r. r -> c r
z ByteString -> 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) = 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
  get :: Get RE
get = ByteString -> Bool -> RE
RE (ByteString -> Bool -> RE) -> Get ByteString -> Get (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 -> 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 ]
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 -> RE
RE (ByteString -> Bool -> RE)
-> Parser ByteString -> Parser (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 -> 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 Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reCaseSensitive"

-- 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

compileRE :: RE -> Either String Regex
compileRE :: RE -> Either String Regex
compileRE = RE -> Either String Regex
_reCompiled