Language/Symantic/Expr/Maybe/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeOperators #-}
   7 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   8 module Expr.Maybe.Test where
   9
  10 import Test.Tasty
  11 import Test.Tasty.HUnit
  12
  13 import qualified Control.Arrow as Arrow
  14 import qualified Control.Monad as Monad
  15 import Data.Proxy (Proxy(..))
  16 import Data.Text (Text)
  17 import Data.Type.Equality ((:~:)(Refl))
  18 import Prelude hiding (maybe, not)
  19
  20 import Language.Symantic.Repr
  21 import Language.Symantic.Expr
  22 import Language.Symantic.Type
  23
  24 import AST.Test
  25
  26 -- * Expressions
  27 e1 = maybe (bool True) (lam not) (just $ bool True)
  28
  29 -- * Tests
  30 type Ex = Expr_Root
  31  (   Expr_Lambda
  32  .|. Expr_Maybe
  33  .|. Expr_Bool
  34  )
  35 ex_from = root_expr_from (Proxy::Proxy Ex)
  36
  37 (==>) ast expected =
  38         testCase (show ast) $
  39         case ex_from ast of
  40          Left err -> Left err @?= Prelude.snd `Arrow.left` expected
  41          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  42                 case expected of
  43                  Left (_, err) -> Right ("…"::String) @?= Left err
  44                  Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
  45                         (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
  46                         case ty `eq_type` ty_expected of
  47                          Nothing -> Monad.return $ Left $
  48                                 error_expr (Proxy::Proxy Ex) $
  49                                 Error_Expr_Type_mismatch ast
  50                                  (Exists_Type ty)
  51                                  (Exists_Type ty_expected)
  52                          Just Refl -> do
  53                                 let h = host_from_expr r
  54                                 Monad.return $
  55                                         Right
  56                                          ( ty
  57                                          , h
  58                                          , text_from_expr r
  59                                          -- , (text_from_expr :: Repr_Text h -> Text) r
  60                                          )
  61
  62 tests :: TestTree
  63 tests = testGroup "Maybe"
  64  [ AST "just" [AST "bool" [AST "True" []]] ==> Right
  65          ( type_maybe type_bool
  66          , Just True
  67          , "just True" )
  68  , AST "just"
  69          [ AST "let"
  70                  [ AST "x" []
  71                  , AST "bool" [AST "True" []]
  72                  , AST "var" [AST "x" []]
  73                  ]
  74          ] ==> Right
  75          ( type_maybe type_bool
  76          , Just True
  77          , "just (let x0 = True in x0)" )
  78  , AST "maybe"
  79          [ AST "bool" [AST "True" []]
  80          , AST "\\"
  81                  [ AST "x" []
  82                  , AST "Bool" []
  83                  , AST "not" [AST "var" [AST "x" []]]
  84                  ]
  85          , AST "nothing"
  86                  [ AST "Bool" []
  87                  ]
  88          ] ==> Right
  89          ( type_bool
  90          , True
  91          , "maybe True (\\x0 -> !x0) nothing" )
  92  , AST "maybe"
  93          [ AST "bool" [AST "False" []]
  94          , AST "\\"
  95                  [ AST "x" []
  96                  , AST "Bool" []
  97                  , AST "not" [AST "var" [AST "x" []]]
  98                  ]
  99          , AST "just"
 100                  [ AST "bool" [AST "True" []]
 101                  ]
 102          ] ==> Right
 103          ( type_bool
 104          , False
 105          , "maybe False (\\x0 -> !x0) (just True)" )
 106  ]