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 lam) 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 lam root) root)
 241  ) => Type_from AST (Type_Fun lam 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 lam) 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 lam root) root)
 433  ) => Type1_from AST (Type_Fun lam 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 (Lambda lam 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 lam) (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 lam) (Type_of_Expr root)
 535  , Root_of_Expr root ~ root
 536  , IBool (Is_Last_Expr (Expr_Lambda_App lam root) root)
 537  ) => Expr_from AST (Expr_Lambda_App lam 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 "app" asts -> from_ast2 asts app_from ex ast ctx k
 546                  _ -> Left $ error_expr_unsupported ex ast
 547 instance -- Expr_from AST Expr_Lambda_Inline
 548  ( Eq_Type (Type_Root_of_Expr root)
 549  , Type_from AST (Type_Root_of_Expr root)
 550  , Expr_from AST root
 551  , Lift_Type (Type_Fun lam) (Type_of_Expr root)
 552  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 553  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 554  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 555  , Root_of_Expr root ~ root
 556  , IBool (Is_Last_Expr (Expr_Lambda_Inline lam root) root)
 557  ) => Expr_from AST (Expr_Lambda_Inline lam root) where
 558         expr_from ex ast ctx k =
 559                 case ast of
 560                  AST "inline"     asts -> go_lam asts inline
 561                  AST "let_inline" asts -> go_let asts let_inline
 562                  _ -> Left $ error_expr_unsupported ex ast
 563                 where
 564                 go_lam asts
 565                  (lam::forall repr arg res. Sym_Lambda_Inline lam repr
 566                      => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
 567                         case asts of
 568                          [AST name [], ast_ty_arg, ast_body] ->
 569                                 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
 570                          _ -> Left $ error_expr ex $
 571                                 Error_Expr_Wrong_number_of_arguments ast 3
 572                 go_let asts
 573                  (let_::forall repr var res. Sym_Lambda_Inline lam repr
 574                      => repr var -> (repr var -> repr res) -> repr res) =
 575                         case asts of
 576                          [AST name [], ast_var, ast_body] ->
 577                                 let_from let_ name ast_var ast_body ex ast ctx k
 578                          _ -> Left $ error_expr ex $
 579                                 Error_Expr_Wrong_number_of_arguments ast 3
 580 instance -- Expr_from AST Expr_Lambda_Val
 581  ( Eq_Type (Type_Root_of_Expr root)
 582  , Type_from AST (Type_Root_of_Expr root)
 583  , Expr_from AST root
 584  , Lift_Type (Type_Fun lam) (Type_of_Expr root)
 585  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 586  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 587  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 588  , Root_of_Expr root ~ root
 589  , IBool (Is_Last_Expr (Expr_Lambda_Val lam root) root)
 590  ) => Expr_from AST (Expr_Lambda_Val lam root) where
 591         expr_from ex ast ctx k =
 592                 case ast of
 593                  AST "val"     asts -> go_lam asts val
 594                  AST "let_val" asts -> go_let asts let_val
 595                  _ -> Left $ error_expr_unsupported ex ast
 596                 where
 597                 go_lam asts
 598                  (lam::forall repr arg res. Sym_Lambda_Val lam repr
 599                      => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
 600                         case asts of
 601                          [AST name [], ast_ty_arg, ast_body] ->
 602                                 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
 603                          _ -> Left $ error_expr ex $
 604                                 Error_Expr_Wrong_number_of_arguments ast 3
 605                 go_let asts
 606                  (let_::forall repr var res. Sym_Lambda_Val lam repr
 607                      => repr var -> (repr var -> repr res) -> repr res) =
 608                         case asts of
 609                          [AST name [], ast_var, ast_body] ->
 610                                 let_from let_ name ast_var ast_body ex ast ctx k
 611                          _ -> Left $ error_expr ex $
 612                                 Error_Expr_Wrong_number_of_arguments ast 3
 613 instance -- Expr_from AST Expr_Lambda_Lazy
 614  ( Eq_Type (Type_Root_of_Expr root)
 615  , Type_from AST (Type_Root_of_Expr root)
 616  , Expr_from AST root
 617  , Lift_Type (Type_Fun lam) (Type_of_Expr root)
 618  , Lift_Error_Expr (Error_Expr_Lambda AST)       (Error_of_Expr AST root)
 619  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 620  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 621  , Root_of_Expr root ~ root
 622  , IBool (Is_Last_Expr (Expr_Lambda_Lazy lam root) root)
 623  ) => Expr_from AST (Expr_Lambda_Lazy lam root) where
 624         expr_from ex ast ctx k =
 625                 case ast of
 626                  AST "lazy"     asts -> go_lam asts lazy
 627                  AST "let_lazy" asts -> go_let asts let_lazy
 628                  _ -> Left $ error_expr_unsupported ex ast
 629                 where
 630                 go_lam asts
 631                  (lam::forall repr arg res. Sym_Lambda_Lazy lam repr
 632                      => (repr arg -> repr res) -> repr (Lambda lam arg res)) =
 633                         case asts of
 634                          [AST name [], ast_ty_arg, ast_body] ->
 635                                 lam_from (Proxy::Proxy lam) lam name ast_ty_arg ast_body ex ast ctx k
 636                          _ -> Left $ error_expr ex $
 637                                 Error_Expr_Wrong_number_of_arguments ast 3
 638                 go_let asts
 639                  (let_::forall repr var res. Sym_Lambda_Lazy lam repr
 640                      => repr var -> (repr var -> repr res) -> repr res) =
 641                         case asts of
 642                          [AST name [], ast_var, ast_body] ->
 643                                 let_from let_ name ast_var ast_body ex ast ctx k
 644                          _ -> Left $ error_expr ex $
 645                                 Error_Expr_Wrong_number_of_arguments ast 3
 646 instance -- Expr_from AST Expr_Maybe
 647  ( Eq_Type (Type_Root_of_Expr root)
 648  , Type_from AST (Type_Root_of_Expr root)
 649  , Expr_from AST root
 650  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 651  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 652  , Lift_Type   Type_Maybe     (Type_of_Expr root)
 653  , Unlift_Type Type_Maybe     (Type_of_Expr root)
 654  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 655  , Root_of_Expr root ~ root
 656  , IBool (Is_Last_Expr (Expr_Maybe lam root) root)
 657  ) => Expr_from AST (Expr_Maybe lam root) where
 658         expr_from ex ast ctx k =
 659                 case ast of
 660                  AST "maybe"   asts -> from_ast3 asts maybe_from   ex ast ctx k
 661                  AST "nothing" asts -> from_ast1 asts nothing_from ex ast ctx k
 662                  AST "just"    asts -> from_ast1 asts just_from    ex ast ctx k
 663                  _ -> Left $ error_expr_unsupported ex ast
 664 instance -- Expr_from AST Expr_Eq
 665  ( Eq_Type (Type_Root_of_Expr root)
 666  , Lift_Type Type_Bool (Type_of_Expr root)
 667  , Constraint_Type Eq (Type_Root_of_Expr root)
 668  , Expr_from AST root
 669  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 670  , Root_of_Expr root ~ root
 671  , IBool (Is_Last_Expr (Expr_Eq root) root)
 672  ) => Expr_from AST (Expr_Eq root) where
 673         expr_from ex ast ctx k =
 674                 case ast of
 675                  AST "==" asts -> from_ast2 asts eq_from ex ast ctx k
 676                  _ -> Left $ error_expr_unsupported ex ast
 677 instance -- Expr_from AST Expr_Ord
 678  ( Eq_Type (Type_Root_of_Expr root)
 679  , Lift_Type Type_Ordering (Type_of_Expr root)
 680  , Constraint_Type Ord (Type_Root_of_Expr root)
 681  , Expr_from AST root
 682  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 683  , Root_of_Expr root ~ root
 684  , IBool (Is_Last_Expr (Expr_Ord root) root)
 685  ) => Expr_from AST (Expr_Ord root) where
 686         expr_from ex ast ctx k =
 687                 case ast of
 688                  AST "compare" asts -> from_ast2 asts compare_from ex ast ctx k
 689                  _ -> Left $ error_expr_unsupported ex ast
 690 instance -- Expr_from AST Expr_List
 691  ( Eq_Type (Type_Root_of_Expr root)
 692  , Type_from AST (Type_Root_of_Expr root)
 693  , Expr_from AST root
 694  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 695  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 696  , Lift_Type   Type_List      (Type_of_Expr root)
 697  , Unlift_Type Type_List      (Type_of_Expr root)
 698  , Lift_Type   Type_Bool      (Type_of_Expr root)
 699  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 700  , Root_of_Expr root ~ root
 701  , IBool (Is_Last_Expr (Expr_List lam root) root)
 702  ) => Expr_from AST (Expr_List lam root) where
 703         expr_from ex ast ctx k =
 704                 case ast of
 705                  AST "[]"          asts -> from_ast1 asts list_empty_from  ex ast ctx k
 706                  AST ":"           asts -> from_ast2 asts list_cons_from   ex ast ctx k
 707                  AST "list_filter" asts -> from_ast2 asts list_filter_from ex ast ctx k
 708                  AST "list"        asts ->
 709                         case asts of
 710                          ast_ty_a:asts' -> list_from ast_ty_a asts' ex ast ctx k
 711                          _ -> Left $ error_expr ex $
 712                                 Error_Expr_Wrong_number_of_arguments ast 1
 713                  _ -> Left $ error_expr_unsupported ex ast
 714 instance -- Expr_from AST Expr_Map
 715  ( Eq_Type (Type_Root_of_Expr root)
 716  , Expr_from AST root
 717  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 718  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 719  , Lift_Type   Type_Map       (Type_of_Expr root)
 720  , Unlift_Type Type_Map       (Type_of_Expr root)
 721  , Lift_Type   Type_List      (Type_of_Expr root)
 722  , Unlift_Type Type_List      (Type_of_Expr root)
 723  , Lift_Type   Type_Tuple2    (Type_of_Expr root)
 724  , Unlift_Type Type_Tuple2    (Type_of_Expr root)
 725  , Constraint_Type Ord (Type_Root_of_Expr root)
 726  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 727  , Root_of_Expr root ~ root
 728  , IBool (Is_Last_Expr (Expr_Map lam root) root)
 729  ) => Expr_from AST (Expr_Map lam root) where
 730         expr_from ex ast ctx k =
 731                 case ast of
 732                  AST "map_from_list" asts -> from_ast1 asts map_from_list_from ex ast ctx k
 733                  AST "map_map" asts -> from_ast2 asts map_map_from ex ast ctx k
 734                  _ -> Left $ error_expr_unsupported ex ast
 735 instance -- Expr_from AST Expr_Functor
 736  ( Eq_Type (Type_Root_of_Expr root)
 737  , Expr_from AST root
 738  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 739  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 740  , Unlift_Type1 (Type_of_Expr root)
 741  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 742  , Constraint_Type1 Functor (Type_Root_of_Expr root)
 743  , Root_of_Expr root ~ root
 744  , IBool (Is_Last_Expr (Expr_Functor lam root) root)
 745  ) => Expr_from AST (Expr_Functor lam root) where
 746         expr_from ex ast ctx k =
 747                 case ast of
 748                  AST "fmap" asts -> from_ast2 asts fmap_from ex ast ctx k
 749                  AST "<$>"  asts -> from_ast2 asts fmap_from ex ast ctx k
 750                  _ -> Left $ error_expr_unsupported ex ast
 751 instance -- Expr_from AST Expr_Applicative
 752  ( Eq_Type (Type_Root_of_Expr root)
 753  , Type1_from AST (Type_Root_of_Expr root)
 754  , Expr_from AST root
 755  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 756  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 757  , Eq_Type1 (Type_Root_of_Expr root)
 758  , Unlift_Type1 (Type_of_Expr root)
 759  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 760  , Constraint_Type1 Applicative (Type_Root_of_Expr root)
 761  , Root_of_Expr root ~ root
 762  , IBool (Is_Last_Expr (Expr_Applicative lam root) root)
 763  ) => Expr_from AST (Expr_Applicative lam root) where
 764         expr_from ex ast ctx k =
 765                 case ast of
 766                  AST "pure" asts -> from_ast2 asts pure_from     ex ast ctx k
 767                  AST "<*>"  asts -> from_ast2 asts ltstargt_from ex ast ctx k
 768                  _ -> Left $ error_expr_unsupported ex ast
 769 instance -- Expr_from AST Expr_Traversable
 770  ( Eq_Type (Type_Root_of_Expr root)
 771  , Expr_from AST root
 772  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 773  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 774  , Eq_Type1 (Type_Root_of_Expr root)
 775  , Unlift_Type1 (Type_of_Expr root)
 776  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 777  , Constraint_Type1 Applicative (Type_Root_of_Expr root)
 778  , Constraint_Type1 Traversable (Type_Root_of_Expr root)
 779  , Root_of_Expr root ~ root
 780  , IBool (Is_Last_Expr (Expr_Traversable lam root) root)
 781  ) => Expr_from AST (Expr_Traversable lam root) where
 782         expr_from ex ast ctx k =
 783                 case ast of
 784                  AST "traverse"  asts -> from_ast2 asts traverse_from ex ast ctx k
 785                  _ -> Left $ error_expr_unsupported ex ast
 786 instance -- Expr_from AST Expr_Foldable
 787  ( Eq_Type (Type_Root_of_Expr root)
 788  , Expr_from AST root
 789  , Lift_Type   Type_Int       (Type_of_Expr root)
 790  , Lift_Type   Type_Bool      (Type_of_Expr root)
 791  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 792  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 793  , Eq_Type1 (Type_Root_of_Expr root)
 794  , Unlift_Type1 (Type_of_Expr root)
 795  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 796  , Constraint_Type  Eq       (Type_Root_of_Expr root)
 797  , Constraint_Type  Ord      (Type_Root_of_Expr root)
 798  , Constraint_Type  Monoid   (Type_Root_of_Expr root)
 799  , Constraint_Type1 Foldable (Type_Root_of_Expr root)
 800  , Root_of_Expr root ~ root
 801  , IBool (Is_Last_Expr (Expr_Foldable lam root) root)
 802  ) => Expr_from AST (Expr_Foldable lam root) where
 803         expr_from ex ast ctx k =
 804                 case ast of
 805                  AST "foldMap" asts -> from_ast2 asts foldMap_from ex ast ctx k
 806                  AST "null"    asts -> from_ast1 asts null_from ex ast ctx k
 807                  AST "length"  asts -> from_ast1 asts length_from ex ast ctx k
 808                  AST "minimum" asts -> from_ast1 asts minimum_from ex ast ctx k
 809                  AST "maximum" asts -> from_ast1 asts maximum_from ex ast ctx k
 810                  AST "elem"    asts -> from_ast2 asts elem_from ex ast ctx k
 811                  _ -> Left $ error_expr_unsupported ex ast
 812 instance -- Expr_from AST Expr_Monoid
 813  ( Eq_Type (Type_Root_of_Expr root)
 814  , Type_from AST (Type_Root_of_Expr root)
 815  , Expr_from AST root
 816  , Lift_Type   Type_Int       (Type_of_Expr root)
 817  , Lift_Type   Type_Bool      (Type_of_Expr root)
 818  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 819  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 820  , Unlift_Type1 (Type_of_Expr root)
 821  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 822  , Constraint_Type Monoid (Type_Root_of_Expr root)
 823  , Root_of_Expr root ~ root
 824  , IBool (Is_Last_Expr (Expr_Monoid lam root) root)
 825  ) => Expr_from AST (Expr_Monoid lam root) where
 826         expr_from ex ast ctx k =
 827                 case ast of
 828                  AST "mempty"  asts -> from_ast1 asts mempty_from ex ast ctx k
 829                  AST "mappend" asts -> from_ast2 asts mappend_from ex ast ctx k
 830                  _ -> Left $ error_expr_unsupported ex ast
 831 instance -- Expr_from AST Expr_Monad
 832  ( Eq_Type (Type_Root_of_Expr root)
 833  , Type1_from AST (Type_Root_of_Expr root)
 834  , Expr_from AST root
 835  , Lift_Type   (Type_Fun lam) (Type_of_Expr root)
 836  , Unlift_Type (Type_Fun lam) (Type_of_Expr root)
 837  , Eq_Type1 (Type_Root_of_Expr root)
 838  , Unlift_Type1 (Type_of_Expr root)
 839  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 840  , Constraint_Type1 Monad (Type_Root_of_Expr root)
 841  , Root_of_Expr root ~ root
 842  , IBool (Is_Last_Expr (Expr_Monad lam root) root)
 843  ) => Expr_from AST (Expr_Monad lam root) where
 844         expr_from ex ast ctx k =
 845                 case ast of
 846                  AST "return" asts -> from_ast2 asts return_from ex ast ctx k
 847                  AST ">>="    asts -> from_ast2 asts bind_from   ex ast ctx k
 848                  _ -> Left $ error_expr_unsupported ex ast
 849 instance -- Expr_from AST Expr_Either
 850  ( Eq_Type (Type_Root_of_Expr root)
 851  , Type_from  AST (Type_Root_of_Expr root)
 852  , Expr_from AST root
 853  , Lift_Error_Expr (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
 854  , Root_of_Expr root ~ root
 855  , Lift_Type   Type_Either (Type_of_Expr root)
 856  , Unlift_Type Type_Either (Type_of_Expr root)
 857  , IBool (Is_Last_Expr (Expr_Either root) root)
 858  ) => Expr_from AST (Expr_Either root) where
 859         expr_from ex ast ctx k =
 860                 case ast of
 861                  AST "left"  asts -> from_ast2 asts left_from  ex ast ctx k
 862                  AST "right" asts -> from_ast2 asts right_from ex ast ctx k
 863                  _ -> Left $ error_expr_unsupported ex ast