]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Compiling/Applicative/Test.hs
Add Parsing.Token.
[haskell/symantic.git] / Language / Symantic / Compiling / Applicative / Test.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
4 module Compiling.Applicative.Test where
5
6 import Test.Tasty
7
8 import Data.Proxy (Proxy(..))
9 import Data.Text (Text)
10 import Prelude hiding ((&&), not, (||))
11
12 import Language.Symantic.Parsing
13 import Language.Symantic.Typing
14 import Language.Symantic.Compiling
15 import Compiling.Term.Test
16 import Compiling.Bool.Test ()
17 import Parsing.Test
18
19 -- * Tests
20 type Ifaces =
21 [ Proxy (->)
22 , Proxy Bool
23 , Proxy Maybe
24 , Proxy Applicative
25 ]
26 (==>) = test_term_from (Proxy::Proxy Ifaces)
27
28 instance
29 ( Inj_Token (Syntax Text) ts Applicative
30 , Tokenize (Syntax Text) (Syntax Text) ts ) =>
31 TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Applicative) where
32 tokenizeT _t (Syntax "(<*>)" (ast_fa2b : as)) = Just $ do
33 fa2b <- tokenize ast_fa2b
34 Right $ (as,) $ EToken $ inj_token (Syntax "(<*>)" [ast_fa2b]) $
35 Token_Term_Applicative_ltstargt fa2b
36 tokenizeT _t (Syntax "(<*)" (ast_fa : ast_fb : as)) = Just $ do
37 fa <- tokenize ast_fa
38 fb <- tokenize ast_fb
39 Right $ (as,) $ EToken $ inj_token (Syntax "(<*)" [ast_fa, ast_fb]) $
40 Token_Term_Applicative_ltstar fa fb
41 tokenizeT _t (Syntax "(*>)" (ast_fa : ast_fb : as)) = Just $ do
42 fa <- tokenize ast_fa
43 fb <- tokenize ast_fb
44 Right $ (as,) $ EToken $ inj_token (Syntax "(*>)" [ast_fa, ast_fb]) $
45 Token_Term_Applicative_stargt fa fb
46 tokenizeT _t _sy = Nothing
47
48 tests :: TestTree
49 tests = testGroup "Applicative"
50 [ Syntax "(<*>)"
51 [ Syntax "Just" [Syntax "xor" [syLit True]]
52 , Syntax "Just" [syLit True]
53 ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "(\\x0 -> Just ((\\x1 -> (\\x2 -> x1 `xor` x2)) True) <*> x0) (Just True)")
54 , Syntax "(*>)"
55 [ Syntax "Just" [syLit False]
56 , Syntax "Just" [syLit True]
57 ] ==> Right (ty @Maybe :$ ty @Bool, Just True, "Just False *> Just True")
58 , Syntax "(<*)"
59 [ Syntax "Just" [syLit False]
60 , Syntax "Just" [syLit True]
61 ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "Just False <* Just True")
62 ]