symantic-lib/Language/Symantic/Lib/Num/Test.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# LANGUAGE StandaloneDeriving #-}
   3 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Lib.Num.Test where
   6
   7 import Test.Tasty
   8
   9 import Prelude (Num)
  10 import Prelude hiding (Num(..))
  11
  12 import Language.Symantic
  13 import Language.Symantic.Lib
  14 import Compiling.Test
  15
  16 -- * Tests
  17 type SS =
  18  [ Proxy (->)
  19  , Proxy Integer
  20  , Proxy Num
  21  , Proxy Num2
  22  , Proxy Int
  23  , Proxy Integral
  24  , Proxy Foldable
  25  , Proxy Traversable
  26  , Proxy []
  27  ]
  28 (==>) = test_readTerm @() @SS
  29
  30 tests :: TestTree
  31 tests = testGroup "Num"
  32  [ "42"                        ==> Right (tyInteger,  42, "42")
  33  , "-42"                       ==> Right (tyInteger, -42, "negate 42")
  34  , "- -42"                     ==> Right (tyInteger,  42, "negate (negate 42)")
  35  , "1 + -2"                    ==> Right (tyInteger,  -1, "1 + negate 2")
  36  , "-1 + -2"                   ==> Right (tyInteger,  -3, "negate 1 + negate 2")
  37  , "-(1 + -2)"                 ==> Right (tyInteger,   1, "negate (1 + negate 2)")
  38  , "(+) 1 2"                   ==> Right (tyInteger,   3, "1 + 2")
  39  , "1 + 2"                     ==> Right (tyInteger,   3, "1 + 2")
  40  , "1 + 2 - 3"                 ==> Right (tyInteger,   0, "1 + 2 - 3")
  41  , "1 + 2 * 3"                 ==> Right (tyInteger,   7, "1 + 2 * 3")
  42  , "3 * 2 + 1"                 ==> Right (tyInteger,   7, "3 * 2 + 1")
  43  , "3 * (2 + 1)"               ==> Right (tyInteger,   9, "3 * (2 + 1)")
  44  , "4 + 3 * 2 + 1"             ==> Right (tyInteger,  11, "4 + 3 * 2 + 1")
  45  , "5 * 4 + 3 * 2 + 1"         ==> Right (tyInteger,  27, "5 * 4 + 3 * 2 + 1")
  46  , "negate`42"                 ==> Right (tyInteger, -42, "negate 42")
  47  , "42`negate"                 ==> Right (tyInteger, -42, "negate 42")
  48  , "42`negate "                ==> Right (tyInteger, -42, "negate 42")
  49  , "42`negate`negate"          ==> Right (tyInteger,  42, "negate (negate 42)")
  50  , "42`abs`negate"             ==> Right (tyInteger, -42, "negate (abs 42)")
  51  , "42`negate`abs"             ==> Right (tyInteger,  42, "abs (negate 42)")
  52  , "abs`negate`42"             ==> Right (tyInteger,  42, "abs (negate 42)")
  53  , "negate`abs`42"             ==> Right (tyInteger, -42, "negate (abs 42)")
  54  , "negate`abs`42`mod`9"       ==> Right (tyInteger,   3, "negate (abs 42) `mod` 9")
  55  , "negate abs`42"             ==> Right (tyInteger, -42, "negate (abs 42)")
  56  , "negate 42`abs"             ==> Right (tyInteger, -42, "negate (abs 42)")
  57  , "(+) negate`2 44"           ==> Right (tyInteger,  42, "negate 2 + 44")
  58  , "(+) 2`negate 44"           ==> Right (tyInteger,  42, "negate 2 + 44")
  59  , "(+) (negate`2) 44"         ==> Right (tyInteger,  42, "negate 2 + 44")
  60  , "abs negate`42"             ==> Right (tyInteger,  42, "abs (negate 42)")
  61  , "(+) 40 2"                  ==> Right (tyInteger,  42, "40 + 2")
  62  , "(+) 40 -2"                 ==> Right (tyInteger,  38, "40 + negate 2")
  63  , "negate 42 + 42`negate"     ==> Right (tyInteger, -84, "negate 42 + negate 42")
  64  , "(+) (negate 42) 42`negate" ==> Right (tyInteger, -84, "negate 42 + negate 42")
  65  , "(+) negate`42 42`negate"   ==> Right (tyInteger, -84, "negate 42 + negate 42")
  66  , "42`abs`negate`mod`abs`negate`9" ==> Right (tyInteger, 3, "negate (abs 42) `mod` abs (negate 9)")
  67  , "abs`42`negate"             ==> Right (tyInteger,  42, "abs (negate 42)")
  68  , "negate`42`abs"             ==> Right (tyInteger,  42, "abs (negate 42)")
  69  , testGroup "Error_Term"
  70          [ "(+) 40 - 2" ==> Left (tyInteger,
  71                 Right $ Error_Term_Beta $ Error_Beta_Unify $
  72                 Error_Unify_Const_mismatch
  73                  (TypeVT $ tyFun @_ @'[])
  74                  (TypeVT $ tyInteger @_ @'[]))
  75          ]
  76  ]
  77
  78 -- | A newtype to test prefix and postfix.
  79 newtype Num2 a = Num2 a
  80 type instance Sym (Proxy Num2) = Sym_Num2
  81 class Sym_Num2 (term:: * -> *) where
  82
  83 instance Sym_Num2 Eval where
  84 instance Sym_Num2 View where
  85 instance Sym_Num2 (Dup r1 r2) where
  86 instance Sym_Num2 term => Sym_Num2 (BetaT term) where
  87 instance FixityOf Num2
  88 instance ClassInstancesFor Num2
  89 instance TypeInstancesFor Num2
  90 instance Gram_Term_AtomsFor src ss g Num2
  91 instance (Source src, Inj_Sym ss Num) => ModuleFor src ss Num2 where
  92         moduleFor _s = ["Num2"] `moduleWhere`
  93          [ "abs"    `withPrefix`   9 := teNum_abs
  94          , "negate" `withPrefix`  10 := teNum_negate
  95          , "abs"    `withPostfix`  9 := teNum_abs
  96          , "negate" `withPostfix` 10 := teNum_negate
  97          ]