module Data.Validator.Utils where

import           Control.Arrow
import qualified Data.HashMap.Strict  as H
import           Data.List.NonEmpty   (NonEmpty)
import qualified Data.List.NonEmpty   as N
import           Data.Scientific      (Scientific, fromFloatDigits)
import           Data.Set             (Set)
import qualified Data.Set             as S
import qualified Data.Text            as T
import qualified Data.Vector          as V

import           Import

--------------------------------------------------
-- * QuickCheck
--------------------------------------------------

arbitraryText :: Gen Text
arbitraryText = T.pack <$> arbitrary

arbitraryScientific :: Gen Scientific
arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary

arbitraryPositiveScientific :: Gen Scientific
arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific)
                            . getPositive
                          <$> arbitrary

arbitraryValue :: Gen Value
arbitraryValue = sized f
  where
    f :: Int -> Gen Value
    f n | n <= 1    = oneof nonRecursive
        | otherwise = oneof $
            fmap (Array . V.fromList) (traverse (const (f (n `div` 10)))
              =<< (arbitrary :: Gen [()]))
          : fmap (Object . H.fromList) (traverse (const (g (n `div` 10)))
              =<< (arbitrary :: Gen [()]))
          : nonRecursive

    g :: Int -> Gen (Text, Value)
    g n = (,) <$> arbitraryText <*> f n

    nonRecursive :: [Gen Value]
    nonRecursive =
      [ pure Null
      , Bool <$> arbitrary
      , String <$> arbitraryText
      , Number <$> arbitraryScientific
      ]

arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a)
arbitraryHashMap = H.fromList . fmap (first T.pack) <$> arbitrary

arbitrarySetOfText :: Gen (Set Text)
arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary

newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a }

instance FromJSON a => FromJSON (NonEmpty' a) where
  parseJSON v = do
    xs <- parseJSON v
    case N.nonEmpty xs of
      Nothing -> fail "Must have at least one item."
      Just ne -> pure (NonEmpty' ne)

instance ToJSON a => ToJSON (NonEmpty' a) where
  toJSON = toJSON . N.toList . _unNonEmpty'

instance Arbitrary a => Arbitrary (NonEmpty' a) where
  arbitrary = do
    xs <- arbitrary
    case N.nonEmpty xs of
      Nothing -> NonEmpty' . pure <$> arbitrary
      Just ne -> pure (NonEmpty' ne)

--------------------------------------------------
-- * allUniqueValues
--------------------------------------------------

allUniqueValues :: Vector Value -> Bool
allUniqueValues = allUnique . fmap OrdValue . V.toList

-- NOTE: When we no longer support GHC 7.8 we can generalize
-- allUnique to work on any Foldable and remove this function.
allUniqueValues' :: NonEmpty Value -> Bool
allUniqueValues' = allUnique . fmap OrdValue . N.toList

allUnique :: (Ord a) => [a] -> Bool
allUnique xs = S.size (S.fromList xs) == length xs

-- | OrdValue's Ord instance needs benchmarking, but it allows us to
-- use our 'allUnique' function instead of O(n^2) nub, so it's probably
-- worth it.
newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq

instance Ord OrdValue where
  (OrdValue Null) `compare` (OrdValue Null) = EQ
  (OrdValue Null) `compare` _               = LT
  _               `compare` (OrdValue Null) = GT

  (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y
  (OrdValue (Bool _)) `compare` _                   = LT
  _                   `compare` (OrdValue (Bool _)) = GT

  (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y
  (OrdValue (Number _)) `compare` _                     = LT
  _                     `compare` (OrdValue (Number _)) = GT

  (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y
  (OrdValue (String _)) `compare` _                     = LT
  _                     `compare` (OrdValue (String _)) = GT

  (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) =
    (OrdValue <$> xs) `compare` (OrdValue <$> ys)
  (OrdValue (Array _))  `compare` _                     = LT
  _                     `compare` (OrdValue (Array _))  = GT

  (OrdValue (Object x)) `compare` (OrdValue (Object y)) =
    H.toList (OrdValue <$> x) `compare` H.toList (OrdValue <$> y)