{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Lib.Num.Test where
import Test.Tasty
-import qualified Data.Monoid as Monoid
-import Data.Proxy (Proxy(..))
import Prelude (Num)
import Prelude hiding (Num(..))
-import Language.Symantic.Parsing
-import Language.Symantic.Typing
-import Language.Symantic.Compiling
-import Language.Symantic.Interpreting
-import Language.Symantic.Lib.Num
-import Compiling.Term.Test
+import Language.Symantic
+import Language.Symantic.Lib
+import Compiling.Test
-- * Tests
-type Ifaces =
+type SS =
[ Proxy (->)
, Proxy Integer
, Proxy Num
, Proxy Traversable
, Proxy []
]
-(==>) = test_compile @Ifaces
+(==>) = test_readTerm @() @SS
tests :: TestTree
tests = testGroup "Num"
- [ "42" ==> Right (ty @Integer, 42, "42")
- , "-42" ==> Right (ty @Integer, -42, "negate 42")
- , "- -42" ==> Right (ty @Integer, 42, "negate (negate 42)")
- , "1 + -2" ==> Right (ty @Integer, -1, "(\\x0 -> 1 + x0) (negate 2)")
- , "-1 + -2" ==> Right (ty @Integer, -3, "(\\x0 -> negate 1 + x0) (negate 2)")
- , "-(1 + -2)" ==> Right (ty @Integer, 1, "negate ((\\x0 -> 1 + x0) (negate 2))")
- , "(+) 1 2" ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2")
- , "1 + 2" ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2")
- , "1 + 2 - 3" ==> Right (ty @Integer, 0, "(\\x0 -> (\\x1 -> 1 + x1) 2 - x0) 3")
- , "1 + 2 * 3" ==> Right (ty @Integer, 7, "(\\x0 -> 1 + x0) ((\\x0 -> 2 * x0) 3)")
- , "3 * 2 + 1" ==> Right (ty @Integer, 7, "(\\x0 -> (\\x1 -> 3 * x1) 2 + x0) 1")
- , "3 * (2 + 1)" ==> Right (ty @Integer, 9, "(\\x0 -> 3 * x0) ((\\x0 -> 2 + x0) 1)")
- , "4 + 3 * 2 + 1" ==> Right (ty @Integer, 11,
- "(\\x0 -> (\\x1 -> 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1")
- , "5 * 4 + 3 * 2 + 1" ==> Right (ty @Integer, 27,
- "(\\x0 -> (\\x1 -> (\\x2 -> 5 * x2) 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1")
- , "negate`42" ==> Right (ty @Integer, -42, "negate 42")
- , "42`negate" ==> Right (ty @Integer, -42, "negate 42")
- , "42`negate " ==> Right (ty @Integer, -42, "negate 42")
- , "42`negate`negate" ==> Right (ty @Integer, 42, "negate (negate 42)")
- , "42`abs`negate" ==> Right (ty @Integer, -42, "negate (abs 42)")
- , "42`negate`abs" ==> Right (ty @Integer, 42, "abs (negate 42)")
- , "abs`negate`42" ==> Right (ty @Integer, 42, "abs (negate 42)")
- , "negate`abs`42" ==> Right (ty @Integer, -42, "negate (abs 42)")
- , "abs`42`negate" ==> Right (ty @Integer, 42, "abs (negate 42)")
- , "negate`42`abs" ==> Right (ty @Integer, 42, "abs (negate 42)")
- , "negate`abs`42`mod`9" ==> Right
- (ty @Integer,3, "(\\x0 -> negate (abs 42) `mod` x0) 9")
- , "42`abs`negate`mod`abs`negate`9" ==> Right
- (ty @Integer, 3, "(\\x0 -> negate (abs 42) `mod` x0) (abs (negate 9))")
+ [ "42" ==> Right (tyInteger, 42, "42")
+ , "-42" ==> Right (tyInteger, -42, "negate 42")
+ , "- -42" ==> Right (tyInteger, 42, "negate (negate 42)")
+ , "1 + -2" ==> Right (tyInteger, -1, "1 + negate 2")
+ , "-1 + -2" ==> Right (tyInteger, -3, "negate 1 + negate 2")
+ , "-(1 + -2)" ==> Right (tyInteger, 1, "negate (1 + negate 2)")
+ , "(+) 1 2" ==> Right (tyInteger, 3, "1 + 2")
+ , "1 + 2" ==> Right (tyInteger, 3, "1 + 2")
+ , "1 + 2 - 3" ==> Right (tyInteger, 0, "1 + 2 - 3")
+ , "1 + 2 * 3" ==> Right (tyInteger, 7, "1 + 2 * 3")
+ , "3 * 2 + 1" ==> Right (tyInteger, 7, "3 * 2 + 1")
+ , "3 * (2 + 1)" ==> Right (tyInteger, 9, "3 * (2 + 1)")
+ , "4 + 3 * 2 + 1" ==> Right (tyInteger, 11, "4 + 3 * 2 + 1")
+ , "5 * 4 + 3 * 2 + 1" ==> Right (tyInteger, 27, "5 * 4 + 3 * 2 + 1")
+ , "negate`42" ==> Right (tyInteger, -42, "negate 42")
+ , "42`negate" ==> Right (tyInteger, -42, "negate 42")
+ , "42`negate " ==> Right (tyInteger, -42, "negate 42")
+ , "42`negate`negate" ==> Right (tyInteger, 42, "negate (negate 42)")
+ , "42`abs`negate" ==> Right (tyInteger, -42, "negate (abs 42)")
+ , "42`negate`abs" ==> Right (tyInteger, 42, "abs (negate 42)")
+ , "abs`negate`42" ==> Right (tyInteger, 42, "abs (negate 42)")
+ , "negate`abs`42" ==> Right (tyInteger, -42, "negate (abs 42)")
+ , "negate`abs`42`mod`9" ==> Right (tyInteger, 3, "negate (abs 42) `mod` 9")
+ , "negate abs`42" ==> Right (tyInteger, -42, "negate (abs 42)")
+ , "negate 42`abs" ==> Right (tyInteger, -42, "negate (abs 42)")
+ , "(+) negate`2 44" ==> Right (tyInteger, 42, "negate 2 + 44")
+ , "(+) 2`negate 44" ==> Right (tyInteger, 42, "negate 2 + 44")
+ , "(+) (negate`2) 44" ==> Right (tyInteger, 42, "negate 2 + 44")
+ , "abs negate`42" ==> Right (tyInteger, 42, "abs (negate 42)")
+ , "(+) 40 2" ==> Right (tyInteger, 42, "40 + 2")
+ , "(+) 40 -2" ==> Right (tyInteger, 38, "40 + negate 2")
+ , "negate 42 + 42`negate" ==> Right (tyInteger, -84, "negate 42 + negate 42")
+ , "(+) (negate 42) 42`negate" ==> Right (tyInteger, -84, "negate 42 + negate 42")
+ , "(+) negate`42 42`negate" ==> Right (tyInteger, -84, "negate 42 + negate 42")
+ , "42`abs`negate`mod`abs`negate`9" ==> Right (tyInteger, 3, "negate (abs 42) `mod` abs (negate 9)")
+ , "abs`42`negate" ==> Right (tyInteger, 42, "abs (negate 42)")
+ , "negate`42`abs" ==> Right (tyInteger, 42, "abs (negate 42)")
+ , testGroup "Error_Term"
+ [ "(+) 40 - 2" ==> Left (tyInteger,
+ Right $ Error_Term_Beta $ Error_Beta_Unify $
+ Error_Unify_Const_mismatch
+ (TypeVT $ tyFun @_ @'[])
+ (TypeVT $ tyInteger @_ @'[]))
+ ]
]
-- | A newtype to test prefix and postfix.
newtype Num2 a = Num2 a
-
+type instance Sym Num2 = Sym_Num2
class Sym_Num2 (term:: * -> *) where
-type instance Sym_of_Iface (Proxy Num2) = Sym_Num2
-type instance TyConsts_of_Iface (Proxy Num2) = Proxy Num2 ': TyConsts_imported_by (Proxy Num2)
-type instance TyConsts_imported_by (Proxy Num2) = '[ Proxy Integer ]
-
-instance Sym_Num2 HostI where
-instance Sym_Num2 TextI where
-instance Sym_Num2 (DupI r1 r2) where
-
-instance
- ( Read_TyNameR TyName cs rs
- , Inj_TyConst cs Num2
- ) => Read_TyNameR TyName cs (Proxy Num2 ': rs) where
- read_TyNameR _cs (TyName "Num2") k = k (ty @Num2)
- read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
-instance Show_TyConst cs => Show_TyConst (Proxy Num2 ': cs) where
- show_TyConst TyConstZ{} = "Num2"
- show_TyConst (TyConstS c) = show_TyConst c
-
-instance Proj_TyConC cs (Proxy Num2)
-data instance TokenT meta (ts::[*]) (Proxy Num2)
-deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num2))
-deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num2))
-instance CompileI cs is (Proxy Num2) where
- compileI _tok _ctx _k = undefined
-instance -- TokenizeT
- Inj_Token meta ts Num =>
- TokenizeT meta ts (Proxy Num2) where
- tokenizeT _t = Monoid.mempty
- { tokenizers_prefix = tokenizeTMod []
- [ tokenize1 "abs" (Prefix 9) Token_Term_Num_abs
- , tokenize1 "negate" (Prefix 10) Token_Term_Num_negate
- ]
- , tokenizers_postfix = tokenizeTMod []
- [ tokenize1 "abs" (Postfix 9) Token_Term_Num_abs
- , tokenize1 "negate" (Postfix 10) Token_Term_Num_negate
- ]
- }
-instance Gram_Term_AtomsT meta ts (Proxy Num2) g
+instance Sym_Num2 Eval where
+instance Sym_Num2 View where
+instance Sym_Num2 (Dup r1 r2) where
+instance Sym_Num2 term => Sym_Num2 (BetaT term) where
+instance FixityOf Num2
+instance ClassInstancesFor Num2
+instance TypeInstancesFor Num2
+instance Gram_Term_AtomsFor src ss g Num2
+instance (Source src, Inj_Sym ss Num) => ModuleFor src ss Num2 where
+ moduleFor = ["Num2"] `moduleWhere`
+ [ "abs" `withPrefix` 9 := teNum_abs
+ , "negate" `withPrefix` 10 := teNum_negate
+ , "abs" `withPostfix` 9 := teNum_abs
+ , "negate" `withPostfix` 10 := teNum_negate
+ ]
sourcephile / git / haskell / symantic.git / blobdiff