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