a3/code/Generics/GenParse.icl

   1 implementation module GenParse
   2
   3 import StdGeneric, StdEnv, StdMaybe
   4
   5 //---------------------------------------------------------------------------
   6
   7
   8 :: StringInput = { si_str :: !String, si_pos :: !Int}
   9
  10 mkStringInput :: String -> StringInput
  11 mkStringInput str = {si_str = str, si_pos = 0}
  12
  13 instance ParseInput StringInput where
  14         parseInput s=:{si_pos, si_str}
  15                 #! size_str = size si_str
  16                 | size_str == si_pos
  17                         = (Nothing, {s & si_str = si_str})
  18                 | otherwise
  19                         #! ch = si_str.[si_pos]
  20                         = (Just ch, {s & si_str = si_str, si_pos = inc si_pos})
  21
  22 instance ParseInput File where
  23         parseInput file
  24                 # (ok, c, file) = sfreadc file
  25                 | ok
  26                         = (Just c, file)
  27                         = (Nothing, file)
  28
  29 //---------------------------------------------------------------------------
  30
  31 // lex tokens
  32 :: Token
  33         = TokenInt Int
  34         | TokenChar Char
  35         | TokenReal Real
  36         | TokenBool Bool
  37         | TokenString String
  38         | TokenIdent String
  39         | TokenOpenPar
  40         | TokenClosePar
  41         | TokenOpenCurly
  42         | TokenCloseCurly
  43         | TokenOpenList
  44         | TokenCloseList
  45         | TokenComma
  46         | TokenEnd
  47         | TokenError String
  48
  49 instance toString Token where
  50         toString (TokenInt x) = toString x
  51         toString (TokenChar x) = toString x
  52         toString (TokenReal x) = toString x
  53         toString (TokenBool x) = toString x
  54         toString (TokenString x) = x
  55         toString (TokenIdent x) = x
  56         toString TokenOpenPar = "("
  57         toString TokenClosePar = ")"
  58         toString TokenOpenCurly = "{"
  59         toString TokenCloseCurly = "}"
  60         toString TokenOpenList = "["
  61         toString TokenCloseList = "]"
  62         toString TokenComma = ","
  63         toString TokenEnd = "<end>"
  64         toString (TokenError err) = "<error: " +++ err +++ ">"
  65
  66 // preparsed expressions
  67 :: Expr
  68         = ExprInt Int
  69         | ExprChar Char
  70         | ExprReal Real
  71         | ExprBool Bool
  72         | ExprString String
  73         | ExprIdent String
  74         | ExprApp {Expr}
  75         | ExprTuple {Expr}
  76         | ExprField String Expr
  77         | ExprRecord (Maybe String) {Expr}
  78         | ExprList [Expr]
  79         | ExprArray [Expr]
  80         | ExprEnd Token
  81         | ExprError String
  82
  83         // aux
  84         | ExprUnit
  85         | ExprAppInInfix {Expr} GenConsAssoc Int GenConsAssoc
  86         | ExprPair Expr Expr
  87
  88
  89 instance toString Expr where
  90         toString (ExprInt x) = toString x
  91         toString (ExprChar x) = toString x
  92         toString (ExprBool x) = toString x
  93         toString (ExprReal x) = toString x
  94         toString (ExprString x) = x
  95         toString (ExprIdent x) = x
  96         toString (ExprApp xs) = "(" +++ tostr [x\\x<-:xs] +++ ")"
  97         where
  98                 tostr [] = ""
  99                 tostr [x] = toString x
 100                 tostr [x:xs] = toString x +++ " " +++ tostr xs
 101         toString (ExprTuple xs) = "(" +++ tostr [x\\x<-:xs] +++ ")"
 102         where
 103                 tostr [] = ""
 104                 tostr [x] = toString x
 105                 tostr [x:xs] = toString x +++ ", " +++ tostr xs
 106         toString (ExprRecord name xs) = "{" +++ tostr [x\\x<-:xs] +++ "}"
 107         where
 108                 tostr [] = ""
 109                 tostr [x] = toString x
 110                 tostr [x:xs] = toString x +++ ", " +++ tostr xs
 111         toString (ExprField name expr) = name +++ "=" +++ toString expr
 112
 113
 114 :: ParseState s =
 115         { ps_input      :: !s                   // lex input
 116         , ps_char       :: !Maybe Char  // unget char
 117         , ps_tokens :: ![Token]         // unget tokens
 118         }
 119
 120 lexGetChar ps=:{ps_char=Nothing, ps_input}
 121         # (mc, ps_input) = parseInput ps_input
 122         = (mc, {ps & ps_input = ps_input})
 123 lexGetChar ps=:{ps_char} = (ps_char, {ps & ps_char = Nothing})
 124
 125 lexUngetChar c ps=:{ps_char=Nothing} = {ps & ps_char = Just c}
 126 lexUngetChar c ps = abort "cannot unget\n"
 127
 128 isSpecialChar   :: !Char -> Bool
 129 isSpecialChar '~'       = True
 130 isSpecialChar '@'       = True
 131 isSpecialChar '#'       = True
 132 isSpecialChar '$'       = True
 133 isSpecialChar '%'       = True
 134 isSpecialChar '^'       = True
 135 isSpecialChar '?'       = True
 136 isSpecialChar '!'       = True
 137 isSpecialChar '+'       = True
 138 isSpecialChar '-'       = True
 139 isSpecialChar '*'       = True
 140 isSpecialChar '<'       = True
 141 isSpecialChar '>'       = True
 142 isSpecialChar '\\'      = True
 143 isSpecialChar '/'       = True
 144 isSpecialChar '|'       = True
 145 isSpecialChar '&'       = True
 146 isSpecialChar '='       = True
 147 isSpecialChar ':'       = True
 148 isSpecialChar '.'       = True
 149 isSpecialChar c         = False
 150
 151 //----------------------------------------------------------------------------------
 152 // lex input
 153
 154 lexUngetToken token ps=:{ps_tokens} = {ps & ps_tokens = [token:ps_tokens]}
 155
 156 lexGetToken ps=:{ps_tokens=[token:tokens]} = (token, {ps & ps_tokens = tokens})
 157 lexGetToken ps=:{ps_tokens=[]}
 158         = lex ps
 159 where
 160         lex s
 161                 # (mc, s) = lexGetChar s
 162                 = case mc of
 163                         Nothing  -> (TokenEnd, s)
 164                         Just '\0' -> (TokenEnd, s)
 165                         Just '(' -> (TokenOpenPar, s)
 166                         Just ')' -> (TokenClosePar, s)
 167                         Just '{' -> (TokenOpenCurly, s)
 168                         Just '}' -> (TokenCloseCurly, s)
 169                         Just '[' -> (TokenOpenList, s)
 170                         Just ']' -> (TokenCloseList, s)
 171                         Just ',' -> (TokenComma, s)
 172                         Just '\'' -> lex_char 0 [] s
 173                         Just '"'  -> lex_string 0 [] s
 174                         Just '_' -> lex_ident 1 ['_'] s
 175                         Just '`' -> lex_ident 1 ['`'] s
 176                         Just '+'
 177                                 # (mc, s) = lexGetChar s
 178                                 -> case mc of
 179                                         Nothing -> (TokenIdent "+", s)
 180                                         Just c
 181                                                 | isDigit c
 182                                                         -> lex_number +1 (lexUngetChar c s)
 183                                                 | otherwise
 184                                                         -> lex_ident 1 ['+'] (lexUngetChar c s)
 185                         Just '-'
 186                                 # (mc, s) = lexGetChar s
 187                                 -> case mc of
 188                                         Nothing -> (TokenIdent "-", s)
 189                                         Just c
 190                                                 | isDigit c
 191                                                         -> lex_number -1 (lexUngetChar c s)
 192                                                 | otherwise
 193                                                         -> lex_funny_ident 1 ['-'] (lexUngetChar c s) // PK
 194         //                                              -> lex_ident 1 ['-'] (lexUngetChar c s)
 195                         Just c
 196                                 | isSpace c
 197                                         -> lex s
 198                                 | isDigit c
 199                                         -> lex_number +1 (lexUngetChar c s)
 200                                 | isAlpha c
 201                                         -> lex_ident 1 [c] s
 202                                 | isSpecialChar c
 203                                         -> lex_funny_ident 1 [c] s
 204                                 | otherwise
 205                                         -> (TokenError ("Unknown character " +++ toString c), s)
 206
 207         lex_digits s
 208                 = lex_digits_acc 0 [] s
 209         lex_digits_acc num acc s
 210                 # (mc, s) = lexGetChar s
 211                 = case mc of
 212                         Nothing
 213                                 -> (num, acc, s)
 214                         Just c
 215                                 | isDigit c
 216                                         -> lex_digits_acc (inc num) [digitToInt c:acc] s
 217                                 | otherwise
 218                                         -> (num, acc, lexUngetChar c s)
 219
 220         digits_to_int :: [Int] -> Int
 221         digits_to_int [] = 0
 222         digits_to_int [digit:digits] = digit + 10 * digits_to_int digits
 223
 224         digits_to_real :: [Int] -> Real
 225         digits_to_real [] = 0.0
 226         digits_to_real [digit:digits] = toReal digit + 10.0 * digits_to_real digits
 227
 228         lex_number sign s
 229                 #! (num_digits, digits, s) = lex_digits s
 230                 #! (mc, s) = lexGetChar s
 231                 = case mc of
 232                         Nothing -> (TokenInt (sign * digits_to_int digits), s)
 233                         Just '.'
 234                                 -> lex_real_with_fraction (toReal sign) (digits_to_real digits) s
 235                         Just 'E'
 236                                 #! real = toReal sign * digits_to_real digits
 237                                 -> lex_real_with_exp real s
 238                         Just 'e'
 239                                 #! real = toReal sign * digits_to_real digits
 240                                 -> lex_real_with_exp real s
 241                         Just c
 242                                 -> (TokenInt (sign * digits_to_int digits), lexUngetChar c s)
 243
 244         lex_real_with_fraction sign real s
 245                 #! (num_digits, digits, s) = lex_digits s
 246                 #! fraction = digits_to_real digits  / 10.0^ toReal num_digits
 247                 #! real = sign * (real + fraction)
 248                 #! (mc, s) = lexGetChar s
 249                 = case mc of
 250                         Nothing -> (TokenReal real, s)
 251                         Just 'E'
 252                                 -> lex_real_with_exp real s
 253                         Just 'e'
 254                                 -> lex_real_with_exp real s
 255                         Just c
 256                                 -> (TokenReal real, lexUngetChar c s)
 257
 258         lex_real_with_exp real s
 259                 # (mc, s) = lexGetChar s
 260                 = case mc of
 261                         Nothing -> (TokenReal real, s)
 262                         Just '+'
 263                                 #! (num_digits, digits, s) = lex_digits s
 264                                 -> (TokenReal (real * 10.0 ^ digits_to_real digits), s)
 265                         Just '-'
 266                                 #! (num_digits, digits, s) = lex_digits s
 267                                 -> (TokenReal (real * 10.0 ^ (-1.0 * digits_to_real digits)), s)
 268                         Just c
 269                                 | isDigit c
 270                                         #! (num_digits, digits, s) = lex_digits (lexUngetChar c s)
 271                                         -> (TokenReal (real * 10.0 ^ digits_to_real digits), s)
 272                                 | otherwise
 273                                         -> (TokenError "error in real constant", s)
 274
 275         lex_ident num_chars acc_chars s
 276                 # (mc, s) = lexGetChar s
 277                 = case mc of
 278                         Nothing -> (mktoken num_chars acc_chars, s)
 279                         Just '_' -> lex_ident (inc num_chars) ['_':acc_chars] s
 280                         Just '`' -> lex_ident (inc num_chars) ['`':acc_chars] s
 281                         Just c
 282                                 | isAlphanum c
 283                                         -> lex_ident (inc num_chars) [c:acc_chars] s
 284                                 | otherwise
 285                                         -> (mktoken num_chars acc_chars, lexUngetChar c s)
 286         where
 287                 mktoken num_chars acc_chars
 288                         = case mk_str num_chars acc_chars of
 289                                 "True"  -> TokenBool True
 290                                 "False" -> TokenBool False
 291                                 str             -> TokenIdent str
 292
 293         lex_funny_ident num_chars acc_chars s
 294                 # (mc, s) = lexGetChar s
 295                 = case mc of
 296                         Nothing         -> (TokenIdent (mk_str num_chars acc_chars), s)
 297                         Just c
 298                                 | isSpecialChar c
 299                                         -> lex_funny_ident (inc num_chars) [c:acc_chars] s
 300                                 | otherwise
 301                                         -> (TokenIdent (mk_str num_chars acc_chars), lexUngetChar c s)
 302
 303         lex_string num_chars acc_chars s
 304                 # (mc, s) = lexGetChar s
 305                 = case mc of
 306                         Nothing -> (TokenError "error in string constant", s)
 307                         Just '"' -> (TokenString (mk_str num_chars acc_chars), s)
 308                         Just '\\'
 309                                 #! (mc, s) = lex_special_char s
 310                                 -> case mc of
 311                                         Nothing -> (TokenError "error in string constant", s)
 312                                         Just c -> lex_string (inc num_chars) [c:acc_chars] s
 313                         Just c  -> lex_string (inc num_chars) [c:acc_chars] s
 314
 315
 316         lex_char num_chars acc_chars s
 317                 # (mc, s) = lexGetChar s
 318                 = case mc of
 319                         Nothing -> (TokenError "error in char constant", s)
 320                         Just '\''
 321                                 | num_chars == 1
 322                                         -> (TokenChar (hd acc_chars), s)
 323                                 | num_chars == 0
 324                                         -> (TokenError "char constant contains no characters ", s)
 325                                 | otherwise
 326                                         -> (TokenError "char constant contains more than one character", s)
 327                         Just '\\'
 328                                 #! (mc, s) = lex_special_char s
 329                                 -> case mc of
 330                                         Nothing -> (TokenError "error in char constant", s)
 331                                         Just c -> lex_char (inc num_chars) [c:acc_chars] s
 332                         Just c  -> lex_char (inc num_chars) [c:acc_chars] s
 333
 334         lex_special_char s
 335                 #! (mc, s) = lexGetChar s
 336                 = case mc of
 337                         Just 'n' -> (Just '\n', s)
 338                         Just 'r' -> (Just '\r', s)
 339                         Just 'f' -> (Just '\f', s)
 340                         Just 'b' -> (Just '\b', s)
 341                         Just 't' -> (Just '\t', s)
 342                         Just '\\' -> (Just '\\', s)
 343                         Just '\'' -> (Just '\'', s)
 344                         Just '\"' -> (Just '\"', s)
 345                         Just '\0' -> (Just '\0', s)
 346                         //Just '\x' -> abort "lex: hex char not implemented\n"
 347                         //Just '\0' -> abort "lex: oct char not implemented\n"
 348                         _ -> (mc, s)
 349
 350         mk_str num_chars acc_chars
 351                 # str = createArray num_chars ' '
 352                 = fill (dec num_chars) acc_chars str
 353         where
 354                 fill i [] str           = str
 355                 fill i [x:xs] str       = fill (dec i) xs {str & [i] = x}
 356
 357
 358 //----------------------------------------------------------------------------------
 359 // preparse input
 360
 361
 362 :: ParseEnv = PETop | PETuple | PEPar | PERecord | PEList
 363
 364 preParse :: (ParseState s) -> (Expr, ParseState s) | ParseInput s
 365 preParse s
 366         = parse_expr PETop s
 367 where
 368         parse_expr env s
 369                 = parse_app env [] s
 370
 371         parse_app env exprs s
 372                 #! (token, s) = lexGetToken s
 373                 = parse token env exprs s
 374         where
 375                 parse TokenComma PETuple exprs  s       = (mkexpr exprs, lexUngetToken TokenComma s)
 376                 parse TokenComma PERecord exprs s       = (mkexpr exprs, lexUngetToken TokenComma s)
 377                 parse TokenComma PEList exprs   s       = (mkexpr exprs, lexUngetToken TokenComma s)
 378                 parse TokenComma PETop exprs s          = (ExprError "end of input expected instead of ,", s)
 379                 parse TokenComma PEPar exprs s          = (ExprError ") expected instead of ,", s)
 380                 parse TokenComma env exprs s            = abort "unknown env\n"
 381
 382                 parse TokenClosePar PETuple     exprs s = (mkexpr exprs, lexUngetToken TokenClosePar s)
 383                 parse TokenClosePar PERecord exprs s = (ExprError "} expected instead of )", s)
 384                 parse TokenClosePar PEList exprs s  = (ExprError "] expected instead of )", s)
 385                 parse TokenClosePar PETop       exprs s = (ExprError "end of input expected instead of )", s)
 386                 parse TokenClosePar PEPar       exprs s = (mkexpr exprs, lexUngetToken TokenClosePar s)
 387                 parse TokenClosePar env exprs s         = abort "unknown env\n"
 388
 389                 parse TokenCloseCurly PETuple   exprs s = (ExprError ") expected instead of }", s)
 390                 parse TokenCloseCurly PEList    exprs s = (ExprError "] expected instead of }", s)
 391                 parse TokenCloseCurly PERecord exprs s = (mkexpr exprs, lexUngetToken TokenCloseCurly s)
 392                 parse TokenCloseCurly PETop     exprs s = (ExprError "end of input expected instead of )", s)
 393                 parse TokenCloseCurly PEPar     exprs s = (mkexpr exprs, lexUngetToken TokenCloseCurly s)
 394                 parse TokenCloseCurly env exprs s       = abort "unknown env\n"
 395
 396                 parse TokenCloseList PETuple exprs s    = (ExprError ") expected instead of ]", s)
 397                 parse TokenCloseList PERecord exprs s = (ExprError "} expected instead of ]", s)
 398                 parse TokenCloseList PEList exprs s = (mkexpr exprs, lexUngetToken TokenCloseList s)
 399                 parse TokenCloseList PETop      exprs s = (ExprError "end of input expected instead of )", s)
 400                 parse TokenCloseList PEPar      exprs s = (mkexpr exprs, lexUngetToken TokenCloseList s)
 401                 parse TokenCloseList env exprs s        = abort "unknown env\n"
 402
 403                 parse TokenEnd PETuple exprs s          = (ExprError ") or, expected instead of end of input", s)
 404                 parse TokenEnd PERecord exprs s         = (ExprError "} or, expected instead of end of input", s)
 405                 parse TokenEnd PEList exprs s           = (ExprError "] or, expected instead of end of input", s)
 406                 parse TokenEnd PETop exprs s            = (mkexpr exprs, lexUngetToken TokenEnd s)
 407                 parse TokenEnd PEPar exprs s            = (ExprError ") expected instead of end of input",s)
 408                 parse TokenEnd env exprs s                      = abort "unknown env\n"
 409
 410                 parse (TokenInt x) env exprs s          = parse_app env [ExprInt x:exprs] s
 411                 parse (TokenBool x) env exprs s         = parse_app env [ExprBool x:exprs] s
 412                 parse (TokenReal x) env exprs s         = parse_app env [ExprReal x:exprs] s
 413                 parse (TokenChar x) env exprs s         = parse_app env [ExprChar x:exprs] s
 414                 parse (TokenString x) env exprs s       = parse_app env [ExprString x:exprs] s
 415                 parse (TokenIdent x) env exprs s        = parse_app env [ExprIdent x:exprs] s
 416                 parse TokenOpenPar env exprs s
 417                         # (expr, s)     = parse_par_expr s
 418                         = case expr of
 419                                 ExprError err   -> (ExprError err, s)
 420                                 _                               ->  parse_app env [expr:exprs] s
 421                 parse TokenOpenCurly env exprs s
 422                         # (expr, s) = parse_record_or_array s
 423                         = case expr of
 424                                 ExprError err   -> (ExprError err, s)
 425                                 _                               ->  parse_app env [expr:exprs] s
 426                 parse TokenOpenList env exprs s
 427                         # (expr, s) = parse_list s
 428                         = case expr of
 429                                 ExprError err   -> (ExprError err, s)
 430                                 _                               ->  parse_app env [expr:exprs] s
 431                 parse (TokenError err) env exprs s
 432                         = (ExprError ("lex error in parse_app: "  +++ err), s)
 433
 434                 parse token env exprs s
 435                         = abort ("parse app - unknown token " +++ toString token)
 436
 437
 438                 mkexpr []               = ExprError "expression expected"
 439                 mkexpr [expr]   = expr
 440                 mkexpr exprs    = ExprApp {e\\e <- reverse exprs}
 441
 442         parse_par_expr s
 443                 #! (expr, s) = parse_expr PETuple s
 444                 = case expr of
 445                         ExprError err -> (ExprError err, s)
 446                         _
 447                                 #! (token, s) = lexGetToken s
 448                                 -> case token of
 449                                         TokenClosePar -> (expr, s)
 450                                         TokenComma -> parse_tuple [expr] (lexUngetToken token s)
 451                                         _       -> (ExprError (", or ) expected, found " +++ toString token), s)
 452
 453         parse_tuple exprs s
 454                 #! (token, s) = lexGetToken s
 455                 = case token of
 456                         TokenComma
 457                                 #! (expr, s) = parse_expr PETuple s
 458                                 -> case expr of
 459                                         ExprError err -> (ExprError err, s)
 460                                         _       -> parse_tuple [expr:exprs] s
 461                         TokenClosePar
 462                                 -> (ExprTuple {e\\e<-reverse exprs}, s)
 463                         _
 464                                 -> (ExprError "parse tuple: , or ) expected", s)
 465
 466         parse_list s
 467                 #! (token, s) = lexGetToken s
 468                 = case token of
 469                         TokenCloseList
 470                                 -> (ExprList [], s)
 471                         _
 472                                 #! (expr, s) = parse_expr PEList (lexUngetToken token s)
 473                                 -> case expr of
 474                                         ExprError err -> (ExprError (err +++ " ; parse list"), s)
 475                                         _ -> parse_rest [expr] s
 476         where
 477                 parse_rest exprs s
 478                         #! (token, s) = lexGetToken s
 479                         = case token of
 480                                 TokenComma
 481                                         #! (expr, s) = parse_expr PEList s
 482                                         -> case expr of
 483                                                 ExprError err -> (ExprError err, s)
 484                                                 _       -> parse_rest [expr:exprs] s
 485                                 TokenCloseList
 486                                         -> (ExprList (reverse exprs), s)
 487                                 _
 488                                         -> (ExprError "parse list: , or ] expected", s)
 489
 490
 491         parse_record_or_array s
 492                 #! (token, s) = lexGetToken s
 493                 = case token of
 494                         TokenCloseCurly
 495                                 -> (ExprArray [], s)
 496                         TokenIdent name
 497                                 #! (token, s) = lexGetToken s
 498                                 -> case token of
 499                                         TokenIdent "="
 500                                                 #! (expr, s) = parse_expr PERecord s
 501                                                 -> parse_record Nothing [ExprField name expr] s
 502                                         TokenIdent "|"
 503                                                 -> parse_record (Just ("_" +++ name)) [] (lexUngetToken TokenComma s)
 504                                         _
 505                                                 #! (expr, s) = parse_expr PERecord
 506                                                         (lexUngetToken (TokenIdent name) (lexUngetToken token s))
 507                                                 -> parse_array [expr] s
 508                         _
 509                                 #! (expr, s) = parse_expr PERecord (lexUngetToken token s)
 510                                 -> parse_array [expr] s
 511         where
 512                 parse_record rec_name fields s
 513                         #! (token, s) = lexGetToken s
 514                         = case token of
 515                                 TokenCloseCurly
 516                                         -> (ExprRecord rec_name {e\\e<- reverse fields}, s)
 517                                 TokenComma
 518                                         #! (token, s) = lexGetToken     s
 519                                         -> case token of
 520                                                 TokenIdent field_name
 521                                                         #! (token, s) = lexGetToken     s
 522                                                         -> case token of
 523                                                                 TokenIdent "="
 524                                                                         #! (expr, s) = parse_expr PERecord s
 525                                                                         -> parse_record rec_name [ExprField field_name expr:fields] s
 526                                 _ -> (ExprError ("parse record failed on token " +++ toString token), s)
 527
 528                 parse_array exprs s
 529                         #! (token, s) = lexGetToken s
 530                         = case token of
 531                                 TokenCloseCurly
 532                                         -> (ExprArray (reverse exprs), s)
 533                                 TokenComma
 534                                         #! (expr, s) = parse_expr PERecord s
 535                                         -> parse_array [expr:exprs] s
 536                                 _ -> (ExprError ("parse array failed on token " +++ toString token), s)
 537
 538
 539 //----------------------------------------------------------------------------------
 540
 541 generic gParse a :: Expr -> Maybe a
 542
 543 gParse{|Int|} (ExprInt x)                       = Just x
 544 gParse{|Int|} _                                         = Nothing
 545
 546 gParse{|Char|} (ExprChar x)                     = Just x
 547 gParse{|Char|} _                                        = Nothing
 548
 549 gParse{|Bool|} (ExprBool x)                     = Just x
 550 gParse{|Bool|} _                                        = Nothing
 551
 552 gParse{|Real|} (ExprReal x)                     = Just x
 553 gParse{|Real|} _                                        = Nothing
 554
 555 gParse{|String|} (ExprString x)         = Just x
 556 gParse{|String|} _                                      = Nothing
 557
 558 gParse{|UNIT|}  ExprUnit                        = Just UNIT
 559 gParse{|UNIT|} _                                        = Nothing
 560
 561 gParse{|PAIR|} fx fy (ExprPair ex ey)
 562         = case fx ex of
 563                 Just x -> case fy ey of
 564                         Just y                                  -> Just (PAIR x y)
 565                         Nothing                                 -> Nothing
 566                 Nothing                                         -> Nothing
 567 gParse{|PAIR|} fx fy _                          = Nothing
 568
 569 gParse{|EITHER|} fl fr expr
 570         = case fl expr of
 571                 Nothing                                         -> case fr expr of
 572                         Nothing                                 -> Nothing
 573                         Just x                                  -> Just (RIGHT x)
 574                 Just x                                          -> Just (LEFT x)
 575
 576 gParse{|CONS of d|} parse_arg expr
 577         | d.gcd_arity == 0
 578                 = parse_nullary expr
 579         | isEmpty d.gcd_fields
 580                 | is_tuple d.gcd_name
 581                         = parse_tuple expr
 582                 | otherwise
 583                         = case d.gcd_prio of
 584                                 GenConsNoPrio
 585                                         -> parse_nonfix expr
 586                                 GenConsPrio assoc prio
 587                                         -> parse_infix assoc prio expr
 588         | otherwise
 589                 = parse_record expr
 590 where
 591         mkprod []               = abort "mkprod\n"
 592         mkprod [expr]   = expr
 593         mkprod exprs
 594                 # (xs, ys) = splitAt (length exprs / 2) exprs
 595                 = ExprPair (mkprod xs) (mkprod ys)
 596
 597         parse_nullary (ExprIdent name)
 598                 | name == d.gcd_name
 599                         = mapMaybe CONS (parse_arg ExprUnit)
 600         parse_nullary _
 601                 = Nothing
 602
 603         parse_nonfix (ExprApp exprs)
 604                 = parse_nonfix1 exprs
 605         parse_nonfix (ExprAppInInfix exprs _ _ _)
 606                 = parse_nonfix1 exprs
 607         parse_nonfix _
 608                 = Nothing
 609
 610         parse_nonfix1 exprs
 611                 #! size_exprs = size exprs
 612                 | size_exprs == d.gcd_arity + 1 && is_ident d.gcd_name exprs.[0]
 613                         #! arg_exprs = [exprs.[i] \\ i <- [1 .. size_exprs - 1]]
 614                         = mapMaybe CONS (parse_arg (mkprod arg_exprs))
 615                 | otherwise
 616                         = Nothing
 617
 618         is_ident wanted_name (ExprIdent name) = name == wanted_name
 619         is_ident _ _ = False
 620
 621         parse_tuple (ExprTuple exprs)
 622                 = mapMaybe CONS (parse_arg (mkprod [e\\e<-:exprs]))
 623         parse_tuple expr = Nothing
 624
 625         parse_record (ExprRecord rec_name exprs)
 626                 | check_name rec_name d.gcd_name
 627                         = mapMaybe CONS (parse_arg (mkprod [e\\e<-:exprs]))
 628                         = Nothing
 629         where
 630                 check_name Nothing cons_name = True
 631                 check_name (Just rec_name) cons_name = rec_name == cons_name
 632         parse_record expr = Nothing
 633
 634         parse_infix this_assoc this_prio (ExprApp exprs)
 635                 = parse_infix1 this_assoc this_prio exprs
 636         parse_infix this_assoc this_prio (ExprAppInInfix exprs outer_assoc outer_prio branch)
 637                 | this_prio > outer_prio
 638                         = parse_infix1 this_assoc this_prio exprs
 639                 | this_prio < outer_prio
 640                         = Nothing
 641                 | otherwise
 642                         = case (this_assoc, outer_assoc, branch) of
 643                                 (GenConsAssocLeft, GenConsAssocLeft, GenConsAssocLeft)
 644                                         -> parse_infix1 this_assoc this_prio exprs
 645                                 (GenConsAssocRight, GenConsAssocRight, GenConsAssocRight)
 646                                         -> parse_infix1 this_assoc this_prio exprs
 647                                 _ -> Nothing
 648         parse_infix this_assoc this_prio expr
 649                 = Nothing
 650
 651         parse_infix1 this_assoc this_prio exprs
 652                 #! size_exprs = size exprs
 653                 | size_exprs < 3 = Nothing
 654                 = case (case this_assoc of GenConsAssocLeft -> find_last; _ -> find_first) exprs of
 655                         Nothing -> Nothing
 656                         Just op_index
 657                                 #! left_arg  = mkarg GenConsAssocLeft {exprs.[i] \\ i <- [0 .. op_index - 1]}
 658                                 #! right_arg = mkarg GenConsAssocRight {exprs.[i] \\ i <- [op_index + 1 .. size_exprs - 1]}
 659                                 -> mapMaybe CONS (parse_arg (ExprPair left_arg right_arg))
 660         where
 661                 mkarg branch exprs
 662                         = case size exprs of
 663                                 0 -> abort "mkarg\n"
 664                                 1 -> exprs.[0]
 665                                 _ -> ExprAppInInfix exprs this_assoc this_prio branch
 666
 667         find_last exprs
 668                 = find (size exprs - 2) exprs
 669         where
 670                 find i exprs
 671                         | i < 1
 672                                 = Nothing
 673                         | otherwise
 674                                 = case exprs.[i] of
 675                                         ExprIdent s | s == d.gcd_name   -> Just i
 676                                         _                                                               -> find (dec i) exprs
 677         find_first exprs
 678                 = find 1 exprs
 679         where
 680                 find i exprs
 681                         | i >= size exprs - 1
 682                                 = Nothing
 683                         | otherwise
 684                                 = case exprs.[i] of
 685                                         ExprIdent s | s == d.gcd_name   -> Just i
 686                                         _                                                               -> find (inc i) exprs
 687
 688         is_tuple name
 689                 #! size_name = size name
 690                 = (size_name == 7 || size_name == 8)
 691                 && name.[0] == '_'
 692                 && name.[1] == 'T'
 693                 && name.[2] == 'u'
 694                 && name.[3] == 'p'
 695                 && name.[4] == 'l'
 696                 && name.[5] == 'e'
 697                 && isDigit name.[6]
 698                 && (size_name == 7 || isDigit name.[7])
 699
 700 gParse{|FIELD of d|} parse_arg (ExprField name value)
 701         | d.gfd_name == name
 702                 = mapMaybe FIELD (parse_arg value)
 703                 = Nothing
 704 gParse{|OBJECT|} parse_arg expr
 705         = mapMaybe OBJECT (parse_arg expr)
 706
 707 gParse{|[]|} parse_arg (ExprList exprs)
 708         = maybeAll (map parse_arg exprs)
 709 gParse{|[]|} parse_arg _ = Nothing
 710
 711 gParse{|{}|} parse_arg (ExprArray exprs)
 712         = mapMaybe (\xs -> {x\\x<-xs}) (maybeAll (map parse_arg exprs))
 713 gParse{|{}|} parse_arg _ = Nothing
 714
 715 gParse{|{!}|} parse_arg (ExprArray exprs)
 716         = mapMaybe (\xs -> {x\\x<-xs}) (maybeAll (map parse_arg exprs))
 717 gParse{|{!}|} parse_arg _ = Nothing
 718
 719 maybeAll []                     = Just []
 720 maybeAll [Nothing:_]    = Nothing
 721 maybeAll [Just x: mxs]
 722         = case maybeAll mxs of
 723                 Nothing -> Nothing
 724                 Just xs -> Just [x:xs]
 725
 726 //----------------------------------------------------------------------------------
 727
 728 preParseInput :: s -> Expr | ParseInput s
 729 preParseInput input
 730         # (expr, s) = preParse {ps_input=input, ps_char = Nothing, ps_tokens = [] }
 731         = expr
 732
 733 preParseString :: String -> Expr
 734 preParseString str = preParseInput {si_pos = 0, si_str = str}
 735
 736 preParseFile :: File -> Expr
 737 preParseFile file = preParseInput file
 738
 739 parseString :: String -> Maybe a | gParse{|*|} a
 740 parseString str = gParse{|*|} (preParseString str)
 741
 742 parseFile :: File -> Maybe a | gParse{|*|} a
 743 parseFile file = gParse{|*|} (preParseFile file)
 744
 745 //Start = preParseString "{rec_field = A (B1, B2) (C D), rec_field2 = (X,Y)}"
 746 //Start = preParseString "123.456e1"
 747 //Start = preParseString "([1,2,3], [4,5,6])"
 748 //Start = preParseString "{A B D,X Y Z,I J K}"
 749
 750 //----------------------------------------------------------------------------------
 751
 752 :: Tree a b = Tip a | Bin b (Tree a b) (Tree a b)
 753 :: T
 754         = :+: infixl 2 T T
 755         | :-: infixl 2 T T
 756         | :*: infixl 3 T T
 757         | :->: infixr 4 T T
 758         | U
 759
 760 :: Rec = { rec_x :: T, rec_y :: (.Tree Int Real, Real) }
 761
 762 derive gParse (,), (,,), (,,,), Tree, T, Rec
 763 derive bimap Maybe, ParseState, []
 764
 765 //Start :: Maybe T
 766 //Start = parseString "U :+: U :+: U"
 767
 768 //Start :: Maybe (Tree Int Int)
 769 //Start = parseString "Bin 1 (Tip 2) (Tip 3)"
 770
 771 //Start :: Maybe (Tree Int Int, Int)
 772 //Start = parseString "((Bin 1 (Tip (2)) (Tip 3), 1000))"
 773
 774 //Start :: Maybe Rec
 775 //Start = parseString "{ Rec | rec_x = U :+: U :+: U, rec_y = (Bin 1.1 (Tip 2) (Tip 3), 1.09) }"
 776
 777 //Start :: Maybe [Tree Int Int]
 778 //Start = parseString "[Bin 1 (Tip (2)) (Tip 3), Tip 100, Tip 200]"
 779
 780 //Start = preParseString "1.23e12"
 781
 782 /*
 783 Start :: *World -> (Maybe Rec, *World)
 784 Start w
 785         #! (ok, f, w) = sfopen "test.txt" FReadText w
 786         | not ok
 787                 = (abort "sfopen failed", w)
 788                 = (parseFile f, w)
 789 */