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

import Test.Tasty

import qualified Data.Monoid as Monoid
import Data.Proxy (Proxy(..))
import Prelude (Num)
import Prelude hiding (Num(..))

import Language.Symantic.Parsing
import Language.Symantic.Parsing.Grammar
import Language.Symantic.Typing
import Language.Symantic.Compiling
import Language.Symantic.Interpreting
import Language.Symantic.Lib.Num
import Compiling.Term.Test

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

tests :: TestTree
tests = testGroup "Num"
 [ "42" ==> Right (ty @Integer, 42, "42")
 , "-42" ==> Right (ty @Integer, -42, "negate 42")
 , "- -42" ==> Right (ty @Integer, 42, "negate (negate 42)")
 , "1 + -2" ==> Right (ty @Integer, -1, "(\\x0 -> 1 + x0) (negate 2)")
 , "-1 + -2" ==> Right (ty @Integer, -3, "(\\x0 -> negate 1 + x0) (negate 2)")
 , "-(1 + -2)" ==> Right (ty @Integer, 1, "negate ((\\x0 -> 1 + x0) (negate 2))")
 , "(+) 1 2" ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2")
 , "1 + 2" ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2")
 , "1 + 2 - 3" ==> Right (ty @Integer, 0, "(\\x0 -> (\\x1 -> 1 + x1) 2 - x0) 3")
 , "1 + 2 * 3" ==> Right (ty @Integer, 7, "(\\x0 -> 1 + x0) ((\\x0 -> 2 * x0) 3)")
 , "3 * 2 + 1" ==> Right (ty @Integer, 7, "(\\x0 -> (\\x1 -> 3 * x1) 2 + x0) 1")
 , "3 * (2 + 1)" ==> Right (ty @Integer, 9, "(\\x0 -> 3 * x0) ((\\x0 -> 2 + x0) 1)")
 , "4 + 3 * 2 + 1" ==> Right (ty @Integer, 11,
	 "(\\x0 -> (\\x1 -> 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1")
 , "5 * 4 + 3 * 2 + 1" ==> Right (ty @Integer, 27,
	 "(\\x0 -> (\\x1 -> (\\x2 -> 5 * x2) 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1")
 , "negate`42" ==> Right (ty @Integer, -42, "negate 42")
 , "42`negate" ==> Right (ty @Integer, -42, "negate 42")
 , "42`negate " ==> Right (ty @Integer, -42, "negate 42")
 , "42`negate`negate" ==> Right (ty @Integer, 42, "negate (negate 42)")
 , "42`abs`negate" ==> Right (ty @Integer, -42, "negate (abs 42)")
 , "42`negate`abs" ==> Right (ty @Integer, 42, "abs (negate 42)")
 , "abs`negate`42" ==> Right (ty @Integer, 42, "abs (negate 42)")
 , "negate`abs`42" ==> Right (ty @Integer, -42, "negate (abs 42)")
 , "abs`42`negate" ==> Right (ty @Integer, 42, "abs (negate 42)")
 , "negate`42`abs" ==> Right (ty @Integer, 42, "abs (negate 42)")
 , "negate`abs`42`mod`9" ==> Right
	 (ty @Integer,3, "(\\x0 -> negate (abs 42) `mod` x0) 9")
 , "42`abs`negate`mod`abs`negate`9" ==> Right
	 (ty @Integer, 3, "(\\x0 -> negate (abs 42) `mod` x0) (abs (negate 9))")
 ]

-- | A newtype to test prefix and postfix.
newtype Num2 a = Num2 a

class Sym_Num2 (term:: * -> *) where

type instance Sym_of_Iface (Proxy Num2) = Sym_Num2
type instance Consts_of_Iface (Proxy Num2) = Proxy Num2 ': Consts_imported_by Num2
type instance Consts_imported_by Num2 = '[ Proxy Integer ]

instance Sym_Num2 HostI where
instance Sym_Num2 TextI where
instance Sym_Num2 (DupI r1 r2) where

instance
 ( Read_TypeNameR Type_Name cs rs
 , Inj_Const cs Num2
 ) => Read_TypeNameR Type_Name cs (Proxy Num2 ': rs) where
	read_typenameR _cs (Type_Name "Num2") k = k (ty @Num2)
	read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
instance Show_Const cs => Show_Const (Proxy Num2 ': cs) where
	show_const ConstZ{} = "Num2"
	show_const (ConstS c) = show_const c

instance Proj_ConC cs (Proxy Num2)
data instance TokenT meta (ts::[*]) (Proxy Num2)
deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num2))
deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num2))
instance CompileI is (Proxy Num2) where
	compileI _tok _ctx _k = undefined
instance -- TokenizeT
 Inj_Token meta ts Num =>
 TokenizeT meta ts (Proxy Num2) where
	tokenizeT _t = Monoid.mempty
	 { tokenizers_prefix = tokenizeTMod []
		 [ tokenize1 "abs"    (Prefix  9) Token_Term_Num_abs
		 , tokenize1 "negate" (Prefix 10) Token_Term_Num_negate
		 ]
	 , tokenizers_postfix = tokenizeTMod []
		 [ tokenize1 "abs"    (Postfix  9) Token_Term_Num_abs
		 , tokenize1 "negate" (Postfix 10) Token_Term_Num_negate
		 ]
	 }
instance Gram_Term_AtomsT meta ts (Proxy Num2) g