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  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  80                    (Error_of_Expr ast (Root_of_Expr ex))
  81  ) => [ast]
  82  -> ExprFrom ast ex hs ret
  83  -> ExprFrom 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  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  94                    (Error_of_Expr ast (Root_of_Expr ex))
  95  ) => [ast] -> (ast -> ExprFrom ast ex hs ret)
  96  -> ExprFrom 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  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 107                    (Error_of_Expr ast (Root_of_Expr ex))
 108  ) => [ast] -> (ast -> ast -> ExprFrom ast ex hs ret)
 109  -> ExprFrom 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  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 120                    (Error_of_Expr ast (Root_of_Expr ex))
 121  ) => [ast] -> (ast -> ast -> ast -> ExprFrom ast ex hs ret)
 122  -> ExprFrom 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  , Error_Expr_Lift (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  -> ExprFrom 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  , Type0_Eq (Type_Root_of_Expr root)
 152  , Expr_From ast root
 153  , Error_Expr_Lift (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  -> ExprFrom 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  , Type0_Eq (Type_Root_of_Expr root)
 171  , Expr_From ast root
 172  , Error_Expr_Lift (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  -> ExprFrom 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  , Type0_Eq (Type_Root_of_Expr root)
 190  , Expr_From ast root
 191  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 192                    (Error_of_Expr ast root)
 193  , Root_of_Expr root ~ root
 194  , Type0_Constraint c ty
 195  ) => (forall lit repr. (c lit, Sym_of_Expr ex repr) => repr lit -> repr lit)
 196  -> Proxy c -> [ast]
 197  -> ExprFrom 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  , Type0_Eq (Type_Root_of_Expr root)
 210  , Expr_From ast root
 211  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
 212                    (Error_of_Expr ast root)
 213  , Root_of_Expr root ~ root
 214  , Type0_Constraint c ty
 215  ) => (forall lit repr. (c lit, Sym_of_Expr ex repr) => repr lit -> repr lit -> repr lit)
 216  -> Proxy c -> [ast]
 217  -> ExprFrom 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 -- Type0_From AST Type_Var0
 225  ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 226  , IBool (Is_Last_Type (Type_Var0 root) root)
 227  ) => Type0_From AST (Type_Var0 root) where
 228         type0_from ty ast _k =
 229                 Left $ error_type_unsupported ty ast
 230          -- NOTE: no support so far.
 231 instance -- Type0_From AST Type_Var1
 232  ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 233  , IBool (Is_Last_Type (Type_Var1 root) root)
 234  ) => Type0_From AST (Type_Var1 root) where
 235         type0_from ty ast _k =
 236                 Left $ error_type_unsupported ty ast
 237          -- NOTE: no support so far.
 238 instance -- Type0_From AST Type_Unit
 239  ( Type_Root_Lift Type_Unit root
 240  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 241  , IBool (Is_Last_Type (Type_Unit root) root)
 242  ) => Type0_From AST (Type_Unit root) where
 243         type0_from ty ast k =
 244                 case ast of
 245                  AST "()" asts ->
 246                         case asts of
 247                          [] -> k type_unit
 248                          _ -> Left $ error_type_lift $
 249                                 Error_Type_Wrong_number_of_arguments ast 0
 250                  _ -> Left $ error_type_unsupported ty ast
 251 instance -- Type0_From AST Type_Bool
 252  ( Type_Root_Lift Type_Bool root
 253  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 254  , IBool (Is_Last_Type (Type_Bool root) root)
 255  ) => Type0_From AST (Type_Bool root) where
 256         type0_from ty ast k =
 257                 case ast of
 258                  AST "Bool" asts ->
 259                         case asts of
 260                          [] -> k type_bool
 261                          _ -> Left $ error_type_lift $
 262                                 Error_Type_Wrong_number_of_arguments ast 0
 263                  _ -> Left $ error_type_unsupported ty ast
 264 instance -- Type0_From AST Type_Char
 265  ( Type_Root_Lift Type_Char root
 266  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 267  , IBool (Is_Last_Type (Type_Char root) root)
 268  ) => Type0_From AST (Type_Char root) where
 269         type0_from ty ast k =
 270                 case ast of
 271                  AST "Char" asts ->
 272                         case asts of
 273                          [] -> k type_char
 274                          _ -> Left $ error_type_lift $
 275                                 Error_Type_Wrong_number_of_arguments ast 0
 276                  _ -> Left $ error_type_unsupported ty ast
 277 instance -- Type0_From AST Type_Int
 278  ( Type_Root_Lift Type_Int root
 279  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 280  , IBool (Is_Last_Type (Type_Int root) root)
 281  ) => Type0_From AST (Type_Int root) where
 282         type0_from ty ast k =
 283                 case ast of
 284                  AST "Int" asts ->
 285                         case asts of
 286                          [] -> k type_int
 287                          _ -> Left $ error_type_lift $
 288                                 Error_Type_Wrong_number_of_arguments ast 0
 289                  _ -> Left $ error_type_unsupported ty ast
 290 instance -- Type0_From AST Type_Text
 291  ( Type_Root_Lift Type_Text root
 292  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 293  , IBool (Is_Last_Type (Type_Text root) root)
 294  ) => Type0_From AST (Type_Text root) where
 295         type0_from ty ast k =
 296                 case ast of
 297                  AST "Text" asts ->
 298                         case asts of
 299                          [] -> k type_text
 300                          _ -> Left $ error_type_lift $
 301                                 Error_Type_Wrong_number_of_arguments ast 0
 302                  _ -> Left $ error_type_unsupported ty ast
 303 instance -- Type0_From AST Type_Ordering
 304  ( Type_Root_Lift Type_Ordering root
 305  , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
 306  , IBool (Is_Last_Type (Type_Ordering root) root)
 307  ) => Type0_From AST (Type_Ordering root) where
 308         type0_from ty ast k =
 309                 case ast of
 310                  AST "Ordering" asts ->
 311                         case asts of
 312                          [] -> k type_ordering
 313                          _ -> Left $ error_type_lift $
 314                                 Error_Type_Wrong_number_of_arguments ast 0
 315                  _ -> Left $ error_type_unsupported ty ast
 316 instance -- Type0_From AST Type_Fun
 317  ( Type0_Eq root
 318  , Type0_From AST root
 319  , Type_Root_Lift Type_Fun root
 320  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 321  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 322  , Root_of_Type root ~ root
 323  , IBool (Is_Last_Type (Type_Fun root) root)
 324  ) => Type0_From AST (Type_Fun root) where
 325         type0_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 $ error_type_lift $
 331                                 Error_Type_Wrong_number_of_arguments ast 2
 332                  _ -> Left $ error_type_unsupported ty ast
 333 instance -- Type0_From AST Type_Maybe
 334  ( Type0_Eq root
 335  , Type0_From AST root
 336  , Type_Root_Lift Type_Maybe root
 337  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 338  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 339  , Root_of_Type root ~ root
 340  , IBool (Is_Last_Type (Type_Maybe root) root)
 341  ) => Type0_From AST (Type_Maybe root) where
 342         type0_from ty ast k =
 343                 case ast of
 344                  AST "Maybe" asts ->
 345                         case asts of
 346                          [ast_a] ->
 347                                 type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
 348                                 k (type_maybe ty_a)
 349                          _ -> Left $ error_type_lift $
 350                                 Error_Type_Wrong_number_of_arguments ast 1
 351                  _ -> Left $ error_type_unsupported ty ast
 352 instance -- Type0_From AST Type_List
 353  ( Type0_Eq root
 354  , Type0_From AST root
 355  , Type_Root_Lift Type_List root
 356  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 357  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 358  , Root_of_Type root ~ root
 359  , IBool (Is_Last_Type (Type_List root) root)
 360  ) => Type0_From AST (Type_List root) where
 361         type0_from ty ast k =
 362                 case ast of
 363                  AST "[]" asts ->
 364                         case asts of
 365                          [ast_a] ->
 366                                 type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
 367                                 k (type_list ty_a)
 368                          _ -> Left $ error_type_lift $
 369                                 Error_Type_Wrong_number_of_arguments ast 1
 370                  _ -> Left $ error_type_unsupported ty ast
 371 instance -- Type0_From AST Type_Map
 372  ( Type0_Eq root
 373  , Type0_From AST root
 374  , Type_Root_Lift Type_Map root
 375  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 376  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 377  , Type0_Constraint Ord root
 378  , Root_of_Type root ~ root
 379  , IBool (Is_Last_Type (Type_Map root) root)
 380  ) => Type0_From AST (Type_Map root) where
 381         type0_from ty ast k =
 382                 case ast of
 383                  AST "Map" asts ->
 384                         case asts of
 385                          [ast_k, ast_a] ->
 386                                 type0_from (Proxy::Proxy root) ast_k $ \ty_k ->
 387                                 type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
 388                                 k (type_map ty_k ty_a)
 389                          _ -> Left $ error_type_lift $
 390                                 Error_Type_Wrong_number_of_arguments ast 2
 391                  _ -> Left $ error_type_unsupported ty ast
 392 instance -- Type0_From AST Type_Tuple2
 393  ( Type0_Eq root
 394  , Type0_From AST root
 395  , Type_Root_Lift Type_Tuple2 root
 396  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 397  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 398  , Root_of_Type root ~ root
 399  , IBool (Is_Last_Type (Type_Tuple2 root) root)
 400  ) => Type0_From AST (Type_Tuple2 root) where
 401         type0_from ty ast k =
 402                 case ast of
 403                  AST "(,)" asts ->
 404                         case asts of
 405                          [ast_a, ast_b] ->
 406                                 type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
 407                                 type0_from (Proxy::Proxy root) ast_b $ \ty_b ->
 408                                 k (type_tuple2 ty_a ty_b)
 409                          _ -> Left $ error_type_lift $
 410                                 Error_Type_Wrong_number_of_arguments ast 2
 411                  _ -> Left $ error_type_unsupported ty ast
 412 instance -- Type0_From AST Type_Either
 413  ( Type0_Eq root
 414  , Type0_From AST root
 415  , Type_Root_Lift Type_Either root
 416  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 417  , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
 418  , Root_of_Type root ~ root
 419  , IBool (Is_Last_Type (Type_Either root) root)
 420  ) => Type0_From AST (Type_Either root) where
 421         type0_from ty ast k =
 422                 case ast of
 423                  AST "Either" asts ->
 424                         case asts of
 425                          [ast_l, ast_r] ->
 426                                 type0_from (Proxy::Proxy root) ast_l $ \ty_l ->
 427                                 type0_from (Proxy::Proxy root) ast_r $ \ty_r ->
 428                                 k (type_either ty_l ty_r)
 429                          _ -> Left $ error_type_lift $
 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  ( Error_Type_Lift (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  ( Error_Type_Lift (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  ( Error_Type_Lift (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  ( Error_Type_Lift (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  ( Error_Type_Lift (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  ( Error_Type_Lift (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  ( Type0_From AST root
 459  , Type_Root_Lift Type_Maybe root
 460  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 461  , Error_Type_Unlift (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 $ error_type_lift $
 471                                 Error_Type_Wrong_number_of_arguments ast 0
 472                  _ -> Left $ error_type_unsupported ty ast
 473 instance -- Type1_From AST Type_List
 474  ( Type0_Eq root
 475  , Type0_From AST root
 476  , Type_Root_Lift Type_List root
 477  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 478  , Error_Type_Unlift (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 $ error_type_lift $
 488                                 Error_Type_Wrong_number_of_arguments ast 0
 489                  _ -> Left $ error_type_unsupported ty ast
 490 instance -- Type1_From AST Type_IO
 491  ( Type0_Eq root
 492  , Type0_From AST root
 493  , Type_Root_Lift Type_IO root
 494  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 495  , Error_Type_Unlift (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 $ error_type_lift $
 505                                 Error_Type_Wrong_number_of_arguments ast 0
 506                  _ -> Left $ error_type_unsupported ty ast
 507 instance -- Type1_From AST Type_Fun
 508  ( Type0_Eq root
 509  , Type0_From AST root
 510  , Type_Root_Lift Type_Fun root
 511  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 512  , Error_Type_Unlift (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                                 type0_from (Proxy::Proxy root) ast_arg $ \(ty_arg::root h_arg) ->
 522                                 k (Proxy::Proxy ((->) h_arg)) $
 523                                         type_fun ty_arg
 524                          _ -> Left $ error_type_lift $
 525                                 Error_Type_Wrong_number_of_arguments ast 1
 526                  _ -> Left $ error_type_unsupported ty ast
 527 instance -- Type1_From AST Type_Either
 528  ( Type0_Eq root
 529  , Type0_From AST root
 530  , Type_Root_Lift Type_Either root
 531  , Error_Type_Lift   (Error_Type AST) (Error_of_Type AST root)
 532  , Error_Type_Unlift (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                                 type0_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 $ error_type_lift $
 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  ( Expr_From AST root
 550  , Type0_Eq (Type_Root_of_Expr root)
 551  , Type0_Lift   Type_Bool (Type_of_Expr root)
 552  , Type0_Unlift Type_Bool (Type_of_Expr root)
 553  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST 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  ( Expr_From AST root
 567  , Type0_Eq (Type_Root_of_Expr root)
 568  , Type0_Lift Type_Bool (Type_of_Expr root)
 569  , Error_Expr_Lift (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  ( Expr_From AST root
 579  , Type0_Eq (Type_Root_of_Expr root)
 580  , Type0_Lift Type_Bool (Type_of_Expr root)
 581  , Type0_Lift Type_Unit (Type_of_Expr root)
 582  , Error_Expr_Lift (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  ( Expr_From AST root
 592  , Type0_Eq (Type_Root_of_Expr root)
 593  , Type0_Lift   Type_Int (Type_of_Expr root)
 594  , Type0_Unlift Type_Int (Type_of_Expr root)
 595  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST 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  ( Expr_From AST root
 605  , Type0_Eq (Type_Root_of_Expr root)
 606  , Type0_Lift   Type_Integer (Type_of_Expr root)
 607  , Type0_Unlift Type_Integer (Type_of_Expr root)
 608  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST 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  ( Expr_From AST root
 618  , Type0_Eq (Type_Root_of_Expr root)
 619  , Type0_Constraint Num (Type_Root_of_Expr root)
 620  , Error_Expr_Lift (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  ( Expr_From AST root
 635  , Type0_Eq (Type_Root_of_Expr root)
 636  , Type0_Constraint Integral (Type_Root_of_Expr root)
 637  , Type0_Lift Type_Tuple2  (Type_of_Expr root)
 638  , Type0_Lift Type_Integer (Type_of_Expr root)
 639  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 640  , Root_of_Expr root ~ root
 641  , IBool (Is_Last_Expr (Expr_Integral root) root)
 642  ) => Expr_From AST (Expr_Integral root) where
 643         expr_from ex ast ctx k =
 644                 let c = (Proxy :: Proxy Integral) in
 645                 case ast of
 646                  AST "quot"    asts -> class_op2_from_AST Expr.quot c asts ex ast ctx k
 647                  AST "div"     asts -> class_op2_from_AST Expr.div  c asts ex ast ctx k
 648                  AST "rem"     asts -> class_op2_from_AST Expr.rem  c asts ex ast ctx k
 649                  AST "mod"     asts -> class_op2_from_AST Expr.mod  c asts ex ast ctx k
 650                  AST "quotRem" asts -> from_ast2 asts quotRem_from         ex ast ctx k
 651                  AST "divMod"  asts -> from_ast2 asts divMod_from          ex ast ctx k
 652                  _ -> Left $ error_expr_unsupported ex ast
 653 instance -- Expr_From AST Expr_Text
 654  ( Expr_From AST root
 655  , Type0_Eq (Type_Root_of_Expr root)
 656  , Type0_Lift   Type_Text (Type_of_Expr root)
 657  , Type0_Unlift Type_Text (Type_of_Expr root)
 658  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 659  , Root_of_Expr root ~ root
 660  , IBool (Is_Last_Expr (Expr_Text root) root)
 661  ) => Expr_From AST (Expr_Text root) where
 662         expr_from ex ast =
 663                 case ast of
 664                  AST "text" asts ->
 665                         case asts of
 666                          [AST lit []] -> \_ctx k ->
 667                                 k type_text $ Forall_Repr_with_Context $ \_c -> text lit
 668                          _ -> \_ctx _k -> Left $ error_expr ex $
 669                                 Error_Expr_Wrong_number_of_arguments ast 1
 670                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 671 instance -- Expr_From AST Expr_Char
 672  ( Expr_From AST root
 673  , Type0_Eq (Type_Root_of_Expr root)
 674  , Type0_Lift   Type_Char (Type_of_Expr root)
 675  , Type0_Unlift Type_Char (Type_of_Expr root)
 676  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 677  , Root_of_Expr root ~ root
 678  , IBool (Is_Last_Expr (Expr_Char root) root)
 679  ) => Expr_From AST (Expr_Char root) where
 680         expr_from ex ast =
 681                 case ast of
 682                  AST "char" asts ->
 683                         case asts of
 684                          [AST lit []] ->
 685                                 case Text.uncons lit of
 686                                  Just (c, "") -> \_ctx k ->
 687                                         k type_char $ Forall_Repr_with_Context $ \_c -> char c
 688                                  _ -> \_ctx _k -> Left $ error_expr ex $
 689                                         Error_Expr_Read (Error_Read lit) ast
 690                          _ -> \_ctx _k -> Left $ error_expr ex $
 691                                 Error_Expr_Wrong_number_of_arguments ast 1
 692                  AST "char_toUpper" asts -> op1_from_AST char_toUpper type_char asts ex ast
 693                  _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
 694 instance -- Expr_From AST Expr_Lambda
 695  ( Expr_From AST root
 696  , Type0_Eq (Type_Root_of_Expr root)
 697  , Type0_From AST (Type_Root_of_Expr root)
 698  , Type0_Lift   Type_Fun (Type_of_Expr root)
 699  , Type0_Unlift Type_Fun (Type_of_Expr root)
 700  , Error_Expr_Lift (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 701  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 702  , Root_of_Expr root ~ root
 703  , IBool (Is_Last_Expr (Expr_Lambda root) root)
 704  ) => Expr_From AST (Expr_Lambda root) where
 705         expr_from ex ast ctx k =
 706                 case ast of
 707                  AST "var" asts ->
 708                         case asts of
 709                          [AST name []] -> var_from name ex ast ctx k
 710                          _ -> Left $ error_expr ex $
 711                                 Error_Expr_Wrong_number_of_arguments ast 1
 712                  AST "$"   asts -> from_ast2 asts app_from ex ast ctx k
 713                  AST "\\"  asts -> go_lam asts
 714                  AST "let" asts -> go_let asts
 715                  _ -> Left $ error_expr_unsupported ex ast
 716                 where
 717                 go_lam asts =
 718                         case asts of
 719                          [AST name [], ast_ty_arg, ast_body] ->
 720                                 lam_from name ast_ty_arg ast_body ex ast ctx k
 721                          _ -> Left $ error_expr ex $
 722                                 Error_Expr_Wrong_number_of_arguments ast 3
 723                 go_let asts =
 724                         case asts of
 725                          [AST name [], ast_var, ast_body] ->
 726                                 let_from name ast_var ast_body ex ast ctx k
 727                          _ -> Left $ error_expr ex $
 728                                 Error_Expr_Wrong_number_of_arguments ast 3
 729 instance -- Expr_From AST Expr_Maybe
 730  ( Expr_From AST root
 731  , Type0_Eq (Type_Root_of_Expr root)
 732  , Type0_From AST (Type_Root_of_Expr root)
 733  , Type0_Lift   Type_Fun   (Type_of_Expr root)
 734  , Type0_Unlift Type_Fun   (Type_of_Expr root)
 735  , Type0_Lift   Type_Maybe (Type_of_Expr root)
 736  , Type0_Unlift Type_Maybe (Type_of_Expr root)
 737  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 738  , Root_of_Expr root ~ root
 739  , IBool (Is_Last_Expr (Expr_Maybe root) root)
 740  ) => Expr_From AST (Expr_Maybe root) where
 741         expr_from ex ast ctx k =
 742                 case ast of
 743                  AST "maybe"   asts -> from_ast3 asts maybe_from   ex ast ctx k
 744                  AST "nothing" asts -> from_ast1 asts nothing_from ex ast ctx k
 745                  AST "just"    asts -> from_ast1 asts just_from    ex ast ctx k
 746                  _ -> Left $ error_expr_unsupported ex ast
 747 instance -- Expr_From AST Expr_Eq
 748  ( Expr_From AST root
 749  , Type0_Eq (Type_Root_of_Expr root)
 750  , Type0_Lift Type_Bool (Type_of_Expr root)
 751  , Type0_Constraint Eq (Type_Root_of_Expr root)
 752  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 753  , Root_of_Expr root ~ root
 754  , IBool (Is_Last_Expr (Expr_Eq root) root)
 755  ) => Expr_From AST (Expr_Eq root) where
 756         expr_from ex ast ctx k =
 757                 case ast of
 758                  AST "==" asts -> from_ast2 asts eq_from ex ast ctx k
 759                  _ -> Left $ error_expr_unsupported ex ast
 760 instance -- Expr_From AST Expr_Ord
 761  ( Expr_From AST root
 762  , Type0_Eq (Type_Root_of_Expr root)
 763  , Type0_Lift Type_Ordering (Type_of_Expr root)
 764  , Type0_Constraint Ord (Type_Root_of_Expr root)
 765  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 766  , Root_of_Expr root ~ root
 767  , IBool (Is_Last_Expr (Expr_Ord root) root)
 768  ) => Expr_From AST (Expr_Ord root) where
 769         expr_from ex ast ctx k =
 770                 case ast of
 771                  AST "compare" asts -> from_ast2 asts compare_from ex ast ctx k
 772                  _ -> Left $ error_expr_unsupported ex ast
 773 instance -- Expr_From AST Expr_List
 774  ( Expr_From AST root
 775  , Type0_Eq (Type_Root_of_Expr root)
 776  , Type0_From AST (Type_Root_of_Expr root)
 777  , Type0_Lift   Type_Fun  (Type_of_Expr root)
 778  , Type0_Unlift Type_Fun  (Type_of_Expr root)
 779  , Type0_Lift   Type_List (Type_of_Expr root)
 780  , Type0_Unlift Type_List (Type_of_Expr root)
 781  , Type0_Lift   Type_Bool (Type_of_Expr root)
 782  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 783  , Root_of_Expr root ~ root
 784  , IBool (Is_Last_Expr (Expr_List root) root)
 785  ) => Expr_From AST (Expr_List root) where
 786         expr_from ex ast ctx k =
 787                 case ast of
 788                  AST "[]"          asts -> from_ast1 asts list_empty_from  ex ast ctx k
 789                  AST ":"           asts -> from_ast2 asts list_cons_from   ex ast ctx k
 790                  AST "list_filter" asts -> from_ast2 asts list_filter_from ex ast ctx k
 791                  AST "list"        asts ->
 792                         case asts of
 793                          ast_ty_a:asts' -> list_from ast_ty_a asts' ex ast ctx k
 794                          _ -> Left $ error_expr ex $
 795                                 Error_Expr_Wrong_number_of_arguments ast 1
 796                  AST "list_zipWith" asts -> from_ast3 asts list_zipWith_from ex ast ctx k
 797                  AST "list_reverse" asts -> from_ast1 asts list_reverse_from ex ast ctx k
 798                  _ -> Left $ error_expr_unsupported ex ast
 799 instance -- Expr_From AST Expr_Map
 800  ( Expr_From AST root
 801  , Type0_Eq (Type_Root_of_Expr root)
 802  , Type0_Lift   Type_Fun    (Type_of_Expr root)
 803  , Type0_Unlift Type_Fun    (Type_of_Expr root)
 804  , Type0_Lift   Type_Bool   (Type_of_Expr root)
 805  , Type0_Unlift Type_Bool   (Type_of_Expr root)
 806  , Type0_Lift   Type_List   (Type_of_Expr root)
 807  , Type0_Unlift Type_List   (Type_of_Expr root)
 808  , Type0_Lift   Type_Map    (Type_of_Expr root)
 809  , Type0_Unlift Type_Map    (Type_of_Expr root)
 810  , Type0_Lift   Type_Maybe  (Type_of_Expr root)
 811  , Type0_Unlift Type_Maybe  (Type_of_Expr root)
 812  , Type0_Lift   Type_Tuple2 (Type_of_Expr root)
 813  , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
 814  , Type0_Constraint Ord (Type_Root_of_Expr root)
 815  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 816  , Root_of_Expr root ~ root
 817  , IBool (Is_Last_Expr (Expr_Map root) root)
 818  ) => Expr_From AST (Expr_Map root) where
 819         expr_from ex ast ctx k =
 820                 case ast of
 821                  AST "map_from_list"    asts -> from_ast1 asts map_from_list_from ex ast ctx k
 822                  AST "mapWithKey"       asts -> from_ast2 asts mapWithKey_from ex ast ctx k
 823                  AST "map_lookup"       asts -> from_ast2 asts map_lookup_from ex ast ctx k
 824                  AST "map_keys"         asts -> from_ast1 asts map_keys_from ex ast ctx k
 825                  AST "map_member"       asts -> from_ast2 asts map_member_from ex ast ctx k
 826                  AST "map_insert"       asts -> from_ast3 asts map_insert_from ex ast ctx k
 827                  AST "map_delete"       asts -> from_ast2 asts map_delete_from ex ast ctx k
 828                  AST "map_difference"   asts -> from_ast2 asts map_difference_from ex ast ctx k
 829                  AST "map_foldrWithKey" asts -> from_ast3 asts map_foldrWithKey_from ex ast ctx k
 830                  _ -> Left $ error_expr_unsupported ex ast
 831 instance -- Expr_From AST Expr_Functor
 832  ( Expr_From AST root
 833  , Type0_Eq (Type_Root_of_Expr root)
 834  , Type0_Lift   Type_Fun (Type_of_Expr root)
 835  , Type0_Unlift Type_Fun (Type_of_Expr root)
 836  , Type1_Unlift (Type_of_Expr root)
 837  , Type1_Constraint Functor (Type_Root_of_Expr root)
 838  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 839  , Root_of_Expr root ~ root
 840  , IBool (Is_Last_Expr (Expr_Functor root) root)
 841  ) => Expr_From AST (Expr_Functor root) where
 842         expr_from ex ast ctx k =
 843                 case ast of
 844                  AST "fmap" asts -> from_ast2 asts fmap_from ex ast ctx k
 845                  AST "<$>"  asts -> from_ast2 asts fmap_from ex ast ctx k
 846                  _ -> Left $ error_expr_unsupported ex ast
 847 instance -- Expr_From AST Expr_MonoFunctor
 848  ( Expr_From AST root
 849  , Type0_Eq (Type_Root_of_Expr root)
 850  , Type0_Lift   Type_Fun (Type_of_Expr root)
 851  , Type0_Unlift Type_Fun (Type_of_Expr root)
 852  , Type1_Unlift (Type_of_Expr root)
 853  , Type0_Constraint MT.MonoFunctor (Type_Root_of_Expr root)
 854  , Type0_Family Type_Family_MonoElement (Type_Root_of_Expr root)
 855  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 856  , Root_of_Expr root ~ root
 857  , IBool (Is_Last_Expr (Expr_MonoFunctor root) root)
 858  ) => Expr_From AST (Expr_MonoFunctor root) where
 859         expr_from ex ast ctx k =
 860                 case ast of
 861                  AST "omap" asts -> from_ast2 asts omap_from ex ast ctx k
 862                  _ -> Left $ error_expr_unsupported ex ast
 863 instance -- Expr_From AST Expr_Applicative
 864  ( Expr_From AST root
 865  , Type0_Eq (Type_Root_of_Expr root)
 866  , Type1_From AST (Type_Root_of_Expr root)
 867  , Type0_Lift   Type_Fun (Type_of_Expr root)
 868  , Type0_Unlift Type_Fun (Type_of_Expr root)
 869  , Type1_Eq (Type_Root_of_Expr root)
 870  , Type1_Unlift (Type_of_Expr root)
 871  , Type1_Constraint Applicative (Type_Root_of_Expr root)
 872  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 873  , Root_of_Expr root ~ root
 874  , IBool (Is_Last_Expr (Expr_Applicative root) root)
 875  ) => Expr_From AST (Expr_Applicative root) where
 876         expr_from ex ast ctx k =
 877                 case ast of
 878                  AST "pure" asts -> from_ast2 asts pure_from     ex ast ctx k
 879                  AST "<*>"  asts -> from_ast2 asts ltstargt_from ex ast ctx k
 880                  _ -> Left $ error_expr_unsupported ex ast
 881 instance -- Expr_From AST Expr_Traversable
 882  ( Expr_From AST root
 883  , Type0_Eq (Type_Root_of_Expr root)
 884  , Type0_Lift   Type_Fun (Type_of_Expr root)
 885  , Type0_Unlift Type_Fun (Type_of_Expr root)
 886  , Type1_Eq (Type_Root_of_Expr root)
 887  , Type1_Unlift (Type_of_Expr root)
 888  , Type1_Constraint Applicative (Type_Root_of_Expr root)
 889  , Type1_Constraint Traversable (Type_Root_of_Expr root)
 890  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 891  , Root_of_Expr root ~ root
 892  , IBool (Is_Last_Expr (Expr_Traversable root) root)
 893  ) => Expr_From AST (Expr_Traversable root) where
 894         expr_from ex ast ctx k =
 895                 case ast of
 896                  AST "traverse"  asts -> from_ast2 asts traverse_from ex ast ctx k
 897                  _ -> Left $ error_expr_unsupported ex ast
 898 instance -- Expr_From AST Expr_Foldable
 899  ( Expr_From AST root
 900  , Type0_Constraint Eq       (Type_Root_of_Expr root)
 901  , Type0_Constraint Monoid   (Type_Root_of_Expr root)
 902  , Type0_Constraint Ord      (Type_Root_of_Expr root)
 903  , Type0_Eq                  (Type_Root_of_Expr root)
 904  , Type0_Lift   Type_Bool    (Type_of_Expr root)
 905  , Type0_Lift   Type_Fun     (Type_of_Expr root)
 906  , Type0_Lift   Type_Int     (Type_of_Expr root)
 907  , Type0_Unlift Type_Fun     (Type_of_Expr root)
 908  , Type1_Constraint Foldable (Type_Root_of_Expr root)
 909  , Type1_Eq (Type_Root_of_Expr root)
 910  , Type1_Unlift (Type_of_Expr root)
 911  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 912  , Root_of_Expr root ~ root
 913  , IBool (Is_Last_Expr (Expr_Foldable root) root)
 914  ) => Expr_From AST (Expr_Foldable root) where
 915         expr_from ex ast ctx k =
 916                 case ast of
 917                  AST "foldMap" asts -> from_ast2 asts foldMap_from ex ast ctx k
 918                  AST "null"    asts -> from_ast1 asts null_from ex ast ctx k
 919                  AST "length"  asts -> from_ast1 asts length_from ex ast ctx k
 920                  AST "minimum" asts -> from_ast1 asts minimum_from ex ast ctx k
 921                  AST "maximum" asts -> from_ast1 asts maximum_from ex ast ctx k
 922                  AST "elem"    asts -> from_ast2 asts elem_from ex ast ctx k
 923                  _ -> Left $ error_expr_unsupported ex ast
 924 instance -- Expr_From AST Expr_Monoid
 925  ( Expr_From AST root
 926  , Type0_Eq (Type_Root_of_Expr root)
 927  , Type0_From AST (Type_Root_of_Expr root)
 928  , Type0_Constraint Monoid (Type_Root_of_Expr root)
 929  , Type0_Lift   Type_Int  (Type_of_Expr root)
 930  , Type0_Lift   Type_Bool (Type_of_Expr root)
 931  , Type0_Lift   Type_Fun  (Type_of_Expr root)
 932  , Type0_Unlift Type_Fun  (Type_of_Expr root)
 933  , Type1_Unlift (Type_of_Expr root)
 934  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 935  , Root_of_Expr root ~ root
 936  , IBool (Is_Last_Expr (Expr_Monoid root) root)
 937  ) => Expr_From AST (Expr_Monoid root) where
 938         expr_from ex ast ctx k =
 939                 case ast of
 940                  AST "mempty"  asts -> from_ast1 asts mempty_from ex ast ctx k
 941                  AST "mappend" asts -> from_ast2 asts mappend_from ex ast ctx k
 942                  AST "<>"      asts -> from_ast2 asts mappend_from ex ast ctx k
 943                  _ -> Left $ error_expr_unsupported ex ast
 944 instance -- Expr_From AST Expr_Monad
 945  ( Expr_From AST root
 946  , Type0_Eq (Type_Root_of_Expr root)
 947  , Type0_Lift   Type_Fun (Type_of_Expr root)
 948  , Type0_Unlift Type_Fun (Type_of_Expr root)
 949  , Type1_From AST (Type_Root_of_Expr root)
 950  , Type1_Constraint Monad (Type_Root_of_Expr root)
 951  , Type1_Eq (Type_Root_of_Expr root)
 952  , Type1_Unlift (Type_of_Expr root)
 953  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 954  , Root_of_Expr root ~ root
 955  , IBool (Is_Last_Expr (Expr_Monad root) root)
 956  ) => Expr_From AST (Expr_Monad root) where
 957         expr_from ex ast ctx k =
 958                 case ast of
 959                  AST "return" asts -> from_ast2 asts return_from ex ast ctx k
 960                  AST ">>="    asts -> from_ast2 asts bind_from   ex ast ctx k
 961                  _ -> Left $ error_expr_unsupported ex ast
 962 instance -- Expr_From AST Expr_Either
 963  ( Expr_From AST root
 964  , Type0_Eq (Type_Root_of_Expr root)
 965  , Type0_From AST (Type_Root_of_Expr root)
 966  , Type0_Lift   Type_Either (Type_of_Expr root)
 967  , Type0_Unlift Type_Either (Type_of_Expr root)
 968  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 969  , Root_of_Expr root ~ root
 970  , IBool (Is_Last_Expr (Expr_Either root) root)
 971  ) => Expr_From AST (Expr_Either root) where
 972         expr_from ex ast ctx k =
 973                 case ast of
 974                  AST "left"  asts -> from_ast2 asts left_from  ex ast ctx k
 975                  AST "right" asts -> from_ast2 asts right_from ex ast ctx k
 976                  _ -> Left $ error_expr_unsupported ex ast
 977 instance -- Expr_From AST Expr_Tuple2
 978  ( Expr_From AST root
 979  , Type0_Eq (Type_Root_of_Expr root)
 980  , Type0_Lift   Type_Tuple2 (Type_of_Expr root)
 981  , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
 982  , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 983  , Root_of_Expr root ~ root
 984  , IBool (Is_Last_Expr (Expr_Tuple2 root) root)
 985  ) => Expr_From AST (Expr_Tuple2 root) where
 986         expr_from ex ast ctx k =
 987                 case ast of
 988                  AST "(,)" asts -> from_ast2 asts tuple2_from ex ast ctx k
 989                  AST "fst" asts -> from_ast1 asts fst_from ex ast ctx k
 990                  AST "snd" asts -> from_ast1 asts snd_from ex ast ctx k
 991                  _ -> Left $ error_expr_unsupported ex ast