Regex.hs

{-# 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'{
    _reString        :: BS.ByteString
  , _reCaseSensitive :: Bool
  , _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 RE {reString, reCaseSensitive} <- RE' reString reCaseSensitive _ where
  RE str caseSensitive = RE' str caseSensitive (compileRegex caseSensitive str)

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

instance Show RE where
  showsPrec d (RE str caseSensitive) = showParen (d > 10) 
    $ showString "RE {reString = " 
    . showsPrec 11 str
    . showString ", reCaseSensitive = "
    . showsPrec 11 caseSensitive
    . showString "}"

instance Read RE where
  readPrec = parens . prec 10 $ do
    Ident "RE" <- lexP
    Punc "{" <- lexP
    Ident "reString" <- lexP
    Punc "=" <- lexP
    str <- readPrec
    Punc "," <- lexP
    Ident "reCaseSensitive" <- lexP
    Punc "=" <- lexP
    caseSensitive <- readPrec
    Punc "}" <- lexP
    pure (RE str caseSensitive)

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

instance Eq RE where
  x == y = toComparisonKey x == toComparisonKey y

instance Ord RE where
  x `compare` y = toComparisonKey x `compare` toComparisonKey y

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

instance Data RE where
  gfoldl k z (RE s c) = z RE `k` s `k` c
  gunfold k z _ = k (k (z RE))
  toConstr _ = conRE
  dataTypeOf _ = tyRE

instance Binary RE where
  put (RE x y) = put x >> put y
  get = RE <$> get <*> get

instance ToJSON RE where
  toJSON re = object [ "reString"        .= encodeToText (reString re)
                     , "reCaseSensitive" .= reCaseSensitive re ]
instance FromJSON RE where
  parseJSON = withObject "RE" $ \v ->
    RE <$> ((v .: "reString") >>= decodeFromText)
       <*> v .: "reCaseSensitive"

-- functions to marshall bytestrings to text

encodeToText :: BS.ByteString -> Text.Text
encodeToText = TE.decodeUtf8 . Base64.encode

decodeFromText :: (Monad m, MonadFail m) => Text.Text -> m BS.ByteString
decodeFromText = either fail return . Base64.decode . TE.encodeUtf8

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