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