Language/Symantic/Expr/Int/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.Int.Test where
   9
  10 import Test.Tasty
  11 import Test.Tasty.HUnit
  12
  13 import Control.Arrow (left)
  14 -- import Data.Functor.Identity (Identity)
  15 -- import Control.Monad.IO.Class (MonadIO(..))
  16 import Data.Proxy (Proxy(..))
  17 import Data.Text (Text)
  18 import Data.Type.Equality ((:~:)(Refl))
  19 import Prelude hiding ((&&), not, (||), (+), negate)
  20
  21 import Language.Symantic.Repr
  22 import Language.Symantic.Expr
  23 import Language.Symantic.Type
  24 -- import Language.Symantic.Trans
  25
  26 import AST.Test
  27
  28 -- * Class 'Sym_Int_Vars'
  29
  30 -- | A few boolean variables.
  31 class Sym_Int_Vars repr where
  32         x :: repr Int
  33         y :: repr Int
  34         z :: repr Int
  35 instance Sym_Int_Vars (Repr_Text fun) where
  36         x = Repr_Text $ \_p _v -> "x"
  37         y = Repr_Text $ \_p _v -> "y"
  38         z = Repr_Text $ \_p _v -> "z"
  39
  40 -- * Expressions
  41 e1 = int 1 + int 0
  42 e2 = (int 1 + int 0) + negate (int 1 + int 1)
  43 e3 = (int 1 + negate (int 0)) + (int 1 + negate (int 1))
  44 e4 = int 0 + negate (int 1)
  45 e5 = int 1 + negate x
  46 e6 = x + y
  47 e7 = (x + y) + z
  48 e8 = x + (y + int 1)
  49
  50 -- * Tests
  51 type Ex lam = Expr_Root (Expr_Lambda lam .|. Expr_Int)
  52 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
  53
  54 (==>) ast expected =
  55         testCase (show ast) $
  56         case ex_from ast of
  57          Left err -> Left err @?= snd `left` expected
  58          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  59                 case expected of
  60                  Left (_, err) -> Right ("…"::String) @?= Left err
  61                  Right (ty_expected::Type_Root_of_Expr (Ex IO) h, _::h, _::Text) ->
  62                         (>>= (@?= (\(_::Proxy h, err) -> err) `left` expected)) $
  63                         case ty `type_eq` ty_expected of
  64                          Nothing -> return $ Left $
  65                                 error_expr (Proxy::Proxy (Ex IO)) $
  66                                 Error_Expr_Type_mismatch ast
  67                                  (Exists_Type ty)
  68                                  (Exists_Type ty_expected)
  69                          Just Refl -> do
  70                                 h <- host_from_expr r
  71                                 return $
  72                                         Right
  73                                          ( ty
  74                                          , h
  75                                          , text_from_expr r
  76                                          -- , (text_from_expr :: Repr_Text IO h -> String) r
  77                                          )
  78
  79 tests :: TestTree
  80 tests = testGroup "Int" $
  81  [ AST "int" [AST "1" []] ==> Right
  82          ( type_int
  83          , 1
  84          , "1" )
  85  , AST "bool" [AST "True" []] ==> Left (Proxy::Proxy Bool,
  86         Error_Expr_Alt_Curr $
  87         Error_Expr_Unsupported $ AST "bool" [AST "True" []])
  88  , AST "+"
  89          [ AST "int" [AST "1" []]
  90          , AST "int" [AST "1" []]
  91          ] ==> Right
  92          ( type_int
  93          , 2
  94          , "1 + 1" )
  95  , let ast = AST "app"
  96          [ AST "int" [AST "1" []]
  97          , AST "int" [AST "1" []]
  98          ] in ast ==> Left (Proxy::Proxy Int,
  99         Error_Expr_Alt_Curr $
 100         Error_Expr_Type_mismatch ast
 101          (Exists_Type (type_var SZero `type_fun` type_var (SSucc SZero)
 102          ::Type_Root (Type_Var :|: Type_Fun IO :|: Type_Int)
 103                      (IO Zero -> IO (Succ Zero))))
 104          (Exists_Type type_int))
 105  , AST "app"
 106          [ AST "val"
 107                  [ AST "x" []
 108                  , AST "Int" []
 109                  , AST "var" [AST "x" []]
 110                  ]
 111          , AST "int" [AST "1" []]
 112          ] ==> Right
 113          ( type_int
 114          , 1
 115          , "(\\x0 -> x0) 1" )
 116  , AST "app"
 117          [ AST "val"
 118                  [ AST "x" []
 119                  , AST "Int" []
 120                  , AST "+"
 121                          [ AST "var" [AST "x" []]
 122                          , AST "int" [AST "1" []]
 123                          ]
 124                  ]
 125          , AST "int" [AST "1" []]
 126          ] ==> Right
 127          ( type_int
 128          , 2
 129          , "(\\x0 -> x0 + 1) 1" )
 130  , AST "let_val"
 131          [ AST "x" []
 132          , AST "int" [AST "1" []]
 133          , AST "+"
 134                  [ AST "var" [AST "x" []]
 135                  , AST "int" [AST "1" []]
 136                  ]
 137          ] ==> Right
 138          ( type_int
 139          , 2
 140          , "let x0 = 1 in x0 + 1" )
 141  ]