--- /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