SortedMap uses any comparator

Makefile

@@ -55,3 +55,8 @@ vscode:
 
 playground: .PHONY
 	cd playground && ./build
+
+profile: .PHONY
+	rm isolate* build/*; node --prof newt.js -o newt2.js src/Main.newt
+	node --prof-process isolate* > profile.txt
+

TODO.md

@@ -3,6 +3,7 @@
 
 - [ ] Raw is duplicated between Lib.Syntax and Lib.Compile, but not detected
 - [ ] vscode - run newt when switching editors
+- [ ] who calls X?  We can only do this scoped to the current context for now. Someday whole source dir
 - [ ] case split
   - We could fake this up:
     - given a name and a point in the editor

src/Data/Graph.newt

@@ -82,7 +82,7 @@ strongConnect {k} st vtx =
 -- to ignore ambiguity from indirect solutions
 tarjan : ∀ k. {{Eq k}} {{Ord k}} → List (k × List k) → List (List k)
 tarjan {k} nodes =
-  let g = foldMap const EmptyMap $ map mkVertex nodes in
+  let g = foldMap const emptyMap $ map mkVertex nodes in
   .result $ foldl checkVertex (MkTState 0 Nil Nil g) $ map fst nodes
   where
     mkVertex : k × List k → k × TVertex k

src/Data/SortedMap.newt

@@ -2,50 +2,52 @@ module Data.SortedMap
 
 import Prelude
 
--- TODO We'll want to replace Ord/Eq with (a → Ordering) (and rewrite most of our aoc solutions...)
-
 data T23 : Nat -> U -> U -> U where
   Leaf : ∀ k v. k -> v -> T23 Z k v
   Node2 : ∀ h k v. T23 h k v -> k -> T23 h k v -> T23 (S h) k v
   Node3 : ∀ h k v. T23 h k v -> k -> T23 h k v -> k -> T23 h k v -> T23 (S h) k v
 
-lookupT23 : ∀ h k v. {{Ord k}} -> k -> T23 h k v -> Maybe (k × v)
+lookupT23 : ∀ h k v. (k → k → Ordering) -> k -> T23 h k v -> Maybe (k × v)
-lookupT23 key (Leaf k v)= case compare k key of
+lookupT23 compare key (Leaf k v)= case compare k key of
     EQ => Just (k,v)
     _ => Nothing
-lookupT23 key (Node2 t1 k1 t2) =
+lookupT23 compare key (Node2 t1 k1 t2) =
-  if key <= k1 then lookupT23 key t1 else lookupT23 key t2
+  case compare key k1 of
-lookupT23 key (Node3 t1 k1 t2 k2 t3) =
+    GT => lookupT23 compare key t2
-  if key <= k1 then lookupT23 key t1
+    _ => lookupT23 compare key t1
-  else if key <= k2 then lookupT23 key t2
+lookupT23 compare key (Node3 t1 k1 t2 k2 t3) =
-  else lookupT23 key t3
+  case compare key k1 of
+    GT => case compare key k2 of
+      GT => lookupT23 compare key t3
+      _ => lookupT23 compare key t2
+    _ => lookupT23 compare key t1
 
-insertT23 : ∀ h k v. {{Ord k}} -> k -> v -> T23 h k v -> Either (T23 h k v) (T23 h k v × k × T23 h k v)
+insertT23 : ∀ h k v. (k → k → Ordering) -> k -> v -> T23 h k v -> Either (T23 h k v) (T23 h k v × k × T23 h k v)
-insertT23 key value (Leaf k v) = case compare key k of
+insertT23 compare key value (Leaf k v) = case compare key k of
   EQ => Left (Leaf key value)
   LT => Right (Leaf key value, key, Leaf k v)
   GT => Right (Leaf k v, k, Leaf key value)
-insertT23 key value (Node2 t1 k1 t2) =
+insertT23 compare key value (Node2 t1 k1 t2) =
-  if key <= k1 then
+  case compare key k1 of
-    case insertT23 key value t1 of
+    GT => case insertT23 compare key value t2 of
-      Left t1' => Left (Node2 t1' k1 t2)
-      Right (a,b,c) => Left (Node3 a b c k1 t2)
-  else case insertT23 key value t2 of
       Left t2' => Left (Node2 t1 k1 t2')
       Right (a,b,c) => Left (Node3 t1 k1 a b c)
-insertT23 key value (Node3 t1 k1 t2 k2 t3) =
+    _ => case insertT23 compare key value t1 of
-  if key <= k1 then
+      Left t1' => Left (Node2 t1' k1 t2)
-    case insertT23 key value t1 of
+      Right (a,b,c) => Left (Node3 a b c k1 t2)
-      Left t1' => Left (Node3 t1' k1 t2 k2 t3)
+insertT23 compare key value (Node3 t1 k1 t2 k2 t3) =
-      Right (a,b,c) => Right (Node2 a b c, k1, Node2 t2 k2 t3)
+  case compare key k1 of
-  else if key <= k2 then
+    GT => case compare key k2 of
-    case insertT23 key value t2 of
+      GT => case insertT23 compare key value t3 of
-      Left t2' => Left (Node3 t1 k1 t2' k2 t3)
-      Right (a,b,c) => Right (Node2 t1 k1 a, b, Node2 c k2 t3)
-  else
-    case insertT23 key value t3 of
         Left t3' => Left (Node3 t1 k1 t2 k2 t3')
         Right (a,b,c) => Right (Node2 t1 k1 t2, k2, Node2 a b c)
+      _ => case insertT23 compare key value t2 of
+        Left t2' => Left (Node3 t1 k1 t2' k2 t3)
+        Right (a,b,c) => Right (Node2 t1 k1 a, b, Node2 c k2 t3)
+    _ =>
+      case insertT23 compare key value t1 of
+        Left t1' => Left (Node3 t1' k1 t2 k2 t3)
+        Right (a,b,c) => Right (Node2 a b c, k1, Node2 t2 k2 t3)
 
 -- This is cribbed from Idris. Deleting nodes takes a bit of code.
 Hole : Nat → U → U → U
@@ -84,52 +86,57 @@ merge3 (Node3 a b c d e) f (Node3 g h i j k) l m = Node7 a b c d e f g h i j k l
 
 -- height is erased in the data everywhere but the top, but needed for case
 -- I wonder if we could use a 1 + 1 + 1 type instead of Either Tree Hole and condense this
-deleteT23 : ∀ k v. {{Ord k}} → (h : Nat) -> k -> T23 h k v -> Either (T23 h k v) (Hole h k v)
+deleteT23 : ∀ k v. (k → k → Ordering) → (h : Nat) -> k -> T23 h k v -> Either (T23 h k v) (Hole h k v)
-deleteT23 Z key (Leaf k v) = case compare k key of
+deleteT23 compare Z key (Leaf k v) = case compare k key of
   EQ => Right MkUnit
   _ => Left (Leaf k v)
-deleteT23 (S Z) key (Node2 t1 k1 t2) =
+deleteT23 compare (S Z) key (Node2 t1 k1 t2) =
-  if key <= k1
+  case compare key k1 of
-  then case deleteT23 Z key t1 of
+    GT => case deleteT23 compare Z key t2 of
-    Left t1 => Left (Node2 t1 k1 t2)
-    Right _ => Right t2
-  else case deleteT23 Z key t2 of
       Left t2 => Left (Node2 t1 k1 t2)
       Right MkUnit => Right t1
-deleteT23 (S Z) key (Node3 t1 k1 t2 k2 t3) =
+    _ => case deleteT23 compare Z key t1 of
-  if key <= k1
+      Left t1 => Left (Node2 t1 k1 t2)
-  then case deleteT23 _ key t1 of
+      Right _ => Right t2
-    Left t1 => Left (Node3 t1 k1 t2 k2 t3)
+deleteT23 compare (S Z) key (Node3 t1 k1 t2 k2 t3) =
-    Right MkUnit => Left (Node2 t2 k2 t3)
+  case compare key k1 of
-  else if key <= k2 then case deleteT23 _ key t2 of
+    GT => case compare key k2 of
-    Left t2 => Left (Node3 t1 k1 t2 k2 t3)
+      GT => case deleteT23 compare _ key t3 of
-    Right _ => Left (Node2 t1 k1 t3)
-  else case deleteT23 _ key t3 of
         Left t3 => Left (Node3 t1 k1 t2 k2 t3)
         Right _ => Left (Node2 t1 k1 t2)
-deleteT23 (S (S h)) key (Node2 t1 k1 t2) =
+      _ => case deleteT23 compare _ key t2 of
-  if key <= k1
+        Left t2 => Left (Node3 t1 k1 t2 k2 t3)
-  then case deleteT23 (S h) key t1 of
+        Right _ => Left (Node2 t1 k1 t3)
-    Left t1 => Left (Node2 t1 k1 t2)
+    _ => case deleteT23 compare _ key t1 of
-    Right t1 => case t2 of
+      Left t1 => Left (Node3 t1 k1 t2 k2 t3)
-      Node2 t2' k2' t3' => Right (Node3 t1 k1 t2' k2' t3')
+      Right MkUnit => Left (Node2 t2 k2 t3)
-      Node3 t2 k2 t3 k3 t4 => Left $ Node4 t1 k1 t2 k2 t3 k3 t4
+deleteT23 compare (S (S h)) key (Node2 t1 k1 t2) =
-  else case deleteT23 _ key t2 of
+  case compare key k1 of
+    GT => case deleteT23 compare _ key t2 of
       Left t2 => Left (Node2 t1 k1 t2)
       Right t2 => case t1 of
         Node2 a b c => Right (Node3 a b c k1 t2)
         Node3 a b c d e => Left (Node4 a b c d e k1 t2)
-deleteT23 (S (S h)) key (Node3 t1 k1 t2 k2 t3) =
+    _ => case deleteT23 compare (S h) key t1 of
-  if key <= k1
+      Left t1 => Left (Node2 t1 k1 t2)
-  then case deleteT23 _ key t1 of
+      Right t1 => case t2 of
-    Left t1 => Left (Node3 t1 k1 t2 k2 t3)
+        Node2 t2' k2' t3' => Right (Node3 t1 k1 t2' k2' t3')
-    Right t1 => Left (merge1 t1 k1 t2 k2 t3)
+        Node3 t2 k2 t3 k3 t4 => Left $ Node4 t1 k1 t2 k2 t3 k3 t4
-  else if key <= k2 then case deleteT23 _ key t2 of
+
-    Left t2 => Left (Node3 t1 k1 t2 k2 t3)
+
-    Right t2 => Left (merge2 t1 k1 t2 k2 t3)
+deleteT23 compare (S (S h)) key (Node3 t1 k1 t2 k2 t3) =
-  else case deleteT23 _ key t3 of
+  case compare key k1 of
+    GT => case compare key k2 of
+      GT => case deleteT23 compare _ key t3 of
         Left t3 => Left (Node3 t1 k1 t2 k2 t3)
         Right t3 => Left (merge3 t1 k1 t2 k2 t3)
+      _ => case deleteT23 compare _ key t2 of
+        Left t2 => Left (Node3 t1 k1 t2 k2 t3)
+        Right t2 => Left (merge2 t1 k1 t2 k2 t3)
+    _ => case deleteT23 compare _ key t1 of
+      Left t1 => Left (Node3 t1 k1 t2 k2 t3)
+      Right t1 => Left (merge1 t1 k1 t2 k2 t3)
+
 
 treeLeft : ∀ h k v. T23 h k v → (k × v)
 treeLeft (Leaf k v) = (k, v)
@@ -143,51 +150,51 @@ treeRight (Node3 _ _ _ _ t3) = treeRight t3
 
 
 data SortedMap : U -> U -> U where
-  EmptyMap : ∀ k v. SortedMap k v
+  EmptyMap : ∀ k v. (k → k → Ordering) → SortedMap k v
-  -- not erased so we know what happens in delete
+  -- h not erased so we know what happens in delete
-  MapOf : ∀ k v. {h : Nat} →  T23 h k v -> SortedMap k v
+  MapOf : ∀ k v. {h : Nat} → (k → k → Ordering) → T23 h k v → SortedMap k v
 
-deleteMap : ∀ k v. {{Ord k}} → k → SortedMap k v → SortedMap k v
+deleteMap : ∀ k v. k → SortedMap k v → SortedMap k v
-deleteMap key EmptyMap = EmptyMap
+deleteMap key m@(EmptyMap _) = m
 -- REVIEW if I split h separately in a nested case, it doesn't sort out Hole
-deleteMap key (MapOf {k} {v} {Z} tree) = case deleteT23 Z key tree of
+deleteMap key (MapOf {k} {v} {Z} compare tree) = case deleteT23 compare Z key tree of
-  Left t => MapOf t
+  Left t => MapOf compare t
-  Right t => EmptyMap
+  Right t => EmptyMap compare
-deleteMap key (MapOf {k} {v} {S n} tree) = case deleteT23 (S n) key tree of
+deleteMap key (MapOf {k} {v} {S n} compare tree) = case deleteT23 compare (S n) key tree of
-  Left t => MapOf t
+  Left t => MapOf compare t
-  Right t => MapOf t
+  Right t => MapOf compare t
 
 leftMost : ∀ k v. SortedMap k v → Maybe (k × v)
-leftMost EmptyMap = Nothing
+leftMost (MapOf compare m) = Just (treeLeft m)
-leftMost (MapOf m) = Just (treeLeft m)
+leftMost _ = Nothing
 
 rightMost : ∀ k v. SortedMap k v → Maybe (k × v)
-rightMost EmptyMap = Nothing
+rightMost (MapOf compare m) = Just (treeRight m)
-rightMost (MapOf m) = Just (treeRight m)
+rightMost _ = Nothing
 
 -- TODO issue with metas and case if written as `do` block
-pop : ∀ k v. {{Ord k}} → SortedMap k v → Maybe ((k × v) × SortedMap k v)
+pop : ∀ k v. SortedMap k v → Maybe ((k × v) × SortedMap k v)
 pop m = case leftMost m of
     Just (k,v) => Just ((k,v), deleteMap k m)
     Nothing => Nothing
 
-lookupMap : ∀ k v. {{Ord k}} -> k -> SortedMap k v -> Maybe (k × v)
+lookupMap : ∀ k v. k -> SortedMap k v -> Maybe (k × v)
-lookupMap k EmptyMap = Nothing
+lookupMap k (MapOf compare map) = lookupT23 compare k map
-lookupMap k (MapOf map) = lookupT23 k map
+lookupMap k _ = Nothing
 
-lookupMap' : ∀ k v. {{Ord k}} -> k -> SortedMap k v -> Maybe v
+lookupMap' : ∀ k v. k -> SortedMap k v -> Maybe v
-lookupMap' k EmptyMap = Nothing
+lookupMap' k (MapOf compare map) = snd <$> lookupT23 compare k map
-lookupMap' k (MapOf map) = snd <$> lookupT23 k map
+lookupMap' k _ = Nothing
 
 
-updateMap : ∀ k v. {{Ord k}} -> k -> v -> SortedMap k v -> SortedMap k v
+updateMap : ∀ k v. k -> v -> SortedMap k v -> SortedMap k v
-updateMap k v EmptyMap = MapOf $ Leaf k v
+updateMap k v (EmptyMap compare) = MapOf compare $ Leaf k v
-updateMap k v (MapOf map) = case insertT23 k v map of
+updateMap k v (MapOf compare map) = case insertT23 compare k v map of
-  Left map' => MapOf map'
+  Left map' => MapOf compare map'
-  Right (a, b, c) => MapOf (Node2 a b c)
+  Right (a, b, c) => MapOf compare (Node2 a b c)
 
 toList : ∀ k v. SortedMap k v → List (k × v)
-toList {k} {v} (MapOf smap) = reverse $ go smap Nil
+toList {k} {v} (MapOf compare smap) = reverse $ go smap Nil
   where
     go : ∀ h. T23 h k v → List (k × v) → List (k × v)
     go (Leaf k v) acc = (k, v) :: acc
@@ -195,14 +202,17 @@ toList {k} {v} (MapOf smap) = reverse $ go smap Nil
     go (Node3 t1 k1 t2 k2 t3) acc = go t3 $ go t2 $ go t1 acc
 toList _ = Nil
 
-mapFromList : ∀ k v. {{Ord k}} {{Eq k}} → List (k × v) → SortedMap k v
+emptyMap :  ∀ k v. {{Ord k}} → SortedMap k v
-mapFromList {k} {v} stuff = foldl go EmptyMap stuff
+emptyMap = EmptyMap compare
+
+mapFromList : ∀ k v. {{Ord k}} → List (k × v) → SortedMap k v
+mapFromList {k} {v} stuff = foldl go emptyMap stuff
   where
     go : SortedMap k v → k × v → SortedMap k v
     go map (k, v) = updateMap k v map
 
 
-foldMap : ∀ a b. {{Ord a}} → (b → b → b) → SortedMap a b → List (a × b) → SortedMap a b
+foldMap : ∀ a b. (b → b → b) → SortedMap a b → List (a × b) → SortedMap a b
 foldMap f m Nil = m
 foldMap f m ((a,b) :: xs) = case lookupMap a m of
   Nothing => foldMap f (updateMap a b m) xs

src/Lib/Compile.newt

@@ -385,7 +385,7 @@ process : QName → M (List Doc)
 process name = do
   let wat = QN ("Prelude" :: Nil) "arrayToList"
   top <- getTop
-  entries <- getEntries EmptyMap name
+  entries <- getEntries emptyMap name
 
   -- Maybe move this dance into liftWhere
   ref <- newIORef entries
@@ -397,7 +397,7 @@ process name = do
   entries <- readIORef ref
   -- Now working with defs
   exprs <- mapM defToCExp $ toList entries
-  let cexpMap = foldMap const EmptyMap exprs
+  let cexpMap = foldMap const emptyMap exprs
   cexpMap <- tailCallOpt cexpMap
   let names = sortedNames cexpMap name
   pure $ map cexpToDoc $ mapMaybe (\x => lookupMap x cexpMap) names

src/Lib/Parser/Impl.newt

@@ -50,7 +50,7 @@ perror fn ((MkBounded val (MkBounds line col _ _)) :: _) msg = E (MkFC fn (line,
 
 
 parse : ∀ a. String -> Parser a -> TokenList -> Either Error a
-parse fn pa toks = case runP pa toks False EmptyMap (MkFC fn (-1,-1)) of
+parse fn pa toks = case runP pa toks False emptyMap (MkFC fn (-1,-1)) of
   Fail fatal err toks com ops => Left err
   OK a Nil _ _ => Right a
   OK a ts _ _ => Left (perror fn ts "Extra toks")

src/Lib/TopContext.newt

@@ -42,9 +42,9 @@ instance Show TopContext where
 -- TODO need to get class dependencies working
 emptyTop : ∀ io. {{Monad io}} {{HasIO io}} -> io TopContext
 emptyTop = do
-  let mcctx = MC EmptyMap Nil 0 CheckAll
+  let mcctx = MC emptyMap Nil 0 CheckAll
   errs <- newIORef $ the (List Error) Nil
-  pure $ MkTop EmptyMap Nil EmptyMap Nil EmptyMap mcctx 0 errs EmptyMap
+  pure $ MkTop emptyMap Nil emptyMap Nil emptyMap mcctx 0 errs emptyMap
 
 
 setFlag : QName → FC → EFlag → M Unit

src/Lib/Types.newt

@@ -391,7 +391,7 @@ record ModContext where
 
 -- A placeholder while walking through dependencies of a module
 emptyModCtx : String → ModContext
-emptyModCtx csum = MkModCtx csum EmptyMap (MC EmptyMap Nil 0 NoCheck) EmptyMap
+emptyModCtx csum = MkModCtx csum emptyMap (MC emptyMap Nil 0 NoCheck) emptyMap
 
 HintTable : U
 HintTable = SortedMap QName (List (QName × Tm))

src/Main.newt

@@ -151,9 +151,9 @@ processModule importFC base stk qn@(QN ns nm) = do
   (decls, ops) <- parseDecls fn top.ops toks Lin
 
   top <- getTop
-  let freshMC = MC EmptyMap Nil 0 CheckAll
+  let freshMC = MC emptyMap Nil 0 CheckAll
   -- set imported, mod, freshMC, ops  before processing
-  modifyTop (\ top => MkTop top.modules imported EmptyMap modns EmptyMap freshMC top.verbose top.errors ops)
+  modifyTop (\ top => MkTop top.modules imported emptyMap modns emptyMap freshMC top.verbose top.errors ops)
   for imported $ \ ns => do
     let (Just mod) = lookupMap' ns top.modules | _ => error emptyFC "namespace \{show ns} missing"
     importHints (listValues mod.modDefs)
@@ -220,7 +220,7 @@ processFile fn = do
     | Left err => error (MkFC fn (0,0)) "error reading \{fn}: \{show err}"
   let (Right toks) = tokenise fn src
     | Left err => throwError err
-  let (Right ((nameFC, modName), _, _)) = partialParse fn parseModHeader EmptyMap toks
+  let (Right ((nameFC, modName), _, _)) = partialParse fn parseModHeader emptyMap toks
     | Left (err,toks) => throwError err
 
   (base,qn) <- getBaseDir fn modName
@@ -233,8 +233,8 @@ processFile fn = do
   setDef (QN primNS "PiType") emptyFC (Erased emptyFC) (PrimFn "(h0, h1) => ({ tag: \"PiType\", h0, h1 });" (S (S Z)) Nil) Nil
 
   top <- getTop
-  let modules = updateMap primNS (MkModCtx "" top.defs (MC EmptyMap Nil 0 CheckAll) top.ops) top.modules
+  let modules = updateMap primNS (MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops) top.modules
-  modifyTop (\ top => MkTop modules (primNS :: Nil) EmptyMap Nil EmptyMap top.metaCtx top.verbose top.errors top.ops)
+  modifyTop (\ top => MkTop modules (primNS :: Nil) emptyMap Nil emptyMap top.metaCtx top.verbose top.errors top.ops)
 
   src <- processModule emptyFC base Nil qn
   top <- getTop

src/Test/Parser.newt

@@ -17,7 +17,7 @@ main = do
     | _ => putStrLn "postpone error"
   -- debugLog toks
 
-  let (OK a toks com ops) = runP parseMod toks False EmptyMap (MkFC fn (0,0))
+  let (OK a toks com ops) = runP parseMod toks False emptyMap (MkFC fn (0,0))
     | fail => debugLog fail
   putStrLn "Module"
   debugLog $ a

tests/Data/SortedMap.newt

@@ -0,0 +1 @@
+../../src/Data/SortedMap.newt

tests/SortedMap.newt

@@ -1 +0,0 @@
-../newt/SortedMap.newt

tests/TestMap.newt

@@ -1,17 +1,17 @@
 module TestMap
 
 import Prelude
-import SortedMap
+import Data.SortedMap
 
 main : IO Unit
 main = do
-  let m = updateMap 2 0 EmptyMap
+  let m = updateMap 2 0 emptyMap
   debugLog $ toList m
   debugLog $ toList $ deleteMap 2 m
   debugLog $ toList $ updateMap 2 3 m
   debugLog $ toList $ updateMap 1 3 m
   let x = 4 :: 1 :: 5 :: 7 :: 2 :: 9 :: 3 :: 10 :: 6 :: 0 :: 11 :: 12 :: 13 :: 20 :: 14 :: 16 :: 17 :: 8 :: Nil
-  let m = foldl (\ m x => updateMap x MkUnit m) EmptyMap x
+  let m = foldl (\ m x => updateMap x MkUnit m) emptyMap x
   debugLog $ toList m
   debugLog $ leftMost m
   debugLog $ rightMost m