Language/Symantic/Expr/Monad/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE NoMonomorphismRestriction #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeOperators #-}
   7 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   8
   9 module Expr.Monad.Test where
  10
  11 import Test.Tasty
  12 import Test.Tasty.HUnit
  13
  14 import qualified Control.Arrow as Arrow
  15 import qualified Control.Monad as Monad
  16 import qualified Data.Functor as Functor
  17 import Data.Functor.Identity
  18 import Data.Proxy (Proxy(..))
  19 import Data.Text (Text)
  20 import Data.Type.Equality ((:~:)(Refl))
  21 import Prelude hiding ((&&), not, (||), (==), (<$>), (+), Applicative(..), Monad(..), Monad(..))
  22
  23 import Language.Symantic.Type
  24 import Language.Symantic.Expr as Expr
  25 import Language.Symantic.Repr
  26
  27 import AST.Test
  28
  29 -- * Expressions
  30 t = bool True
  31 f = bool False
  32 e1 = (>>=) (list $ int Functor.<$> [1..3])
  33            (val $ \i -> list [i, i])
  34
  35 -- * Tests
  36 type Ex lam = Expr_Root
  37  (   Expr_Lambda_App lam
  38  .|. Expr_Lambda_Val lam
  39  .|. Expr_List lam
  40  .|. Expr_Maybe lam
  41  .|. Expr_Int
  42  .|. Expr_Bool
  43  .|. Expr_Functor lam
  44  .|. Expr_Applicative lam
  45  .|. Expr_Monad lam
  46  .|. Expr_Either
  47  )
  48 ex_from = root_expr_from (Proxy::Proxy (Ex lam)) (Proxy::Proxy lam)
  49
  50 (==>) ast expected =
  51         testCase (show ast) $
  52         case ex_from ast of
  53          Left err -> Left err @?= snd `Arrow.left` expected
  54          Right (Exists_Type_and_Repr ty (Forall_Repr r)) ->
  55                 case expected of
  56                  Left (_, err) -> Right ("…"::String) @?= Left err
  57                  Right (ty_expected::Type_Root_of_Expr (Ex Identity) h, _::h, _::Text) ->
  58                         (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
  59                         case ty `eq_type` ty_expected of
  60                          Nothing -> Monad.return $ Left $
  61                                 error_expr (Proxy::Proxy (Ex Identity)) $
  62                                 Error_Expr_Type_mismatch ast
  63                                  (Exists_Type ty)
  64                                  (Exists_Type ty_expected)
  65                          Just Refl -> do
  66                                 let h = runIdentity $ host_from_expr r
  67                                 Monad.return $
  68                                         Right
  69                                          ( ty
  70                                          , h
  71                                          , text_from_expr r
  72                                          -- , (text_from_expr :: Repr_Text Identity h -> Text) r
  73                                          )
  74
  75 tests :: TestTree
  76 tests = testGroup "Monad"
  77  [ AST ">>="
  78          [ AST "list"
  79                  [ AST "Int" []
  80                  , AST "int" [AST "1" []]
  81                  , AST "int" [AST "2" []]
  82                  , AST "int" [AST "3" []]
  83                  ]
  84          , AST "val"
  85                  [ AST "x" [], AST "Int" []
  86                  , AST "list"
  87                          [ AST "Int" []
  88                          , AST "var" [ AST "x" [] ]
  89                          , AST "var" [ AST "x" [] ]
  90                          ]
  91                  ]
  92          ] ==> Right
  93          ( type_list type_int
  94          , [1, 1, 2, 2, 3, 3]
  95          , "[1, 2, 3] >>= (\\x0 -> [x0, x0])" )
  96  , AST ">>="
  97          [ AST "just" [ AST "int" [AST "1" []] ]
  98          , AST "val"
  99                  [ AST "x" [], AST "Int" []
 100                  , AST "nothing"
 101                          [ AST "Int" []
 102                          ]
 103                  ]
 104          ] ==> Right
 105          ( type_maybe type_int
 106          , Nothing
 107          , "just 1 >>= (\\x0 -> nothing)" )
 108  , AST ">>="
 109          [ AST "right"
 110                  [ AST "Bool" []
 111                  , AST "int" [AST "1" []]
 112                  ]
 113          , AST "val"
 114                  [ AST "x" [], AST "Int" []
 115                  , AST "left"
 116                          [ AST "Int" []
 117                          , AST "bool" [AST "True" []]
 118                          ]
 119                  ]
 120          ] ==> Right
 121          ( type_either type_bool type_int
 122          , Left True
 123          , "right 1 >>= (\\x0 -> left True)" )
 124  ]