{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HUnit.Num where

import Test.Tasty
import Prelude (Num)
import Prelude hiding (Num(..))

import Language.Symantic
import Language.Symantic.Lib
import Testing.Compiling

-- * Tests
type SS =
 [ Proxy (->)
 , Proxy Integer
 , Proxy Num
 , Proxy Num2
 , Proxy Int
 , Proxy Integral
 , Proxy Foldable
 , Proxy Traversable
 , Proxy []
 ]
(==>) = readTe @() @SS

hunits :: TestTree
hunits = testGroup "Num"
 [ "42"                        ==> Right (tyInteger,  42, "42")
 , "-42"                       ==> Right (tyInteger, -42, "negate 42")
 , "- -42"                     ==> Right (tyInteger,  42, "negate (negate 42)")
 , "1 + -2"                    ==> Right (tyInteger,  -1, "1 + negate 2")
 , "-1 + -2"                   ==> Right (tyInteger,  -3, "negate 1 + negate 2")
 , "-(1 + -2)"                 ==> Right (tyInteger,   1, "negate (1 + negate 2)")
 , "(+) 1 2"                   ==> Right (tyInteger,   3, "1 + 2")
 , "1+2"                       ==> Right (tyInteger,   3, "1 + 2")
 , "1 +2"                      ==> Right (tyInteger,   3, "1 + 2")
 , "1+ 2"                      ==> Right (tyInteger,   3, "1 + 2")
 , "1 + 2"                     ==> Right (tyInteger,   3, "1 + 2")
 , "1 + 2 - 3"                 ==> Right (tyInteger,   0, "1 + 2 - 3")
 , "1 + 2 * 3"                 ==> Right (tyInteger,   7, "1 + 2 * 3")
 , "3 * 2 + 1"                 ==> Right (tyInteger,   7, "3 * 2 + 1")
 , "3 * (2 + 1)"               ==> Right (tyInteger,   9, "3 * (2 + 1)")
 , "4 + 3 * 2 + 1"             ==> Right (tyInteger,  11, "4 + 3 * 2 + 1")
 , "5 * 4 + 3 * 2 + 1"         ==> Right (tyInteger,  27, "5 * 4 + 3 * 2 + 1")
 , "negate`42"                 ==> Right (tyInteger, -42, "negate 42")
 , "42`negate"                 ==> Right (tyInteger, -42, "negate 42")
 , "42`negate "                ==> Right (tyInteger, -42, "negate 42")
 , "42`negate`negate"          ==> Right (tyInteger,  42, "negate (negate 42)")
 , "42`abs`negate"             ==> Right (tyInteger, -42, "negate (abs 42)")
 , "42`negate`abs"             ==> Right (tyInteger,  42, "abs (negate 42)")
 , "abs`negate`42"             ==> Right (tyInteger,  42, "abs (negate 42)")
 , "negate`abs`42"             ==> Right (tyInteger, -42, "negate (abs 42)")
 , "negate`abs`42`mod`9"       ==> Right (tyInteger,   3, "negate (abs 42) `mod` 9")
 , "negate abs`42"             ==> Right (tyInteger, -42, "negate (abs 42)")
 , "negate 42`abs"             ==> Right (tyInteger, -42, "negate (abs 42)")
 , "(+) negate`2 44"           ==> Right (tyInteger,  42, "negate 2 + 44")
 , "(+) 2`negate 44"           ==> Right (tyInteger,  42, "negate 2 + 44")
 , "(+) (negate`2) 44"         ==> Right (tyInteger,  42, "negate 2 + 44")
 , "abs negate`42"             ==> Right (tyInteger,  42, "abs (negate 42)")
 , "(+) 40 2"                  ==> Right (tyInteger,  42, "40 + 2")
 , "(+) 40 $ -2"               ==> Right (tyInteger,  38, "(($) (\\x0 -> 40 + x0)) (negate 2)")
 , "negate 42 + 42`negate"     ==> Right (tyInteger, -84, "negate 42 + negate 42")
 , "(+) (negate 42) 42`negate" ==> Right (tyInteger, -84, "negate 42 + negate 42")
 , "(+) negate`42 42`negate"   ==> Right (tyInteger, -84, "negate 42 + negate 42")
 , "42`abs`negate`mod`abs`negate`9" ==> Right (tyInteger, 3, "negate (abs 42) `mod` abs (negate 9)")
 , "abs`42`negate"             ==> Right (tyInteger,  42, "abs (negate 42)")
 , "negate`42`abs"             ==> Right (tyInteger,  42, "abs (negate 42)")
 , testGroup "Error_Term"
   [ "(+) 40 -2"  ==> Left (tyInteger,
		Right $ Error_Term_Beta $ Error_Beta_Unify $
		Error_Unify_Const_mismatch
		 (TypeVT $ tyFun @_ @'[])
		 (TypeVT $ tyInteger @_ @'[]))
	 , "(+) 40 - 2" ==> Left (tyInteger,
		Right $ Error_Term_Beta $ Error_Beta_Unify $
		Error_Unify_Const_mismatch
		 (TypeVT $ tyFun @_ @'[])
		 (TypeVT $ tyInteger @_ @'[]))
	 ]
 ]

-- | A newtype to test prefix and postfix.
newtype Num2 a = Num2 a
type instance Sym Num2 = Sym_Num2
class Sym_Num2 (term:: * -> *) where

instance Sym_Num2 Eval where
instance Sym_Num2 View where
instance Sym_Num2 (Dup r1 r2) where
instance Sym_Num2 term => Sym_Num2 (BetaT term) where
instance NameTyOf Num2 where
	nameTyOf _c = ["Num2"] `Mod` "Num2"
instance FixityOf Num2
instance ClassInstancesFor Num2
instance TypeInstancesFor Num2
instance Gram_Term_AtomsFor src ss g Num2
instance (Source src, SymInj ss Num) => ModuleFor src ss Num2 where
	moduleFor = ["Num2"] `moduleWhere`
	 [ "abs"    `withPrefix`   9 := teNum_abs
	 , "negate" `withPrefix`  10 := teNum_negate
	 , "abs"    `withPostfix`  9 := teNum_abs
	 , "negate" `withPostfix` 10 := teNum_negate
	 ]