Language/Symantic/AST/Test.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# LANGUAGE TypeOperators #-}
  11 {-# LANGUAGE UndecidableInstances #-}
  12 -- | Abstract Syntax Tree.
  13 module AST.Test where
  14
  15 import Test.Tasty
  16 -- import Test.Tasty.HUnit
  17
  18 import qualified Data.List as List
  19 import Data.Proxy (Proxy(..))
  20 import Data.Text (Text)
  21 import qualified Data.Text as Text
  22 import qualified Data.MonoTraversable as MT
  23
  24 import Language.Symantic.Lib.Data.Bool
  25 import Language.Symantic.Type
  26 import Language.Symantic.Expr as Expr
  27
  28 tests :: TestTree
  29 tests = testGroup "AST" $
  30  [
  31  ]
  32
  33 -- * Type 'AST'
  34 data AST
  35  =   AST Text [AST]
  36  deriving (Eq)
  37 -- | Custom 'Show' instance a little bit more readable
  38 -- than the automatically derived one.
  39 instance Show AST where
  40         showsPrec p ast@(AST f args) =
  41                 let n = Text.unpack f in
  42                 case ast of
  43                  AST _ [] -> showString n
  44                  AST "->" [a] ->
  45                                 showParen (p >= prec_arrow) $
  46                                 showString ("("++n++") ") .
  47                                 showsPrec prec_arrow a
  48                  AST "->" [a, b] ->
  49                                 showParen (p >= prec_arrow) $
  50                                 showsPrec prec_arrow a .
  51                                 showString (" "++n++" ") .
  52                                 showsPrec prec_arrow b
  53                  AST "\\" [var, ty, body] ->
  54                                 showParen (p >= prec_lambda) $
  55                                 showString ("\\(") .
  56                                 showsPrec prec_lambda var .
  57                                 showString (":") .
  58                                 showsPrec prec_lambda ty .
  59                                 showString (") -> ") .
  60                                 showsPrec prec_lambda body
  61                  AST "$" [fun, arg] ->
  62                                 showParen (p >= prec_app) $
  63                                 showsPrec prec_app fun .
  64                                 showString (" $ ") .
  65                                 showsPrec prec_app arg
  66                  _ ->
  67                         showString n .
  68                         showString "(" .
  69                         showString (List.intercalate ", " $ show Prelude.<$> args) .
  70                         showString ")"
  71                 where prec_arrow  = 1
  72                       prec_lambda = 1
  73                       prec_app    = 1
  74
  75 -- ** Parsing utilities
  76 from_ast0
  77  :: forall ty ast ex hs ret.
  78  ( ty ~ Type_Root_of_Expr ex
  79  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
  80                    (Error_of_Expr ast (Root_of_Expr ex))
  81  ) => [ast]
  82  -> Expr_From ast ex hs ret
  83  -> Expr_From ast ex hs ret
  84 from_ast0 asts k' ex ast ctx k =
  85         case asts of
  86          [] -> k' ex ast ctx k
  87          _ -> Left $ error_expr ex $
  88                 Error_Expr_Wrong_number_of_arguments ast 0
  89
  90 from_ast1
  91  :: forall ty ast ex hs ret.
  92  ( ty ~ Type_Root_of_Expr ex
  93  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
  94                    (Error_of_Expr ast (Root_of_Expr ex))
  95  ) => [ast] -> (ast -> Expr_From ast ex hs ret)
  96  -> Expr_From ast ex hs ret
  97 from_ast1 asts k' ex ast ctx k =
  98         case asts of
  99          [ast_0] -> k' ast_0 ex ast ctx k
 100          _ -> Left $ error_expr ex $
 101                 Error_Expr_Wrong_number_of_arguments ast 1
 102
 103 from_ast2
 104  :: forall ty ast ex hs ret.
 105  ( ty ~ Type_Root_of_Expr ex
 106  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 107                    (Error_of_Expr ast (Root_of_Expr ex))
 108  ) => [ast] -> (ast -> ast -> Expr_From ast ex hs ret)
 109  -> Expr_From ast ex hs ret
 110 from_ast2 asts k' ex ast ctx k =
 111         case asts of
 112          [ast_0, ast_1] -> k' ast_0 ast_1 ex ast ctx k
 113          _ -> Left $ error_expr ex $
 114                 Error_Expr_Wrong_number_of_arguments ast 2
 115
 116 from_ast3
 117  :: forall ty ast ex hs ret.
 118  ( ty ~ Type_Root_of_Expr ex
 119  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 120                    (Error_of_Expr ast (Root_of_Expr ex))
 121  ) => [ast] -> (ast -> ast -> ast -> Expr_From ast ex hs ret)
 122  -> Expr_From ast ex hs ret
 123 from_ast3 asts k' ex ast ctx k =
 124         case asts of
 125          [ast_0, ast_1, ast_2] -> k' ast_0 ast_1 ast_2 ex ast ctx k
 126          _ -> Left $ error_expr ex $
 127                 Error_Expr_Wrong_number_of_arguments ast 3
 128
 129 lit_from_AST
 130  :: forall root ty lit ex ast hs ret.
 131  ( ty ~ Type_Root_of_Expr ex
 132  , root ~ Root_of_Expr ex
 133  , ast ~ AST
 134  , Read lit
 135  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 136                    (Error_of_Expr ast root)
 137  ) => (forall repr. Sym_of_Expr ex repr => lit -> repr lit)
 138  -> ty lit -> [ast]
 139  -> Expr_From ast ex hs ret
 140 lit_from_AST op ty_lit asts ex ast ctx k =
 141         case asts of
 142          [AST lit []] -> lit_from op ty_lit lit ex ast ctx k
 143          _ -> Left $ error_expr ex $
 144                 Error_Expr_Wrong_number_of_arguments ast 1
 145
 146 op1_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)
 157  -> ty lit -> [ast]
 158  -> Expr_From ast ex hs ret
 159 op1_from_AST op ty_lit asts ex ast ctx k =
 160         case asts of
 161          [ast_x] -> op1_from op ty_lit ast_x ex ast ctx k
 162          _ -> Left $ error_expr ex $
 163                 Error_Expr_Wrong_number_of_arguments ast 1
 164
 165 op2_from_AST
 166  :: forall root ty lit ex ast hs ret.
 167  ( ty ~ Type_Root_of_Expr ex
 168  , root ~ Root_of_Expr ex
 169  , ast ~ AST
 170  , Eq_Type (Type_Root_of_Expr root)
 171  , Expr_from ast root
 172  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 173                    (Error_of_Expr ast root)
 174  , Root_of_Expr root ~ root
 175  ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
 176  -> ty lit -> [ast]
 177  -> Expr_From ast ex hs ret
 178 op2_from_AST op ty_lit asts ex ast ctx k =
 179         case asts of
 180          [ast_x, ast_y] -> op2_from op ty_lit ast_x ast_y ex ast ctx k
 181          _ -> Left $ error_expr ex $
 182                 Error_Expr_Wrong_number_of_arguments ast 2
 183
 184 class_op1_from_AST
 185  :: forall root ty c ex ast hs ret.
 186  ( ty ~ Type_Root_of_Expr ex
 187  , root ~ Root_of_Expr ex
 188  , ast ~ AST
 189  , Eq_Type (Type_Root_of_Expr root)
 190  , Expr_from ast root
 191  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 192                    (Error_of_Expr ast root)
 193  , Root_of_Expr root ~ root
 194  , Constraint_Type c ty
 195  ) => (forall lit repr. (c lit, Sym_of_Expr ex repr) => repr lit -> repr lit)
 196  -> Proxy c -> [ast]
 197  -> Expr_From ast ex hs ret
 198 class_op1_from_AST op c asts ex ast ctx k =
 199         case asts of
 200          [ast_x] -> class_op1_from op c ast_x ex ast ctx k
 201          _ -> Left $ error_expr ex $
 202                 Error_Expr_Wrong_number_of_arguments ast 1
 203
 204 class_op2_from_AST
 205  :: forall root ty c ex ast hs ret.
 206  ( ty ~ Type_Root_of_Expr ex
 207  , root ~ Root_of_Expr ex
 208  , ast ~ AST
 209  , Eq_Type (Type_Root_of_Expr root)
 210  , Expr_from ast root
 211  , Lift_Error_Expr (Error_Expr (Error_of_Type ast ty) ty ast)
 212                    (Error_of_Expr ast root)
 213  , Root_of_Expr root ~ root
 214  , Constraint_Type c ty
 215  ) => (forall lit repr. (c lit, Sym_of_Expr ex repr) => repr lit -> repr lit -> repr lit)
 216  -> Proxy c -> [ast]
 217  -> Expr_From ast ex hs ret
 218 class_op2_from_AST op c asts ex ast ctx k =
 219         case asts of
 220          [ast_x, ast_y] -> class_op2_from op c ast_x ast_y ex ast ctx k
 221          _ -> Left $ error_expr ex $
 222                 Error_Expr_Wrong_number_of_arguments ast 2
 223
 224 instance -- Type_from AST Type_Var0
 225  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 226  , IBool (Is_Last_Type (Type_Var0 root) root)
 227  ) => Type_from AST (Type_Var0 root) where
 228         type_from ty ast _k =
 229                 Left $ error_type_unsupported ty ast
 230          -- NOTE: no support so far.
 231 instance -- Type_from AST Type_Var1
 232  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 233  , IBool (Is_Last_Type (Type_Var1 root) root)
 234  ) => Type_from AST (Type_Var1 root) where
 235         type_from ty ast _k =
 236                 Left $ error_type_unsupported ty ast
 237          -- NOTE: no support so far.
 238 instance -- Type_from AST Type_Unit
 239  ( Lift_Type_Root Type_Unit root
 240  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 241  , IBool (Is_Last_Type (Type_Unit root) root)
 242  ) => Type_from AST (Type_Unit root) where
 243         type_from ty ast k =
 244                 case ast of
 245                  AST "()" asts ->
 246                         case asts of
 247                          [] -> k type_unit
 248                          _ -> Left $ lift_error_type $
 249                                 Error_Type_Wrong_number_of_arguments ast 0
 250                  _ -> Left $ error_type_unsupported ty ast
 251 instance -- Type_from AST Type_Bool
 252  ( Lift_Type_Root Type_Bool root
 253  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 254  , IBool (Is_Last_Type (Type_Bool root) root)
 255  ) => Type_from AST (Type_Bool root) where
 256         type_from ty ast k =
 257                 case ast of
 258                  AST "Bool" asts ->
 259                         case asts of
 260                          [] -> k type_bool
 261                          _ -> Left $ lift_error_type $
 262                                 Error_Type_Wrong_number_of_arguments ast 0
 263                  _ -> Left $ error_type_unsupported ty ast
 264 instance -- Type_from AST Type_Char
 265  ( Lift_Type_Root Type_Char root
 266  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 267  , IBool (Is_Last_Type (Type_Char root) root)
 268  ) => Type_from AST (Type_Char root) where
 269         type_from ty ast k =
 270                 case ast of
 271                  AST "Char" asts ->
 272                         case asts of
 273                          [] -> k type_char
 274                          _ -> Left $ lift_error_type $
 275                                 Error_Type_Wrong_number_of_arguments ast 0
 276                  _ -> Left $ error_type_unsupported ty ast
 277 instance -- Type_from AST Type_Int
 278  ( Lift_Type_Root Type_Int root
 279  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 280  , IBool (Is_Last_Type (Type_Int root) root)
 281  ) => Type_from AST (Type_Int root) where
 282         type_from ty ast k =
 283                 case ast of
 284                  AST "Int" asts ->
 285                         case asts of
 286                          [] -> k type_int
 287                          _ -> Left $ lift_error_type $
 288                                 Error_Type_Wrong_number_of_arguments ast 0
 289                  _ -> Left $ error_type_unsupported ty ast
 290 instance -- Type_from AST Type_Text
 291  ( Lift_Type_Root Type_Text root
 292  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 293  , IBool (Is_Last_Type (Type_Text root) root)
 294  ) => Type_from AST (Type_Text root) where
 295         type_from ty ast k =
 296                 case ast of
 297                  AST "Text" asts ->
 298                         case asts of
 299                          [] -> k type_text
 300                          _ -> Left $ lift_error_type $
 301                                 Error_Type_Wrong_number_of_arguments ast 0
 302                  _ -> Left $ error_type_unsupported ty ast
 303 instance -- Type_from AST Type_Ordering
 304  ( Lift_Type_Root Type_Ordering root
 305  , Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 306  , IBool (Is_Last_Type (Type_Ordering root) root)
 307  ) => Type_from AST (Type_Ordering root) where
 308         type_from ty ast k =
 309                 case ast of
 310                  AST "Ordering" asts ->
 311                         case asts of
 312                          [] -> k type_ordering
 313                          _ -> Left $ lift_error_type $
 314                                 Error_Type_Wrong_number_of_arguments ast 0
 315                  _ -> Left $ error_type_unsupported ty ast
 316 instance -- Type_from AST Type_Fun
 317  ( Eq_Type root
 318  , Type_from AST root
 319  , Lift_Type_Root Type_Fun root
 320  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 321  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 322  , Root_of_Type root ~ root
 323  , IBool (Is_Last_Type (Type_Fun root) root)
 324  ) => Type_from AST (Type_Fun root) where
 325         type_from ty ast k =
 326                 case ast of
 327                  AST "->" asts ->
 328                         case asts of
 329                          [ast_arg, ast_res] -> type_fun_from ty ast_arg ast_res k
 330                          _ -> Left $ lift_error_type $
 331                                 Error_Type_Wrong_number_of_arguments ast 2
 332                  _ -> Left $ error_type_unsupported ty ast
 333 instance -- Type_from AST Type_Maybe
 334  ( Eq_Type root
 335  , Type_from AST root
 336  , Lift_Type_Root Type_Maybe root
 337  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 338  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 339  , Root_of_Type root ~ root
 340  , IBool (Is_Last_Type (Type_Maybe root) root)
 341  ) => Type_from AST (Type_Maybe root) where
 342         type_from ty ast k =
 343                 case ast of
 344                  AST "Maybe" asts ->
 345                         case asts of
 346                          [ast_a] ->
 347                                 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
 348                                 k (type_maybe ty_a)
 349                          _ -> Left $ lift_error_type $
 350                                 Error_Type_Wrong_number_of_arguments ast 1
 351                  _ -> Left $ error_type_unsupported ty ast
 352 instance -- Type_from AST Type_List
 353  ( Eq_Type root
 354  , Type_from AST root
 355  , Lift_Type_Root Type_List root
 356  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 357  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 358  , Root_of_Type root ~ root
 359  , IBool (Is_Last_Type (Type_List root) root)
 360  ) => Type_from AST (Type_List root) where
 361         type_from ty ast k =
 362                 case ast of
 363                  AST "[]" asts ->
 364                         case asts of
 365                          [ast_a] ->
 366                                 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
 367                                 k (type_list ty_a)
 368                          _ -> Left $ lift_error_type $
 369                                 Error_Type_Wrong_number_of_arguments ast 1
 370                  _ -> Left $ error_type_unsupported ty ast
 371 instance -- Type_from AST Type_Map
 372  ( Eq_Type root
 373  , Type_from AST root
 374  , Lift_Type_Root Type_Map root
 375  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 376  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 377  , Constraint_Type Ord root
 378  , Root_of_Type root ~ root
 379  , IBool (Is_Last_Type (Type_Map root) root)
 380  ) => Type_from AST (Type_Map root) where
 381         type_from ty ast k =
 382                 case ast of
 383                  AST "Map" asts ->
 384                         case asts of
 385                          [ast_k, ast_a] ->
 386                                 type_from (Proxy::Proxy root) ast_k $ \ty_k ->
 387                                 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
 388                                 k (type_map ty_k ty_a)
 389                          _ -> Left $ lift_error_type $
 390                                 Error_Type_Wrong_number_of_arguments ast 2
 391                  _ -> Left $ error_type_unsupported ty ast
 392 instance -- Type_from AST Type_Tuple2
 393  ( Eq_Type root
 394  , Type_from AST root
 395  , Lift_Type_Root Type_Tuple2 root
 396  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 397  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 398  , Root_of_Type root ~ root
 399  , IBool (Is_Last_Type (Type_Tuple2 root) root)
 400  ) => Type_from AST (Type_Tuple2 root) where
 401         type_from ty ast k =
 402                 case ast of
 403                  AST "(,)" asts ->
 404                         case asts of
 405                          [ast_a, ast_b] ->
 406                                 type_from (Proxy::Proxy root) ast_a $ \ty_a ->
 407                                 type_from (Proxy::Proxy root) ast_b $ \ty_b ->
 408                                 k (type_tuple2 ty_a ty_b)
 409                          _ -> Left $ lift_error_type $
 410                                 Error_Type_Wrong_number_of_arguments ast 2
 411                  _ -> Left $ error_type_unsupported ty ast
 412 instance -- Type_from AST Type_Either
 413  ( Eq_Type root
 414  , Type_from AST root
 415  , Lift_Type_Root Type_Either root
 416  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 417  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 418  , Root_of_Type root ~ root
 419  , IBool (Is_Last_Type (Type_Either root) root)
 420  ) => Type_from AST (Type_Either root) where
 421         type_from ty ast k =
 422                 case ast of
 423                  AST "Either" asts ->
 424                         case asts of
 425                          [ast_l, ast_r] ->
 426                                 type_from (Proxy::Proxy root) ast_l $ \ty_l ->
 427                                 type_from (Proxy::Proxy root) ast_r $ \ty_r ->
 428                                 k (type_either ty_l ty_r)
 429                          _ -> Left $ lift_error_type $
 430                                 Error_Type_Wrong_number_of_arguments ast 2
 431                  _ -> Left $ error_type_unsupported ty ast
 432
 433 instance -- Type1_from AST Type_Bool
 434  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 435  , IBool (Is_Last_Type (Type_Bool root) root)
 436  ) => Type1_from AST (Type_Bool root)
 437 instance -- Type1_from AST Type_Int
 438  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 439  , IBool (Is_Last_Type (Type_Int root) root)
 440  ) => Type1_from AST (Type_Int root)
 441 instance -- Type1_from AST Type_Unit
 442  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 443  , IBool (Is_Last_Type (Type_Unit root) root)
 444  ) => Type1_from AST (Type_Unit root)
 445 instance -- Type1_from AST Type_Ordering
 446  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 447  , IBool (Is_Last_Type (Type_Ordering root) root)
 448  ) => Type1_from AST (Type_Ordering root)
 449 instance -- Type1_from AST Type_Var0
 450  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 451  , IBool (Is_Last_Type (Type_Var0 root) root)
 452  ) => Type1_from AST (Type_Var0 root)
 453 instance -- Type1_from AST Type_Var1
 454  ( Lift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 455  , IBool (Is_Last_Type (Type_Var1 root) root)
 456  ) => Type1_from AST (Type_Var1 root)
 457 instance -- Type1_from AST Type_Maybe
 458  ( Type_from AST root
 459  , Lift_Type_Root Type_Maybe root
 460  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 461  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 462  , Root_of_Type root ~ root
 463  , IBool (Is_Last_Type (Type_Maybe root) root)
 464  ) => Type1_from AST (Type_Maybe root) where
 465         type1_from ty ast k =
 466                 case ast of
 467                  AST "Maybe" asts ->
 468                         case asts of
 469                          [] -> k (Proxy::Proxy Maybe) type_maybe
 470                          _ -> Left $ lift_error_type $
 471                                 Error_Type_Wrong_number_of_arguments ast 0
 472                  _ -> Left $ error_type_unsupported ty ast
 473 instance -- Type1_from AST Type_List
 474  ( Eq_Type root
 475  , Type_from AST root
 476  , Lift_Type_Root Type_List root
 477  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 478  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 479  , Root_of_Type root ~ root
 480  , IBool (Is_Last_Type (Type_List root) root)
 481  ) => Type1_from AST (Type_List root) where
 482         type1_from ty ast k =
 483                 case ast of
 484                  AST "[]" asts ->
 485                         case asts of
 486                          [] -> k (Proxy::Proxy []) type_list
 487                          _ -> Left $ lift_error_type $
 488                                 Error_Type_Wrong_number_of_arguments ast 0
 489                  _ -> Left $ error_type_unsupported ty ast
 490 instance -- Type1_from AST Type_IO
 491  ( Eq_Type root
 492  , Type_from AST root
 493  , Lift_Type_Root Type_IO root
 494  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 495  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 496  , Root_of_Type root ~ root
 497  , IBool (Is_Last_Type (Type_IO root) root)
 498  ) => Type1_from AST (Type_IO root) where
 499         type1_from ty ast k =
 500                 case ast of
 501                  AST "IO" asts ->
 502                         case asts of
 503                          [] -> k (Proxy::Proxy IO) type_io
 504                          _ -> Left $ lift_error_type $
 505                                 Error_Type_Wrong_number_of_arguments ast 0
 506                  _ -> Left $ error_type_unsupported ty ast
 507 instance -- Type1_from AST Type_Fun
 508  ( Eq_Type root
 509  , Type_from AST root
 510  , Lift_Type_Root Type_Fun root
 511  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 512  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 513  , Root_of_Type root ~ root
 514  , IBool (Is_Last_Type (Type_Fun root) root)
 515  ) => Type1_from AST (Type_Fun root) where
 516         type1_from ty ast k =
 517                 case ast of
 518                  AST "->" asts ->
 519                         case asts of
 520                          [ast_arg] ->
 521                                 type_from (Proxy::Proxy root) ast_arg $ \(ty_arg::root h_arg) ->
 522                                 k (Proxy::Proxy ((->) h_arg)) $
 523                                         type_fun ty_arg
 524                          _ -> Left $ lift_error_type $
 525                                 Error_Type_Wrong_number_of_arguments ast 1
 526                  _ -> Left $ error_type_unsupported ty ast
 527 instance -- Type1_from AST Type_Either
 528  ( Eq_Type root
 529  , Type_from AST root
 530  , Lift_Type_Root Type_Either root
 531  , Lift_Error_Type   (Error_Type AST) (Error_of_Type AST root)
 532  , Unlift_Error_Type (Error_Type AST) (Error_of_Type AST root)
 533  , Root_of_Type root ~ root
 534  , IBool (Is_Last_Type (Type_Either root) root)
 535  ) => Type1_from AST (Type_Either root) where
 536         type1_from ty ast k =
 537                 case ast of
 538                  AST "Either" asts ->
 539                         case asts of
 540                          [ast_l] ->
 541                                 type_from (Proxy::Proxy root) ast_l $ \(ty_l::root h_l) ->
 542                                 k (Proxy::Proxy (Either h_l)) $
 543                                         type_either ty_l
 544                          _ -> Left $ lift_error_type $
 545                                 Error_Type_Wrong_number_of_arguments ast 1
 546                  _ -> Left $ error_type_unsupported ty ast
 547
 548 instance -- Expr_from AST Expr_Bool
 549  ( Eq_Type (Type_Root_of_Expr root)
 550  , Expr_from AST root
 551  , Lift_Type Type_Bool (Type_of_Expr root)
 552  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 553  , Unlift_Type Type_Bool (Type_of_Expr root)
 554  , Root_of_Expr root ~ root
 555  , IBool (Is_Last_Expr (Expr_Bool root) root)
 556  ) => Expr_from AST (Expr_Bool root) where
 557         expr_from ex ast =
 558                 case ast of
 559                  AST "bool" asts -> lit_from_AST bool      type_bool asts ex ast
 560                  AST "not"  asts -> op1_from_AST Expr.not  type_bool asts ex ast
 561                  AST "&&"   asts -> op2_from_AST (Expr.&&) type_bool asts ex ast
 562                  AST "||"   asts -> op2_from_AST (Expr.||) type_bool asts ex ast
 563                  AST "xor"  asts -> op2_from_AST Expr.xor  type_bool asts ex ast
 564                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 565 instance -- Expr_from AST Expr_If
 566  ( Eq_Type (Type_Root_of_Expr root)
 567  , Expr_from AST root
 568  , Lift_Type Type_Bool (Type_of_Expr root)
 569  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 570  , Root_of_Expr root ~ root
 571  , IBool (Is_Last_Expr (Expr_If root) root)
 572  ) => Expr_from AST (Expr_If root) where
 573         expr_from ex ast ctx k =
 574                 case ast of
 575                  AST "if" asts -> from_ast3 asts if_from ex ast ctx k
 576                  _ -> Left $ error_expr_unsupported ex ast
 577 instance -- Expr_from AST Expr_When
 578  ( Eq_Type (Type_Root_of_Expr root)
 579  , Expr_from AST root
 580  , Lift_Type Type_Bool (Type_of_Expr root)
 581  , Lift_Type Type_Unit (Type_of_Expr root)
 582  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 583  , Root_of_Expr root ~ root
 584  , IBool (Is_Last_Expr (Expr_When root) root)
 585  ) => Expr_from AST (Expr_When root) where
 586         expr_from ex ast ctx k =
 587                 case ast of
 588                  AST "when" asts -> from_ast2 asts when_from ex ast ctx k
 589                  _ -> Left $ error_expr_unsupported ex ast
 590 instance -- Expr_from AST Expr_Int
 591  ( Eq_Type (Type_Root_of_Expr root)
 592  , Expr_from AST root
 593  , Lift_Type Type_Int (Type_of_Expr root)
 594  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 595  , Unlift_Type Type_Int (Type_of_Expr root)
 596  , Root_of_Expr root ~ root
 597  , IBool (Is_Last_Expr (Expr_Int root) root)
 598  ) => Expr_from AST (Expr_Int root) where
 599         expr_from ex ast =
 600                 case ast of
 601                  AST "int" asts -> lit_from_AST int type_int asts ex ast
 602                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 603 instance -- Expr_from AST Expr_Integer
 604  ( Eq_Type (Type_Root_of_Expr root)
 605  , Expr_from AST root
 606  , Lift_Type Type_Integer (Type_of_Expr root)
 607  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 608  , Unlift_Type Type_Integer (Type_of_Expr root)
 609  , Root_of_Expr root ~ root
 610  , IBool (Is_Last_Expr (Expr_Integer root) root)
 611  ) => Expr_from AST (Expr_Integer root) where
 612         expr_from ex ast =
 613                 case ast of
 614                  AST "integer" asts -> lit_from_AST integer type_integer asts ex ast
 615                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 616 instance -- Expr_from AST Expr_Num
 617  ( Eq_Type (Type_Root_of_Expr root)
 618  , Expr_from AST root
 619  , Constraint_Type Num (Type_Root_of_Expr root)
 620  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 621  , Root_of_Expr root ~ root
 622  , IBool (Is_Last_Expr (Expr_Num root) root)
 623  ) => Expr_from AST (Expr_Num root) where
 624         expr_from ex ast =
 625                 let c = (Proxy :: Proxy Num) in
 626                 case ast of
 627                  AST "abs"    asts -> class_op1_from_AST Expr.abs    c asts ex ast
 628                  AST "negate" asts -> class_op1_from_AST Expr.negate c asts ex ast
 629                  AST "+"      asts -> class_op2_from_AST (Expr.+)    c asts ex ast
 630                  AST "-"      asts -> class_op2_from_AST (Expr.-)    c asts ex ast
 631                  AST "*"      asts -> class_op2_from_AST (Expr.*)    c asts ex ast
 632                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 633 instance -- Expr_from AST Expr_Integral
 634  ( Eq_Type (Type_Root_of_Expr root)
 635  , Expr_from AST root
 636  , Constraint_Type Integral (Type_Root_of_Expr root)
 637  , Lift_Type   Type_Tuple2  (Type_of_Expr root)
 638  , Lift_Type   Type_Integer (Type_of_Expr root)
 639  , Unlift_Type Type_Integer (Type_of_Expr root)
 640  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 641  , Root_of_Expr root ~ root
 642  , IBool (Is_Last_Expr (Expr_Integral root) root)
 643  ) => Expr_from AST (Expr_Integral root) where
 644         expr_from ex ast ctx k =
 645                 let c = (Proxy :: Proxy Integral) in
 646                 case ast of
 647                  AST "quot"    asts -> class_op2_from_AST Expr.quot c asts ex ast ctx k
 648                  AST "div"     asts -> class_op2_from_AST Expr.div  c asts ex ast ctx k
 649                  AST "rem"     asts -> class_op2_from_AST Expr.rem  c asts ex ast ctx k
 650                  AST "mod"     asts -> class_op2_from_AST Expr.mod  c asts ex ast ctx k
 651                  AST "quotRem" asts -> from_ast2 asts quotRem_from         ex ast ctx k
 652                  AST "divMod"  asts -> from_ast2 asts divMod_from          ex ast ctx k
 653                  _ -> Left $ error_expr_unsupported ex ast
 654 instance -- Expr_from AST Expr_Text
 655  ( Eq_Type (Type_Root_of_Expr root)
 656  , Expr_from AST root
 657  , Lift_Type Type_Text (Type_of_Expr root)
 658  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 659  , Unlift_Type Type_Text (Type_of_Expr root)
 660  , Root_of_Expr root ~ root
 661  , IBool (Is_Last_Expr (Expr_Text root) root)
 662  ) => Expr_from AST (Expr_Text root) where
 663         expr_from ex ast =
 664                 case ast of
 665                  AST "text" asts ->
 666                         case asts of
 667                          [AST lit []] -> \_ctx k ->
 668                                 k type_text $ Forall_Repr_with_Context $ \_c -> text lit
 669                          _ -> \_ctx _k -> Left $ error_expr ex $
 670                                 Error_Expr_Wrong_number_of_arguments ast 1
 671                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 672 instance -- Expr_from AST Expr_Char
 673  ( Eq_Type (Type_Root_of_Expr root)
 674  , Expr_from AST root
 675  , Lift_Type Type_Char (Type_of_Expr root)
 676  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 677  , Unlift_Type Type_Char (Type_of_Expr root)
 678  , Root_of_Expr root ~ root
 679  , IBool (Is_Last_Expr (Expr_Char root) root)
 680  ) => Expr_from AST (Expr_Char root) where
 681         expr_from ex ast =
 682                 case ast of
 683                  AST "char" asts ->
 684                         case asts of
 685                          [AST lit []] ->
 686                                 case Text.uncons lit of
 687                                  Just (c, "") -> \_ctx k ->
 688                                         k type_char $ Forall_Repr_with_Context $ \_c -> char c
 689                                  _ -> \_ctx _k -> Left $ error_expr ex $
 690                                         Error_Expr_Read (Error_Read lit) ast
 691                          _ -> \_ctx _k -> Left $ error_expr ex $
 692                                 Error_Expr_Wrong_number_of_arguments ast 1
 693                  AST "char_toUpper" asts -> op1_from_AST char_toUpper type_char asts ex ast
 694                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 695 instance -- Expr_from AST Expr_Lambda
 696  ( Eq_Type (Type_Root_of_Expr root)
 697  , Type_from AST (Type_Root_of_Expr root)
 698  , Expr_from AST root
 699  , Lift_Type Type_Fun (Type_of_Expr root)
 700  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 701  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 702  , Unlift_Type Type_Fun (Type_of_Expr root)
 703  , Root_of_Expr root ~ root
 704  , IBool (Is_Last_Expr (Expr_Lambda root) root)
 705  ) => Expr_from AST (Expr_Lambda root) where
 706         expr_from ex ast ctx k =
 707                 case ast of
 708                  AST "var" asts ->
 709                         case asts of
 710                          [AST name []] -> var_from name ex ast ctx k
 711                          _ -> Left $ error_expr ex $
 712                                 Error_Expr_Wrong_number_of_arguments ast 1
 713                  AST "$"   asts -> from_ast2 asts app_from ex ast ctx k
 714                  AST "\\"  asts -> go_lam asts
 715                  AST "let" asts -> go_let asts
 716                  _ -> Left $ error_expr_unsupported ex ast
 717                 where
 718                 go_lam asts =
 719                         case asts of
 720                          [AST name [], ast_ty_arg, ast_body] ->
 721                                 lam_from name ast_ty_arg ast_body ex ast ctx k
 722                          _ -> Left $ error_expr ex $
 723                                 Error_Expr_Wrong_number_of_arguments ast 3
 724                 go_let asts =
 725                         case asts of
 726                          [AST name [], ast_var, ast_body] ->
 727                                 let_from name ast_var ast_body ex ast ctx k
 728                          _ -> Left $ error_expr ex $
 729                                 Error_Expr_Wrong_number_of_arguments ast 3
 730 instance -- Expr_from AST Expr_Maybe
 731  ( Eq_Type (Type_Root_of_Expr root)
 732  , Type_from AST (Type_Root_of_Expr root)
 733  , Expr_from AST root
 734  , Lift_Type   Type_Fun (Type_of_Expr root)
 735  , Unlift_Type Type_Fun (Type_of_Expr root)
 736  , Lift_Type   Type_Maybe     (Type_of_Expr root)
 737  , Unlift_Type Type_Maybe     (Type_of_Expr root)
 738  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 739  , Root_of_Expr root ~ root
 740  , IBool (Is_Last_Expr (Expr_Maybe root) root)
 741  ) => Expr_from AST (Expr_Maybe root) where
 742         expr_from ex ast ctx k =
 743                 case ast of
 744                  AST "maybe"   asts -> from_ast3 asts maybe_from   ex ast ctx k
 745                  AST "nothing" asts -> from_ast1 asts nothing_from ex ast ctx k
 746                  AST "just"    asts -> from_ast1 asts just_from    ex ast ctx k
 747                  _ -> Left $ error_expr_unsupported ex ast
 748 instance -- Expr_from AST Expr_Eq
 749  ( Eq_Type (Type_Root_of_Expr root)
 750  , Lift_Type Type_Bool (Type_of_Expr root)
 751  , Constraint_Type Eq (Type_Root_of_Expr root)
 752  , Expr_from AST root
 753  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 754  , Root_of_Expr root ~ root
 755  , IBool (Is_Last_Expr (Expr_Eq root) root)
 756  ) => Expr_from AST (Expr_Eq root) where
 757         expr_from ex ast ctx k =
 758                 case ast of
 759                  AST "==" asts -> from_ast2 asts eq_from ex ast ctx k
 760                  _ -> Left $ error_expr_unsupported ex ast
 761 instance -- Expr_from AST Expr_Ord
 762  ( Eq_Type (Type_Root_of_Expr root)
 763  , Lift_Type Type_Ordering (Type_of_Expr root)
 764  , Constraint_Type Ord (Type_Root_of_Expr root)
 765  , Expr_from AST root
 766  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 767  , Root_of_Expr root ~ root
 768  , IBool (Is_Last_Expr (Expr_Ord root) root)
 769  ) => Expr_from AST (Expr_Ord root) where
 770         expr_from ex ast ctx k =
 771                 case ast of
 772                  AST "compare" asts -> from_ast2 asts compare_from ex ast ctx k
 773                  _ -> Left $ error_expr_unsupported ex ast
 774 instance -- Expr_from AST Expr_List
 775  ( Eq_Type (Type_Root_of_Expr root)
 776  , Type_from AST (Type_Root_of_Expr root)
 777  , Expr_from AST root
 778  , Lift_Type   Type_Fun (Type_of_Expr root)
 779  , Unlift_Type Type_Fun (Type_of_Expr root)
 780  , Lift_Type   Type_List      (Type_of_Expr root)
 781  , Unlift_Type Type_List      (Type_of_Expr root)
 782  , Lift_Type   Type_Bool      (Type_of_Expr root)
 783  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 784  , Root_of_Expr root ~ root
 785  , IBool (Is_Last_Expr (Expr_List root) root)
 786  ) => Expr_from AST (Expr_List root) where
 787         expr_from ex ast ctx k =
 788                 case ast of
 789                  AST "[]"          asts -> from_ast1 asts list_empty_from  ex ast ctx k
 790                  AST ":"           asts -> from_ast2 asts list_cons_from   ex ast ctx k
 791                  AST "list_filter" asts -> from_ast2 asts list_filter_from ex ast ctx k
 792                  AST "list"        asts ->
 793                         case asts of
 794                          ast_ty_a:asts' -> list_from ast_ty_a asts' ex ast ctx k
 795                          _ -> Left $ error_expr ex $
 796                                 Error_Expr_Wrong_number_of_arguments ast 1
 797                  AST "list_zipWith" asts -> from_ast3 asts list_zipWith_from ex ast ctx k
 798                  AST "list_reverse" asts -> from_ast1 asts list_reverse_from ex ast ctx k
 799                  _ -> Left $ error_expr_unsupported ex ast
 800 instance -- Expr_from AST Expr_Map
 801  ( Eq_Type (Type_Root_of_Expr root)
 802  , Expr_from AST root
 803  , Lift_Type   Type_Fun    (Type_of_Expr root)
 804  , Unlift_Type Type_Fun    (Type_of_Expr root)
 805  , Lift_Type   Type_Bool   (Type_of_Expr root)
 806  , Unlift_Type Type_Bool   (Type_of_Expr root)
 807  , Lift_Type   Type_List   (Type_of_Expr root)
 808  , Unlift_Type Type_List   (Type_of_Expr root)
 809  , Lift_Type   Type_Map    (Type_of_Expr root)
 810  , Unlift_Type Type_Map    (Type_of_Expr root)
 811  , Lift_Type   Type_Maybe  (Type_of_Expr root)
 812  , Unlift_Type Type_Maybe  (Type_of_Expr root)
 813  , Lift_Type   Type_Tuple2 (Type_of_Expr root)
 814  , Unlift_Type Type_Tuple2 (Type_of_Expr root)
 815  , Constraint_Type Ord (Type_Root_of_Expr root)
 816  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 817  , Root_of_Expr root ~ root
 818  , IBool (Is_Last_Expr (Expr_Map root) root)
 819  ) => Expr_from AST (Expr_Map root) where
 820         expr_from ex ast ctx k =
 821                 case ast of
 822                  AST "map_from_list"    asts -> from_ast1 asts map_from_list_from ex ast ctx k
 823                  AST "mapWithKey"       asts -> from_ast2 asts mapWithKey_from ex ast ctx k
 824                  AST "map_lookup"       asts -> from_ast2 asts map_lookup_from ex ast ctx k
 825                  AST "map_keys"         asts -> from_ast1 asts map_keys_from ex ast ctx k
 826                  AST "map_member"       asts -> from_ast2 asts map_member_from ex ast ctx k
 827                  AST "map_insert"       asts -> from_ast3 asts map_insert_from ex ast ctx k
 828                  AST "map_delete"       asts -> from_ast2 asts map_delete_from ex ast ctx k
 829                  AST "map_difference"   asts -> from_ast2 asts map_difference_from ex ast ctx k
 830                  AST "map_foldrWithKey" asts -> from_ast3 asts map_foldrWithKey_from ex ast ctx k
 831                  _ -> Left $ error_expr_unsupported ex ast
 832 instance -- Expr_from AST Expr_Functor
 833  ( Eq_Type (Type_Root_of_Expr root)
 834  , Expr_from AST root
 835  , Lift_Type   Type_Fun (Type_of_Expr root)
 836  , Unlift_Type Type_Fun (Type_of_Expr root)
 837  , Unlift_Type1 (Type_of_Expr root)
 838  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 839  , Constraint_Type1 Functor (Type_Root_of_Expr root)
 840  , Root_of_Expr root ~ root
 841  , IBool (Is_Last_Expr (Expr_Functor root) root)
 842  ) => Expr_from AST (Expr_Functor root) where
 843         expr_from ex ast ctx k =
 844                 case ast of
 845                  AST "fmap" asts -> from_ast2 asts fmap_from ex ast ctx k
 846                  AST "<$>"  asts -> from_ast2 asts fmap_from ex ast ctx k
 847                  _ -> Left $ error_expr_unsupported ex ast
 848 instance -- Expr_from AST Expr_MonoFunctor
 849  ( Eq_Type (Type_Root_of_Expr root)
 850  , Expr_from AST root
 851  , Lift_Type   Type_Fun (Type_of_Expr root)
 852  , Unlift_Type Type_Fun (Type_of_Expr root)
 853  , Unlift_Type1 (Type_of_Expr root)
 854  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 855  , Constraint_Type MT.MonoFunctor (Type_Root_of_Expr root)
 856  , Type_Associated MonoElement (Type_Root_of_Expr root)
 857  , Root_of_Expr root ~ root
 858  , IBool (Is_Last_Expr (Expr_MonoFunctor root) root)
 859  ) => Expr_from AST (Expr_MonoFunctor root) where
 860         expr_from ex ast ctx k =
 861                 case ast of
 862                  AST "omap" asts -> from_ast2 asts omap_from ex ast ctx k
 863                  _ -> Left $ error_expr_unsupported ex ast
 864 instance -- Expr_from AST Expr_Applicative
 865  ( Eq_Type (Type_Root_of_Expr root)
 866  , Type1_from AST (Type_Root_of_Expr root)
 867  , Expr_from AST root
 868  , Lift_Type   Type_Fun (Type_of_Expr root)
 869  , Unlift_Type Type_Fun (Type_of_Expr root)
 870  , Eq_Type1 (Type_Root_of_Expr root)
 871  , Unlift_Type1 (Type_of_Expr root)
 872  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 873  , Constraint_Type1 Applicative (Type_Root_of_Expr root)
 874  , Root_of_Expr root ~ root
 875  , IBool (Is_Last_Expr (Expr_Applicative root) root)
 876  ) => Expr_from AST (Expr_Applicative root) where
 877         expr_from ex ast ctx k =
 878                 case ast of
 879                  AST "pure" asts -> from_ast2 asts pure_from     ex ast ctx k
 880                  AST "<*>"  asts -> from_ast2 asts ltstargt_from ex ast ctx k
 881                  _ -> Left $ error_expr_unsupported ex ast
 882 instance -- Expr_from AST Expr_Traversable
 883  ( Eq_Type (Type_Root_of_Expr root)
 884  , Expr_from AST root
 885  , Lift_Type   Type_Fun (Type_of_Expr root)
 886  , Unlift_Type Type_Fun (Type_of_Expr root)
 887  , Eq_Type1 (Type_Root_of_Expr root)
 888  , Unlift_Type1 (Type_of_Expr root)
 889  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 890  , Constraint_Type1 Applicative (Type_Root_of_Expr root)
 891  , Constraint_Type1 Traversable (Type_Root_of_Expr root)
 892  , Root_of_Expr root ~ root
 893  , IBool (Is_Last_Expr (Expr_Traversable root) root)
 894  ) => Expr_from AST (Expr_Traversable root) where
 895         expr_from ex ast ctx k =
 896                 case ast of
 897                  AST "traverse"  asts -> from_ast2 asts traverse_from ex ast ctx k
 898                  _ -> Left $ error_expr_unsupported ex ast
 899 instance -- Expr_from AST Expr_Foldable
 900  ( Eq_Type (Type_Root_of_Expr root)
 901  , Expr_from AST root
 902  , Lift_Type   Type_Int  (Type_of_Expr root)
 903  , Lift_Type   Type_Bool (Type_of_Expr root)
 904  , Lift_Type   Type_Fun  (Type_of_Expr root)
 905  , Unlift_Type Type_Fun  (Type_of_Expr root)
 906  , Eq_Type1 (Type_Root_of_Expr root)
 907  , Unlift_Type1 (Type_of_Expr root)
 908  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 909  , Constraint_Type  Eq       (Type_Root_of_Expr root)
 910  , Constraint_Type  Ord      (Type_Root_of_Expr root)
 911  , Constraint_Type  Monoid   (Type_Root_of_Expr root)
 912  , Constraint_Type1 Foldable (Type_Root_of_Expr root)
 913  , Root_of_Expr root ~ root
 914  , IBool (Is_Last_Expr (Expr_Foldable root) root)
 915  ) => Expr_from AST (Expr_Foldable root) where
 916         expr_from ex ast ctx k =
 917                 case ast of
 918                  AST "foldMap" asts -> from_ast2 asts foldMap_from ex ast ctx k
 919                  AST "null"    asts -> from_ast1 asts null_from ex ast ctx k
 920                  AST "length"  asts -> from_ast1 asts length_from ex ast ctx k
 921                  AST "minimum" asts -> from_ast1 asts minimum_from ex ast ctx k
 922                  AST "maximum" asts -> from_ast1 asts maximum_from ex ast ctx k
 923                  AST "elem"    asts -> from_ast2 asts elem_from ex ast ctx k
 924                  _ -> Left $ error_expr_unsupported ex ast
 925 instance -- Expr_from AST Expr_Monoid
 926  ( Eq_Type (Type_Root_of_Expr root)
 927  , Type_from AST (Type_Root_of_Expr root)
 928  , Expr_from AST root
 929  , Lift_Type   Type_Int  (Type_of_Expr root)
 930  , Lift_Type   Type_Bool (Type_of_Expr root)
 931  , Lift_Type   Type_Fun  (Type_of_Expr root)
 932  , Unlift_Type Type_Fun  (Type_of_Expr root)
 933  , Unlift_Type1 (Type_of_Expr root)
 934  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 935  , Constraint_Type Monoid (Type_Root_of_Expr root)
 936  , Root_of_Expr root ~ root
 937  , IBool (Is_Last_Expr (Expr_Monoid root) root)
 938  ) => Expr_from AST (Expr_Monoid root) where
 939         expr_from ex ast ctx k =
 940                 case ast of
 941                  AST "mempty"  asts -> from_ast1 asts mempty_from ex ast ctx k
 942                  AST "mappend" asts -> from_ast2 asts mappend_from ex ast ctx k
 943                  AST "<>"      asts -> from_ast2 asts mappend_from ex ast ctx k
 944                  _ -> Left $ error_expr_unsupported ex ast
 945 instance -- Expr_from AST Expr_Monad
 946  ( Eq_Type (Type_Root_of_Expr root)
 947  , Type1_from AST (Type_Root_of_Expr root)
 948  , Expr_from AST root
 949  , Lift_Type   Type_Fun (Type_of_Expr root)
 950  , Unlift_Type Type_Fun (Type_of_Expr root)
 951  , Eq_Type1 (Type_Root_of_Expr root)
 952  , Unlift_Type1 (Type_of_Expr root)
 953  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 954  , Constraint_Type1 Monad (Type_Root_of_Expr root)
 955  , Root_of_Expr root ~ root
 956  , IBool (Is_Last_Expr (Expr_Monad root) root)
 957  ) => Expr_from AST (Expr_Monad root) where
 958         expr_from ex ast ctx k =
 959                 case ast of
 960                  AST "return" asts -> from_ast2 asts return_from ex ast ctx k
 961                  AST ">>="    asts -> from_ast2 asts bind_from   ex ast ctx k
 962                  _ -> Left $ error_expr_unsupported ex ast
 963 instance -- Expr_from AST Expr_Either
 964  ( Eq_Type (Type_Root_of_Expr root)
 965  , Type_from  AST (Type_Root_of_Expr root)
 966  , Expr_from AST root
 967  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 968  , Root_of_Expr root ~ root
 969  , Lift_Type   Type_Either (Type_of_Expr root)
 970  , Unlift_Type Type_Either (Type_of_Expr root)
 971  , IBool (Is_Last_Expr (Expr_Either root) root)
 972  ) => Expr_from AST (Expr_Either root) where
 973         expr_from ex ast ctx k =
 974                 case ast of
 975                  AST "left"  asts -> from_ast2 asts left_from  ex ast ctx k
 976                  AST "right" asts -> from_ast2 asts right_from ex ast ctx k
 977                  _ -> Left $ error_expr_unsupported ex ast
 978 instance -- Expr_from AST Expr_Tuple2
 979  ( Eq_Type (Type_Root_of_Expr root)
 980  , Expr_from AST root
 981  , Lift_Type   Type_Tuple2 (Type_of_Expr root)
 982  , Unlift_Type Type_Tuple2 (Type_of_Expr root)
 983  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 984  , Root_of_Expr root ~ root
 985  , IBool (Is_Last_Expr (Expr_Tuple2 root) root)
 986  ) => Expr_from AST (Expr_Tuple2 root) where
 987         expr_from ex ast ctx k =
 988                 case ast of
 989                  AST "(,)" asts -> from_ast2 asts tuple2_from ex ast ctx k
 990                  AST "fst" asts -> from_ast1 asts fst_from ex ast ctx k
 991                  AST "snd" asts -> from_ast1 asts snd_from ex ast ctx k
 992                  _ -> Left $ error_expr_unsupported ex ast