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