dunham/newt
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Preliminary work on autos

Browse Source
This commit is contained in:
Steve Dunham
2024-10-25 21:07:12 -07:00
parent ec1f58a071
commit e1ef6b5ee5
9 changed files with 107 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Lib/CompileExp.idr
View File

@@ -93,7 +93,7 @@ compileTerm tm@(App _ _ _) with (funArgs tm)
-- apply (CRef "Meta\{show k}") args' [<] 0
arity <- case meta of
-- maybe throw
(Unsolved x j ctx _) => pure 0 -- FIXME # of Bound in ctx.bds
(Unsolved x j ctx _ _) => pure 0 -- FIXME # of Bound in ctx.bds
(Solved j tm) => pure $ getArity !(quote 0 tm)
apply (CRef "Meta\{show k}") args' [<] arity
_ | (t@(Ref fc nm _), args) = do

67
src/Lib/Elab.idr
View File

@@ -53,7 +53,7 @@ lookupDef ctx name = go 0 ctx.types ctx.env
export
forceMeta : Val -> M Val
forceMeta (VMeta fc ix sp) = case !(lookupMeta ix) of
(Unsolved pos k xs _) => pure (VMeta fc ix sp)
(Unsolved pos k xs _ _) => pure (VMeta fc ix sp)
(Solved k t) => vappSpine t sp >>= forceMeta
forceMeta x = pure x
@@ -70,7 +70,7 @@ tryEval k sp =
-- Lennart needed more forcing for recursive nat,
forceType : Val -> M Val
forceType (VMeta fc ix sp) = case !(lookupMeta ix) of
(Unsolved x k xs _) => pure (VMeta fc ix sp)
(Unsolved x k xs _ _) => pure (VMeta fc ix sp)
(Solved k t) => vappSpine t sp >>= forceType
forceType x = pure x
@@ -141,7 +141,7 @@ parameters (ctx: Context)
solve : Nat -> Nat -> SnocList Val -> Val -> M ()
solve l m sp t = do
debug "solve \{show m} lvl \{show l} sp \{show sp} is \{show t}"
meta@(Unsolved metaFC ix ctx ty) <- lookupMeta m
meta@(Unsolved metaFC ix ctx ty _) <- lookupMeta m
| _ => error (getFC t) "Meta \{show m} already solved!"
let size = length $ filter (\x => x == Bound) $ toList ctx.bds
debug "\{show m} size is \{show size}"
@@ -297,8 +297,15 @@ unifyCatch fc ctx ty' ty = do
insert : (ctx : Context) -> Tm -> Val -> M (Tm, Val)
insert ctx tm ty = do
case !(forceMeta ty) of
VPi fc x Auto a b => do
-- FIXME mark meta as auto, maybe try to solve here?
m <- freshMeta ctx (getFC tm) a AutoSolve
debug "INSERT Auto \{pprint (names ctx) m} : \{show a}"
debug "TM \{pprint (names ctx) tm}"
mv <- eval ctx.env CBN m
insert ctx (App (getFC tm) tm m) !(b $$ mv)
VPi fc x Implicit a b => do
m <- freshMeta ctx (getFC tm) a
m <- freshMeta ctx (getFC tm) a Normal
debug "INSERT \{pprint (names ctx) m} : \{show a}"
debug "TM \{pprint (names ctx) tm}"
mv <- eval ctx.env CBN m
@@ -346,9 +353,11 @@ introClause : String -> Icit -> Clause -> M Clause
introClause nm icit (MkClause fc cons (pat :: pats) expr) =
if icit == getIcit pat then pure $ MkClause fc ((nm, pat) :: cons) pats expr
else if icit == Implicit then pure $ MkClause fc ((nm, PatWild fc Implicit) :: cons) (pat :: pats) expr
else error fc "Explicit arg and implicit pattern \{show nm} \{show icit} \{show pat}"
else if icit == Auto then pure $ MkClause fc ((nm, PatWild fc Auto) :: cons) (pat :: pats) expr
else error fc "Explicit arg and \{show $ getIcit pat} pattern \{show nm} \{show pat}"
-- handle implicts at end?
introClause nm Implicit (MkClause fc cons [] expr) = pure $ MkClause fc ((nm, PatWild fc Implicit) :: cons) [] expr
introClause nm Auto (MkClause fc cons [] expr) = pure $ MkClause fc ((nm, PatWild fc Auto) :: cons) [] expr
introClause nm icit (MkClause fc cons [] expr) = error fc "Clause size doesn't match"
-- A split candidate looks like x /? Con ...
@@ -542,17 +551,21 @@ buildCase ctx prob scnm scty (dcName, arity, ty) = do
-- We get a list of clauses back (a Problem) and then solve that
-- If they all fail, we have a coverage issue. (Assuming the constructor is valid)
makeConst : List Bind -> List Pattern -> List (String, Pattern)
makeConst [] [] = []
makeConstr : List Bind -> List Pattern -> List (String, Pattern)
makeConstr [] [] = []
-- would need M in here to throw, and I'm building stuff as I go, I suppose I could <$>
makeConst [] (pat :: pats) = ?extra_patterns
makeConst ((MkBind nm Implicit x) :: xs) [] = (nm, PatWild emptyFC Implicit) :: makeConst xs []
makeConst ((MkBind nm Explicit x) :: xs) [] = ?extra_binders_2
makeConst ((MkBind nm Implicit x) :: xs) (pat :: pats) =
makeConstr [] (pat :: pats) = ?extra_patterns
makeConstr ((MkBind nm Implicit x) :: xs) [] = (nm, PatWild emptyFC Implicit) :: makeConstr xs []
makeConstr ((MkBind nm Auto x) :: xs) [] = (nm, PatWild emptyFC Auto) :: makeConstr xs []
makeConstr ((MkBind nm Explicit x) :: xs) [] = ?extra_binders_2
makeConstr ((MkBind nm Explicit x) :: xs) (pat :: pats) =
if getIcit pat == Explicit
then (nm, PatWild (getFC pat) Implicit) :: makeConst xs (pat :: pats)
else (nm, pat) :: makeConst xs pats
makeConst ((MkBind nm Explicit x) :: xs) (pat :: pats) = (nm, pat) :: makeConst xs pats
then (nm, pat) :: makeConstr xs pats
else ?explict_implicit_mismatch
makeConstr ((MkBind nm icit x) :: xs) (pat :: pats) =
if getIcit pat /= icit -- Implicit/Explicit Implicit/Auto, etc
then (nm, PatWild (getFC pat) icit) :: makeConstr xs (pat :: pats)
else (nm, pat) :: makeConstr xs pats
-- replace constraint with constraints on parameters, or nothing if non-matching clause
rewriteConstraint : List Bind -> List Constraint -> List Constraint -> Maybe (List Constraint)
@@ -564,7 +577,7 @@ buildCase ctx prob scnm scty (dcName, arity, ty) = do
PatWild _ _ => Just $ c :: (xs ++ acc)
PatLit fc lit => Nothing -- error fc "Literal \{show lit} in constructor split"
PatCon _ _ str ys => if str == dcName
then Just $ (makeConst vars ys) ++ xs ++ acc
then Just $ (makeConstr vars ys) ++ xs ++ acc
else Nothing
else rewriteConstraint vars xs (c :: acc)
@@ -791,7 +804,7 @@ check ctx tm ty = case (tm, !(forceType ty)) of
let ctx' = extend ctx nm a
tm' <- check ctx' tm !(b $$ var)
pure $ Lam fc nm tm'
else if icit' == Implicit then do
else if icit' /= Explicit then do
let var = VVar fc (length ctx.env) [<]
ty' <- b $$ var
-- use nm' here if we want them automatically in scope
@@ -804,7 +817,7 @@ check ctx tm ty = case (tm, !(forceType ty)) of
(tm, ty@(VPi fc nm' Implicit a b)) => do
let names = toList $ map fst ctx.types
debug "XXX edge add implicit lambda {\{nm'} : \{show a}} to \{show tm} "
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')}"
@@ -825,9 +838,11 @@ check ctx tm ty = case (tm, !(forceType ty)) of
-- assuming all of the implicit ty have been handled above
let names = toList $ map fst ctx.types
(tm', ty') <- case !(infer ctx tm) of
-- Kovacs doesn't insert on tm = Implicit Lam, we don't have Plicity there
-- 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
(tm'@(Lam{}), ty'@(VPi _ _ Implicit _ _)) => do debug "Lambda"; pure (tm', ty')
-- This seems wrong, the ty' is what insert runs on, so we're just short circuiting here
(tm'@(Lam{}), ty'@(VPi _ _ Implicit _ _)) => do debug "CheckMe 1"; pure (tm', ty')
(tm'@(Lam{}), ty'@(VPi _ _ Auto _ _)) => do debug "CheckMe 2"; pure (tm', ty')
(tm', ty') => do
debug "RUN INSERT ON \{pprint names tm'} at \{show ty'}"
insert ctx tm' ty'
@@ -848,6 +863,7 @@ infer ctx (RVar fc nm) = go 0 ctx.types
else go (i + 1) xs
-- need environment of name -> type..
infer ctx (RApp fc t u icit) = do
-- If the app is explicit, add any necessary metas
(icit, t, tty) <- case the Icit icit of
Explicit => do
(t, tty) <- infer ctx t
@@ -856,6 +872,9 @@ infer ctx (RApp fc t u icit) = do
Implicit => do
(t, tty) <- infer ctx t
pure (Implicit, t, tty)
Auto => do
(t, tty) <- infer ctx t
pure (Auto, t, tty)
(a,b) <- case !(forceMeta tty) of
(VPi fc str icit' a b) => if icit' == icit then pure (a,b)
@@ -865,8 +884,8 @@ infer ctx (RApp fc t u icit) = do
-- TODO test case to cover this.
tty => do
debug "unify PI for \{show tty}"
a <- eval ctx.env CBN !(freshMeta ctx fc (VU emptyFC))
b <- MkClosure ctx.env <$> freshMeta (extend ctx ":ins" a) fc (VU emptyFC)
a <- eval ctx.env CBN !(freshMeta ctx fc (VU emptyFC) Normal)
b <- MkClosure ctx.env <$> freshMeta (extend ctx ":ins" a) fc (VU emptyFC) Normal
unifyCatch fc ctx tty (VPi fc ":ins" icit a b)
pure (a,b)
@@ -896,7 +915,7 @@ infer ctx (RAnn fc tm rty) = do
pure (tm, vty)
infer ctx (RLam fc nm icit tm) = do
a <- freshMeta ctx fc (VU emptyFC) >>= eval ctx.env CBN
a <- freshMeta ctx fc (VU emptyFC) Normal >>= eval ctx.env CBN
let ctx' = extend ctx nm a
(tm', b) <- infer ctx' tm
debug "make lam for \{show nm} scope \{pprint (names ctx) tm'} : \{show b}"
@@ -904,9 +923,9 @@ infer ctx (RLam fc nm icit tm) = do
-- error {ctx} [DS "can't infer lambda"]
infer ctx (RImplicit fc) = do
ty <- freshMeta ctx fc (VU emptyFC)
ty <- freshMeta ctx fc (VU emptyFC) Normal
vty <- eval ctx.env CBN ty
tm <- freshMeta ctx fc vty
tm <- freshMeta ctx fc vty Normal
pure (tm, vty)
infer ctx (RLit fc (LString str)) = pure (Lit fc (LString str), !(primType fc "String"))

8
src/Lib/Eval.idr
View File

@@ -94,7 +94,7 @@ eval env mode (App _ t u) = evalSpine env mode t [!(eval env mode u)]
eval env mode (U fc) = pure (VU fc)
eval env mode (Meta fc i) =
case !(lookupMeta i) of
(Unsolved _ k xs _) => pure $ VMeta fc i [<]
(Unsolved _ k xs _ _) => pure $ VMeta fc i [<]
(Solved k t) => pure $ t
eval env mode (Lam fc x t) = pure $ VLam fc x (MkClosure env t)
eval env mode (Pi fc x icit a b) = pure $ VPi fc x icit !(eval env mode a) (MkClosure env b)
@@ -127,7 +127,7 @@ quote l (VVar fc k sp) = if k < l
else ?borken
quote l (VMeta fc i sp) =
case !(lookupMeta i) of
(Unsolved _ k xs _) => quoteSp l (Meta fc i) sp
(Unsolved _ k xs _ _) => quoteSp l (Meta fc i) sp
(Solved k t) => quote l !(vappSpine t sp)
quote l (VLam fc x t) = pure $ Lam fc x !(quote (S l) !(t $$ VVar emptyFC l [<]))
quote l (VPi fc x icit a b) = pure $ Pi fc x icit !(quote l a) !(quote (S l) !(b $$ VVar emptyFC l [<]))
@@ -161,7 +161,7 @@ solveMeta ctx ix tm = do
where
go : List MetaEntry -> SnocList MetaEntry -> M (List MetaEntry)
go [] _ = error' "Meta \{show ix} not found"
go (meta@(Unsolved pos k _ _) :: xs) lhs = if k == ix
go (meta@(Unsolved pos k _ _ _) :: xs) lhs = if k == ix
then do
-- empty context should be ok, because this needs to be closed
putStrLn "INFO at \{show pos}: solve \{show k} as \{!(prval tm)}"
@@ -207,7 +207,7 @@ zonkApp top l env t@(Meta fc k) sp = case !(lookupMeta k) of
foo <- vappSpine v ([<] <>< sp')
debug "-> result is \{show foo}"
quote l foo
(Unsolved x j xs _) => pure $ appSpine t sp
(Unsolved x j xs _ _) => pure $ appSpine t sp
zonkApp top l env t sp = pure $ appSpine !(zonk top l env t) sp
zonkAlt : TopContext -> Nat -> Env -> CaseAlt -> M CaseAlt

32
src/Lib/Parser.idr
View File

@@ -33,6 +33,13 @@ braces pa = do
sym "}"
pure t
dbraces : Parser a -> Parser a
dbraces pa = do
sym "{{"
t <- pa
sym "}}"
pure t
optional : Parser a -> Parser (Maybe a)
optional pa = Just <$> pa <|> pure Nothing
@@ -81,7 +88,9 @@ atom = RU <$> getPos <* keyword "U"
pArg : Parser (Icit,FC,Raw)
pArg = do
fc <- getPos
(Explicit,fc,) <$> atom <|> (Implicit,fc,) <$> braces typeExpr
(Explicit,fc,) <$> atom
<|> (Implicit,fc,) <$> braces typeExpr
<|> (Auto,fc,) <$> dbraces typeExpr
parseApp : Parser Raw
parseApp = do
@@ -137,6 +146,7 @@ letExpr = do
pLetArg : Parser (Icit, String, Maybe Raw)
pLetArg = (Implicit,,) <$> braces (ident <|> uident) <*> optional (sym ":" >> typeExpr)
<|> (Auto,,) <$> dbraces (ident <|> uident) <*> optional (sym ":" >> typeExpr)
<|> (Explicit,,) <$> parens (ident <|> uident) <*> optional (sym ":" >> typeExpr)
<|> (Explicit,,Nothing) <$> (ident <|> uident)
<|> (Explicit,"_",Nothing) <$ keyword "_"
@@ -169,6 +179,9 @@ patAtom = do
<|> braces (PatVar fc Implicit <$> ident)
<|> braces (PatWild fc Implicit <$ keyword "_")
<|> braces (PatCon fc Implicit <$> (uident <|> token MixFix) <*> many patAtom)
<|> dbraces (PatVar fc Auto <$> ident)
<|> dbraces (PatWild fc Auto <$ keyword "_")
<|> dbraces (PatCon fc Auto <$> (uident <|> token MixFix) <*> many patAtom)
<|> parens pPattern
pPattern = PatCon (!getPos) Explicit <$> (uident <|> token MixFix) <*> many patAtom <|> patAtom
@@ -196,11 +209,13 @@ term = caseExpr
<|> lamExpr
<|> parseOp
varname : Parser String
varname = (ident <|> uident <|> keyword "_" *> pure "_")
ebind : Parser (List (FC, String, Icit, Raw))
ebind = do
sym "("
names <- some $ withPos (ident <|> uident)
names <- some $ withPos varname
sym ":"
ty <- typeExpr
sym ")"
@@ -209,18 +224,27 @@ ebind = do
ibind : Parser (List (FC, String, Icit, Raw))
ibind = do
sym "{"
names <- some $ withPos (ident <|> uident)
-- REVIEW - I have name required and type optional, which I think is the opposite of what I expect
names <- some $ withPos varname
ty <- optional (sym ":" >> typeExpr)
sym "}"
pure $ map (\(pos,name) => (pos, name, Implicit, fromMaybe (RImplicit pos) ty)) names
abind : Parser (List (FC, String, Icit, Raw))
abind = do
sym "{{"
names <- some $ withPos varname
ty <- optional (sym ":" >> typeExpr)
sym "}}"
pure $ map (\(pos,name) => (pos, name, Auto, fromMaybe (RImplicit pos) ty)) names
arrow : Parser Unit
arrow = sym "->" <|> sym "→"
-- Collect a bunch of binders (A : U) {y : A} -> ...
binders : Parser Raw
binders = do
binds <- many (ibind <|> try ebind)
binds <- many (abind <|> ibind <|> try ebind)
arrow
scope <- typeExpr
pure $ foldr (uncurry mkBind) scope (join binds)

5
src/Lib/ProcessDecl.idr
View File

@@ -87,7 +87,10 @@ processDecl (Def fc nm clauses) = do
for_ mc.metas $ \case
(Solved k x) => pure ()
(Unsolved (l,c) k ctx ty) => do
(Unsolved (l,c) k ctx ty User) => do
-- TODO print here
pure ()
(Unsolved (l,c) k ctx ty kind) => do
-- should just print, but it's too subtle in the sea of messages
-- we'd also need the ability to mark the whole top context as failure if we continue
-- put a list of errors in TopContext

8
src/Lib/Syntax.idr
View File

@@ -207,6 +207,7 @@ Pretty Raw where
wrap : Icit -> Doc -> Doc
wrap Explicit x = x
wrap Implicit x = text "{" ++ x ++ text "}"
wrap Auto x = text "{{" ++ x ++ text "}}"
par : Nat -> Nat -> Doc -> Doc
par p p' d = if p' < p then text "(" ++ d ++ text ")" else d
@@ -217,12 +218,11 @@ Pretty Raw where
-- This needs precedence and operators...
asDoc p (RApp _ x y Explicit) = par p 2 $ asDoc 2 x <+> asDoc 3 y
asDoc p (RApp _ x y Implicit) = par p 2 $ asDoc 2 x <+> text "{" ++ asDoc 0 y ++ text "}"
asDoc p (RApp _ x y Auto) = par p 2 $ asDoc 2 x <+> text "{{" ++ asDoc 0 y ++ text "}}"
asDoc p (RU _) = text "U"
asDoc p (RPi _ Nothing Explicit ty scope) = par p 1 $ asDoc p ty <+> text "->" <+/> asDoc p scope
asDoc p (RPi _ (Just x) Explicit ty scope) =
par p 1 $ text "(" <+> text x <+> text ":" <+> asDoc p ty <+> text ")" <+> text "->" <+/> asDoc p scope
asDoc p (RPi _ nm Implicit ty scope) =
par p 1 $ text "{" <+> text (fromMaybe "_" nm) <+> text ":" <+> asDoc p ty <+> text "}" <+> text "->" <+/> asDoc 1 scope
asDoc p (RPi _ nm icit ty scope) =
par p 1 $ wrap icit (text (fromMaybe "_" nm) <+> text ":" <+> asDoc p ty ) <+> text "->" <+/> asDoc 1 scope
asDoc p (RLet _ x v ty scope) =
par p 0 $ text "let" <+> text x <+> text ":" <+> asDoc p ty
<+> text "=" <+> asDoc p v

1
src/Lib/Tokenizer.idr
View File

@@ -61,6 +61,7 @@ rawTokens
<|> match (blockComment (exact "/-") (exact "-/")) (Tok Space)
<|> match (exact ",") (Tok Oper)
<|> match (some opChar) checkOp
<|> match (exact "{{" <|> exact "}}") (Tok Keyword)
<|> match symbol (Tok Symbol)
<|> match spaces (Tok Space)

28
src/Lib/Types.idr
View File

@@ -21,7 +21,7 @@ Name : Type
Name = String
public export
data Icit = Implicit | Explicit
data Icit = Implicit | Explicit | Auto
%name Icit icit
@@ -29,6 +29,7 @@ export
Show Icit where
show Implicit = "Implicit"
show Explicit = "Explicit"
show Auto = "Auto"
public export
data BD = Bound | Defined
@@ -137,6 +138,7 @@ Show Tm where
show (U _) = "U"
show (Pi _ str Explicit t u) = "(Pi (\{str} : \{show t}) => \{show u})"
show (Pi _ str Implicit t u) = "(Pi {\{str} : \{show t}} => \{show u})"
show (Pi _ str Auto t u) = "(Pi {{\{str} : \{show t}}} => \{show u})"
show (Case _ sc alts) = "(Case \{show sc} \{show alts})"
show (Let _ nm t u) = "(Let \{nm} \{show t} \{show u})"
@@ -147,6 +149,7 @@ export
Eq Icit where
Implicit == Implicit = True
Explicit == Explicit = True
Auto == Auto = True
_ == _ = False
||| Eq on Tm. We've got deBruijn indices, so I'm not comparing names
@@ -182,6 +185,8 @@ pprint names tm = render 80 $ go names tm
go names (Lam _ nm t) = text "(\\ \{nm} =>" <+> go (nm :: names) t <+> ")"
go names (App _ t u) = text "(" <+> go names t <+> go names u <+> ")"
go names (U _) = "U"
go names (Pi _ nm Auto t u) =
text "({{" <+> text nm <+> ":" <+> go names t <+> "}}" <+> "->" <+> go (nm :: names) u <+> ")"
go names (Pi _ nm Implicit t u) =
text "({" <+> text nm <+> ":" <+> go names t <+> "}" <+> "->" <+> go (nm :: names) u <+> ")"
go names (Pi _ nm Explicit t u) =
@@ -312,7 +317,16 @@ Can I get val back? Do we need to quote? What happens if we don't?
record Context
public export
data MetaEntry = Unsolved FC Nat Context Val | Solved Nat Val
data MetaKind = Normal | User | AutoSolve
public export
Show MetaKind where
show Normal = "Normal"
show User = "User"
show AutoSolve = "Auto"
public export
data MetaEntry = Unsolved FC Nat Context Val MetaKind | Solved Nat Val
public export
@@ -402,7 +416,7 @@ define ctx name val ty =
export
covering
Show MetaEntry where
show (Unsolved pos k ctx ty) = "Unsolved \{show pos} \{show k} : \{show ty} \{show ctx.bds}"
show (Unsolved pos k ctx ty kind) = "Unsolved \{show pos} \{show k} \{show kind} : \{show ty} \{show ctx.bds}"
show (Solved k x) = "Solved \{show k} \{show x}"
export withPos : Context -> FC -> Context
@@ -429,11 +443,11 @@ error' : String -> M a
error' msg = throwError $ E (0,0) msg
export
freshMeta : Context -> FC -> Val -> M Tm
freshMeta ctx fc ty = do
freshMeta : Context -> FC -> Val -> MetaKind -> M Tm
freshMeta ctx fc ty kind = do
mc <- readIORef ctx.metas
putStrLn "INFO at \{show fc}: fresh meta \{show mc.next} : \{show ty}"
writeIORef ctx.metas $ { next $= S, metas $= (Unsolved fc mc.next ctx ty ::) } mc
writeIORef ctx.metas $ { next $= S, metas $= (Unsolved fc mc.next ctx ty kind ::) } mc
pure $ applyBDs 0 (Meta emptyFC mc.next) ctx.bds
where
-- hope I got the right order here :)
@@ -457,7 +471,7 @@ lookupMeta ix = do
where
go : List MetaEntry -> M MetaEntry
go [] = error' "Meta \{show ix} not found"
go (meta@(Unsolved _ k ys _) :: xs) = if k == ix then pure meta else go xs
go (meta@(Unsolved _ k ys _ _) :: xs) = if k == ix then pure meta else go xs
go (meta@(Solved k x) :: xs) = if k == ix then pure meta else go xs
-- we need more of topcontext later - Maybe switch it up so we're not passing