]> Git — Sourcephile - haskell/symantic.git/blob - symantic-lib/Language/Symantic/Lib/Num/Test.hs
Fix comment typo.
[haskell/symantic.git] / 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 Num2
76 type instance TyConsts_imported_by 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 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