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

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   3 {-# OPTIONS_GHC -O0 -fmax-simplifier-iterations=0 #-}
   4 {-# LANGUAGE UndecidableInstances #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 module Lib.Num.Test where
   7
   8 import Test.Tasty
   9
  10 import qualified Data.Monoid as Monoid
  11 import Data.Proxy (Proxy(..))
  12 import Prelude (Num)
  13 import Prelude hiding (Num(..))
  14
  15 import Language.Symantic.Parsing
  16 import Language.Symantic.Typing
  17 import Language.Symantic.Compiling
  18 import Language.Symantic.Interpreting
  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  ]
  69
  70 -- | A newtype to test prefix and postfix.
  71 newtype Num2 a = Num2 a
  72
  73 class Sym_Num2 (term:: * -> *) where
  74
  75 type instance Sym_of_Iface (Proxy Num2) = Sym_Num2
  76 type instance TyConsts_of_Iface (Proxy Num2) = Proxy Num2 ': TyConsts_imported_by Num2
  77 type instance TyConsts_imported_by Num2 = '[ Proxy Integer ]
  78
  79 instance Sym_Num2 HostI where
  80 instance Sym_Num2 TextI where
  81 instance Sym_Num2 (DupI r1 r2) where
  82
  83 instance
  84  ( Read_TyNameR TyName cs rs
  85  , Inj_TyConst cs Num2
  86  ) => Read_TyNameR TyName cs (Proxy Num2 ': rs) where
  87         read_TyNameR _cs (TyName "Num2") k = k (ty @Num2)
  88         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  89 instance Show_TyConst cs => Show_TyConst (Proxy Num2 ': cs) where
  90         show_TyConst TyConstZ{} = "Num2"
  91         show_TyConst (TyConstS c) = show_TyConst c
  92
  93 instance Proj_TyConC cs (Proxy Num2)
  94 data instance TokenT meta (ts::[*]) (Proxy Num2)
  95 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num2))
  96 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num2))
  97 instance CompileI is (Proxy Num2) where
  98         compileI _tok _ctx _k = undefined
  99 instance -- TokenizeT
 100  Inj_Token meta ts Num =>
 101  TokenizeT meta ts (Proxy Num2) where
 102         tokenizeT _t = Monoid.mempty
 103          { tokenizers_prefix = tokenizeTMod []
 104                  [ tokenize1 "abs"    (Prefix  9) Token_Term_Num_abs
 105                  , tokenize1 "negate" (Prefix 10) Token_Term_Num_negate
 106                  ]
 107          , tokenizers_postfix = tokenizeTMod []
 108                  [ tokenize1 "abs"    (Postfix  9) Token_Term_Num_abs
 109                  , tokenize1 "negate" (Postfix 10) Token_Term_Num_negate
 110                  ]
 111          }
 112 instance Gram_Term_AtomsT meta ts (Proxy Num2) g