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 qualified Data.Monoid as Monoid
  10 import Data.Proxy (Proxy(..))
  11 import Prelude (Num)
  12 import Prelude hiding (Num(..))
  13
  14 import Language.Symantic.Parsing
  15 import Language.Symantic.Typing
  16 import Language.Symantic.Compiling
  17 import Language.Symantic.Interpreting
  18 import Language.Symantic.Lib.Lambda ((~>))
  19 import Language.Symantic.Lib.Num
  20 import Compiling.Term.Test
  21
  22 -- * Tests
  23 type Ifaces =
  24  [ Proxy (->)
  25  , Proxy Integer
  26  , Proxy Num
  27  , Proxy Num2
  28  , Proxy Int
  29  , Proxy Integral
  30  , Proxy Foldable
  31  , Proxy Traversable
  32  , Proxy []
  33  ]
  34 (==>) = test_compile @Ifaces
  35
  36 tests :: TestTree
  37 tests = testGroup "Num"
  38  [ "42"                ==> Right (ty @Integer, 42, "42")
  39  , "-42"               ==> Right (ty @Integer, -42, "negate 42")
  40  , "- -42"             ==> Right (ty @Integer, 42, "negate (negate 42)")
  41  , "1 + -2"            ==> Right (ty @Integer, -1, "(\\x0 -> 1 + x0) (negate 2)")
  42  , "-1 + -2"           ==> Right (ty @Integer, -3, "(\\x0 -> negate 1 + x0) (negate 2)")
  43  , "-(1 + -2)"         ==> Right (ty @Integer, 1, "negate ((\\x0 -> 1 + x0) (negate 2))")
  44  , "(+) 1 2"           ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2")
  45  , "1 + 2"             ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2")
  46  , "1 + 2 - 3"         ==> Right (ty @Integer, 0, "(\\x0 -> (\\x1 -> 1 + x1) 2 - x0) 3")
  47  , "1 + 2 * 3"         ==> Right (ty @Integer, 7, "(\\x0 -> 1 + x0) ((\\x0 -> 2 * x0) 3)")
  48  , "3 * 2 + 1"         ==> Right (ty @Integer, 7, "(\\x0 -> (\\x1 -> 3 * x1) 2 + x0) 1")
  49  , "3 * (2 + 1)"       ==> Right (ty @Integer, 9, "(\\x0 -> 3 * x0) ((\\x0 -> 2 + x0) 1)")
  50  , "4 + 3 * 2 + 1"     ==> Right (ty @Integer, 11,
  51          "(\\x0 -> (\\x1 -> 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1")
  52  , "5 * 4 + 3 * 2 + 1" ==> Right (ty @Integer, 27,
  53          "(\\x0 -> (\\x1 -> (\\x2 -> 5 * x2) 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1")
  54  , "negate`42"         ==> Right (ty @Integer, -42, "negate 42")
  55  , "42`negate"         ==> Right (ty @Integer, -42, "negate 42")
  56  , "42`negate "        ==> Right (ty @Integer, -42, "negate 42")
  57  , "42`negate`negate"  ==> Right (ty @Integer, 42, "negate (negate 42)")
  58  , "42`abs`negate"     ==> Right (ty @Integer, -42, "negate (abs 42)")
  59  , "42`negate`abs"     ==> Right (ty @Integer, 42, "abs (negate 42)")
  60  , "abs`negate`42"     ==> Right (ty @Integer, 42, "abs (negate 42)")
  61  , "negate`abs`42"     ==> Right (ty @Integer, -42, "negate (abs 42)")
  62  , "abs`42`negate"     ==> Right (ty @Integer, 42, "abs (negate 42)")
  63  , "negate`42`abs"     ==> Right (ty @Integer, 42, "abs (negate 42)")
  64  , "negate`abs`42`mod`9" ==> Right
  65          (ty @Integer,3, "(\\x0 -> negate (abs 42) `mod` x0) 9")
  66  , "42`abs`negate`mod`abs`negate`9" ==> Right
  67          (ty @Integer, 3, "(\\x0 -> negate (abs 42) `mod` x0) (abs (negate 9))")
  68  , "negate abs`42"             ==> Right (ty @Integer, -42, "negate (abs 42)")
  69  , "negate 42`abs"             ==> Right (ty @Integer, -42, "negate (abs 42)")
  70  , "negate 42 + 42`negate"     ==> Right (ty @Integer, -84, "(\\x0 -> negate 42 + x0) (negate 42)")
  71  , "(+) (negate 42) 42`negate" ==> Right (ty @Integer, -84, "(\\x0 -> negate 42 + x0) (negate 42)")
  72  , "(+) negate`42 42`negate"   ==> Right (ty @Integer, -84, "(\\x0 -> negate 42 + x0) (negate 42)")
  73  , "(+) negate`2 44"           ==> Right (ty @Integer,  42, "(\\x0 -> negate 2 + x0) 44")
  74  , "(+) 2`negate 44"           ==> Right (ty @Integer,  42, "(\\x0 -> negate 2 + x0) 44")
  75  , "(+) (negate`2) 44"         ==> Right (ty @Integer,  42, "(\\x0 -> negate 2 + x0) 44")
  76  , "abs negate`42"             ==> Right (ty @Integer,  42, "abs (negate 42)")
  77  , "(+) 40 2"                  ==> Right (ty @Integer,  42, "(\\x0 -> 40 + x0) 2")
  78  , "(+) 40 -2"                 ==> Right (ty @Integer,  38, "(\\x0 -> 40 + x0) (negate 2)")
  79  , testGroup "Error_Term"
  80          [ "(+) 40 - 2" ==> Left (ty @Integer,
  81                 Right $ Error_Term_Con_Type $ Right $ Con_TyCon $
  82                 At (maybeRight $ test_tokenizer "(+) 40") $
  83                 KType $ ty @Num :$ (ty @Integer ~> ty @Integer))
  84          ]
  85  ]
  86
  87 -- | A newtype to test prefix and postfix.
  88 newtype Num2 a = Num2 a
  89
  90 class Sym_Num2 (term:: * -> *) where
  91
  92 type instance Sym_of_Iface (Proxy Num2) = Sym_Num2
  93 type instance TyConsts_of_Iface (Proxy Num2) = Proxy Num2 ': TyConsts_imported_by (Proxy Num2)
  94 type instance TyConsts_imported_by (Proxy Num2) = '[ Proxy Integer ]
  95
  96 instance Sym_Num2 HostI where
  97 instance Sym_Num2 TextI where
  98 instance Sym_Num2 (DupI r1 r2) where
  99
 100 instance
 101  ( Read_TyNameR TyName cs rs
 102  , Inj_TyConst cs Num2
 103  ) => Read_TyNameR TyName cs (Proxy Num2 ': rs) where
 104         read_TyNameR _cs (TyName "Num2") k = k (ty @Num2)
 105         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
 106 instance Show_TyConst cs => Show_TyConst (Proxy Num2 ': cs) where
 107         show_TyConst TyConstZ{} = "Num2"
 108         show_TyConst (TyConstS c) = show_TyConst c
 109
 110 instance Proj_TyConC cs (Proxy Num2)
 111 data instance TokenT meta (ts::[*]) (Proxy Num2)
 112 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num2))
 113 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num2))
 114 instance CompileI cs is (Proxy Num2) where
 115         compileI _tok _ctx _k = undefined
 116 instance -- TokenizeT
 117  Inj_Token meta ts Num =>
 118  TokenizeT meta ts (Proxy Num2) where
 119         tokenizeT _t = Monoid.mempty
 120          { tokenizers_prefix = tokenizeTMod []
 121                  [ tokenize1 "abs"    (Prefix  9) Token_Term_Num_abs
 122                  , tokenize1 "negate" (Prefix 10) Token_Term_Num_negate
 123                  ]
 124          , tokenizers_postfix = tokenizeTMod []
 125                  [ tokenize1 "abs"    (Postfix  9) Token_Term_Num_abs
 126                  , tokenize1 "negate" (Postfix 10) Token_Term_Num_negate
 127                  ]
 128          }
 129 instance Gram_Term_AtomsT meta ts (Proxy Num2) g