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 - 3"                 ==> Right (tyInteger,   0, "1 + 2 - 3")
  40  , "1 + 2 * 3"                 ==> Right (tyInteger,   7, "1 + 2 * 3")
  41  , "3 * 2 + 1"                 ==> Right (tyInteger,   7, "3 * 2 + 1")
  42  , "3 * (2 + 1)"               ==> Right (tyInteger,   9, "3 * (2 + 1)")
  43  , "4 + 3 * 2 + 1"             ==> Right (tyInteger,  11, "4 + 3 * 2 + 1")
  44  , "5 * 4 + 3 * 2 + 1"         ==> Right (tyInteger,  27, "5 * 4 + 3 * 2 + 1")
  45  , "negate`42"                 ==> Right (tyInteger, -42, "negate 42")
  46  , "42`negate"                 ==> Right (tyInteger, -42, "negate 42")
  47  , "42`negate "                ==> Right (tyInteger, -42, "negate 42")
  48  , "42`negate`negate"          ==> Right (tyInteger,  42, "negate (negate 42)")
  49  , "42`abs`negate"             ==> Right (tyInteger, -42, "negate (abs 42)")
  50  , "42`negate`abs"             ==> Right (tyInteger,  42, "abs (negate 42)")
  51  , "abs`negate`42"             ==> Right (tyInteger,  42, "abs (negate 42)")
  52  , "negate`abs`42"             ==> Right (tyInteger, -42, "negate (abs 42)")
  53  , "negate`abs`42`mod`9"       ==> Right (tyInteger,   3, "negate (abs 42) `mod` 9")
  54  , "negate abs`42"             ==> Right (tyInteger, -42, "negate (abs 42)")
  55  , "negate 42`abs"             ==> Right (tyInteger, -42, "negate (abs 42)")
  56  , "(+) negate`2 44"           ==> Right (tyInteger,  42, "negate 2 + 44")
  57  , "(+) 2`negate 44"           ==> Right (tyInteger,  42, "negate 2 + 44")
  58  , "(+) (negate`2) 44"         ==> Right (tyInteger,  42, "negate 2 + 44")
  59  , "abs negate`42"             ==> Right (tyInteger,  42, "abs (negate 42)")
  60  , "(+) 40 2"                  ==> Right (tyInteger,  42, "40 + 2")
  61  , "(+) 40 -2"                 ==> Right (tyInteger,  38, "40 + negate 2")
  62  , "negate 42 + 42`negate"     ==> Right (tyInteger, -84, "negate 42 + negate 42")
  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  , "42`abs`negate`mod`abs`negate`9" ==> Right (tyInteger, 3, "negate (abs 42) `mod` abs (negate 9)")
  66  , "abs`42`negate"             ==> Right (tyInteger,  42, "abs (negate 42)")
  67  , "negate`42`abs"             ==> Right (tyInteger,  42, "abs (negate 42)")
  68  , testGroup "Error_Term"
  69          [ "(+) 40 - 2" ==> Left (tyInteger,
  70                 Right $ Error_Term_Beta $ Error_Beta_Unify $
  71                 Error_Unify_Const_mismatch
  72                  (TypeVT $ tyFun @_ @'[])
  73                  (TypeVT $ tyInteger @_ @'[]))
  74          ]
  75  ]
  76
  77 -- | A newtype to test prefix and postfix.
  78 newtype Num2 a = Num2 a
  79 type instance Sym Num2 = Sym_Num2
  80 class Sym_Num2 (term:: * -> *) where
  81
  82 instance Sym_Num2 Eval where
  83 instance Sym_Num2 View where
  84 instance Sym_Num2 (Dup r1 r2) where
  85 instance Sym_Num2 term => Sym_Num2 (BetaT term) where
  86 instance NameTyOf Num2 where
  87         nameTyOf _c = ["Num2"] `Mod` "Num2"
  88 instance FixityOf Num2
  89 instance ClassInstancesFor Num2
  90 instance TypeInstancesFor Num2
  91 instance Gram_Term_AtomsFor src ss g Num2
  92 instance (Source src, SymInj ss Num) => ModuleFor src ss Num2 where
  93         moduleFor = ["Num2"] `moduleWhere`
  94          [ "abs"    `withPrefix`   9 := teNum_abs
  95          , "negate" `withPrefix`  10 := teNum_negate
  96          , "abs"    `withPostfix`  9 := teNum_abs
  97          , "negate" `withPostfix` 10 := teNum_negate
  98          ]