module APL.Tests
  ( properties,
    genVar
  )
where

import APL.AST (Exp (..), subExp, VName, printExp)
import APL.Eval (eval, runEval)
import APL.Parser (parseAPL, keywords)
import APL.Error (isVariableError, isDomainError, isTypeError)
import APL.Check (checkExp)
import Test.QuickCheck
  ( Property
  , Gen
  , Arbitrary (arbitrary, shrink)
  , property
  , cover
  , checkCoverage
  , oneof
  , sized
  , frequency
  , elements
  , listOf
  , suchThat
  , resize
  , withMaxSuccess
  )

genString :: Gen String
genString = resize 4 $ listOf $ elements ['a'..'z']

varTest :: String -> Bool
varTest s = (not (s `elem` keywords)) && ((length s) > 1)

genVar :: Gen String
genVar = suchThat (genString) (varTest)

genInt :: Gen Integer
genInt = suchThat arbitrary (\i -> i >= 0)

instance Arbitrary Exp where
  arbitrary = sized (genExp [])

  shrink (Add e1 e2) =
    e1 : e2 : [Add e1' e2 | e1' <- shrink e1] ++ [Add e1 e2' | e2' <- shrink e2]
  shrink (Sub e1 e2) =
    e1 : e2 : [Sub e1' e2 | e1' <- shrink e1] ++ [Sub e1 e2' | e2' <- shrink e2]
  shrink (Mul e1 e2) =
    e1 : e2 : [Mul e1' e2 | e1' <- shrink e1] ++ [Mul e1 e2' | e2' <- shrink e2]
  shrink (Div e1 e2) =
    e1 : e2 : [Div e1' e2 | e1' <- shrink e1] ++ [Div e1 e2' | e2' <- shrink e2]
  shrink (Pow e1 e2) =
    e1 : e2 : [Pow e1' e2 | e1' <- shrink e1] ++ [Pow e1 e2' | e2' <- shrink e2]
  shrink (Eql e1 e2) =
    e1 : e2 : [Eql e1' e2 | e1' <- shrink e1] ++ [Eql e1 e2' | e2' <- shrink e2]
  shrink (If cond e1 e2) =
    e1 : e2 : [If cond' e1 e2 | cond' <- shrink cond] ++ [If cond e1' e2 | e1' <- shrink e1] ++ [If cond e1 e2' | e2' <- shrink e2]
  shrink (Let x e1 e2) =
    e1 : [Let x e1' e2 | e1' <- shrink e1] ++ [Let x e1 e2' | e2' <- shrink e2]
  shrink (Lambda x e) =
    [Lambda x e' | e' <- shrink e]
  shrink (Apply e1 e2) =
    e1 : e2 : [Apply e1' e2 | e1' <- shrink e1] ++ [Apply e1 e2' | e2' <- shrink e2]
  shrink (TryCatch e1 e2) =
    e1 : e2 : [TryCatch e1' e2 | e1' <- shrink e1] ++ [TryCatch e1 e2' | e2' <- shrink e2]
  shrink _ = []

genExp :: [VName] -> Int -> Gen Exp
genExp _ 0 = oneof [CstInt <$> genInt, CstBool <$> arbitrary]
genExp vars size =
  frequency
    [ (1, CstInt <$> genInt)
    , (1, CstBool <$> arbitrary)
    , (1, Add <$> genExp vars halfSize <*> genExp vars halfSize)
    , (1, Sub <$> genExp vars halfSize <*> genExp vars halfSize)
    , (1, Mul <$> genExp vars halfSize <*> genExp vars halfSize)
    , (1, Div <$> genExp vars halfSize <*> genExp vars halfSize)
    , (1, Pow <$> genExp vars halfSize <*> genExp vars halfSize)
    , (1, Eql <$> genExp vars halfSize <*> genExp vars halfSize)
    , (1, If <$> genExp vars thirdSize <*> genExp vars thirdSize <*> genExp vars thirdSize)
    , (1, Var <$> genVar)
    , (if (length vars) > 0 then 50 else 0, Var <$> elements vars)
    , (25, do
        var <- genVar
        e1 <- genExp vars halfSize
        e2 <- genExp (var:vars) halfSize
        pure $ Let var e1 e2
      )
    , (25, do
        var <- genVar
        body <- genExp vars (size - 1)
        pure $ Lambda var body
      )
    , (1, Apply <$> genExp vars halfSize <*> genExp vars halfSize)
    , (1, TryCatch <$> genExp vars halfSize <*> genExp vars halfSize)
    ]
  where
    halfSize = size `div` 2
    thirdSize = size `div` 3

expCoverage :: Exp -> Property
expCoverage e = checkCoverage
  . cover 20 (any isDomainError (checkExp e)) "domain error"
  . cover 20 (not $ any isDomainError (checkExp e)) "no domain error"
  . cover 20 (any isTypeError (checkExp e)) "type error"
  . cover 20 (not $ any isTypeError (checkExp e)) "no type error"
  . cover 5 (any isVariableError (checkExp e)) "variable error"
  . cover 70 (not $ any isVariableError (checkExp e)) "no variable error"
  . cover 50 (or [2 <= n && n <= 4 | Var v <- subExp e, let n = length v]) "non-trivial variable"
  $ ()

parsePrinted :: Exp -> Bool
parsePrinted e = case (parseAPL "input" (printExp e)) of
  Left _ -> False
  Right e' -> e == e'

onlyCheckedErrors :: Exp -> Bool
onlyCheckedErrors e = case runEval (eval e) of
  Right _ -> True
  Left err -> err `elem` (checkExp e)

properties :: [(String, Property)]
properties =
  [ ("expCoverage", property expCoverage)
  , ("parsePrinted", property (withMaxSuccess 10000 parsePrinted))
  , ("onlyCheckedErrors", property (withMaxSuccess 1000000 onlyCheckedErrors))
  ]