Address issues with unify's case tree in idris

Clean up some stuff in prelude
Add parser for where

Makefile

@@ -2,8 +2,7 @@ SRCS=$(shell find src -name "*.idr")
 
 .PHONY:
 
-all: build/exec/newt build/exec/newt.js
+all: build/exec/newt build/exec/newt.js build/exec/newt.min.js
-# build/exec/newt.min.js
 
 build/exec/newt: ${SRCS}
 	idris2 --build newt.ipkg

aoc2023/Lib.newt

@@ -159,4 +159,4 @@ map f (x :: xs) = f x :: map f xs
 
 infixl 9 _∘_
 _∘_ : {A B C : U} -> (B -> C) -> (A -> B) -> A -> C
-(f . g) x = f ( g x)
+(f ∘ g) x = f (g x)

port/Prelude.newt

@@ -109,6 +109,13 @@ instance Functor Maybe where
   map f Nothing = Nothing
   map f (Just a) = Just (f a)
 
+-- TODO this probably should depend on / entail Functor
+infixl 3 _<*>_
+class Applicative (f : U → U) where
+  -- appIsFunctor : Functor f
+  return : {a} → a → f a
+  _<*>_ : {a b} -> f (a → b) → f a → f b
+
 infixr 2 _<|>_
 class Alternative (m : U → U) where
   _<|>_ : {a} → m a → m a → m a
@@ -185,9 +192,17 @@ pfunc alen : {a : U} -> Array a -> Int := "(a,arr) => arr.length"
 pfunc aget : {a : U} -> Array a -> Int -> a := "(a, arr, ix) => arr[ix]"
 pfunc aempty : {a : U} -> Unit -> Array a := "() => []"
 
-
+-- TODO represent Nat as number at runtime
+pfunc natToInt : Nat -> Int := "(n) => {
+  let rval = 0
+  while (n.tag === 'S') {
+    n = n.h0
+    rval++
+  }
+  return rval
+}"
 pfunc fastConcat : List String → String := "(xs) => listToArray(undefined, xs).join('')"
-pfunc replicate : Nat -> Char → String := "() => abort('FIXME replicate')"
+pfunc replicate : Nat -> Char → String := "(n,c) => c.repeat(natToInt(n))"
 
 -- I don't want to use an empty type because it would be a proof of void
 ptype World
@@ -203,7 +218,10 @@ instance Monad IO where
     MkIORes a w => mab a w
   pure a = \ w => MkIORes a w
 
-pfunc putStrLn : String -> IO Unit := "(s) => (w) => console.log(s)"
+pfunc putStrLn : String -> IO Unit := "(s) => (w) => {
+  console.log(s)
+  return MkIORes(Unit,MkUnit,w)
+}"
 
 class Show a where
   show : a → String

port/Prettier.newt

@@ -86,8 +86,8 @@ pretty {{MkPretty p}} x = p x
 render : Nat -> Doc -> String
 render w x = layout (best w Z x) Lin
 
-SemigroupDoc : Semigroup Doc
+instance Semigroup Doc where
-SemigroupDoc = MkSemi (\ x y => Seq x (Seq (Text " ") y))
+  x <+> y = Seq x (Seq (Text " ") y)
 
 -- Match System.File so we don't get warnings
 
@@ -100,9 +100,8 @@ text = Text
 nest : Nat -> Doc -> Doc
 nest = Nest
 
-infixl 7 _++_
+instance Concat Doc where
-_++_ : Doc -> Doc -> Doc
+  x ++ y = Seq x y
-x ++ y = Seq x y
 
 infixl 5 _</>_
 _</>_ : Doc -> Doc -> Doc

port/TestPrettier.newt

@@ -17,3 +17,4 @@ foo = render fifty doc
 main : IO Unit
 main = do
   putStrLn foo
+  putStrLn $ replicate five 'x'

src/Lib/Compile.idr

