Switch to esm, add #export statement to newt, tweaks to LSP

src/Lib/Compile.newt

@@ -414,10 +414,13 @@ we're visiting shallow or deep. We're trying to avoid hitting issues with indire
 - Shallow represents the declaration, so we filter to those at the end
 
 TODO this could be made faster by keeping a map of the done information
+REVIEW could I avoid most of this by using `function` instead of arrow functions?
+
 -/
 
-sortedNames : SortedMap QName CExp → QName → List QName
-sortedNames defs qn = map snd $ filter (not ∘ fst) $ go Nil Nil (True, qn)
+sortedNames : SortedMap QName CExp → List QName → List QName
+sortedNames defs names =
+  map snd $ filter (not ∘ fst) $ foldl (go Nil) Nil $ map (True,) names
   where
     getBody : CAlt → CExp
     getBody (CConAlt _ _ _ _ t) = t
@@ -483,10 +486,10 @@ eraseEntries = do
     go _ = pure MkUnit
 
 -- given a initial function, return a dependency-ordered list of javascript source
-process : QName → M (List Doc)
-process name = do
+process : List QName → M (List Doc)
+process names = do
   top <- getTop
-  entries <- getEntries emptyMap name
+  entries <- foldlM getEntries emptyMap names
 
   -- Maybe move this dance into liftWhere
   ref <- newIORef entries
@@ -500,18 +503,35 @@ process name = do
   cexpMap <- tailCallOpt cexpMap
   -- Not needed for JS, uncomment to test
   -- cexpMap <- liftLambda cexpMap
-  let names = sortedNames cexpMap name
-  pure $ map cexpToDoc $ mapMaybe (\x => lookupMap x cexpMap) names
+  let names = sortedNames cexpMap names
+  pure $ mapMaybe (go cexpMap) names
+  where
+    go : ExpMap → QName → Maybe Doc
+    go cexpMap name = do
+      cexp <- lookupMap name cexpMap
+      if elem name names
+        then Just $ text "export" <+> cexpToDoc cexp
+        else Just $ cexpToDoc cexp
 
 compile : M (List Doc)
 compile = do
   top <- getTop
-  case lookupRaw "main" top of
-    Just (MkEntry fc name type def _) => do
-      tmp <- process name
-      -- tack on call to main function
-      let exec = stmtToDoc $ JPlain $ Apply (Var $ show name) Nil
-      pure $ reverse (exec :: tmp)
-    Nothing =>
-      -- TODO maybe emit everything if there is no main
-      error emptyFC "No main function found"
+  let exports = getExports Nil $ listValues top.defs
+  let mainName = (QN top.ns "main")
+  let main = lookup mainName top
+  let todo = case main of
+    Nothing => exports
+    Just _ => mainName :: exports
+  defs <- process todo
+  case lookup mainName top of
+    Just _ => -- tack on call to main function
+      let exec = stmtToDoc $ JPlain $ Apply (Var $ show mainName) Nil
+      in pure $ reverse (exec :: defs)
+    Nothing => pure $ reverse defs
+  where
+    getExports : List QName → List TopEntry → List QName
+    getExports acc Nil = acc
+    getExports acc ((MkEntry fc name@(QN ns nm) type def eflags) :: rest) =
+      let acc = if elem Export eflags then name :: acc else acc
+      in getExports acc rest
+

src/Lib/Elab.newt

