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