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