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