@@ -493,22 +493,18 @@ unify env mode t u = do
     unifyRest t' u' = error (getFC t') "unify failed \{show t'} =?= \{show u'} \n  env is \{show env}"
 
     unifyRef : Val -> Val -> M UnifyResult
-    unifyRef t'@(VRef fc k sp)  u'@(VRef fc' k' sp') =
+    unifyRef t'@(VRef fc k sp)  u'@(VRef fc' k' sp') = do
       -- unifySpine is a problem for cmp (S x) (S y) =?= cmp x y
-        do
-        -- catchError(unifySpine env mode (k == k') sp sp') $ \ err => do
-            Nothing <- tryEval env t'
-              | Just v => do
-                  debug $ \ _ => "tryEval \{show t'} to \{show v}"
-                  unify env mode v u'
-            Nothing <- tryEval env u'
-              | Just v => unify env mode t' v
-            if k == k'
-              then unifySpine env mode (k == k') sp sp'
-              else error fc "vref mismatch \{show t'} =?= \{show u'}"
+      Nothing <- tryEval env t'
+        | Just v => do
+            debug $ \ _ => "tryEval \{show t'} to \{show v}"
+            unify env mode v u'
+      Nothing <- tryEval env u'
+        | Just v => unify env mode t' v
+      if k == k'
+        then unifySpine env mode (k == k') sp sp'
+        else error fc "vref mismatch \{show t'} =?= \{show u'}"
 
-    -- Lennart.newt cursed type references itself
-    -- We _could_ look up the ref, eval against Nil and vappSpine...
     unifyRef t         u@(VRef fc' k' sp') = do
       debug $ \ _ => "expand \{show t} =?= %ref \{show k'}"
       top <- getTop
@@ -1488,7 +1484,7 @@ check ctx tm ty = do
                 error fc "Icity issue checking \{show t} at \{show ty}"
     (t@(RLam _ (BI fc nm icit quant) tm), ty) => do
               pty <- prvalCtx ty
-              error fc "Expected pi type, got \{pty}"
+              error fc "Expected \{pty}, got pi type"
 
     (RLet fc nm ty v sc, rty) => do
       ty' <- check ctx ty (VU emptyFC)

src/Lib/Parser.newt

@@ -669,11 +669,18 @@ parseInstance = do
 parseNorm : Parser Decl
 parseNorm = DCheck <$> getPos <* keyword "#check" <*> typeExpr <* keyword ":" <*> typeExpr
 
+parseExport : Parser Decl
+parseExport = do
+  loc <- getPos
+  keyword "#export"
+  names <- many $ withFC ident
+  pure $ Exports loc names
 
 parseDecl : Parser Decl
 parseDecl = parseMixfix <|> parsePType <|> parsePFunc
   <|> parseNorm <|> parseData <|> parseShortData
   <|> parseClass <|> parseInstance <|> parseRecord
+  <|> parseExport
   -- We'll put the backtracing stuff last, but there is a commit issue in parseDef
   <|> parseSig <|> parseDef
 

src/Lib/Parser/Impl.newt

@@ -206,7 +206,7 @@ token' : Kind -> Parser String
 token' k = satisfy (\t => t.val.kind == k) "Expected a \{show k} token"
 
 keyword' : String -> Parser Unit
-keyword' kw = ignore $ satisfy (\t => t.val.text == kw && (t.val.kind == Keyword || t.val.kind == Symbol || t.val.kind == Number)) "Expected '\{kw}'"
+keyword' kw = ignore $ satisfy (\t => t.val.text == kw && (t.val.kind == Keyword || t.val.kind == Symbol || t.val.kind == Number || t.val.kind == Pragma)) "Expected '\{kw}'"
 
 -- expect indented token of given kind
 

src/Lib/ProcessDecl.newt

@@ -529,6 +529,16 @@ processRecord ns recordFC (nameFC, nm) tele cname decls = do
       let deps = ((name, RApp fc (RVar fc pname) (RVar fc "$self") Explicit) :: deps)
       processFields autoPat tail deps rest
 
+processExports : String → FC → List (FC × String) → M Unit
+processExports ns fc names = do
+  top <- getTop
+  traverse_ (setExport top) names
+  where
+    setExport : TopContext → FC × String → M Unit
+    setExport top (fc, name) = do
+      let (Just entry) = lookupRaw name top | _ => error fc "\{name} not in scope"
+      setFlag entry.name fc Export
+
 -- currently mixfix registration is handled in the parser
 -- since we now run a decl at a time we could do it here.
 processDecl ns (PMixFix _ _ _ _)  = pure MkUnit
@@ -544,3 +554,4 @@ processDecl ns (Data fc nm ty (Just cons)) = processData ns fc nm ty cons
 -- TODO distinguish from function signatures
 processDecl ns (Data fc (_, nm) ty Nothing) = processTypeSig ns fc (nm :: Nil) ty
 processDecl ns (Record recordFC nm tele cname decls) = processRecord ns recordFC nm tele cname decls
+processDecl ns (Exports fc names) = processExports ns fc names

src/Lib/Syntax.newt

@@ -97,10 +97,12 @@ data Decl
   | Class FC (FC × Name) Telescope (List Decl)
   | Instance FC Raw (Maybe (List Decl))
   | Record FC (FC × Name) Telescope (Maybe $ FC × Name) (List Decl)
+  | Exports FC (List $ FC × Name)
 
 
 instance HasFC Decl where
   getFC (TypeSig x strs tm) = x
+  getFC (Exports x _) = x
   getFC (FunDef x str xs) = x
   getFC (DCheck x tm tm1) = x
   getFC (Data x str tm xs) = x
@@ -148,6 +150,7 @@ instance Show Decl where
   show (Class _ (_,nm) tele decls) = foo ("Class" ::  nm :: "..." :: (show $ map show decls) :: Nil)
   show (Instance _ nm decls) = foo ("Instance" ::  show nm :: (show $ map show decls) :: Nil)
   show (Record _ nm tele nm1 decls) = foo ("Record" :: show nm :: show tele :: show nm1 :: show decls :: Nil)
+  show (Exports _ nms) = foo ("Exports" :: show nms :: Nil)
 
 
 instance Show Module where
@@ -263,6 +266,7 @@ instance Pretty Decl where
     <+> (nest 2 $ text "where" </> stack (map pretty decls))
   pretty (Instance _ _ _) = text "TODO pretty Instance"
   pretty (ShortData _ lhs sigs) = text "data" <+> pretty lhs <+> text "=" <+> pipeSep (map pretty sigs)
+  pretty (Exports _ nms) = text "#export" <+> spread (map (text ∘ show ∘ snd) nms)
 
 lhsNames : Raw → List String
 lhsNames tm = case tm of

src/Lib/Types.newt

@@ -221,18 +221,11 @@ data VCaseAlt : U where
   VCaseCons : (name : QName) -> (args : List String) -> Env -> Tm ->  VCaseAlt
   VCaseLit : Literal -> Val -> VCaseAlt
   VCaseDefault : Val -> VCaseAlt
-  -- VCaseCons : (name : QName) -> (args : List String) -> Tm ->  VCaseAlt
-  -- VCaseLit : Literal -> Tm -> VCaseAlt
-  -- VCaseDefault : Tm -> VCaseAlt
-
 
 data Val : U where
-  -- This will be local / flex with spine.
   VVar : FC -> (k : Int) -> (sp : SnocList Val) -> Val
   VRef : FC -> (nm : QName) -> (sp : SnocList Val) -> Val
-  -- neutral case
   VCase : FC -> (sc : Val) -> List VCaseAlt -> Val
-  -- we'll need to look this up in ctx with IO
   VMeta : FC -> QName -> (sp : SnocList Val) -> Val
   VLam : FC -> Name -> Icit -> Quant -> Closure -> Val
   VPi : FC -> Name -> Icit -> Quant -> (a : Val) -> (b : Closure) -> Val
@@ -374,15 +367,17 @@ instance Show Def where
 
 -- entry in the top level context
 
-data EFlag = Hint | Inline
+data EFlag = Hint | Inline | Export
 
 instance Show EFlag where
   show Hint = "hint"
   show Inline = "inline"
+  show Export = "export"
 
 instance Eq EFlag where
   Hint == Hint = True
   Inline == Inline = True
+  Export == Export = True
   _ == _ = False
 
 record TopEntry where
@@ -601,7 +596,7 @@ lookupMeta ix@(QN ns nm) = do
     Just meta => pure meta
     Nothing => case lookupMap' ns top.modules of
       Nothing =>
-          error emptyFC "missing module: \{show ns}"
+          error emptyFC "missing module: \{show ns} looking up meta \{show ix}"
       Just mod => case lookupMap' ix mod.modMetaCtx.metas of
         Nothing =>
           error emptyFC "missing meta: \{show ix}"
@@ -641,3 +636,13 @@ instance Show Pattern where
 data Constraint = PC String Pattern Val
 instance Show Constraint where
   show (PC nm pat ty) = show (nm,pat,ty)
+
+-- Lazy because `let` would do work at the top of a `M a`
+prof : ∀ a. String → Lazy (M a) → M a
+prof desc work = do
+  start <- getTime
+  res <- force work
+  end <- getTime
+  putStrLn "PROF \{desc} \{show $ end - start} ms"
+  pure res
+