Language/Symantic/Lib/Num/Test.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   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.Parsing.Grammar
  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 Consts_of_Iface (Proxy Num2) = Proxy Num2 ': Consts_imported_by Num2
  77 type instance Consts_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_TypeNameR Type_Name cs rs
  85  , Inj_Const cs Num2
  86  ) => Read_TypeNameR Type_Name cs (Proxy Num2 ': rs) where
  87         read_typenameR _cs (Type_Name "Num2") k = k (ty @Num2)
  88         read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
  89 instance Show_Const cs => Show_Const (Proxy Num2 ': cs) where
  90         show_const ConstZ{} = "Num2"
  91         show_const (ConstS c) = show_const c
  92
  93 instance Proj_ConC 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