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

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