{-# LANGUAGE CPP, DeriveDataTypeable #-}

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Unsafe #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.CaseInsensitive.Internal
-- Copyright   :  (c) 2011-2013 Bas van Dijk
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>
--
-- Internal module which exports the 'CI' type, constructor,
-- associated instances and the 'FoldCase' class and instances.
--
-----------------------------------------------------------------------------

module Data.CaseInsensitive.Internal ( CI
                                     , mk
                                     , unsafeMk
                                     , original
                                     , foldedCase
                                     , map
                                     , traverse
                                     , FoldCase(foldCase)
                                     ) where

--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from base:
import Control.Applicative (Applicative)
import Data.Bool      ( (||) )
import Data.Char      ( Char, toLower )
import Data.Eq        ( Eq, (==) )
import Data.Function  ( on )
import Data.Monoid    ( Monoid, mempty, mappend )
import Data.Ord       ( Ord, compare )
import Data.String    ( IsString, fromString )
import Data.Data      ( Data )
import Data.Typeable  ( Typeable )
import Data.Word      ( Word8 )
import Prelude        ( (.), fmap, (&&), (+), (<=), otherwise )
import Text.Read      ( Read, readPrec )
import Text.Show      ( Show, showsPrec )
import Data.Semigroup ( Semigroup, (<>) )

import qualified Data.List as L ( map )

#if __GLASGOW_HASKELL__ < 700
import Control.Monad ( (>>) )
import Prelude       ( fromInteger )
#endif

-- from bytestring:
import qualified Data.ByteString      as B  ( ByteString, map )
import qualified Data.ByteString.Lazy as BL ( ByteString, map )

-- from text:
import qualified Data.Text      as T  ( Text, toCaseFold )
import qualified Data.Text.Lazy as TL ( Text, toCaseFold, pack, unpack )

-- from deepseq:
import Control.DeepSeq ( NFData, rnf, deepseq )

-- from hashable:
import Data.Hashable ( Hashable, hashWithSalt )


--------------------------------------------------------------------------------
-- Case Insensitive Strings
--------------------------------------------------------------------------------

{-| A @CI s@ provides /C/ase /I/nsensitive comparison for the string-like type
@s@ (for example: 'String', 'T.Text', 'B.ByteString', etc.).

Note that @CI s@ has an instance for 'IsString' which together with the
@OverloadedStrings@ language extension allows you to write case insensitive
string literals as in:

@
\> (\"Content-Type\" :: 'CI' 'T.Text') == (\"CONTENT-TYPE\" :: 'CI' 'T.Text')
True
@

-}
data CI s = CI { forall s. CI s -> s
original   :: !s -- ^ Retrieve the original string-like value.
               , forall s. CI s -> s
foldedCase :: !s -- ^ Retrieve the case folded string-like value.
                                  --   (Also see 'foldCase').
               }
          deriving (Typeable (CI s)
Typeable (CI s) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> CI s -> c (CI s))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (CI s))
-> (CI s -> Constr)
-> (CI s -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (CI s)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (CI s)))
-> ((forall b. Data b => b -> b) -> CI s -> CI s)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r)
-> (forall u. (forall d. Data d => d -> u) -> CI s -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> CI s -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> CI s -> m (CI s))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CI s -> m (CI s))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CI s -> m (CI s))
-> Data (CI s)
CI s -> Constr
CI s -> DataType
(forall b. Data b => b -> b) -> CI s -> CI s
forall s. Data s => Typeable (CI s)
forall s. Data s => CI s -> Constr
forall s. Data s => CI s -> DataType
forall s. Data s => (forall b. Data b => b -> b) -> CI s -> CI s
forall s u.
Data s =>
Int -> (forall d. Data d => d -> u) -> CI s -> u
forall s u. Data s => (forall d. Data d => d -> u) -> CI s -> [u]
forall s r r'.
Data s =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
forall s r r'.
Data s =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
forall s (m :: * -> *).
(Data s, Monad m) =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
forall s (m :: * -> *).
(Data s, MonadPlus m) =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
forall s (c :: * -> *).
Data s =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (CI s)
forall s (c :: * -> *).
Data s =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CI s -> c (CI s)
forall s (t :: * -> *) (c :: * -> *).
(Data s, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (CI s))
forall s (t :: * -> * -> *) (c :: * -> *).
(Data s, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (CI s))
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CI s -> u
forall u. (forall d. Data d => d -> u) -> CI s -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (CI s)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CI s -> c (CI s)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (CI s))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (CI s))
$cgfoldl :: forall s (c :: * -> *).
Data s =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CI s -> c (CI s)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CI s -> c (CI s)
$cgunfold :: forall s (c :: * -> *).
Data s =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (CI s)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (CI s)
$ctoConstr :: forall s. Data s => CI s -> Constr
toConstr :: CI s -> Constr
$cdataTypeOf :: forall s. Data s => CI s -> DataType
dataTypeOf :: CI s -> DataType
$cdataCast1 :: forall s (t :: * -> *) (c :: * -> *).
(Data s, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (CI s))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (CI s))
$cdataCast2 :: forall s (t :: * -> * -> *) (c :: * -> *).
(Data s, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (CI s))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (CI s))
$cgmapT :: forall s. Data s => (forall b. Data b => b -> b) -> CI s -> CI s
gmapT :: (forall b. Data b => b -> b) -> CI s -> CI s
$cgmapQl :: forall s r r'.
Data s =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
$cgmapQr :: forall s r r'.
Data s =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> CI s -> r
$cgmapQ :: forall s u. Data s => (forall d. Data d => d -> u) -> CI s -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> CI s -> [u]
$cgmapQi :: forall s u.
Data s =>
Int -> (forall d. Data d => d -> u) -> CI s -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CI s -> u
$cgmapM :: forall s (m :: * -> *).
(Data s, Monad m) =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
$cgmapMp :: forall s (m :: * -> *).
(Data s, MonadPlus m) =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
$cgmapMo :: forall s (m :: * -> *).
(Data s, MonadPlus m) =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CI s -> m (CI s)
Data, Typeable)

