edwinb/Idris2-boot
1
1
Fork 0
mirror of https://github.com/edwinb/Idris2-boot.git synced 2024-12-25 05:43:19 +03:00
Code Issues Projects Releases Wiki Activity

Make 'with' work in where blocks

Browse Source 
Need to set up nested names appropriately for the with function so that
the environment gets passed through correctly, and use abstractEnvType
to get the type of the with function rather than simply binding the
environment as is.
This commit is contained in:
Edwin Brady 2019-07-08 23:05:04 +02:00
parent 1cc097aefc
commit 11560a5c82
3 changed files with 78 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
src/TTImp/Elab/Local.idr
View File

@ -35,52 +35,52 @@ checkLocal {vars} rig elabinfo nest env fc nestdecls scope expty
traverse (processDecl [] nest' env') (map (updateName nest') nestdecls)
check rig elabinfo nest' env scope expty
where
-- For the local definitions, don't allow access to linear things
-- unless they're explicitly passed.
-- This is because, at the moment, we don't have any mechanism of
-- ensuring the nested definition is used exactly once
dropLinear : Env Term vs -> Env Term vs
dropLinear [] = []
dropLinear (b :: bs)
= if isLinear (multiplicity b)
then setMultiplicity b Rig0 :: dropLinear bs
else b :: dropLinear bs
-- For the local definitions, don't allow access to linear things
-- unless they're explicitly passed.
-- This is because, at the moment, we don't have any mechanism of
-- ensuring the nested definition is used exactly once
dropLinear : Env Term vs -> Env Term vs
dropLinear [] = []
dropLinear (b :: bs)
= if isLinear (multiplicity b)
then setMultiplicity b Rig0 :: dropLinear bs
else b :: dropLinear bs
applyEnv : Int -> Name ->
Core (Name, (Maybe Name, FC -> NameType -> Term vars))
applyEnv outer inner
= do n' <- resolveName (Nested outer inner)
pure (inner, (Just (Nested outer inner),
\fc, nt => applyTo fc
(Ref fc nt (Resolved n')) env))
applyEnv : Int -> Name ->
Core (Name, (Maybe Name, FC -> NameType -> Term vars))
applyEnv outer inner
= do n' <- resolveName (Nested outer inner)
pure (inner, (Just (Nested outer inner),
\fc, nt => applyTo fc
(Ref fc nt (Resolved n')) env))
-- Update the names in the declarations to the new 'nested' names.
-- When we encounter the names in elaboration, we'll update to an
-- application of the nested name.
newName : NestedNames vars -> Name -> Name
newName nest n
= case lookup n (names nest) of
Just (Just n', _) => n'
_ => n
-- Update the names in the declarations to the new 'nested' names.
-- When we encounter the names in elaboration, we'll update to an
-- application of the nested name.
newName : NestedNames vars -> Name -> Name
newName nest n
= case lookup n (names nest) of
Just (Just n', _) => n'
_ => n
updateTyName : NestedNames vars -> ImpTy -> ImpTy
updateTyName nest (MkImpTy loc' n ty)
= MkImpTy loc' (newName nest n) ty
updateTyName : NestedNames vars -> ImpTy -> ImpTy
updateTyName nest (MkImpTy loc' n ty)
= MkImpTy loc' (newName nest n) ty
updateDataName : NestedNames vars -> ImpData -> ImpData
updateDataName nest (MkImpData loc' n tycons dopts dcons)
= MkImpData loc' (newName nest n) tycons dopts
(map (updateTyName nest) dcons)
updateDataName nest (MkImpLater loc' n tycons)
= MkImpLater loc' (newName nest n) tycons
updateDataName : NestedNames vars -> ImpData -> ImpData
updateDataName nest (MkImpData loc' n tycons dopts dcons)
= MkImpData loc' (newName nest n) tycons dopts
(map (updateTyName nest) dcons)
updateDataName nest (MkImpLater loc' n tycons)
= MkImpLater loc' (newName nest n) tycons
updateName : NestedNames vars -> ImpDecl -> ImpDecl
updateName nest (IClaim loc' r vis fnopts ty)
= IClaim loc' r vis fnopts (updateTyName nest ty)
updateName nest (IDef loc' n cs)
= IDef loc' (newName nest n) cs
updateName nest (IData loc' vis d)
= IData loc' vis (updateDataName nest d)
updateName nest i = i
updateName : NestedNames vars -> ImpDecl -> ImpDecl
updateName nest (IClaim loc' r vis fnopts ty)
= IClaim loc' r vis fnopts (updateTyName nest ty)
updateName nest (IDef loc' n cs)
= IDef loc' (newName nest n) cs
updateName nest (IData loc' vis d)
= IData loc' vis (updateDataName nest d)
updateName nest i = i

48
src/TTImp/ProcessDef.idr
View File

@ -256,7 +256,8 @@ plicit (Pi _ p _) = p
plicit (PVar _ p _) = p
plicit _ = Explicit
bindNotReq : FC -> Int -> Env Term vs -> (sub : SubVars pre vs) ->
bindNotReq : {vs : _} ->
FC -> Int -> Env Term vs -> (sub : SubVars pre vs) ->
List (PiInfo, Name) ->
Term vs -> (List (PiInfo, Name), Term pre)
bindNotReq fc i [] SubRefl ns tm = (ns, embed tm)
@ -272,14 +273,16 @@ bindNotReq {vs = n :: _} fc i (b :: env) (DropCons p) ns tm
= bindNotReq fc i env p ((plicit b, n) :: ns)
(Bind fc _ (Pi (multiplicity b) Explicit (binderType b)) tm)
bindReq : FC -> Env Term vs -> (sub : SubVars pre vs) ->
bindReq : {vs : _} ->
FC -> Env Term vs -> (sub : SubVars pre vs) ->
List (PiInfo, Name) ->
Term pre -> Maybe (List (PiInfo, Name), ClosedTerm)
bindReq fc env SubRefl ns tm = pure (ns, bindEnv fc env tm)
bindReq fc {vs = n :: _} (b :: env) (KeepCons p) ns tm
= do b' <- shrinkBinder b p
bindReq fc env p ((plicit b, n) :: ns)
(Bind fc _ (Pi (multiplicity b) Explicit (binderType b')) tm)
Term pre -> Maybe (List (PiInfo, Name), List Name, ClosedTerm)
bindReq {vs} fc env SubRefl ns tm
= pure (ns, reverse vs, abstractEnvType fc env tm)
bindReq {vs = n :: _} fc (b :: env) (KeepCons p) ns tm
= do b' <- shrinkBinder b p
bindReq fc env p ((plicit b, n) :: ns)
(Bind fc _ (Pi (multiplicity b) Explicit (binderType b')) tm)
bindReq fc (b :: env) (DropCons p) ns tm
= bindReq fc env p ns tm
@ -397,6 +400,16 @@ withRHS fc drop wname wargnames tm toplhs
wrhsC : ImpClause -> Core ImpClause
wrhsC (PatClause fc lhs rhs) = pure $ PatClause fc lhs !(wrhs rhs)
wrhsC c = pure c
-- For checking with blocks as nested names
applyEnv : {auto c : Ref Ctxt Defs} ->
Env Term vars -> Name ->
Core (Name, (Maybe Name, FC -> NameType -> Term vars))
applyEnv env withname
= do n' <- resolveName withname
pure (withname, (Just withname,
\fc, nt => applyTo fc
(Ref fc nt (Resolved n')) env))
-- Check a pattern clause, returning the component of the 'Case' expression it
-- represents, or Nothing if it's an impossible clause
@ -457,6 +470,7 @@ checkClause {vars} mult hashit n opts nest env (PatClause fc lhs_in rhs)
_ => pure ()
pure (Just (MkClause env' lhstm' rhstm))
-- TODO: (to decide) With is complicated. Move this into its own module?
checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs)
= do (vars' ** (sub', env', nest', lhspat, reqty)) <-
checkLHS mult hashit n opts nest env fc lhs_in
@ -470,7 +484,7 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs
clearHoleLHS
logTerm 5 "With value" wval
logTerm 5 "Required type" reqty
logTerm 3 "Required type" reqty
wvalTy <- getTerm gwvalTy
defs <- get Ctxt
wval <- normaliseHoles defs env' wval
@ -504,7 +518,7 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs
(weaken {n=wargn} notreqty))
let bNotReq = Bind fc wargn (Pi RigW Explicit wvalTy) wtyScope
let Just (reqns, wtype) = bindReq fc env' withSub [] bNotReq
let Just (reqns, envns, wtype) = bindReq fc env' withSub [] bNotReq
| Nothing => throw (InternalError "Impossible happened: With abstraction failure #4")
-- list of argument names - 'Just' means we need to match the name
@ -514,24 +528,30 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs
= map Just reqns ++
Nothing :: map Just notreqns
logTerm 5 "With function type" wtype
logTerm 3 "With function type" wtype
log 5 $ "Argument names " ++ show wargNames
wname <- genWithName n
widx <- addDef wname (newDef fc wname mult vars wtype Private None)
let rhs_in = apply (IVar fc wname)
(map (maybe wval_raw (\pn => IVar fc (snd pn))) wargNames)
(map (IVar fc) envns ++
map (maybe wval_raw (\pn => IVar fc (snd pn))) wargNames)
log 3 $ "Applying to with argument " ++ show rhs_in
rhs <- wrapError (InRHS fc !(getFullName (Resolved n))) $
checkTermSub n wmode opts nest' env' env sub' rhs_in
(gnf env' reqty)
-- Generate new clauses by rewriting the matched arguments
cs' <- traverse (mkClauseWith 1 wname wargNames lhs_in) cs
log 3 $ "With clauses: " ++ show cs'
-- Elaborate the new definition here
nestname <- applyEnv env wname
let nest'' = record { names $= (nestname ::) } nest
let wdef = IDef fc wname cs'
processDecl [] nest env wdef
processDecl [] nest'' env wdef
pure (Just (MkClause env' lhspat rhs))
where
@ -554,7 +574,7 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs
keepOldEnv (KeepCons p) (KeepCons p')
= let (_ ** rest) = keepOldEnv p p' in
(_ ** KeepCons rest)
-- Rewrite the clauses in the block to use an updated LHS.
-- 'drop' is the number of additional with arguments we expect (i.e.
-- the things to drop from the end before matching LHSs)

2
support/chez/support.ss
View File

@ -170,6 +170,8 @@
(micro (mod s 1000000)))
(sleep (make-time 'time-duration (* 1000 micro) sec))))
(define (blodwen-time) (time-second (current-time)))
(define (blodwen-args)
(define (blodwen-build-args args)
(if (null? args)