Language/Symantic/Compiling/Functor/Test.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   5 module Compiling.Functor.Test where
   6
   7 import Test.Tasty
   8
   9 import Data.Proxy (Proxy(..))
  10 import Data.Text (Text)
  11 import Prelude hiding ((&&), not, (||))
  12
  13 import Language.Symantic.Parsing
  14 import Language.Symantic.Typing
  15 import Language.Symantic.Compiling
  16 import Compiling.Term.Test
  17 import Compiling.Bool.Test ()
  18 import Parsing.Test
  19
  20 -- * Tests
  21 type Ifaces =
  22  [ Proxy (->)
  23  , Proxy Bool
  24  , Proxy Maybe
  25  , Proxy Functor
  26  ]
  27 (==>) = test_term_from (Proxy::Proxy Ifaces)
  28
  29 instance
  30  ( Inj_Token (Syntax Text) ts Functor
  31  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
  32  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Functor) where
  33         tokenizeT _t (Syntax "fmap" (ast_f : ast_m : as)) = Just $ do
  34                 f <- tokenize ast_f
  35                 m <- tokenize ast_m
  36                 Right $ (as,) $ EToken $ inj_token (Syntax "fmap" [ast_f, ast_m]) $
  37                         Token_Term_Functor_fmap f m
  38         tokenizeT _t (Syntax "(<$)" (ast_a : ast_fb : as)) = Just $ do
  39                 a  <- tokenize ast_a
  40                 fb <- tokenize ast_fb
  41                 Right $ (as,) $ EToken $ inj_token (Syntax "fmap" [ast_a, ast_fb]) $
  42                         Token_Term_Functor_ltdollar a fb
  43         tokenizeT _t _sy = Nothing
  44
  45 tests :: TestTree
  46 tests = testGroup "Functor"
  47  [ Syntax "fmap"
  48          [ syLam "x" (sy @Bool)
  49                  (Syntax "not" [syVar "x"])
  50          , Syntax "Just" [syLit True]
  51          ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "fmap (\\x0 -> (\\x1 -> not x1) x0) (Just True)")
  52  , Syntax "(<$)"
  53          [ syLit False
  54          , Syntax "Just" [syLit True]
  55          ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "False <$ Just True")
  56  ]