{-# OPTIONS_GHC -fglasgow-exts #-}

import Test.QuickCheck
import Data.Char (ord)
import Control.Monad

import Text.Printf
import Debug.Trace
import System.Environment

import qualified Data.CompactString.UTF8 as C
import qualified Data.List          as L
import Data.CompactString.Encodings

import qualified Data.ByteString as B

import QuickCheckUtils hiding (C)

type C = C.CompactString

------------------------------------------------------------------------
-- Functions not in Data.List

l_headView []     = Nothing
l_headView (x:xs) = Just (x, xs)
l_lastView xs = if L.null xs then Nothing else Just (L.init xs, L.last xs)

l_mapIndexed f = L.zipWith f [0..]

l_spanEnd p = (\(x,y) -> (reverse y, reverse x)) . span p . reverse
l_breakEnd p = l_spanEnd (not . p)

l_findSubstring  pat str = case l_findSubstrings pat str of
                                []     -> Nothing
                                (x:xs) -> Just x
l_findSubstrings pat str = L.map fst $ L.filter snd $ zip [0..] $ L.map (pat `L.isPrefixOf`) (L.tails str)

l_split     c    = l_splitWith (==c)
l_splitWith p [] = []
l_splitWith p xs = sw xs
 where sw xs = case L.break p xs of
            (_ ,[]    ) -> [xs]
            (ys,(_:zs)) -> ys : sw zs

l_count c = L.length . L.filter (==c)

------------------------------------------------------------------------
-- Properties : Internal consistency

prop_validate cs = C.validate cs == Just cs

------------------------------------------------------------------------
-- Properties : Functions not in the prelude

prop_pack   xs = C.unpack (C.pack xs) == xs
prop_unpack cs = C.pack (C.unpack cs) == cs

prop_elemIndexEnd c xs =
        C.elemIndexEnd c xs ==
        (-) (C.length xs - 1) `fmap` C.elemIndex c (C.reverse xs)

prop_findIndexEnd c xs =
        C.findIndexEnd c xs ==
        (-) (C.length xs - 1) `fmap` C.findIndex c (C.reverse xs)


------------------------------------------------------------------------
-- Properties : Comparing with lists

prop_eq         = eq2
        ((==)           :: C -> C -> Bool)
        ((==)           :: S -> S -> Bool)
prop_compare    = eq2
        (compare        :: C -> C -> Ordering)
        (compare        :: S -> S -> Ordering)
prop_show       = eq1
        (show           :: C -> String)
        (show           :: S -> String)

prop_empty      = C.empty       `eq0`           ""
prop_singleton  = C.singleton   `eq1`           (return         :: Char -> S)

prop_cons       = C.cons        `eq2`           ((:)            :: Char -> S -> S)
prop_snoc       = C.snoc        `eq2`           ((\s c -> s ++ [c]) :: S -> Char -> S)
prop_append     = C.append      `eq2`           ((++)           :: S -> S -> S)
prop_head       = C.head        `eqnotnull1`    (L.head         :: S -> Char)
prop_tail       = C.tail        `eqnotnull1`    (L.tail         :: S -> S)
prop_last       = C.last        `eqnotnull1`    (L.last         :: S -> Char)
prop_init       = C.init        `eqnotnull1`    (L.init         :: S -> S)
prop_headView   = C.headView    `eq1`           (l_headView     :: S -> Maybe (Char, S))
prop_lastView   = C.lastView    `eq1`           (l_lastView     :: S -> Maybe (S, Char))
prop_null       = C.null        `eq1`           (L.null         :: S -> Bool)
prop_length     = C.length      `eq1`           (L.length       :: S -> Int)

prop_map        = C.map         `eq2`           (L.map          :: (Char -> Char) -> (S -> S))
prop_reverse    = C.reverse     `eq1`           (L.reverse      :: S -> S)
prop_intersperse= C.intersperse `eq2`           (L.intersperse  :: Char -> S -> S)
prop_transpose  = C.transpose   `eq1`           (L.transpose    :: [S] -> [S])

prop_foldl      = eq3
        (C.foldl        :: (Int -> Char -> Int) -> Int -> C -> Int)
        (L.foldl        :: (Int -> Char -> Int) -> Int -> S -> Int)
prop_foldr      = eq3
        (C.foldr        :: (Char -> Int -> Int) -> Int -> C -> Int)
        (L.foldr        :: (Char -> Int -> Int) -> Int -> S -> Int)
prop_foldl'     = eq3
        (C.foldl'       :: (Int -> Char -> Int) -> Int -> C -> Int)
        (L.foldl'       :: (Int -> Char -> Int) -> Int -> S -> Int)
prop_foldl1     = C.foldl1      `eqnotnull2`    (L.foldl1       :: (Char -> Char -> Char) -> S -> Char)
prop_foldr1     = C.foldr1      `eqnotnull2`    (L.foldr1       :: (Char -> Char -> Char) -> S -> Char)
prop_foldl1'    = C.foldl1'     `eqnotnull2`    (L.foldl1'      :: (Char -> Char -> Char) -> S -> Char)

prop_concat     = C.concat      `eq1`           (L.concat       :: [S] -> S)
prop_concatMap  = C.concatMap   `eq2b`          (L.concatMap    :: (Char -> S) -> S -> S)
prop_any        = C.any         `eq2`           (L.any          :: (Char -> Bool) -> S -> Bool)
prop_all        = C.all         `eq2`           (L.all          :: (Char -> Bool) -> S -> Bool)
prop_maximum    = C.maximum     `eqnotnull1`    (L.maximum      :: S -> Char)
prop_minimum    = C.minimum     `eqnotnull1`    (L.minimum      :: S -> Char)

prop_concatMap2 = c_concatMap2  `eq2b`          (L.concatMap    :: (Char -> S) -> S -> S)
    where c_concatMap2 f = C.concat . L.map (C.validate_ . f) . C.unpack
prop_concatMap3 = c_concatMap3  `eq2`          (L.map    :: (Char -> S) -> S -> [S])
    where
      c_concatMap3 :: (Char -> C) -> C -> [C]
      c_concatMap3 f = L.map f . C.unpack

prop_concatMapFoldr = eq2
        (\f -> C.foldr ((:) . f) [] :: C -> [C])
        (\f -> L.foldr ((:) . f) [] :: S -> [S])

prop_scanl      = C.scanl       `eq3`           (L.scanl        :: (Char -> Char -> Char) -> Char -> S -> S)
prop_scanr      = C.scanr       `eq3`           (L.scanr        :: (Char -> Char -> Char) -> Char -> S -> S)
prop_scanl1     = C.scanl1      `eqnotnull2`    (L.scanl1       :: (Char -> Char -> Char) -> S -> S)
prop_scanr1     = C.scanr1      `eqnotnull2`    (L.scanr1       :: (Char -> Char -> Char) -> S -> S)

prop_mapAccumL  = eq3
        (C.mapAccumL    :: (Int -> Char -> (Int, Char)) -> Int -> C -> (Int, C))
        (L.mapAccumL    :: (Int -> Char -> (Int, Char)) -> Int -> S -> (Int, S))
prop_mapAccumR  = eq3
        (C.mapAccumR    :: (Int -> Char -> (Int, Char)) -> Int -> C -> (Int, C))
        (L.mapAccumR    :: (Int -> Char -> (Int, Char)) -> Int -> S -> (Int, S))
prop_mapIndexed = eq2
        (C.mapIndexed   :: (Int -> Char -> Char) -> C -> C)
        (l_mapIndexed   :: (Int -> Char -> Char) -> S -> S)

prop_replicate          = C.replicate      `eq2`        (L.replicate    :: Int -> Char -> S)
-- note: we have to take a finite length, otherwise we could loop
--       since C.unfoldr is strict this is not possible
--prop_unfoldr  = eq3
--      (\n -> C.take n (C.unfoldr      :: (Int -> Maybe (Char, Int)) -> Int -> C))
--      (\n -> C.take n (L.unfoldr      :: (Int -> Maybe (Char, Int)) -> Int -> S))
prop_unfoldrN   = eq3
        (\n f a -> fst      $ (C.unfoldrN :: Int -> (Int -> Maybe (Char, Int)) -> Int -> (C, Maybe Int)) n f a)
        (\n f a -> L.take n $ (L.unfoldr  ::        (Int -> Maybe (Char, Int)) -> Int ->  S            )   f a)

prop_take               = C.take           `eq2`        (L.take         :: Int -> S -> S)
prop_drop               = C.drop           `eq2`        (L.drop         :: Int -> S -> S)
prop_splitAt            = C.splitAt        `eq2`        (L.splitAt      :: Int -> S -> (S,S))
prop_takeWhile          = C.takeWhile      `eq2`        (L.takeWhile    :: (Char -> Bool) -> S -> S)
prop_dropWhile          = C.dropWhile      `eq2`        (L.dropWhile    :: (Char -> Bool) -> S -> S)
prop_break              = C.break          `eq2`        (L.break        :: (Char -> Bool) -> S -> (S,S))
prop_span               = C.span           `eq2`        (L.span         :: (Char -> Bool) -> S -> (S,S))
prop_breakEnd           = C.breakEnd       `eq2`        (l_breakEnd     :: (Char -> Bool) -> S -> (S,S))
prop_spanEnd            = C.spanEnd        `eq2`        (l_spanEnd      :: (Char -> Bool) -> S -> (S,S))
prop_group              = C.group          `eq1`        (L.group        :: S -> [S])
prop_groupBy            = C.groupBy        `eq2`        (L.groupBy      :: (Char -> Char -> Bool) -> S -> [S])
prop_inits              = C.inits          `eq1`        (L.inits        :: S -> [S])
prop_tails              = C.tails          `eq1`        (L.tails        :: S -> [S])

prop_split              = C.split          `eq2`        (l_split        :: Char          -> S -> [S])
prop_splitWith          = C.splitWith      `eq2`        (l_splitWith    :: (Char -> Bool) ->S -> [S])

prop_lines              = C.lines          `eq1`        (L.lines        :: S -> [S])
prop_unlines            = C.unlines        `eq1`        (L.unlines      :: [S] -> S)
prop_words              = C.words          `eq1`        (L.words        :: S -> [S])
prop_unwords            = C.unwords        `eq1`        (L.unwords      :: [S] -> S)

prop_isPrefixOf         = C.isPrefixOf     `eq2`        (L.isPrefixOf   :: S -> S -> Bool)
prop_isSuffixOf         = C.isSuffixOf     `eq2`        (L.isSuffixOf   :: S -> S -> Bool)
prop_isSubstringOf      = C.isInfixOf      `eq2`        (L.isInfixOf    :: S -> S -> Bool)

prop_findSubstring      = C.findSubstring  `eq2`        (l_findSubstring:: S -> S -> Maybe Int)
prop_findSubstrings     = C.findSubstrings `eq2`        (l_findSubstrings::S -> S -> [Int])

prop_elem               = C.elem           `eq2`        (L.elem         :: Char -> S -> Bool)
prop_notElem            = C.notElem        `eq2`        (L.notElem      :: Char -> S -> Bool)

prop_find               = C.find           `eq2`        (L.find         :: (Char -> Bool) -> S -> Maybe Char)
prop_filter             = C.filter         `eq2`        (L.filter       :: (Char -> Bool) -> S -> S)
prop_partition          = C.partition      `eq2`        (L.partition    :: (Char -> Bool) -> S -> (S,S))

prop_index              = C.index          `eqexcept2`  ((L.!!)         :: S -> Int -> Char)
prop_elemIndex          = C.elemIndex      `eq2`        (L.elemIndex    :: Char -> S -> Maybe Int)
prop_elemIndices        = C.elemIndices    `eq2`        (L.elemIndices  :: Char -> S -> [Int])
prop_findIndex          = C.findIndex      `eq2`        (L.findIndex    :: (Char -> Bool) -> S -> Maybe Int)
prop_findIndices        = C.findIndices    `eq2`        (L.findIndices  :: (Char -> Bool) -> S -> [Int])
prop_count              = C.count          `eq2`        (l_count        :: Char -> S -> Int)

prop_zip                = C.zip            `eq2`        (L.zip          :: S -> S -> [(Char,Char)])
prop_zipWith            = eq3
        (C.zipWith      :: (Char -> Char -> Int) -> C -> C -> [Int])
        (L.zipWith      :: (Char -> Char -> Int) -> S -> S -> [Int])
prop_zipWith'           = C.zipWith'       `eq3`        (L.zipWith      :: (Char -> Char -> Char) -> S -> S -> S)
prop_unzip              = C.unzip          `eq1`        (L.unzip        :: [(Char,Char)] -> (S,S))

prop_sort               = C.sort           `eq1`        (L.sort         :: S -> S)

------------------------------------------------------------------------
-- Properties : Encding

-- "C.fromByteString . C.toByteString = id"
prop_fromToByteString cs = C.fromByteString (C.toByteString cs)  ==  Just cs

-- "decode . encode = id"
prop_de enc = \x -> case C.encode enc x of
        Nothing -> False ==> False
        Just  y -> property $ C.decode enc y == Just x

-- "encode . decode = id"
prop_ed enc = \x -> case C.decode enc x of
        Nothing -> False ==> False
        Just  y -> property $ C.encode enc y == Just x

-- "decodeBOM . encodeBOM = id"
prop_decode_bom enc = \x -> C.decodeBOM (C.encodeBOM_ enc x) == Just x

prop_decode_encode_UTF8    = prop_de UTF8
prop_decode_encode_UTF16BE = prop_de (UTF16 BE)
prop_decode_encode_UTF16LE = prop_de (UTF16 LE)
prop_decode_encode_UTF32BE = prop_de (UTF32 BE)
prop_decode_encode_UTF32LE = prop_de (UTF32 LE)
prop_decode_encode_ASCII   = prop_de ASCII
prop_decode_encode_Latin1  = prop_de Latin1
prop_decode_encode_Compact = prop_de Compact

prop_encode_decode_UTF8    = prop_ed UTF8
-- This does not hold for UTF16, because two different bytestrings can represent the
-- same Unicode string: The order of a surrogate pair can be swapped
--prop_encode_decode_UTF16BE = prop_ed (decode (UTF16 BE)) (encode (UTF16 BE))
--prop_encode_decode_UTF16LE = prop_ed (decode (UTF16 LE)) (encode (UTF16 LE))
prop_encode_decode_UTF32BE = prop_ed (UTF32 BE)
prop_encode_decode_UTF32LE = prop_ed (UTF32 LE)
prop_encode_decode_ASCII   = prop_ed ASCII
prop_encode_decode_Latin1  = prop_ed Latin1
prop_encode_decode_Compact = prop_ed Compact

prop_decode_no_bom      = \x -> C.take 1 x /= C.pack "\xFEFF"
                        ==> C.decodeBOM (C.encode_ UTF8 x) == Just x
prop_decode_bom_UTF8    = prop_decode_bom UTF8
prop_decode_bom_UTF16BE = prop_decode_bom (UTF16 BE)
prop_decode_bom_UTF16LE = prop_decode_bom (UTF16 LE)
prop_decode_bom_UTF32BE = prop_decode_bom (UTF32 BE)
prop_decode_bom_UTF32LE = prop_decode_bom (UTF32 LE)

------------------------------------------------------------------------
-- The tests

tests = list_tests
     ++ other_tests
     ++ encoding_tests

list_tests :: [(String, Int -> IO ())]
list_tests =
    [("validate",       mytest prop_validate)
    
    ,("eq",             mytest prop_eq)
    ,("compare",        mytest prop_compare)
    ,("show",           mytest prop_show)
    
    ,("empty",          mytest prop_empty)
    ,("singleton",      mytest prop_singleton)
    
    ,("cons",           mytest prop_cons)
    ,("snoc",           mytest prop_snoc)
    ,("append",         mytest prop_append)
    ,("head",           mytest prop_head)
    ,("tail",           mytest prop_tail)
    ,("init",           mytest prop_init)
    ,("null",           mytest prop_null)
    ,("length",         mytest prop_length)
    
    ,("map",            mytest prop_map)
    ,("reverse",        mytest prop_reverse)
    ,("intersperse",    mytest prop_intersperse)
    ,("transpose",      mytest prop_transpose)
    ,("foldl",          mytest prop_foldl)
    ,("foldr",          mytest prop_foldr)
    ,("foldl'",         mytest prop_foldl')
    ,("foldl1",         mytest prop_foldl1)
    ,("foldr1",         mytest prop_foldr1)
    ,("foldl1'",        mytest prop_foldl1')
    
    ,("concat",         mytest prop_concat)
    ,("concatMap",      mytest prop_concatMap)
    ,("any",            mytest prop_any)
    ,("all",            mytest prop_all)
    ,("maximum",        mytest prop_maximum)
    ,("minimum",        mytest prop_minimum)
    
    ,("scanl",          mytest prop_scanl)
    ,("scanr",          mytest prop_scanr)
    ,("scanl1",         mytest prop_scanl1)
    ,("scanr1",         mytest prop_scanr1)
    
    ,("mapAccumL",      mytest prop_mapAccumL)
    ,("mapAccumR",      mytest prop_mapAccumR)
    ,("mapIndexed",     mytest prop_mapIndexed)
    
    ,("replicate",      mytest prop_replicate)
    ,("unfoldrN",       mytest prop_unfoldrN)
    
    ,("take",           mytest prop_take)
    ,("drop",           mytest prop_drop)
    ,("splitAt",        mytest prop_splitAt)
    ,("takeWhile",      mytest prop_takeWhile)
    ,("dropWhile",      mytest prop_dropWhile)
    ,("break",          mytest prop_break)
    ,("span",           mytest prop_span)
    ,("breakEnd",       mytest prop_breakEnd)
    ,("spanEnd",        mytest prop_spanEnd)
    ,("group",          mytest prop_group)
    ,("groupBy",        mytest prop_groupBy)
    ,("inits",          mytest prop_inits)
    ,("tails",          mytest prop_tails)

    ,("split",          mytest prop_split)
    ,("splitWith",      mytest prop_splitWith)

    ,("lines",          mytest prop_lines)
    ,("unlines",        mytest prop_unlines)
    ,("words",          mytest prop_words)
    ,("unwords",        mytest prop_unwords)
    
    ,("isPrefixOf",     mytest prop_isPrefixOf)
    ,("isSuffixOf",     mytest prop_isSuffixOf)
    
    ,("isSubstringOf",  mytest prop_isSubstringOf)
    ,("findSubstring",  mytest prop_findSubstring)
    ,("findSubstrings", mytest prop_findSubstrings)
    
    ,("elem",           mytest prop_elem)
    ,("notElem",        mytest prop_notElem)
    
    ,("find",           mytest prop_find)
    ,("filter",         mytest prop_filter)
    ,("partition",      mytest prop_partition)
    
    ,("index",          mytest prop_index)
    ,("elemIndex",      mytest prop_elemIndex)
    ,("elemIndices",    mytest prop_elemIndices)
    ,("findIndex",      mytest prop_findIndex)
    ,("findIndices",    mytest prop_findIndices)
    ,("count",          mytest prop_count)
    
    ,("zip",            mytest prop_zip)
    ,("zipWith",        mytest prop_zipWith)
    ,("zipWith'",       mytest prop_zipWith')
    ,("unzip",          mytest prop_unzip)
    
    ,("sort",           mytest prop_sort)
    
    {-
    ,("",       mytest )
    -}
    ]

other_tests :: [(String, Int -> IO ())]
other_tests =
    [("unpack . pack",          mytest prop_pack)
    ,("pack . unpack",          mytest prop_unpack)
    ,("elemIndexEnd",           mytest prop_elemIndexEnd)
    ,("findIndexEnd",           mytest prop_findIndexEnd)
    ]

encoding_tests :: [(String, Int -> IO ())]
encoding_tests =
    [("from . toByteString",            mytest prop_fromToByteString)
    
    ,("decode . encode: UTF-8",         mytest prop_decode_encode_UTF8)
    ,("decode . encode: UTF-16BE",      mytest prop_decode_encode_UTF16BE)
    ,("decode . encode: UTF-16LE",      mytest prop_decode_encode_UTF16LE)
    ,("decode . encode: UTF-32BE",      mytest prop_decode_encode_UTF32BE)
    ,("decode . encode: UTF-32LE",      mytest prop_decode_encode_UTF32LE)
    ,("decode . encode: ASCII",         mytest prop_decode_encode_ASCII)
    ,("decode . encode: Latin1",        mytest prop_decode_encode_Latin1)
    ,("decode . encode: Compact",       mytest prop_decode_encode_Compact)
    
    ,("encode . decode: UTF-8",         mytest prop_encode_decode_UTF8)
    --,("encode . decode: UTF-16BE",    mytest prop_encode_decode_UTF16BE)
    --,("encode . decode: UTF-16LE",    mytest prop_encode_decode_UTF16LE)
    ,("encode . decode: UTF-32BE",      mytest prop_encode_decode_UTF32BE)
    ,("encode . decode: UTF-32LE",      mytest prop_encode_decode_UTF32LE)
    ,("encode . decode: ASCII",         mytest prop_encode_decode_ASCII)
    ,("encode . decode: Latin1",        mytest prop_encode_decode_Latin1)
    ,("encode . decode: Compact",       mytest prop_encode_decode_Compact)
    
    ,("decode no BOM",                  mytest prop_decode_no_bom)
    ,("decode / BOM: UTF-8",            mytest prop_decode_bom_UTF8)
    ,("decode / BOM: UTF-16BE",         mytest prop_decode_bom_UTF16BE)
    ,("decode / BOM: UTF-16LE",         mytest prop_decode_bom_UTF16LE)
    ,("decode / BOM: UTF-32BE",         mytest prop_decode_bom_UTF32BE)
    ,("decode / BOM: UTF-32LE",         mytest prop_decode_bom_UTF32LE)
    ]

------------------------------------------------------------------------
-- The entry point

main = run tests

run :: [(String, Int -> IO ())] -> IO ()
run tests = do
    x <- getArgs
    let n = if null x then 100 else read . head $ x
    mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests