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