{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, StandaloneDeriving, DeriveGeneric #-}

module Set7Test where

import Data.List
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Generics (Generic)
import Generic.Random
import Test.QuickCheck

import Mooc.Th
import Mooc.Test

import Set7 hiding (bake)

main = score tests

tests = [(1,"travel",[ex1_travel, ex1_velocity])
        ,(2,"Set",[ex2_member, ex2_add, ex2_empty_add])
        ,(3,"bake",[ex3_ok, ex3_finished, ex3_error, ex3_type])
        ,(4,"average NonEmpty",[ex4])
        ,(5,"reverseNonEmpty",[ex5_one, ex5_many])
        ,(6,"Semigroup x3",[ex6_Distance, ex6_Time, ex6_Velocity])
        ,(7,"Monoid Set",[ex7_combine, ex7_mempty])
        ,(8,"Operation1&2",[ex8_multiply1, ex8_multiply2, ex8_show1, ex8_show1_multiply1, ex8_show2, ex8_show2_multiply2])
        ,(9,"PasswordRequirement",[ex9_basics, ex9_either_both, ex9_large])
        ,(10,"Arithmetic",[ex10_examples, ex10_large])
        ]

--

ex1_velocity = forAll_ $ \d ->
  forAll_ $ \(Positive t) ->
  $(testing [|velocity (Distance d) (Time t)|]) (?==Velocity (d/t))

ex1_travel = forAll_ $ \(v,t) ->
  $(testing [|travel (Velocity v) (Time t)|]) (?==Distance (v*t))

instance (Ord a, Arbitrary a) => Arbitrary (Set a) where
  arbitrary = fmap (Set . nub) orderedList

m2_member example = forAll_ $ \(Set xs) ->
  not (null xs) ==>
  forAllBlind (elements (xs`asTypeOf`example)) $ \x ->
  conjoin [$(testing [|member x (Set xs)|]) (?==True)
          ,$(testing [|member x (Set (delete x xs))|]) (?==False)]

ex2_member = conjoin [m2_member [True,False]
                     ,m2_member [1::Int,2,3]]

m2_add example = forAll_ $ \(Set xs) ->
  not (null xs) ==>
  forAllBlind (elements (xs`asTypeOf`example)) $ \x ->
  conjoin [$(testing [|add x (Set xs)|]) (?==(Set xs))
          ,$(testing [|add x (Set (delete x xs))|]) (?==(Set xs))]

ex2_add = conjoin [m2_add ["foo","bar"]
                  ,m2_add [1::Int,2,3]]

ex2_empty_add = conjoin
  [forAll_ $ \(i::Integer) -> counterexample ("add "++show i++" emptySet") (add i emptySet ?== Set [i])
  ,forAll_ $ \(b::Bool) -> counterexample ("add " ++show b++"(add "++show b++" emptySet)")
    (add b (add b emptySet) ?== Set [b])]

deriving instance Generic Event
instance Arbitrary Event where
  arbitrary = genericArbitrary uniform

ex3_good = [[AddEggs,AddFlour,AddSugar,Mix,Bake]
           ,[AddEggs,AddSugar,AddFlour,Mix,Bake]]

canFinish ev = any (\g -> ev `isPrefixOf` g) ex3_good
finished ev = any (\g -> g `isPrefixOf` ev) ex3_good

bake :: [Event] -> State
bake events = go Start events
  where go state [] = state
        go state (e:es) = go (step state e) es

ex3_ok = forAllBlind (elements ex3_good) $ \events ->
  $(testing [|bake events|]) (?==Finished)

ex3_finished = forAll_ $ \(ev::Event) ->
  $(testing [|step Finished ev|]) (?==Finished)

genBad = do
  g <- elements ex3_good
  i <- choose (0,length g - 1)
  let pre = take i g
  x <- arbitrary `suchThat` (\x -> not (canFinish (pre++[x]) || finished (pre++[x])))
  y <- arbitrary
  elements [pre++[x], pre++[x,y]]

ex3_error = forAllBlind (genBad) $ \events ->
  $(testing [|bake events|]) (?==Error)

ex3_type = $(reifyType "State") $ \(DataType vars cs) ->
  conjoin [counterexample "  should have no type parameters" $ vars == []
          ,conjoin $ map ok cs]
  where ok (Constructor _ []) = property True
        ok (Constructor n _) = counterexample ("  constructor "++show n++" should have no fields") $ property False
        ok (Weird n) = counterexample ("  constructor "++show n++" is weird. Make it normal.") $ property False

ex4 = conjoin [forAll_ $ \(Small i) -> $(testing [|average ((fromIntegral i :: Float) :| [])|]) (?==fromIntegral i)
              ,forAllBlind (choose (1,10)) $ \n -> forAll_ $ \(i::Rational) ->
                  $(testing [|average (i:|(replicate n i))|]) (?==i)
              ,forAll_ $ \(Small i) -> let f = fromIntegral i in $(testing [|average ((f-1):|[f,f+1])|]) (?==f)
              ,forAll_ $ \(Small i,Small j) ->
                  let x = fromIntegral i :: Double
                      y = fromIntegral j :: Double
                  in $(testing [|average (x:|(replicate 9 x ++ replicate 10 y))|]) (?~=(x+y)/2)]

ex5_one = forAll_ $ \(x::Bool) -> $(testing [|reverseNonEmpty (x:|[])|]) (?==(x:|[]))

ex5_many = forAllBlind (choose (0,10)) $ \(i::Int) ->
  forAllBlind (choose (2,10)) $ \(n::Int) ->
  $(testing [|reverseNonEmpty (i:|[i+1..i+n])|]) (?==((i+n):|[i+n-1,i+n-2..i]))

ex6_Distance = $(withInstance "Semigroup" "Distance" [|(<>)|]) $ \(<>) ->
  forAll_ $ \(x,y) ->
  $(testing [|(Distance x) <> (Distance y)|]) (?==Distance (x+y))

ex6_Time = $(withInstance "Semigroup" "Time" [|(<>)|]) $ \(<>) ->
  forAll_ $ \(x,y) ->
  $(testing [|(Time x) <> (Time y)|]) (?==Time (x+y))

ex6_Velocity = $(withInstance "Semigroup" "Velocity" [|(<>)|]) $ \(<>) ->
  forAll_ $ \(x,y) ->
  $(testing [|(Velocity x) <> (Velocity y)|]) (?==Velocity (x+y))

split [] = return ([],[])
split (x:xs) = do
  (as,bs) <- split xs
  oneof [return (x:as,bs)
        ,return (as,x:bs)
        ,return (x:as,x:bs)]

ex7_combine = $(withInstance1 "Monoid" "Set" [|(<>)|]) $ \(<>) ->
  forAll_ $ \(Set (xs :: [Integer])) ->
  forAllBlind (split xs) $ \(as,bs) ->
  $(testing [|(Set as) <> (Set bs)|]) (?==(Set xs))

ex7_mempty = $(withInstance1 "Monoid" "Set" [|((<>),mempty)|]) $ \((<>),mempty) ->
  forAll_ $ \(Set (xs :: [Char])) ->
  conjoin [counterexample (show (Set xs) ++ " <> mempty") ((Set xs <> mempty) ?== Set xs)
          ,counterexample ("mempty <> " ++ show (Set xs)) ((mempty <> Set xs) ?== Set xs)]

smallInt = choose (0,100::Int)

ex8_multiply1 = $(withConstructor "Operation1" "Multiply1" ["Int","Int"]) $ \mul1 ->
  forAllBlind smallInt $ \i ->
  forAllBlind smallInt $ \j ->
  $(testing [|compute1 (mul1 i j)|]) (?==(i*j))

{-
ex8_multiply1 = $(reifyType "Operation1") $ \(DataType vars cs) ->
  case filter ok cs of
    [Constructor _ ts] -> counterexample "  constructor Multiply1 should have type Int -> Int -> Operation1" $
                          property $ ts == [SimpleType "Int", SimpleType "Int"]
    [_] -> counterexample ("  constructor Multiply1 is weid. Make it normal.") $ property False
    _ -> counterexample ("  should have a constructor named Multiply1") $ property False
  where ok (Constructor "Multiply1" _) = True
        ok (Weird "Multiply1") = True
        ok _ = False
-}

ex8_multiply2 =
  $(withInstance "Operation2" "Multiply2" [|compute2|]) $ \compute2 ->
  $(withDefined "Multiply2") $ \mul2 ->
  forAllBlind smallInt $ \i ->
  forAllBlind smallInt $ \j ->
  -- no Show instance available...
  counterexample ("compute2 (Multiply2 " ++ show i ++ " " ++ show j ++ ")") $
  compute2 (mul2 i j) ?== (i*j)

ex8_show1 =
  $(hasType "show1" [t|Operation1 -> String|]) $ \show1 ->
  forAllBlind smallInt $ \i ->
  forAllBlind smallInt $ \j ->
  conjoin [$(testing [|show1 (Add1 i j)|]) (?==show i++"+"++show j)
          ,$(testing [|show1 (Subtract1 i j)|]) (?==show i++"-"++show j)]

ex8_show1_multiply1 =
  $(withConstructor "Operation1" "Multiply1" ["Int","Int"]) $ \mul1 ->
  $(hasType "show1" [t|Operation1 -> String|]) $ \show1 ->
  forAllBlind smallInt $ \i ->
  forAllBlind smallInt $ \j ->
  counterexample ("show1 (Multiply1 " ++ show i ++ " " ++ show j ++ ")") $
  show1 (mul1 i j) ?== show i++"*"++show j

ex8_show2 =
  conjoin [$(withDefined "show2") $ \show2 ->
              forAllBlind smallInt $ \i ->
              forAllBlind smallInt $ \j ->
              $(testing [|show2 (Add2 i j)|]) (?==show i++"+"++show j)
          ,$(withDefined "show2") $ \show2 ->
              forAllBlind smallInt $ \i ->
              forAllBlind smallInt $ \j ->
              $(testing [|show2 (Subtract2 i j)|]) (?==show i++"-"++show j)]

ex8_show2_multiply2 =
  $(withDefined "show2") $ \show2 ->
  $(withDefined "Multiply2") $ \mul2 ->
  forAllBlind (choose (0,100::Int)) $ \i ->
  forAllBlind (choose (0,100::Int)) $ \j ->
  $(testing [|show2 (Add2 i j)|]) (?==show i++"+"++show j)

ex9_basics =
  conjoin [$(testing [|passwordAllowed "short" (MinimumLength 8)|]) (?==False)
          ,$(testing [|passwordAllowed "veryLongPassword" (MinimumLength 8)|]) (?==True)
          ,$(testing [|passwordAllowed "password" (ContainsSome "0123456789")|]) (?==False)
          ,$(testing [|passwordAllowed "p4ssword" (ContainsSome "0123456789")|]) (?==True)
          ,$(testing [|passwordAllowed "password" (DoesNotContain "0123456789")|]) (?==True)
          ,$(testing [|passwordAllowed "p4ssword" (DoesNotContain "0123456789")|]) (?==False)
          ]

ex9_either_both = property $ do
  ~limits@[a,b,c,d] <- vectorOf 4 (choose (3,12))
  password <- vectorOf 24 (choose ('a','z'))
  let or = Or (Or (MinimumLength a) (MinimumLength b)) (Or (MinimumLength c) (MinimumLength d))
      and = And (And (MinimumLength a) (MinimumLength b)) (And (MinimumLength c) (MinimumLength d))
      low = minimum limits
      hi = maximum limits
  return $
    (low < hi) ==> do med <- choose (low,hi-1)
                      return $
                        conjoin [$(testing [|passwordAllowed (take (low-1) password) or|]) (?==False)
                                ,$(testing [|passwordAllowed (take (low-1) password) and|]) (?==False)
                                ,$(testing [|passwordAllowed (take med password) or|]) (?==True)
                                ,$(testing [|passwordAllowed (take med password) and|]) (?==False)
                                ,$(testing [|passwordAllowed (take hi password) or|]) (?==True)
                                ,$(testing [|passwordAllowed (take hi password) and|]) (?==True)]

tree leaf node [] = MinimumLength 0
tree leaf node cs
  | length cs <= 2 = leaf cs
tree leaf node cs = node (tree leaf node lefts) (tree leaf node rights)
  where (lefts,rights) = splitAt (length cs `div` 2) cs

special = elements "0123456789!#%&/()="

ex9_large = forAllBlind (listOf special) $ \forbidden ->
  forAllBlind (listOf special) $ \required' ->
  forAllShrink_ (listOf (choose ('a','z'))) $ \base ->
  let required = filter (not . flip elem forbidden) required'
      rules = And (tree ContainsSome Or required) (tree DoesNotContain And forbidden)
  in not (null required) ==>
    not (null forbidden) ==>
    forAllBlind (elements required) $ \req ->
    forAllBlind (elements forbidden) $ \forb ->
    conjoin [$(testing [|passwordAllowed base rules|]) (?==False)
             ,forAllBlind (shuffle (req:base)) $ \pw ->
                 $(testing [|passwordAllowed pw rules|]) (?==True)
             ,forAllBlind (shuffle (forb:req:base)) $ \pw ->
                 $(testing [|passwordAllowed pw rules|]) (?==False)]

ex10_examples = conjoin [$(testing [|evaluate (literal 3)|]) (?==3)
                        ,$(testing [|render   (literal 3)|]) (?=="3")
                        ,$(testing [|evaluate (operation "+" (literal 3) (literal 4))|]) (?==7)
                        ,$(testing [|render   (operation "+" (literal 3) (literal 4))|]) (?=="(3+4)")
                        ,$(testing [|evaluate (operation "*" (literal 3) (operation "+" (literal 1) (literal 1)))|]) (?==6)
                        ,$(testing [|render   (operation "*" (literal 3) (operation "+" (literal 1) (literal 1)))|]) (?=="(3*(1+1))")]

gen_arithmetic :: Integer -> Gen (Integer,Arithmetic,String,String)
gen_arithmetic 0 = do
  i <- choose (0,10)
  return (i,literal i,show i,"(literal "++show i++")")
gen_arithmetic i = do
  (lval,lexp,lshow,lcode) <- gen_arithmetic (i-1)
  (rval,rexp,rshow,rcode) <- gen_arithmetic (i-1)
  elements [(lval+rval,operation "+" lexp rexp,"("++lshow++"+"++rshow++")","(operation \"+\" "++lcode++" "++rcode++")")
           ,(lval*rval,operation "*" lexp rexp,"("++lshow++"*"++rshow++")","(operation \"*\" "++lcode++" "++rcode++")")]

m_ex10 level = forAllShrink_ (choose (1,level)) $ \l ->
  forAllBlind (gen_arithmetic level) $ \(val,exp,show,code) ->
  conjoin [counterexample ("evaluate "++code) $ evaluate exp ?== val
          ,counterexample ("render "++code) $ render exp ?== show]

ex10_large = conjoin [m_ex10 level | level <- [1..5]]