diff --git a/TODO.md b/TODO.md index c168ea4..9426813 100644 --- a/TODO.md +++ b/TODO.md @@ -1,17 +1,19 @@ ## TODO +- [ ] Add icit to Lam (see `check` for details) - [ ] TCO? Probably needed in browser, since v8 doesn't do it. bun and JavaScriptCore do support it. -- [ ] Fix string printing to be js instead of weird Idris strings +- [x] Fix string printing to be js instead of weird Idris strings - [ ] make $ special - Makes inference easier, cleaner output, and allows `foo $ \ x => ...` - remove hack from Elab.infer - [ ] Support @ on the LHS - [ ] records -- [ ] `Inhabited (List a)` isn't solving if I have `instance ∀ a. Inhabited (List a)` - [ ] rework unify case tree - Idris needs help with the case tree to keep code size down, do it in stages, one dcon at a time. - [ ] Strategy to avoid three copies of `Prelude.newt` in this source tree +- [ ] `mapM` needs inference help when scrutinee (see Day2.newt) +- [ ] Can't skip an auto. We need `{{_}}` to be auto or `%search` syntax. - [x] add filenames to FC - [x] maybe use backtick for javascript so we don't highlight strings as JS - [ ] add namespaces @@ -85,6 +87,7 @@ - [x] there is some zero argument application in generated code - [x] get equality.newt to work - [x] broken again because I added J, probably need to constrain scrutinee to value +- [ ] Bad FC for missing case in where clause (probably from ctx) - [x] inline metas. Maybe zonk after TC/elab - [x] implicit patterns - [x] operators @@ -140,3 +143,15 @@ - [ ] Name space flattening makes it a bit more subtle when a misspelled (or shadowed) constructor turns into a variable. +### Error Messages + +Missing `Monad Maybe` looks like: +``` +Unsolved meta 358 Normal type U 0 constraints +Unsolved meta 356 Auto type Monad (?m:355 s:0) 0 constraints +Unsolved meta 355 Normal type U -> U 2 constraints + * (m355 (%var0 (List (%meta 358 [1 sp]))) =?= (Maybe (List Card)) + * (m355 (%var0 (%meta 358 [1 sp])) =?= (Maybe Card) +``` +There is some information here, but it's obtuse. One issue is that I'm taking an Agda-inspired approach to search (try every option and see if exactly one works with our constraints) rather than Idris (assume the determinant on an interface is injective and solve `m344 %var0` with `Maybe`). + diff --git a/aoc2023/Day2.newt b/aoc2023/Day2.newt index 3b15a2b..2fda72e 100644 --- a/aoc2023/Day2.newt +++ b/aoc2023/Day2.newt @@ -21,14 +21,6 @@ pfunc repr : {a : U} -> a -> String := `(a,o) => ''+o` pfunc jrepr : {a : U} -> a -> String := `(a,o) => JSON.stringify(o, null, ' ')` pfunc toInt : String -> Int := `s => Number(s)` -mapM : ∀ a b c. (a -> Either b c) -> List a -> Either b (List c) -mapM f Nil = Right Nil -mapM f (x :: xs) = case f x of - Left msg => Left msg - Right v => case mapM f xs of - Left msg => Left msg - Right vs => Right $ v :: vs - maxd : Draw -> Draw -> Draw maxd (a,b,c) (d,e,f) = (max a d, max b e, max c f) @@ -42,10 +34,12 @@ parseColor line = case split line " " of (n :: "blue" :: Nil) => Right (0,0,toInt n) x => Left $ "Bad draw" ++ repr x +-- FIXME implicit isn't being solved in time here. parseDraw : String -> Either String Draw -parseDraw line = case mapM parseColor $ split line ", " of - Right parts => Right $ foldl maxd (0,0,0) parts - Left err => Left err +parseDraw line = + case mapM {Either String} parseColor $ split line ", " of + Right parts => Right $ foldl maxd (0,0,0) parts + Left err => Left err parseGame : String -> Either String Game parseGame line = @@ -55,7 +49,7 @@ parseGame line = (a :: b :: Nil) => case split a " " of ("Game" :: ns :: Nil) => let num = toInt ns in - case mapM parseDraw $ split b "; " of + case mapM {Either String} parseDraw $ split b "; " of Right parts => Right $ MkGame num parts Left err => Left err _ => Left "No Game" @@ -79,7 +73,7 @@ run : String -> IO Unit run fn = do putStrLn fn text <- readFile fn - case mapM parseGame (split (trim text) "\n") of + case mapM {Either String} parseGame (split (trim text) "\n") of Left err => putStrLn $ "fail " ++ err Right games => do putStrLn "part1" diff --git a/aoc2023/Day3.newt b/aoc2023/Day3.newt index 9c08ea8..a4566bd 100644 --- a/aoc2023/Day3.newt +++ b/aoc2023/Day3.newt @@ -6,7 +6,6 @@ import Node pfunc repr : {a : U} -> a -> String := `(a,o) => ''+o` pfunc jrepr : {a : U} -> a -> String := `(a,o) => JSON.stringify(o, null, ' ')` -pfunc trace : ∀ a. String -> a -> a := `(_, msg, a) => { console.log(msg,debugStr(_,a)); return a }` maybe : ∀ a b. b → (a → b) → Maybe a → b maybe def f Nothing = def diff --git a/aoc2023/Day4.newt b/aoc2023/Day4.newt new file mode 100644 index 0000000..534a8d7 --- /dev/null +++ b/aoc2023/Day4.newt @@ -0,0 +1,67 @@ +module Day4 + +import Prelude +import Node + +Round : U +Round = List Int × List Int + +parseRound : String → Maybe Round +parseRound s = + case split s ": " of + (a :: b :: Nil) => case split b " | " of + (l :: r :: Nil) => Just (nums l, nums r) + _ => Nothing + _ => Nothing + where + -- Nat or Int here? + nums : String → List Int + -- catch - split returns empty strings that become zeros + nums s = map stringToInt $ filter (_/=_ "") $ split (trim s) " " + +parse : String -> Maybe (List Round) +parse s = mapM parseRound (split (trim s) "\n") + +pfunc pow : Int → Int → Int := `(x,y) => x ** y` + +part1 : List Round → Int +part1 rounds = foldl _+_ 0 $ map score rounds + where + -- TODO we'll keep the math in Int land until we have magic Nat + score : Round → Int + score (a,b) = let count = natToInt $ length $ filter (\ n => elem n b) a + in if count == 0 then 0 else pow 2 (count - 1) + +part2 : List Round → Int +part2 rounds = go 0 $ map (_,_ 1) rounds + where + mark : Int -> Nat → List (Int × Round) → List (Int × Round) + mark _ _ Nil = Nil + mark v Z rounds = rounds + mark v (S k) ((cnt, round) :: rounds) = (cnt + v, round) :: mark v k rounds + + go : Int → List (Int × Round) → Int + go acc Nil = acc + go acc ((cnt, a, b) :: rounds) = + let n = length $ filter (\ n => elem n b) a + in go (acc + cnt) $ mark cnt n rounds + +run : String -> IO Unit +run fn = do + putStrLn fn + text <- readFile fn + + case parse text of + Nothing => putStrLn "fail" + Just cards => do + putStrLn "part1" + printLn (part1 cards) + putStrLn "part2" + printLn (part2 cards) + +-- 13/30 +-- 25004/14427616 +main : IO Unit +main = do + run "aoc2023/day4/eg.txt" + run "aoc2023/day4/input.txt" diff --git a/aoc2023/Prelude.newt b/aoc2023/Prelude.newt index 001235e..429791e 100644 --- a/aoc2023/Prelude.newt +++ b/aoc2023/Prelude.newt @@ -26,6 +26,10 @@ infixl 6 _==_ class Eq a where _==_ : a → a → Bool +infixl 6 _/=_ +_/=_ : ∀ a. {{Eq a}} → a → a → Bool +a /= b = not (a == b) + data Nat : U where Z : Nat S : Nat -> Nat @@ -159,6 +163,14 @@ class Applicative (f : U → U) where return : {0 a} → a → f a _<*>_ : {0 a b} -> f (a → b) → f a → f b +class Traversable (t : U → U) where + traverse : {f : U → U} → {{appf : Applicative f}} → {a : U} → {b : U} → (a → f b) → t a → f (t b) + +instance Applicative Maybe where + return a = Just a + Nothing <*> _ = Nothing + Just f <*> fa = f <$> fa + infixr 2 _<|>_ class Alternative (m : U → U) where _<|>_ : {0 a} → m a → m a → m a @@ -306,6 +318,21 @@ instance Monad List where bind Nil amb = Nil bind (x :: xs) amb = amb x ++ bind xs amb + + +-- This is traverse, but we haven't defined Traversable yet +mapA : ∀ m. {{Applicative m}} {0 a b} → (a → m b) → List a → m (List b) +mapA f Nil = return Nil +mapA f (x :: xs) = return _::_ <*> f x <*> mapA f xs + + +mapM : ∀ m. {{Monad m}} {0 a b} → (a → m b) → List a → m (List b) +mapM f Nil = pure Nil +mapM f (x :: xs) = do + b <- f x + bs <- mapM f xs + pure (b :: bs) + class HasIO (m : U -> U) where liftIO : ∀ a. IO a → m a @@ -483,3 +510,30 @@ getAt! : ∀ a. {{Inhabited a}} → Nat → List a → a getAt! _ Nil = default getAt! Z (x :: xs) = x getAt! (S k) (x :: xs) = getAt! k xs + + +instance ∀ a. Applicative (Either a) where + return b = Right b + Right x <*> Right y = Right (x y) + Left x <*> _ = Left x + Right x <*> Left y = Left y + +instance ∀ a. Monad (Either a) where + pure x = Right x + bind (Right x) mab = mab x + bind (Left x) mab = Left x + +instance Monad Maybe where + pure x = Just x + bind Nothing mab = Nothing + bind (Just x) mab = mab x + + +elem : ∀ a. {{Eq a}} → a → List a → Bool +elem v Nil = False +elem v (x :: xs) = if v == x then True else elem v xs + +-- TODO no empty value on my `Add`, I need a group.. +-- sum : ∀ a. {{Add a}} → List a → a +-- sum xs = foldl _+_ +pfunc trace uses (debugStr) : ∀ a. String -> a -> a := `(_, msg, a) => { console.log(msg,debugStr(_,a)); return a }` diff --git a/aoc2023/day4/eg.txt b/aoc2023/day4/eg.txt new file mode 100644 index 0000000..9bdb874 --- /dev/null +++ b/aoc2023/day4/eg.txt @@ -0,0 +1,6 @@ +Card 1: 41 48 83 86 17 | 83 86 6 31 17 9 48 53 +Card 2: 13 32 20 16 61 | 61 30 68 82 17 32 24 19 +Card 3: 1 21 53 59 44 | 69 82 63 72 16 21 14 1 +Card 4: 41 92 73 84 69 | 59 84 76 51 58 5 54 83 +Card 5: 87 83 26 28 32 | 88 30 70 12 93 22 82 36 +Card 6: 31 18 13 56 72 | 74 77 10 23 35 67 36 11 diff --git a/playground/samples/Day2.newt b/playground/samples/Day2.newt index fe68aeb..7c45184 100644 --- a/playground/samples/Day2.newt +++ b/playground/samples/Day2.newt @@ -26,14 +26,6 @@ pfunc repr : {a : U} -> a -> String := `(a,o) => ''+o` pfunc jrepr : {a : U} -> a -> String := `(a,o) => JSON.stringify(o, null, ' ')` pfunc toInt : String -> Int := `s => Number(s)` -mapM : ∀ a b c. (a -> Either b c) -> List a -> Either b (List c) -mapM f Nil = Right Nil -mapM f (x :: xs) = case f x of - Left msg => Left msg - Right v => case mapM f xs of - Left msg => Left msg - Right vs => Right $ v :: vs - maxd : Draw -> Draw -> Draw maxd (a,b,c) (d,e,f) = (max a d, max b e, max c f) @@ -48,7 +40,7 @@ parseColor line = case split line " " of x => Left $ "Bad draw" ++ repr x parseDraw : String -> Either String Draw -parseDraw line = case mapM parseColor $ split line ", " of +parseDraw line = case mapM {Either String} parseColor $ split line ", " of Right parts => Right $ foldl maxd (0,0,0) parts Left err => Left err @@ -60,7 +52,7 @@ parseGame line = (a :: b :: Nil) => case split a " " of ("Game" :: ns :: Nil) => let num = toInt ns in - case mapM parseDraw $ split b "; " of + case mapM {Either String} parseDraw $ split b "; " of Right parts => Right $ MkGame num parts Left err => Left err _ => Left "No Game" @@ -85,7 +77,7 @@ part2 (MkGame n parts :: rest) = run : String -> Async Unit run fn = do text <- fetchText fn - case mapM parseGame (split (trim text) "\n") of + case mapM {Either String} parseGame (split (trim text) "\n") of Left err => putStrLn $ "fail " ++ err Right games => do putStrLn "part1" diff --git a/playground/samples/Prelude.newt b/playground/samples/Prelude.newt index 001235e..429791e 100644 --- a/playground/samples/Prelude.newt +++ b/playground/samples/Prelude.newt @@ -26,6 +26,10 @@ infixl 6 _==_ class Eq a where _==_ : a → a → Bool +infixl 6 _/=_ +_/=_ : ∀ a. {{Eq a}} → a → a → Bool +a /= b = not (a == b) + data Nat : U where Z : Nat S : Nat -> Nat @@ -159,6 +163,14 @@ class Applicative (f : U → U) where return : {0 a} → a → f a _<*>_ : {0 a b} -> f (a → b) → f a → f b +class Traversable (t : U → U) where + traverse : {f : U → U} → {{appf : Applicative f}} → {a : U} → {b : U} → (a → f b) → t a → f (t b) + +instance Applicative Maybe where + return a = Just a + Nothing <*> _ = Nothing + Just f <*> fa = f <$> fa + infixr 2 _<|>_ class Alternative (m : U → U) where _<|>_ : {0 a} → m a → m a → m a @@ -306,6 +318,21 @@ instance Monad List where bind Nil amb = Nil bind (x :: xs) amb = amb x ++ bind xs amb + + +-- This is traverse, but we haven't defined Traversable yet +mapA : ∀ m. {{Applicative m}} {0 a b} → (a → m b) → List a → m (List b) +mapA f Nil = return Nil +mapA f (x :: xs) = return _::_ <*> f x <*> mapA f xs + + +mapM : ∀ m. {{Monad m}} {0 a b} → (a → m b) → List a → m (List b) +mapM f Nil = pure Nil +mapM f (x :: xs) = do + b <- f x + bs <- mapM f xs + pure (b :: bs) + class HasIO (m : U -> U) where liftIO : ∀ a. IO a → m a @@ -483,3 +510,30 @@ getAt! : ∀ a. {{Inhabited a}} → Nat → List a → a getAt! _ Nil = default getAt! Z (x :: xs) = x getAt! (S k) (x :: xs) = getAt! k xs + + +instance ∀ a. Applicative (Either a) where + return b = Right b + Right x <*> Right y = Right (x y) + Left x <*> _ = Left x + Right x <*> Left y = Left y + +instance ∀ a. Monad (Either a) where + pure x = Right x + bind (Right x) mab = mab x + bind (Left x) mab = Left x + +instance Monad Maybe where + pure x = Just x + bind Nothing mab = Nothing + bind (Just x) mab = mab x + + +elem : ∀ a. {{Eq a}} → a → List a → Bool +elem v Nil = False +elem v (x :: xs) = if v == x then True else elem v xs + +-- TODO no empty value on my `Add`, I need a group.. +-- sum : ∀ a. {{Add a}} → List a → a +-- sum xs = foldl _+_ +pfunc trace uses (debugStr) : ∀ a. String -> a -> a := `(_, msg, a) => { console.log(msg,debugStr(_,a)); return a }` diff --git a/src/Lib/Elab.idr b/src/Lib/Elab.idr index 38640fc..befcfbf 100644 --- a/src/Lib/Elab.idr +++ b/src/Lib/Elab.idr @@ -944,16 +944,6 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of (t@(RLam _ (BI fc nm icit quant) tm), ty) => error fc "Expected pi type, got \{!(prvalCtx ty)}" - (tm, ty@(VPi fc nm' Implicit rig a b)) => do - let names = toList $ map fst ctx.types - debug "XXX edge case add implicit lambda {\{nm'} : \{show a}} to \{show tm} " - let var = VVar fc (length ctx.env) [<] - ty' <- b $$ var - debugM $ pure "XXX ty' is \{!(prvalCtx {ctx=(extend ctx nm' a)} ty')}" - sc <- check (extend ctx nm' a) tm ty' - pure $ Lam (getFC tm) nm' sc - - (RImplicit fc, ty) => freshMeta ctx fc ty Normal (RLet fc nm ty v sc, rty) => do ty' <- check ctx ty (VU emptyFC) @@ -964,6 +954,26 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of sc' <- check ctx' sc rty pure $ Let fc nm v' sc' + (RImplicit fc, ty) => freshMeta ctx fc ty Normal + + (tm, ty@(VPi fc nm' Implicit rig a b)) => do + let names = toList $ map fst ctx.types + debug "XXX edge case add implicit lambda {\{nm'} : \{show a}} to \{show tm} " + let var = VVar fc (length ctx.env) [<] + ty' <- b $$ var + debugM $ pure "XXX ty' is \{!(prvalCtx {ctx=(extend ctx nm' a)} ty')}" + sc <- check (extend ctx nm' a) tm ty' + pure $ Lam (getFC tm) nm' sc + + (tm, ty@(VPi fc nm' Auto rig a b)) => do + let names = toList $ map fst ctx.types + debug "XXX edge case add auto lambda {\{nm'} : \{show a}} to \{show tm} " + let var = VVar fc (length ctx.env) [<] + ty' <- b $$ var + debugM $ pure "XXX ty' is \{!(prvalCtx {ctx=(extend ctx nm' a)} ty')}" + sc <- check (extend ctx nm' a) tm ty' + pure $ Lam (getFC tm) nm' sc + (tm,ty) => do -- We need to insert if tm is not an Implicit Lam -- assuming all of the implicit ty have been handled above @@ -972,8 +982,10 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of -- Kovacs doesn't insert on tm = Implicit Lam, we don't have Plicity in Lam -- so I'll check the inferred type for an implicit pi -- This seems wrong, the ty' is what insert runs on, so we're just short circuiting here - (tm'@(Lam{}), ty'@(VPi _ _ Implicit rig _ _)) => do debug "CheckMe 1"; pure (tm', ty') - (tm'@(Lam{}), ty'@(VPi _ _ Auto rig _ _)) => do debug "CheckMe 2"; pure (tm', ty') + + -- REVIEW - I think we need icit on Lam, check that they match and drop the two "edge" above? + -- (tm'@(Lam{}), ty'@(VPi _ _ Implicit rig _ _)) => do debug "CheckMe 1"; pure (tm', ty') + -- (tm'@(Lam{}), ty'@(VPi _ _ Auto rig _ _)) => do debug "CheckMe 2"; pure (tm', ty') (tm', ty') => do debug "RUN INSERT ON \{pprint names tm'} at \{show ty'}" insert ctx tm' ty' @@ -1009,7 +1021,7 @@ infer ctx (RApp fc t u icit) = do pure (Auto, t, tty) (a,b) <- case !(forceMeta tty) of - (VPi fc str icit' rig a b) => if icit' == icit then pure (a,b) + (VPi fc' str icit' rig a b) => if icit' == icit then pure (a,b) else error fc "IcitMismatch \{show icit} \{show icit'}" -- If it's not a VPi, try to unify it with a VPi diff --git a/src/Lib/Types.idr b/src/Lib/Types.idr index 752acea..5b48205 100644 --- a/src/Lib/Types.idr +++ b/src/Lib/Types.idr @@ -525,7 +525,7 @@ freshMeta : Context -> FC -> Val -> MetaKind -> M Tm freshMeta ctx fc ty kind = do top <- get mc <- readIORef top.metas - debug "fresh meta \{show mc.next} : \{show ty}" + debug "fresh meta \{show mc.next} : \{show ty} (\{show kind})" writeIORef top.metas $ { next $= S, metas $= (Unsolved fc mc.next ctx ty kind [] ::) } mc pure $ applyBDs 0 (Meta fc mc.next) ctx.bds where