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 Control.Arrow (left)
  14 import Data.Proxy (Proxy(..))
  15 import Data.Text (Text)
  16 import Data.Type.Equality ((:~:)(Refl))
  17 import Prelude hiding (maybe, not)
  18
  19 import Language.Symantic.Repr
  20 import Language.Symantic.Expr
  21 import Language.Symantic.Type
  22
  23 import AST.Test
  24
  25 -- * Expressions
  26 e1 = maybe (bool True) (val not) (just $ bool True)
  27
  28 -- * Tests
  29 type Ex lam = Expr_Root (Expr_Lambda lam .|. Expr_Maybe lam .|. Expr_Bool)
  30 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
  31
  32 (==>) ast expected =
  33         testCase (show ast) $
  34         case ex_from ast of
  35          Left err -> Left err @?= snd `left` expected
  36          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  37                 case expected of
  38                  Left (_, err) -> Right ("…"::String) @?= Left err
  39                  Right (ty_expected::Type_Root_of_Expr (Ex IO) h, _::h, _::Text) ->
  40                         (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
  41                         case ty `type_eq` ty_expected of
  42                          Nothing -> return $ Left $
  43                                 error_expr (Proxy::Proxy (Ex IO)) $
  44                                 Error_Expr_Type_mismatch ast
  45                                  (Exists_Type ty)
  46                                  (Exists_Type ty_expected)
  47                          Just Refl -> do
  48                                 h <- host_from_expr r
  49                                 return $
  50                                         Right
  51                                          ( ty
  52                                          , h
  53                                          , text_from_expr r
  54                                          -- , (text_from_expr :: Repr_String IO h -> Text) r
  55                                          )
  56
  57 tests :: TestTree
  58 tests = testGroup "Maybe"
  59  [ AST "just" [AST "bool" [AST "True" []]] ==> Right
  60          ( type_maybe type_bool
  61          , Just True
  62          , "just True" )
  63  , AST "just"
  64          [ AST "let_val"
  65                  [ AST "x" []
  66                  , AST "bool" [AST "True" []]
  67                  , AST "var" [AST "x" []]
  68                  ]
  69          ] ==> Right
  70          ( type_maybe type_bool
  71          , Just True
  72          , "just (let x0 = True in x0)" )
  73  , AST "maybe"
  74          [ AST "bool" [AST "True" []]
  75          , AST "val"
  76                  [ AST "x" []
  77                  , AST "Bool" []
  78                  , AST "not" [AST "var" [AST "x" []]]
  79                  ]
  80          , AST "nothing"
  81                  [ AST "Bool" []
  82                  ]
  83          ] ==> Right
  84          ( type_bool
  85          , True
  86          , "maybe True (\\x0 -> !x0) nothing" )
  87  , AST "maybe"
  88          [ AST "bool" [AST "False" []]
  89          , AST "val"
  90                  [ AST "x" []
  91                  , AST "Bool" []
  92                  , AST "not" [AST "var" [AST "x" []]]
  93                  ]
  94          , AST "just"
  95                  [ AST "bool" [AST "True" []]
  96                  ]
  97          ] ==> Right
  98          ( type_bool
  99          , False
 100          , "maybe False (\\x0 -> !x0) (just True)" )
 101  ]