move idris version to orig and newt version to src.

Development is being done on the newt version now.

src/Lib/Parser.newt

@@ -0,0 +1,669 @@
+module Lib.Parser
+
+-- NOW Still working on this.
+
+import Prelude
+import Lib.Common
+import Data.SortedMap
+import Data.String
+import Lib.Parser.Impl
+import Lib.Syntax
+import Lib.Token
+import Lib.Types
+
+lazy : ∀ a. (Unit → Parser a) → Parser a
+lazy pa = pa MkUnit
+
+ident : Parser String
+ident = token Ident <|> token MixFix
+
+uident : Parser String
+uident = token UIdent
+
+parenWrap : ∀ a. Parser a -> Parser a
+parenWrap pa = do
+  symbol "("
+  t <- pa
+  symbol ")"
+  pure t
+
+braces : ∀ a. Parser a -> Parser a
+braces pa = do
+  symbol "{"
+  t <- pa
+  symbol "}"
+  pure t
+
+dbraces : ∀ a. Parser a -> Parser a
+dbraces pa = do
+  symbol "{{"
+  t <- pa
+  symbol "}}"
+  pure t
+
+
+optional : ∀ a. Parser a -> Parser (Maybe a)
+optional pa = Just <$> pa <|> pure Nothing
+
+stringLit : Parser Raw
+stringLit = do
+  fc <- getPos
+  t <- token StringKind
+  pure $ RLit fc (LString t)
+
+
+-- typeExpr is term with arrows.
+typeExpr : Parser Raw
+term : (Parser Raw)
+
+interp : Parser Raw
+interp = do
+  token StartInterp
+  tm <- term
+  token EndInterp
+  pure tm
+
+
+interpString : Parser Raw
+interpString = do
+  -- fc <- getPos
+  ignore $ token StartQuote
+  part <- term
+  parts <- many (stringLit <|> interp)
+  ignore $ token EndQuote
+  pure $ foldl append part parts
+  where
+    append : Raw -> Raw -> Raw
+    append t u =
+      let fc = getFC t in
+      (RApp (getFC t) (RApp fc (RVar fc "_++_") t Explicit) u Explicit)
+
+intLit : Parser Raw
+intLit = do
+  fc <- getPos
+  t <- token Number
+  pure $ RLit fc (LInt (stringToInt t))
+
+
+charLit : Parser Raw
+charLit = do
+  fc <- getPos
+  v <- token Character
+  pure $ RLit fc (LChar $ strIndex v 0)
+
+lit : Parser Raw
+lit = intLit <|> interpString <|> stringLit <|> charLit
+
+
+
+-- helpful when we've got some / many and need FC for each
+addPos : ∀ a. Parser a -> Parser (FC × a)
+addPos pa = _,_ <$> getPos <*> pa
+
+asAtom : Parser Raw
+asAtom = do
+  fc <- getPos
+  nm <- ident
+  asPat <- optional $ keyword "@" *> parenWrap typeExpr
+  case asPat of
+    Just exp => pure $ RAs fc nm exp
+    Nothing  => pure $ RVar fc nm
+
+-- the inside of Raw
+atom : Parser Raw
+atom = do
+  pure MkUnit
+  RU <$> getPos <* keyword "U"
+    -- <|> RVar <$> getPos <*> ident
+    <|> asAtom
+    <|> RVar <$> getPos <*> uident
+    <|> RVar <$> getPos <*> token Projection
+    <|> lit
+    <|> RImplicit <$> getPos <* keyword "_"
+    <|> RHole <$> getPos <* keyword "?"
+    <|> parenWrap typeExpr
+
+-- Argument to a Spine
+pArg : Parser (Icit × FC × Raw)
+pArg = do
+  fc <- getPos
+  (\x => Explicit, fc, x) <$> atom
+    <|> (\x => Implicit, fc, x) <$> braces typeExpr
+    <|> (\x => Auto, fc, x) <$> dbraces typeExpr
+
+AppSpine : U
+AppSpine = List (Icit × FC × Raw)
+
+pratt : Operators -> Int -> String -> Raw -> AppSpine -> Parser (Raw × AppSpine)
+pratt ops prec stop left spine = do
+  (left, spine) <- runPrefix stop left spine
+  let (left, spine) = projectHead left spine
+  let spine = runProject spine
+  case spine of
+    Nil => pure (left, Nil)
+    ((Explicit, fc, tm@(RVar x nm)) :: rest) =>
+        if nm == stop then pure (left,spine) else
+        case lookupMap' nm ops of
+          Just (MkOp name p fix False rule) => if p < prec
+            then pure (left, spine)
+            else
+              runRule p fix stop rule (RApp fc (RVar fc name) left Explicit) rest
+          Just _ => fail "expected operator"
+          Nothing =>
+            if isPrefixOf "." nm
+            then pratt ops prec stop (RApp (getFC tm) tm left Explicit) rest
+            else pratt ops prec stop (RApp (getFC left) left tm Explicit) rest
+    ((icit, fc, tm) :: rest) => pratt ops prec stop (RApp (getFC left) left tm icit) rest
+  where
+    projectHead : Raw -> AppSpine -> (Raw × AppSpine)
+    projectHead t sp@((Explicit, fc', RVar fc nm) :: rest) =
+      if isPrefixOf "." nm
+        then projectHead (RApp fc (RVar fc nm) t Explicit) rest
+        else (t,sp)
+    projectHead t sp = (t, sp)
+
+    -- we need to check left/AppSpine first
+    -- we have a case above for when the next token is a projection, but
+    -- we need this to make projection bind tighter than app
+    runProject : AppSpine -> AppSpine
+    runProject (t@(Explicit, fc', tm) :: u@(Explicit, _, RVar fc nm) :: rest) =
+      if isPrefixOf "." nm
+        then runProject ((Explicit, fc', RApp fc (RVar fc nm) tm Explicit) :: rest)
+        else (t :: u :: rest)
+    runProject tms = tms
+
+    -- left has our partially applied operator and we're picking up args
+    -- for the rest of the `_`
+    runRule : Int -> Fixity -> String -> List String -> Raw -> AppSpine -> Parser (Raw × AppSpine)
+    runRule p fix stop Nil left spine = pure (left, spine)
+    runRule p fix stop ("" :: Nil) left spine = do
+      let pr = case fix of
+                InfixR => p
+                _ => p + 1
+      case spine of
+                ((_, fc, right) :: rest) => do
+                  (right, rest) <- pratt ops pr stop right rest
+                  pratt ops prec stop (RApp (getFC left) left right Explicit) rest
+                _ => fail "trailing operator"
+
+    runRule p fix stop (nm :: rule) left spine = do
+      case spine of
+        Nil => fail "short"
+        ((_, _, right) :: rest) => do
+
+          (right,rest) <- pratt ops 0 nm right rest -- stop!!
+          let ((_,fc',RVar fc name) :: rest) = rest
+            | _ => fail "expected \{nm}"
+          if name == nm
+            then runRule p fix stop rule (RApp (getFC left) left right Explicit) rest
+            else fail "expected \{nm}"
+
+    -- run any prefix operators
+    runPrefix : String -> Raw -> AppSpine -> Parser (Raw × AppSpine)
+    runPrefix stop (RVar fc nm) spine =
+      case lookupMap' nm ops of
+           -- TODO False should be an error here
+         Just (MkOp name p fix True rule) => do
+            runRule p fix stop rule (RVar fc name) spine
+         _ =>
+          pure (left, spine)
+    runPrefix stop left spine = pure (left, spine)
+
+
+
+parseOp : Parser Raw
+parseOp = do
+  fc <- getPos
+  ops <- getOps
+  hd <- atom
+  rest <- many pArg
+  (res, Nil) <- pratt ops 0 "" hd rest
+    | _ => fail "extra stuff"
+  pure res
+
+
+-- TODO case let? We see to only have it for `do`
+-- try (keyword "let" >> symbol "(")
+
+
+letExpr : Parser Raw
+letExpr = do
+  keyword "let"
+  alts <- startBlock $ someSame $ letAssign
+  keyword' "in"
+  scope <- typeExpr
+  pure $ foldl mkLet scope (reverse alts)
+  where
+    mkLet : Raw → String × FC × Maybe Raw × Raw → Raw
+    mkLet acc (n,fc,ty,v) = RLet fc n (fromMaybe (RImplicit fc) ty) v acc
+
+    letAssign : Parser (Name × FC × Maybe Raw × Raw)
+    letAssign = do
+      fc <- getPos
+      name <- ident
+      -- TODO type assertion
+      ty <- optional (keyword ":" *> typeExpr)
+      keyword "="
+      t <- typeExpr
+      pure (name,fc,ty,t)
+
+pLamArg : Parser (Icit × String × Maybe Raw)
+pLamArg = impArg <|> autoArg <|> expArg
+       <|> (\ x => (Explicit, x, Nothing)) <$> (ident <|> uident)
+       <|> keyword "_" *> pure (Explicit, "_", Nothing)
+  where
+    impArg : Parser (Icit × String × Maybe Raw)
+    impArg = do
+      nm <- braces (ident <|> uident)
+      ty <- optional (symbol ":" >> typeExpr)
+      pure (Implicit, nm, ty)
+
+    autoArg : Parser (Icit × String × Maybe Raw)
+    autoArg = do
+      nm <- dbraces (ident <|> uident)
+      ty <- optional (symbol ":" >> typeExpr)
+      pure (Auto, nm, ty)
+
+    expArg : Parser (Icit × String × Maybe Raw)
+    expArg = do
+      nm <- parenWrap (ident <|> uident)
+      ty <- optional (symbol ":" >> typeExpr)
+      pure (Explicit, nm, ty)
+
+lamExpr : Parser Raw
+lamExpr = do
+  pos <- getPos
+  keyword "\\" <|> keyword "λ"
+  args <- some $ addPos pLamArg
+  keyword "=>"
+  scope <- typeExpr
+  pure $ foldr mkLam scope args
+  where
+    mkLam : FC × Icit × Name × Maybe Raw → Raw → Raw
+    mkLam (fc, icit, name, ty) sc = RLam fc (BI fc name icit Many) sc
+
+
+caseAlt : Parser RCaseAlt
+caseAlt = do
+  pure MkUnit
+  pat <- typeExpr
+  keyword "=>"
+  t <- term
+  pure $ MkAlt pat t
+
+
+caseExpr : Parser Raw
+caseExpr = do
+  fc <- getPos
+  keyword "case"
+  sc <- term
+  keyword "of"
+  alts <- startBlock $ someSame $ caseAlt
+  pure $ RCase fc sc alts
+
+caseLamExpr : Parser Raw
+caseLamExpr = do
+  fc <- getPos
+  try ((keyword "\\" <|> keyword "λ") *> keyword "case")
+  alts <- startBlock $ someSame $ caseAlt
+  pure $ RLam fc (BI fc "$case" Explicit Many) $ RCase fc (RVar fc "$case") alts
+
+doExpr : Parser Raw
+doStmt : Parser DoStmt
+
+caseLet : Parser Raw
+caseLet = do
+  -- look ahead so we can fall back to normal let
+  fc <- getPos
+  try (keyword "let" >> symbol "(")
+  pat <- typeExpr
+  symbol ")"
+  keyword "="
+  sc <- typeExpr
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
+  keyword "in"
+  body <- term
+  pure $ RCase fc sc (MkAlt pat body :: alts)
+
+doCaseLet : Parser DoStmt
+doCaseLet = do
+  -- look ahead so we can fall back to normal let
+  -- Maybe make it work like arrow?
+  fc <- getPos
+  try (keyword "let" >> symbol "(")
+  pat <- typeExpr
+  symbol ")"
+  keyword "="
+  sc <- typeExpr
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
+  bodyFC <- getPos
+  body <- RDo <$> getPos <*> someSame doStmt
+  pure $ DoExpr fc (RCase fc sc (MkAlt pat body :: alts))
+
+doArrow : Parser DoStmt
+doArrow = do
+  fc <- getPos
+  left <- typeExpr
+  (Just _) <- optional $ keyword "<-"
+    | _ => pure $ DoExpr fc left
+  right <- term
+  alts <- startBlock $ manySame $ symbol "|" *> caseAlt
+  pure $ DoArrow fc left right alts
+
+doLet : Parser DoStmt
+doLet = do
+  fc <- getPos
+  keyword "let"
+  nm <- ident
+  keyword "="
+  tm <- term
+  pure $ DoLet fc nm tm
+
+doStmt
+  = doCaseLet
+  <|> doLet
+  <|> doArrow
+
+doExpr = RDo <$> getPos <* keyword "do" <*> (startBlock $ someSame doStmt)
+
+parseIfThen : Parser Raw
+parseIfThen = do
+  fc <- getPos
+  keyword "if"
+  a <- term
+  keyword "then"
+  b <- term
+  keyword "else"
+  c <- term
+  pure $ RIf fc a b c
+
+term' : Parser Raw
+
+term' =  caseExpr
+    <|> caseLet
+    <|> letExpr
+    <|> caseLamExpr
+    <|> lamExpr
+    <|> doExpr
+    <|> parseIfThen
+    -- Make this last for better error messages
+    <|> parseOp
+
+term = do
+  t <- term'
+  rest <- many (_,_ <$> getPos <* keyword "$" <*> term')
+  pure $ apply t rest
+  where
+    apply : Raw -> List (FC × Raw) -> Raw
+    apply t Nil = t
+    apply t ((fc,x) :: xs) = RApp fc t (apply x xs) Explicit
+
+varname : Parser String
+varname = (ident <|> uident <|> keyword "_" *> pure "_")
+
+quantity : Parser Quant
+quantity = fromMaybe Many <$> optional (Zero <$ keyword "0")
+
+ebind : Parser Telescope
+ebind = do
+  -- don't commit until we see the ":"
+  symbol "("
+  quant <- quantity
+  names <- try (some (addPos varname) <* symbol ":")
+  ty <- typeExpr
+  symbol ")"
+  pure $ map (makeBind quant ty) names
+  where
+    makeBind : Quant → Raw → FC × String → (BindInfo × Raw)
+    makeBind quant ty (pos, name) = (BI pos name Explicit quant, ty)
+
+
+ibind : Parser Telescope
+ibind = do
+  -- I've gone back and forth on this, but I think {m a b} is more useful than {Int}
+  symbol "{"
+  quant <- quantity
+  names <- (some (addPos varname))
+  ty <- optional (symbol ":" *> typeExpr)
+  symbol "}"
+  pure $ map (makeBind quant ty) names
+  where
+    makeBind : Quant → Maybe Raw → FC × String → BindInfo × Raw
+    makeBind quant ty (pos, name) = (BI pos name Implicit quant, fromMaybe (RImplicit pos) ty)
+
+abind : Parser Telescope
+abind = do
+  -- for this, however, it would be nice to allow {{Monad A}}
+  symbol "{{"
+  name <- optional $ try (addPos varname <* symbol ":")
+  ty <- typeExpr
+  symbol "}}"
+  case name of
+    Just (pos,name) => pure ((BI pos name Auto Many, ty) :: Nil)
+    Nothing => pure ((BI (getFC ty) "_" Auto Many, ty) :: Nil)
+
+arrow : Parser Unit
+arrow = symbol "->" <|> symbol "→"
+
+-- Collect a bunch of binders (A : U) {y : A} -> ...
+
+forAll : Parser Raw
+forAll = do
+  keyword "forall" <|> keyword "∀"
+  all <- some (addPos varname)
+  keyword "."
+  scope <- typeExpr
+  pure $ foldr mkPi scope all
+  where
+    mkPi : FC × String → Raw → Raw
+    mkPi (fc, n) sc = RPi fc (BI fc n Implicit Zero) (RImplicit fc) sc
+
+binders : Parser Raw
+binders = do
+  binds <- many (abind <|> ibind <|> ebind)
+  arrow
+  scope <- typeExpr
+  pure $ foldr mkBind scope (join binds)
+  where
+    mkBind : (BindInfo × Raw) -> Raw -> Raw
+    mkBind (info, ty) scope = RPi (getFC info) info ty scope
+
+typeExpr
+  = binders
+  <|> forAll
+  <|> (do
+        fc <- getPos
+        exp <- term
+        scope <- optional (arrow *> typeExpr)
+        case scope of
+          Nothing      => pure exp
+          -- consider Maybe String to represent missing
+          (Just scope) => pure $ RPi fc (BI fc "_" Explicit Many) exp scope)
+
+-- And top level stuff
+
+
+parseSig : Parser Decl
+parseSig = TypeSig <$> getPos <*> try (some (ident <|> uident <|> token Projection) <* keyword ":") <*> typeExpr
+
+parseImport : Parser Import
+parseImport = do
+  fc <- getPos
+  keyword "import"
+  ident <- uident
+  rest <- many $ token Projection
+  let name = joinBy "" (ident :: rest)
+  pure $ MkImport fc name
+
+-- Do we do pattern stuff now? or just name = lambda?
+-- TODO multiple names
+parseMixfix : Parser Decl
+parseMixfix = do
+  fc <- getPos
+  fix <- InfixL <$ keyword "infixl"
+     <|> InfixR <$ keyword "infixr"
+     <|> Infix <$ keyword "infix"
+  prec <- token Number
+  ops <- some $ token MixFix
+  for ops $ \ op => addOp op (cast prec) fix
+  pure $ PMixFix fc ops (cast prec) fix
+
+getName : Raw -> Parser String
+getName (RVar x nm) = pure nm
+getName (RApp x t u icit) = getName t
+getName tm = fail "bad LHS"
+
+
+
+parseDef : Parser Decl
+parseDef = do
+  fc <- getPos
+  t <- typeExpr
+  nm <- getName t
+  keyword "="
+  body <- typeExpr
+  wfc <- getPos
+  w <- optional $ do
+    keyword "where"
+    startBlock $ manySame $ (parseSig <|> parseDef)
+  let body = maybe body (\ decls => RWhere wfc decls body) w
+  -- these get collected later
+  pure $ Def fc nm ((t, body) :: Nil) -- (MkClause fc Nil t body :: Nil)
+
+
+parsePType : Parser Decl
+parsePType = do
+  fc <- getPos
+  keyword "ptype"
+  id <- uident
+  ty <- optional $ do
+    keyword ":"
+    typeExpr
+  pure $ PType fc id ty
+
+parsePFunc : Parser Decl
+parsePFunc = do
+  fc <- getPos
+  keyword "pfunc"
+  nm <- ident
+  used <- optional (keyword "uses" >> parenWrap (many $ uident <|> ident <|> token MixFix))
+  keyword ":"
+  ty <- typeExpr
+  keyword ":="
+  src <- token JSLit
+  pure $ PFunc fc nm (fromMaybe Nil used) ty src
+
+
+parseShortData : Parser Decl
+parseShortData = do
+  fc <- getPos
+  keyword "data"
+  lhs <- typeExpr
+  keyword "="
+  sigs <- sepBy (keyword "|") typeExpr
+  pure $ ShortData fc lhs sigs
+
+
+parseData : Parser Decl
+parseData = do
+  fc <- getPos
+  -- commit when we hit ":"
+  name <- try $ (keyword "data" *> (uident <|> ident <|> token MixFix) <* keyword ":")
+  ty <- typeExpr
+  keyword "where"
+  decls <- startBlock $ manySame $ parseSig
+  pure $ Data fc name ty decls
+
+nakedBind : Parser Telescope
+nakedBind = do
+  names <- some (addPos varname)
+  pure $ map makeBind names
+  where
+    makeBind : FC × String → (BindInfo × Raw)
+    makeBind (pos, name) = (BI pos name Explicit Many, RImplicit pos)
+
+parseRecord : Parser Decl
+parseRecord = do
+  fc <- getPos
+  keyword "record"
+  name <- uident
+  teles <- many $ ebind <|> nakedBind
+  keyword "where"
+  cname <- optional $ keyword "constructor" *> (uident <|> token MixFix)
+  decls <- startBlock $ manySame $ parseSig
+  pure $ Record fc name (join teles) cname decls
+
+
+
+parseClass : Parser Decl
+parseClass = do
+  fc <- getPos
+  keyword "class"
+  name <- uident
+  teles <- many $ ebind <|> nakedBind
+  keyword "where"
+  decls <- startBlock $ manySame $ parseSig
+  pure $ Class fc name (join teles) decls
+
+
+parseInstance : Parser Decl
+parseInstance = do
+  fc <- getPos
+  keyword "instance"
+  ty <- typeExpr
+  -- is it a forward declaration
+  (Just _) <- optional $ keyword "where"
+    | _ => pure $ Instance fc ty Nothing
+  decls <- startBlock $ manySame $ parseDef
+  pure $ Instance fc ty (Just decls)
+
+-- Not sure what I want here.
+-- I can't get a Tm without a type, and then we're covered by the other stuff
+parseNorm : Parser Decl
+parseNorm = DCheck <$> getPos <* keyword "#check" <*> typeExpr <* keyword ":" <*> typeExpr
+
+
+parseDecl : Parser Decl
+parseDecl = parseMixfix <|> parsePType <|> parsePFunc
+  <|> parseNorm <|> parseData <|> parseShortData <|> parseSig <|> parseDef
+  <|> parseClass <|> parseInstance <|> parseRecord
+
+
+
+parseModHeader : Parser (FC × String)
+parseModHeader = do
+  sameLevel (keyword "module")
+  fc <- getPos
+  name <- uident
+  rest <- many $ token Projection
+  -- FIXME use QName
+  let name = joinBy "" (name :: rest)
+  pure (fc, name)
+
+
+parseImports : Parser (List Import)
+parseImports = manySame parseImport
+
+
+parseMod : Parser Module
+parseMod = do
+  sameLevel (keyword "module")
+  name <- uident
+  rest <- many $ token Projection
+  imports <- manySame parseImport
+  decls <- manySame parseDecl
+  let name = joinBy "" (name :: rest)
+  pure $ MkModule name imports decls
+
+
+-- data ReplCmd =
+--     Def Decl
+--   | Norm Raw -- or just name?
+--   | Check Raw
+
+
+-- -- Eventually I'd like immediate actions in the file, like lean, but I
+-- -- also want to REPL to work and we can do that first.
+-- parseRepl : Parser ReplCmd
+-- parseRepl = Def <$> parseDecl <|> Norm <$ keyword "#nf" <*> typeExpr
+--   <|> Check <$ keyword "#check" <*> typeExpr