-- | Make the given string-like value case insensitive.
mk :: FoldCase s => s -> CI s
mk :: forall s. FoldCase s => s -> CI s
mk s
s = s -> s -> CI s
forall s. s -> s -> CI s
CI s
s (s -> s
forall s. FoldCase s => s -> s
foldCase s
s)

-- | Constructs a 'CI' from an already case folded string-like
-- value. The given string is used both as the 'original' as well as
-- the 'foldedCase'.
--
-- This function is unsafe since the compiler can't guarantee that the
-- provided string is case folded.
unsafeMk :: FoldCase s => s -> CI s
unsafeMk :: forall s. FoldCase s => s -> CI s
unsafeMk s
s = s -> s -> CI s
forall s. s -> s -> CI s
CI s
s s
s

-- | Transform the original string-like value but keep it case insensitive.
map :: FoldCase s2 => (s1 -> s2) -> (CI s1 -> CI s2)
map :: forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
map s1 -> s2
f = s2 -> CI s2
forall s. FoldCase s => s -> CI s
mk (s2 -> CI s2) -> (CI s1 -> s2) -> CI s1 -> CI s2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s1 -> s2
f (s1 -> s2) -> (CI s1 -> s1) -> CI s1 -> s2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI s1 -> s1
forall s. CI s -> s
original

