Language/Symantic/AST/Test.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE Rank2Types #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# LANGUAGE UndecidableInstances #-}
  10 -- | Abstract Syntax Tree.
  11 module AST.Test where
  12
  13 import Test.Tasty
  14 -- import Test.Tasty.HUnit
  15
  16 import qualified Data.List as List
  17 import Data.Proxy (Proxy(..))
  18 import Data.Text (Text)
  19 import qualified Data.Text as Text
  20 import Prelude hiding (and, not, or)
  21
  22 import Language.Symantic.Type
  23 import Language.Symantic.Expr
  24
  25 tests :: TestTree
  26 tests = testGroup "AST" $
  27  [
  28  ]
  29
  30 -- * Type 'AST'
  31 data AST
  32  =   AST Text [AST]
  33  deriving (Eq)
  34 -- | Custom 'Show' instance a little bit more readable
  35 -- than the automatically derived one.
  36 instance Show AST where
  37         showsPrec p ast@(AST f args) =
  38                 let n = Text.unpack f in
  39                 case ast of
  40                  AST _ [] -> showString n
  41                  AST "->" [a] ->
  42                                 showParen (p >= prec_arrow) $
  43                                 showString ("("++n++") ") .
  44                                 showsPrec prec_arrow a
  45                  AST "->" [a, b] ->
  46                                 showParen (p >= prec_arrow) $
  47                                 showsPrec prec_arrow a .
  48                                 showString (" "++n++" ") .
  49                                 showsPrec prec_arrow b
  50                  _ ->
  51                         showString n .
  52                         showString "(" .
  53                         showString (List.intercalate ", " $ show <$> args) .
  54                         showString ")"
  55                 where prec_arrow = 1
  56
  57 instance -- Type_from AST Type_Var
  58  ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
  59  , Implicit_HBool (Is_Last_Type (Type_Var root) root)
  60  ) => Type_from AST (Type_Var root) where
  61         type_from ty ast _k =
  62                 Left $ error_type_unsupported ty ast
  63          -- NOTE: no support so far.
  64 instance -- Type_from AST Type_Unit
  65  ( Type_Root_Lift Type_Unit root
  66  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
  67  , Implicit_HBool (Is_Last_Type (Type_Unit root) root)
  68  ) => Type_from AST (Type_Unit root) where
  69         type_from ty ast k =
  70                 case ast of
  71                  AST "()" asts ->
  72                         case asts of
  73                          [] -> k type_unit
  74                          _ -> Left $ error_type_lift $
  75                                 Error_Type_Wrong_number_of_arguments ast 0
  76                  _ -> Left $ error_type_unsupported ty ast
  77 instance -- Type_from AST Type_Bool
  78  ( Type_Root_Lift Type_Bool root
  79  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
  80  , Implicit_HBool (Is_Last_Type (Type_Bool root) root)
  81  ) => Type_from AST (Type_Bool root) where
  82         type_from ty ast k =
  83                 case ast of
  84                  AST "Bool" asts ->
  85                         case asts of
  86                          [] -> k type_bool
  87                          _ -> Left $ error_type_lift $
  88                                 Error_Type_Wrong_number_of_arguments ast 0
  89                  _ -> Left $ error_type_unsupported ty ast
  90 instance -- Type_from AST Type_Int
  91  ( Type_Root_Lift Type_Int root
  92  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
  93  , Implicit_HBool (Is_Last_Type (Type_Int root) root)
  94  ) => Type_from AST (Type_Int root) where
  95         type_from ty ast k =
  96                 case ast of
  97                  AST "Int" asts ->
  98                         case asts of
  99                          [] -> k type_int
 100                          _ -> Left $ error_type_lift $
 101                                 Error_Type_Wrong_number_of_arguments ast 0
 102                  _ -> Left $ error_type_unsupported ty ast
 103 instance -- Type_from AST Type_Fun
 104  ( Type_Eq root
 105  , Type_from AST root
 106  , Type_Root_Lift (Type_Fun lam) root
 107  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 108  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 109  , Root_of_Type root ~ root
 110  , Implicit_HBool (Is_Last_Type (Type_Fun lam root) root)
 111  ) => Type_from AST (Type_Fun lam root) where
 112         type_from ty ast k =
 113                 case ast of
 114                  AST "->" asts ->
 115                         case asts of
 116                          [ast_arg, ast_res] -> type_fun_from ty ast_arg ast_res k
 117                          _ -> Left $ error_type_lift $
 118                                 Error_Type_Wrong_number_of_arguments ast 2
 119                  _ -> Left $ error_type_unsupported ty ast
 120 instance -- Type_from AST Type_Maybe
 121  ( Type_Eq root
 122  , Type_from AST root
 123  , Type_Root_Lift Type_Maybe root
 124  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 125  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 126  , Root_of_Type root ~ root
 127  , Implicit_HBool (Is_Last_Type (Type_Maybe root) root)
 128  ) => Type_from AST (Type_Maybe root) where
 129         type_from ty ast k =
 130                 case ast of
 131                  AST "Maybe" asts ->
 132                         case asts of
 133                          [ast_a] ->
 134                                 type_from (Proxy::Proxy root) ast_a $ \(ty_a::root h_a) ->
 135                                         k (type_root_lift $ Type_Maybe ty_a
 136                                          :: root (Maybe h_a))
 137                          _ -> Left $ error_type_lift $
 138                                 Error_Type_Wrong_number_of_arguments ast 1
 139                  _ -> Left $ error_type_unsupported ty ast
 140 instance -- Expr_from AST Expr_Bool
 141  ( Type_from AST (Type_Root_of_Expr root)
 142  , Expr_from AST root
 143  , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
 144  , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 145                                (                   Type_Root_of_Expr root)
 146                                AST)
 147                    (Error_of_Expr AST root)
 148  , Type_Unlift Type_Bool (Type_of_Expr root)
 149  , Root_of_Expr root ~ root
 150  , Implicit_HBool (Is_Last_Expr (Expr_Bool root) root)
 151  ) => Expr_from AST (Expr_Bool root) where
 152         expr_from ex ast =
 153                 case ast of
 154                  AST "bool" asts -> lit_from_AST bool type_bool asts ex ast
 155                  AST "not"  asts -> op1_from_AST not  type_bool asts ex ast
 156                  AST "and"  asts -> op2_from_AST and  type_bool asts ex ast
 157                  AST "or"   asts -> op2_from_AST or   type_bool asts ex ast
 158                  AST "xor"  asts -> op2_from_AST xor  type_bool asts ex ast
 159                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 160 instance -- Expr_from AST Expr_If
 161  ( Type_from AST (Type_Root_of_Expr root)
 162  , Expr_from AST root
 163  , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
 164  , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 165                                (                   Type_Root_of_Expr root)
 166                                AST)
 167                    (Error_of_Expr AST root)
 168  , Root_of_Expr root ~ root
 169  , Implicit_HBool (Is_Last_Expr (Expr_If root) root)
 170  ) => Expr_from AST (Expr_If root) where
 171         expr_from ex ast ctx k =
 172                 case ast of
 173                  AST "if" asts ->
 174                         case asts of
 175                          [ast_cond, ast_ok, ast_ko] ->
 176                                 if_from ast_cond ast_ok ast_ko ex ast ctx k
 177                          _ -> Left $ error_expr ex $
 178                                 Error_Expr_Wrong_number_of_arguments ast 3
 179                  _ -> Left $ error_expr_unsupported ex ast
 180 instance -- Expr_from AST Expr_When
 181  ( Type_from AST (Type_Root_of_Expr root)
 182  , Expr_from AST root
 183  , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
 184  , Type_Root_Lift Type_Unit (Type_Root_of_Expr root)
 185  , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 186                                (                   Type_Root_of_Expr root)
 187                                AST)
 188                    (Error_of_Expr AST root)
 189  , Root_of_Expr root ~ root
 190  , Implicit_HBool (Is_Last_Expr (Expr_When root) root)
 191  ) => Expr_from AST (Expr_When root) where
 192         expr_from ex ast ctx k =
 193                 case ast of
 194                  AST "when" asts ->
 195                         case asts of
 196                          [ast_cond, ast_ok] ->
 197                                 when_from ast_cond ast_ok ex ast ctx k
 198                          _ -> Left $ error_expr ex $
 199                                 Error_Expr_Wrong_number_of_arguments ast 2
 200                  _ -> Left $ error_expr_unsupported ex ast
 201 instance -- Expr_from AST Expr_Int
 202  ( Type_from AST (Type_Root_of_Expr root)
 203  , Expr_from AST root
 204  , Type_Root_Lift Type_Int (Type_Root_of_Expr root)
 205  , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 206                                (                   Type_Root_of_Expr root)
 207                                AST)
 208                    (Error_of_Expr AST root)
 209
 210  , Type_Unlift Type_Int (Type_of_Expr root)
 211  , Root_of_Expr root ~ root
 212  , Implicit_HBool (Is_Last_Expr (Expr_Int root) root)
 213  ) => Expr_from AST (Expr_Int root) where
 214         expr_from ex ast =
 215                 case ast of
 216                  AST "int" asts -> lit_from_AST int type_int asts ex ast
 217                  AST "neg" asts -> op1_from_AST neg type_int asts ex ast
 218                  AST "add" asts -> op2_from_AST add type_int asts ex ast
 219                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 220 instance -- Expr_from AST Expr_Lambda
 221  ( Type_from AST (Type_Root_of_Expr root)
 222  , Expr_from AST root
 223  , Type_Root_Lift (Type_Fun lam) (Type_Root_of_Expr root)
 224  , Error_Expr_Lift (Error_Expr_Lambda AST)
 225                    (Error_of_Expr AST root)
 226  , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 227                                (                   Type_Root_of_Expr root)
 228                                AST)
 229                    (Error_of_Expr AST root)
 230  , Error_Expr_Unlift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 231                                  (                   Type_Root_of_Expr root)
 232                                  AST)
 233                    (Error_of_Expr AST root)
 234  , Type_Unlift (Type_Fun lam) (Type_of_Expr root)
 235  , Root_of_Expr root ~ root
 236  , Implicit_HBool (Is_Last_Expr (Expr_Lambda lam root) root)
 237  ) => Expr_from AST (Expr_Lambda lam root) where
 238         expr_from ex ast ctx k =
 239                 case ast of
 240                  AST "var" asts ->
 241                         case asts of
 242                          [AST name []] -> var_from name ex ast ctx k
 243                          _ -> Left $ error_expr ex $
 244                                 Error_Expr_Wrong_number_of_arguments ast 1
 245                  AST "app" asts ->
 246                         case asts of
 247                          [ast_lam, ast_arg_actual] ->
 248                                 app_from ast_lam ast_arg_actual ex ast ctx k
 249                          _ -> Left $ error_expr ex $
 250                                 Error_Expr_Wrong_number_of_arguments ast 2
 251                  AST "inline"     asts -> go_lam asts inline
 252                  AST "val"        asts -> go_lam asts val
 253                  AST "lazy"       asts -> go_lam asts lazy
 254                  AST "let_inline" asts -> go_let asts let_inline
 255                  AST "let_val"    asts -> go_let asts let_val
 256                  AST "let_lazy"   asts -> go_let asts let_lazy
 257                  _ -> Left $ error_expr_unsupported ex ast
 258                 where
 259                 go_lam asts
 260                  (lam::forall repr arg res. Sym_Lambda lam repr
 261                      => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
 262                         case asts of
 263                          [AST name [], ast_ty_arg, ast_body] ->
 264                                 lam_from lam name ast_ty_arg ast_body ex ast ctx k
 265                          _ -> Left $ error_expr ex $
 266                                 Error_Expr_Wrong_number_of_arguments ast 3
 267                 go_let asts
 268                  (let_::forall repr var res. Sym_Lambda lam repr
 269                      => repr var -> (repr var -> repr res) -> repr res) =
 270                         case asts of
 271                          [AST name [], ast_var, ast_body] ->
 272                                 let_from let_ name ast_var ast_body ex ast ctx k
 273                          _ -> Left $ error_expr ex $
 274                                 Error_Expr_Wrong_number_of_arguments ast 3
 275 instance -- Expr_from AST Expr_Maybe
 276  ( Type_from AST (Type_Root_of_Expr root)
 277  , Expr_from AST root
 278  , Type_Root_Lift (Type_Fun lam) (Type_Root_of_Expr root)
 279  , Type_Root_Lift Type_Maybe (Type_Root_of_Expr root)
 280  , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 281                                (                   Type_Root_of_Expr root)
 282                                AST)
 283                    (Error_of_Expr AST root)
 284  , Error_Expr_Unlift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 285                                  (                   Type_Root_of_Expr root)
 286                                  AST)
 287                    (Error_of_Expr AST root)
 288  , Type_Unlift (Type_Fun lam) (Type_of_Expr root)
 289  , Type_Unlift Type_Maybe     (Type_of_Expr root)
 290  , Root_of_Expr root ~ root
 291  , Implicit_HBool (Is_Last_Expr (Expr_Maybe lam root) root)
 292  ) => Expr_from AST (Expr_Maybe lam root) where
 293         expr_from ex ast ctx k =
 294                 case ast of
 295                  AST "maybe" asts ->
 296                         case asts of
 297                          [ast_n, ast_j, ast_m] -> maybe_from ast_n ast_j ast_m ex ast ctx k
 298                          _ -> Left $ error_expr ex $
 299                                 Error_Expr_Wrong_number_of_arguments ast 3
 300                  AST "nothing" asts ->
 301                         case asts of
 302                          [ast_ty_a] -> nothing_from ast_ty_a ex ast ctx k
 303                          _ -> Left $ error_expr ex $
 304                                 Error_Expr_Wrong_number_of_arguments ast 1
 305                  AST "just" asts ->
 306                         case asts of
 307                          [ast_a] -> just_from ast_a ex ast ctx k
 308                          _ -> Left $ error_expr ex $
 309                                 Error_Expr_Wrong_number_of_arguments ast 1
 310                  _ -> Left $ error_expr_unsupported ex ast
 311 instance -- Expr_from AST Expr_Eq
 312  ( Type_from AST (Type_Root_of_Expr root)
 313  , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
 314  , Type_Constraint Eq (Type_Root_of_Expr root)
 315  , Expr_from AST root
 316  , Error_Expr_Lift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 317                                (                   Type_Root_of_Expr root)
 318                                AST)
 319                    (Error_of_Expr AST root)
 320  , Error_Expr_Unlift (Error_Expr (Error_of_Type AST (Type_Root_of_Expr root))
 321                                  (                   Type_Root_of_Expr root)
 322                                  AST)
 323                    (Error_of_Expr AST root)
 324  , Root_of_Expr root ~ root
 325  , Implicit_HBool (Is_Last_Expr (Expr_Eq root) root)
 326  ) => Expr_from AST (Expr_Eq root) where
 327         expr_from ex ast ctx k =
 328                 case ast of
 329                  AST "eq" asts ->
 330                         case asts of
 331                          [ast_x, ast_y] -> eq_from ast_x ast_y ex ast ctx k
 332                          _ -> Left $ error_expr ex $
 333                                 Error_Expr_Wrong_number_of_arguments ast 2
 334                  _ -> Left $ error_expr_unsupported ex ast
 335
 336 lit_from_AST
 337  :: forall root ty lit ex ast hs ret.
 338  ( ty ~ Type_Root_of_Expr ex
 339  , root ~ Root_of_Expr ex
 340  , ast ~ AST
 341  , Read lit
 342  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 343                    (Error_of_Expr ast root)
 344  ) => (forall repr. Sym_of_Expr ex repr => lit -> repr lit)
 345  -> ty lit -> [ast]
 346  -> Expr_From ast ex hs ret
 347 lit_from_AST op ty_lit asts ex ast ctx k =
 348         case asts of
 349          [AST lit []] -> lit_from op ty_lit lit ex ast ctx k
 350          _ -> Left $ error_expr ex $
 351                 Error_Expr_Wrong_number_of_arguments ast 1
 352
 353 op1_from_AST
 354  :: forall root ty lit ex ast hs ret.
 355  ( ty ~ Type_Root_of_Expr ex
 356  , root ~ Root_of_Expr ex
 357  , ast ~ AST
 358  , Type_Eq (Type_Root_of_Expr root)
 359  , Expr_from ast root
 360  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 361                    (Error_of_Expr ast root)
 362  , Root_of_Expr root ~ root
 363  ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit)
 364  -> ty lit -> [ast]
 365  -> Expr_From ast ex hs ret
 366 op1_from_AST op ty_lit asts ex ast ctx k =
 367         case asts of
 368          [ast_x] -> op1_from op ty_lit ast_x ex ast ctx k
 369          _ -> Left $ error_expr ex $
 370                 Error_Expr_Wrong_number_of_arguments ast 1
 371
 372 op2_from_AST
 373  :: forall root ty lit ex ast hs ret.
 374  ( ty ~ Type_Root_of_Expr ex
 375  , root ~ Root_of_Expr ex
 376  , ast ~ AST
 377  , Type_Eq (Type_Root_of_Expr root)
 378  , Expr_from ast root
 379  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 380                    (Error_of_Expr ast root)
 381  , Root_of_Expr root ~ root
 382  ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
 383  -> ty lit -> [ast]
 384  -> Expr_From ast ex hs ret
 385 op2_from_AST op ty_lit asts ex ast ctx k =
 386         case asts of
 387          [ast_x, ast_y] -> op2_from op ty_lit ast_x ast_y ex ast ctx k
 388          _ -> Left $ error_expr ex $
 389                 Error_Expr_Wrong_number_of_arguments ast 2