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
  21 import Language.Symantic.Type
  22 import Language.Symantic.Expr as Expr
  23
  24 tests :: TestTree
  25 tests = testGroup "AST" $
  26  [
  27  ]
  28
  29 -- * Type 'AST'
  30 data AST
  31  =   AST Text [AST]
  32  deriving (Eq)
  33 -- | Custom 'Show' instance a little bit more readable
  34 -- than the automatically derived one.
  35 instance Show AST where
  36         showsPrec p ast@(AST f args) =
  37                 let n = Text.unpack f in
  38                 case ast of
  39                  AST _ [] -> showString n
  40                  AST "->" [a] ->
  41                                 showParen (p >= prec_arrow) $
  42                                 showString ("("++n++") ") .
  43                                 showsPrec prec_arrow a
  44                  AST "->" [a, b] ->
  45                                 showParen (p >= prec_arrow) $
  46                                 showsPrec prec_arrow a .
  47                                 showString (" "++n++" ") .
  48                                 showsPrec prec_arrow b
  49                  _ ->
  50                         showString n .
  51                         showString "(" .
  52                         showString (List.intercalate ", " $ show Prelude.<$> args) .
  53                         showString ")"
  54                 where prec_arrow = 1
  55
  56 -- ** Parsing utilities
  57 from_ast0
  58  :: forall ty ast ex hs ret.
  59  ( ty ~ Type_Root_of_Expr ex
  60  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
  61                    (Error_of_Expr ast (Root_of_Expr ex))
  62  ) => [ast]
  63  -> Expr_From ast ex hs ret
  64  -> Expr_From ast ex hs ret
  65 from_ast0 asts k' ex ast ctx k =
  66         case asts of
  67          [] -> k' ex ast ctx k
  68          _ -> Left $ error_expr ex $
  69                 Error_Expr_Wrong_number_of_arguments ast 0
  70
  71 from_ast1
  72  :: forall ty ast ex hs ret.
  73  ( ty ~ Type_Root_of_Expr ex
  74  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
  75                    (Error_of_Expr ast (Root_of_Expr ex))
  76  ) => [ast] -> (ast -> Expr_From ast ex hs ret)
  77  -> Expr_From ast ex hs ret
  78 from_ast1 asts k' ex ast ctx k =
  79         case asts of
  80          [ast_0] -> k' ast_0 ex ast ctx k
  81          _ -> Left $ error_expr ex $
  82                 Error_Expr_Wrong_number_of_arguments ast 1
  83
  84 from_ast2
  85  :: forall ty ast ex hs ret.
  86  ( ty ~ Type_Root_of_Expr ex
  87  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
  88                    (Error_of_Expr ast (Root_of_Expr ex))
  89  ) => [ast] -> (ast -> ast -> Expr_From ast ex hs ret)
  90  -> Expr_From ast ex hs ret
  91 from_ast2 asts k' ex ast ctx k =
  92         case asts of
  93          [ast_0, ast_1] -> k' ast_0 ast_1 ex ast ctx k
  94          _ -> Left $ error_expr ex $
  95                 Error_Expr_Wrong_number_of_arguments ast 2
  96
  97 from_ast3
  98  :: forall ty ast ex hs ret.
  99  ( ty ~ Type_Root_of_Expr ex
 100  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 101                    (Error_of_Expr ast (Root_of_Expr ex))
 102  ) => [ast] -> (ast -> ast -> ast -> Expr_From ast ex hs ret)
 103  -> Expr_From ast ex hs ret
 104 from_ast3 asts k' ex ast ctx k =
 105         case asts of
 106          [ast_0, ast_1, ast_2] -> k' ast_0 ast_1 ast_2 ex ast ctx k
 107          _ -> Left $ error_expr ex $
 108                 Error_Expr_Wrong_number_of_arguments ast 3
 109
 110 lit_from_AST
 111  :: forall root ty lit ex ast hs ret.
 112  ( ty ~ Type_Root_of_Expr ex
 113  , root ~ Root_of_Expr ex
 114  , ast ~ AST
 115  , Read lit
 116  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 117                    (Error_of_Expr ast root)
 118  ) => (forall repr. Sym_of_Expr ex repr => lit -> repr lit)
 119  -> ty lit -> [ast]
 120  -> Expr_From ast ex hs ret
 121 lit_from_AST op ty_lit asts ex ast ctx k =
 122         case asts of
 123          [AST lit []] -> lit_from op ty_lit lit ex ast ctx k
 124          _ -> Left $ error_expr ex $
 125                 Error_Expr_Wrong_number_of_arguments ast 1
 126
 127 op1_from_AST
 128  :: forall root ty lit ex ast hs ret.
 129  ( ty ~ Type_Root_of_Expr ex
 130  , root ~ Root_of_Expr ex
 131  , ast ~ AST
 132  , Eq_Type (Type_Root_of_Expr root)
 133  , Expr_from ast root
 134  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 135                    (Error_of_Expr ast root)
 136  , Root_of_Expr root ~ root
 137  ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit)
 138  -> ty lit -> [ast]
 139  -> Expr_From ast ex hs ret
 140 op1_from_AST op ty_lit asts ex ast ctx k =
 141         case asts of
 142          [ast_x] -> op1_from op ty_lit ast_x ex ast ctx k
 143          _ -> Left $ error_expr ex $
 144                 Error_Expr_Wrong_number_of_arguments ast 1
 145
 146 op2_from_AST
 147  :: forall root ty lit ex ast hs ret.
 148  ( ty ~ Type_Root_of_Expr ex
 149  , root ~ Root_of_Expr ex
 150  , ast ~ AST
 151  , Eq_Type (Type_Root_of_Expr root)
 152  , Expr_from ast root
 153  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 154                    (Error_of_Expr ast root)
 155  , Root_of_Expr root ~ root
 156  ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
 157  -> ty lit -> [ast]
 158  -> Expr_From ast ex hs ret
 159 op2_from_AST op ty_lit asts ex ast ctx k =
 160         case asts of
 161          [ast_x, ast_y] -> op2_from op ty_lit ast_x ast_y ex ast ctx k
 162          _ -> Left $ error_expr ex $
 163                 Error_Expr_Wrong_number_of_arguments ast 2
 164
 165 instance -- Type_from AST Type_Var0
 166  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 167  , Implicit_HBool (Is_Last_Type (Type_Var0 root) root)
 168  ) => Type_from AST (Type_Var0 root) where
 169         type_from ty ast _k =
 170                 Left $ error_type_unsupported ty ast
 171          -- NOTE: no support so far.
 172 instance -- Type_from AST Type_Var1
 173  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 174  , Implicit_HBool (Is_Last_Type (Type_Var1 root) root)
 175  ) => Type_from AST (Type_Var1 root) where
 176         type_from ty ast _k =
 177                 Left $ error_type_unsupported ty ast
 178          -- NOTE: no support so far.
 179 instance -- Type_from AST Type_Unit
 180  ( Lift_Type_Root Type_Unit root
 181  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 182  , Implicit_HBool (Is_Last_Type (Type_Unit root) root)
 183  ) => Type_from AST (Type_Unit root) where
 184         type_from ty ast k =
 185                 case ast of
 186                  AST "()" asts ->
 187                         case asts of
 188                          [] -> k type_unit
 189                          _ -> Left $ lift_error_type $
 190                                 Error_Type_Wrong_number_of_arguments ast 0
 191                  _ -> Left $ error_type_unsupported ty ast
 192 instance -- Type_from AST Type_Bool
 193  ( Lift_Type_Root Type_Bool root
 194  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 195  , Implicit_HBool (Is_Last_Type (Type_Bool root) root)
 196  ) => Type_from AST (Type_Bool root) where
 197         type_from ty ast k =
 198                 case ast of
 199                  AST "Bool" asts ->
 200                         case asts of
 201                          [] -> k type_bool
 202                          _ -> Left $ lift_error_type $
 203                                 Error_Type_Wrong_number_of_arguments ast 0
 204                  _ -> Left $ error_type_unsupported ty ast
 205 instance -- Type_from AST Type_Int
 206  ( Lift_Type_Root Type_Int root
 207  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 208  , Implicit_HBool (Is_Last_Type (Type_Int root) root)
 209  ) => Type_from AST (Type_Int root) where
 210         type_from ty ast k =
 211                 case ast of
 212                  AST "Int" asts ->
 213                         case asts of
 214                          [] -> k type_int
 215                          _ -> Left $ lift_error_type $
 216                                 Error_Type_Wrong_number_of_arguments ast 0
 217                  _ -> Left $ error_type_unsupported ty ast
 218 instance -- Type_from AST Type_Ordering
 219  ( Lift_Type_Root Type_Ordering root
 220  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 221  , Implicit_HBool (Is_Last_Type (Type_Ordering root) root)
 222  ) => Type_from AST (Type_Ordering root) where
 223         type_from ty ast k =
 224                 case ast of
 225                  AST "Ordering" asts ->
 226                         case asts of
 227                          [] -> k type_ordering
 228                          _ -> Left $ lift_error_type $
 229                                 Error_Type_Wrong_number_of_arguments ast 0
 230                  _ -> Left $ error_type_unsupported ty ast
 231 instance -- Type_from AST Type_Fun
 232  ( Eq_Type root
 233  , Type_from AST root
 234  , Lift_Type_Root (Type_Fun lam) root
 235  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 236  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 237  , Root_of_Type root ~ root
 238  , Implicit_HBool (Is_Last_Type (Type_Fun lam root) root)
 239  ) => Type_from AST (Type_Fun lam root) where
 240         type_from ty ast k =
 241                 case ast of
 242                  AST "->" asts ->
 243                         case asts of
 244                          [ast_arg, ast_res] -> type_fun_from ty ast_arg ast_res k
 245                          _ -> Left $ lift_error_type $
 246                                 Error_Type_Wrong_number_of_arguments ast 2
 247                  _ -> Left $ error_type_unsupported ty ast
 248 instance -- Type_from AST Type_Maybe
 249  ( Eq_Type root
 250  , Type_from AST root
 251  , Lift_Type_Root Type_Maybe root
 252  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 253  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 254  , Root_of_Type root ~ root
 255  , Implicit_HBool (Is_Last_Type (Type_Maybe root) root)
 256  ) => Type_from AST (Type_Maybe root) where
 257         type_from ty ast k =
 258                 case ast of
 259                  AST "Maybe" asts ->
 260                         case asts of
 261                          [ast_a] ->
 262                                 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
 263                                         k (type_maybe ty_a)
 264                          _ -> Left $ lift_error_type $
 265                                 Error_Type_Wrong_number_of_arguments ast 1
 266                  _ -> Left $ error_type_unsupported ty ast
 267 instance -- Type_from AST Type_List
 268  ( Eq_Type root
 269  , Type_from AST root
 270  , Lift_Type_Root Type_List root
 271  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 272  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 273  , Root_of_Type root ~ root
 274  , Implicit_HBool (Is_Last_Type (Type_List root) root)
 275  ) => Type_from AST (Type_List root) where
 276         type_from ty ast k =
 277                 case ast of
 278                  AST "[]" asts ->
 279                         case asts of
 280                          [ast_a] ->
 281                                 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
 282                                         k (type_list ty_a)
 283                          _ -> Left $ lift_error_type $
 284                                 Error_Type_Wrong_number_of_arguments ast 1
 285                  _ -> Left $ error_type_unsupported ty ast
 286
 287 instance -- Type1_from AST Type_Bool
 288  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 289  , Implicit_HBool (Is_Last_Type (Type_Bool root) root)
 290  ) => Type1_from AST (Type_Bool root)
 291 instance -- Type1_from AST Type_Int
 292  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 293  , Implicit_HBool (Is_Last_Type (Type_Int root) root)
 294  ) => Type1_from AST (Type_Int root)
 295 instance -- Type1_from AST Type_Unit
 296  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 297  , Implicit_HBool (Is_Last_Type (Type_Unit root) root)
 298  ) => Type1_from AST (Type_Unit root)
 299 instance -- Type1_from AST Type_Ordering
 300  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 301  , Implicit_HBool (Is_Last_Type (Type_Ordering root) root)
 302  ) => Type1_from AST (Type_Ordering root)
 303 instance -- Type1_from AST Type_Var0
 304  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 305  , Implicit_HBool (Is_Last_Type (Type_Var0 root) root)
 306  ) => Type1_from AST (Type_Var0 root)
 307 instance -- Type1_from AST Type_Var1
 308  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 309  , Implicit_HBool (Is_Last_Type (Type_Var1 root) root)
 310  ) => Type1_from AST (Type_Var1 root)
 311 instance -- Type1_from AST Type_Maybe
 312  ( Type_from AST root
 313  , Lift_Type_Root Type_Maybe root
 314  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 315  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 316  , Root_of_Type root ~ root
 317  , Implicit_HBool (Is_Last_Type (Type_Maybe root) root)
 318  ) => Type1_from AST (Type_Maybe root) where
 319         type1_from ty ast k =
 320                 case ast of
 321                  AST "Maybe" asts ->
 322                         case asts of
 323                          [] -> k (Proxy::Proxy Maybe) type_maybe
 324                          _ -> Left $ lift_error_type $
 325                                 Error_Type_Wrong_number_of_arguments ast 0
 326                  _ -> Left $ error_type_unsupported ty ast
 327 instance -- Type1_from AST Type_List
 328  ( Eq_Type root
 329  , Type_from AST root
 330  , Lift_Type_Root Type_List root
 331  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 332  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 333  , Root_of_Type root ~ root
 334  , Implicit_HBool (Is_Last_Type (Type_List root) root)
 335  ) => Type1_from AST (Type_List root) where
 336         type1_from ty ast k =
 337                 case ast of
 338                  AST "[]" asts ->
 339                         case asts of
 340                          [] -> k (Proxy::Proxy []) type_list
 341                          _ -> Left $ lift_error_type $
 342                                 Error_Type_Wrong_number_of_arguments ast 0
 343                  _ -> Left $ error_type_unsupported ty ast
 344 instance -- Type1_from AST Type_Fun
 345  ( Eq_Type root
 346  , Type_from AST root
 347  , Lift_Type_Root (Type_Fun lam) root
 348  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 349  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 350  , Root_of_Type root ~ root
 351  , Implicit_HBool (Is_Last_Type (Type_Fun lam root) root)
 352  ) => Type1_from AST (Type_Fun lam root) where
 353         type1_from ty ast k =
 354                 case ast of
 355                  AST "->" asts ->
 356                         case asts of
 357                          [ast_arg] ->
 358                                 type_from (Proxy::Proxy root) ast_arg $ \(ty_arg::root h_arg) ->
 359                                 k (Proxy::Proxy (Lambda lam h_arg)) $
 360                                         type_fun ty_arg
 361                          _ -> Left $ lift_error_type $
 362                                 Error_Type_Wrong_number_of_arguments ast 1
 363                  _ -> Left $ error_type_unsupported ty ast
 364
 365 instance -- Expr_from AST Expr_Bool
 366  ( Eq_Type (Type_Root_of_Expr root)
 367  , Type_from AST (Type_Root_of_Expr root)
 368  , Expr_from AST root
 369  , Lift_Type_Root Type_Bool (Type_Root_of_Expr root)
 370  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 371  , Unlift_Type Type_Bool (Type_of_Expr root)
 372  , Root_of_Expr root ~ root
 373  , Implicit_HBool (Is_Last_Expr (Expr_Bool root) root)
 374  ) => Expr_from AST (Expr_Bool root) where
 375         expr_from ex ast =
 376                 case ast of
 377                  AST "bool" asts -> lit_from_AST bool      type_bool asts ex ast
 378                  AST "not"  asts -> op1_from_AST Expr.not  type_bool asts ex ast
 379                  AST "&&"   asts -> op2_from_AST (Expr.&&) type_bool asts ex ast
 380                  AST "||"   asts -> op2_from_AST (Expr.||) type_bool asts ex ast
 381                  AST "xor"  asts -> op2_from_AST Expr.xor  type_bool asts ex ast
 382                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 383 instance -- Expr_from AST Expr_If
 384  ( Eq_Type (Type_Root_of_Expr root)
 385  , Type_from AST (Type_Root_of_Expr root)
 386  , Expr_from AST root
 387  , Lift_Type_Root Type_Bool (Type_Root_of_Expr root)
 388  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 389  , Root_of_Expr root ~ root
 390  , Implicit_HBool (Is_Last_Expr (Expr_If root) root)
 391  ) => Expr_from AST (Expr_If root) where
 392         expr_from ex ast ctx k =
 393                 case ast of
 394                  AST "if" asts -> from_ast3 asts if_from ex ast ctx k
 395                  _ -> Left $ error_expr_unsupported ex ast
 396 instance -- Expr_from AST Expr_When
 397  ( Eq_Type (Type_Root_of_Expr root)
 398  , Type_from AST (Type_Root_of_Expr root)
 399  , Expr_from AST root
 400  , Lift_Type_Root Type_Bool (Type_Root_of_Expr root)
 401  , Lift_Type_Root Type_Unit (Type_Root_of_Expr root)
 402  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 403  , Root_of_Expr root ~ root
 404  , Implicit_HBool (Is_Last_Expr (Expr_When root) root)
 405  ) => Expr_from AST (Expr_When root) where
 406         expr_from ex ast ctx k =
 407                 case ast of
 408                  AST "when" asts -> from_ast2 asts when_from ex ast ctx k
 409                  _ -> Left $ error_expr_unsupported ex ast
 410 instance -- Expr_from AST Expr_Int
 411  ( Eq_Type (Type_Root_of_Expr root)
 412  , Type_from AST (Type_Root_of_Expr root)
 413  , Expr_from AST root
 414  , Lift_Type_Root Type_Int (Type_Root_of_Expr root)
 415  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 416  , Unlift_Type Type_Int (Type_of_Expr root)
 417  , Root_of_Expr root ~ root
 418  , Implicit_HBool (Is_Last_Expr (Expr_Int root) root)
 419  ) => Expr_from AST (Expr_Int root) where
 420         expr_from ex ast =
 421                 case ast of
 422                  AST "int"    asts -> lit_from_AST int         type_int asts ex ast
 423                  AST "abs"    asts -> op1_from_AST Expr.abs    type_int asts ex ast
 424                  AST "negate" asts -> op1_from_AST Expr.negate type_int asts ex ast
 425                  AST "+"      asts -> op2_from_AST (Expr.+)    type_int asts ex ast
 426                  AST "-"      asts -> op2_from_AST (Expr.-)    type_int asts ex ast
 427                  AST "*"      asts -> op2_from_AST (Expr.*)    type_int asts ex ast
 428                  AST "mod"    asts -> op2_from_AST Expr.mod    type_int asts ex ast
 429                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 430 instance -- Expr_from AST Expr_Lambda
 431  ( Eq_Type (Type_Root_of_Expr root)
 432  , Type_from AST (Type_Root_of_Expr root)
 433  , Expr_from AST root
 434  , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
 435  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 436  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 437  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 438  , Root_of_Expr root ~ root
 439  , Implicit_HBool (Is_Last_Expr (Expr_Lambda_App lam root) root)
 440  ) => Expr_from AST (Expr_Lambda_App lam root) where
 441         expr_from ex ast ctx k =
 442                 case ast of
 443                  AST "var" asts ->
 444                         case asts of
 445                          [AST name []] -> var_from name ex ast ctx k
 446                          _ -> Left $ error_expr ex $
 447                                 Error_Expr_Wrong_number_of_arguments ast 1
 448                  AST "app" asts -> from_ast2 asts app_from ex ast ctx k
 449                  _ -> Left $ error_expr_unsupported ex ast
 450 instance -- Expr_from AST Expr_Lambda_Inline
 451  ( Eq_Type (Type_Root_of_Expr root)
 452  , Type_from AST (Type_Root_of_Expr root)
 453  , Expr_from AST root
 454  , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
 455  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 456  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 457  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 458  , Root_of_Expr root ~ root
 459  , Implicit_HBool (Is_Last_Expr (Expr_Lambda_Inline lam root) root)
 460  ) => Expr_from AST (Expr_Lambda_Inline lam root) where
 461         expr_from ex ast ctx k =
 462                 case ast of
 463                  AST "inline"     asts -> go_lam asts inline
 464                  AST "let_inline" asts -> go_let asts let_inline
 465                  _ -> Left $ error_expr_unsupported ex ast
 466                 where
 467                 go_lam asts
 468                  (lam::forall repr arg res. Sym_Lambda_Inline lam repr
 469                      => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
 470                         case asts of
 471                          [AST name [], ast_ty_arg, ast_body] ->
 472                                 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
 473                          _ -> Left $ error_expr ex $
 474                                 Error_Expr_Wrong_number_of_arguments ast 3
 475                 go_let asts
 476                  (let_::forall repr var res. Sym_Lambda_Inline lam repr
 477                      => repr var -> (repr var -> repr res) -> repr res) =
 478                         case asts of
 479                          [AST name [], ast_var, ast_body] ->
 480                                 let_from let_ name ast_var ast_body ex ast ctx k
 481                          _ -> Left $ error_expr ex $
 482                                 Error_Expr_Wrong_number_of_arguments ast 3
 483 instance -- Expr_from AST Expr_Lambda_Val
 484  ( Eq_Type (Type_Root_of_Expr root)
 485  , Type_from AST (Type_Root_of_Expr root)
 486  , Expr_from AST root
 487  , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
 488  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 489  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 490  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 491  , Root_of_Expr root ~ root
 492  , Implicit_HBool (Is_Last_Expr (Expr_Lambda_Val lam root) root)
 493  ) => Expr_from AST (Expr_Lambda_Val lam root) where
 494         expr_from ex ast ctx k =
 495                 case ast of
 496                  AST "val"     asts -> go_lam asts val
 497                  AST "let_val" asts -> go_let asts let_val
 498                  _ -> Left $ error_expr_unsupported ex ast
 499                 where
 500                 go_lam asts
 501                  (lam::forall repr arg res. Sym_Lambda_Val lam repr
 502                      => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
 503                         case asts of
 504                          [AST name [], ast_ty_arg, ast_body] ->
 505                                 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
 506                          _ -> Left $ error_expr ex $
 507                                 Error_Expr_Wrong_number_of_arguments ast 3
 508                 go_let asts
 509                  (let_::forall repr var res. Sym_Lambda_Val lam repr
 510                      => repr var -> (repr var -> repr res) -> repr res) =
 511                         case asts of
 512                          [AST name [], ast_var, ast_body] ->
 513                                 let_from let_ name ast_var ast_body ex ast ctx k
 514                          _ -> Left $ error_expr ex $
 515                                 Error_Expr_Wrong_number_of_arguments ast 3
 516 instance -- Expr_from AST Expr_Lambda_Lazy
 517  ( Eq_Type (Type_Root_of_Expr root)
 518  , Type_from AST (Type_Root_of_Expr root)
 519  , Expr_from AST root
 520  , Lift_Type_Root (Type_Fun lam) (Type_Root_of_Expr root)
 521  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 522  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 523  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 524  , Root_of_Expr root ~ root
 525  , Implicit_HBool (Is_Last_Expr (Expr_Lambda_Lazy lam root) root)
 526  ) => Expr_from AST (Expr_Lambda_Lazy lam root) where
 527         expr_from ex ast ctx k =
 528                 case ast of
 529                  AST "lazy"     asts -> go_lam asts lazy
 530                  AST "let_lazy" asts -> go_let asts let_lazy
 531                  _ -> Left $ error_expr_unsupported ex ast
 532                 where
 533                 go_lam asts
 534                  (lam::forall repr arg res. Sym_Lambda_Lazy lam repr
 535                      => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
 536                         case asts of
 537                          [AST name [], ast_ty_arg, ast_body] ->
 538                                 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
 539                          _ -> Left $ error_expr ex $
 540                                 Error_Expr_Wrong_number_of_arguments ast 3
 541                 go_let asts
 542                  (let_::forall repr var res. Sym_Lambda_Lazy lam repr
 543                      => repr var -> (repr var -> repr res) -> repr res) =
 544                         case asts of
 545                          [AST name [], ast_var, ast_body] ->
 546                                 let_from let_ name ast_var ast_body ex ast ctx k
 547                          _ -> Left $ error_expr ex $
 548                                 Error_Expr_Wrong_number_of_arguments ast 3
 549 instance -- Expr_from AST Expr_Maybe
 550  ( Eq_Type (Type_Root_of_Expr root)
 551  , Type_from AST (Type_Root_of_Expr root)
 552  , Expr_from AST root
 553  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 554  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 555  , Lift_Type   Type_Maybe     (Type_of_Expr root)
 556  , Unlift_Type Type_Maybe     (Type_of_Expr root)
 557  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 558  , Root_of_Expr root ~ root
 559  , Implicit_HBool (Is_Last_Expr (Expr_Maybe lam root) root)
 560  ) => Expr_from AST (Expr_Maybe lam root) where
 561         expr_from ex ast ctx k =
 562                 case ast of
 563                  AST "maybe"   asts -> from_ast3 asts maybe_from   ex ast ctx k
 564                  AST "nothing" asts -> from_ast1 asts nothing_from ex ast ctx k
 565                  AST "just"    asts -> from_ast1 asts just_from    ex ast ctx k
 566                  _ -> Left $ error_expr_unsupported ex ast
 567 instance -- Expr_from AST Expr_Eq
 568  ( Eq_Type (Type_Root_of_Expr root)
 569  , Type_from AST (Type_Root_of_Expr root)
 570  , Lift_Type Type_Bool (Type_of_Expr root)
 571  , Constraint_Type Eq (Type_Root_of_Expr root)
 572  , Expr_from AST root
 573  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 574  , Root_of_Expr root ~ root
 575  , Implicit_HBool (Is_Last_Expr (Expr_Eq root) root)
 576  ) => Expr_from AST (Expr_Eq root) where
 577         expr_from ex ast ctx k =
 578                 case ast of
 579                  AST "==" asts -> from_ast2 asts eq_from ex ast ctx k
 580                  _ -> Left $ error_expr_unsupported ex ast
 581 instance -- Expr_from AST Expr_Ord
 582  ( Eq_Type (Type_Root_of_Expr root)
 583  , Type_from AST (Type_Root_of_Expr root)
 584  , Lift_Type Type_Ordering (Type_of_Expr root)
 585  , Constraint_Type Ord (Type_Root_of_Expr root)
 586  , Expr_from AST root
 587  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 588  , Root_of_Expr root ~ root
 589  , Implicit_HBool (Is_Last_Expr (Expr_Ord root) root)
 590  ) => Expr_from AST (Expr_Ord root) where
 591         expr_from ex ast ctx k =
 592                 case ast of
 593                  AST "compare" asts -> from_ast2 asts compare_from ex ast ctx k
 594                  _ -> Left $ error_expr_unsupported ex ast
 595 instance -- Expr_from AST Expr_List
 596  ( Eq_Type (Type_Root_of_Expr root)
 597  , Type_from AST (Type_Root_of_Expr root)
 598  , Expr_from AST root
 599  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 600  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 601  , Lift_Type   Type_List      (Type_of_Expr root)
 602  , Unlift_Type Type_List      (Type_of_Expr root)
 603  , Lift_Type   Type_Bool      (Type_of_Expr root)
 604  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 605  , Root_of_Expr root ~ root
 606  , Implicit_HBool (Is_Last_Expr (Expr_List lam root) root)
 607  ) => Expr_from AST (Expr_List lam root) where
 608         expr_from ex ast ctx k =
 609                 case ast of
 610                  AST "[]"          asts -> from_ast1 asts list_empty_from  ex ast ctx k
 611                  AST ":"           asts -> from_ast2 asts list_cons_from   ex ast ctx k
 612                  AST "list_filter" asts -> from_ast2 asts list_filter_from ex ast ctx k
 613                  AST "list"        asts ->
 614                         case asts of
 615                          ast_ty_a:asts' -> list_from ast_ty_a asts' ex ast ctx k
 616                          _ -> Left $ error_expr ex $
 617                                 Error_Expr_Wrong_number_of_arguments ast 1
 618                  _ -> Left $ error_expr_unsupported ex ast
 619 instance -- Expr_from AST Expr_Map
 620  ( Eq_Type (Type_Root_of_Expr root)
 621  , Type_from AST (Type_Root_of_Expr root)
 622  , Expr_from AST root
 623  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 624  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 625  , Lift_Type   Type_Map       (Type_of_Expr root)
 626  , Unlift_Type Type_Map       (Type_of_Expr root)
 627  , Lift_Type   Type_List      (Type_of_Expr root)
 628  , Unlift_Type Type_List      (Type_of_Expr root)
 629  , Lift_Type   Type_Tuple2    (Type_of_Expr root)
 630  , Unlift_Type Type_Tuple2    (Type_of_Expr root)
 631  , Constraint_Type Ord (Type_Root_of_Expr root)
 632  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 633  , Root_of_Expr root ~ root
 634  , Implicit_HBool (Is_Last_Expr (Expr_Map lam root) root)
 635  ) => Expr_from AST (Expr_Map lam root) where
 636         expr_from ex ast ctx k =
 637                 case ast of
 638                  AST "map_from_list" asts -> from_ast1 asts map_from_list_from ex ast ctx k
 639                  AST "map_map" asts -> from_ast2 asts map_map_from ex ast ctx k
 640                  _ -> Left $ error_expr_unsupported ex ast
 641 instance -- Expr_from AST Expr_Functor
 642  ( Eq_Type (Type_Root_of_Expr root)
 643  , Type_from AST (Type_Root_of_Expr root)
 644  , Expr_from AST root
 645  , String_from_Type (Type_Root_of_Expr root)
 646  -- , Lift_Type   Type_Var1      (Type_of_Expr root)
 647  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 648  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 649  , Unlift_Type1 (Type_of_Expr root)
 650  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 651  , Constraint_Type1 Functor (Type_Root_of_Expr root)
 652  , Root_of_Expr root ~ root
 653  , Implicit_HBool (Is_Last_Expr (Expr_Functor lam root) root)
 654  ) => Expr_from AST (Expr_Functor lam root) where
 655         expr_from ex ast ctx k =
 656                 case ast of
 657                  AST "fmap" asts -> from_ast2 asts fmap_from ex ast ctx k
 658                  AST "<$>"  asts -> from_ast2 asts fmap_from ex ast ctx k
 659                  _ -> Left $ error_expr_unsupported ex ast
 660 instance -- Expr_from AST Expr_Applicative
 661  ( Eq_Type (Type_Root_of_Expr root)
 662  , Type1_from AST (Type_Root_of_Expr root)
 663  , Expr_from AST root
 664  , String_from_Type (Type_Root_of_Expr root)
 665  -- , Lift_Type   Type_Var1      (Type_of_Expr root)
 666  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 667  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 668  , Eq_Type1 (Type_Root_of_Expr root)
 669  , Unlift_Type1 (Type_of_Expr root)
 670  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 671  , Constraint_Type1 Applicative (Type_Root_of_Expr root)
 672  , Root_of_Expr root ~ root
 673  , Implicit_HBool (Is_Last_Expr (Expr_Applicative lam root) root)
 674  ) => Expr_from AST (Expr_Applicative lam root) where
 675         expr_from ex ast ctx k =
 676                 case ast of
 677                  AST "pure" asts -> from_ast2 asts pure_from     ex ast ctx k
 678                  AST "<*>"  asts -> from_ast2 asts ltstargt_from ex ast ctx k
 679                  _ -> Left $ error_expr_unsupported ex ast