@@ -155,7 +155,7 @@ termToJS env (CCase t alts) f =
           (JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
 
 
--- REVIEW the escaping in show might not match JS
+-- FIXME escaping is wrong, e.g. \215 instead of \xd7
 jsString : String -> Doc
 jsString str = text (show str)
 

src/Lib/Elab.idr

@@ -232,6 +232,10 @@ unifySpine env mode True [<] [<] = pure (MkResult [])
 unifySpine env mode True (xs :< x) (ys :< y) = [| unify env mode x y <+> (unifySpine env mode True xs ys) |]
 unifySpine env mode True _ _ = error emptyFC "meta spine length mismatch"
 
+
+
+
+
 unify env mode t u = do
   debug "Unify lvl \{show $ length env}"
   debug "  \{show t}"
@@ -243,67 +247,55 @@ unify env mode t u = do
   debug "env \{show env}"
   -- debug "types \{show $ ctx.types}"
   let l = length env
-  case (mode,t',u') of
+  -- On the LHS, variable matching is yields constraints/substitutions
+  -- We want this to happen before VRefs are expanded, and mixing mode
+  -- into the case tree explodes it further.
+  case mode of
+    Pattern => unifyPattern t' u'
+    Normal => unify' t' u'
 
+  where
+    unify' : Val -> Val -> M UnifyResult
     -- flex/flex
-    (_, VMeta fc k sp,  VMeta fc' k' sp' ) =>
+    unify' (VMeta fc k sp) (VMeta fc' k' sp') =
       if k == k' then unifySpine env mode (k == k') sp sp'
       -- TODO, might want to try the other way, too.
       else if length sp < length sp'
         then solve env k' sp' (VMeta fc k sp) >> pure neutral
         else solve env k sp (VMeta fc' k' sp') >> pure neutral
-    (_, t,           VMeta fc' i' sp') => solve env i' sp' t >> pure neutral
+    unify' t (VMeta fc' i' sp') = solve env i' sp' t >> pure neutral
-    (_, VMeta fc i sp, t'           ) => solve env i sp t' >> pure neutral
+    unify' (VMeta fc i sp) t' = solve env i sp t' >> pure neutral
-    (_, VPi fc _ _ a b, VPi fc' _ _ a' b') => do
+    unify' (VPi fc _ _ a b) (VPi fc' _ _ a' b') = do
-      let fresh = VVar fc l [<]
+      let fresh = VVar fc (length env) [<]
       [| unify env mode a a' <+> unify (fresh :: env) mode !(b $$ fresh) !(b' $$ fresh) |]
-    (_, VVar fc k sp,   (VVar fc' k' sp')  ) =>
+    unify' t'@(VVar fc k sp)  u'@(VVar fc' k' sp')  =
       if k == k' then unifySpine env mode (k == k') sp sp'
-      else case (mode, sp, sp') of
+      else error fc "Failed to unify \{show t'} and \{show u'}"
-        (Pattern, [<],[<]) => if k < k' then pure $ MkResult [(k,u')] else pure $ MkResult [(k',t')]
-        _ => error fc "Failed to unify \{show t'} and \{show u'}"
 
     -- we don't eta expand on LHS
