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