diff --git a/TODO.md b/TODO.md index e6e40ba..3ff976e 100644 --- a/TODO.md +++ b/TODO.md @@ -1,6 +1,9 @@ ## TODO +- [ ] Allow unicode operators/names + - refactored parser to prep for this +- [ ] handle if_then_else_ - [x] Remember operators from imports - [ ] Default cases for non-primitives (currently gets expanded to all constructors) - [x] Case for primitives diff --git a/src/Lib/Parser.idr b/src/Lib/Parser.idr index 2f28ea1..1a27f42 100644 --- a/src/Lib/Parser.idr +++ b/src/Lib/Parser.idr @@ -74,6 +74,10 @@ export term : (Parser Raw) withPos : Parser a -> Parser (FC, a) withPos pa = (,) <$> getPos <*> pa +lookup : String -> List OpDef -> Maybe OpDef +lookup _ [] = Nothing +lookup name (op :: ops) = if op.name == name then Just op else lookup name ops + -- the inside of Raw atom : Parser Raw atom = RU <$> getPos <* keyword "U" @@ -91,40 +95,36 @@ pArg = do (Explicit,fc,) <$> atom <|> (Implicit,fc,) <$> braces typeExpr <|> (Auto,fc,) <$> dbraces typeExpr + <|> (Explicit,fc,) . RVar fc <$> token Oper -parseApp : Parser Raw -parseApp = do - fc <- getPos - hd <- atom - rest <- many pArg - pure $ foldl (\a, (icit,fc,b) => RApp fc a b icit) hd rest +AppSpine = List (Icit,FC,Raw) -lookup : String -> List OpDef -> Maybe OpDef -lookup _ [] = Nothing -lookup name (op :: ops) = if op.name == name then Just op else lookup name ops +pratt : List OpDef -> Int -> Raw -> AppSpine -> Parser (Raw, AppSpine) +pratt ops prec left [] = pure (left, []) +pratt ops prec left rest@((Explicit, fc, tm@(RVar x nm)) :: xs) = + let op' = ("_" ++ nm ++ "_") in + case lookup op' ops of + Nothing => pratt ops prec (RApp fc left tm Explicit) xs + Just (MkOp name p fix) => if p < prec + then pure (left, rest) + else + let pr = case fix of InfixR => p; _ => p + 1 in + case xs of + ((_, _, right) :: rest) => do + (right, rest) <- pratt ops pr right rest + pratt ops prec (RApp fc(RApp fc (RVar fc op') left Explicit) right Explicit) rest + _ => fail "trailing operator" +pratt ops prec left ((icit, fc, tm) :: xs) = pratt ops prec (RApp fc left tm icit) xs parseOp : Parser Raw -parseOp = parseApp >>= go 0 - where - go : Int -> Raw -> Parser Raw - go prec left = - try (do - fc <- getPos - op <- token Oper - ops <- getOps - let op' = "_" ++ op ++ "_" - let Just (MkOp _ p fix) = lookup op' ops - -- this is eaten, but we need `->` and `:=` to not be an operator to have fatal here - | Nothing => case op of - -- Location is poor on these because we pull off of the remaining token list... - "->" => fail "no infix decl for \{op}" - ":=" => fail "no infix decl for \{op}" - op => fatal "no infix decl for \{op}" - if p >= prec then pure () else fail "" - let pr = case fix of InfixR => p; _ => p + 1 - right <- go pr !(parseApp) - go prec (RApp fc (RApp fc (RVar fc op') left Explicit) right Explicit)) - <|> pure left +parseOp = do + fc <- getPos + ops <- getOps + hd <- atom + rest <- many pArg + (res, []) <- pratt ops 0 hd rest + | _ => fail "extra stuff" + pure res export letExpr : Parser Raw diff --git a/src/Lib/Syntax.idr b/src/Lib/Syntax.idr index e196c10..df95d2c 100644 --- a/src/Lib/Syntax.idr +++ b/src/Lib/Syntax.idr @@ -60,19 +60,19 @@ public export data RCaseAlt = MkAlt Raw Raw data Raw : Type where - RVar : FC -> (nm : Name) -> Raw - RLam : FC -> (nm : String) -> (icit : Icit) -> (ty : Raw) -> Raw - RApp : FC -> (t : Raw) -> (u : Raw) -> (icit : Icit) -> Raw - RU : FC -> Raw - RPi : FC -> (nm : Maybe Name) -> (icit : Icit) -> (ty : Raw) -> (sc : Raw) -> Raw - RLet : FC -> (nm : Name) -> (ty : Raw) -> (v : Raw) -> (sc : Raw) -> Raw - RAnn : FC -> (tm : Raw) -> (ty : Raw) -> Raw - RLit : FC -> Literal -> Raw - RCase : FC -> (scrut : Raw) -> (alts : List RCaseAlt) -> Raw - RImplicit : FC -> Raw - RHole : FC -> Raw + RVar : (fc : FC) -> (nm : Name) -> Raw + RLam : (fc : FC) -> (nm : String) -> (icit : Icit) -> (ty : Raw) -> Raw + RApp : (fc : FC) -> (t : Raw) -> (u : Raw) -> (icit : Icit) -> Raw + RU : (fc : FC) -> Raw + RPi : (fc : FC) -> (nm : Maybe Name) -> (icit : Icit) -> (ty : Raw) -> (sc : Raw) -> Raw + RLet : (fc : FC) -> (nm : Name) -> (ty : Raw) -> (v : Raw) -> (sc : Raw) -> Raw + RAnn : (fc : FC) -> (tm : Raw) -> (ty : Raw) -> Raw + RLit : (fc : FC) -> Literal -> Raw + RCase : (fc : FC) -> (scrut : Raw) -> (alts : List RCaseAlt) -> Raw + RImplicit : (fc : FC) -> Raw + RHole : (fc : FC) -> Raw -- not used, but intended to allow error recovery - RParseError : FC -> String -> Raw + RParseError : (fc : FC) -> String -> Raw %name Raw tm diff --git a/src/Lib/Tokenizer.idr b/src/Lib/Tokenizer.idr index e7ff77f..18654df 100644 --- a/src/Lib/Tokenizer.idr +++ b/src/Lib/Tokenizer.idr @@ -48,6 +48,8 @@ unquote str = case unpack str of go ('\\' :: (x :: xs)) = x :: go xs go (x :: xs) = x :: go xs +opMiddle = pred (\c => not (isSpace c || c == '_')) + rawTokens : Tokenizer (Token Kind) rawTokens = match (lower <+> many identMore) checkKW @@ -55,7 +57,7 @@ rawTokens <|> match (some digit) (Tok Number) <|> match (is '#' <+> many alpha) (Tok Pragma) <|> match charLit (Tok Character) - <|> match (exact "_" <+> (some opChar <|> exact ",") <+> exact "_") (Tok MixFix) + <|> match (exact "_" <+> (some opMiddle) <+> exact "_") (Tok MixFix) <|> match (quo <+> manyUntil quo (esc any <|> any) <+> quo) (Tok StringKind . unquote) <|> match (lineComment (exact "--")) (Tok Space) <|> match (blockComment (exact "/-") (exact "-/")) (Tok Space)