symantic-lib/test/HUnit/Num.hs

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