+++ /dev/null
-implementation module GenParse\r
-\r
-import StdGeneric, StdEnv, StdMaybe\r
-\r
-//---------------------------------------------------------------------------\r
-\r
-\r
-:: StringInput = { si_str :: !String, si_pos :: !Int} \r
-\r
-mkStringInput :: String -> StringInput \r
-mkStringInput str = {si_str = str, si_pos = 0}\r
-\r
-instance ParseInput StringInput where\r
- parseInput s=:{si_pos, si_str}\r
- #! size_str = size si_str\r
- | size_str == si_pos \r
- = (Nothing, {s & si_str = si_str})\r
- | otherwise\r
- #! ch = si_str.[si_pos]\r
- = (Just ch, {s & si_str = si_str, si_pos = inc si_pos})\r
-\r
-instance ParseInput File where \r
- parseInput file \r
- # (ok, c, file) = sfreadc file\r
- | ok\r
- = (Just c, file)\r
- = (Nothing, file)\r
- \r
-//---------------------------------------------------------------------------\r
-\r
-// lex tokens\r
-:: Token \r
- = TokenInt Int\r
- | TokenChar Char\r
- | TokenReal Real \r
- | TokenBool Bool\r
- | TokenString String\r
- | TokenIdent String\r
- | TokenOpenPar\r
- | TokenClosePar\r
- | TokenOpenCurly\r
- | TokenCloseCurly\r
- | TokenOpenList\r
- | TokenCloseList\r
- | TokenComma\r
- | TokenEnd\r
- | TokenError String\r
-\r
-instance toString Token where\r
- toString (TokenInt x) = toString x\r
- toString (TokenChar x) = toString x\r
- toString (TokenReal x) = toString x\r
- toString (TokenBool x) = toString x\r
- toString (TokenString x) = x\r
- toString (TokenIdent x) = x\r
- toString TokenOpenPar = "("\r
- toString TokenClosePar = ")"\r
- toString TokenOpenCurly = "{"\r
- toString TokenCloseCurly = "}"\r
- toString TokenOpenList = "["\r
- toString TokenCloseList = "]" \r
- toString TokenComma = ","\r
- toString TokenEnd = "<end>"\r
- toString (TokenError err) = "<error: " +++ err +++ ">"\r
-\r
-// preparsed expressions\r
-:: Expr \r
- = ExprInt Int\r
- | ExprChar Char\r
- | ExprReal Real \r
- | ExprBool Bool\r
- | ExprString String\r
- | ExprIdent String\r
- | ExprApp {Expr} \r
- | ExprTuple {Expr}\r
- | ExprField String Expr\r
- | ExprRecord (Maybe String) {Expr}\r
- | ExprList [Expr]\r
- | ExprArray [Expr]\r
- | ExprEnd Token\r
- | ExprError String\r
-\r
- // aux\r
- | ExprUnit\r
- | ExprAppInInfix {Expr} GenConsAssoc Int GenConsAssoc\r
- | ExprPair Expr Expr\r
-\r
-\r
-instance toString Expr where\r
- toString (ExprInt x) = toString x\r
- toString (ExprChar x) = toString x\r
- toString (ExprBool x) = toString x\r
- toString (ExprReal x) = toString x\r
- toString (ExprString x) = x\r
- toString (ExprIdent x) = x\r
- toString (ExprApp xs) = "(" +++ tostr [x\\x<-:xs] +++ ")"\r
- where\r
- tostr [] = ""\r
- tostr [x] = toString x\r
- tostr [x:xs] = toString x +++ " " +++ tostr xs\r
- toString (ExprTuple xs) = "(" +++ tostr [x\\x<-:xs] +++ ")"\r
- where\r
- tostr [] = ""\r
- tostr [x] = toString x\r
- tostr [x:xs] = toString x +++ ", " +++ tostr xs\r
- toString (ExprRecord name xs) = "{" +++ tostr [x\\x<-:xs] +++ "}"\r
- where\r
- tostr [] = ""\r
- tostr [x] = toString x\r
- tostr [x:xs] = toString x +++ ", " +++ tostr xs\r
- toString (ExprField name expr) = name +++ "=" +++ toString expr\r
-\r
- \r
-:: ParseState s =\r
- { ps_input :: !s // lex input\r
- , ps_char :: !Maybe Char // unget char\r
- , ps_tokens :: ![Token] // unget tokens\r
- }\r
-\r
-lexGetChar ps=:{ps_char=Nothing, ps_input}\r
- # (mc, ps_input) = parseInput ps_input\r
- = (mc, {ps & ps_input = ps_input})\r
-lexGetChar ps=:{ps_char} = (ps_char, {ps & ps_char = Nothing})\r
-\r
-lexUngetChar c ps=:{ps_char=Nothing} = {ps & ps_char = Just c}\r
-lexUngetChar c ps = abort "cannot unget\n" \r
-\r
-isSpecialChar :: !Char -> Bool\r
-isSpecialChar '~' = True\r
-isSpecialChar '@' = True\r
-isSpecialChar '#' = True\r
-isSpecialChar '$' = True\r
-isSpecialChar '%' = True\r
-isSpecialChar '^' = True\r
-isSpecialChar '?' = True\r
-isSpecialChar '!' = True\r
-isSpecialChar '+' = True\r
-isSpecialChar '-' = True\r
-isSpecialChar '*' = True\r
-isSpecialChar '<' = True\r
-isSpecialChar '>' = True\r
-isSpecialChar '\\' = True\r
-isSpecialChar '/' = True\r
-isSpecialChar '|' = True\r
-isSpecialChar '&' = True\r
-isSpecialChar '=' = True\r
-isSpecialChar ':' = True\r
-isSpecialChar '.' = True\r
-isSpecialChar c = False\r
-\r
-//---------------------------------------------------------------------------------- \r
-// lex input\r
-\r
-lexUngetToken token ps=:{ps_tokens} = {ps & ps_tokens = [token:ps_tokens]}\r
-\r
-lexGetToken ps=:{ps_tokens=[token:tokens]} = (token, {ps & ps_tokens = tokens})\r
-lexGetToken ps=:{ps_tokens=[]}\r
- = lex ps\r
-where\r
- lex s \r
- # (mc, s) = lexGetChar s\r
- = case mc of\r
- Nothing -> (TokenEnd, s)\r
- Just '\0' -> (TokenEnd, s)\r
- Just '(' -> (TokenOpenPar, s)\r
- Just ')' -> (TokenClosePar, s)\r
- Just '{' -> (TokenOpenCurly, s)\r
- Just '}' -> (TokenCloseCurly, s)\r
- Just '[' -> (TokenOpenList, s)\r
- Just ']' -> (TokenCloseList, s)\r
- Just ',' -> (TokenComma, s)\r
- Just '\'' -> lex_char 0 [] s\r
- Just '"' -> lex_string 0 [] s\r
- Just '_' -> lex_ident 1 ['_'] s\r
- Just '`' -> lex_ident 1 ['`'] s\r
- Just '+'\r
- # (mc, s) = lexGetChar s\r
- -> case mc of\r
- Nothing -> (TokenIdent "+", s)\r
- Just c\r
- | isDigit c\r
- -> lex_number +1 (lexUngetChar c s)\r
- | otherwise\r
- -> lex_ident 1 ['+'] (lexUngetChar c s)\r
- Just '-'\r
- # (mc, s) = lexGetChar s\r
- -> case mc of\r
- Nothing -> (TokenIdent "-", s)\r
- Just c\r
- | isDigit c\r
- -> lex_number -1 (lexUngetChar c s)\r
- | otherwise\r
- -> lex_funny_ident 1 ['-'] (lexUngetChar c s) // PK\r
- // -> lex_ident 1 ['-'] (lexUngetChar c s)\r
- Just c\r
- | isSpace c\r
- -> lex s \r
- | isDigit c\r
- -> lex_number +1 (lexUngetChar c s)\r
- | isAlpha c\r
- -> lex_ident 1 [c] s\r
- | isSpecialChar c\r
- -> lex_funny_ident 1 [c] s\r
- | otherwise\r
- -> (TokenError ("Unknown character " +++ toString c), s)\r
-\r
- lex_digits s \r
- = lex_digits_acc 0 [] s \r
- lex_digits_acc num acc s\r
- # (mc, s) = lexGetChar s\r
- = case mc of\r
- Nothing \r
- -> (num, acc, s)\r
- Just c\r
- | isDigit c\r
- -> lex_digits_acc (inc num) [digitToInt c:acc] s\r
- | otherwise \r
- -> (num, acc, lexUngetChar c s) \r
-\r
- digits_to_int :: [Int] -> Int\r
- digits_to_int [] = 0\r
- digits_to_int [digit:digits] = digit + 10 * digits_to_int digits \r
-\r
- digits_to_real :: [Int] -> Real \r
- digits_to_real [] = 0.0\r
- digits_to_real [digit:digits] = toReal digit + 10.0 * digits_to_real digits\r
-\r
- lex_number sign s\r
- #! (num_digits, digits, s) = lex_digits s\r
- #! (mc, s) = lexGetChar s\r
- = case mc of \r
- Nothing -> (TokenInt (sign * digits_to_int digits), s)\r
- Just '.'\r
- -> lex_real_with_fraction (toReal sign) (digits_to_real digits) s\r
- Just 'E'\r
- #! real = toReal sign * digits_to_real digits \r
- -> lex_real_with_exp real s\r
- Just 'e'\r
- #! real = toReal sign * digits_to_real digits \r
- -> lex_real_with_exp real s\r
- Just c \r
- -> (TokenInt (sign * digits_to_int digits), lexUngetChar c s) \r
-\r
- lex_real_with_fraction sign real s\r
- #! (num_digits, digits, s) = lex_digits s\r
- #! fraction = digits_to_real digits / 10.0^ toReal num_digits \r
- #! real = sign * (real + fraction) \r
- #! (mc, s) = lexGetChar s\r
- = case mc of \r
- Nothing -> (TokenReal real, s)\r
- Just 'E'\r
- -> lex_real_with_exp real s\r
- Just 'e'\r
- -> lex_real_with_exp real s\r
- Just c \r
- -> (TokenReal real, lexUngetChar c s) \r
-\r
- lex_real_with_exp real s\r
- # (mc, s) = lexGetChar s\r
- = case mc of\r
- Nothing -> (TokenReal real, s)\r
- Just '+' \r
- #! (num_digits, digits, s) = lex_digits s\r
- -> (TokenReal (real * 10.0 ^ digits_to_real digits), s) \r
- Just '-' \r
- #! (num_digits, digits, s) = lex_digits s\r
- -> (TokenReal (real * 10.0 ^ (-1.0 * digits_to_real digits)), s) \r
- Just c \r
- | isDigit c\r
- #! (num_digits, digits, s) = lex_digits (lexUngetChar c s)\r
- -> (TokenReal (real * 10.0 ^ digits_to_real digits), s) \r
- | otherwise \r
- -> (TokenError "error in real constant", s)\r
- \r
- lex_ident num_chars acc_chars s\r
- # (mc, s) = lexGetChar s\r
- = case mc of\r
- Nothing -> (mktoken num_chars acc_chars, s)\r
- Just '_' -> lex_ident (inc num_chars) ['_':acc_chars] s\r
- Just '`' -> lex_ident (inc num_chars) ['`':acc_chars] s\r
- Just c \r
- | isAlphanum c\r
- -> lex_ident (inc num_chars) [c:acc_chars] s\r
- | otherwise \r
- -> (mktoken num_chars acc_chars, lexUngetChar c s) \r
- where\r
- mktoken num_chars acc_chars\r
- = case mk_str num_chars acc_chars of\r
- "True" -> TokenBool True\r
- "False" -> TokenBool False\r
- str -> TokenIdent str \r
-\r
- lex_funny_ident num_chars acc_chars s\r
- # (mc, s) = lexGetChar s\r
- = case mc of\r
- Nothing -> (TokenIdent (mk_str num_chars acc_chars), s)\r
- Just c\r
- | isSpecialChar c\r
- -> lex_funny_ident (inc num_chars) [c:acc_chars] s\r
- | otherwise \r
- -> (TokenIdent (mk_str num_chars acc_chars), lexUngetChar c s) \r
-\r
- lex_string num_chars acc_chars s\r
- # (mc, s) = lexGetChar s\r
- = case mc of\r
- Nothing -> (TokenError "error in string constant", s)\r
- Just '"' -> (TokenString (mk_str num_chars acc_chars), s)\r
- Just '\\' \r
- #! (mc, s) = lex_special_char s\r
- -> case mc of\r
- Nothing -> (TokenError "error in string constant", s)\r
- Just c -> lex_string (inc num_chars) [c:acc_chars] s\r
- Just c -> lex_string (inc num_chars) [c:acc_chars] s\r
-\r
-\r
- lex_char num_chars acc_chars s\r
- # (mc, s) = lexGetChar s\r
- = case mc of\r
- Nothing -> (TokenError "error in char constant", s)\r
- Just '\'' \r
- | num_chars == 1\r
- -> (TokenChar (hd acc_chars), s)\r
- | num_chars == 0\r
- -> (TokenError "char constant contains no characters ", s)\r
- | otherwise \r
- -> (TokenError "char constant contains more than one character", s)\r
- Just '\\' \r
- #! (mc, s) = lex_special_char s\r
- -> case mc of\r
- Nothing -> (TokenError "error in char constant", s)\r
- Just c -> lex_char (inc num_chars) [c:acc_chars] s\r
- Just c -> lex_char (inc num_chars) [c:acc_chars] s\r
-\r
- lex_special_char s \r
- #! (mc, s) = lexGetChar s\r
- = case mc of\r
- Just 'n' -> (Just '\n', s)\r
- Just 'r' -> (Just '\r', s)\r
- Just 'f' -> (Just '\f', s)\r
- Just 'b' -> (Just '\b', s)\r
- Just 't' -> (Just '\t', s)\r
- Just '\\' -> (Just '\\', s)\r
- Just '\'' -> (Just '\'', s)\r
- Just '\"' -> (Just '\"', s)\r
- Just '\0' -> (Just '\0', s)\r
- //Just '\x' -> abort "lex: hex char not implemented\n"\r
- //Just '\0' -> abort "lex: oct char not implemented\n"\r
- _ -> (mc, s)\r
-\r
- mk_str num_chars acc_chars\r
- # str = createArray num_chars ' '\r
- = fill (dec num_chars) acc_chars str\r
- where \r
- fill i [] str = str\r
- fill i [x:xs] str = fill (dec i) xs {str & [i] = x}\r
- \r
-\r
-//---------------------------------------------------------------------------------- \r
-// preparse input\r
-\r
-\r
-:: ParseEnv = PETop | PETuple | PEPar | PERecord | PEList\r
-\r
-preParse :: (ParseState s) -> (Expr, ParseState s) | ParseInput s\r
-preParse s \r
- = parse_expr PETop s\r
-where\r
- parse_expr env s\r
- = parse_app env [] s\r
- \r
- parse_app env exprs s\r
- #! (token, s) = lexGetToken s\r
- = parse token env exprs s\r
- where\r
- parse TokenComma PETuple exprs s = (mkexpr exprs, lexUngetToken TokenComma s)\r
- parse TokenComma PERecord exprs s = (mkexpr exprs, lexUngetToken TokenComma s)\r
- parse TokenComma PEList exprs s = (mkexpr exprs, lexUngetToken TokenComma s)\r
- parse TokenComma PETop exprs s = (ExprError "end of input expected instead of ,", s)\r
- parse TokenComma PEPar exprs s = (ExprError ") expected instead of ,", s)\r
- parse TokenComma env exprs s = abort "unknown env\n"\r
-\r
- parse TokenClosePar PETuple exprs s = (mkexpr exprs, lexUngetToken TokenClosePar s)\r
- parse TokenClosePar PERecord exprs s = (ExprError "} expected instead of )", s)\r
- parse TokenClosePar PEList exprs s = (ExprError "] expected instead of )", s)\r
- parse TokenClosePar PETop exprs s = (ExprError "end of input expected instead of )", s)\r
- parse TokenClosePar PEPar exprs s = (mkexpr exprs, lexUngetToken TokenClosePar s)\r
- parse TokenClosePar env exprs s = abort "unknown env\n"\r
-\r
- parse TokenCloseCurly PETuple exprs s = (ExprError ") expected instead of }", s)\r
- parse TokenCloseCurly PEList exprs s = (ExprError "] expected instead of }", s)\r
- parse TokenCloseCurly PERecord exprs s = (mkexpr exprs, lexUngetToken TokenCloseCurly s)\r
- parse TokenCloseCurly PETop exprs s = (ExprError "end of input expected instead of )", s)\r
- parse TokenCloseCurly PEPar exprs s = (mkexpr exprs, lexUngetToken TokenCloseCurly s)\r
- parse TokenCloseCurly env exprs s = abort "unknown env\n"\r
-\r
- parse TokenCloseList PETuple exprs s = (ExprError ") expected instead of ]", s)\r
- parse TokenCloseList PERecord exprs s = (ExprError "} expected instead of ]", s)\r
- parse TokenCloseList PEList exprs s = (mkexpr exprs, lexUngetToken TokenCloseList s)\r
- parse TokenCloseList PETop exprs s = (ExprError "end of input expected instead of )", s)\r
- parse TokenCloseList PEPar exprs s = (mkexpr exprs, lexUngetToken TokenCloseList s)\r
- parse TokenCloseList env exprs s = abort "unknown env\n"\r
-\r
- parse TokenEnd PETuple exprs s = (ExprError ") or, expected instead of end of input", s)\r
- parse TokenEnd PERecord exprs s = (ExprError "} or, expected instead of end of input", s)\r
- parse TokenEnd PEList exprs s = (ExprError "] or, expected instead of end of input", s)\r
- parse TokenEnd PETop exprs s = (mkexpr exprs, lexUngetToken TokenEnd s)\r
- parse TokenEnd PEPar exprs s = (ExprError ") expected instead of end of input",s)\r
- parse TokenEnd env exprs s = abort "unknown env\n"\r
- \r
- parse (TokenInt x) env exprs s = parse_app env [ExprInt x:exprs] s\r
- parse (TokenBool x) env exprs s = parse_app env [ExprBool x:exprs] s\r
- parse (TokenReal x) env exprs s = parse_app env [ExprReal x:exprs] s\r
- parse (TokenChar x) env exprs s = parse_app env [ExprChar x:exprs] s\r
- parse (TokenString x) env exprs s = parse_app env [ExprString x:exprs] s\r
- parse (TokenIdent x) env exprs s = parse_app env [ExprIdent x:exprs] s\r
- parse TokenOpenPar env exprs s \r
- # (expr, s) = parse_par_expr s\r
- = case expr of\r
- ExprError err -> (ExprError err, s)\r
- _ -> parse_app env [expr:exprs] s\r
- parse TokenOpenCurly env exprs s\r
- # (expr, s) = parse_record_or_array s\r
- = case expr of\r
- ExprError err -> (ExprError err, s)\r
- _ -> parse_app env [expr:exprs] s\r
- parse TokenOpenList env exprs s \r
- # (expr, s) = parse_list s\r
- = case expr of\r
- ExprError err -> (ExprError err, s)\r
- _ -> parse_app env [expr:exprs] s\r
- parse (TokenError err) env exprs s \r
- = (ExprError ("lex error in parse_app: " +++ err), s) \r
- \r
- parse token env exprs s \r
- = abort ("parse app - unknown token " +++ toString token)\r
- \r
- \r
- mkexpr [] = ExprError "expression expected"\r
- mkexpr [expr] = expr\r
- mkexpr exprs = ExprApp {e\\e <- reverse exprs}\r
-\r
- parse_par_expr s\r
- #! (expr, s) = parse_expr PETuple s\r
- = case expr of\r
- ExprError err -> (ExprError err, s)\r
- _\r
- #! (token, s) = lexGetToken s\r
- -> case token of\r
- TokenClosePar -> (expr, s)\r
- TokenComma -> parse_tuple [expr] (lexUngetToken token s)\r
- _ -> (ExprError (", or ) expected, found " +++ toString token), s)\r
- \r
- parse_tuple exprs s \r
- #! (token, s) = lexGetToken s\r
- = case token of\r
- TokenComma \r
- #! (expr, s) = parse_expr PETuple s\r
- -> case expr of\r
- ExprError err -> (ExprError err, s)\r
- _ -> parse_tuple [expr:exprs] s\r
- TokenClosePar \r
- -> (ExprTuple {e\\e<-reverse exprs}, s)\r
- _ \r
- -> (ExprError "parse tuple: , or ) expected", s) \r
-\r
- parse_list s\r
- #! (token, s) = lexGetToken s\r
- = case token of\r
- TokenCloseList \r
- -> (ExprList [], s)\r
- _ \r
- #! (expr, s) = parse_expr PEList (lexUngetToken token s)\r
- -> case expr of\r
- ExprError err -> (ExprError (err +++ " ; parse list"), s)\r
- _ -> parse_rest [expr] s\r
- where\r
- parse_rest exprs s \r
- #! (token, s) = lexGetToken s\r
- = case token of\r
- TokenComma \r
- #! (expr, s) = parse_expr PEList s\r
- -> case expr of\r
- ExprError err -> (ExprError err, s)\r
- _ -> parse_rest [expr:exprs] s\r
- TokenCloseList \r
- -> (ExprList (reverse exprs), s)\r
- _ \r
- -> (ExprError "parse list: , or ] expected", s) \r
-\r
- \r
- parse_record_or_array s \r
- #! (token, s) = lexGetToken s\r
- = case token of\r
- TokenCloseCurly \r
- -> (ExprArray [], s)\r
- TokenIdent name\r
- #! (token, s) = lexGetToken s\r
- -> case token of\r
- TokenIdent "="\r
- #! (expr, s) = parse_expr PERecord s\r
- -> parse_record Nothing [ExprField name expr] s\r
- TokenIdent "|"\r
- -> parse_record (Just ("_" +++ name)) [] (lexUngetToken TokenComma s)\r
- _\r
- #! (expr, s) = parse_expr PERecord \r
- (lexUngetToken (TokenIdent name) (lexUngetToken token s))\r
- -> parse_array [expr] s\r
- _ \r
- #! (expr, s) = parse_expr PERecord (lexUngetToken token s)\r
- -> parse_array [expr] s\r
- where\r
- parse_record rec_name fields s\r
- #! (token, s) = lexGetToken s\r
- = case token of\r
- TokenCloseCurly \r
- -> (ExprRecord rec_name {e\\e<- reverse fields}, s)\r
- TokenComma\r
- #! (token, s) = lexGetToken s\r
- -> case token of\r
- TokenIdent field_name\r
- #! (token, s) = lexGetToken s\r
- -> case token of\r
- TokenIdent "=" \r
- #! (expr, s) = parse_expr PERecord s\r
- -> parse_record rec_name [ExprField field_name expr:fields] s\r
- _ -> (ExprError ("parse record failed on token " +++ toString token), s) \r
-\r
- parse_array exprs s\r
- #! (token, s) = lexGetToken s\r
- = case token of\r
- TokenCloseCurly \r
- -> (ExprArray (reverse exprs), s)\r
- TokenComma\r
- #! (expr, s) = parse_expr PERecord s\r
- -> parse_array [expr:exprs] s\r
- _ -> (ExprError ("parse array failed on token " +++ toString token), s) \r
-\r
-\r
-//---------------------------------------------------------------------------------- \r
-\r
-generic gParse a :: Expr -> Maybe a\r
-\r
-gParse{|Int|} (ExprInt x) = Just x \r
-gParse{|Int|} _ = Nothing\r
-\r
-gParse{|Char|} (ExprChar x) = Just x \r
-gParse{|Char|} _ = Nothing\r
-\r
-gParse{|Bool|} (ExprBool x) = Just x \r
-gParse{|Bool|} _ = Nothing\r
-\r
-gParse{|Real|} (ExprReal x) = Just x \r
-gParse{|Real|} _ = Nothing\r
-\r
-gParse{|String|} (ExprString x) = Just x\r
-gParse{|String|} _ = Nothing \r
-\r
-gParse{|UNIT|} ExprUnit = Just UNIT\r
-gParse{|UNIT|} _ = Nothing \r
-\r
-gParse{|PAIR|} fx fy (ExprPair ex ey) \r
- = case fx ex of\r
- Just x -> case fy ey of\r
- Just y -> Just (PAIR x y)\r
- Nothing -> Nothing\r
- Nothing -> Nothing\r
-gParse{|PAIR|} fx fy _ = Nothing\r
-\r
-gParse{|EITHER|} fl fr expr \r
- = case fl expr of\r
- Nothing -> case fr expr of\r
- Nothing -> Nothing\r
- Just x -> Just (RIGHT x)\r
- Just x -> Just (LEFT x) \r
- \r
-gParse{|CONS of d|} parse_arg expr\r
- | d.gcd_arity == 0 \r
- = parse_nullary expr\r
- | isEmpty d.gcd_fields\r
- | is_tuple d.gcd_name\r
- = parse_tuple expr \r
- | otherwise\r
- = case d.gcd_prio of\r
- GenConsNoPrio \r
- -> parse_nonfix expr\r
- GenConsPrio assoc prio \r
- -> parse_infix assoc prio expr \r
- | otherwise\r
- = parse_record expr \r
-where\r
- mkprod [] = abort "mkprod\n"\r
- mkprod [expr] = expr\r
- mkprod exprs \r
- # (xs, ys) = splitAt (length exprs / 2) exprs\r
- = ExprPair (mkprod xs) (mkprod ys) \r
- \r
- parse_nullary (ExprIdent name)\r
- | name == d.gcd_name\r
- = mapMaybe CONS (parse_arg ExprUnit)\r
- parse_nullary _\r
- = Nothing\r
-\r
- parse_nonfix (ExprApp exprs)\r
- = parse_nonfix1 exprs\r
- parse_nonfix (ExprAppInInfix exprs _ _ _)\r
- = parse_nonfix1 exprs\r
- parse_nonfix _ \r
- = Nothing\r
-\r
- parse_nonfix1 exprs\r
- #! size_exprs = size exprs\r
- | size_exprs == d.gcd_arity + 1 && is_ident d.gcd_name exprs.[0]\r
- #! arg_exprs = [exprs.[i] \\ i <- [1 .. size_exprs - 1]]\r
- = mapMaybe CONS (parse_arg (mkprod arg_exprs))\r
- | otherwise\r
- = Nothing\r
- \r
- is_ident wanted_name (ExprIdent name) = name == wanted_name\r
- is_ident _ _ = False \r
-\r
- parse_tuple (ExprTuple exprs) \r
- = mapMaybe CONS (parse_arg (mkprod [e\\e<-:exprs]))\r
- parse_tuple expr = Nothing\r
- \r
- parse_record (ExprRecord rec_name exprs) \r
- | check_name rec_name d.gcd_name\r
- = mapMaybe CONS (parse_arg (mkprod [e\\e<-:exprs]))\r
- = Nothing\r
- where\r
- check_name Nothing cons_name = True\r
- check_name (Just rec_name) cons_name = rec_name == cons_name\r
- parse_record expr = Nothing\r
-\r
- parse_infix this_assoc this_prio (ExprApp exprs)\r
- = parse_infix1 this_assoc this_prio exprs\r
- parse_infix this_assoc this_prio (ExprAppInInfix exprs outer_assoc outer_prio branch)\r
- | this_prio > outer_prio\r
- = parse_infix1 this_assoc this_prio exprs\r
- | this_prio < outer_prio\r
- = Nothing\r
- | otherwise\r
- = case (this_assoc, outer_assoc, branch) of\r
- (GenConsAssocLeft, GenConsAssocLeft, GenConsAssocLeft)\r
- -> parse_infix1 this_assoc this_prio exprs\r
- (GenConsAssocRight, GenConsAssocRight, GenConsAssocRight)\r
- -> parse_infix1 this_assoc this_prio exprs\r
- _ -> Nothing\r
- parse_infix this_assoc this_prio expr\r
- = Nothing\r
- \r
- parse_infix1 this_assoc this_prio exprs\r
- #! size_exprs = size exprs\r
- | size_exprs < 3 = Nothing\r
- = case (case this_assoc of GenConsAssocLeft -> find_last; _ -> find_first) exprs of\r
- Nothing -> Nothing\r
- Just op_index\r
- #! left_arg = mkarg GenConsAssocLeft {exprs.[i] \\ i <- [0 .. op_index - 1]}\r
- #! right_arg = mkarg GenConsAssocRight {exprs.[i] \\ i <- [op_index + 1 .. size_exprs - 1]}\r
- -> mapMaybe CONS (parse_arg (ExprPair left_arg right_arg))\r
- where\r
- mkarg branch exprs\r
- = case size exprs of\r
- 0 -> abort "mkarg\n"\r
- 1 -> exprs.[0]\r
- _ -> ExprAppInInfix exprs this_assoc this_prio branch\r
- \r
- find_last exprs \r
- = find (size exprs - 2) exprs\r
- where\r
- find i exprs\r
- | i < 1\r
- = Nothing\r
- | otherwise \r
- = case exprs.[i] of\r
- ExprIdent s | s == d.gcd_name -> Just i \r
- _ -> find (dec i) exprs \r
- find_first exprs\r
- = find 1 exprs\r
- where\r
- find i exprs\r
- | i >= size exprs - 1\r
- = Nothing\r
- | otherwise \r
- = case exprs.[i] of\r
- ExprIdent s | s == d.gcd_name -> Just i \r
- _ -> find (inc i) exprs \r
-\r
- is_tuple name \r
- #! size_name = size name\r
- = (size_name == 7 || size_name == 8)\r
- && name.[0] == '_'\r
- && name.[1] == 'T'\r
- && name.[2] == 'u'\r
- && name.[3] == 'p'\r
- && name.[4] == 'l'\r
- && name.[5] == 'e'\r
- && isDigit name.[6]\r
- && (size_name == 7 || isDigit name.[7])\r
-\r
-gParse{|FIELD of d|} parse_arg (ExprField name value) \r
- | d.gfd_name == name\r
- = mapMaybe FIELD (parse_arg value)\r
- = Nothing\r
-gParse{|OBJECT|} parse_arg expr\r
- = mapMaybe OBJECT (parse_arg expr)\r
-\r
-gParse{|[]|} parse_arg (ExprList exprs) \r
- = maybeAll (map parse_arg exprs)\r
-gParse{|[]|} parse_arg _ = Nothing\r
-\r
-gParse{|{}|} parse_arg (ExprArray exprs)\r
- = mapMaybe (\xs -> {x\\x<-xs}) (maybeAll (map parse_arg exprs)) \r
-gParse{|{}|} parse_arg _ = Nothing\r
- \r
-gParse{|{!}|} parse_arg (ExprArray exprs)\r
- = mapMaybe (\xs -> {x\\x<-xs}) (maybeAll (map parse_arg exprs))\r
-gParse{|{!}|} parse_arg _ = Nothing\r
-\r
-maybeAll [] = Just []\r
-maybeAll [Nothing:_] = Nothing\r
-maybeAll [Just x: mxs] \r
- = case maybeAll mxs of\r
- Nothing -> Nothing\r
- Just xs -> Just [x:xs] \r
-\r
-//---------------------------------------------------------------------------------- \r
-\r
-preParseInput :: s -> Expr | ParseInput s\r
-preParseInput input \r
- # (expr, s) = preParse {ps_input=input, ps_char = Nothing, ps_tokens = [] }\r
- = expr\r
- \r
-preParseString :: String -> Expr\r
-preParseString str = preParseInput {si_pos = 0, si_str = str}\r
-\r
-preParseFile :: File -> Expr \r
-preParseFile file = preParseInput file\r
-\r
-parseString :: String -> Maybe a | gParse{|*|} a\r
-parseString str = gParse{|*|} (preParseString str)\r
-\r
-parseFile :: File -> Maybe a | gParse{|*|} a\r
-parseFile file = gParse{|*|} (preParseFile file)\r
-\r
-//Start = preParseString "{rec_field = A (B1, B2) (C D), rec_field2 = (X,Y)}"\r
-//Start = preParseString "123.456e1"\r
-//Start = preParseString "([1,2,3], [4,5,6])"\r
-//Start = preParseString "{A B D,X Y Z,I J K}"\r
-\r
-//---------------------------------------------------------------------------------- \r
-\r
-:: Tree a b = Tip a | Bin b (Tree a b) (Tree a b)\r
-:: T\r
- = :+: infixl 2 T T\r
- | :-: infixl 2 T T\r
- | :*: infixl 3 T T\r
- | :->: infixr 4 T T\r
- | U\r
-\r
-:: Rec = { rec_x :: T, rec_y :: (.Tree Int Real, Real) }\r
-\r
-derive gParse (,), (,,), (,,,), Tree, T, Rec\r
-derive bimap Maybe, ParseState, []\r
-\r
-//Start :: Maybe T\r
-//Start = parseString "U :+: U :+: U"\r
-\r
-//Start :: Maybe (Tree Int Int)\r
-//Start = parseString "Bin 1 (Tip 2) (Tip 3)"\r
-\r
-//Start :: Maybe (Tree Int Int, Int)\r
-//Start = parseString "((Bin 1 (Tip (2)) (Tip 3), 1000))"\r
-\r
-//Start :: Maybe Rec\r
-//Start = parseString "{ Rec | rec_x = U :+: U :+: U, rec_y = (Bin 1.1 (Tip 2) (Tip 3), 1.09) }"\r
-\r
-//Start :: Maybe [Tree Int Int]\r
-//Start = parseString "[Bin 1 (Tip (2)) (Tip 3), Tip 100, Tip 200]" \r
-\r
-//Start = preParseString "1.23e12"\r
-\r
-/*\r
-Start :: *World -> (Maybe Rec, *World)\r
-Start w \r
- #! (ok, f, w) = sfopen "test.txt" FReadText w\r
- | not ok\r
- = (abort "sfopen failed", w)\r
- = (parseFile f, w) \r
-*/
\ No newline at end of file
repositories / tt2015.git / blobdiff