-    (Normal, VLam fc _ t,  VLam _ _ t') => do
+    unify' (VLam fc _ t)  (VLam _ _ t') = do
-      let fresh = VVar fc l [<]
+      let fresh = VVar fc (length env) [<]
       unify (fresh :: env) mode !(t $$ fresh) !(t' $$ fresh)
-    (Normal, t,         VLam fc' _ t') => do
+    unify' t         (VLam fc' _ t') = do
       debug "ETA \{show t}"
-      let fresh = VVar fc' l [<]
+      let fresh = VVar fc' (length env) [<]
       unify (fresh :: env) mode !(t `vapp` fresh) !(t' $$ fresh)
-    (Normal, VLam fc _ t,  t'       ) => do
+    unify' (VLam fc _ t)  t'     = do
       debug "ETA' \{show t'}"
-      let fresh = VVar fc l [<]
+      let fresh = VVar fc (length env) [<]
       unify (fresh :: env) mode !(t $$ fresh) !(t' `vapp` fresh)
 
-
     -- We only want to do this for LHS pattern vars, otherwise, try expanding
-    (_, VVar fc k [<], u) => case mode of
+    unify' t'@(VVar fc k [<]) u = case !(tryEval env u) of
-      Pattern => pure $ MkResult[(k, u)]
-      Normal => case !(tryEval env u) of
         Just v => unify env mode t' v
-        Nothing => error fc "Failed to unify \{show t'} and \{show u'}"
+        Nothing => error fc "Failed to unify \{show t'} and \{show u}"
 
-    (_,t, VVar fc k [<]) => case mode of
+    unify' t u'@(VVar fc k [<]) = case !(tryEval env t) of
-      Pattern => pure $ MkResult[(k, t)]
-      Normal => case !(tryEval env t) of
         Just v => unify env mode v u'
-        Nothing => error fc "Failed to unify \{show t'} and \{show u'}"
+        Nothing => error fc "Failed to unify \{show t} and \{show u'}"
-
-    (_, VLam fc _ t,  VLam _ _ t') =>
-      let fresh = VVar fc l [<] in
-      unify (fresh :: env) mode !(t $$ fresh) !(t' $$ fresh)
-    (_, t,         VLam fc' _ t') => do
-      debug "ETA \{show t}"
-      let fresh = VVar fc' l [<]
-      unify (fresh :: env) mode !(t `vapp` fresh) !(t' $$ fresh)
-    (_, VLam fc _ t,  t'       ) => do
-      debug "ETA' \{show t'}"
-      let fresh = VVar fc l [<]
-      unify (fresh :: env) mode !(t $$ fresh) !(t' `vapp` fresh)
 
     -- REVIEW - consider separate value for DCon/TCon
-    (_, VRef fc k def sp,  VRef fc' k' def' sp') =>
+    unify' t'@(VRef fc k def sp)  u'@(VRef fc' k' def' sp') =
       -- unifySpine is a problem for cmp (S x) (S y) =?= cmp x y
         do
         -- catchError {e = Error} (unifySpine env mode (k == k') sp sp') $ \ err => do
@@ -317,23 +309,34 @@ unify env mode t u = do
               then unifySpine env mode (k == k') sp sp'
               else error fc "vref mismatch \{show t'} \{show u'}"
 
-    (_, VU _, VU _) => pure neutral
+    unify' (VU _) (VU _) = pure neutral
     -- Lennart.newt cursed type references itself
     -- We _could_ look up the ref, eval against [] and vappSpine...
-    (_, t,         VRef fc' k' def sp') => do
+    unify' t         u@(VRef fc' k' def sp') = do
       debug "expand \{show t} =?= %ref \{k'}"
       case lookup k' !(get) of
         Just (MkEntry name ty (Fn tm)) => unify env mode t !(vappSpine !(eval [] CBN tm) sp')
-        _ => error fc' "unify failed \{show t'} =?= \{show u'} [no Fn]\n  env is \{show env}"
+        _ => error fc' "unify failed \{show t} =?= \{show u} [no Fn]\n  env is \{show env}"
 
-    (_, VRef fc k def sp, u) => do
+    unify' t@(VRef fc k def sp) u = do
       debug "expand %ref \{k} \{show sp} =?= \{show u}"
       case lookup k !(get) of
         Just (MkEntry name ty (Fn tm)) => unify env mode !(vappSpine !(eval [] CBN tm) sp) u
-        _ => error fc "unify failed \{show t'} [no Fn] =?= \{show u'}\n  env is \{show env}"
+        _ => error fc "unify failed \{show t} [no Fn] =?= \{show u}\n  env is \{show env}"
 
     -- REVIEW I'd like to quote this back, but we have l that aren't in the environment.
-    _ => error (getFC t') "unify failed \{show t'} =?= \{show u'} \n  env is \{show env}"
+    unify' t' u' = error (getFC t') "unify failed \{show t'} =?= \{show u'} \n  env is \{show env}"
+
+    unifyPattern : Val -> Val -> M UnifyResult
+    unifyPattern t'@(VVar fc k sp)  u'@(VVar fc' k' sp')  =
+      if k == k' then unifySpine env mode (k == k') sp sp'
+      else case (sp, sp') of
+        ([<],[<]) => if k < k' then pure $ MkResult [(k,u')] else pure $ MkResult [(k',t')]
+        _ => error fc "Failed to unify \{show t'} and \{show u'}"
+
+    unifyPattern (VVar fc k [<]) u = pure $ MkResult[(k, u)]
+    unifyPattern t (VVar fc k [<]) = pure $ MkResult [(k, t)]
+    unifyPattern t u = unify' t u
 
 export
 unifyCatch : FC -> Context -> Val -> Val -> M ()

src/Lib/Parser.idr

@@ -366,6 +366,10 @@ parseDef = do
   pats <- many patAtom
   keyword "="
   body <- typeExpr
+  w <- optional $ do
+    keyword "where"
+    startBlock $ manySame $ (parseSig <|> parseDef)
+
   -- these get collected later
   pure $ Def fc nm [(t, body)] -- [MkClause fc [] t body]
 

src/Lib/ProcessDecl.idr

@@ -50,7 +50,6 @@ findMatches ctx ty ((MkEntry name type def) :: xs) = do
       debug "No match \{show ty} \{pprint [] type} \{showError "" err}"
       writeIORef top.metas mc
       findMatches ctx ty xs)
-findMatches ctx ty (y :: xs) = findMatches ctx ty xs
 
 contextMatches : Context -> Val -> M (List (Tm, MetaContext))
 contextMatches ctx ty = go (zip ctx.env (toList ctx.types))