Language/Symantic/AST/Test.hs

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