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