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