-- | Transform the original string-like value but keep it case insensitive.
traverse :: (FoldCase s2, Applicative f) => (s1 -> f s2) -> CI s1 -> f (CI s2)
traverse :: forall s2 (f :: * -> *) s1.
(FoldCase s2, Applicative f) =>
(s1 -> f s2) -> CI s1 -> f (CI s2)
traverse s1 -> f s2
f = (s2 -> CI s2) -> f s2 -> f (CI s2)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s2 -> CI s2
forall s. FoldCase s => s -> CI s
mk (f s2 -> f (CI s2)) -> (CI s1 -> f s2) -> CI s1 -> f (CI s2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s1 -> f s2
f (s1 -> f s2) -> (CI s1 -> s1) -> CI s1 -> f s2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI s1 -> s1
forall s. CI s -> s
original

instance (IsString s, FoldCase s) => IsString (CI s) where
    fromString :: String -> CI s
fromString = s -> CI s
forall s. FoldCase s => s -> CI s
mk (s -> CI s) -> (String -> s) -> String -> CI s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> s
forall a. IsString a => String -> a
fromString

instance Semigroup s => Semigroup (CI s) where
    CI s
o1 s
l1 <> :: CI s -> CI s -> CI s
<> CI s
o2 s
l2 = s -> s -> CI s
forall s. s -> s -> CI s
CI (s
o1 s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
o2) (s
l1 s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
l2)

instance Monoid s => Monoid (CI s) where
    mempty :: CI s
mempty = s -> s -> CI s
forall s. s -> s -> CI s
CI s
forall a. Monoid a => a
mempty s
forall a. Monoid a => a
mempty
    CI s
o1 s
l1 mappend :: CI s -> CI s -> CI s
`mappend` CI s
o2 s
l2 = s -> s -> CI s
forall s. s -> s -> CI s
CI (s
o1 s -> s -> s
forall a. Monoid a => a -> a -> a
`mappend` s
o2) (s
l1 s -> s -> s
forall a. Monoid a => a -> a -> a
`mappend` s
l2)

instance Eq s => Eq (CI s) where
    == :: CI s -> CI s -> Bool
(==) = s -> s -> Bool
forall a. Eq a => a -> a -> Bool
(==) (s -> s -> Bool) -> (CI s -> s) -> CI s -> CI s -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` CI s -> s
forall s. CI s -> s
foldedCase

instance Ord s => Ord (CI s) where
    compare :: CI s -> CI s -> Ordering
compare = s -> s -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (s -> s -> Ordering) -> (CI s -> s) -> CI s -> CI s -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` CI s -> s
forall s. CI s -> s
foldedCase

instance (Read s, FoldCase s) => Read (CI s) where
    readPrec :: ReadPrec (CI s)
readPrec = (s -> CI s) -> ReadPrec s -> ReadPrec (CI s)
forall a b. (a -> b) -> ReadPrec a -> ReadPrec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> CI s
forall s. FoldCase s => s -> CI s
mk ReadPrec s
forall a. Read a => ReadPrec a
readPrec

instance Show s => Show (CI s) where
    showsPrec :: Int -> CI s -> ShowS
showsPrec Int
prec = Int -> s -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
prec (s -> ShowS) -> (CI s -> s) -> CI s -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI s -> s
forall s. CI s -> s
original

instance Hashable s => Hashable (CI s) where
    hashWithSalt :: Int -> CI s -> Int
hashWithSalt Int
salt = Int -> s -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (s -> Int) -> (CI s -> s) -> CI s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI s -> s
forall s. CI s -> s
foldedCase

instance NFData s => NFData (CI s) where
    rnf :: CI s -> ()
rnf (CI s
o s
f) = s
o s -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` s
f s -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

--------------------------------------------------------------------------------
-- Folding (lowering) cases
--------------------------------------------------------------------------------

-- | Class of string-like types that support folding cases.
--
-- /Note/: In some languages, case conversion is a locale- and context-dependent
-- operation. The @foldCase@ method is /not/ intended to be locale sensitive.
-- Programs that require locale sensitivity should use appropriate versions of
-- the case mapping functions from the @text-icu@ package:
-- <http://hackage.haskell.org/package/text-icu>
class FoldCase s where
    foldCase :: s -> s

    foldCaseList :: [s] -> [s]
    foldCaseList = (s -> s) -> [s] -> [s]
forall a b. (a -> b) -> [a] -> [b]
L.map s -> s
forall s. FoldCase s => s -> s
foldCase

instance FoldCase a => FoldCase [a] where
    foldCase :: [a] -> [a]
foldCase = [a] -> [a]
forall a. FoldCase a => [a] -> [a]
foldCaseList

-- | Note that @foldCase@ on @'B.ByteString's@ is only guaranteed to be correct for ISO-8859-1 encoded strings!
instance FoldCase B.ByteString where foldCase :: ByteString -> ByteString
foldCase = (Word8 -> Word8) -> ByteString -> ByteString
B.map Word8 -> Word8
toLower8

-- | Note that @foldCase@ on @'BL.ByteString's@ is only guaranteed to be correct for ISO-8859-1 encoded strings!
instance FoldCase BL.ByteString where foldCase :: ByteString -> ByteString
foldCase = (Word8 -> Word8) -> ByteString -> ByteString
BL.map Word8 -> Word8
toLower8

instance FoldCase Char where
    foldCase :: Char -> Char
foldCase     = Char -> Char
toLower
    foldCaseList :: ShowS
foldCaseList = Text -> String
TL.unpack (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toCaseFold (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

instance FoldCase T.Text  where foldCase :: Text -> Text
foldCase = Text -> Text
T.toCaseFold
instance FoldCase TL.Text where foldCase :: Text -> Text
foldCase = Text -> Text
TL.toCaseFold
instance FoldCase (CI s)  where foldCase :: CI s -> CI s
foldCase (CI s
_ s
l) = s -> s -> CI s
forall s. s -> s -> CI s
CI s
l s
l

{-# INLINE toLower8 #-}
toLower8 :: Word8 -> Word8
toLower8 :: Word8 -> Word8
toLower8 Word8
w
  |  Word8
65 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=  Word8
90 Bool -> Bool -> Bool
||
    Word8
192 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
214 Bool -> Bool -> Bool
||
    Word8
216 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
222 = Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
32
  | Bool
otherwise            = Word8
w

--------------------------------------------------------------------------------
-- Rewrite RULES
--------------------------------------------------------------------------------

{-# RULES "foldCase/ByteString" foldCase = foldCaseBS #-}

foldCaseBS :: B.ByteString -> B.ByteString
foldCaseBS :: ByteString -> ByteString
foldCaseBS ByteString
bs = (Word8 -> Word8) -> ByteString -> ByteString
B.map Word8 -> Word8
toLower8' ByteString
bs
    where
      toLower8' :: Word8 -> Word8
      toLower8' :: Word8 -> Word8
toLower8' Word8
w
          |  Word8
65  Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=  Word8
90 Bool -> Bool -> Bool
||
             Word8
192 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
214 Bool -> Bool -> Bool
||
             Word8
216 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
222 = Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
32
          | Bool
otherwise             = Word8
w