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