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_compile (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_app 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  ]