Language/LOL/Symantic/Expr/Maybe/Test.hs

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