diff --git a/libs/base/Data/SnocList.idr b/libs/base/Data/SnocList.idr index 68964dc064..2c4467309c 100644 --- a/libs/base/Data/SnocList.idr +++ b/libs/base/Data/SnocList.idr @@ -471,3 +471,13 @@ tailRecAppendIsAppend : (sx, sy : SnocList a) -> tailRecAppend sx sy = sx ++ sy tailRecAppendIsAppend sx Lin = Refl tailRecAppendIsAppend sx (sy :< y) = trans (snocTailRecAppend y sx sy) (cong (:< y) $ tailRecAppendIsAppend sx sy) + +||| `reverseOnto` reverses the snoc list and prepends it to the "onto" argument +export +revOnto : (xs, vs : SnocList a) -> reverseOnto xs vs = xs ++ reverse vs +revOnto _ [<] = Refl +revOnto xs (vs :< v) = + do rewrite revOnto (xs :< v) vs + rewrite sym $ appendAssociative xs [ HasLength (S n) ([ HasLength (S n) ([ HasLength n sy -> HasLength (n + m) (sx ++ sy) diff --git a/src/Compiler/ANF.idr b/src/Compiler/ANF.idr index fa694850a8..940f97578e 100644 --- a/src/Compiler/ANF.idr +++ b/src/Compiler/ANF.idr @@ -8,8 +8,10 @@ import Core.Core import Core.TT import Data.List +import Data.SnocList import Data.Vect import Libraries.Data.SortedSet +import Libraries.Data.SnocList.Extra %default covering @@ -136,9 +138,9 @@ Show ANFDef where show args ++ " -> " ++ show ret show (MkAError exp) = "Error: " ++ show exp -data AVars : List Name -> Type where - Nil : AVars [] - (::) : Int -> AVars xs -> AVars (x :: xs) +data AVars : SnocList Name -> Type where + Lin : AVars [<] + (:<) : AVars xs -> Int -> AVars (xs :< x) data Next : Type where @@ -150,8 +152,8 @@ nextVar pure i lookup : {idx : _} -> (0 p : IsVar x idx vs) -> AVars vs -> Int -lookup First (x :: xs) = x -lookup (Later p) (x :: xs) = lookup p xs +lookup First (xs :< x) = x +lookup (Later p) (xs :< x) = lookup p xs bindArgs : {auto v : Ref Next Int} -> List ANF -> Core (List (AVar, Maybe ANF)) @@ -187,6 +189,15 @@ mlet fc val sc = do i <- nextVar pure $ ALet fc i val (sc (ALocal i)) +bindAsFresh : + {auto v : Ref Next Int} -> + (args : List Name) -> AVars vars' -> + Core (List Int, AVars (vars' <>< args)) +bindAsFresh [] vs = pure ([], vs) +bindAsFresh (n :: ns) vs + = do i <- nextVar + mapFst (i ::) <$> bindAsFresh ns (vs :< i) + mutual anfArgs : {vars : _} -> {auto v : Ref Next Int} -> @@ -194,7 +205,7 @@ mutual List (Lifted vars) -> (List AVar -> ANF) -> Core ANF anfArgs fc vs args f = do args' <- traverse (anf vs) args - letBind fc args' f + letBind fc (toList args') f anf : {vars : _} -> {auto v : Ref Next Int} -> @@ -211,7 +222,7 @@ mutual _ => ACrash fc "Can't happen (AApp)" anf vs (LLet fc x val sc) = do i <- nextVar - let vs' = i :: vs + let vs' = vs :< i pure $ ALet fc i !(anf vs val) !(anf vs' sc) anf vs (LCon fc n ci t args) = anfArgs fc vs args (ACon fc n ci t) @@ -241,16 +252,8 @@ mutual {auto v : Ref Next Int} -> AVars vars -> LiftedConAlt vars -> Core AConAlt anfConAlt vs (MkLConAlt n ci t args sc) - = do (is, vs') <- bindArgs args vs + = do (is, vs') <- bindAsFresh args vs pure $ MkAConAlt n ci t is !(anf vs' sc) - where - bindArgs : (args : List Name) -> AVars vars' -> - Core (List Int, AVars (args ++ vars')) - bindArgs [] vs = pure ([], vs) - bindArgs (n :: ns) vs - = do i <- nextVar - (is, vs') <- bindArgs ns vs - pure (i :: is, i :: vs') anfConstAlt : {vars : _} -> {auto v : Ref Next Int} -> @@ -262,25 +265,18 @@ export toANF : LiftedDef -> Core ANFDef toANF (MkLFun args scope sc) = do v <- newRef Next (the Int 0) - (iargs, vsNil) <- bindArgs args [] - let vs : AVars args = rewrite sym (appendNilRightNeutral args) in - vsNil - (iargs', vs) <- bindArgs scope vs - pure $ MkAFun (iargs ++ reverse iargs') !(anf vs sc) - where - bindArgs : {auto v : Ref Next Int} -> - (args : List Name) -> AVars vars' -> - Core (List Int, AVars (args ++ vars')) - bindArgs [] vs = pure ([], vs) - bindArgs (n :: ns) vs - = do i <- nextVar - (is, vs') <- bindArgs ns vs - pure (i :: is, i :: vs') + (iargs, vsNil) <- bindAsFresh (cast args) [<] + let vs : AVars args + := rewrite sym $ appendLinLeftNeutral args in + rewrite snocAppendAsFish [<] args in vsNil + (iargs', vs) <- bindAsFresh (cast scope) vs + sc' <- anf (rewrite snocAppendAsFish args scope in vs) sc + pure $ MkAFun (iargs ++ reverse iargs') sc' toANF (MkLCon t a ns) = pure $ MkACon t a ns toANF (MkLForeign ccs fargs t) = pure $ MkAForeign ccs fargs t toANF (MkLError err) = do v <- newRef Next (the Int 0) - pure $ MkAError !(anf [] err) + pure $ MkAError !(anf [<] err) export freeVariables : ANF -> SortedSet AVar diff --git a/src/Compiler/CaseOpts.idr b/src/Compiler/CaseOpts.idr index 2f20494c05..7fbdac8b8b 100644 --- a/src/Compiler/CaseOpts.idr +++ b/src/Compiler/CaseOpts.idr @@ -10,8 +10,13 @@ import Core.FC import Core.TT import Data.List +import Data.SnocList import Data.Vect +import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra + %default covering {- @@ -32,38 +37,39 @@ case t of shiftUnder : {args : _} -> {idx : _} -> - (0 p : IsVar n idx (x :: args ++ vars)) -> - NVar n (args ++ x :: vars) + (0 p : IsVar n idx (vars ++ args :< x)) -> + NVar n (vars :< x ++ args) shiftUnder First = weakenNVar (mkSizeOf args) (MkNVar First) shiftUnder (Later p) = insertNVar (mkSizeOf args) (MkNVar p) -shiftVar : {outer, args : Scope} -> - NVar n (outer ++ (x :: args ++ vars)) -> - NVar n (outer ++ (args ++ x :: vars)) +shiftVar : {outer : Scope} -> {args : List Name} -> + NVar n ((vars <>< args :< x) ++ outer) -> + NVar n ((vars :< x <>< args) ++ outer) shiftVar nvar = let out = mkSizeOf outer in + -- TODO: G.Allois version has Left/Right swap case locateNVar out nvar of Left nvar => embed nvar - Right (MkNVar p) => weakenNs out (shiftUnder p) + Right (MkNVar p) => weakenNs out (shiftUndersN (mkSizeOf _) p) mutual + renameVar : IsVar x i ((vars :< old <>< args) ++ local) -> + IsVar x i ((vars :< new <>< args) ++ local) + renameVar = believe_me -- it's the same index, so just the identity at run time + shiftBinder : {outer, args : _} -> (new : Name) -> - CExp (outer ++ old :: (args ++ vars)) -> - CExp (outer ++ (args ++ new :: vars)) + CExp (((vars <>< args) :< old) ++ outer) -> + CExp ((vars :< new <>< args) ++ outer) shiftBinder new (CLocal fc p) = case shiftVar (MkNVar p) of MkNVar p' => CLocal fc (renameVar p') - where - renameVar : IsVar x i (outer ++ (args ++ (old :: rest))) -> - IsVar x i (outer ++ (args ++ (new :: rest))) - renameVar = believe_me -- it's the same index, so just the identity at run time shiftBinder new (CRef fc n) = CRef fc n shiftBinder {outer} new (CLam fc n sc) - = CLam fc n $ shiftBinder {outer = n :: outer} new sc + = CLam fc n $ shiftBinder {outer = outer :< n} new sc shiftBinder new (CLet fc n inlineOK val sc) = CLet fc n inlineOK (shiftBinder new val) - $ shiftBinder {outer = n :: outer} new sc + $ shiftBinder {outer = outer :< n} new sc shiftBinder new (CApp fc f args) = CApp fc (shiftBinder new f) $ map (shiftBinder new) args shiftBinder new (CCon fc ci c tag args) @@ -85,36 +91,36 @@ mutual shiftBinder new (CErased fc) = CErased fc shiftBinder new (CCrash fc msg) = CCrash fc msg - shiftBinderConAlt : {outer, args : _} -> + shiftBinderConAlt : {outer : _} -> {args : _} -> (new : Name) -> - CConAlt (outer ++ (x :: args ++ vars)) -> - CConAlt (outer ++ (args ++ new :: vars)) + CConAlt (((vars <>< args) :< old) ++ outer) -> + CConAlt ((vars :< new <>< args) ++ outer) shiftBinderConAlt new (MkConAlt n ci t args' sc) - = let sc' : CExp ((args' ++ outer) ++ (x :: args ++ vars)) - = rewrite sym (appendAssociative args' outer (x :: args ++ vars)) in sc in + = let sc' : CExp (((vars <>< args) :< old) ++ (outer <>< args')) + = rewrite sym $ snocAppendFishAssociative (vars <>< args :< old) outer args' in sc in MkConAlt n ci t args' $ - rewrite (appendAssociative args' outer (args ++ new :: vars)) - in shiftBinder new {outer = args' ++ outer} sc' + rewrite snocAppendFishAssociative (vars :< new <>< args) outer args' + in shiftBinder new {outer = outer <>< args'} sc' shiftBinderConstAlt : {outer, args : _} -> (new : Name) -> - CConstAlt (outer ++ (x :: args ++ vars)) -> - CConstAlt (outer ++ (args ++ new :: vars)) + CConstAlt (((vars <>< args) :< old) ++ outer) -> + CConstAlt ((vars :< new <>< args) ++ outer) shiftBinderConstAlt new (MkConstAlt c sc) = MkConstAlt c $ shiftBinder new sc -- If there's a lambda inside a case, move the variable so that it's bound -- outside the case block so that we can bind it just once outside the block liftOutLambda : {args : _} -> (new : Name) -> - CExp (old :: args ++ vars) -> - CExp (args ++ new :: vars) -liftOutLambda = shiftBinder {outer = []} + CExp (vars <>< args :< old) -> + CExp (vars :< new <>< args) +liftOutLambda = shiftBinder {outer = [<]} -- If all the alternatives start with a lambda, we can have a single lambda -- binding outside tryLiftOut : (new : Name) -> List (CConAlt vars) -> - Maybe (List (CConAlt (new :: vars))) + Maybe (List (CConAlt (vars :< new))) tryLiftOut new [] = Just [] tryLiftOut new (MkConAlt n ci t args (CLam fc x sc) :: as) = do as' <- tryLiftOut new as @@ -124,7 +130,7 @@ tryLiftOut _ _ = Nothing tryLiftOutConst : (new : Name) -> List (CConstAlt vars) -> - Maybe (List (CConstAlt (new :: vars))) + Maybe (List (CConstAlt (vars :< new))) tryLiftOutConst new [] = Just [] tryLiftOutConst new (MkConstAlt c (CLam fc x sc) :: as) = do as' <- tryLiftOutConst new as @@ -134,7 +140,7 @@ tryLiftOutConst _ _ = Nothing tryLiftDef : (new : Name) -> Maybe (CExp vars) -> - Maybe (Maybe (CExp (new :: vars))) + Maybe (Maybe (CExp (vars :< new))) tryLiftDef new Nothing = Just Nothing tryLiftDef new (Just (CLam fc x sc)) = let sc' = liftOutLambda {args = []} new sc in @@ -313,8 +319,8 @@ doCaseOfCase fc x xalts xdef alts def updateAlt (MkConAlt n ci t args sc) = MkConAlt n ci t args $ CConCase fc sc - (map (weakenNs (mkSizeOf args)) alts) - (map (weakenNs (mkSizeOf args)) def) + (map (weakensN (mkSizeOf args)) alts) + (map (weakensN (mkSizeOf args)) def) updateDef : CExp vars -> CExp vars updateDef sc = CConCase fc sc alts def diff --git a/src/Compiler/Common.idr b/src/Compiler/Common.idr index e113a34d0a..eef84335ed 100644 --- a/src/Compiler/Common.idr +++ b/src/Compiler/Common.idr @@ -80,7 +80,7 @@ Ord UsePhase where public export record CompileData where constructor MkCompileData - mainExpr : CExp [] -- main expression to execute. This also appears in + mainExpr : CExp [<] -- main expression to execute. This also appears in -- the definitions below as MN "__mainExpression" 0 -- For incremental compilation and for compiling exported -- names only, this can be set to 'erased'. @@ -152,7 +152,7 @@ getMinimalDef (Coded ns bin) name <- fromBuf b let def = MkGlobalDef fc name (Erased fc Placeholder) [] [] [] [] mul - [] (specified Public) (MkTotality Unchecked IsCovering) False + [<] (specified Public) (MkTotality Unchecked IsCovering) False [] Nothing refsR False False True None cdef Nothing [] Nothing pure (def, Just (ns, bin)) @@ -351,8 +351,8 @@ getCompileDataWith exports doLazyAnnots phase_in tm_in traverse (lambdaLift doLazyAnnots) cseDefs else pure [] - let lifted = (mainname, MkLFun [] [] liftedtm) :: - ldefs ++ concat lifted_in + let lifted = (mainname, MkLFun [<] [<] liftedtm) :: + (ldefs ++ concat lifted_in) anf <- if phase >= ANF then logTime 2 "Get ANF" $ traverse (\ (n, d) => pure (n, !(toANF d))) lifted @@ -408,7 +408,7 @@ getCompileData = getCompileDataWith [] export compileTerm : {auto c : Ref Ctxt Defs} -> - ClosedTerm -> Core (CExp []) + ClosedTerm -> Core (CExp [<]) compileTerm tm_in = do tm <- toFullNames tm_in fixArityExp !(compileExp tm) diff --git a/src/Compiler/CompileExpr.idr b/src/Compiler/CompileExpr.idr index 249773ace0..7bfc9cd320 100644 --- a/src/Compiler/CompileExpr.idr +++ b/src/Compiler/CompileExpr.idr @@ -12,11 +12,22 @@ import Core.TT import Core.Value import Data.List +import Data.SnocList import Data.Maybe import Data.Vect +import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra + %default covering +-- For ease of type level reasoning! +public export +rev : SnocList a -> SnocList a +rev [<] = [<] +rev (xs :< x) = [ pure (Arity 0) numArgs _ tm = pure (Arity 0) -mkSub : Nat -> (ns : List Name) -> List Nat -> (ns' ** Thin ns' ns) -mkSub i _ [] = (_ ** Refl) -mkSub i [] ns = (_ ** Refl) -mkSub i (x :: xs) es - = let (ns' ** p) = mkSub (S i) xs es in - if i `elem` es - then (ns' ** Drop p) - else (x :: ns' ** Keep p) - -weakenVar : Var ns -> Var (a :: ns) +||| Compute the thinning getting rid of the listed de Bruijn indices. +-- TODO: is the list of erased arguments guaranteed to be sorted? +-- Should it? +mkSub : (ns : SnocList Name) -> List Nat -> (ns' ** Thin ns' ns) +mkSub ns = mkSub' (length ns) ns + where + mkSub' : Nat -> (ns : SnocList Name) -> List Nat -> (ns' ** Thin ns' ns) + mkSub' i _ [] = (_ ** Refl) + mkSub' i [<] ns = (_ ** Refl) + mkSub' (S i) (xs :< x) es + = let (ns' ** p) = mkSub' i xs es in + if i `elem` es + then (ns' ** Drop p) + else (ns' :< x ** Keep p) + -- Next case can't happen if called with the right Nat from mkDropSubst + -- FIXME: rule it out with a type! + mkSub' Z (xs :< x) es = let (vs ** th) = mkSub' Z xs es in (vs ** Drop th) + +weakenVar : Var ns -> Var (ns :< a) weakenVar (MkVar p) = (MkVar (Later p)) etaExpand : {vars : _} -> @@ -131,16 +151,16 @@ eraseConArgs arity epos fn args then dropPos epos fn' -- fn' might be lambdas, after eta expansion else fn' -mkDropSubst : Nat -> List Nat -> - (rest : List Name) -> - (vars : List Name) -> - (vars' ** Thin (vars' ++ rest) (vars ++ rest)) -mkDropSubst i es rest [] = ([] ** Refl) -mkDropSubst i es rest (x :: xs) - = let (vs ** sub) = mkDropSubst (1 + i) es rest xs in - if i `elem` es - then (vs ** Drop sub) - else (x :: vs ** Keep sub) +||| Compute the thinning dropping the erased arguments +mkDropSubst : (erasedArgs : List Nat) -> + (args : List Name) -> + (args' ** Thin (vars <>< args') (vars <>< args)) +mkDropSubst es args + = let (vs ** th) = mkSub (cast args) es in + MkDPair (cast vs) + $ rewrite sym $ snocAppendAsFish vars vs in + rewrite fishAsSnocAppend vars args in + embed th -- Rewrite applications of Nat-like constructors and functions to more optimal -- versions using Integer @@ -343,8 +363,7 @@ toCExpTm n (Bind fc x (Let _ rig val _) sc) rig toCExpTm n (Bind fc x (Pi _ c e ty) sc) = pure $ CCon fc (UN (Basic "->")) TYCON Nothing - [ !(toCExp n ty) - , CLam fc x !(toCExp n sc)] + [!(toCExp n ty), CLam fc x !(toCExp n sc)] toCExpTm n (Bind fc x b tm) = pure $ CErased fc -- We'd expect this to have been dealt with in toCExp, but for completeness... toCExpTm n (App fc tm arg) @@ -386,7 +405,8 @@ mutual Core (List (CConAlt vars)) conCases n [] = pure [] conCases {vars} n (ConCase x tag args sc :: ns) - = do defs <- get Ctxt + = do log "compiler.newtype.world" 50 "conCases-2 on \{show n} x: \{show x}, args: \{show args}, sc: \{show sc}" + defs <- get Ctxt Just gdef <- lookupCtxtExact x (gamma defs) | Nothing => -- primitive type match do xn <- getFullName x @@ -395,10 +415,13 @@ mutual case (definition gdef) of DCon _ arity (Just pos) => conCases n ns -- skip it _ => do xn <- getFullName x + let erased = eraseArgs gdef + log "compiler.newtype.world" 50 "conCases-2 on \{show n} args: \{show args}, erased: \{show erased}" let (args' ** sub) - = mkDropSubst 0 (eraseArgs gdef) vars args + = mkDropSubst erased args sc' <- toCExpTree n sc ns' <- conCases n ns + log "compiler.newtype.world" 50 "conCases-2 on \{show n} sc': \{show sc'}, ns': \{show ns'}, args': \{show args'}, sub: \{show sub}" if dcon (definition gdef) then pure $ MkConAlt xn !(dconFlag xn) (Just tag) args' (shrinkCExp sub sc') :: ns' else pure $ MkConAlt xn !(dconFlag xn) Nothing args' (shrinkCExp sub sc') :: ns' @@ -453,33 +476,51 @@ mutual -- works in a nice principled way. if noworld -- just substitute the scrutinee into -- the RHS - then - let (s, env) : (SizeOf args, SubstCEnv args vars) - = mkSubst 0 scr pos args in - do log "compiler.newtype.world" 50 "Inlining case on \{show n} (no world)" - pure $ Just (substs s env !(toCExpTree n sc)) + then do log "compiler.newtype.world" 50 "Inlining case on \{show n} (no world)" + + sc' <- toCExpTree n sc + let sc'' : CExp (vars ++ cast args) + := rewrite sym $ fishAsSnocAppend vars args in sc' + + let (s, env) : (SizeOf args, SubstCEnv (cast args) vars) + = mkSubst 0 scr pos args + + pure $ Just (substs (cast s) env sc'') else -- let bind the scrutinee, and substitute the -- name into the RHS - let (s, env) : (_, SubstCEnv args (MN "eff" 0 :: vars)) - = mkSubst 0 (CLocal fc First) pos args in - do sc' <- toCExpTree n sc - let scope = insertNames {outer=args} + + do log "compiler.newtype.world" 25 "Kept the scrutinee \{show n} \{show pos} sc \{show sc}, vars: \{show $ toList vars}, args: \{show $ toList args}, scr: \{show scr}" + let (s, env) : (_, SubstCEnv (cast args) (vars :< MN "eff" 0)) + = mkSubst 0 (CLocal fc First) pos args + + sc' <- toCExpTree n sc + + let sc'' : CExp (vars ++ cast args) + := rewrite sym $ fishAsSnocAppend vars args in sc' + + log "compiler.newtype.world" 25 "Kept the scrutinee \{show pos} sc': \{show sc'}, env: \{show env}" + + let + scope : CExp ((vars ++ [ pure Nothing -- there's a normal match to do where mkSubst : Nat -> CExp vs -> - Nat -> (args : List Name) -> (SizeOf args, SubstCEnv args vs) - mkSubst _ _ _ [] = (zero, []) + Nat -> (args : List Name) -> (SizeOf args, SubstCEnv (cast args) vs) + mkSubst _ _ _ [] = (zero, [<]) mkSubst i scr pos (a :: as) = let (s, env) = mkSubst (1 + i) scr pos as in - if i == pos - then (suc s, scr :: env) - else (suc s, CErased fc :: env) + rewrite snocAppendFishAssociative [ @@ -502,8 +543,8 @@ mutual toCExpTree n alts@(Case _ x scTy (DelayCase ty arg sc :: rest)) = let fc = getLoc scTy in pure $ - CLet fc arg YesInline (CForce fc LInf (CLocal (getLoc scTy) x)) $ - CLet fc ty YesInline (CErased fc) + CLet fc ty YesInline (CErased fc) $ + CLet fc arg YesInline (CForce fc LInf (CLocal (getLoc scTy) (Later x))) !(toCExpTree n sc) toCExpTree n alts = toCExpTree' n alts @@ -515,11 +556,14 @@ mutual Core (CExp vars) toCExpTree' n (Case _ x scTy alts@(ConCase _ _ _ _ :: _)) = let fc = getLoc scTy in - do Nothing <- getNewType fc (CLocal fc x) n alts - | Just def => pure def + do log "compiler.newtype.world" 50 "toCExpTree'-1 on \{show n} x: \{show $ MkVar x}, scTy: \{show scTy}, alts: \{show alts}" + Nothing <- getNewType fc (CLocal fc x) n alts + | Just def => do log "compiler.newtype.world" 50 "toCExpTree'-1 on \{show n} getNewType def: \{show def}" + pure def defs <- get Ctxt cases <- conCases n alts def <- getDef n alts + log "compiler.newtype.world" 50 "toCExpTree'-1 on \{show n} cases: \{show cases}, def: \{show def}" if isNil cases then pure (fromMaybe (CErased fc) def) else unitTree $ enumTree !(builtinNatTree $ @@ -545,9 +589,9 @@ mutual -- Need this for ensuring that argument list matches up to operator arity for -- builtins -data ArgList : Nat -> List Name -> Type where - NoArgs : ArgList Z [] - ConsArg : (a : Name) -> ArgList k as -> ArgList (S k) (a :: as) +data ArgList : Nat -> SnocList Name -> Type where + NoArgs : ArgList Z [<] + ConsArg : (a : Name) -> ArgList k as -> ArgList (S k) (as :< a) mkArgList : Int -> (n : Nat) -> (ns ** ArgList n ns) mkArgList i Z = (_ ** NoArgs) @@ -556,35 +600,35 @@ mkArgList i (S k) (_ ** ConsArg (MN "arg" i) rec) data NArgs : Type where - User : Name -> List (Closure []) -> NArgs - Struct : String -> List (String, Closure []) -> NArgs + User : Name -> List (Closure [<]) -> NArgs + Struct : String -> List (String, Closure [<]) -> NArgs NUnit : NArgs NPtr : NArgs NGCPtr : NArgs NBuffer : NArgs NForeignObj : NArgs - NIORes : Closure [] -> NArgs + NIORes : Closure [<] -> NArgs getPArgs : {auto c : Ref Ctxt Defs} -> - Defs -> Closure [] -> Core (String, Closure []) + Defs -> Closure [<] -> Core (String, Closure [<]) getPArgs defs cl = do NDCon fc _ _ _ args <- evalClosure defs cl | nf => throw (GenericMsg (getLoc nf) "Badly formed struct type") - case reverse (map snd args) of - (tydesc :: n :: _) => + case map snd args of + (_ :< n :< tydesc) => do NPrimVal _ (Str n') <- evalClosure defs n | nf => throw (GenericMsg (getLoc nf) "Unknown field name") pure (n', tydesc) _ => throw (GenericMsg fc "Badly formed struct type") getFieldArgs : {auto c : Ref Ctxt Defs} -> - Defs -> Closure [] -> Core (List (String, Closure [])) + Defs -> Closure [<] -> Core (List (String, Closure [<])) getFieldArgs defs cl = do NDCon fc _ _ _ args <- evalClosure defs cl | nf => throw (GenericMsg (getLoc nf) "Badly formed struct type") case map snd args of -- cons - [_, t, rest] => + [< _, t, rest] => do rest' <- getFieldArgs defs rest (n, ty) <- getPArgs defs t pure ((n, ty) :: rest') @@ -592,7 +636,7 @@ getFieldArgs defs cl _ => pure [] getNArgs : {auto c : Ref Ctxt Defs} -> - Defs -> Name -> List (Closure []) -> Core NArgs + Defs -> Name -> List (Closure [<]) -> Core NArgs getNArgs defs (NS _ (UN $ Basic "IORes")) [arg] = pure $ NIORes arg getNArgs defs (NS _ (UN $ Basic "Ptr")) [arg] = pure NPtr getNArgs defs (NS _ (UN $ Basic "AnyPtr")) [] = pure NPtr @@ -608,7 +652,7 @@ getNArgs defs (NS _ (UN $ Basic "Struct")) [n, args] getNArgs defs n args = pure $ User n args nfToCFType : {auto c : Ref Ctxt Defs} -> - FC -> (inStruct : Bool) -> NF [] -> Core CFType + FC -> (inStruct : Bool) -> NF [<] -> Core CFType nfToCFType _ _ (NPrimVal _ $ PrT IntType) = pure CFInt nfToCFType _ _ (NPrimVal _ $ PrT IntegerType) = pure CFInteger nfToCFType _ _ (NPrimVal _ $ PrT Bits8Type) = pure CFUnsigned8 @@ -628,7 +672,7 @@ nfToCFType _ _ (NPrimVal _ $ PrT WorldType) = pure CFWorld nfToCFType _ False (NBind fc _ (Pi _ _ _ ty) sc) = do defs <- get Ctxt sty <- nfToCFType fc False !(evalClosure defs ty) - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) tty <- nfToCFType fc False sc' pure (CFFun sty tty) nfToCFType _ True (NBind fc _ _ _) @@ -636,7 +680,7 @@ nfToCFType _ True (NBind fc _ _ _) nfToCFType _ s (NTCon fc n_in _ _ args) = do defs <- get Ctxt n <- toFullNames n_in - case !(getNArgs defs n $ map snd args) of + case !(getNArgs defs n $ toList (map snd args)) of User un uargs => do nargs <- traverse (evalClosure defs) uargs cargs <- traverse (nfToCFType fc s) nargs @@ -663,54 +707,54 @@ nfToCFType _ s (NErased _ _) = pure (CFUser (UN (Basic "__")) []) nfToCFType fc s t = do defs <- get Ctxt - ty <- quote defs [] t + ty <- quote defs [<] t throw (GenericMsg (getLoc t) ("Can't marshal type for foreign call " ++ show !(toFullNames ty))) getCFTypes : {auto c : Ref Ctxt Defs} -> - List CFType -> NF [] -> + List CFType -> NF [<] -> Core (List CFType, CFType) getCFTypes args (NBind fc _ (Pi _ _ _ ty) sc) = do defs <- get Ctxt aty <- nfToCFType fc False !(evalClosure defs ty) - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) getCFTypes (aty :: args) sc' getCFTypes args t = pure (reverse args, !(nfToCFType (getLoc t) False t)) -lamRHSenv : Int -> FC -> (ns : List Name) -> (SizeOf ns, SubstCEnv ns []) -lamRHSenv i fc [] = (zero, []) -lamRHSenv i fc (n :: ns) +lamRHSenv : Int -> FC -> (ns : SnocList Name) -> (SizeOf ns, SubstCEnv ns [<]) +lamRHSenv i fc [<] = (zero, [<]) +lamRHSenv i fc (ns :< n) = let (s, env) = lamRHSenv (i + 1) fc ns in - (suc s, CRef fc (MN "x" i) :: env) + (suc s, env :< CRef fc (MN "x" i)) mkBounds : (xs : _) -> Bounds xs -mkBounds [] = None -mkBounds (x :: xs) = Add x x (mkBounds xs) +mkBounds [<] = None +mkBounds (xs :< x) = Add x x (mkBounds xs) getNewArgs : {done : _} -> - SubstCEnv done args -> List Name -getNewArgs [] = [] -getNewArgs (CRef _ n :: xs) = n :: getNewArgs xs -getNewArgs {done = x :: xs} (_ :: sub) = x :: getNewArgs sub + SubstCEnv done args -> SnocList Name +getNewArgs [<] = [<] +getNewArgs (xs :< CRef _ n) = getNewArgs xs :< n +getNewArgs {done = xs :< x} (sub :< _) = getNewArgs sub :< x -- If a name is declared in one module and defined in another, -- we have to assume arity 0 for incremental compilation because -- we have no idea how it's defined, and when we made calls to the -- function, they had arity 0. -lamRHS : (ns : List Name) -> CExp ns -> CExp [] +lamRHS : (ns : SnocList Name) -> CExp ns -> CExp [<] lamRHS ns tm = let (s, env) = lamRHSenv 0 (getFC tm) ns - tmExp = substs s env (rewrite appendNilRightNeutral ns in tm) + tmExp = substs s env (rewrite appendLinLeftNeutral ns in tm) newArgs = reverse $ getNewArgs env bounds = mkBounds newArgs - expLocs = mkLocals zero {vars = []} bounds tmExp in + expLocs = mkLocals zero {vars = [<]} bounds tmExp in lamBind (getFC tm) _ expLocs where - lamBind : FC -> (ns : List Name) -> CExp ns -> CExp [] - lamBind fc [] tm = tm - lamBind fc (n :: ns) tm = lamBind fc ns (CLam fc n tm) + lamBind : FC -> (ns : SnocList Name) -> CExp ns -> CExp [<] + lamBind fc [<] tm = tm + lamBind fc (ns :< n) tm = lamBind fc ns (CLam fc n tm) toCDef : {auto c : Ref Ctxt Defs} -> Name -> ClosedTerm -> List Nat -> Def -> @@ -718,19 +762,24 @@ toCDef : {auto c : Ref Ctxt Defs} -> toCDef n ty _ None = pure $ MkError $ CCrash emptyFC ("Encountered undefined name " ++ show !(getFullName n)) toCDef n ty erased (PMDef pi args _ tree _) - = do let (args' ** p) = mkSub 0 args erased + = do log "compiler.newtype.world" 25 "toCDef PMDef args \{show $ toList args}, ty: \{show ty}, n: \{show n}, erased: \{show erased}, tree: \{show tree}" + let (args' ** p) = mkSub args erased s <- newRef NextMN 0 comptree <- toCExpTree n tree - pure $ toLam (externalDecl pi) $ if isNil erased - then MkFun args comptree - else MkFun args' (shrinkCExp p comptree) + log "compiler.newtype.world" 25 "toCDef PMDef comptree \{show comptree}, p: \{show p}, is_ext: \{show $ (externalDecl pi)}" + let lam = toLam (externalDecl pi) $ + if isNil erased + then MkFun args comptree + else MkFun args' (shrinkCExp p comptree) + log "compiler.newtype.world" 25 "toCDef PMDef lam \{show lam}, args': \{show $ toList args'}" + pure lam where toLam : Bool -> CDef -> CDef - toLam True (MkFun args rhs) = MkFun [] (lamRHS args rhs) + toLam True (MkFun args rhs) = MkFun [<] (lamRHS args rhs) toLam _ d = d toCDef n ty _ (ExternDef arity) = let (ns ** args) = mkArgList 0 arity in - pure $ MkFun _ (CExtPrim emptyFC !(getFullName n) (map toArgExp (getVars args))) + pure $ MkFun _ (CExtPrim emptyFC !(getFullName n) (reverse $ map toArgExp (getVars args))) where toArgExp : (Var ns) -> CExp ns toArgExp (MkVar p) = CLocal emptyFC p @@ -740,11 +789,11 @@ toCDef n ty _ (ExternDef arity) getVars (ConsArg a rest) = MkVar First :: map weakenVar (getVars rest) toCDef n ty _ (ForeignDef arity cs) = do defs <- get Ctxt - (atys, retty) <- getCFTypes [] !(nf defs [] ty) + (atys, retty) <- getCFTypes [] !(nf defs [<] ty) pure $ MkForeign cs atys retty toCDef n ty _ (Builtin {arity} op) = let (ns ** args) = mkArgList 0 arity in - pure $ MkFun _ (COp emptyFC op (map toArgExp (getVars args))) + pure $ MkFun _ (COp emptyFC op (reverse $ map toArgExp (getVars args))) where toArgExp : (Var ns) -> CExp ns toArgExp (MkVar p) = CLocal emptyFC p @@ -755,7 +804,7 @@ toCDef n ty _ (Builtin {arity} op) toCDef n _ _ (DCon tag arity pos) = do let nt = snd <$> pos defs <- get Ctxt - args <- numArgs {vars = []} defs (Ref EmptyFC (DataCon tag arity) n) + args <- numArgs {vars = [<]} defs (Ref EmptyFC (DataCon tag arity) n) let arity' = case args of NewTypeBy ar _ => ar EraseArgs ar erased => ar `minus` length erased @@ -780,7 +829,7 @@ toCDef n ty _ def export compileExp : {auto c : Ref Ctxt Defs} -> - ClosedTerm -> Core (CExp []) + ClosedTerm -> Core (CExp [<]) compileExp tm = do s <- newRef NextMN 0 exp <- toCExp (UN $ Basic "main") tm @@ -802,7 +851,8 @@ compileDef n -- traversing everything from the main expression. -- For now, consider it an incentive not to have cycles :). then recordWarning (GenericWarn emptyFC ("Compiling hole " ++ show n)) - else do ce <- toCDef n (type gdef) (eraseArgs gdef) + else do log "compiler.newtype.world" 25 "compileDef name \{show n}, type gdef: \{show $ type gdef}" + ce <- logDepth $ toCDef n (type gdef) (eraseArgs gdef) !(toFullNames (definition gdef)) setCompiled n ce where diff --git a/src/Compiler/ES/ToAst.idr b/src/Compiler/ES/ToAst.idr index c9d5661fe5..1d65dfff63 100644 --- a/src/Compiler/ES/ToAst.idr +++ b/src/Compiler/ES/ToAst.idr @@ -151,11 +151,11 @@ mutual -- list, to the surrounding scope. stmt e (NmApp _ x xs) = do (mbx, vx) <- liftFun x - (mbxs, args) <- liftArgs xs + (mbxs, args) <- liftArgs (toList xs) pure . prepend (mbx ++ mbxs) $ assign e (EApp vx args) stmt e (NmCon _ n ci tg xs) = do - (mbxs, args) <- liftArgs xs + (mbxs, args) <- liftArgs (toList xs) pure . prepend mbxs $ assign e (ECon (tag n tg) ci args) stmt e o@(NmOp _ x xs) = @@ -166,7 +166,7 @@ mutual pure . prepend mbxs $ assign e (EOp x args) stmt e (NmExtPrim _ n xs) = do - (mbxs, args) <- liftArgs xs + (mbxs, args) <- liftArgs (toList xs) pure . prepend mbxs $ assign e (EExtPrim n args) stmt e (NmForce _ _ x) = do diff --git a/src/Compiler/Inline.idr b/src/Compiler/Inline.idr index 535a9ca2b7..bcb91680de 100644 --- a/src/Compiler/Inline.idr +++ b/src/Compiler/Inline.idr @@ -16,24 +16,54 @@ import Core.TT import Data.Maybe import Data.List +import Data.SnocList import Data.Vect import Libraries.Data.List.LengthMatch import Libraries.Data.NameMap import Libraries.Data.WithDefault -%default covering - -data EEnv : List Name -> List Name -> Type where - Nil : EEnv free [] - (::) : CExp free -> EEnv free vars -> EEnv free (x :: vars) +import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.LengthMatch +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.HasLength +import Libraries.Data.SnocList.Extra -extend : EEnv free vars -> (args : List (CExp free)) -> (args' : List Name) -> - LengthMatch args args' -> EEnv free (args' ++ vars) -extend env [] [] NilMatch = env -extend env (a :: xs) (n :: ns) (ConsMatch w) - = a :: extend env xs ns w +%default covering -Stack : List Name -> Type +-- TODO: refactor (by G.Allois) +-- E.g. it's very similar to a `Subst` type defined in Compiler.Opts +-- or Core.TT.Subst' Subst +data EEnv : SnocList Name -> SnocList Name -> Type where + Lin : EEnv free [<] + (:<) : EEnv free vars -> CExp free -> EEnv free (vars :< x) + +snoc : EEnv free vars -> CExp free -> EEnv free ([ EEnv free varsr -> EEnv free (varsl ++ varsr) +(++) sx Lin = sx +(++) sx (sy :< y) = (sx ++ sy) :< y + +public export +covering +{free, vars : _} -> Show (EEnv free vars) where + show x = "EEnv [" ++ showAll x ++ "]{vars = " ++ show (asList vars) ++ ", free = " ++ show (toList free) ++ "}" + where + showAll : {free, vars : _} -> EEnv free vars -> String + showAll Lin = "" + showAll (Lin :< x) = show x + showAll (xx :< x) = show x ++ ", " ++ showAll xx + +extend : EEnv free vars -> + (args : List Name) -> + (argsVal : List (CExp free)) -> + Maybe (EEnv free (vars <>< args)) +extend env [] [] = pure env +extend env (_ :: ns) (v :: vs) = extend (env :< v) ns vs +extend _ _ _ = Nothing + +Stack : SnocList Name -> Type Stack vars = List (CExp vars) unload : Stack vars -> CExp vars -> CExp vars @@ -49,13 +79,34 @@ getArity (MkCon _ arity _) = arity getArity (MkForeign _ args _) = length args getArity (MkError _) = 0 +insertInMiddle : {0 local, outer : Scope} -> + SizeOf outer -> (n : Name) -> (CExp free) -> EEnv free (local ++ outer) -> EEnv free ((local :< n) ++ outer) +insertInMiddle {outer = [<]} (MkSizeOf Z Z) _ y xs = xs :< y +insertInMiddle {outer = os :< o} (MkSizeOf (S len) (S sz)) n y (xs :< x) = insertInMiddle (MkSizeOf len sz) n y xs :< x + +getArgsFromStack : Stack free -> (args : List Name) -> + List (CExp free) -> + Maybe (List (CExp free), Stack free) +getArgsFromStack (e :: es) (a :: as) acc + = getArgsFromStack es as (e :: acc) +getArgsFromStack stk [] acc = Just (acc, stk) +getArgsFromStack _ _ _ = Nothing + +takeArgs : EEnv free vars -> List (CExp free) -> (args : List Name) -> + Maybe (EEnv free (vars <>< args)) +takeArgs env (e :: es) args@(a :: as) + = do env' <- takeArgs env es as + let inserted = insertInMiddle {local=vars} {outer = cast as} (mkSizeOf $ cast as) a e (rewrite sym $ fishAsSnocAppend vars as in env') + pure (rewrite fishAsSnocAppend (vars :< a) as in inserted) +takeArgs env stk [] = pure env +takeArgs env [] args = Nothing + takeFromStack : EEnv free vars -> Stack free -> (args : List Name) -> - Maybe (EEnv free (args ++ vars), Stack free) -takeFromStack env (e :: es) (a :: as) - = do (env', stk') <- takeFromStack env es as - pure (e :: env', stk') -takeFromStack env stk [] = pure (env, stk) -takeFromStack env [] args = Nothing + Maybe (EEnv free (vars <>< args), Stack free) +takeFromStack env es as + = do (args, stk') <- getArgsFromStack es as [] + env' <- takeArgs env args as + pure (env', stk') data LVar : Type where @@ -66,7 +117,7 @@ genName n put LVar (i + 1) pure (MN n i) -refToLocal : Name -> (x : Name) -> CExp vars -> CExp (x :: vars) +refToLocal : Name -> (x : Name) -> CExp vars -> CExp (vars :< x) refToLocal x new tm = refsToLocals (Add new x None) tm largest : Ord a => a -> List a -> a @@ -105,7 +156,7 @@ mutual usedCon : {free : _} -> {idx : Nat} -> (0 p : IsVar n idx free) -> CConAlt free -> Int usedCon n (MkConAlt _ _ _ args sc) - = let MkVar n' = weakenNs (mkSizeOf args) (MkVar n) in + = let MkVar n' = weakensN (mkSizeOf args) (MkVar n) in used n' sc usedConst : {free : _} -> @@ -118,16 +169,19 @@ mutual {auto l : Ref LVar Int} -> FC -> List Name -> Stack free -> EEnv free vars -> - {idx : Nat} -> (0 p : IsVar x idx (vars ++ free)) -> + {idx : Nat} -> (0 p : IsVar x idx (free ++ vars)) -> Core (CExp free) - evalLocal {vars = []} fc rec stk env p - = pure $ unload stk (CLocal fc p) - evalLocal {vars = x :: xs} fc rec stk (v :: env) First - = case stk of + evalLocal {vars = [<]} fc rec stk env p + = do log "compiler.inline.io_bind" 50 $ "Attempting to evalLocal-1, stk: \{show stk}, p: \{show $ nameAt p}, env: \{show env}" + pure $ unload stk (CLocal fc p) + evalLocal {vars = xs :< x} fc rec stk (env :< v) First + = do log "compiler.inline.io_bind" 50 $ "Attempting to evalLocal-2, stk: \{show stk}, p: First, v: \{show v}, env: \{show env}" + case stk of [] => pure v _ => eval rec env stk (weakenNs (mkSizeOf xs) v) - evalLocal {vars = x :: xs} fc rec stk (_ :: env) (Later p) - = evalLocal fc rec stk env p + evalLocal {vars = xs :< x} fc rec stk (env :< _) (Later p) + = do log "compiler.inline.io_bind" 50 $ "Attempting to evalLocal-3, stk: \{show stk}, p: Later \{show $ nameAt p}, env: \{show env}" + logDepth $ evalLocal fc rec stk env p tryApply : {vars, free : _} -> {auto c : Ref Ctxt Defs} -> @@ -135,33 +189,46 @@ mutual List Name -> Stack free -> EEnv free vars -> CDef -> Core (Maybe (CExp free)) tryApply {free} {vars} rec stk env (MkFun args exp) - = do let Just (env', stk') = takeFromStack env stk args + = do log "compiler.inline.io_bind" 50 $ "tryApply args: \{show $ toList args}, exp: \{show exp}, stk: \{show stk}, env: \{show env}" + let Just (env', stk') + : Maybe (EEnv free (vars <>< cast args), List (CExp free)) + = (takeFromStack env stk (cast args)) | Nothing => pure Nothing - res <- eval rec env' stk' - (rewrite sym (appendAssociative args vars free) in - embed {outer = vars ++ free} exp) + let exp' : CExp (free ++ (vars <>< cast args)) = (embed $ embedFishily (castInvolutive exp)) + log "compiler.inline.io_bind" 50 $ "tryApply stk': \{show stk'}, env': \{show env'}, rec: \{show rec}, exp': \{show exp'}" + res <- eval rec env' stk' exp' pure (Just res) + where + -- it should be like that: + -- castInvolutive : { args : _ } -> cast {to=SnocList Name} (cast {to=List Name} args) === args + -- castInvolutive = ... + -- And if yes, so, we could move further in decision but for now leave it trivially: + castInvolutive : CExp args -> CExp ([<] <>< (args <>> [])) + castInvolutive = believe_me tryApply rec stk env _ = pure Nothing eval : {vars, free : _} -> {auto c : Ref Ctxt Defs} -> {auto l : Ref LVar Int} -> - List Name -> EEnv free vars -> Stack free -> CExp (vars ++ free) -> + List Name -> EEnv free vars -> Stack free -> CExp (free ++ vars) -> Core (CExp free) - eval rec env stk (CLocal fc p) = evalLocal fc rec stk env p + eval rec env stk (CLocal fc p) = + do log "compiler.inline.io_bind" 50 $ "Attempting to CLocal, env: \{show env}, stk: \{show stk}, p: \{show $ nameAt p}" + evalLocal fc rec stk env p -- This is hopefully a temporary hack, giving a special case for io_bind. -- Currently the elaborator is a bit cautious about inlining case blocks -- in case they duplicate work. We should fix that, to decide more accurately -- whether they're safe to inline, but until then this gives such a huge -- boost by removing unnecessary lambdas that we'll keep the special case. eval rec env stk (CRef fc n) = do + log "compiler.inline.io_bind" 50 $ "Attempting to CRef, rec: \{show rec}, env: \{show env}, stk: \{show stk}, n: \{show n}" when (n == NS primIONS (UN $ Basic "io_bind")) $ log "compiler.inline.io_bind" 50 $ "Attempting to inline io_bind, its stack is: \{show stk}" case (n == NS primIONS (UN $ Basic "io_bind"), stk) of (True, act :: cont :: world :: stk) => do xn <- genName "act" - sc <- eval rec [] [] (CApp fc cont [CRef fc xn, world]) + sc <- eval rec [<] [] (CApp fc cont [CRef fc xn, world]) pure $ unload stk $ CLet fc xn NotInline (CApp fc act [world]) @@ -170,7 +237,7 @@ mutual do wn <- genName "world" xn <- genName "act" let world : forall vars. CExp vars := CRef fc wn - sc <- eval rec [] [] (CApp fc cont [CRef fc xn, world]) + sc <- eval rec [<] [] (CApp fc cont [CRef fc xn, world]) pure $ CLam fc wn $ refToLocal wn wn $ CLet fc xn NotInline (CApp fc act [world]) @@ -187,17 +254,21 @@ mutual if (Inline `elem` gdefFlags) && (not (n `elem` rec)) && (not (NoInline `elem` gdefFlags)) - then do ap <- tryApply (n :: rec) stk env def + then do log "compiler.inline.io_bind" 50 $ "Attempting to CRef Inline Apply, def: \{show def}, n: \{show n}, rec: \{show rec}" + ap <- tryApply (n :: rec) stk env def + log "compiler.inline.io_bind" 50 $ "Attempting to CRef Inline Apply, ap: \{show ap}" pure $ fromMaybe (unloadApp arity stk (CRef fc n)) ap else pure $ unloadApp arity stk (CRef fc n) eval {vars} {free} rec env [] (CLam fc x sc) - = do xn <- genName "lamv" - sc' <- eval rec (CRef fc xn :: env) [] sc + = do log "compiler.inline.io_bind" 50 $ "Attempting to CLam, rec: \{show rec}, env: \{show env}, x: \{show x}, sc: \{show sc}" + xn <- genName "lamv" + sc' <- logDepth $ eval rec (env :< CRef fc xn) [] sc + log "compiler.inline.io_bind" 50 $ "Attempting to CLam, sc': \{show sc'}" pure $ CLam fc x (refToLocal xn x sc') - eval rec env (e :: stk) (CLam fc x sc) = eval rec (e :: env) stk sc + eval rec env (e :: stk) (CLam fc x sc) = eval rec (env :< e) stk sc eval {vars} {free} rec env stk (CLet fc x NotInline val sc) = do xn <- genName "letv" - sc' <- eval rec (CRef fc xn :: env) [] sc + sc' <- eval rec (env :< CRef fc xn) [] sc val' <- eval rec env [] val pure (unload stk $ CLet fc x NotInline val' (refToLocal xn x sc')) eval {vars} {free} rec env stk (CLet fc x YesInline val sc) @@ -206,9 +277,9 @@ mutual -- are guaranteed not to duplicate work. (We don't know -- that yet). then do val' <- eval rec env [] val - eval rec (val' :: env) stk sc + eval rec (env :< val') stk sc else do xn <- genName "letv" - sc' <- eval rec (CRef fc xn :: env) stk sc + sc' <- eval rec (env :< CRef fc xn) stk sc val' <- eval rec env [] val pure (CLet fc x YesInline val' (refToLocal xn x sc')) eval rec env stk (CApp fc f@(CRef nfc n) args) @@ -216,80 +287,106 @@ mutual -- a name from another module where the job is already done defs <- get Ctxt Just gdef <- lookupCtxtExact n (gamma defs) - | Nothing => do args' <- traverse (eval rec env []) args + | Nothing => do log "compiler.inline.io_bind" 50 $ "Attempting to CApp CRef Nothing, rec: \{show rec}, env: \{show env}, args: \{show args}" + -- Yaffle: (n :: rec) + args' <- logDepth $ traverse (eval rec env []) args + log "compiler.inline.io_bind" 50 $ "Attempting to CApp CRef Nothing, stk: \{show stk}, n: \{show n}, args': \{show args'}" pure (unload stk (CApp fc (CRef nfc n) args')) - eval rec env (!(traverse (eval rec env []) args) ++ stk) f + log "compiler.inline.io_bind" 50 $ "Attempting to CApp CRef, rec: \{show rec}, env: \{show env}, args: \{show args}" + -- Yaffle: (n :: rec) + args' <- logDepth $ traverse (eval rec env []) args + log "compiler.inline.io_bind" 50 $ "Attempting to CApp CRef, env: \{show env}, args': \{show args'}, stk: \{show stk}, f: \{show f}" + eval rec env (args' ++ stk) f eval rec env stk (CApp fc f args) - = eval rec env (!(traverse (eval rec env []) args) ++ stk) f + = do log "compiler.inline.io_bind" 50 $ "Attempting to CApp, f: \{show f}, args: \{show args}" + stk' <- logDepth $ traverse (eval rec env []) args + log "compiler.inline.io_bind" 50 $ "Attempting to CApp, stk': \{show stk'}, stk: \{show stk}" + eval rec env (stk' ++ stk) f eval rec env stk (CCon fc n ci t args) - = pure $ unload stk $ CCon fc n ci t !(traverse (eval rec env []) args) + = pure $ unload stk $ CCon fc n ci t !(logDepth $ traverse (eval rec env []) args) eval rec env stk (COp fc p args) - = pure $ unload stk $ COp fc p !(traverseVect (eval rec env []) args) + = pure $ unload stk $ COp fc p !(logDepth $ traverseVect (eval rec env []) args) eval rec env stk (CExtPrim fc p args) - = pure $ unload stk $ CExtPrim fc p !(traverse (eval rec env []) args) + = pure $ unload stk $ CExtPrim fc p !(logDepth $ traverse (eval rec env []) args) eval rec env stk (CForce fc lr e) = case !(eval rec env [] e) of - CDelay _ _ e' => eval rec [] stk e' + CDelay _ _ e' => eval rec [<] stk e' res => pure $ unload stk (CForce fc lr res) -- change this to preserve laziness semantics eval rec env stk (CDelay fc lr e) = pure $ unload stk (CDelay fc lr !(eval rec env [] e)) eval rec env stk (CConCase fc sc alts def) - = do sc' <- eval rec env [] sc + = do log "compiler.inline.io_bind" 50 $ "Attempting to con case, env: \{show env}, sc: \{show sc}" + sc' <- logDepth $ eval rec env [] sc let env' = update sc env sc' + log "compiler.inline.io_bind" 50 $ "Attempting to con case, env': \{show env'}, stk: \{show stk}, sc': \{show sc'}, alts: \{show alts}, def: \{show def}" Nothing <- pickAlt rec env' stk sc' alts def | Just val => pure val def' <- traverseOpt (eval rec env' stk) def - pure $ caseOfCase $ CConCase fc sc' - !(traverse (evalAlt fc rec env' stk) alts) - def' + log "compiler.inline.io_bind" 50 $ "Attempting to con case, env': \{show env'}, stk: \{show stk}, alts: \{show alts}" + alts' <- logDepth $ traverse (evalAlt fc rec env' stk) alts + log "compiler.inline.io_bind" 50 $ "Attempting to con case, sc': \{show sc'}, alts': \{show alts'}, def': \{show def'}" + pure $ caseOfCase $ CConCase fc sc' alts' def' where updateLoc : {idx, vs : _} -> - (0 p : IsVar x idx (vs ++ free)) -> + (0 p : IsVar x idx (free ++ vs)) -> EEnv free vs -> CExp free -> EEnv free vs - updateLoc {vs = []} p env val = env - updateLoc {vs = (x::xs)} First (e :: env) val = val :: env - updateLoc {vs = (y::xs)} (Later p) (e :: env) val = e :: updateLoc p env val + updateLoc {vs = [<]} p env val = env + updateLoc {vs = (xs :< x)} First (env :< e) val = env :< val + updateLoc {vs = (xs :< y)} (Later p) (env :< e) val = updateLoc p env val :< e update : {vs : _} -> - CExp (vs ++ free) -> EEnv free vs -> CExp free -> EEnv free vs + CExp (free ++ vs) -> EEnv free vs -> CExp free -> EEnv free vs update (CLocal _ p) env sc = updateLoc p env sc update _ env _ = env eval rec env stk (CConstCase fc sc alts def) - = do sc' <- eval rec env [] sc + = do sc' <- logDepth $ eval rec env [] sc Nothing <- pickConstAlt rec env stk sc' alts def | Just val => pure val def' <- traverseOpt (eval rec env stk) def pure $ caseOfCase $ CConstCase fc sc' - !(traverse (evalConstAlt rec env stk) alts) + !(logDepth $ traverse (evalConstAlt rec env stk) alts) def' eval rec env stk (CPrimVal fc c) = pure $ unload stk $ CPrimVal fc c eval rec env stk (CErased fc) = pure $ unload stk $ CErased fc eval rec env stk (CCrash fc str) = pure $ unload stk $ CCrash fc str - extendLoc : {auto l : Ref LVar Int} -> + extendLoc : {vars, free : _} -> + {auto c : Ref Ctxt Defs} -> {auto l : Ref LVar Int} -> FC -> EEnv free vars -> (args' : List Name) -> - Core (Bounds args', EEnv free (args' ++ vars)) + Core (Bounds (cast args'), EEnv free (vars <>< args')) extendLoc fc env [] = pure (None, env) - extendLoc fc env (n :: ns) - = do xn <- genName "cv" - (bs', env') <- extendLoc fc env ns - pure (Add n xn bs', CRef fc xn :: env') + extendLoc fc env a@(n :: ns) + = do log "compiler.inline.io_bind" 50 "Attempting to extendLoc, env: \{show env}, a: \{show a}" + xn <- genName "cv" + let env' = env :< CRef fc xn + (bs', env'') <- logDepth $ extendLoc fc env' ns + + let + bs'' : Bounds ([< ns) + bs'' = do + rewrite snocAppendFishAssociative [ {auto c : Ref Ctxt Defs} -> {auto l : Ref LVar Int} -> - FC -> List Name -> EEnv free vars -> Stack free -> CConAlt (vars ++ free) -> + FC -> List Name -> EEnv free vars -> Stack free -> CConAlt (free ++ vars) -> Core (CConAlt free) evalAlt {free} {vars} fc rec env stk (MkConAlt n ci t args sc) - = do (bs, env') <- extendLoc fc env args + = do log "compiler.inline.io_bind" 50 $ "Attempting to evalAlt, env: \{show env}, args: \{show args}" + (bs, env') <- extendLoc fc env args + log "compiler.inline.io_bind" 50 $ "Attempting to evalAlt, bs: \{show bs}, env': \{show env'}" scEval <- eval rec env' stk - (rewrite sym (appendAssociative args vars free) in sc) - pure $ MkConAlt n ci t args (refsToLocals bs scEval) + (rewrite sym $ snocAppendFishAssociative free vars args in sc) + pure $ MkConAlt n ci t args (rewrite snocAppendFishAssociative free [<] args in refsToLocals bs scEval) evalConstAlt : {vars, free : _} -> {auto c : Ref Ctxt Defs} -> {auto l : Ref LVar Int} -> - List Name -> EEnv free vars -> Stack free -> CConstAlt (vars ++ free) -> + List Name -> EEnv free vars -> Stack free -> CConstAlt (free ++ vars) -> Core (CConstAlt free) evalConstAlt rec env stk (MkConstAlt c sc) = MkConstAlt c <$> eval rec env stk sc @@ -298,21 +395,18 @@ mutual {auto c : Ref Ctxt Defs} -> {auto l : Ref LVar Int} -> List Name -> EEnv free vars -> Stack free -> - CExp free -> List (CConAlt (vars ++ free)) -> - Maybe (CExp (vars ++ free)) -> + CExp free -> List (CConAlt (free ++ vars)) -> + Maybe (CExp (free ++ vars)) -> Core (Maybe (CExp free)) pickAlt rec env stk (CCon fc n ci t args) [] def = traverseOpt (eval rec env stk) def pickAlt {vars} {free} rec env stk con@(CCon fc n ci t args) (MkConAlt n' _ t' args' sc :: alts) def - = if matches n t n' t' - then case checkLengthMatch args args' of - Nothing => pure Nothing - Just m => - do let env' : EEnv free (args' ++ vars) - = extend env args args' m - pure $ Just !(eval rec env' stk - (rewrite sym (appendAssociative args' vars free) in - sc)) + = + if matches n t n' t' + then do let Just env' = extend env args' args + | Nothing => pure Nothing + pure $ Just !(eval rec env' stk + (rewrite sym $ snocAppendFishAssociative free vars args' in sc)) else pickAlt rec env stk con alts def where matches : Name -> Maybe Int -> Name -> Maybe Int -> Bool @@ -325,15 +419,15 @@ mutual {auto c : Ref Ctxt Defs} -> {auto l : Ref LVar Int} -> List Name -> EEnv free vars -> Stack free -> - CExp free -> List (CConstAlt (vars ++ free)) -> - Maybe (CExp (vars ++ free)) -> + CExp free -> List (CConstAlt (free ++ vars)) -> + Maybe (CExp (free ++ vars)) -> Core (Maybe (CExp free)) pickConstAlt rec env stk (CPrimVal fc c) [] def = traverseOpt (eval rec env stk) def pickConstAlt {vars} {free} rec env stk (CPrimVal fc c) (MkConstAlt c' sc :: alts) def = if c == c' then Just <$> eval rec env stk sc - else pickConstAlt rec env stk (CPrimVal fc c) alts def + else logDepth $ pickConstAlt rec env stk (CPrimVal fc c) alts def pickConstAlt rec env stk _ _ _ = pure Nothing -- Inlining may have messed with function arity (e.g. by adding lambdas to @@ -415,33 +509,33 @@ fixArity d = pure d -- TODO: get rid of this `done` by making the return `args'` runtime irrelevant? getLams : {done : _} -> SizeOf done -> - Int -> SubstCEnv done args -> CExp (done ++ args) -> - (args' ** (SizeOf args', SubstCEnv args' args, CExp (args' ++ args))) + Int -> SubstCEnv done args -> CExp (args ++ done) -> + (args' ** (SizeOf args', SubstCEnv args' args, CExp (args ++ args'))) getLams {done} d i env (CLam fc x sc) - = getLams {done = x :: done} (suc d) (i + 1) (CRef fc (MN "ext" i) :: env) sc + = getLams {done = done :< x} (suc d) (i + 1) (env :< CRef fc (MN "ext" i)) sc getLams {done} d i env sc = (done ** (d, env, sc)) mkBounds : (xs : _) -> Bounds xs -mkBounds [] = None -mkBounds (x :: xs) = Add x x (mkBounds xs) +mkBounds [<] = None +mkBounds (xs :< x) = Add x x (mkBounds xs) getNewArgs : {done : _} -> - SubstCEnv done args -> List Name -getNewArgs [] = [] -getNewArgs (CRef _ n :: xs) = n :: getNewArgs xs -getNewArgs {done = x :: xs} (_ :: sub) = x :: getNewArgs sub + SubstCEnv done args -> SnocList Name +getNewArgs [<] = [<] +getNewArgs (xs :< CRef _ n) = getNewArgs xs :< n +getNewArgs {done = xs :< x} (sub :< _) = getNewArgs sub :< x -- Move any lambdas in the body of the definition into the lhs list of vars. -- Annoyingly, the indices will need fixing up because the order in the top -- level definition goes left to right (i.e. first argument has lowest index, -- not the highest, as you'd expect if they were all lambdas). -mergeLambdas : (args : List Name) -> CExp args -> (args' ** CExp args') +mergeLambdas : (args : SnocList Name) -> CExp args -> (args' ** CExp args') mergeLambdas args (CLam fc x sc) - = let (args' ** (s, env, exp')) = getLams zero 0 [] (CLam fc x sc) + = let (args' ** (s, env, exp')) = getLams zero 0 [<] (CLam fc x sc) expNs = substs s env exp' newArgs = reverse $ getNewArgs env - expLocs = mkLocals (mkSizeOf args) {vars = []} (mkBounds newArgs) - (rewrite appendNilRightNeutral args in expNs) in + expLocs = mkLocals (mkSizeOf args) {vars = [<]} (mkBounds newArgs) + (rewrite appendLinLeftNeutral args in expNs) in (_ ** expLocs) mergeLambdas args exp = (args ** exp) @@ -453,8 +547,8 @@ doEval : {args : _} -> (n : Name) -> (exp : CExp args) -> Core (CExp args) doEval n exp = do l <- newRef LVar (the Int 0) - log "compiler.inline.eval" 10 (show n ++ ": " ++ show exp) - exp' <- eval [] [] [] exp + log "compiler.inline.eval" 10 ("Origin: " ++ show n ++ " args: " ++ show (toList args) ++ " exp: " ++ show exp) + exp' <- logDepth $ eval [] [<] [] exp log "compiler.inline.eval" 10 ("Inlined: " ++ show exp') pure exp' @@ -468,7 +562,9 @@ inline n d = pure d mergeLam : {auto c : Ref Ctxt Defs} -> CDef -> Core CDef mergeLam (MkFun args def) - = do let (args' ** exp') = mergeLambdas args def + = do log "compiler.inline.io_bind" 50 "mergeLam, args: \{show $ toList args}, def: \{show def}" + let (args' ** exp') = mergeLambdas args def + log "compiler.inline.io_bind" 50 "mergeLam, args': \{show $ toList args'}, exp': \{show exp'}" pure $ MkFun args' exp' mergeLam d = pure d @@ -574,17 +670,17 @@ compileAndInlineAll let ns = keys (toIR defs) cns <- filterM nonErased ns - traverse_ compileDef cns - traverse_ rewriteIdentityFlag cns + traverse_ (logDepthWrap compileDef) cns + traverse_ (logDepthWrap rewriteIdentityFlag) cns transform 3 cns -- number of rounds to run transformations. -- This seems to be the point where not much useful -- happens any more. - traverse_ updateCallGraph cns + traverse_ (logDepthWrap updateCallGraph) cns -- in incremental mode, add the arity of the definitions to the hash, -- because if these change we need to recompile dependencies -- accordingly unless (isNil (incrementalCGs !getSession)) $ - traverse_ addArityHash cns + traverse_ (logDepthWrap addArityHash) cns where transform : Nat -> List Name -> Core () transform Z cns = pure () diff --git a/src/Compiler/Interpreter/VMCode.idr b/src/Compiler/Interpreter/VMCode.idr index b5279d6176..6fc9bd7b6f 100644 --- a/src/Compiler/Interpreter/VMCode.idr +++ b/src/Compiler/Interpreter/VMCode.idr @@ -113,7 +113,7 @@ indexMaybe (x :: xs) idx = if idx <= 0 then Just x else indexMaybe xs (idx - 1) callPrim : Ref State InterpState => Stack -> PrimFn ar -> Vect ar Object -> Core Object callPrim stk BelieveMe [_, _, obj] = pure obj callPrim stk fn args = case the (Either Object (Vect ar Constant)) $ traverse getConst args of - Right args' => case getOp {vars=[]} fn (NPrimVal EmptyFC <$> args') of + Right args' => case getOp {vars=[<]} fn (NPrimVal EmptyFC <$> args') of Just (NPrimVal _ res) => pure $ Const res _ => interpError stk $ "OP: Error calling " ++ show (opName fn) ++ " with operands: " ++ show args' Left obj => interpError stk $ "OP: Expected Constant, found " ++ showType obj diff --git a/src/Compiler/LambdaLift.idr b/src/Compiler/LambdaLift.idr index ec53c35ac1..fe2d9dc7a6 100644 --- a/src/Compiler/LambdaLift.idr +++ b/src/Compiler/LambdaLift.idr @@ -16,8 +16,11 @@ import Core.Core import Core.TT import Data.List +import Data.SnocList import Data.Vect +import Libraries.Data.SnocList.Extra + %default covering mutual @@ -92,7 +95,7 @@ mutual ||| @ expr is the expression to bind `x` to. ||| @ body is the expression to evaluate after binding. LLet : FC -> (x : Name) -> (expr : Lifted vars) -> - (body : Lifted (x :: vars)) -> Lifted vars + (body : Lifted (vars :< x)) -> Lifted vars ||| Use of a constructor to construct a compound data type value. ||| @@ -169,7 +172,7 @@ mutual ||| @ vars is the list of names accessible within the current scope of the ||| lambda-lifted code. public export - data LiftedConAlt : (vars : List Name) -> Type where + data LiftedConAlt : (vars : SnocList Name) -> Type where ||| Constructs a branch of an "LCon" (constructor tag) case statement. ||| @@ -187,7 +190,7 @@ mutual ||| @ body is the expression that is evaluated as the consequence of ||| this branch matching. MkLConAlt : (n : Name) -> (info : ConInfo) -> (tag : Maybe Int) -> - (args : List Name) -> (body : Lifted (args ++ vars)) -> + (args : List Name) -> (body : Lifted (vars <>< args)) -> LiftedConAlt vars ||| A branch of an "LConst" (constant expression) case statement. @@ -195,7 +198,7 @@ mutual ||| @ vars is the list of names accessible within the current scope of the ||| lambda-lifted code. public export - data LiftedConstAlt : (vars : List Name) -> Type where + data LiftedConstAlt : (vars : SnocList Name) -> Type where ||| Constructs a branch of an "LConst" (constant expression) case ||| statement. @@ -224,8 +227,8 @@ data LiftedDef : Type where -- (Sorry for the awkward API - it's to do with how the indices are -- arranged for the variables, and it could be expensive to reshuffle them! -- See Compiler.ANF for an example of how they get resolved to names) - MkLFun : (args : List Name) -> (scope : List Name) -> - (body : Lifted (scope ++ args)) -> LiftedDef + MkLFun : (args : SnocList Name) -> (scope : SnocList Name) -> + (body : Lifted (args ++ scope)) -> LiftedDef ||| Constructs a definition of a constructor for a compound data type. ||| @@ -258,7 +261,7 @@ data LiftedDef : Type where ||| `LCrash` rather than `prim_crash`. ||| ||| @ expl : an explanation of the error. - MkLError : (expl : Lifted []) -> LiftedDef + MkLError : (expl : Lifted [<]) -> LiftedDef showLazy : Maybe LazyReason -> String showLazy = maybe "" $ (" " ++) . show @@ -269,26 +272,26 @@ mutual {vs : _} -> Show (Lifted vs) where show (LLocal {idx} _ p) = "!" ++ show (nameAt p) show (LAppName fc lazy n args) - = show n ++ showLazy lazy ++ "(" ++ showSep ", " (map show args) ++ ")" + = show n ++ showLazy lazy ++ "(" ++ showSep ", " (toList $ map show args) ++ ")" show (LUnderApp fc n m args) = "<" ++ show n ++ " underapp " ++ show m ++ ">(" ++ - showSep ", " (map show args) ++ ")" + showSep ", " (toList $ map show args) ++ ")" show (LApp fc lazy c arg) = show c ++ showLazy lazy ++ " @ (" ++ show arg ++ ")" show (LLet fc x val sc) = "%let " ++ show x ++ " = " ++ show val ++ " in " ++ show sc show (LCon fc n _ t args) - = "%con " ++ show n ++ "(" ++ showSep ", " (map show args) ++ ")" + = "%con " ++ show n ++ "(" ++ showSep ", " (toList $ map show args) ++ ")" show (LOp fc lazy op args) = "%op " ++ show op ++ showLazy lazy ++ "(" ++ showSep ", " (toList (map show args)) ++ ")" show (LExtPrim fc lazy p args) - = "%extprim " ++ show p ++ showLazy lazy ++ "(" ++ showSep ", " (map show args) ++ ")" + = "%extprim " ++ show p ++ showLazy lazy ++ "(" ++ showSep ", " (toList $ map show args) ++ ")" show (LConCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def + ++ showSep "| " (toList $ map show alts) ++ " " ++ show def show (LConstCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def + ++ showSep "| " (toList $ map show alts) ++ " " ++ show def show (LPrimVal _ x) = show x show (LErased _) = "___" show (LCrash _ x) = "%CRASH(" ++ show x ++ ")" @@ -298,7 +301,7 @@ mutual {vs : _} -> Show (LiftedConAlt vs) where show (MkLConAlt n _ t args sc) = "%conalt " ++ show n ++ - "(" ++ showSep ", " (map show args) ++ ") => " ++ show sc + "(" ++ showSep ", " (toList $ map show args) ++ ") => " ++ show sc export covering @@ -349,7 +352,7 @@ unload fc _ f [] = pure f -- only outermost LApp must be lazy as rest will be closures unload fc lazy f (a :: as) = unload fc Nothing (LApp fc lazy f a) as -record Used (vars : List Name) where +record Used (vars : SnocList Name) where constructor MkUsed used : Vect (length vars) Bool @@ -357,25 +360,45 @@ initUsed : {vars : _} -> Used vars initUsed {vars} = MkUsed (replicate (length vars) False) lengthDistributesOverAppend - : (xs, ys : List a) - -> length (xs ++ ys) = length xs + length ys -lengthDistributesOverAppend [] ys = Refl -lengthDistributesOverAppend (x :: xs) ys = + : (xs, ys : SnocList a) + -> length (ys ++ xs) = length xs + length ys +lengthDistributesOverAppend [<] ys = Refl +lengthDistributesOverAppend (xs :< x) ys = cong S $ lengthDistributesOverAppend xs ys -weakenUsed : {outer : _} -> Used vars -> Used (outer ++ vars) +weakenUsed : {outer : _} -> Used vars -> Used (vars ++ outer) weakenUsed {outer} (MkUsed xs) = MkUsed (rewrite lengthDistributesOverAppend outer vars in (replicate (length outer) False ++ xs)) -contractUsed : (Used (x::vars)) -> Used vars +-- TODO +-- lengthDistributesOverAppendFish +-- : (xs : List a) +-- -> (ys : SnocList a) +-- -> length (ys <>< xs) = length xs + length ys + +weakenUsedFish : {outer : _} -> Used vars -> Used (vars <>< outer) +weakenUsedFish {outer} (MkUsed xs) = + do rewrite fishAsSnocAppend vars outer + MkUsed $ do + rewrite lengthDistributesOverAppend (cast outer) vars + -- See lengthDistributesOverAppendFish + (believe_me $ replicate (length outer) False ++ xs) + +contractUsed : (Used (vars :< x)) -> Used vars contractUsed (MkUsed xs) = MkUsed (tail xs) contractUsedMany : {remove : _} -> - (Used (remove ++ vars)) -> + (Used (vars ++ remove)) -> + Used vars +contractUsedMany {remove=[<]} x = x +contractUsedMany {remove=(rs :< r)} x = contractUsedMany {remove=rs} (contractUsed x) + +contractUsedManyFish : {remove : _} -> + (Used (vars <>< remove)) -> Used vars -contractUsedMany {remove=[]} x = x -contractUsedMany {remove=(r::rs)} x = contractUsedMany {remove=rs} (contractUsed x) +contractUsedManyFish {remove=[]} x = x +contractUsedManyFish {remove=(r :: rs)} x = contractUsed $ contractUsedManyFish {remove=rs} x markUsed : {vars : _} -> (idx : Nat) -> @@ -397,21 +420,21 @@ getUnused : Used vars -> getUnused (MkUsed uv) = map not uv total -dropped : (vars : List Name) -> +dropped : (vars : SnocList Name) -> (drop : Vect (length vars) Bool) -> - List Name -dropped [] _ = [] -dropped (x::xs) (False::us) = x::(dropped xs us) -dropped (x::xs) (True::us) = dropped xs us + SnocList Name +dropped [<] _ = [<] +dropped (xs :< x) (False::us) = dropped xs us :< x +dropped (xs :< x) (True::us) = dropped xs us mutual makeLam : {auto l : Ref Lifts LDefs} -> {vars : _} -> {doLazyAnnots : Bool} -> {default Nothing lazy : Maybe LazyReason} -> - FC -> (bound : List Name) -> - CExp (bound ++ vars) -> Core (Lifted vars) - makeLam fc bound (CLam _ x sc') = makeLam fc {doLazyAnnots} {lazy} (x :: bound) sc' + FC -> (bound : SnocList Name) -> + CExp (vars ++ bound) -> Core (Lifted vars) + makeLam fc bound (CLam _ x sc') = makeLam fc {doLazyAnnots} {lazy} (bound :< x) sc' makeLam {vars} fc bound sc = do scl <- liftExp {doLazyAnnots} {lazy} sc -- Find out which variables aren't used in the new definition, and @@ -425,15 +448,15 @@ mutual pure $ LUnderApp fc n (length bound) (allVars fc vars unused) where - allPrfs : (vs : List Name) -> (unused : Vect (length vs) Bool) -> List (Var vs) - allPrfs [] _ = [] - allPrfs (v :: vs) (False::uvs) = MkVar First :: map weaken (allPrfs vs uvs) - allPrfs (v :: vs) (True::uvs) = map weaken (allPrfs vs uvs) + allPrfs : (vs : SnocList Name) -> (unused : Vect (length vs) Bool) -> List (Var vs) + allPrfs [<] _ = [] + allPrfs (vs :< v) (False::uvs) = MkVar First :: map weaken (allPrfs vs uvs) + allPrfs (vs :< v) (True::uvs) = map weaken (allPrfs vs uvs) -- apply to all the variables. 'First' will be first in the last, which -- is good, because the most recently bound name is the first argument to -- the resulting function - allVars : FC -> (vs : List Name) -> (unused : Vect (length vs) Bool) -> List (Lifted vs) + allVars : FC -> (vs : SnocList Name) -> (unused : Vect (length vs) Bool) -> List (Lifted vs) allVars fc vs unused = map (\ (MkVar p) => LLocal fc p) (allPrfs vs unused) -- if doLazyAnnots = True then annotate function application with laziness @@ -445,7 +468,7 @@ mutual CExp vars -> Core (Lifted vars) liftExp (CLocal fc prf) = pure $ LLocal fc prf liftExp (CRef fc n) = pure $ LAppName fc lazy n [] -- probably shouldn't happen! - liftExp (CLam fc x sc) = makeLam {doLazyAnnots} {lazy} fc [x] sc + liftExp (CLam fc x sc) = makeLam {doLazyAnnots} {lazy} fc [ Used vars -> LiftedConAlt vars -> Used vars usedConAlt used (MkLConAlt n ci tag args sc) = - contractUsedMany {remove=args} (usedVars (weakenUsed used) sc) + contractUsedManyFish {remove=args} (usedVars (weakenUsedFish used) sc) usedVars used (LConstCase fc sc alts def) = let defUsed = maybe used (usedVars used {vars}) def @@ -529,24 +552,24 @@ mutual dropIdx : {vars : _} -> {idx : _} -> - (outer : List Name) -> + (outer : SnocList Name) -> (unused : Vect (length vars) Bool) -> - (0 p : IsVar x idx (outer ++ vars)) -> - Var (outer ++ (dropped vars unused)) - dropIdx [] (False::_) First = MkVar First - dropIdx [] (True::_) First = assert_total $ + (0 p : IsVar x idx (vars ++ outer)) -> + Var ((dropped vars unused) ++ outer) + dropIdx [<] (False::_) First = MkVar First + dropIdx [<] (True::_) First = assert_total $ idris_crash "INTERNAL ERROR: Referenced variable marked as unused" - dropIdx [] (False::rest) (Later p) = Var.later $ dropIdx [] rest p - dropIdx [] (True::rest) (Later p) = dropIdx [] rest p - dropIdx (_::xs) unused First = MkVar First - dropIdx (_::xs) unused (Later p) = Var.later $ dropIdx xs unused p + dropIdx [<] (False::rest) (Later p) = Var.later $ dropIdx [<] rest p + dropIdx [<] (True::rest) (Later p) = dropIdx [<] rest p + dropIdx (xs :< _) unused First = MkVar First + dropIdx (xs :< _) unused (Later p) = Var.later $ dropIdx xs unused p dropUnused : {vars : _} -> {auto _ : Ref Lifts LDefs} -> - {outer : List Name} -> + {outer : SnocList Name} -> (unused : Vect (length vars) Bool) -> - (l : Lifted (outer ++ vars)) -> - Lifted (outer ++ (dropped vars unused)) + (l : Lifted (vars ++ outer)) -> + Lifted ((dropped vars unused) ++ outer) dropUnused _ (LPrimVal fc val) = LPrimVal fc val dropUnused _ (LErased fc) = LErased fc dropUnused _ (LCrash fc msg) = LCrash fc msg @@ -557,7 +580,7 @@ mutual LCon fc n ci tag args' dropUnused {outer} unused (LLet fc n val sc) = let val' = dropUnused unused val - sc' = dropUnused {outer=n::outer} (unused) sc in + sc' = dropUnused {outer= outer :< n} (unused) sc in LLet fc n val' sc' dropUnused unused (LApp fc lazy c arg) = let c' = dropUnused unused c @@ -579,18 +602,25 @@ mutual let alts' = map dropConCase alts in LConCase fc (dropUnused unused sc) alts' (map (dropUnused unused) def) where - dropConCase : LiftedConAlt (outer ++ vars) -> - LiftedConAlt (outer ++ (dropped vars unused)) + dropConCase : LiftedConAlt (vars ++ outer) -> + LiftedConAlt (dropped vars unused ++ outer) dropConCase (MkLConAlt n ci t args sc) = - let sc' = (rewrite sym $ appendAssociative args outer vars in sc) - droppedSc = dropUnused {vars=vars} {outer=args++outer} unused sc' in - MkLConAlt n ci t args (rewrite appendAssociative args outer (dropped vars unused) in droppedSc) + MkLConAlt n ci t args droppedSc + where + sc' : Lifted (vars ++ (outer <>< args)) + sc' = rewrite sym $ snocAppendFishAssociative vars outer args in sc + + droppedSc : Lifted ((dropped vars unused ++ outer) <>< args) + droppedSc = do + rewrite snocAppendFishAssociative (dropped vars unused) outer args + dropUnused {vars=vars} {outer=outer <>< args} unused sc' + dropUnused {vars} {outer} unused (LConstCase fc sc alts def) = let alts' = map dropConstCase alts in LConstCase fc (dropUnused unused sc) alts' (map (dropUnused unused) def) where - dropConstCase : LiftedConstAlt (outer ++ vars) -> - LiftedConstAlt (outer ++ (dropped vars unused)) + dropConstCase : LiftedConstAlt (vars ++ outer) -> + LiftedConstAlt ((dropped vars unused) ++ outer) dropConstCase (MkLConstAlt c val) = MkLConstAlt c (dropUnused unused val) export @@ -606,7 +636,7 @@ export lambdaLiftDef : (doLazyAnnots : Bool) -> Name -> CDef -> Core (List (Name, LiftedDef)) lambdaLiftDef doLazyAnnots n (MkFun args exp) = do (expl, defs) <- liftBody {doLazyAnnots} n exp - pure ((n, MkLFun args [] expl) :: defs) + pure ((n, MkLFun args [<] expl) :: defs) lambdaLiftDef _ n (MkCon t a nt) = pure [(n, MkLCon t a nt)] lambdaLiftDef _ n (MkForeign ccs fargs ty) = pure [(n, MkLForeign ccs fargs ty)] lambdaLiftDef doLazyAnnots n (MkError exp) diff --git a/src/Compiler/Opts/CSE.idr b/src/Compiler/Opts/CSE.idr index cf1ce54e03..b530121651 100644 --- a/src/Compiler/Opts/CSE.idr +++ b/src/Compiler/Opts/CSE.idr @@ -42,13 +42,15 @@ import Data.Vect import Libraries.Data.SortedSet import Libraries.Data.SortedMap +import Libraries.Data.SnocList.Extra + ||| Maping from a pairing of closed terms together with ||| their size (for efficiency) to the number of ||| occurences in toplevel definitions and flag for ||| whether it was encountered in delayed subexpression. public export UsageMap : Type -UsageMap = SortedMap (Integer, CExp []) (Name, Integer, Bool) +UsageMap = SortedMap (Integer, CExp [<]) (Name, Integer, Bool) ||| Number of appearances of a closed expression. ||| @@ -76,7 +78,7 @@ Show Count where ||| some delayed expression. public export ReplaceMap : Type -ReplaceMap = SortedMap Name (CExp [], Count, Bool) +ReplaceMap = SortedMap Name (CExp [<], Count, Bool) toReplaceMap : UsageMap -> ReplaceMap toReplaceMap = SortedMap.fromList @@ -99,7 +101,7 @@ record St where -- returning a new machine generated name to be used -- if the expression should be lifted to the toplevel. -- Very small expressions are being ignored. -store : Ref Sts St => Integer -> CExp [] -> Core (Maybe Name) +store : Ref Sts St => Integer -> CExp [<] -> Core (Maybe Name) store sz exp = if sz < 5 then pure Nothing @@ -118,13 +120,13 @@ store sz exp = -- Strengthening of Expressions -------------------------------------------------------------------------------- -dropVar : (pre : List Name) +dropVar : (pre : SnocList Name) -> (n : Nat) - -> (0 p : IsVar x n (pre ++ ns)) + -> (0 p : IsVar x n (ns ++ pre)) -> Maybe (IsVar x n pre) -dropVar [] _ _ = Nothing -dropVar (y :: xs) 0 First = Just First -dropVar (y :: xs) (S k) (Later p) = +dropVar [<] _ _ = Nothing +dropVar (xs :< y) 0 First = Just First +dropVar (xs :< y) (S k) (Later p) = case dropVar xs k p of Just p' => Just $ Later p' Nothing => Nothing @@ -133,7 +135,7 @@ mutual -- tries to 'strengthen' an expression by removing -- a prefix of bound variables. typically, this is invoked -- with `{pre = []}`. - dropEnv : {pre : List Name} -> CExp (pre ++ ns) -> Maybe (CExp pre) + dropEnv : {pre : SnocList Name} -> CExp (ns ++ pre) -> Maybe (CExp pre) dropEnv (CLocal {idx} fc p) = (\q => CLocal fc q) <$> dropVar pre idx p dropEnv (CRef fc x) = Just (CRef fc x) dropEnv (CLam fc x y) = CLam fc x <$> dropEnv y @@ -161,14 +163,15 @@ mutual dropEnv (CErased fc) = Just $ CErased fc dropEnv (CCrash fc x) = Just $ CCrash fc x - dropConAlt : {pre : List Name} - -> CConAlt (pre ++ ns) + dropConAlt : {pre : SnocList Name} + -> CConAlt (ns ++ pre) -> Maybe (CConAlt pre) - dropConAlt (MkConAlt x y tag args z) = - MkConAlt x y tag args . embed <$> dropEnv z + dropConAlt (MkConAlt x y tag args z) + = do z <- dropEnv {ns} (rewrite sym $ snocAppendFishAssociative ns pre args in z) + pure $ MkConAlt x y tag args z - dropConstAlt : {pre : List Name} - -> CConstAlt (pre ++ ns) + dropConstAlt : {pre : SnocList Name} + -> CConstAlt (ns ++ pre) -> Maybe (CConstAlt pre) dropConstAlt (MkConstAlt x y) = MkConstAlt x <$> dropEnv y @@ -204,7 +207,7 @@ mutual analyze exp = do (sze, exp') <- analyzeSubExp exp - case dropEnv {pre = []} exp' of + case dropEnv {pre = [<]} exp' of Just e0 => do Just nm <- store sze e0 | Nothing => pure (sze, exp') @@ -474,12 +477,12 @@ replaceDef (n, fc, d@(MkError _)) = pure (n, fc, d) newToplevelDefs : ReplaceMap -> List (Name, FC, CDef) newToplevelDefs rm = mapMaybe toDef $ SortedMap.toList rm - where toDef : (Name,(CExp[],Count,Bool)) -> Maybe (Name, FC, CDef) - toDef (nm,(exp,Many,False)) = Just (nm, EmptyFC, MkFun [] exp) - toDef (nm,(exp,Many,True)) = Just (nm, EmptyFC, MkFun [] (CDelay EmptyFC LLazy exp)) + where toDef : (Name,(CExp [<],Count,Bool)) -> Maybe (Name, FC, CDef) + toDef (nm,(exp,Many,False)) = Just (nm, EmptyFC, MkFun [<] exp) + toDef (nm,(exp,Many,True)) = Just (nm, EmptyFC, MkFun [<] (CDelay EmptyFC LLazy exp)) toDef _ = Nothing -undefinedCount : (Name, (CExp [], Count)) -> Bool +undefinedCount : (Name, (CExp [<], Count)) -> Bool undefinedCount (_, _, Once) = False undefinedCount (_, _, Many) = False undefinedCount (_, _, C x) = True diff --git a/src/Compiler/Opts/ConstantFold.idr b/src/Compiler/Opts/ConstantFold.idr index 3f814bf8a5..1f568c4367 100644 --- a/src/Compiler/Opts/ConstantFold.idr +++ b/src/Compiler/Opts/ConstantFold.idr @@ -7,8 +7,14 @@ import Core.Primitives import Core.Value import Core.Name import Data.List +import Data.SnocList import Data.Vect +import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf + +%hide Core.TT.Subst.Subst + findConstAlt : Constant -> List (CConstAlt vars) -> Maybe (CExp vars) -> Maybe (CExp vars) findConstAlt c [] def = def @@ -24,34 +30,42 @@ foldableOp (Cast from to) = isJust (intKind from) && isJust (intKind to) foldableOp _ = True -data Subst : List Name -> List Name -> Type where - Nil : Subst [] vars - (::) : CExp vars -> Subst ds vars -> Subst (d :: ds) vars - Wk : SizeOf ws -> Subst ds vars -> Subst (ws ++ ds) (ws ++ vars) +data Subst : SnocList Name -> SnocList Name -> Type where + Lin : Subst [<] vars + (:<) : Subst ds vars -> CExp vars -> Subst (ds :< d) vars + Wk : Subst ds vars -> SizeOf ws -> Subst (ds ++ ws) (vars ++ ws) -initSubst : (vars : List Name) -> Subst vars vars +initSubst : (vars : SnocList Name) -> Subst vars vars initSubst vars - = rewrite sym $ appendNilRightNeutral vars in - Wk (mkSizeOf vars) [] - - -wk : SizeOf out -> Subst ds vars -> Subst (out ++ ds) (out ++ vars) -wk sout (Wk {ws, ds, vars} sws rho) - = rewrite appendAssociative out ws ds in - rewrite appendAssociative out ws vars in - Wk (sout + sws) rho -wk ws rho = Wk ws rho - -record WkCExp (vars : List Name) where + = rewrite sym $ appendLinLeftNeutral vars in + Wk [<] (mkSizeOf vars) + + +wk : Subst ds vars -> SizeOf out -> Subst (ds ++ out) (vars ++ out) +wk (Wk {ws, ds, vars} rho sws) sout + = do + rewrite sym $ appendAssociative ds ws out + rewrite sym $ appendAssociative vars ws out + -- Yaffle: Wk rho (sout + sws) + Wk rho (sws + sout) +wk rho ws = Wk rho ws + +wksN : Subst ds vars -> SizeOf out -> Subst (ds <>< out) (vars <>< out) +wksN s s' + = rewrite fishAsSnocAppend ds out in + rewrite fishAsSnocAppend vars out in + wk s (zero <>< s') + +record WkCExp (vars : Scope) where constructor MkWkCExp - {0 outer, supp : List Name} + {0 outer, supp : Scope} size : SizeOf outer - 0 prf : vars === outer ++ supp + 0 prf : vars === supp ++ outer expr : CExp supp Weaken WkCExp where - weakenNs s' (MkWkCExp {outer, supp} s Refl e) - = MkWkCExp (s' + s) (appendAssociative ns outer supp) e + weakenNs s' (MkWkCExp {supp, outer} s Refl e) + = MkWkCExp (s + s') (sym $ appendAssociative supp outer ns) e lookup : FC -> Var ds -> Subst ds vars -> CExp vars lookup fc (MkVar p) rho = case go p rho of @@ -62,17 +76,18 @@ lookup fc (MkVar p) rho = case go p rho of go : {i : Nat} -> {0 ds, vars : _} -> (0 _ : IsVar n i ds) -> Subst ds vars -> Either (Var vars) (WkCExp vars) - go First (val :: rho) = Right (MkWkCExp zero Refl val) - go (Later p) (val :: rho) = go p rho - go p (Wk ws rho) = case sizedView ws of + go First (rho :< val) = Right (MkWkCExp zero Refl val) + go (Later p) (rho :< val) = go p rho + go p (Wk rho ws) = case sizedView ws of Z => go p rho S ws' => case i of Z => Left (MkVar First) - S i' => bimap later weaken (go (dropLater p) (Wk ws' rho)) + S i' => bimap later weaken (go (dropLater p) (Wk rho ws')) replace : CExp vars -> Bool replace (CLocal _ _) = True replace (CPrimVal _ _) = True +-- Yaffle: the line is removed replace (CErased _) = True replace _ = False @@ -87,16 +102,16 @@ constFold : {vars' : _} -> constFold rho (CLocal fc p) = lookup fc (MkVar p) rho constFold rho e@(CRef fc x) = CRef fc x constFold rho (CLam fc x y) - = CLam fc x $ constFold (wk (mkSizeOf [x]) rho) y - + = CLam fc x $ constFold (wk rho (mkSizeOf [ constFold (val::rho) z - False => case constFold (wk (mkSizeOf [x]) rho) z of + True => constFold (rho :< val) z + False => case constFold (wk rho (mkSizeOf [ val body => CLet fc x inl val body constFold rho (CApp fc (CRef fc2 n) [x]) = @@ -104,13 +119,14 @@ constFold rho (CApp fc (CRef fc2 n) [x]) = then case constFold rho x of CPrimVal fc3 (BI v) => if v >= 0 then CPrimVal fc3 (BI v) else CPrimVal fc3 (BI 0) - v => CApp fc (CRef fc2 n) [v] - else CApp fc (CRef fc2 n) [constFold rho x] + v => CApp fc (CRef fc2 n) (v :: Nil) + else CApp fc (CRef fc2 n) (constFold rho x :: Nil) constFold rho (CApp fc x xs) = CApp fc (constFold rho x) (constFold rho <$> xs) -- erase `UNIT` constructors, so they get constant-folded -- in `let` bindings (for instance, when optimizing `(>>)` for `IO` constFold rho (CCon fc x UNIT tag []) = CErased fc constFold rho (CCon fc x y tag xs) = CCon fc x y tag $ constFold rho <$> xs +--- ? constFold rho (COp fc BelieveMe [CErased _, CErased _ , x]) = constFold rho x constFold rho (COp {arity} fc fn xs) = let xs' = map (constFold rho) xs @@ -157,7 +173,7 @@ constFold rho (CConCase fc sc xs x) where foldAlt : CConAlt vars -> CConAlt vars' foldAlt (MkConAlt n ci t xs e) - = MkConAlt n ci t xs $ constFold (wk (mkSizeOf xs) rho) e + = MkConAlt n ci t xs $ constFold (wksN rho (mkSizeOf xs)) e constFold rho (CConstCase fc sc xs x) = let sc' = constFold rho sc diff --git a/src/Compiler/Opts/Identity.idr b/src/Compiler/Opts/Identity.idr index 0349381e65..932fe46cf7 100644 --- a/src/Compiler/Opts/Identity.idr +++ b/src/Compiler/Opts/Identity.idr @@ -4,19 +4,28 @@ import Compiler.CompileExpr import Core.Context import Core.Context.Log import Data.List +import Data.SnocList import Data.Vect -makeArgs : (args : List Name) -> List (Var (args ++ vars)) +import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf + +makeArgs : (args : SnocList Name) -> List (Var (vars ++ args)) makeArgs args = makeArgs' args id where - makeArgs' : (args : List Name) -> (Var (args ++ vars) -> a) -> List a - makeArgs' [] f = [] - makeArgs' (x :: xs) f = f (MkVar First) :: makeArgs' xs (f . weaken) + makeArgs' : (args : SnocList Name) -> (Var (vars ++ args) -> a) -> List a + makeArgs' [<] f = [] + makeArgs' (xs :< x) f = f (MkVar First) :: makeArgs' xs (f . weaken) + +makeArgz : (args : List Name) -> List (Var (vars <>< args)) +makeArgz args + = embedFishily @{ListFreelyEmbeddable} + $ allVars ([<] <>< args) parameters (fn1 : Name) (idIdx : Nat) mutual -- special case for matching on 'Nat'-shaped things - isUnsucc : Var vars -> CExp vars -> Maybe (Constant, Var (x :: vars)) + isUnsucc : Var vars -> CExp vars -> Maybe (Constant, Var (vars :< x)) isUnsucc var (COp _ (Sub _) [CLocal _ p, CPrimVal _ c]) = if var == MkVar p then Just (c, MkVar First) @@ -85,8 +94,8 @@ parameters (fn1 : Name) (idIdx : Nat) altEq : CConAlt vars -> Bool altEq (MkConAlt y _ _ args exp) = cexpIdentity - (weakenNs (mkSizeOf args) var) - (Just (y, makeArgs args)) + (weakensN (mkSizeOf args) var) + (Just (y, makeArgz args)) const exp cexpIdentity var con const (CConstCase fc sc xs x) = @@ -113,13 +122,13 @@ checkIdentity fn (v :: vs) exp idx = if cexpIdentity fn idx v Nothing Nothing ex else checkIdentity fn vs exp (S idx) calcIdentity : (fullName : Name) -> CDef -> Maybe Nat -calcIdentity fn (MkFun args exp) = checkIdentity fn (makeArgs {vars=[]} args) (rewrite appendNilRightNeutral args in exp) Z +calcIdentity fn (MkFun args exp) = checkIdentity fn (makeArgs {vars=[<]} args) (rewrite appendLinLeftNeutral args in exp) Z calcIdentity _ _ = Nothing -getArg : FC -> Nat -> (args : List Name) -> Maybe (CExp args) -getArg _ _ [] = Nothing -getArg fc Z (a :: _) = Just $ CLocal fc First -getArg fc (S k) (_ :: as) = weaken <$> getArg fc k as +getArg : FC -> Nat -> (args : SnocList Name) -> Maybe (CExp args) +getArg _ _ [<] = Nothing +getArg fc Z (_ :< a) = Just $ CLocal fc First +getArg fc (S k) (as :< _) = weaken <$> getArg fc k as idCDef : Nat -> CDef -> Maybe CDef idCDef idx (MkFun args exp) = MkFun args <$> getArg (getFC exp) idx args diff --git a/src/Compiler/VMCode.idr b/src/Compiler/VMCode.idr index b66d0a4043..c693bb4b40 100644 --- a/src/Compiler/VMCode.idr +++ b/src/Compiler/VMCode.idr @@ -173,7 +173,7 @@ toVM t res (AConCase fc (ALocal scr) [MkAConAlt n ci mt args code] Nothing) -- e used = foldMap collectUsed body in projectArgs scr 0 used args ++ body toVM t res (AConCase fc (ALocal scr) alts def) - = [CASE (Loc scr) (map toVMConAlt alts) (map (toVM t res) def)] + = [CASE (Loc scr) (toList $ map toVMConAlt alts) (map (toVM t res) def)] where toVMConAlt : AConAlt -> (Either Int Name, List VMInst) toVMConAlt (MkAConAlt n ci tag args code) @@ -181,7 +181,7 @@ toVM t res (AConCase fc (ALocal scr) alts def) used = foldMap collectUsed body in (maybe (Right n) Left tag, projectArgs scr 0 used args ++ body) toVM t res (AConstCase fc (ALocal scr) alts def) - = [CONSTCASE (Loc scr) (map toVMConstAlt alts) (map (toVM t res) def)] + = [CONSTCASE (Loc scr) (toList $ map toVMConstAlt alts) (map (toVM t res) def)] where toVMConstAlt : AConstAlt -> (Constant, List VMInst) toVMConstAlt (MkAConstAlt c code) diff --git a/src/Core/AutoSearch.idr b/src/Core/AutoSearch.idr index 2c4441c6d3..1c600458a8 100644 --- a/src/Core/AutoSearch.idr +++ b/src/Core/AutoSearch.idr @@ -11,9 +11,11 @@ import Core.Value import Data.Either import Data.List +import Data.SnocList import Data.Maybe import Libraries.Data.WithDefault +import Libraries.Data.SnocList.SizeOf %default covering @@ -38,7 +40,7 @@ tryNoDefaultsFirst : {auto c : Ref Ctxt Defs} -> (Bool -> Core a) -> Core a tryNoDefaultsFirst f = tryUnifyUnambig {preferLeftError=True} (f False) (f True) -SearchEnv : List Name -> Type +SearchEnv : SnocList Name -> Type SearchEnv vars = List (NF vars, Closure vars) searchType : {vars : _} -> @@ -52,7 +54,7 @@ searchType : {vars : _} -> Env Term vars -> (target : Term vars) -> Core (Term vars) public export -record ArgInfo (vars : List Name) where +record ArgInfo (vars : SnocList Name) where constructor MkArgInfo holeID : Int argRig : RigCount @@ -60,6 +62,9 @@ record ArgInfo (vars : List Name) where metaApp : Term vars argType : Term vars +{vars: _} -> Show (ArgInfo vars) where + show x = "{ArgInfo holeId: \{show $ holeID x}, argRig: \{show $ argRig x}, plicit: \{assert_total $ show $ plicit x}, metaApp: \{assert_total $ show $ metaApp x}, argType: \{assert_total $ show $ argType x}}" + export mkArgs : {vars : _} -> {auto c : Ref Ctxt Defs} -> @@ -101,18 +106,18 @@ searchIfHole : {vars : _} -> (arg : ArgInfo vars) -> Core () searchIfHole fc defaults trying ispair Z def top env arg - = throw (CantSolveGoal fc (gamma !(get Ctxt)) [] top Nothing) -- possibly should say depth limit hit? + = throw (CantSolveGoal fc (gamma !(get Ctxt)) [<] top Nothing) -- possibly should say depth limit hit? searchIfHole fc defaults trying ispair (S depth) def top env arg = do let hole = holeID arg let rig = argRig arg defs <- get Ctxt Just gdef <- lookupCtxtExact (Resolved hole) (gamma defs) - | Nothing => throw (CantSolveGoal fc (gamma !(get Ctxt)) [] top Nothing) + | Nothing => throw (CantSolveGoal fc (gamma !(get Ctxt)) [<] top Nothing) let Hole _ _ = definition gdef | _ => pure () -- already solved top' <- if ispair - then normaliseScope defs [] (type gdef) + then normaliseScope defs [<] (type gdef) else pure top argdef <- searchType fc rig defaults trying depth def False top' env @@ -124,7 +129,7 @@ searchIfHole fc defaults trying ispair (S depth) def top env arg then pure () else do vs <- unify inTerm fc env (metaApp arg) argdef let [] = constraints vs - | _ => throw (CantSolveGoal fc (gamma defs) [] top Nothing) + | _ => throw (CantSolveGoal fc (gamma defs) [<] top Nothing) pure () successful : {vars : _} -> @@ -158,13 +163,13 @@ anyOne : {vars : _} -> FC -> Env Term vars -> (topTy : ClosedTerm) -> List (Core (Term vars)) -> Core (Term vars) -anyOne fc env top [] = throw (CantSolveGoal fc (gamma !(get Ctxt)) [] top Nothing) +anyOne fc env top [] = throw (CantSolveGoal fc (gamma !(get Ctxt)) [<] top Nothing) anyOne fc env top [elab] = catch elab $ \case err@(CantSolveGoal _ _ _ _ _) => throw err err@(AmbiguousSearch _ _ _ _) => throw err - _ => throw $ CantSolveGoal fc (gamma !(get Ctxt)) [] top Nothing + _ => throw $ CantSolveGoal fc (gamma !(get Ctxt)) [<] top Nothing anyOne fc env top (elab :: elabs) = tryUnify elab (anyOne fc env top elabs) @@ -178,7 +183,7 @@ exactlyOne fc env top target [elab] = catch elab $ \case err@(CantSolveGoal _ _ _ _ _) => throw err - _ => throw $ CantSolveGoal fc (gamma !(get Ctxt)) [] top Nothing + _ => throw $ CantSolveGoal fc (gamma !(get Ctxt)) [<] top Nothing exactlyOne {vars} fc env top target all = do elabs <- successful all case nubBy ((==) `on` fst) $ rights elabs of @@ -187,7 +192,7 @@ exactlyOne {vars} fc env top target all put Ctxt defs commit pure res - [] => throw (CantSolveGoal fc (gamma !(get Ctxt)) [] top Nothing) + [] => throw (CantSolveGoal fc (gamma !(get Ctxt)) [<] top Nothing) rs => throw (AmbiguousSearch fc env !(quote !(get Ctxt) env target) !(traverse normRes rs)) where @@ -203,17 +208,17 @@ getUsableEnv : {vars : _} -> FC -> RigCount -> SizeOf done -> Env Term vars -> - List (Term (done ++ vars), Term (done ++ vars)) -getUsableEnv fc rigc p [] = [] -getUsableEnv {vars = v :: vs} {done} fc rigc p (b :: env) + List (Term (vars ++ done), Term (vars ++ done)) +getUsableEnv fc rigc p [<] = [] +getUsableEnv {vars = vs :< v} {done} fc rigc p (env :< b) = let rest = getUsableEnv fc rigc (sucR p) env in if (multiplicity b == top || isErased rigc) then let 0 var = mkIsVar (hasLength p) in (Local (binderLoc b) Nothing _ var, - rewrite appendAssociative done [v] vs in + rewrite sym (appendAssociative vs [ @@ -227,7 +232,7 @@ usableLocal loc defaults env (NApp fc (NMeta _ _ _) args) = pure False usableLocal {vars} loc defaults env (NTCon _ n _ _ args) = do sd <- getSearchData loc (not defaults) n - usableLocalArg 0 (detArgs sd) (map snd args) + usableLocalArg 0 (detArgs sd) (toList $ map snd args) -- usable if none of the determining arguments of the local's type are -- holes where @@ -274,9 +279,9 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env (prf, ty) targe where clearEnvType : {idx : Nat} -> (0 p : IsVar nm idx vs) -> FC -> Env Term vs -> Env Term vs - clearEnvType First fc (b :: env) - = Lam (binderLoc b) (multiplicity b) Explicit (Erased fc Placeholder) :: env - clearEnvType (Later p) fc (b :: env) = b :: clearEnvType p fc env + clearEnvType First fc (env :< b) + = env :< Lam (binderLoc b) (multiplicity b) Explicit (Erased fc Placeholder) + clearEnvType (Later p) fc (env :< b) = clearEnvType p fc env :< b clearEnv : Term vars -> Env Term vars -> Env Term vars clearEnv (Local fc _ idx p) env @@ -291,12 +296,15 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env (prf, ty) targe findDirect defs f ty target = do (args, appTy) <- mkArgs fc rigc env ty fprf <- f prf + log "auto" 10 $ "findDirect args" ++ show args + logNF "auto" 10 "findDirect appTy" env appTy logTermNF "auto" 10 "Trying" env fprf logNF "auto" 10 "Type" env ty logNF "auto" 10 "For target" env target ures <- unify inTerm fc env target appTy + log "auto" 10 $ "findDirect ures: " ++ show ures let [] = constraints ures - | _ => throw (CantSolveGoal fc (gamma defs) [] top Nothing) + | _ => throw (CantSolveGoal fc (gamma defs) [<] top Nothing) -- We can only use the local if its type is not an unsolved hole if !(usableLocal fc defaults env ty) then do @@ -311,19 +319,19 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env (prf, ty) targe (impLast args) pure candidate else do logNF "auto" 10 "Can't use " env ty - throw (CantSolveGoal fc (gamma defs) [] top Nothing) + throw (CantSolveGoal fc (gamma defs) [<] top Nothing) findPos : Defs -> (Term vars -> Core (Term vars)) -> NF vars -> -- local's type (target : NF vars) -> Core (Term vars) - findPos defs f nty@(NTCon pfc pn _ _ [(_, xty), (_, yty)]) target + findPos defs f nty@(NTCon pfc pn _ _ [<(_, xty), (_, yty)]) target = tryUnifyUnambig (findDirect defs f nty target) $ - do fname <- maybe (throw (CantSolveGoal fc (gamma defs) [] top Nothing)) + do fname <- maybe (throw (CantSolveGoal fc (gamma defs) [<] top Nothing)) pure !fstName - sname <- maybe (throw (CantSolveGoal fc (gamma defs) [] top Nothing)) + sname <- maybe (throw (CantSolveGoal fc (gamma defs) [<] top Nothing)) pure !sndName if !(isPairType pn) @@ -345,7 +353,7 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env (prf, ty) targe ytytm, !(f arg)]) ytynf target)] - else throw (CantSolveGoal fc (gamma defs) [] top Nothing) + else throw (CantSolveGoal fc (gamma defs) [<] top Nothing) findPos defs f nty target = findDirect defs f nty target @@ -386,9 +394,9 @@ searchName fc rigc defaults trying depth def top env target (n, ndef) = do defs <- get Ctxt when (not (visibleInAny (!getNS :: !getNestedNS) (fullname ndef) (collapseDefault $ visibility ndef))) $ - throw (CantSolveGoal fc (gamma defs) [] top Nothing) + throw (CantSolveGoal fc (gamma defs) [<] top Nothing) when (BlockedHint `elem` flags ndef) $ - throw (CantSolveGoal fc (gamma defs) [] top Nothing) + throw (CantSolveGoal fc (gamma defs) [<] top Nothing) let ty = type ndef let namety : NameType @@ -401,7 +409,7 @@ searchName fc rigc defaults trying depth def top env target (n, ndef) (args, appTy) <- mkArgs fc rigc env nty ures <- unify inTerm fc env target appTy let [] = constraints ures - | _ => throw (CantSolveGoal fc (gamma defs) [] top Nothing) + | _ => throw (CantSolveGoal fc (gamma defs) [<] top Nothing) ispair <- isPairNF env nty defs let candidate = apply fc (Ref fc namety n) (map metaApp args) logTermNF "auto" 10 "Candidate " env candidate @@ -421,7 +429,7 @@ searchNames : {vars : _} -> Env Term vars -> Bool -> List Name -> (target : NF vars) -> Core (Term vars) searchNames fc rigc defaults trying depth defining topty env ambig [] target - = throw (CantSolveGoal fc (gamma !(get Ctxt)) [] topty Nothing) + = throw (CantSolveGoal fc (gamma !(get Ctxt)) [<] topty Nothing) searchNames fc rigc defaults trying depth defining topty env ambig (n :: ns) target = do defs <- get Ctxt visnsm <- traverse (visible (gamma defs) (currentNS defs :: nestedNS defs)) (n :: ns) @@ -469,25 +477,26 @@ concreteDets {vars} fc defaults env top pos dets (arg :: args) concrete : Defs -> NF vars -> (atTop : Bool) -> Core () concrete defs (NBind nfc x b sc) atTop = do scnf <- sc defs (toClosure defaultOpts env (Erased nfc Placeholder)) - concrete defs scnf False + logDepth $ concrete defs scnf False concrete defs (NTCon nfc n t a args) atTop = do sd <- getSearchData nfc False n - let args' = drop 0 (detArgs sd) args + let args' = drop 0 (detArgs sd) (cast {to = List (FC, Closure vars)} args) + log "auto" 10 $ "concrete-2 args: \{show $ toList args}, detArgs: \{show $ detArgs sd}, args': \{show $ toList args'}" traverse_ (\ parg => do argnf <- evalClosure defs parg - concrete defs argnf False) (map snd args') + logDepth $ concrete defs argnf False) (map snd args') concrete defs (NDCon nfc n t a args) atTop = do traverse_ (\ parg => do argnf <- evalClosure defs parg - concrete defs argnf False) (map snd args) + logDepth $ concrete defs argnf False) (map snd args) concrete defs (NApp _ (NMeta n i _) _) True = do Just (Hole _ b) <- lookupDefExact n (gamma defs) - | _ => throw (DeterminingArg fc n i [] top) + | _ => throw (DeterminingArg fc n i [<] top) unless (implbind b) $ - throw (DeterminingArg fc n i [] top) + throw (DeterminingArg fc n i [<] top) concrete defs (NApp _ (NMeta n i _) _) False = do Just (Hole _ b) <- lookupDefExact n (gamma defs) - | def => throw (CantSolveGoal fc (gamma defs) [] top Nothing) + | def => throw (CantSolveGoal fc (gamma defs) [<] top Nothing) unless (implbind b) $ - throw (CantSolveGoal fc (gamma defs) [] top Nothing) + throw (CantSolveGoal fc (gamma defs) [<] top Nothing) concrete defs tm atTop = pure () checkConcreteDets : {vars : _} -> @@ -501,19 +510,19 @@ checkConcreteDets fc defaults env top (NTCon tfc tyn t a args) = do defs <- get Ctxt if !(isPairType tyn) then case args of - [(_, aty), (_, bty)] => + [<(_, aty), (_, bty)] => do anf <- evalClosure defs aty bnf <- evalClosure defs bty checkConcreteDets fc defaults env top anf checkConcreteDets fc defaults env top bnf _ => do sd <- getSearchData fc defaults tyn - concreteDets fc defaults env top 0 (detArgs sd) (map snd args) + concreteDets fc defaults env top 0 (detArgs sd) (toList $ map snd args) else do sd <- getSearchData fc defaults tyn log "auto.determining" 10 $ "Determining arguments for " ++ show !(toFullNames tyn) ++ " " ++ show (detArgs sd) - concreteDets fc defaults env top 0 (detArgs sd) (map snd args) + concreteDets fc defaults env top 0 (detArgs sd) (toList $ map snd args) checkConcreteDets fc defaults env top _ = pure () @@ -531,22 +540,24 @@ abandonIfCycle env tm (ty :: tys) -- Declared at the top searchType fc rigc defaults trying depth def checkdets top env (Bind nfc x b@(Pi fc' c p ty) sc) = pure (Bind nfc x (Lam fc' c p ty) - !(searchType fc rigc defaults [] depth def checkdets top - (b :: env) sc)) + !(logDepth $ searchType fc rigc defaults [] depth def checkdets top + (env :< b) sc)) searchType fc rigc defaults trying depth def checkdets top env (Bind nfc x b@(Let fc' c val ty) sc) = pure (Bind nfc x b - !(searchType fc rigc defaults [] depth def checkdets top - (b :: env) sc)) + !(logDepth $ searchType fc rigc defaults [] depth def checkdets top + (env :< b) sc)) searchType {vars} fc rigc defaults trying depth def checkdets top env target = do defs <- get Ctxt abandonIfCycle env target trying let trying' = target :: trying nty <- nf defs env target + logDepth $ logNF "auto" 3 "searchType-3 nty" env nty case nty of NTCon tfc tyn t a args => if a == length args - then do logNF "auto" 10 "Next target" env nty + then do logNF "auto" 10 "Next target NTCon" env nty sd <- getSearchData fc defaults tyn + log "auto" 10 $ "Next target NTCon search result detArgs: " ++ show (detArgs sd) ++ ", hintGroups: " ++ show (hintGroups sd) -- Check determining arguments are okay for 'args' when checkdets $ checkConcreteDets fc defaults env top @@ -556,16 +567,18 @@ searchType {vars} fc rigc defaults trying depth def checkdets top env target else tryUnifyUnambig (searchLocalVars fc rigc defaults trying' depth def top env nty) (tryGroups Nothing nty (hintGroups sd)) - else throw (CantSolveGoal fc (gamma defs) [] top Nothing) - _ => do logNF "auto" 10 "Next target: " env nty - searchLocalVars fc rigc defaults trying' depth def top env nty + else throw (CantSolveGoal fc (gamma defs) [<] top Nothing) + _ => do logNF "auto" 10 "Next target other: " env nty + result <- searchLocalVars fc rigc defaults trying' depth def top env nty + logTerm "auto" 10 "Next target other result" result + pure result where -- Take the earliest error message (that's when we look inside pairs, -- typically, and it's best to be more precise) tryGroups : Maybe Error -> NF vars -> List (Bool, List Name) -> Core (Term vars) tryGroups (Just err) nty [] = throw err - tryGroups Nothing nty [] = throw (CantSolveGoal fc (gamma !(get Ctxt)) [] top Nothing) + tryGroups Nothing nty [] = throw (CantSolveGoal fc (gamma !(get Ctxt)) [<] top Nothing) tryGroups merr nty ((ambigok, g) :: gs) = tryUnifyUnambig' (do logC "auto" 5 @@ -586,9 +599,9 @@ searchType {vars} fc rigc defaults trying depth def checkdets top env target -- (defining : Name) -> (topTy : Term vars) -> Env Term vars -> -- Core (Term vars) Core.Unify.search fc rigc defaults depth def top env - = do logTermNF "auto" 3 "Initial target: " env top - log "auto" 3 $ "Running search with defaults " ++ show defaults - tm <- searchType fc rigc defaults [] depth def + = do log "auto" 3 $ "Running search with defaults " ++ show defaults + logDepth $ logTermNF "auto" 3 "Initial target: " env top + tm <- logDepth $ searchType fc rigc defaults [] depth def True (abstractEnvType fc env top) env top logTermNF "auto" 3 "Result" env tm diff --git a/src/Core/Binary/Prims.idr b/src/Core/Binary/Prims.idr index ddd0fccbd2..8e7173b274 100644 --- a/src/Core/Binary/Prims.idr +++ b/src/Core/Binary/Prims.idr @@ -7,6 +7,7 @@ import Data.Buffer import Data.List import Data.List.Elem import Data.List1 +import Data.SnocList import Data.Nat import Data.String import Data.Vect @@ -489,3 +490,29 @@ hashFileWith (Just sha256sum) fileName osEscape = if isWindows then id else escapeStringUnix + +export +TTC a => TTC (SnocList a) where + toBuf b xs + = do toBuf b (TailRec_length xs) + traverse_ (toBuf b) xs + where + ||| Tail-recursive length as buffer sizes can get large + ||| + ||| Once we port to Idris2, can use Data.List.TailRec.length instead + length_aux : SnocList a -> Int -> Int + length_aux [<] len = len + length_aux (xs :< _) len = length_aux xs (1 + len) + + TailRec_length : SnocList a -> Int + TailRec_length xs = length_aux xs 0 + + fromBuf b + = do len <- fromBuf b {a = Int} + readElems [<] (integerToNat (cast len)) + where + readElems : SnocList a -> Nat -> Core (SnocList a) + readElems xs Z = pure (reverse xs) + readElems xs (S k) + = do val <- fromBuf b + readElems (xs :< val) k diff --git a/src/Core/Case/CaseBuilder.idr b/src/Core/Case/CaseBuilder.idr index 23aefedaa6..c0844cb64e 100644 --- a/src/Core/Case/CaseBuilder.idr +++ b/src/Core/Case/CaseBuilder.idr @@ -14,10 +14,16 @@ import Core.Value import Idris.Pretty.Annotations import Data.List +import Data.SnocList import Data.String import Data.Vect +import Libraries.Data.List.SizeOf import Libraries.Data.List.LengthMatch import Libraries.Data.SortedSet +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.LengthMatch +import Libraries.Data.SnocList.HasLength +import Libraries.Data.SnocList.Extra import Decidable.Equality @@ -35,7 +41,7 @@ Eq Phase where RunTime == RunTime = True _ == _ = False -data ArgType : List Name -> Type where +data ArgType : SnocList Name -> Type where Known : RigCount -> (ty : Term vars) -> ArgType vars -- arg has type 'ty' Stuck : (fty : Term vars) -> ArgType vars -- ^ arg will have argument type of 'fty' when we know enough to @@ -53,13 +59,16 @@ HasNames (ArgType vars) where resolved gam (Stuck ty) = Stuck <$> resolved gam ty resolved gam Unknown = pure Unknown +export +FreelyEmbeddable CaseTree where + covering {ns : _} -> Show (ArgType ns) where show (Known c t) = "Known " ++ show c ++ " " ++ show t show (Stuck t) = "Stuck " ++ show t show Unknown = "Unknown" -record PatInfo (pvar : Name) (vars : List Name) where +record PatInfo (pvar : Name) (vars : SnocList Name) where constructor MkInfo {idx : Nat} {name : Name} @@ -94,16 +103,31 @@ NamedPats always have the same 'Elem' proof, though this isn't expressed in a type anywhere. -} -data NamedPats : List Name -> -- pattern variables still to process - List Name -> -- the pattern variables still to process, - -- in order +-- Comment from Yaffle: +-- This is using cons syntax, rather than snoc, because we want to process +-- arguments left to right, although the natural order based on when the +-- arguments were lambda bound would be right to left. +-- That's why we use SnocList in the type - the names refer to the lambda +-- bound arguments. I realise this is a bit confusing. Sorry! +data NamedPats : SnocList Name -> -- pattern variables still to process + SnocList Name -> -- the pattern variables still to process, + -- in reverse order Type where - Nil : NamedPats vars [] + Nil : NamedPats vars [<] (::) : PatInfo pvar vars -> -- ^ a pattern, where its variable appears in the vars list, -- and its type. The type has no variable names; any names it -- refers to are explicit - NamedPats vars ns -> NamedPats vars (pvar :: ns) + NamedPats vars ns -> NamedPats vars (ns :< pvar) + +-- For ease of type level reasoning! +rev : SnocList a -> SnocList a +rev [<] = [<] +rev (xs :< x) = [ PatInfo pvar vars -> NamedPats vars ([ List Pat getPatInfo [] = [] @@ -114,7 +138,7 @@ updatePats : {vars, todo : _} -> Env Term vars -> NF vars -> NamedPats vars todo -> Core (NamedPats vars todo) updatePats env nf [] = pure [] -updatePats {todo = pvar :: ns} env (NBind fc _ (Pi _ c _ farg) fsc) (p :: ps) +updatePats {todo = ns :< pvar} env (NBind fc _ (Pi _ c _ farg) fsc) (p :: ps) = case argType p of Unknown => do defs <- get Ctxt @@ -139,17 +163,22 @@ substInPatInfo {pvar} {vars} fc n tm p ps = case argType p of Known c ty => do defs <- get Ctxt - tynf <- nf defs (mkEnv fc _) ty + logTerm "compile.casetree" 25 "substInPatInfo-Known-tm" tm + logTerm "compile.casetree" 25 "substInPatInfo-Known-ty" ty + log "compile.casetree" 25 $ "n: " ++ show n + let env = mkEnv fc vars + -- logEnvRev "compile.casetree" 25 "substInPatInfo env" env + tynf <- nf defs env ty case tynf of NApp _ _ _ => - pure ({ argType := Known c (substName n tm ty) } p, ps) + pure ({ argType := Known c (substName zero n tm ty) } p, ps) -- Got a concrete type, and that's all we need, so stop _ => pure (p, ps) Stuck fty => do defs <- get Ctxt empty <- clearDefs defs let env = mkEnv fc vars - case !(nf defs env (substName n tm fty)) of + case !(nf defs env (substName zero n tm fty)) of NBind pfc _ (Pi _ c _ farg) fsc => pure ({ argType := Known c !(quote empty env farg) } p, !(updatePats env @@ -193,9 +222,9 @@ covering where showAll : {vs, ts : _} -> NamedPats vs ts -> String showAll [] = "" - showAll {ts = t :: _ } [x] + showAll {ts = _ :< t } [x] = show t ++ " " ++ show (pat x) ++ " [" ++ show (argType x) ++ "]" - showAll {ts = t :: _ } (x :: xs) + showAll {ts = _ :< t } (x :: xs) = show t ++ " " ++ show (pat x) ++ " [" ++ show (argType x) ++ "]" ++ ", " ++ showAll xs @@ -204,7 +233,7 @@ covering where prettyAll : {vs, ts : _} -> NamedPats vs ts -> List (Doc IdrisSyntax) prettyAll [] = [] - prettyAll {ts = t :: _ } (x :: xs) + prettyAll {ts = _ :< t } (x :: xs) = parens (pretty0 t <++> equals <++> pretty (pat x)) :: prettyAll xs @@ -217,34 +246,58 @@ Weaken ArgType where weakenNs s (Stuck fty) = Stuck (weakenNs s fty) weakenNs s Unknown = Unknown +GenWeaken ArgType where + genWeakenNs p q Unknown = Unknown + genWeakenNs p q (Known c ty) = Known c $ genWeakenNs p q ty + genWeakenNs p q (Stuck fty) = Stuck $ genWeakenNs p q fty + Weaken (PatInfo p) where weakenNs s (MkInfo p el fty) = MkInfo p (weakenIsVar s el) (weakenNs s fty) -- FIXME: perhaps 'vars' should be second argument so we can use Weaken interface weaken : {x, vars : _} -> - NamedPats vars todo -> NamedPats (x :: vars) todo + NamedPats vars todo -> NamedPats (vars :< x) todo weaken [] = [] weaken (p :: ps) = weaken p :: weaken ps weakenNs : SizeOf ns -> NamedPats vars todo -> - NamedPats (ns ++ vars) todo + NamedPats (vars ++ ns) todo weakenNs ns [] = [] weakenNs ns (p :: ps) = weakenNs ns p :: weakenNs ns ps -(++) : NamedPats vars ms -> NamedPats vars ns -> NamedPats vars (ms ++ ns) +FreelyEmbeddable (PatInfo p) where + +FreelyEmbeddable ArgType where + +GenWeaken (PatInfo p) where + genWeakenNs p q (MkInfo {idx} {name} pat loc at) = do + let MkNVar loc' = genWeakenNs p q $ MkNVar {nvarIdx=idx} loc + let at' = genWeakenNs p q at + MkInfo pat loc' at' + +genWeakenNs : {0 local, ns, outer : Scope} -> + SizeOf outer -> SizeOf ns -> NamedPats (local ++ outer) todo -> NamedPats (local ++ ns ++ outer) todo +genWeakenNs p q Nil = Nil +genWeakenNs p q (pi :: np) = genWeakenNs p q pi :: genWeakenNs p q np + +genWeakenAssociative : {0 local, outer : Scope} -> + SizeOf outer -> NamedPats (local ++ outer) todo -> NamedPats ((local ++ [ NamedPats vars ns -> NamedPats vars (ns ++ ms) (++) [] ys = ys (++) (x :: xs) ys = x :: xs ++ ys -tail : NamedPats vars (p :: ps) -> NamedPats vars ps +tail : NamedPats vars (ps :< p) -> NamedPats vars ps tail (x :: xs) = xs -take : (as : List Name) -> NamedPats vars (as ++ bs) -> NamedPats vars as -take [] ps = [] -take (x :: xs) (p :: ps) = p :: take xs ps +take : (as : SnocList Name) -> NamedPats vars (bs ++ as) -> NamedPats vars as +take [<] ps = [] +take (xs :< x) (p :: ps) = p :: take xs ps -data PatClause : (vars : List Name) -> (todo : List Name) -> Type where +data PatClause : (vars : SnocList Name) -> (todo : SnocList Name) -> Type where MkPatClause : List Name -> -- names matched so far (from original lhs) NamedPats vars todo -> Int -> (rhs : Term vars) -> PatClause vars todo @@ -271,10 +324,12 @@ HasNames (PatClause vars todo) where substInClause : {a, vars, todo : _} -> {auto c : Ref Ctxt Defs} -> - FC -> PatClause vars (a :: todo) -> - Core (PatClause vars (a :: todo)) + FC -> PatClause vars (todo :< a) -> + Core (PatClause vars (todo :< a)) substInClause {vars} {a} fc (MkPatClause pvars (MkInfo pat pprf fty :: pats) pid rhs) - = do pats' <- substInPats fc a (mkTerm vars pat) pats + = do let tm = mkTerm vars pat + log "compile.casetree.subst" 50 "Substituting \{show tm} for \{show a} in \{show pat}" + pats' <- substInPats fc a tm pats pure (MkPatClause pvars (MkInfo pat pprf fty :: pats') pid rhs) data Partitions : List (PatClause vars todo) -> Type where @@ -316,7 +371,7 @@ namesFrom (PDelay _ _ t p) = namesFrom t ++ namesFrom p namesFrom (PLoc _ n) = [n] namesFrom _ = [] -clauseType : Phase -> PatClause vars (a :: as) -> ClauseType +clauseType : Phase -> PatClause vars (as :< a) -> ClauseType -- If it's irrelevant, a constructor, and there's no names we haven't seen yet -- and don't see later, treat it as a variable -- Or, if we're compiling for runtime we won't be able to split on it, so @@ -327,7 +382,7 @@ clauseType phase (MkPatClause pvars (MkInfo arg _ ty :: rest) pid rhs) where -- used when we are tempted to split on a constructor: is -- this actually a fully applied one? - splitCon : Nat -> List Pat -> ClauseType + splitCon : Nat -> SnocList Pat -> ClauseType splitCon arity xs = if arity == length xs then ConClause else VarClause @@ -353,7 +408,7 @@ clauseType phase (MkPatClause pvars (MkInfo arg _ ty :: rest) pid rhs) getClauseType phase l _ = clauseType' l partition : {a, as, vars : _} -> - Phase -> (ps : List (PatClause vars (a :: as))) -> Partitions ps + Phase -> (ps : List (PatClause vars (as :< a))) -> Partitions ps partition phase [] = NoClauses partition phase (x :: xs) with (partition phase xs) partition phase (x :: (cs ++ ps)) | (ConClauses cs rest) @@ -384,16 +439,16 @@ conTypeEq CDelay CDelay = Just Refl conTypeEq (CConst x) (CConst y) = (\xy => cong CConst xy) <$> constantEq x y conTypeEq _ _ = Nothing -data Group : List Name -> -- variables in scope - List Name -> -- pattern variables still to process +data Group : SnocList Name -> -- variables in scope + SnocList Name -> -- pattern variables still to process Type where ConGroup : {newargs : _} -> Name -> (tag : Int) -> - List (PatClause (newargs ++ vars) (newargs ++ todo)) -> + List (PatClause (vars ++ newargs) (todo ++ rev newargs)) -> Group vars todo DelayGroup : {tyarg, valarg : _} -> - List (PatClause (tyarg :: valarg :: vars) - (tyarg :: valarg :: todo)) -> + List (PatClause (vars :< tyarg :< valarg) + (todo :< valarg :< tyarg)) -> Group vars todo ConstGroup : Constant -> List (PatClause vars todo) -> Group vars todo @@ -404,17 +459,17 @@ covering show (DelayGroup cs) = "Delay: " ++ show cs show (ConstGroup c cs) = "Const " ++ show c ++ ": " ++ show cs -data GroupMatch : ConType -> List Pat -> Group vars todo -> Type where +data GroupMatch : ConType -> SnocList Pat -> Group vars todo -> Type where ConMatch : {tag : Int} -> LengthMatch ps newargs -> GroupMatch (CName n tag) ps (ConGroup {newargs} n tag (MkPatClause pvs pats pid rhs :: rest)) - DelayMatch : GroupMatch CDelay [] + DelayMatch : GroupMatch CDelay [<] (DelayGroup {tyarg} {valarg} (MkPatClause pvs pats pid rhs :: rest)) - ConstMatch : GroupMatch (CConst c) [] + ConstMatch : GroupMatch (CConst c) [<] (ConstGroup c (MkPatClause pvs pats pid rhs :: rest)) NoMatch : GroupMatch ct ps g -checkGroupMatch : (c : ConType) -> (ps : List Pat) -> (g : Group vars todo) -> +checkGroupMatch : (c : ConType) -> (ps : SnocList Pat) -> (g : Group vars todo) -> GroupMatch c ps g checkGroupMatch (CName x tag) ps (ConGroup {newargs} x' tag' (MkPatClause pvs pats pid rhs :: rest)) = case checkLengthMatch ps newargs of @@ -423,9 +478,9 @@ checkGroupMatch (CName x tag) ps (ConGroup {newargs} x' tag' (MkPatClause pvs pa (Just Refl, Yes Refl) => ConMatch prf _ => NoMatch checkGroupMatch (CName x tag) ps _ = NoMatch -checkGroupMatch CDelay [] (DelayGroup (MkPatClause pvs pats pid rhs :: rest)) +checkGroupMatch CDelay [<] (DelayGroup (MkPatClause pvs pats pid rhs :: rest)) = DelayMatch -checkGroupMatch (CConst c) [] (ConstGroup c' (MkPatClause pvs pats pid rhs :: rest)) +checkGroupMatch (CConst c) [<] (ConstGroup c' (MkPatClause pvs pats pid rhs :: rest)) = case constantEq c c' of Nothing => NoMatch Just Refl => ConstMatch @@ -440,57 +495,130 @@ nextName root put PName (x + 1) pure (MN root x) +-- Copied from +-- https://github.com/gallais/Idris2/blob/4efcf27bbc542bf9991ebaf75415644af7135b5d/src/Core/Case/CaseBuilder.idr +getArgTys : {vars : _} -> + {auto c : Ref Ctxt Defs} -> + Env Term vars -> SnocList Name -> Maybe (NF vars) -> Core (List (ArgType vars)) +getArgTys {vars} env (ns :< n) (Just t@(NBind pfc _ (Pi _ c _ fargc) fsc)) + = do defs <- get Ctxt + empty <- clearDefs defs + -- log "compile.casetree" 25 $ "getArgTys-1 t: " ++ show t ++ ", n: " ++ show n ++ ", vars: " ++ show (reverse $ toList vars) + argty <- case !(evalClosure defs fargc) of + NErased _ _ => pure Unknown + farg => do -- log "compile.casetree" 25 $ "getArgTys-1 farg: " ++ show farg + -- logEnvRev "compile.casetree" 25 "getArgTys-1 env " env + Known c <$> quote empty env farg + scty <- fsc defs (toClosure defaultOpts env (Ref pfc Bound n)) + -- log "compile.casetree" 25 $ "getArgTys-1 scty: " ++ show scty + rest <- logDepth $ getArgTys env ns (Just scty) + pure (argty :: rest) +getArgTys env (ns :< n) (Just t) + = do empty <- clearDefs =<< get Ctxt + -- log "compile.casetree" 25 $ "getArgTys-2 t: " ++ show t ++ ", n: " ++ show n + pure [Stuck !(quote empty env t)] +getArgTys _ _ _ = pure [] + +nextNames' : {vars : _} -> + {auto i : Ref PName Int} -> + {auto c : Ref Ctxt Defs} -> + FC -> + (pats : SnocList Pat) -> + (ns : SnocList Name) -> + LengthMatch pats ns -> + List (ArgType vars) -> + Core (args ** (SizeOf args, NamedPats (vars ++ args) (rev args))) +nextNames' fc [<] [<] LinMatch argtys = pure ([<] ** (zero, [])) +nextNames' fc (pats :< p) (ns :< n) (SnocMatch prf) (argTy :: as) + = do (args ** (l, ps)) <- nextNames' fc pats ns prf as + let argTy' : ArgType ((vars ++ args) :< n) + = weakenNs (mkSizeOf (args :< n)) argTy + pure (args :< n ** (suc l, + snoc (weaken ps) + (MkInfo p First argTy'))) +nextNames' fc (pats :< p) (ns :< n) (SnocMatch prf) argtys + = do (args ** (l, ps)) <- nextNames' fc pats ns prf argtys + pure (args :< n ** (suc l, + snoc (weaken ps) + (MkInfo p First Unknown))) + +snocLMatch : LengthMatch xs ys -> LengthMatch ([ LengthMatch (rev xs) (rev ys) +revLMatch LinMatch = LinMatch +revLMatch (SnocMatch x) + = let x' = revLMatch x in + snocLMatch x' + +snocRMatch : LengthMatch xs ys -> LengthMatch (xs :< x) ([ LengthMatch xs (rev ys) +revRMatch LinMatch = LinMatch +revRMatch (SnocMatch x) + = let x' = revRMatch x in + snocRMatch x' + nextNames : {vars : _} -> {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> - FC -> String -> List Pat -> Maybe (NF vars) -> - Core (args ** (SizeOf args, NamedPats (args ++ vars) args)) -nextNames fc root [] fty = pure ([] ** (zero, [])) -nextNames {vars} fc root (p :: pats) fty - = do defs <- get Ctxt - empty <- clearDefs defs - n <- nextName root + FC -> String -> SnocList Pat -> Maybe (NF vars) -> + Core (args ** (SizeOf args, NamedPats (vars ++ args) (rev args))) +nextNames fc root [<] _ = pure ([<] ** (zero, [])) +nextNames {vars} fc root pats m_nty + = do (args ** lprf) <- mkNames pats let env = mkEnv fc vars - fa_tys <- the (Core (Maybe (NF vars), ArgType vars)) $ - case fty of - Nothing => pure (Nothing, Unknown) - Just (NBind pfc _ (Pi _ c _ fargc) fsc) => - do farg <- evalClosure defs fargc - case farg of - NErased _ _ => - pure (Just !(fsc defs (toClosure defaultOpts env (Ref pfc Bound n))), - Unknown) - _ => pure (Just !(fsc defs (toClosure defaultOpts env (Ref pfc Bound n))), - Known c !(quote empty env farg)) - Just t => - pure (Nothing, Stuck !(quote empty env t)) - (args ** (l, ps)) <- nextNames {vars} fc root pats (fst fa_tys) - let argTy = case snd fa_tys of - Unknown => Unknown - Known rig t => Known rig (weakenNs (suc l) t) - Stuck t => Stuck (weakenNs (suc l) t) - pure (n :: args ** (suc l, MkInfo p First argTy :: weaken ps)) + -- logEnvRev "compile.casetree" 25 "nextNames env" env + -- The arguments are given in reverse order, so when we process them, + -- the argument types are in the correct order + log "compile.casetree" 20 $ "nextNames getArgTys m_nty: " ++ show m_nty ++ ", args: " ++ show args + argTys <- getArgTys env args m_nty + -- for_ (toList m_nty) $ \ ty => do + -- logNF "compile.casetree" 25 "nextNames'' NF" env ty + result@(args_r ** (_, pats_r)) <- nextNames' fc pats (rev args) (revRMatch lprf) (reverse argTys) + log "compile.casetree" 25 $ "nextNames argTys: " ++ show argTys ++ ", args_r: " ++ show args_r ++ ", pats_r: " ++ show pats_r + log "compile.casetree" 25 $ "nextNames argTy: " + pure result + where + mkNames : (vars : SnocList a) -> + Core (ns : SnocList Name ** LengthMatch vars ns) + mkNames [<] = pure ([<] ** LinMatch) + mkNames (xs :< x) + = do n <- nextName root + (ns ** p) <- mkNames xs + pure (ns :< n ** SnocMatch p) -- replace the prefix of patterns with 'pargs' -newPats : (pargs : List Pat) -> LengthMatch pargs ns -> - NamedPats vars (ns ++ todo) -> +newPats : (pargs : SnocList Pat) -> LengthMatch pargs ns -> + NamedPats vars (todo ++ ns) -> NamedPats vars ns -newPats [] NilMatch rest = [] -newPats (newpat :: xs) (ConsMatch w) (pi :: rest) +newPats [<] LinMatch rest = [] +newPats (xs :< newpat) (SnocMatch w) (pi :: rest) = { pat := newpat} pi :: newPats xs w rest -updateNames : List (Name, Pat) -> List (Name, Name) +updateNames : SnocList (Name, Pat) -> SnocList (Name, Name) updateNames = mapMaybe update where update : (Name, Pat) -> Maybe (Name, Name) update (n, PLoc fc p) = Just (p, n) update _ = Nothing -updatePatNames : List (Name, Name) -> NamedPats vars todo -> NamedPats vars todo +updatePatNames : SnocList (Name, Name) -> NamedPats vars todo -> NamedPats vars todo updatePatNames _ [] = [] updatePatNames ns (pi :: ps) = { pat $= update } pi :: updatePatNames ns ps where + lookup : Name -> SnocList (Name, Name) -> Maybe Name + lookup n [<] = Nothing + lookup n (ns :< (x, n')) = if x == n then Just n' else lookup n ns + update : Pat -> Pat update (PAs fc n p) = case lookup n ns of @@ -511,14 +639,14 @@ groupCons : {a, vars, todo : _} -> {auto ct : Ref Ctxt Defs} -> FC -> Name -> List Name -> - List (PatClause vars (a :: todo)) -> + List (PatClause vars (todo :< a)) -> Core (List (Group vars todo)) groupCons fc fn pvars cs = gc [] cs where addConG : {vars', todo' : _} -> Name -> (tag : Int) -> - List Pat -> NamedPats vars' todo' -> + SnocList Pat -> NamedPats vars' todo' -> Int -> (rhs : Term vars') -> (acc : List (Group vars' todo')) -> Core (List (Group vars' todo')) @@ -535,12 +663,17 @@ groupCons fc fn pvars cs Just t <- lookupTyExact n (gamma defs) | Nothing => pure (NErased fc Placeholder) nf defs (mkEnv fc vars') (embed t) - (patnames ** (l, newargs)) <- nextNames {vars=vars'} fc "e" pargs (Just cty) + (patnames ** (l, newargs)) <- logDepth $ do + log "compile.casetree" 25 $ "addConG nextNames for " ++ show (toList pargs) + logNF "compile.casetree" 25 "addConG nextNames cty" (mkEnv fc vars') cty + nextNames {vars=vars'} fc "e" pargs (Just cty) + log "compile.casetree" 25 $ "addConG patnames " ++ show (toList patnames) + log "compile.casetree" 25 $ "addConG newargs " ++ show newargs -- Update non-linear names in remaining patterns (to keep -- explicit dependencies in types accurate) let pats' = updatePatNames (updateNames (zip patnames pargs)) (weakenNs l pats) - let clause = MkPatClause {todo = patnames ++ todo'} + let clause = MkPatClause {todo = todo' ++ rev patnames} pvars (newargs ++ pats') pid (weakenNs l rhs) @@ -549,11 +682,11 @@ groupCons fc fn pvars cs addConG {vars'} {todo'} n tag pargs pats pid rhs ((ConGroup {newargs} n tag ((MkPatClause pvars ps tid tm) :: rest)) :: gs) | (ConMatch {newargs} lprf) - = do let newps = newPats pargs lprf ps + = do let newps = newPats (rev pargs) (revLMatch lprf) ps let l = mkSizeOf newargs let pats' = updatePatNames (updateNames (zip newargs pargs)) (weakenNs l pats) - let newclause : PatClause (newargs ++ vars') (newargs ++ todo') + let newclause : PatClause (vars' ++ newargs) (todo' ++ rev newargs) = MkPatClause pvars (newps ++ pats') pid @@ -581,27 +714,25 @@ groupCons fc fn pvars cs do a' <- evalClosure d a pure (NBind fc (MN "x" 0) (Pi fc top Explicit a) (\dv, av => pure (NDelayed fc LUnknown a')))) - ([tyname, argname] ** (l, newargs)) <- nextNames {vars=vars'} fc "e" [pty, parg] + ([ throw (InternalError "Error compiling Delay pattern match") - let pats' = updatePatNames (updateNames [(tyname, pty), - (argname, parg)]) + let pats' = updatePatNames (updateNames [<(tyname, pty), (argname, parg)]) (weakenNs l pats) - let clause = MkPatClause {todo = tyname :: argname :: todo'} + let clause = MkPatClause pvars (newargs ++ pats') pid (weakenNs l rhs) pure [DelayGroup [clause]] - addDelayG {vars'} {todo'} pty parg pats pid rhs (g :: gs) with (checkGroupMatch CDelay [] g) + addDelayG {vars'} {todo'} pty parg pats pid rhs (g :: gs) with (checkGroupMatch CDelay [<] g) addDelayG {vars'} {todo'} pty parg pats pid rhs ((DelayGroup {tyarg} {valarg} ((MkPatClause pvars ps tid tm) :: rest)) :: gs) | (DelayMatch {tyarg} {valarg}) - = do let l = mkSizeOf [tyarg, valarg] - let newps = newPats [pty, parg] (ConsMatch (ConsMatch NilMatch)) ps - let pats' = updatePatNames (updateNames [(tyarg, pty), - (valarg, parg)]) + = do let l = mkSizeOf [") 0 [s, t] pats pid rhs acc + = addConG (UN $ Basic "->") 0 [ List (Group vars todo) -> - List (PatClause vars (a :: todo)) -> + List (PatClause vars (todo :< a)) -> Core (List (Group vars todo)) gc acc [] = pure acc - gc {a} acc ((MkPatClause pvars (MkInfo pat pprf fty :: pats) pid rhs) :: cs) + gc {a} acc ((MkPatClause _ (MkInfo pat pprf _ :: pats) pid rhs) :: cs) = do acc' <- addGroup pat pprf pats pid rhs acc gc acc' cs -getFirstPat : NamedPats ns (p :: ps) -> Pat +getFirstPat : NamedPats ns (ps :< p) -> Pat getFirstPat (p :: _) = pat p -getFirstArgType : NamedPats ns (p :: ps) -> ArgType ns +getFirstArgType : NamedPats ns (ps :< p) -> ArgType ns getFirstArgType (p :: _) = argType p ||| Store scores alongside rows of named patterns. These scores are used to determine ||| which column of patterns to switch on first. One score per column. -data ScoredPats : List Name -> List Name -> Type where - Scored : List (NamedPats ns (p :: ps)) -> Vect (length (p :: ps)) Int -> ScoredPats ns (p :: ps) +data ScoredPats : SnocList Name -> SnocList Name -> Type where + Scored : List (NamedPats ns (ps :< p)) -> Vect (length (ps :< p)) Int -> ScoredPats ns (ps :< p) {ps : _} -> Show (ScoredPats ns ps) where show (Scored xs ys) = (show ps) ++ "//" ++ (show ys) -zeroedScore : {ps : _} -> List (NamedPats ns (p :: ps)) -> ScoredPats ns (p :: ps) +zeroedScore : {ps : _} -> List (NamedPats ns (ps :< p)) -> ScoredPats ns (ps :< p) zeroedScore nps = Scored nps (replicate (S $ length ps) 0) -||| Proof that a value `v` inserted in the middle of a list with -||| prefix `ps` and suffix `qs` can equivalently be snoced with +||| Proof that a value `v` inserted in the middle of a snoc list with +||| prefix `ps` and suffix `qs` can equivalently be consed with ||| `ps` or consed with `qs` before appending `qs` to `ps`. -elemInsertedMiddle : (v : a) -> (ps,qs : List a) -> (ps ++ (v :: qs)) = ((ps `snoc` v) ++ qs) -elemInsertedMiddle v [] qs = Refl -elemInsertedMiddle v (x :: xs) qs = rewrite elemInsertedMiddle v xs qs in Refl +elemInsertedMiddle : (v : a) -> (ps,qs : SnocList a) -> ((qs :< v) ++ ps) = (qs ++ (v `cons` ps)) +elemInsertedMiddle v [<] qs = Refl +elemInsertedMiddle v (xs :< x) qs = rewrite elemInsertedMiddle v xs qs in Refl ||| Helper to find a single highest scoring name (or none at all) while ||| retaining the context of all names processed. -highScore : {prev : List Name} -> - (names : List Name) -> +highScore : {prev : SnocList Name} -> + (names : SnocList Name) -> (scores : Vect (length names) Int) -> (highVal : Int) -> - (highIdx : (n ** NVar n (prev ++ names))) -> + (highIdx : (n ** NVar n (names ++ prev))) -> (duped : Bool) -> - Maybe (n ** NVar n (prev ++ names)) -highScore [] [] high idx True = Nothing -highScore [] [] high idx False = Just idx -highScore (x :: xs) (y :: ys) high idx duped = - let next = highScore {prev = prev `snoc` x} xs ys + Maybe (n ** NVar n (names ++ prev)) +highScore [<] [] high idx True = Nothing +highScore [<] [] high idx False = Just idx +highScore (xs :< x) (y :: ys) high idx duped = + let next = highScore {prev = x `cons` prev} xs ys prf = elemInsertedMiddle x prev xs in rewrite prf in case compare y high of @@ -714,8 +845,8 @@ highScore (x :: xs) (y :: ys) high idx duped = ||| the result is Nothing indicating we need to apply more scoring ||| to break the tie. ||| Suggested heuristic application order: f, b, a. -highScoreIdx : {p : _} -> {ps : _} -> ScoredPats ns (p :: ps) -> Maybe (n ** NVar n (p :: ps)) -highScoreIdx (Scored xs (y :: ys)) = highScore {prev = []} (p :: ps) (y :: ys) (y - 1) (p ** MkNVar First) False +highScoreIdx : {p : _} -> {ps : _} -> ScoredPats ns (ps :< p) -> Maybe (n ** NVar n (ps :< p)) +highScoreIdx (Scored xs (y :: ys)) = highScore {prev = [<]} (ps :< p) (y :: ys) (y - 1) (p ** MkNVar First) False ||| Apply the penalty function to the head constructor's ||| arity. Produces 0 for all non-head-constructors. @@ -740,21 +871,21 @@ consScoreHeuristic scorePat (Scored xs ys) = where -- also returns NamePats of remaining columns while its in there -- scoring the first column. - scoreFirstColumn : (nps : List (NamedPats ns (p' :: ps'))) -> (res : List (NamedPats ns ps') ** (LengthMatch nps res, Vect (length nps) Int)) + scoreFirstColumn : (nps : List (NamedPats ns (ps' :< p'))) -> (res : List (NamedPats ns ps') ** (LengthMatch nps res, Vect (length nps) Int)) scoreFirstColumn [] = ([] ** (NilMatch, [])) scoreFirstColumn ((w :: ws) :: nps) = let (ws' ** (prf, scores)) = scoreFirstColumn nps in (ws :: ws' ** (ConsMatch prf, scorePat (pat w) :: scores)) scoreColumns : {ps' : _} -> (nps : List (NamedPats ns ps')) -> Vect (length ps') (Vect (length nps) Int) - scoreColumns {ps' = []} nps = [] - scoreColumns {ps' = (w :: ws)} nps = + scoreColumns {ps' = [<]} nps = [] + scoreColumns {ps' = (ws :< w)} nps = let (rest ** (prf, firstColScore)) = scoreFirstColumn nps in firstColScore :: (rewrite lengthsMatch prf in scoreColumns rest) ||| Add 1 to each non-default pat in the first row. ||| This favors constructive matching first and reduces tree depth on average. -heuristicF : {ps : _} -> ScoredPats ns (p :: ps) -> ScoredPats ns (p :: ps) +heuristicF : {ps : _} -> ScoredPats ns (ps :< p) -> ScoredPats ns (ps :< p) heuristicF sps@(Scored [] _) = sps heuristicF (Scored (x :: xs) ys) = let columnScores = scores x @@ -781,9 +912,9 @@ heuristicA = consScoreHeuristic (headConsPenalty (negate . cast)) applyHeuristics : {p : _} -> {ps : _} -> - ScoredPats ns (p :: ps) -> - List (ScoredPats ns (p :: ps) -> ScoredPats ns (p :: ps)) -> - Maybe (n ** NVar n (p :: ps)) + ScoredPats ns (ps :< p) -> + List (ScoredPats ns (ps :< p) -> ScoredPats ns (ps :< p)) -> + Maybe (n ** NVar n (ps :< p)) applyHeuristics x [] = highScoreIdx x applyHeuristics x (f :: fs) = highScoreIdx x <|> applyHeuristics (f x) fs @@ -796,8 +927,8 @@ nextIdxByScore : {p : _} -> {ps : _} -> (useHeuristics : Bool) -> Phase -> - List (NamedPats ns (p :: ps)) -> - (n ** NVar n (p :: ps)) + List (NamedPats ns (ps :< p)) -> + (n ** NVar n (ps :< p)) nextIdxByScore False _ _ = (_ ** (MkNVar First)) nextIdxByScore _ (CompileTime _) _ = (_ ** (MkNVar First)) nextIdxByScore True RunTime xs = @@ -811,7 +942,7 @@ sameType : {ns : _} -> {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> FC -> Phase -> Name -> - Env Term ns -> List (NamedPats ns (p :: ps)) -> + Env Term ns -> List (NamedPats ns (ps :< p)) -> Core () sameType fc phase fn env [] = pure () sameType {ns} fc phase fn env (p :: xs) @@ -822,7 +953,7 @@ sameType {ns} fc phase fn env (p :: xs) (map getFirstArgType xs) ty => throw (CaseCompile fc fn DifferingTypes) where - firstPat : NamedPats ns (np :: nps) -> Pat + firstPat : NamedPats ns (nps :< np) -> Pat firstPat (pinf :: _) = pat pinf headEq : NF ns -> NF ns -> Phase -> Bool @@ -846,7 +977,7 @@ sameType {ns} fc phase fn env (p :: xs) -- Check whether all the initial patterns are the same, or are all a variable. -- If so, we'll match it to refine later types and move on -samePat : List (NamedPats ns (p :: ps)) -> Bool +samePat : List (NamedPats ns (ps :< p)) -> Bool samePat [] = True samePat (pi :: xs) = samePatAs (dropAs (getFirstPat pi)) @@ -871,11 +1002,11 @@ samePat (pi :: xs) samePatAs (PLoc fc n) (PLoc _ _ :: ps) = samePatAs (PLoc fc n) ps samePatAs x y = False -getFirstCon : NamedPats ns (p :: ps) -> Pat +getFirstCon : NamedPats ns (ps :< p) -> Pat getFirstCon (p :: _) = pat p -- Count the number of distinct constructors in the initial pattern -countDiff : List (NamedPats ns (p :: ps)) -> Nat +countDiff : List (NamedPats ns (ps :< p)) -> Nat countDiff xs = length (distinct [] (map getFirstCon xs)) where isVar : Pat -> Bool @@ -909,7 +1040,7 @@ getScore : {ns : _} -> {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> FC -> Phase -> Name -> - List (NamedPats ns (p :: ps)) -> + List (NamedPats ns (ps :< p)) -> Core (Either CaseError ()) getScore fc phase name npss = do catch (do sameType fc phase name (mkEnv fc ns) npss @@ -923,16 +1054,16 @@ getScore fc phase name npss pickNextViable : {p, ns, ps : _} -> {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> - FC -> Phase -> Name -> List (NamedPats ns (p :: ps)) -> - Core (n ** NVar n (p :: ps)) + FC -> Phase -> Name -> List (NamedPats ns (ps :< p)) -> + Core (n ** NVar n (ps :< p)) -- last possible variable -pickNextViable {ps = []} fc phase fn npss +pickNextViable {ps = [<]} fc phase fn npss = if samePat npss then pure (_ ** MkNVar First) else do Right () <- getScore fc phase fn npss | Left err => throw (CaseCompile fc fn err) pure (_ ** MkNVar First) -pickNextViable {ps = q :: qs} fc phase fn npss +pickNextViable {ps = qs :< q} fc phase fn npss = if samePat npss then pure (_ ** MkNVar First) else case !(getScore fc phase fn npss) of @@ -941,11 +1072,11 @@ pickNextViable {ps = q :: qs} fc phase fn npss pure (_ ** MkNVar (Later var)) moveFirst : {idx : Nat} -> (0 el : IsVar nm idx ps) -> NamedPats ns ps -> - NamedPats ns (nm :: dropIsVar ps el) + NamedPats ns (dropIsVar ps el :< nm) moveFirst el nps = getPat el nps :: dropPat el nps shuffleVars : {idx : Nat} -> (0 el : IsVar nm idx todo) -> PatClause vars todo -> - PatClause vars (nm :: dropIsVar todo el) + PatClause vars (dropIsVar todo el :< nm) shuffleVars First orig@(MkPatClause pvars lhs pid rhs) = orig -- no-op shuffleVars el (MkPatClause pvars lhs pid rhs) = MkPatClause pvars (moveFirst el lhs) pid rhs @@ -966,11 +1097,13 @@ mutual -- Before 'partition', reorder the arguments so that the one we -- inspect next has a concrete type that is the same in all cases, and -- has the most distinct constructors (via pickNextViable) - match {todo = (_ :: _)} fc fn phase clauses err + match {todo = (_ :< _)} fc fn phase clauses err = do let nps = getNPs <$> clauses let (_ ** (MkNVar next)) = nextIdxByScore (caseTreeHeuristics !getSession) phase nps let prioritizedClauses = shuffleVars next <$> clauses (n ** MkNVar next') <- pickNextViable fc phase fn (getNPs <$> prioritizedClauses) + log "compile.casetree" 25 $ "Clauses " ++ show clauses + log "compile.casetree" 25 $ "Err " ++ show err log "compile.casetree.pick" 25 $ "Picked " ++ show n ++ " as the next split" let clauses' = shuffleVars next' <$> prioritizedClauses log "compile.casetree.clauses" 25 $ @@ -985,12 +1118,12 @@ mutual Just m => do log "compile.casetree.intermediate" 25 $ "match: new case tree " ++ show m Core.pure m - match {todo = []} fc fn phase [] err + match {todo = [<]} fc fn phase [] err = maybe (pure (Unmatched "No patterns")) pure err - match {todo = []} fc fn phase ((MkPatClause pvars [] pid (Erased _ Impossible)) :: _) err + match {todo = [<]} fc fn phase ((MkPatClause pvars [] pid (Erased _ Impossible)) :: _) err = pure Impossible - match {todo = []} fc fn phase ((MkPatClause pvars [] pid rhs) :: _) err + match {todo = [<]} fc fn phase ((MkPatClause pvars [] pid rhs) :: _) err = pure $ STerm pid rhs caseGroups : {pvar, vars, todo : _} -> @@ -1011,9 +1144,9 @@ mutual altGroups (ConGroup {newargs} cn tag rest :: cs) = do crest <- match fc fn phase rest (map (weakenNs (mkSizeOf newargs)) errorCase) cs' <- altGroups cs - pure (ConCase cn tag newargs crest :: cs') + pure (ConCase cn tag (cast newargs) (rewrite sym $ snocAppendAsFish vars newargs in crest) :: cs') altGroups (DelayGroup {tyarg} {valarg} rest :: cs) - = do crest <- match fc fn phase rest (map (weakenNs (mkSizeOf [tyarg, valarg])) errorCase) + = do crest <- match fc fn phase rest (map (weakenNs (mkSizeOf [ {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> - List (PatClause vars (a :: todo)) -> + List (PatClause vars (todo :< a)) -> Maybe (CaseTree vars) -> Core (CaseTree vars) conRule fc fn phase [] err = maybe (pure (Unmatched "No constructor clauses")) pure err @@ -1035,71 +1168,91 @@ mutual -- in the type if we can. conRule {a} fc fn phase cs@(MkPatClause pvars (MkInfo pat pprf fty :: pats) pid rhs :: rest) err = do refinedcs <- traverse (substInClause fc) cs + log "compile.casetree" 5 $ "conRule refinedcs: " ++ show refinedcs groups <- groupCons fc fn pvars refinedcs + log "compile.casetree" 5 $ "conRule groups: " ++ + show a ++ ", " ++ show groups ++ " , " ++ show cs ty <- case fty of Known _ t => pure t - _ => throw (CaseCompile fc fn UnknownType) + Stuck tm => do logTerm "compile.casetree" 25 "Stuck" tm + throw (CaseCompile fc fn UnknownType) + _ => do log "compile.casetree" 25 "Unknown type" + throw (CaseCompile fc fn UnknownType) caseGroups fc fn phase pprf ty groups err varRule : {a, vars, todo : _} -> {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> - List (PatClause vars (a :: todo)) -> + List (PatClause vars (todo :< a)) -> Maybe (CaseTree vars) -> Core (CaseTree vars) varRule {vars} {a} fc fn phase cs err = do alts' <- traverse updateVar cs match fc fn phase alts' err where - updateVar : PatClause vars (a :: todo) -> Core (PatClause vars todo) + updateVar : PatClause vars (todo :< a) -> Core (PatClause vars todo) -- replace the name with the relevant variable on the rhs - updateVar (MkPatClause pvars (MkInfo (PLoc pfc n) prf fty :: pats) pid rhs) - = pure $ MkPatClause (n :: pvars) + updateVar (MkPatClause pvars (MkInfo {idx} {name} (PLoc pfc n) prf fty :: pats) pid rhs) + = do log "compile.casetree.updateVar" 50 + "Replacing \{show n} with \{show name}[\{show idx}] in \{show rhs}" + log "compile.casetree" 5 $ "Var update " ++ + show a ++ ", " ++ show n ++ ", vars: " ++ show (toList vars) ++ " ==> " ++ show !(toFullNames rhs) + let rhs' = substName zero n (Local pfc (Just False) _ prf) rhs + logTerm "compile.casetree" 5 "updateVar-2 rhs'" rhs' + pure $ MkPatClause (n :: pvars) !(substInPats fc a (Local pfc (Just False) _ prf) pats) - pid (substName n (Local pfc (Just False) _ prf) rhs) + pid rhs' -- If it's an as pattern, replace the name with the relevant variable on -- the rhs then continue with the inner pattern updateVar (MkPatClause pvars (MkInfo (PAs pfc n pat) prf fty :: pats) pid rhs) - = do pats' <- substInPats fc a (mkTerm _ pat) pats - let rhs' = substName n (Local pfc (Just True) _ prf) rhs + = do log "compile.casetree" 5 $ "Var replace " ++ + show a ++ ", " ++ show n ++ ", vars: " ++ show (toList vars) ++ " ==> " ++ show !(toFullNames rhs) + pats' <- substInPats fc a (mkTerm _ pat) pats + let rhs' = substName zero n (Local pfc (Just True) _ prf) rhs + logTerm "compile.casetree" 5 "updateVar-3 rhs'" rhs' updateVar (MkPatClause pvars (MkInfo pat prf fty :: pats') pid rhs') -- match anything, name won't appear in rhs but need to update -- LHS pattern types based on what we've learned updateVar (MkPatClause pvars (MkInfo pat prf fty :: pats) pid rhs) - = pure $ MkPatClause pvars + = do log "compile.casetree" 5 $ "Forced Var update " ++ + show a ++ ", vars: " ++ show (toList vars) ++ ", " ++ show !(toFullNames pat) ++ " ==> " + ++ show !(toFullNames rhs) + pure $ MkPatClause pvars !(substInPats fc a (mkTerm vars pat) pats) pid rhs mixture : {a, vars, todo : _} -> {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> - {ps : List (PatClause vars (a :: todo))} -> + {ps : List (PatClause vars (todo :< a))} -> FC -> Name -> Phase -> Partitions ps -> Maybe (CaseTree vars) -> Core (Maybe (CaseTree vars)) mixture fc fn phase (ConClauses cs rest) err - = do fallthrough <- mixture fc fn phase rest err + = do log "compile.casetree" 25 $ "Mixture ConClauses Rest: " ++ show rest ++ ", cs: " ++ show cs + fallthrough <- mixture fc fn phase rest err pure (Just !(conRule fc fn phase cs fallthrough)) mixture fc fn phase (VarClauses vs rest) err - = do fallthrough <- mixture fc fn phase rest err + = do log "compile.casetree" 25 $ "Mixture VarClauses Rest: " ++ show rest ++ ", vs: " ++ show vs + fallthrough <- mixture fc fn phase rest err pure (Just !(varRule fc fn phase vs fallthrough)) mixture fc fn {a} {todo} phase NoClauses err = pure err export -mkPat : {auto c : Ref Ctxt Defs} -> List Pat -> ClosedTerm -> ClosedTerm -> Core Pat -mkPat [] orig (Ref fc Bound n) = pure $ PLoc fc n -mkPat args orig (Ref fc (DataCon t a) n) = pure $ PCon fc n t a args -mkPat args orig (Ref fc (TyCon t a) n) = pure $ PTyCon fc n a args +mkPat : {auto c : Ref Ctxt Defs} -> SnocList Pat -> ClosedTerm -> ClosedTerm -> Core Pat +mkPat [<] orig (Ref fc Bound n) = pure $ PLoc fc n +mkPat args orig (Ref fc (DataCon t a) n) = pure $ PCon fc n t a (rev args) +mkPat args orig (Ref fc (TyCon t a) n) = pure $ PTyCon fc n a (rev args) mkPat args orig (Ref fc Func n) = do prims <- getPrimitiveNames - mtm <- normalisePrims (const True) isPConst True prims n args orig [] + mtm <- normalisePrims (const True) isPConst True prims n args orig [<] case mtm of Just tm => if tm /= orig -- check we made progress; if there's an -- unresolved interface, we might be stuck -- and we'd loop forever - then mkPat [] tm tm + then mkPat [<] tm tm else -- Possibly this should be an error instead? pure $ PUnmatchable (getLoc orig) orig Nothing => @@ -1107,23 +1260,28 @@ mkPat args orig (Ref fc Func n) "Unmatchable function: " ++ show n pure $ PUnmatchable (getLoc orig) orig mkPat args orig (Bind fc x (Pi _ _ _ s) t) + -- from Yaffle: + -- = let t' = subst (Erased fc Placeholder) t in + -- pure $ PArrow fc x !(mkPat [<] s s) !(mkPat [<] t' t') + -- For (b:Nat) -> b, the codomain looks like b [__], but we want `b` as the pattern = case subst (Erased fc Placeholder) t of - App _ t'@(Ref fc Bound n) (Erased _ _) => pure $ PArrow fc x !(mkPat [] s s) !(mkPat [] t' t') - t' => pure $ PArrow fc x !(mkPat [] s s) !(mkPat [] t' t') + App _ t'@(Ref fc Bound n) (Erased _ _) => pure $ PArrow fc x !(mkPat [<] s s) !(mkPat [<] t' t') + t' => pure $ PArrow fc x !(mkPat [<] s s) !(mkPat [<] t' t') mkPat args orig (App fc fn arg) - = do parg <- mkPat [] arg arg - mkPat (parg :: args) orig fn + = do parg <- mkPat [<] arg arg + mkPat (args :< parg) orig fn +-- Assumption is that clauses are converted to explicit names mkPat args orig (As fc _ (Ref _ Bound n) ptm) - = pure $ PAs fc n !(mkPat [] ptm ptm) + = pure $ PAs fc n !(mkPat [<] ptm ptm) mkPat args orig (As fc _ _ ptm) - = mkPat [] orig ptm + = mkPat [<] orig ptm mkPat args orig (TDelay fc r ty p) - = pure $ PDelay fc r !(mkPat [] orig ty) !(mkPat [] orig p) + = pure $ PDelay fc r !(mkPat [<] orig ty) !(mkPat [<] orig p) mkPat args orig (PrimVal fc $ PrT c) -- Primitive type constant - = pure $ PTyCon fc (UN (Basic $ show c)) 0 [] + = pure $ PTyCon fc (UN (Basic $ show c)) 0 [<] mkPat args orig (PrimVal fc c) = pure $ PConst fc c -- Non-type constant -mkPat args orig (TType fc _) = pure $ PTyCon fc (UN $ Basic "Type") 0 [] +mkPat args orig (TType fc _) = pure $ PTyCon fc (UN $ Basic "Type") 0 [<] mkPat args orig tm = do log "compile.casetree" 10 $ "Catchall: marking " ++ show tm ++ " as unmatchable" @@ -1131,101 +1289,104 @@ mkPat args orig tm export argToPat : {auto c : Ref Ctxt Defs} -> ClosedTerm -> Core Pat -argToPat tm = mkPat [] tm tm +argToPat tm = mkPat [<] tm tm mkPatClause : {auto c : Ref Ctxt Defs} -> FC -> Name -> - (args : List Name) -> ClosedTerm -> - Int -> (List Pat, ClosedTerm) -> - Core (PatClause args args) + (args : SnocList Name) -> ClosedTerm -> + Int -> (SnocList Pat, ClosedTerm) -> + Core (PatClause args (rev args)) mkPatClause fc fn args ty pid (ps, rhs) = maybe (throw (CaseCompile fc fn DifferingArgNumbers)) (\eq => do defs <- get Ctxt - nty <- nf defs [] ty - ns <- mkNames args ps eq (Just nty) + logTerm "compile.casetree" 20 "mkPatClause ty" ty + nty <- nf defs [<] ty + log "compile.casetree" 20 $ "mkPatClause nty: " ++ show nty + -- The arguments are in reverse order, so we need to + -- read what we know off 'nty', and reverse it + argTys <- getArgTys [<] (rev args) (Just nty) + log "compile.casetree" 20 $ "mkPatClause args: " ++ show (toList args) ++ ", argTys: " ++ show argTys + ns <- logQuite $ mkNames args ps eq (reverse argTys) log "compile.casetree" 20 $ "Make pat clause for names " ++ show ns - ++ " in LHS " ++ show ps + ++ " in LHS " ++ show (toList ps) pure (MkPatClause [] ns pid - (rewrite sym (appendNilRightNeutral args) in + (rewrite sym (appendLinLeftNeutral args) in (weakenNs (mkSizeOf args) rhs)))) (checkLengthMatch args ps) where - mkNames : (vars : List Name) -> (ps : List Pat) -> - LengthMatch vars ps -> Maybe (NF []) -> - Core (NamedPats vars vars) - mkNames [] [] NilMatch fty = pure [] - mkNames (arg :: args) (p :: ps) (ConsMatch eq) fty - = do defs <- get Ctxt - empty <- clearDefs defs - fa_tys <- the (Core (Maybe _, ArgType _)) $ - case fty of - Nothing => pure (Nothing, CaseBuilder.Unknown) - Just (NBind pfc _ (Pi _ c _ farg) fsc) => - pure (Just !(fsc defs (toClosure defaultOpts [] (Ref pfc Bound arg))), - Known c (embed {outer = arg :: args} - !(quote empty [] farg))) - Just t => - pure (Nothing, - Stuck (embed {outer = arg :: args} - !(quote empty [] t))) - pure (MkInfo p First (Builtin.snd fa_tys) - :: weaken !(mkNames args ps eq (Builtin.fst fa_tys))) + mkNames : (vars : SnocList Name) -> (ps : SnocList (Pat)) -> + LengthMatch vars ps -> List (ArgType [<]) -> + Core (NamedPats vars (rev vars)) + mkNames [<] [<] LinMatch fty = pure [] + mkNames (args :< _) (ps :< p) (SnocMatch eq) [] + = do rest <- mkNames args ps eq [] + pure (snoc (weaken rest) (MkInfo p First Unknown)) + mkNames (args :< _) (ps :< p) (SnocMatch eq) (f :: fs) + = do rest <- mkNames args ps eq fs + pure (snoc (weaken rest) (MkInfo p First (embed' f))) + where + embed' : ArgType [<] -> ArgType more + embed' Unknown = Unknown + embed' (Stuck t) = Stuck (embed {outer = more} t) + embed' (Known c t) = Known c (embed {outer = more} t) export patCompile : {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> - ClosedTerm -> List (List Pat, ClosedTerm) -> - Maybe (CaseTree []) -> + ClosedTerm -> List (SnocList Pat, ClosedTerm) -> + Maybe (CaseTree [<]) -> Core (args ** CaseTree args) -patCompile fc fn phase ty [] def - = maybe (pure ([] ** Unmatched "No definition")) - (\e => pure ([] ** e)) +patCompile fc fn phase _ [] def + = maybe (pure ([<] ** Unmatched "No definition")) + (\e => pure ([<] ** e)) def patCompile fc fn phase ty (p :: ps) def - = do let (ns ** n) = getNames 0 (fst p) - pats <- mkPatClausesFrom 0 ns (p :: ps) + = do let (ns ** n) = getNames 0 (reverse $ fst p) + log "compile.casetree" 25 $ "ns: " ++ show (asList ns) + pats <- mkPatClausesFrom 0 (rev ns) (p :: ps) -- low verbosity level: pretty print fully resolved names logC "compile.casetree" 5 $ do pats <- traverse toFullNames pats pure $ "Pattern clauses:\n" ++ show (indent 2 $ vcat $ pretty <$> pats) + log "compile.casetree" 25 $ "Def " ++ show def -- higher verbosity: dump the raw data structure log "compile.casetree" 10 $ show pats i <- newRef PName (the Int 0) - cases <- match fc fn phase pats - (rewrite sym (appendNilRightNeutral ns) in - map (weakenNs n) def) + cases <- match fc fn phase pats (embed @{MaybeFreelyEmbeddable} def) pure (_ ** cases) where - mkPatClausesFrom : Int -> (args : List Name) -> - List (List Pat, ClosedTerm) -> - Core (List (PatClause args args)) + mkPatClausesFrom : Int -> (args : SnocList Name) -> + List (SnocList Pat, ClosedTerm) -> + Core (List (PatClause args (rev args))) mkPatClausesFrom i ns [] = pure [] mkPatClausesFrom i ns (p :: ps) = do p' <- mkPatClause fc fn ns ty i p ps' <- mkPatClausesFrom (i + 1) ns ps pure (p' :: ps') - getNames : Int -> List Pat -> (ns : List Name ** SizeOf ns) - getNames i [] = ([] ** zero) - getNames i (x :: xs) = + getNames : Int -> SnocList Pat -> (ns : SnocList Name ** SizeOf ns) + getNames i [<] = ([<] ** zero) + getNames i (xs :< x) = let (ns ** n) = getNames (i + 1) xs - in (MN "arg" i :: ns ** suc n) + in (ns :< MN "arg" i ** suc n) toPatClause : {auto c : Ref Ctxt Defs} -> FC -> Name -> (ClosedTerm, ClosedTerm) -> - Core (List Pat, ClosedTerm) + Core (SnocList Pat, ClosedTerm) toPatClause fc n (lhs, rhs) - = case getFnArgs lhs of + = case getFnArgsSpine lhs of (Ref ffc Func fn, args) => do defs <- get Ctxt (np, _) <- getPosition n (gamma defs) (fnp, _) <- getPosition fn (gamma defs) if np == fnp - then pure (!(traverse argToPat args), rhs) + then do pats <- traverseSnocList argToPat args + log "compile.casetree" 10 $ "toPatClause args: " ++ show (toList args) ++ ", pats: " ++ show (toList pats) + pure (pats, rhs) else throw (GenericMsg ffc ("Wrong function name in pattern LHS " ++ show (n, fn))) (f, args) => throw (GenericMsg fc "Not a function name in pattern LHS") @@ -1234,7 +1395,7 @@ toPatClause fc n (lhs, rhs) -- the names of the top level variables we created are returned in 'args' export simpleCase : {auto c : Ref Ctxt Defs} -> - FC -> Phase -> Name -> ClosedTerm -> (def : Maybe (CaseTree [])) -> + FC -> Phase -> Name -> ClosedTerm -> (def : Maybe (CaseTree [<])) -> (clauses : List (ClosedTerm, ClosedTerm)) -> Core (args ** CaseTree args) simpleCase fc phase fn ty def clauses @@ -1245,6 +1406,7 @@ simpleCase fc phase fn ty def clauses byShow (fst lrhs) <++> pretty "=" <++> byShow (snd lrhs)) ps <- traverse (toPatClause fc fn) clauses defs <- get Ctxt + log "compile.casetree" 5 $ "ps: " ++ show (mapFst toList <$> ps) patCompile fc fn phase ty ps def mutual @@ -1341,28 +1503,29 @@ getPMDef : {auto c : Ref Ctxt Defs} -> -- for the type, which we can use in coverage checking to ensure that one of -- the arguments has an empty type getPMDef fc phase fn ty [] - = do log "compile.casetree.getpmdef" 20 "getPMDef: No clauses!" - defs <- get Ctxt - pure (!(getArgs 0 !(nf defs [] ty)) ** (Unmatched "No clauses", [])) + = do defs <- get Ctxt + args <- getArgs 0 !(nf defs [<] ty) + log "compile.casetree.getpmdef" 20 "getPMDef: No clauses! args: \{show args}" + pure (cast args ** (Unmatched "No clauses", [])) where - getArgs : Int -> NF [] -> Core (List Name) + getArgs : Int -> NF [<] -> Core (List Name) getArgs i (NBind fc x (Pi _ _ _ _) sc) = do defs <- get Ctxt - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) pure (MN "arg" i :: !(getArgs i sc')) getArgs i _ = pure [] getPMDef fc phase fn ty clauses = do defs <- get Ctxt let cs = map (toClosed defs) (labelPat 0 clauses) - (_ ** t) <- simpleCase fc phase fn ty Nothing cs + (args ** t) <- simpleCase fc phase fn ty Nothing cs logC "compile.casetree.getpmdef" 20 $ pure $ "Compiled to: " ++ show !(toFullNames t) let reached = findReached t log "compile.casetree.clauses" 25 $ - "Reached clauses: " ++ (show reached) + "Reached args: \{show $ toList args} clauses: " ++ (show reached) extraDefaults <- findExtraDefaults fc defs t let unreachable = getUnreachable 0 (reached \\ extraDefaults) clauses - pure (_ ** (t, unreachable)) + pure (args ** (t, unreachable)) where getUnreachable : Int -> List Int -> List Clause -> List Clause getUnreachable i is [] = [] diff --git a/src/Core/Case/CaseTree.idr b/src/Core/Case/CaseTree.idr index c11b001f5b..0a11e7385c 100644 --- a/src/Core/Case/CaseTree.idr +++ b/src/Core/Case/CaseTree.idr @@ -3,12 +3,16 @@ module Core.Case.CaseTree import Core.TT import Data.List +import Data.SnocList import Data.String import Idris.Pretty.Annotations import Libraries.Data.NameMap import Libraries.Text.PrettyPrint.Prettyprinter import Libraries.Data.String.Extra -- needed for boostrapping +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra +import Libraries.Data.List.SizeOf %default covering @@ -16,7 +20,7 @@ mutual ||| Case trees in A-normal forms ||| i.e. we may only dispatch on variables, not expressions public export - data CaseTree : List Name -> Type where + data CaseTree : SnocList Name -> Type where ||| case x return scTy of { p1 => e1 ; ... } Case : {name : _} -> (idx : Nat) -> @@ -35,13 +39,13 @@ mutual ||| Case alternatives. Unlike arbitrary patterns, they can be at most ||| one constructor deep. public export - data CaseAlt : List Name -> Type where + data CaseAlt : SnocList Name -> Type where ||| Constructor for a data type; bind the arguments and subterms. ConCase : Name -> (tag : Int) -> (args : List Name) -> - CaseTree (args ++ vars) -> CaseAlt vars + CaseTree (vars <>< args) -> CaseAlt vars ||| Lazy match for the Delay type use for codata types DelayCase : (ty : Name) -> (arg : Name) -> - CaseTree (ty :: arg :: vars) -> CaseAlt vars + CaseTree (vars :< ty :< arg) -> CaseAlt vars ||| Match against a literal ConstCase : Constant -> CaseTree vars -> CaseAlt vars ||| Catch-all case @@ -96,14 +100,14 @@ public export data Pat : Type where PAs : FC -> Name -> Pat -> Pat PCon : FC -> Name -> (tag : Int) -> (arity : Nat) -> - List Pat -> Pat - PTyCon : FC -> Name -> (arity : Nat) -> List Pat -> Pat + SnocList Pat -> Pat + PTyCon : FC -> Name -> (arity : Nat) -> SnocList Pat -> Pat PConst : FC -> (c : Constant) -> Pat PArrow : FC -> (x : Name) -> Pat -> Pat -> Pat PDelay : FC -> LazyReason -> Pat -> Pat -> Pat -- TODO: Matching on lazy types PLoc : FC -> Name -> Pat - PUnmatchable : FC -> Term [] -> Pat + PUnmatchable : FC -> Term [<] -> Pat export isPConst : Pat -> Maybe Constant @@ -124,7 +128,7 @@ showCT indent (Unmatched msg) = "Error: " ++ show msg showCT indent Impossible = "Impossible" showCA indent (ConCase n tag args sc) - = showSep " " (map show (n :: args)) ++ " => " ++ + = showSep " " ([show n] ++ map show (args)) ++ " => " ++ showCT indent sc showCA indent (DelayCase _ arg sc) = "Delay " ++ show arg ++ " => " ++ showCT indent sc @@ -170,8 +174,8 @@ export covering Show Pat where show (PAs _ n p) = show n ++ "@(" ++ show p ++ ")" - show (PCon _ n i _ args) = show n ++ " " ++ show i ++ " " ++ assert_total (show args) - show (PTyCon _ n _ args) = "" ++ show n ++ " " ++ assert_total (show args) + show (PCon _ n i _ args) = show n ++ " " ++ show i ++ " " ++ assert_total (show $ toList args) + show (PTyCon _ n _ args) = "" ++ show n ++ " " ++ assert_total (show $ toList args) show (PConst _ c) = show c show (PArrow _ x s t) = "(" ++ show s ++ " -> " ++ show t ++ ")" show (PDelay _ _ _ p) = "(Delay " ++ show p ++ ")" @@ -182,9 +186,9 @@ export Pretty IdrisSyntax Pat where prettyPrec d (PAs _ n p) = pretty0 n <++> keyword "@" <+> parens (pretty p) prettyPrec d (PCon _ n _ _ args) = - parenthesise (d > Open) $ hsep (pretty0 n :: map (prettyPrec App) args) + parenthesise (d > Open) $ hsep (pretty0 n :: map (prettyPrec App) (toList args)) prettyPrec d (PTyCon _ n _ args) = - parenthesise (d > Open) $ hsep (pretty0 n :: map (prettyPrec App) args) + parenthesise (d > Open) $ hsep (pretty0 n :: map (prettyPrec App) (toList args)) prettyPrec d (PConst _ c) = pretty c prettyPrec d (PArrow _ _ p q) = parenthesise (d > Open) $ pretty p <++> arrow <++> pretty q @@ -195,8 +199,8 @@ Pretty IdrisSyntax Pat where mutual insertCaseNames : SizeOf outer -> SizeOf ns -> - CaseTree (outer ++ inner) -> - CaseTree (outer ++ (ns ++ inner)) + CaseTree (inner ++ outer) -> + CaseTree (inner ++ ns ++ outer) insertCaseNames outer ns (Case idx prf scTy alts) = let MkNVar prf' = insertNVarNames outer ns (MkNVar prf) in Case _ prf' (insertNames outer ns scTy) @@ -207,14 +211,22 @@ mutual insertCaseAltNames : SizeOf outer -> SizeOf ns -> - CaseAlt (outer ++ inner) -> - CaseAlt (outer ++ (ns ++ inner)) + CaseAlt (inner ++ outer) -> + CaseAlt (inner ++ ns ++ outer) insertCaseAltNames p q (ConCase x tag args ct) - = ConCase x tag args - (rewrite appendAssociative args outer (ns ++ inner) in - insertCaseNames (mkSizeOf args + p) q {inner} - (rewrite sym (appendAssociative args outer inner) in - ct)) + = ConCase x tag args ct'' + where + ct' : CaseTree (inner ++ (ns ++ (outer <>< args))) + ct' = insertCaseNames (p <>< mkSizeOf args) q + $ replace {p = CaseTree} (snocAppendFishAssociative inner outer args) ct + + ct'' : CaseTree ((inner ++ (ns ++ outer)) <>< args) + ct'' = do + rewrite (appendAssociative inner ns outer) + rewrite snocAppendFishAssociative (inner ++ ns) outer args + rewrite sym (appendAssociative inner ns (outer <>< args)) + ct' + insertCaseAltNames outer ns (DelayCase tyn valn ct) = DelayCase tyn valn (insertCaseNames (suc (suc outer)) ns ct) @@ -262,17 +274,17 @@ getMetas : CaseTree vars -> NameMap Bool getMetas = getNames (addMetas False) empty export -mkTerm : (vars : List Name) -> Pat -> Term vars +mkTerm : (vars : SnocList Name) -> Pat -> Term vars mkTerm vars (PAs fc x y) = mkTerm vars y mkTerm vars (PCon fc x tag arity xs) - = apply fc (Ref fc (DataCon tag arity) x) + = applySpine fc (Ref fc (DataCon tag arity) x) (map (mkTerm vars) xs) mkTerm vars (PTyCon fc x arity xs) - = apply fc (Ref fc (TyCon 0 arity) x) + = applySpine fc (Ref fc (TyCon 0 arity) x) (map (mkTerm vars) xs) mkTerm vars (PConst fc c) = PrimVal fc c mkTerm vars (PArrow fc x s t) - = Bind fc x (Pi fc top Explicit (mkTerm vars s)) (mkTerm (x :: vars) t) + = Bind fc x (Pi fc top Explicit (mkTerm vars s)) (mkTerm (vars :< x) t) mkTerm vars (PDelay fc r ty p) = TDelay fc r (mkTerm vars ty) (mkTerm vars p) mkTerm vars (PLoc fc n) diff --git a/src/Core/Case/CaseTree/Pretty.idr b/src/Core/Case/CaseTree/Pretty.idr index 493ed50d31..317ecb454d 100644 --- a/src/Core/Case/CaseTree/Pretty.idr +++ b/src/Core/Case/CaseTree/Pretty.idr @@ -84,11 +84,11 @@ namespace Resugared prettyAlt env (ConCase n tag args sc) = do con <- prettyName n sc <- prettyTree (mkEnvOnto emptyFC args env) sc - pure $ hsep (annotate (DCon (Just n)) con :: map pretty0 args) + pure $ hsep (annotate (DCon (Just n)) con :: map pretty0 (toList args)) <++> fatArrow <+> Union (spaces 1 <+> sc) (nest 2 (hardline <+> sc)) prettyAlt env (DelayCase _ arg sc) = do - sc <- prettyTree (mkEnvOnto emptyFC [_,_] env) sc + sc <- prettyTree (mkEnvOnto emptyFC [_, _] env) sc pure $ keyword "Delay" <++> pretty0 arg <++> fatArrow <+> Union (spaces 1 <+> sc) (nest 2 (hardline <+> sc)) diff --git a/src/Core/Case/Util.idr b/src/Core/Case/Util.idr index da36b57696..471c6308ed 100644 --- a/src/Core/Case/Util.idr +++ b/src/Core/Case/Util.idr @@ -4,6 +4,11 @@ import Core.Case.CaseTree import Core.Context import Core.Value +import Data.SnocList +import Libraries.Data.SnocList.Extra +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.List.SizeOf + public export record DataCon where constructor MkDataCon @@ -50,7 +55,7 @@ mkAlt : {vars : _} -> FC -> CaseTree vars -> DataCon -> CaseAlt vars mkAlt fc sc (MkDataCon cn t ar) = ConCase cn t (map (MN "m") (take ar [0..])) - (weakenNs (map take) (emptyRHS fc sc)) + $ weakensN (map take) (emptyRHS fc sc) export tagIs : Int -> CaseAlt vars -> Bool diff --git a/src/Core/CompileExpr.idr b/src/Core/CompileExpr.idr index 2935bd19e7..211c55e91e 100644 --- a/src/Core/CompileExpr.idr +++ b/src/Core/CompileExpr.idr @@ -7,9 +7,12 @@ import Core.Name import Core.TT import Data.List +import Data.SnocList import Data.Vect +import Libraries.Data.List.SizeOf import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra %default covering @@ -71,15 +74,15 @@ Eq InlineOk where mutual ||| CExp - an expression ready for compiling. public export - data CExp : List Name -> Type where + data CExp : SnocList Name -> Type where CLocal : {idx : Nat} -> FC -> (0 p : IsVar x idx vars) -> CExp vars CRef : FC -> Name -> CExp vars -- Lambda expression - CLam : FC -> (x : Name) -> CExp (x :: vars) -> CExp vars + CLam : FC -> (x : Name) -> CExp (vars :< x) -> CExp vars -- Let bindings CLet : FC -> (x : Name) -> InlineOk -> -- Don't inline if set - CExp vars -> CExp (x :: vars) -> CExp vars + CExp vars -> CExp (vars :< x) -> CExp vars -- Application of a defined function. The length of the argument list is -- exactly the same length as expected by its definition (so saturate with -- lambdas if necessary, or overapply with additional CApps) @@ -109,14 +112,14 @@ mutual CCrash : FC -> String -> CExp vars public export - data CConAlt : List Name -> Type where + data CConAlt : SnocList Name -> Type where -- If no tag, then match by constructor name. Back ends might want to -- convert names to a unique integer for performance. MkConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : List Name) -> - CExp (args ++ vars) -> CConAlt vars + CExp (vars <>< args) -> CConAlt vars public export - data CConstAlt : List Name -> Type where + data CConstAlt : SnocList Name -> Type where MkConstAlt : Constant -> CExp vars -> CConstAlt vars mutual @@ -199,7 +202,7 @@ data CFType : Type where public export data CDef : Type where -- Normal function definition - MkFun : (args : List Name) -> CExp args -> CDef + MkFun : (args : SnocList Name) -> CExp args -> CDef -- Constructor MkCon : (tag : Maybe Int) -> (arity : Nat) -> (nt : Maybe Nat) -> CDef -- Foreign definition @@ -209,7 +212,7 @@ data CDef : Type where CDef -- A function which will fail at runtime (usually due to being a hole) so needs -- to run, discarding arguments, no matter how many arguments are passed - MkError : CExp [] -> CDef + MkError : CExp [<] -> CDef public export data NamedDef : Type where @@ -248,9 +251,9 @@ mutual show (NmForce _ lr x) = "(%force " ++ show lr ++ " " ++ show x ++ ")" show (NmDelay _ lr x) = "(%delay " ++ show lr ++ " " ++ show x ++ ")" show (NmConCase _ sc xs def) - = assert_total $ "(%case " ++ show sc ++ " " ++ show xs ++ " " ++ show def ++ ")" + = assert_total $ "(%case con " ++ show sc ++ " " ++ show xs ++ " " ++ show def ++ ")" show (NmConstCase _ sc xs def) - = assert_total $ "(%case " ++ show sc ++ " " ++ show xs ++ " " ++ show def ++ ")" + = assert_total $ "(%case const " ++ show sc ++ " " ++ show xs ++ " " ++ show def ++ ")" show (NmPrimVal _ x) = show x show (NmErased _) = "___" show (NmCrash _ x) = "(CRASH " ++ show x ++ ")" @@ -271,13 +274,13 @@ mutual = "(%constcase " ++ show x ++ " " ++ show exp ++ ")" export -data Names : List Name -> Type where - Nil : Names [] - (::) : Name -> Names xs -> Names (x :: xs) +data Names : SnocList Name -> Type where + Lin : Names [<] + (:<) : Names xs -> Name -> Names (xs :< x) elem : Name -> Names xs -> Bool -elem n [] = False -elem n (x :: xs) = n == x || elem n xs +elem n [<] = False +elem n (xs :< x) = n == x || elem n xs tryNext : Name -> Name tryNext (UN n) = MN (displayUserName n) 0 @@ -292,19 +295,38 @@ uniqueName s ns = export getLocName : (idx : Nat) -> Names vars -> (0 p : IsVar name idx vars) -> Name -getLocName Z (x :: xs) First = x -getLocName (S k) (x :: xs) (Later p) = getLocName k xs p +getLocName Z (xs :< x) First = x +getLocName (S k) (xs :< x) (Later p) = getLocName k xs p export -addLocs : (args : List Name) -> Names vars -> Names (args ++ vars) +addLocz : (args : Scope) -> Names vars -> Names (vars ++ args) +addLocz [<] ns = ns +addLocz (xs :< x) ns + = let rec = addLocz xs ns in + rec :< uniqueName x rec + +export +initLocs : (vars : Scope) -> Names vars +initLocs vars + = rewrite sym $ appendLinLeftNeutral vars in + addLocz vars [<] + +export +addLocs : (args : List Name) -> Names vars -> Names (vars <>< args) addLocs [] ns = ns addLocs (x :: xs) ns - = let rec = addLocs xs ns in - uniqueName x rec :: rec + = let n = uniqueName x ns in + addLocs xs (ns :< n) + +conArgz : (args : SnocList Name) -> Names (vars ++ args) -> SnocList Name +conArgz [<] ns = [<] +conArgz (as :< a) (ns :< n) = conArgz as ns :< n -conArgs : (args : List Name) -> Names (args ++ vars) -> List Name -conArgs [] ns = [] -conArgs (a :: as) (n :: ns) = n :: conArgs as ns +conArgs : (args : List Name) -> Names (vars <>< args) -> List Name +conArgs args ns + = let ns' : Names (vars ++ cast args) + := rewrite sym $ fishAsSnocAppend vars args in ns + in conArgz ([<] <>< args) ns' <>> [] mutual forgetExp : Names vars -> CExp vars -> NamedCExp @@ -351,16 +373,14 @@ mutual export forget : {vars : _} -> CExp vars -> NamedCExp -forget {vars} exp - = forgetExp (addLocs vars []) - (rewrite appendNilRightNeutral vars in exp) +forget exp = forgetExp (initLocs vars) exp export forgetDef : CDef -> NamedDef forgetDef (MkFun args def) - = let ns = addLocs args [] - args' = conArgs {vars = []} args ns in - MkNmFun args' (forget def) + = let ns = addLocz args [<] + args' = conArgz {vars = [<]} args ns in + MkNmFun (cast args') (forget def) forgetDef (MkCon t a nt) = MkNmCon t a nt forgetDef (MkForeign ccs fargs ty) = MkNmForeign ccs fargs ty forgetDef (MkError err) = MkNmError (forget err) @@ -370,6 +390,11 @@ covering {vars : _} -> Show (CExp vars) where show exp = show (forget exp) +public export +covering +{vars : _} -> Show (CConAlt vars) where + show (MkConAlt name ci t args cexp) = "{MkConAlt name: \{show name}, ci: \{show ci}, t: \{show t}, args: \{show args}, cexp: \{show cexp}}" + export covering Show CFType where @@ -395,12 +420,12 @@ Show CFType where show (CFFun s t) = show s ++ " -> " ++ show t show (CFIORes t) = "IORes " ++ show t show (CFStruct n args) = "struct " ++ show n ++ " " ++ showSep " " (map show args) - show (CFUser n args) = show n ++ " " ++ showSep " " (map show args) + show (CFUser n args) = show n ++ " " ++ showSep " " (toList $ map show args) export covering Show CDef where - show (MkFun args exp) = show args ++ ": " ++ show exp + show (MkFun args exp) = show (toList args) ++ ": " ++ show exp show (MkCon tag arity pos) = "Constructor tag " ++ show tag ++ " arity " ++ show arity ++ maybe "" (\n => " (newtype by " ++ show n ++ ")") pos @@ -425,8 +450,8 @@ mutual export insertNames : SizeOf outer -> SizeOf ns -> - CExp (outer ++ inner) -> - CExp (outer ++ (ns ++ inner)) + CExp (inner ++ outer) -> + CExp (inner ++ ns ++ outer) insertNames outer ns (CLocal fc prf) = let MkNVar var' = insertNVarNames outer ns (MkNVar prf) in CLocal fc var' @@ -459,19 +484,28 @@ mutual insertNamesConAlt : SizeOf outer -> SizeOf ns -> - CConAlt (outer ++ inner) -> - CConAlt (outer ++ (ns ++ inner)) + CConAlt (inner ++ outer) -> + CConAlt (inner ++ (ns ++ outer)) insertNamesConAlt {outer} {ns} p q (MkConAlt x ci tag args sc) - = let sc' : CExp ((args ++ outer) ++ inner) - = rewrite sym (appendAssociative args outer inner) in sc in - MkConAlt x ci tag args - (rewrite appendAssociative args outer (ns ++ inner) in - insertNames (mkSizeOf args + p) q sc') + = let sc' : CExp (inner ++ (outer <>< args)) + = rewrite sym $ snocAppendFishAssociative inner outer args in sc + + sc'' : CExp (inner ++ (ns ++ (outer <>< args))) + = insertNames (p <>< mkSizeOf args) q sc' + + sc''' : CExp ((inner ++ (ns ++ outer)) <>< args) + = do rewrite (appendAssociative inner ns outer) + rewrite snocAppendFishAssociative (inner ++ ns) outer args + rewrite sym (appendAssociative inner ns (outer <>< args)) + sc'' + + in + MkConAlt x ci tag args sc''' insertNamesConstAlt : SizeOf outer -> SizeOf ns -> - CConstAlt (outer ++ inner) -> - CConstAlt (outer ++ (ns ++ inner)) + CConstAlt (inner ++ outer) -> + CConstAlt (inner ++ (ns ++ outer)) insertNamesConstAlt outer ns (MkConstAlt x sc) = MkConstAlt x (insertNames outer ns sc) export @@ -517,7 +551,7 @@ mutual shrinkConAlt : Thin newvars vars -> CConAlt vars -> CConAlt newvars shrinkConAlt sub (MkConAlt x ci tag args sc) - = MkConAlt x ci tag args (shrinkCExp (keeps args sub) sc) + = MkConAlt x ci tag args (shrinkCExp (keepz args sub) sc) shrinkConstAlt : Thin newvars vars -> CConstAlt vars -> CConstAlt newvars shrinkConstAlt sub (MkConstAlt x sc) = MkConstAlt x (shrinkCExp sub sc) @@ -534,6 +568,16 @@ public export SubstCEnv : Scope -> Scoped SubstCEnv = Subst CExp +public export +covering +{dropped, vars : _} -> Show (SubstCEnv dropped vars) where + show x = "SubstCEnv [" ++ showAll x ++ "]{vars = " ++ show (toList vars) ++ ", dropped = " ++ show (toList dropped) ++ "}" + where + showAll : {dropped, vars : _} -> SubstCEnv dropped vars -> String + showAll Lin = "" + showAll (Lin :< x) = show x + showAll (xx :< x) = show x ++ ", " ++ showAll xx + mutual substEnv : Substitutable CExp CExp substEnv outer dropped env (CLocal fc prf) @@ -569,11 +613,14 @@ mutual substConAlt : Substitutable CExp CConAlt substConAlt {vars} {outer} {dropped} p q env (MkConAlt x ci tag args sc) - = MkConAlt x ci tag args - (rewrite appendAssociative args outer vars in - substEnv (mkSizeOf args + p) q env - (rewrite sym (appendAssociative args outer (dropped ++ vars)) in - sc)) + = let sc' : CExp ((vars ++ dropped) ++ (outer <>< args)) + = rewrite sym (snocAppendFishAssociative (vars ++ dropped) outer args) in sc + + substed : CExp ((vars ++ outer) <>< args) + = do rewrite snocAppendFishAssociative vars outer args + substEnv (p <>< mkSizeOf args) q env sc' + + in MkConAlt x ci tag args substed substConstAlt : Substitutable CExp CConstAlt substConstAlt outer dropped env (MkConstAlt x sc) = MkConstAlt x (substEnv outer dropped env sc) @@ -581,15 +628,15 @@ mutual export substs : {dropped, vars : _} -> SizeOf dropped -> - SubstCEnv dropped vars -> CExp (dropped ++ vars) -> CExp vars + SubstCEnv dropped vars -> CExp (vars ++ dropped) -> CExp vars substs = substEnv zero mutual export mkLocals : SizeOf outer -> Bounds bound -> - CExp (outer ++ vars) -> - CExp (outer ++ (bound ++ vars)) + CExp (vars ++ outer) -> + CExp (vars ++ (bound ++ outer)) mkLocals later bs (CLocal {idx} {x} fc p) = let MkNVar p' = addVars later bs (MkNVar p) in CLocal {x} fc p' mkLocals later bs (CRef fc var) @@ -628,23 +675,32 @@ mutual mkLocalsConAlt : SizeOf outer -> Bounds bound -> - CConAlt (outer ++ vars) -> - CConAlt (outer ++ (bound ++ vars)) + CConAlt (vars ++ outer) -> + CConAlt (vars ++ (bound ++ outer)) mkLocalsConAlt {bound} {outer} {vars} p bs (MkConAlt x ci tag args sc) - = let sc' : CExp ((args ++ outer) ++ vars) - = rewrite sym (appendAssociative args outer vars) in sc in - MkConAlt x ci tag args - (rewrite appendAssociative args outer (bound ++ vars) in - mkLocals (mkSizeOf args + p) bs sc') + = MkConAlt x ci tag args locals' + where + sc' : CExp (vars ++ (outer <>< args)) + sc' = rewrite sym $ snocAppendFishAssociative vars outer args in sc + + locals : CExp (vars ++ (bound ++ (outer <>< args))) + locals = mkLocals (p <>< mkSizeOf args) bs sc' + + locals' : CExp ((vars ++ (bound ++ outer)) <>< args) + locals' = do + rewrite (appendAssociative vars bound outer) + rewrite snocAppendFishAssociative (vars ++ bound) outer args + rewrite sym (appendAssociative vars bound (outer <>< args)) + locals mkLocalsConstAlt : SizeOf outer -> Bounds bound -> - CConstAlt (outer ++ vars) -> - CConstAlt (outer ++ (bound ++ vars)) + CConstAlt (vars ++ outer) -> + CConstAlt (vars ++ (bound ++ outer)) mkLocalsConstAlt later bs (MkConstAlt x sc) = MkConstAlt x (mkLocals later bs sc) export -refsToLocals : Bounds bound -> CExp vars -> CExp (bound ++ vars) +refsToLocals : Bounds bound -> CExp vars -> CExp (vars ++ bound) refsToLocals None tm = tm refsToLocals bs y = mkLocals zero bs y diff --git a/src/Core/CompileExpr/Pretty.idr b/src/Core/CompileExpr/Pretty.idr index 343fd3d6eb..745b055cf3 100644 --- a/src/Core/CompileExpr/Pretty.idr +++ b/src/Core/CompileExpr/Pretty.idr @@ -17,17 +17,15 @@ import Libraries.Data.String.Extra %hide Vect.catMaybes %hide Vect.(++) -%hide SizeOf.map - %hide Core.Name.prettyOp -%hide CompileExpr.(::) -%hide CompileExpr.Nil +%hide CompileExpr.(:<) +%hide CompileExpr.Lin %hide String.(::) %hide String.Nil %hide Doc.Nil -%hide Subst.(::) -%hide Subst.Nil +%hide Subst.(:<) +%hide Subst.Lin %hide CList.(::) %hide CList.Nil %hide Stream.(::) @@ -120,9 +118,9 @@ prettyCExp : {args : _} -> CExp args -> Doc IdrisSyntax prettyCExp = prettyNamedCExp . forget prettyCDef : CDef -> Doc IdrisDocAnn -prettyCDef (MkFun [] exp) = reAnnotate Syntax $ prettyCExp exp +prettyCDef (MkFun [<] exp) = reAnnotate Syntax $ prettyCExp exp prettyCDef (MkFun args exp) = reAnnotate Syntax $ - keyword "\\" <++> concatWith (\ x, y => x <+> keyword "," <++> y) (map prettyName args) + keyword "\\" <++> concatWith (\ x, y => x <+> keyword "," <++> y) (map prettyName $ toList args) <++> fatArrow <++> prettyCExp exp prettyCDef (MkCon mtag arity nt) = vcat $ header (maybe "Type" (const "Data") mtag <++> "Constructor") :: map (indent 2) diff --git a/src/Core/Context.idr b/src/Core/Context.idr index 7f04b35a56..33ade5c4f2 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -324,7 +324,7 @@ commitCtxt ctxt ||| @vis Visibility, defaulting to private ||| @def actual definition export -newDef : (fc : FC) -> (n : Name) -> (rig : RigCount) -> (vars : List Name) -> +newDef : (fc : FC) -> (n : Name) -> (rig : RigCount) -> (vars : SnocList Name) -> (ty : ClosedTerm) -> (vis : WithDefault Visibility Private) -> (def : Def) -> GlobalDef newDef fc n rig vars ty vis def = MkGlobalDef @@ -557,13 +557,13 @@ mutual export HasNames (Env Term vars) where - full gam [] = pure [] - full gam (b :: bs) - = pure $ !(traverse (full gam) b) :: !(full gam bs) + full gam [<] = pure [<] + full gam (bs :< b) + = pure $ !(full gam bs) :< !(traverse (full gam) b) - resolved gam [] = pure [] - resolved gam (b :: bs) - = pure $ !(traverse (resolved gam) b) :: !(resolved gam bs) + resolved gam [<] = pure [<] + resolved gam (bs :< b) + = pure $ !(resolved gam bs) :< !(traverse (resolved gam) b) export HasNames Clause where @@ -1313,6 +1313,7 @@ addDef n def = do defs <- get Ctxt (idx, gam') <- addCtxt n def (gamma defs) put Ctxt ({ gamma := gam' } defs) + -- coreLift $ putStrLn "Context addDef, n: \{show n}, expr: \{show $ compexpr def}" case definition def of None => pure () Hole _ _ => pure () @@ -1354,7 +1355,7 @@ addBuiltin n ty tot op , specArgs = [] , inferrable = [] , multiplicity = top - , localVars = [] + , localVars = [<] , visibility = specified Public , totality = tot , isEscapeHatch = False diff --git a/src/Core/Context/Context.idr b/src/Core/Context/Context.idr index 6abf0e08f8..6517b17f9d 100644 --- a/src/Core/Context/Context.idr +++ b/src/Core/Context/Context.idr @@ -12,6 +12,7 @@ import public Algebra.SizeChange import Data.IORef import Data.String import Data.List1 +import Data.SnocList import Libraries.Data.IntMap import Libraries.Data.IOArray @@ -70,7 +71,7 @@ public export data Def : Type where None : Def -- Not yet defined PMDef : (pminfo : PMDefInfo) -> - (args : List Name) -> + (args : SnocList Name) -> (treeCT : CaseTree args) -> (treeRT : CaseTree args) -> (pats : List (vs ** (Env Term vs, Term vs, Term vs))) -> @@ -146,7 +147,7 @@ covering Show Def where show None = "undefined" show (PMDef _ args ct rt pats) - = unlines [ show args ++ ";" + = unlines [ show (toList args) ++ ";" , "Compile time tree: " ++ show ct , "Run time tree: " ++ show rt ] @@ -194,7 +195,7 @@ export covering Show Clause where show (MkClause {vars} env lhs rhs) - = show vars ++ ": " ++ show lhs ++ " = " ++ show rhs + = show (toList $ reverse vars) ++ ": " ++ show lhs ++ " = " ++ show rhs public export data DefFlag @@ -307,7 +308,7 @@ record GlobalDef where specArgs : List Nat -- arguments to specialise by inferrable : List Nat -- arguments which can be inferred from elsewhere in the type multiplicity : RigCount - localVars : List Name -- environment name is defined in + localVars : SnocList Name -- environment name is defined in visibility : WithDefault Visibility Private totality : Totality isEscapeHatch : Bool diff --git a/src/Core/Context/Data.idr b/src/Core/Context/Data.idr index 97a5dcd2ea..6e0789a7c1 100644 --- a/src/Core/Context/Data.idr +++ b/src/Core/Context/Data.idr @@ -90,7 +90,7 @@ paramPos tyn dcons = do export addData : {auto c : Ref Ctxt Defs} -> - List Name -> Visibility -> Int -> DataDef -> Core Int + SnocList Name -> Visibility -> Int -> DataDef -> Core Int addData vars vis tidx (MkData (MkCon dfc tyn arity tycon) datacons) = do defs <- get Ctxt tag <- getNextTypeTag diff --git a/src/Core/Context/Log.idr b/src/Core/Context/Log.idr index e259c8a815..735a1d09e1 100644 --- a/src/Core/Context/Log.idr +++ b/src/Core/Context/Log.idr @@ -2,30 +2,79 @@ module Core.Context.Log import Core.Context import Core.Options +import Core.Value import Data.String +import Data.List1 import Libraries.Data.StringMap import System.Clock %default covering +padLeft : Nat -> String -> String +padLeft pl str = + let whitespace = replicate (pl * 2) ' ' + in joinBy "\n" $ toList $ map (\r => whitespace ++ r) $ split (== '\n') str + -- if this function is called, then logging must be enabled. %inline export -logString : String -> Nat -> String -> Core () -logString "" n msg = coreLift $ putStrLn - $ "LOG " ++ show n ++ ": " ++ msg -logString str n msg = coreLift $ putStrLn - $ "LOG " ++ str ++ ":" ++ show n ++ ": " ++ msg +logString : Nat -> String -> Nat -> String -> Core () +logString depth "" n msg = coreLift $ putStrLn + $ padLeft depth $ "LOG " ++ show n ++ ": " ++ msg +logString depth str n msg = coreLift $ putStrLn + $ padLeft depth $ "LOG " ++ str ++ ":" ++ show n ++ ": " ++ msg %inline export -logString' : LogLevel -> String -> Core () -logString' lvl = - logString (fastConcat (intersperse "." (topics lvl)) ++ ":") +logString' : Nat -> LogLevel -> String -> Core () +logString' depth lvl = + logString depth (fastConcat (intersperse "." (topics lvl)) ++ ":") (verbosity lvl) +export +getDepth : {auto c : Ref Ctxt Defs} -> + Core Nat +getDepth + = do defs <- get Ctxt + pure (logDepth $ session (options defs)) + +export +logDepthIncrease : {auto c : Ref Ctxt Defs} -> Core () +logDepthIncrease + = do depth <- getDepth + update Ctxt { options->session->logDepth := depth + 1 } + +export +logDepthDecrease : {auto c : Ref Ctxt Defs} -> Core a -> Core a +logDepthDecrease r + = do r' <- r + depth <- getDepth + update Ctxt { options->session->logDepth := depth `minus` 1 } + pure r' + +export +logDepth : {auto c : Ref Ctxt Defs} -> Core a -> Core a +logDepth r + = do logDepthIncrease + logDepthDecrease r + +export +logQuite : {auto c : Ref Ctxt Defs} -> Core a -> Core a +logQuite r + = do opts <- getSession + update Ctxt { options->session->logEnabled := False } + r' <- r + update Ctxt { options->session->logEnabled := (logEnabled opts) } + pure r' + +export +logDepthWrap : {auto c : Ref Ctxt Defs} -> (a -> Core b) -> a -> Core b +logDepthWrap fn p + = do logDepthIncrease + logDepthDecrease (fn p) + export logging' : {auto c : Ref Ctxt Defs} -> LogLevel -> Core Bool @@ -57,15 +106,37 @@ logTerm : {vars : _} -> Nat -> Lazy String -> Term vars -> Core () logTerm str n msg tm = when !(logging str n) - $ do tm' <- toFullNames tm - logString str n $ msg ++ ": " ++ show tm' + $ do depth <- getDepth + tm' <- toFullNames tm + logString depth str n $ msg ++ ": " ++ show tm' + +export +logLocalEnv : {free, vars : _} -> + {auto c : Ref Ctxt Defs} -> + (s : String) -> + {auto 0 _ : KnownTopic s} -> + Nat -> String -> LocalEnv free vars -> Core () +logLocalEnv str n msg env + = when !(logging str n) $ + do depth <- getDepth + logString depth str n msg + dumpEnv env + where + dumpEnv : {free, vs : SnocList Name} -> LocalEnv free vs -> Core () + dumpEnv [<] = pure () + dumpEnv {vs = _ :< x} (bs :< closure) + = do depth <- getDepth + logString depth str n $ msg ++ ": " ++ show x ++ " :: " ++ show closure + dumpEnv bs + export log' : {auto c : Ref Ctxt Defs} -> LogLevel -> Lazy String -> Core () log' lvl msg = when !(logging' lvl) - $ logString' lvl msg + $ do depth <- getDepth + logString' depth lvl msg ||| Log a message with the given log level. Use increasingly ||| high log level numbers for more granular logging. @@ -82,7 +153,8 @@ log : {auto c : Ref Ctxt Defs} -> Nat -> Lazy String -> Core () log str n msg = when !(logging str n) - $ logString str n msg + $ do depth <- getDepth + logString depth str n msg export unverifiedLogC : {auto c : Ref Ctxt Defs} -> @@ -90,8 +162,9 @@ unverifiedLogC : {auto c : Ref Ctxt Defs} -> Nat -> Core String -> Core () unverifiedLogC str n cmsg = when !(unverifiedLogging str n) - $ do msg <- cmsg - logString str n msg + $ do depth <- getDepth + msg <- cmsg + logString depth str n msg %inline export diff --git a/src/Core/Context/Pretty.idr b/src/Core/Context/Pretty.idr index 068a5b5d74..d9908535cd 100644 --- a/src/Core/Context/Pretty.idr +++ b/src/Core/Context/Pretty.idr @@ -15,13 +15,13 @@ import Core.Context.Context import Libraries.Data.String.Extra -%hide Env.(::) -%hide Env.Nil +%hide Env.(:<) +%hide Env.Lin %hide String.(::) %hide String.Nil %hide Doc.Nil -%hide Subst.(::) -%hide Subst.Nil +%hide Subst.(:<) +%hide Subst.Lin %hide CList.(::) %hide CList.Nil %hide Stream.(::) @@ -43,7 +43,7 @@ namespace Raw prettyDef (PMDef _ args ct _ pats) = let ct = prettyTree ct in vcat - [ "Arguments" <++> cast (prettyList args) + [ "Arguments" <++> cast (prettyList $ toList args) , header "Compile time tree" <++> reAnnotate Syntax ct ] prettyDef (DCon tag arity nt) = @@ -95,7 +95,7 @@ namespace Resugared prettyDef (PMDef _ args ct _ pats) = do ct <- prettyTree (mkEnv emptyFC _) ct pure $ vcat - [ "Arguments" <++> cast (prettyList args) + [ "Arguments" <++> cast (prettyList $ toList args) , header "Compile time tree" <++> reAnnotate Syntax ct ] prettyDef (DCon tag arity nt) = pure $ diff --git a/src/Core/Core.idr b/src/Core/Core.idr index 8658f819d6..d36c482060 100644 --- a/src/Core/Core.idr +++ b/src/Core/Core.idr @@ -5,6 +5,7 @@ import Core.Env import Core.TT import Data.List1 +import Data.SnocList import Data.Vect import Libraries.Data.IMaybe @@ -256,7 +257,7 @@ Show Error where case cov of IsCovering => "Oh yes it is (Internal error!)" MissingCases cs => "Missing cases:\n\t" ++ - showSep "\n\t" (map show cs) + showSep "\n\t" (toList $ map show cs) NonCoveringCall ns => "Calls non covering function" ++ (case ns of [fn] => " " ++ show fn @@ -760,6 +761,18 @@ export traverse : (a -> Core b) -> List a -> Core (List b) traverse f xs = traverse' f xs [] +namespace SnocList + -- Traversable (specialised) + traverse' : (a -> Core b) -> SnocList a -> SnocList b -> Core (SnocList b) + traverse' f [<] acc = pure (reverse acc) + traverse' f (xs :< x) acc + = traverse' f xs (acc :< !(f x)) + + %inline + export + traverse : (a -> Core b) -> SnocList a -> Core (SnocList b) + traverse f xs = traverse' f xs [<] + export mapMaybeM : (a -> Core (Maybe b)) -> List a -> Core (List b) mapMaybeM f = go [<] where @@ -784,7 +797,7 @@ traverseList1 f xxs export traverseSnocList : (a -> Core b) -> SnocList a -> Core (SnocList b) traverseSnocList f [<] = pure [<] -traverseSnocList f (as :< a) = (:<) <$> traverseSnocList f as <*> f a +traverseSnocList f (as :< a) = [| traverseSnocList f as :< f a |] export traverseVect : (a -> Core b) -> Vect n a -> Core (Vect n b) @@ -830,6 +843,14 @@ traverseList1_ f xxs ignore (f x) traverse_ f xs +namespace SnocList + export + traverse_ : (a -> Core b) -> SnocList a -> Core () + traverse_ f [<] = pure () + traverse_ f (xs :< x) + = Core.do ignore (f x) + traverse_ f xs + %inline export traverseFC : (a -> Core b) -> WithFC a -> Core (WithFC b) traverseFC f (MkFCVal fc x) = MkFCVal fc <$> f x @@ -880,6 +901,15 @@ anyM f (x :: xs) then pure True else anyM f xs +-- Do really need it? Better do toList and use `anyM` +export +anyMScoped : (a -> Core Bool) -> SnocList a -> Core Bool +anyMScoped f [<] = pure False +anyMScoped f (xs :< x) + = if !(f x) + then pure True + else anyMScoped f xs + export allM : (a -> Core Bool) -> List a -> Core Bool allM f [] = pure True diff --git a/src/Core/Coverage.idr b/src/Core/Coverage.idr index ee07351cc9..1b093d3b01 100644 --- a/src/Core/Coverage.idr +++ b/src/Core/Coverage.idr @@ -15,6 +15,8 @@ import Data.String import Libraries.Data.NameMap import Libraries.Data.String.Extra +import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf import Libraries.Text.PrettyPrint.Prettyprinter %default covering @@ -77,16 +79,16 @@ conflict defs env nfty n | Nothing => pure False case (definition gdef, type gdef) of (DCon t arity _, dty) - => do Nothing <- conflictNF 0 nfty !(nf defs [] dty) + => do Nothing <- conflictNF 0 nfty !(nf defs [<] dty) | Just ms => pure $ conflictMatch ms pure True _ => pure False where mutual - conflictArgs : Int -> List (Closure vars) -> List (Closure []) -> + conflictArgs : Int -> SnocList (Closure vars) -> SnocList (Closure [<]) -> Core (Maybe (List (Name, Term vars))) - conflictArgs _ [] [] = pure (Just []) - conflictArgs i (c :: cs) (c' :: cs') + conflictArgs _ [<] [<] = pure (Just []) + conflictArgs i (cs :< c) (cs' :< c') = do cnf <- evalClosure defs c cnf' <- evalClosure defs c' Just ms <- conflictNF i cnf cnf' @@ -96,13 +98,13 @@ conflict defs env nfty n pure (Just (ms ++ ms')) conflictArgs _ _ _ = pure (Just []) - -- If the constructor type (the NF []) matches the variable type, + -- If the constructor type (the NF [<]) matches the variable type, -- then there may be a way to construct it, so return the matches in -- the indices. -- If any of those matches clash, the constructor is not valid -- e.g, Eq x x matches Eq Z (S Z), with x = Z and x = S Z -- conflictNF returns the list of matches, for checking - conflictNF : Int -> NF vars -> NF [] -> + conflictNF : Int -> NF vars -> NF [<] -> Core (Maybe (List (Name, Term vars))) conflictNF i t (NBind fc x b sc) -- invent a fresh name, in case a user has bound the same name @@ -110,8 +112,8 @@ conflict defs env nfty n -- put posslbe = let x' = MN (show x) i in conflictNF (i + 1) t - !(sc defs (toClosure defaultOpts [] (Ref fc Bound x'))) - conflictNF i nf (NApp _ (NRef Bound n) []) + !(sc defs (toClosure defaultOpts [<] (Ref fc Bound x'))) + conflictNF i nf (NApp _ (NRef Bound n) [<]) = do empty <- clearDefs defs pure (Just [(n, !(quote empty env nf))]) conflictNF i (NDCon _ n t a args) (NDCon _ n' t' a' args') @@ -189,11 +191,11 @@ getMissingAlts fc defs nfty alts noneOf alts c = not $ any (altMatch c) alts -- Mapping of variable to constructor tag already matched for it -KnownVars : List Name -> Type -> Type +KnownVars : SnocList Name -> Type -> Type KnownVars vars a = List (Var vars, a) -getName : {idx : Nat} -> {vars : List Name} -> (0 p : IsVar n idx vars) -> Name -getName {vars = v :: _} First = v +getName : {idx : Nat} -> {vars : SnocList Name} -> (0 p : IsVar n idx vars) -> Name +getName {vars = _ :< v} First = v getName (Later p) = getName p showK : {ns : _} -> @@ -204,11 +206,16 @@ showK {a} xs = show (map aString xs) (Var vars, a) -> (Name, a) aString (MkVar v, t) = (nameAt v, t) -weakenNs : SizeOf args -> KnownVars vars a -> KnownVars (args ++ vars) a +weakenNs : SizeOf args -> KnownVars vars a -> KnownVars (vars ++ args) a weakenNs args [] = [] weakenNs args ((v, t) :: xs) = (weakenNs args v, t) :: weakenNs args xs +weakensN : SizeOf args -> KnownVars vars a -> KnownVars (vars <>< args) a +weakensN args [] = [] +weakensN args ((v, t) :: xs) + = (weakensN args v, t) :: weakensN args xs + findTag : {idx, vars : _} -> (0 p : IsVar n idx vars) -> KnownVars vars a -> Maybe a findTag v [] = Nothing @@ -271,8 +278,8 @@ buildArgs : {auto c : Ref Ctxt Defs} -> KnownVars vars Int -> -- Things which have definitely match KnownVars vars (List Int) -> -- Things an argument *can't* be -- (because a previous case matches) - List ClosedTerm -> -- ^ arguments, with explicit names - CaseTree vars -> Core (List (List ClosedTerm)) + SnocList ClosedTerm -> -- ^ arguments, with explicit names + CaseTree vars -> Core (List (SnocList ClosedTerm)) buildArgs fc defs known not ps cs@(Case {name = var} idx el ty altsIn) -- If we've already matched on 'el' in this branch, restrict the alternatives -- to the tag we already know. Otherwise, add missing cases and filter out @@ -289,30 +296,31 @@ buildArgs fc defs known not ps cs@(Case {name = var} idx el ty altsIn) buildArgsAlt not altsN where buildArgAlt : KnownVars vars (List Int) -> - CaseAlt vars -> Core (List (List ClosedTerm)) + CaseAlt vars -> Core (List (SnocList ClosedTerm)) buildArgAlt not' (ConCase n t args sc) - = do let l = mkSizeOf args + = do let known' = (MkVar el, t) :: known + let l = mkSizeOf args let con = Ref fc (DataCon t (size l)) n - let ps' = map (substName var + let ps' = map (substName zero var (apply fc con (map (Ref fc Bound) args))) ps - buildArgs fc defs (weakenNs l ((MkVar el, t) :: known)) - (weakenNs l not') ps' sc + buildArgs fc defs (weakensN l known') + (weakensN l not') ps' sc buildArgAlt not' (DelayCase t a sc) = let l = mkSizeOf [t, a] - ps' = map (substName var (TDelay fc LUnknown + ps' = map (substName zero var (TDelay fc LUnknown (Ref fc Bound t) (Ref fc Bound a))) ps in - buildArgs fc defs (weakenNs l known) (weakenNs l not') - ps' sc + buildArgs fc defs (weakensN l known) + (weakensN l not') ps' sc buildArgAlt not' (ConstCase c sc) - = do let ps' = map (substName var (PrimVal fc c)) ps + = do let ps' = map (substName zero var (PrimVal fc c)) ps buildArgs fc defs known not' ps' sc buildArgAlt not' (DefaultCase sc) = buildArgs fc defs known not' ps sc buildArgsAlt : KnownVars vars (List Int) -> List (CaseAlt vars) -> - Core (List (List ClosedTerm)) + Core (List (SnocList ClosedTerm)) buildArgsAlt not' [] = pure [] buildArgsAlt not' (c@(ConCase _ t _ _) :: cs) = pure $ !(buildArgAlt not' c) ++ @@ -345,7 +353,7 @@ getMissing fc n ctree logC "coverage.missing" 20 $ map (join "\n") $ flip traverse pats $ \ pat => show <$> toFullNames pat - pure (map (apply fc (Ref fc Func n)) patss) + pure (map (apply fc (Ref fc Func n) . toList) patss) -- For the given name, get the names it refers to which are not themselves -- covering. @@ -408,26 +416,29 @@ match _ _ = False eraseApps : {auto c : Ref Ctxt Defs} -> Term vs -> Core (Term vs) eraseApps {vs} tm - = case getFnArgs tm of + = case getFnArgsSpine tm of (Ref fc Bound n, args) => - do args' <- traverse eraseApps args - pure (apply fc (Ref fc Bound n) args') + do args' <- traverseSnocList eraseApps args + pure (applySpine fc (Ref fc Bound n) args') (Ref fc nt n, args) => do defs <- get Ctxt mgdef <- lookupCtxtExact n (gamma defs) let eargs = maybe [] eraseArgs mgdef - args' <- traverse eraseApps (dropPos fc 0 eargs args) - pure (apply fc (Ref fc nt n) args') + args' <- traverseSnocList eraseApps + (dropPos fc (length args) eargs args) + pure (applySpine fc (Ref fc nt n) args') (tm, args) => - do args' <- traverse eraseApps args - pure (apply (getLoc tm) tm args') + do args' <- traverseSnocList eraseApps args + pure (applySpine (getLoc tm) tm args') where - dropPos : FC -> Nat -> List Nat -> List (Term vs) -> List (Term vs) - dropPos fc i ns [] = [] - dropPos fc i ns (x :: xs) + dropPos : FC -> Nat -> List Nat -> SnocList (Term vs) -> + SnocList (Term vs) + dropPos fc _ ns [<] = [<] + dropPos fc (S i) ns (xs :< x) = if i `elem` ns - then Erased fc Placeholder :: dropPos fc (S i) ns xs - else x :: dropPos fc (S i) ns xs + then dropPos fc i ns xs :< Erased fc Placeholder + else dropPos fc i ns xs :< x + dropPos fc _ ns xs = xs -- if tm would be matched by trylhs, then it's not an impossible case -- because we've already got it. Ignore anything in erased position. @@ -455,7 +466,7 @@ checkMatched cs ulhs where tryClauses : List Clause -> ClosedTerm -> Core (Maybe ClosedTerm) tryClauses [] ulhs - = do logTermNF "coverage" 10 "Nothing matches" [] ulhs + = do logTermNF "coverage" 10 "Nothing matches" [<] ulhs pure $ Just ulhs tryClauses (MkClause env lhs _ :: cs) ulhs = if !(clauseMatches env lhs ulhs) diff --git a/src/Core/Env.idr b/src/Core/Env.idr index b95a35cdb7..e6db424dc4 100644 --- a/src/Core/Env.idr +++ b/src/Core/Env.idr @@ -1,52 +1,57 @@ module Core.Env import Core.TT +import Core.Name.CompatibleVars import Data.List +import Data.SnocList + +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.HasLength %default total -- Environment containing types and values of local variables public export -data Env : (tm : List Name -> Type) -> List Name -> Type where - Nil : Env tm [] - (::) : Binder (tm vars) -> Env tm vars -> Env tm (x :: vars) +data Env : (tm : SnocList Name -> Type) -> SnocList Name -> Type where + Lin : Env tm [<] + (:<) : Env tm vars -> Binder (tm vars) -> Env tm (vars :< x) %name Env rho export -extend : (x : Name) -> Binder (tm vars) -> Env tm vars -> Env tm (x :: vars) -extend x = (::) {x} +extend : (x : Name) -> Env tm vars -> Binder (tm vars) -> Env tm (vars :< x) +extend x = (:<) {x} export -(++) : {ns : _} -> Env Term ns -> Env Term vars -> Env Term (ns ++ vars) -(++) (b :: bs) e = extend _ (map embed b) (bs ++ e) -(++) [] e = e +(++) : {ns : _} -> Env Term ns -> Env Term vars -> Env Term (vars ++ ns) +(++) (bs :< b) e = extend _ (bs ++ e) (map embed b) +(++) [<] e = e export length : Env tm xs -> Nat -length [] = 0 -length (_ :: xs) = S (length xs) +length [<] = 0 +length (xs :< _) = S (length xs) export lengthNoLet : Env tm xs -> Nat -lengthNoLet [] = 0 -lengthNoLet (Let _ _ _ _ :: xs) = lengthNoLet xs -lengthNoLet (_ :: xs) = S (lengthNoLet xs) +lengthNoLet [<] = 0 +lengthNoLet (xs :< Let _ _ _ _) = lengthNoLet xs +lengthNoLet (xs :< _) = S (lengthNoLet xs) export lengthExplicitPi : Env tm xs -> Nat -lengthExplicitPi [] = 0 -lengthExplicitPi (Pi _ _ Explicit _ :: rho) = S (lengthExplicitPi rho) -lengthExplicitPi (_ :: rho) = lengthExplicitPi rho +lengthExplicitPi [<] = 0 +lengthExplicitPi (rho :< Pi _ _ Explicit _) = S (lengthExplicitPi rho) +lengthExplicitPi (rho :< _) = lengthExplicitPi rho export -namesNoLet : {xs : _} -> Env tm xs -> List Name -namesNoLet [] = [] -namesNoLet (Let _ _ _ _ :: xs) = namesNoLet xs -namesNoLet {xs = x :: _} (_ :: env) = x :: namesNoLet env +namesNoLet : {xs : _} -> Env tm xs -> SnocList Name +namesNoLet [<] = [<] +namesNoLet (xs :< Let _ _ _ _) = namesNoLet xs +namesNoLet {xs = _ :< x} (env :< _) = namesNoLet env :< x public export -data IsDefined : Name -> List Name -> Type where +data IsDefined : Name -> SnocList Name -> Type where MkIsDefined : {idx : Nat} -> RigCount -> (0 p : IsVar n idx vars) -> IsDefined n vars @@ -54,8 +59,8 @@ export defined : {vars : _} -> (n : Name) -> Env Term vars -> Maybe (IsDefined n vars) -defined n [] = Nothing -defined {vars = x :: xs} n (b :: env) +defined n [<] = Nothing +defined {vars = xs :< x} n (env :< b) = case nameEq n x of Nothing => do MkIsDefined rig prf <- defined n env pure (MkIsDefined rig (Later prf)) @@ -65,28 +70,29 @@ defined {vars = x :: xs} n (b :: env) -- outer environment export bindEnv : {vars : _} -> FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm -bindEnv loc [] tm = tm -bindEnv loc (b :: env) tm +bindEnv loc [<] tm = tm +bindEnv loc (env :< b) tm = bindEnv loc env (Bind loc _ (PVar (binderLoc b) (multiplicity b) Explicit (binderType b)) tm) -revOnto : (xs, vs : List a) -> reverseOnto xs vs = reverse vs ++ xs -revOnto xs [] = Refl -revOnto xs (v :: vs) - = rewrite revOnto (v :: xs) vs in - rewrite appendAssociative (reverse vs) [v] xs in - rewrite revOnto [v] vs in Refl - -revNs : (vs, ns : List a) -> reverse ns ++ reverse vs = reverse (vs ++ ns) -revNs [] ns = rewrite appendNilRightNeutral (reverse ns) in Refl -revNs (v :: vs) ns - = rewrite revOnto [v] vs in - rewrite revOnto [v] (vs ++ ns) in - rewrite sym (revNs vs ns) in - rewrite appendAssociative (reverse ns) (reverse vs) [v] in - Refl +public export +revOnto : (xs, vs : SnocList a) -> reverseOnto xs vs = xs ++ reverse vs +revOnto xs [<] = Refl +revOnto xs (vs :< v) + = rewrite revOnto (xs :< v) vs in + rewrite revOnto [ reverse vs ++ reverse ns = reverse (ns ++ vs) +revNs [<] ns = rewrite appendLinLeftNeutral (reverse ns) in Refl +revNs (vs :< v) ns + = rewrite revOnto [ {vars : _} -> {idx : Nat} -> - (ns : List Name) -> + (ns : SnocList Name) -> (0 p : IsVar x idx vars) -> Env tm vars -> Binder (tm (reverseOnto vars ns)) -getBinderUnder {idx = Z} {vars = v :: vs} ns First (b :: env) - = rewrite revOnto vs (v :: ns) in map (weakenNs (reverse (mkSizeOf (v :: ns)))) b -getBinderUnder {idx = S k} {vars = v :: vs} ns (Later lp) (b :: env) - = getBinderUnder (v :: ns) lp env +getBinderUnder {idx = Z} {vars = vs :< v} ns First (env :< b) + = rewrite revOnto (vs :< x) ns in + rewrite sym $ appendAssociative vs [ {vars : _} -> {idx : Nat} -> (0 p : IsVar x idx vars) -> Env tm vars -> Binder (tm vars) -getBinder el env = getBinderUnder [] el env +getBinder el env = getBinderUnder [<] el env -- For getBinderLoc, we are not reusing getBinder because there is no need to -- needlessly weaken stuff; export getBinderLoc : {vars : _} -> {idx : Nat} -> (0 p : IsVar x idx vars) -> Env tm vars -> FC -getBinderLoc {idx = Z} First (b :: _) = binderLoc b -getBinderLoc {idx = S k} (Later p) (_ :: env) = getBinderLoc p env +getBinderLoc {idx = Z} First (_ :< b) = binderLoc b +getBinderLoc {idx = S k} (Later p) (env :< _) = getBinderLoc p env -- Make a type which abstracts over an environment -- Don't include 'let' bindings, since they have a concrete value and @@ -121,12 +130,12 @@ getBinderLoc {idx = S k} (Later p) (_ :: env) = getBinderLoc p env export abstractEnvType : {vars : _} -> FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm -abstractEnvType fc [] tm = tm -abstractEnvType fc (Let fc' c val ty :: env) tm +abstractEnvType fc [<] tm = tm +abstractEnvType fc (env :< Let fc' c val ty) tm = abstractEnvType fc env (Bind fc _ (Let fc' c val ty) tm) -abstractEnvType fc (Pi fc' c e ty :: env) tm +abstractEnvType fc (env :< Pi fc' c e ty) tm = abstractEnvType fc env (Bind fc _ (Pi fc' c e ty) tm) -abstractEnvType fc (b :: env) tm +abstractEnvType fc (env :< b) tm = let bnd = Pi (binderLoc b) (multiplicity b) Explicit (binderType b) in abstractEnvType fc env (Bind fc _ bnd tm) @@ -134,10 +143,10 @@ abstractEnvType fc (b :: env) tm export abstractEnv : {vars : _} -> FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm -abstractEnv fc [] tm = tm -abstractEnv fc (Let fc' c val ty :: env) tm +abstractEnv fc [<] tm = tm +abstractEnv fc (env :< Let fc' c val ty) tm = abstractEnv fc env (Bind fc _ (Let fc' c val ty) tm) -abstractEnv fc (b :: env) tm +abstractEnv fc (env :< b) tm = let bnd = Lam (binderLoc b) (multiplicity b) Explicit (binderType b) in abstractEnv fc env (Bind fc _ bnd tm) @@ -145,27 +154,27 @@ abstractEnv fc (b :: env) tm export abstractFullEnvType : {vars : _} -> FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm -abstractFullEnvType fc [] tm = tm -abstractFullEnvType fc (Pi fc' c e ty :: env) tm +abstractFullEnvType fc [<] tm = tm +abstractFullEnvType fc (env :< Pi fc' c e ty) tm = abstractFullEnvType fc env (Bind fc _ (Pi fc' c e ty) tm) -abstractFullEnvType fc (b :: env) tm +abstractFullEnvType fc (env :< b) tm = let bnd = Pi fc (multiplicity b) Explicit (binderType b) in abstractFullEnvType fc env (Bind fc _ bnd tm) export letToLam : Env Term vars -> Env Term vars -letToLam [] = [] -letToLam (Let fc c val ty :: env) = Lam fc c Explicit ty :: letToLam env -letToLam (b :: env) = b :: letToLam env +letToLam [<] = [<] +letToLam (env :< Let fc c val ty) = letToLam env :< Lam fc c Explicit ty +letToLam (env :< b) = letToLam env :< b mutual -- Quicker, if less safe, to store variables as a Nat, for quick comparison findUsed : {vars : _} -> - Env Term vars -> List Nat -> Term vars -> List Nat + Env Term vars -> SnocList Nat -> Term vars -> SnocList Nat findUsed env used (Local fc r idx p) = if elemBy eqNat idx used then used - else assert_total (findUsedInBinder env (idx :: used) + else assert_total (findUsedInBinder env (used :< idx) (getBinder p env)) where eqNat : Nat -> Nat -> Bool @@ -173,20 +182,20 @@ mutual findUsed env used (Meta _ _ _ args) = findUsedArgs env used args where - findUsedArgs : Env Term vars -> List Nat -> List (Term vars) -> List Nat + findUsedArgs : Env Term vars -> SnocList Nat -> List (Term vars) -> SnocList Nat findUsedArgs env u [] = u findUsedArgs env u (a :: as) = findUsedArgs env (findUsed env u a) as findUsed env used (Bind fc x b tm) = assert_total $ - dropS (findUsed (b :: env) + dropS (findUsed (env :< b) (map S (findUsedInBinder env used b)) tm) where - dropS : List Nat -> List Nat - dropS [] = [] - dropS (Z :: xs) = dropS xs - dropS (S p :: xs) = p :: dropS xs + dropS : SnocList Nat -> SnocList Nat + dropS [<] = [<] + dropS (xs :< Z) = dropS xs + dropS (xs :< S p) = dropS xs :< p findUsed env used (App fc fn arg) = findUsed env (findUsed env used fn) arg findUsed env used (As fc s a p) @@ -200,81 +209,81 @@ mutual findUsed env used _ = used findUsedInBinder : {vars : _} -> - Env Term vars -> List Nat -> - Binder (Term vars) -> List Nat + Env Term vars -> SnocList Nat -> + Binder (Term vars) -> SnocList Nat findUsedInBinder env used (Let _ _ val ty) = findUsed env (findUsed env used val) ty findUsedInBinder env used (PLet _ _ val ty) = findUsed env (findUsed env used val) ty findUsedInBinder env used b = findUsed env used (binderType b) -toVar : (vars : List Name) -> Nat -> Maybe (Var vars) -toVar (v :: vs) Z = Just (MkVar First) -toVar (v :: vs) (S k) +toVar : (vars : SnocList Name) -> Nat -> Maybe (Var vars) +toVar (vs :< v) Z = Just (MkVar First) +toVar (vs :< v) (S k) = do MkVar prf <- toVar vs k Just (MkVar (Later prf)) toVar _ _ = Nothing export findUsedLocs : {vars : _} -> - Env Term vars -> Term vars -> List (Var vars) + Env Term vars -> Term vars -> SnocList (Var vars) findUsedLocs env tm - = mapMaybe (toVar _) (findUsed env [] tm) + = mapMaybe (toVar _) (findUsed env [<] tm) -isUsed : Nat -> List (Var vars) -> Bool -isUsed n [] = False -isUsed n (v :: vs) = n == varIdx v || isUsed n vs +isUsed : Nat -> SnocList (Var vars) -> Bool +isUsed n [<] = False +isUsed n (vs :< v) = n == varIdx v || isUsed n vs mkShrinkSub : {n : _} -> - (vars : _) -> List (Var (n :: vars)) -> - (newvars ** Thin newvars (n :: vars)) -mkShrinkSub [] els + (vars : _) -> SnocList (Var (vars :< n)) -> + (newvars ** Thin newvars (vars :< n)) +mkShrinkSub [<] els = if isUsed 0 els then (_ ** Keep Refl) else (_ ** Drop Refl) -mkShrinkSub (x :: xs) els +mkShrinkSub (xs :< x) els = let (_ ** subRest) = mkShrinkSub xs (dropFirst els) in if isUsed 0 els then (_ ** Keep subRest) else (_ ** Drop subRest) mkShrink : {vars : _} -> - List (Var vars) -> + SnocList (Var vars) -> (newvars ** Thin newvars vars) -mkShrink {vars = []} xs = (_ ** Refl) -mkShrink {vars = v :: vs} xs = mkShrinkSub _ xs +mkShrink {vars = [<]} xs = (_ ** Refl) +mkShrink {vars = vs :< v} xs = mkShrinkSub _ xs -- Find the smallest subset of the environment which is needed to type check -- the given term export findSubEnv : {vars : _} -> Env Term vars -> Term vars -> - (vars' : List Name ** Thin vars' vars) + (vars' : SnocList Name ** Thin vars' vars) findSubEnv env tm = mkShrink (findUsedLocs env tm) export shrinkEnv : Env Term vars -> Thin newvars vars -> Maybe (Env Term newvars) shrinkEnv env Refl = Just env -shrinkEnv (b :: env) (Drop p) = shrinkEnv env p -shrinkEnv (b :: env) (Keep p) +shrinkEnv (env :< b) (Drop p) = shrinkEnv env p +shrinkEnv (env :< b) (Keep p) = do env' <- shrinkEnv env p b' <- assert_total (shrinkBinder b p) - pure (b' :: env') + pure (env' :< b') export -mkEnvOnto : FC -> (xs : List Name) -> Env Term ys -> Env Term (xs ++ ys) +mkEnvOnto : FC -> (xs : List Name) -> Env Term ys -> Env Term (ys <>< xs) mkEnvOnto fc [] vs = vs mkEnvOnto fc (n :: ns) vs - = PVar fc top Explicit (Erased fc Placeholder) - :: mkEnvOnto fc ns vs + = let pv = PVar fc top Explicit (Erased fc Placeholder) in + mkEnvOnto fc ns (vs :< pv) -- Make a dummy environment, if we genuinely don't care about the values -- and types of the contents. -- We use this when building and comparing case trees. export -mkEnv : FC -> (vs : List Name) -> Env Term vs -mkEnv fc [] = [] -mkEnv fc (n :: ns) = PVar fc top Explicit (Erased fc Placeholder) :: mkEnv fc ns +mkEnv : FC -> (vs : SnocList Name) -> Env Term vs +mkEnv fc [<] = [<] +mkEnv fc (ns :< _) = mkEnv fc ns :< PVar fc top Explicit (Erased fc Placeholder) -- Update an environment so that all names are guaranteed unique. In the -- case of a clash, the most recently bound is left unchanged. @@ -282,7 +291,7 @@ export uniqifyEnv : {vars : _} -> Env Term vars -> (vars' ** (Env Term vars', CompatibleVars vars vars')) -uniqifyEnv env = uenv [] env +uniqifyEnv env = uenv [<] env where next : Name -> Name next (MN n i) = MN n (i + 1) @@ -290,7 +299,7 @@ uniqifyEnv env = uenv [] env next (NS ns n) = NS ns (next n) next n = MN (show n) 0 - uniqueLocal : List Name -> Name -> Name + uniqueLocal : SnocList Name -> Name -> Name uniqueLocal vs n = if n `elem` vs -- we'll find a new name eventualy since the list of names @@ -302,40 +311,39 @@ uniqifyEnv env = uenv [] env else n uenv : {vars : _} -> - List Name -> Env Term vars -> + SnocList Name -> Env Term vars -> (vars' ** (Env Term vars', CompatibleVars vars vars')) - uenv used [] = ([] ** ([], Pre)) - uenv used {vars = v :: vs} (b :: bs) + uenv used [<] = ([<] ** ([<], Pre)) + uenv used {vars = vs :< v} (bs :< b) = if v `elem` used then let v' = uniqueLocal used v - (vs' ** (env', compat)) = uenv (v' :: used) bs + (vs' ** (env', compat)) = uenv (used :< v') bs b' = map (compatNs compat) b in - (v' :: vs' ** (b' :: env', Ext compat)) - else let (vs' ** (env', compat)) = uenv (v :: used) bs + (vs' :< v' ** (env' :< b', Ext compat)) + else let (vs' ** (env', compat)) = uenv (used :< v) bs b' = map (compatNs compat) b in - (v :: vs' ** (b' :: env', Ext compat)) + (vs' :< v ** (env' :< b', Ext compat)) export allVars : {vars : _} -> Env Term vars -> List (Var vars) -allVars [] = [] -allVars (v :: vs) = MkVar First :: map weaken (allVars vs) +allVars [<] = [] +allVars (vs :< v) = MkVar First :: map weaken (allVars vs) export allVarsNoLet : {vars : _} -> Env Term vars -> List (Var vars) -allVarsNoLet [] = [] -allVarsNoLet (Let _ _ _ _ :: vs) = map weaken (allVars vs) -allVarsNoLet (v :: vs) = MkVar First :: map weaken (allVars vs) +allVarsNoLet [<] = [] +allVarsNoLet (vs :< Let _ _ _ _) = map weaken (allVars vs) +allVarsNoLet (vs :< v) = MkVar First :: map weaken (allVars vs) export close : FC -> String -> Env Term vars -> Term vars -> ClosedTerm close fc nm env tm = let (s, env) = mkSubstEnv 0 env in - substs s env (rewrite appendNilRightNeutral vars in tm) + substs s env (rewrite appendLinLeftNeutral vars in tm) where - - mkSubstEnv : Int -> Env Term vs -> (SizeOf vs, SubstEnv vs []) - mkSubstEnv i [] = (zero, []) - mkSubstEnv i (v :: vs) + mkSubstEnv : Int -> Env Term vs -> (SizeOf vs, SubstEnv vs [<]) + mkSubstEnv i [<] = (zero, [<]) + mkSubstEnv i (vs :< v) = let (s, env) = mkSubstEnv (i + 1) vs in - (suc s, Ref fc Bound (MN nm i) :: env) + (suc s, env :< Ref fc Bound (MN nm i)) diff --git a/src/Core/GetType.idr b/src/Core/GetType.idr index 696e076680..3cd9d3967c 100644 --- a/src/Core/GetType.idr +++ b/src/Core/GetType.idr @@ -33,7 +33,7 @@ mutual chkMeta fc env !(nf defs env (embed mty)) args chk env (Bind fc nm b sc) = do bt <- chkBinder env b - sct <- chk {vars = nm :: _} (b :: env) sc + sct <- chk {vars = _ :< nm} (env :< b) sc pure $ gnf env (discharge fc nm b !(getTerm bt) !(getTerm sct)) chk env (App fc f a) = do fty <- chk env f @@ -85,7 +85,7 @@ mutual chkBinder env b = chk env (binderType b) discharge : FC -> (nm : Name) -> Binder (Term vars) -> - Term vars -> Term (nm :: vars) -> (Term vars) + Term vars -> Term (vars :< nm) -> (Term vars) discharge fc n (Lam fc' c x ty) bindty scopety = Bind fc n (Pi fc' c x ty) scopety discharge fc n (Let fc' c val ty) bindty scopety diff --git a/src/Core/Hash.idr b/src/Core/Hash.idr index fedb7dbef2..98c72e23ee 100644 --- a/src/Core/Hash.idr +++ b/src/Core/Hash.idr @@ -5,6 +5,7 @@ import Core.CompileExpr import Core.TT import Data.List1 +import Data.SnocList import Libraries.Data.String.Iterator import Data.Vect @@ -83,6 +84,11 @@ Hashable a => Hashable (List a) where hashWithSalt h [] = abs h hashWithSalt h (x :: xs) = hashWithSalt (h * 33 + hash x) xs +export +Hashable a => Hashable (SnocList a) where + hashWithSalt h [<] = abs h + hashWithSalt h (xs :< x) = hashWithSalt (h * 33 + hash x) xs + export Hashable a => Hashable (List1 a) where hashWithSalt h xxs = hashWithSalt (h * 33 + hash (head xxs)) (tail xxs) diff --git a/src/Core/LinearCheck.idr b/src/Core/LinearCheck.idr index b250f22387..8710ccc4e7 100644 --- a/src/Core/LinearCheck.idr +++ b/src/Core/LinearCheck.idr @@ -12,6 +12,7 @@ import Core.Value import Core.TT import Data.List +import Data.SnocList import Libraries.Data.SnocList.SizeOf @@ -19,30 +20,30 @@ import Libraries.Data.SnocList.SizeOf -- List of variable usages - we'll count the contents of specific variables -- when discharging binders, to ensure that linear names are only used once -data Usage : List Name -> Type where - Nil : Usage vars - (::) : Var vars -> Usage vars -> Usage vars +data Usage : SnocList Name -> Type where + Lin : Usage vars + (:<) : Usage vars -> Var vars -> Usage vars Show (Usage vars) where show xs = "[" ++ showAll xs ++ "]" where showAll : Usage vs -> String - showAll [] = "" - showAll [el] = show el - showAll (x :: xs) = show x ++ ", " ++ show xs + showAll [<] = "" + showAll [ Usage vars -doneScope [] = [] -doneScope (MkVar First :: xs) = doneScope xs -doneScope (MkVar (Later p) :: xs) = MkVar p :: doneScope xs +doneScope : Usage (vars :< n) -> Usage vars +doneScope [<] = [<] +doneScope (xs :< MkVar First) = doneScope xs +doneScope (xs :< MkVar (Later p)) = doneScope xs :< MkVar p (++) : Usage ns -> Usage ns -> Usage ns -(++) [] ys = ys -(++) (x :: xs) ys = x :: xs ++ ys +(++) sx Lin = sx +(++) sx (sy :< y) = (sx ++ sy) :< y count : Nat -> Usage ns -> Nat -count p [] = 0 -count p (v :: xs) +count p [<] = 0 +count p (xs :< v) = if p == varIdx v then 1 + count p xs else count p xs mutual @@ -185,9 +186,9 @@ mutual when (not erase) $ rigSafe rigb rig pure (Local fc x idx prf, gnf env ty, used rig) where - getName : {idx : _} -> (vs : List Name) -> (0 p : IsVar n idx vs) -> Name - getName (x :: _) First = x - getName (x :: xs) (Later p) = getName xs p + getName : {idx : _} -> (vs : SnocList Name) -> (0 p : IsVar n idx vs) -> Name + getName (_ :< x) First = x + getName (xs :< x) (Later p) = getName xs p rigSafe : RigCount -> RigCount -> Core () rigSafe l r = when (l < r) @@ -196,12 +197,12 @@ mutual -- count the usage if we're in a linear context. If not, the usage doesn't -- matter used : RigCount -> Usage vars - used r = if isLinear r then [MkVar prf] else [] + used r = if isLinear r then [ eraseLinear env _ => env else env - (sc', sct, usedsc) <- lcheck rig erase (b' :: env') sc + (sc', sct, usedsc) <- lcheck rig erase (env' :< b') sc let used_in = count 0 usedsc holeFound <- if not erase && isLinear (multiplicity b) @@ -295,18 +296,18 @@ mutual else linear getZeroes : {vs : _} -> Env Term vs -> List (Var vs) - getZeroes [] = [] - getZeroes (b :: bs) + getZeroes [<] = [] + getZeroes (bs :< b) = if isErased (multiplicity b) then MkVar First :: map weaken (getZeroes bs) else map weaken (getZeroes bs) eraseLinear : Env Term vs -> Env Term vs - eraseLinear [] = [] - eraseLinear (b :: bs) + eraseLinear [<] = [<] + eraseLinear (bs :< b) = if isLinear (multiplicity b) - then setMultiplicity b erased :: eraseLinear bs - else b :: eraseLinear bs + then eraseLinear bs :< setMultiplicity b erased + else eraseLinear bs :< b checkUsageOK : Nat -> RigCount -> Core () checkUsageOK used r = when (isLinear r && used /= 1) @@ -351,7 +352,7 @@ mutual do when (not erase) $ needFunctionType f' gfty -- we don't do any linearity checking when `erase` is set -- so returning an empty usage is fine - pure (App fc f a, gErased fc, []) + pure (App fc f a, gErased fc, [<]) _ => needFunctionType f' gfty where @@ -386,14 +387,14 @@ mutual _ => throw (GenericMsg fc "Not a delayed type") lcheck rig erase env (PrimVal fc c) = do log "quantity" 15 "lcheck PrimVal" - pure (PrimVal fc c, gErased fc, []) + pure (PrimVal fc c, gErased fc, [<]) lcheck rig erase env (Erased fc i) = do log "quantity" 15 "lcheck Erased" - pure (Erased fc i, gErased fc, []) + pure (Erased fc i, gErased fc, [<]) lcheck rig erase env (TType fc u) -- Not universe checking here, just use the top of the hierarchy = do log "quantity" 15 "lcheck TType" - pure (TType fc u, gType fc (MN "top" 0), []) + pure (TType fc u, gType fc (MN "top" 0), [<]) lcheckBinder : {vars : _} -> {auto c : Ref Ctxt Defs} -> @@ -403,29 +404,29 @@ mutual Core (Binder (Term vars), Glued vars, Usage vars) lcheckBinder rig erase env (Lam fc c x ty) = do (tyv, tyt, _) <- lcheck erased erase env ty - pure (Lam fc c x tyv, tyt, []) + pure (Lam fc c x tyv, tyt, [<]) lcheckBinder rig erase env (Let fc rigc val ty) = do (tyv, tyt, _) <- lcheck erased erase env ty (valv, valt, vs) <- lcheck (rig |*| rigc) erase env val pure (Let fc rigc valv tyv, tyt, vs) lcheckBinder rig erase env (Pi fc c x ty) = do (tyv, tyt, _) <- lcheck (rig |*| c) erase env ty - pure (Pi fc c x tyv, tyt, []) + pure (Pi fc c x tyv, tyt, [<]) lcheckBinder rig erase env (PVar fc c p ty) = do (tyv, tyt, _) <- lcheck erased erase env ty - pure (PVar fc c p tyv, tyt, []) + pure (PVar fc c p tyv, tyt, [<]) lcheckBinder rig erase env (PLet fc rigc val ty) = do (tyv, tyt, _) <- lcheck erased erase env ty (valv, valt, vs) <- lcheck (rig |*| rigc) erase env val pure (PLet fc rigc valv tyv, tyt, vs) lcheckBinder rig erase env (PVTy fc c ty) = do (tyv, tyt, _) <- lcheck erased erase env ty - pure (PVTy fc c tyv, tyt, []) + pure (PVTy fc c tyv, tyt, [<]) discharge : {vars : _} -> Defs -> Env Term vars -> FC -> (nm : Name) -> Binder (Term vars) -> Glued vars -> - Term (nm :: vars) -> Glued (nm :: vars) -> Usage vars -> + Term (vars :< nm) -> Glued (vars :< nm) -> Usage vars -> Core (Term vars, Glued vars, Usage vars) discharge defs env fc nm (Lam fc' c x ty) gbindty scope gscopety used = do scty <- getTerm gscopety @@ -525,12 +526,12 @@ mutual checkEnvUsage : {vars : _} -> SizeOf done -> RigCount -> - Env Term vars -> Usage (done <>> vars) -> - List (Term (done <>> vars)) -> - Term (done <>> vars) -> Core () - checkEnvUsage s rig [] usage args tm = pure () - checkEnvUsage s rig {done} {vars = nm :: xs} (b :: env) usage args tm - = do let pos = mkVarChiply s + Env Term vars -> Usage (vars ++ done) -> + List (Term (vars ++ done)) -> + Term (vars ++ done) -> Core () + checkEnvUsage s rig [<] usage args tm = pure () + checkEnvUsage s rig {done} {vars = xs :< nm} (env :< b) usage args tm + = do let pos = mkVar s let used_in = count (varIdx pos) usage holeFound <- if isLinear (multiplicity b) @@ -543,7 +544,10 @@ mutual checkUsageOK (getLoc (binderType b)) used nm (isLocArg pos args) ((multiplicity b) |*| rig) - checkEnvUsage (s :< nm) rig env usage args tm + checkEnvUsage ([ (vs ** (Env Term vs, Term vs, Term vs)) -> Core (List (Name, ArgUsage)) @@ -645,16 +649,16 @@ mutual RigCount -> (erase : Bool) -> Env Term vars -> Name -> Int -> Def -> List (Term vars) -> Core (Term vars, Glued vars, Usage vars) - expandMeta rig erase env n idx (PMDef _ [] (STerm _ fn) _ _) args - = do tm <- substMeta (embed fn) args zero [] + expandMeta rig erase env n idx (PMDef _ [<] (STerm _ fn) _ _) args + = do tm <- substMeta (embed fn) args zero [<] lcheck rig erase env tm where substMeta : {drop, vs : _} -> - Term (drop ++ vs) -> List (Term vs) -> + Term (vs ++ drop) -> List (Term vs) -> SizeOf drop -> SubstEnv drop vs -> Core (Term vs) substMeta (Bind bfc n (Lam _ c e ty) sc) (a :: as) drop env - = substMeta sc as (suc drop) (a :: env) + = substMeta sc as (suc drop) (env :< a) substMeta (Bind bfc n (Let _ c val ty) sc) as drop env = substMeta (subst val sc) as drop env substMeta rhs [] drop env = pure (substs drop env rhs) @@ -691,19 +695,19 @@ mutual ++ " not a function type)")) lcheckMeta rig erase env fc n idx [] chk nty = do defs <- get Ctxt - pure (Meta fc n idx (reverse chk), glueBack defs env nty, []) + pure (Meta fc n idx (reverse chk), glueBack defs env nty, [<]) checkEnvUsage : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> FC -> SizeOf done -> RigCount -> - Env Term vars -> Usage (done <>> vars) -> - Term (done <>> vars) -> + Env Term vars -> Usage (vars ++ done) -> + Term (vars ++ done) -> Core () -checkEnvUsage fc s rig [] usage tm = pure () -checkEnvUsage fc s rig {vars = nm :: xs} (b :: env) usage tm - = do let pos = mkVarChiply s +checkEnvUsage fc s rig [<] usage tm = pure () +checkEnvUsage fc s rig {vars = xs :< nm} (env :< b) usage tm + = do let pos = mkVar s let used_in = count (varIdx pos) usage holeFound <- if isLinear (multiplicity b) @@ -714,7 +718,10 @@ checkEnvUsage fc s rig {vars = nm :: xs} (b :: env) usage tm then 1 else used_in checkUsageOK used ((multiplicity b) |*| rig) - checkEnvUsage fc (s :< nm) rig env usage tm + checkEnvUsage fc ([ RigCount -> Core () checkUsageOK used r = when (isLinear r && used /= 1) diff --git a/src/Core/Metadata.idr b/src/Core/Metadata.idr index cb7d867b48..c91d86845d 100644 --- a/src/Core/Metadata.idr +++ b/src/Core/Metadata.idr @@ -205,9 +205,9 @@ addLHS loc outerenvlen env tm where toPat : Env Term vs -> Env Term vs - toPat (Lam fc c p ty :: bs) = PVar fc c p ty :: toPat bs - toPat (b :: bs) = b :: toPat bs - toPat [] = [] + toPat (bs :< Lam fc c p ty) = toPat bs :< PVar fc c p ty + toPat (bs :< b) = toPat bs :< b + toPat [<] = [<] -- For giving local variable names types, just substitute the name -- rather than storing the whole environment, otherwise we'll repeatedly @@ -219,8 +219,8 @@ addLHS loc outerenvlen env tm -- types directly! substEnv : {vars : _} -> FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm -substEnv loc [] tm = tm -substEnv {vars = x :: _} loc (b :: env) tm +substEnv loc [<] tm = tm +substEnv {vars = _ :< x} loc (env :< b) tm = substEnv loc env (subst (Ref loc Bound x) tm) export @@ -357,7 +357,7 @@ normaliseTypes nfType : Defs -> (NonEmptyFC, (Name, Nat, ClosedTerm)) -> Core (NonEmptyFC, (Name, Nat, ClosedTerm)) nfType defs (loc, (n, len, ty)) - = pure (loc, (n, len, !(normaliseArgHoles defs [] ty))) + = pure (loc, (n, len, !(normaliseArgHoles defs [<] ty))) record TTMFile where constructor MkTTMFile diff --git a/src/Core/Name.idr b/src/Core/Name.idr index ee466b056d..c4829364ef 100644 --- a/src/Core/Name.idr +++ b/src/Core/Name.idr @@ -449,9 +449,9 @@ nameEq (Resolved x) (Resolved y) with (decEq x y) nameEq _ _ = Nothing export -namesEq : (xs, ys : List Name) -> Maybe (xs = ys) -namesEq [] [] = Just Refl -namesEq (x :: xs) (y :: ys) +namesEq : (xs : SnocList Name) -> (ys : SnocList Name) -> Maybe (xs = ys) +namesEq [<] [<] = Just Refl +namesEq (xs :< x) (ys :< y) = do p <- nameEq x y ps <- namesEq xs ys rewrite p diff --git a/src/Core/Name/CompatibleVars.idr b/src/Core/Name/CompatibleVars.idr new file mode 100644 index 0000000000..333ee26618 --- /dev/null +++ b/src/Core/Name/CompatibleVars.idr @@ -0,0 +1,42 @@ +module Core.Name.CompatibleVars + +public export +data CompatibleVars : (xs, ys : SnocList a) -> Type where + Pre : CompatibleVars xs xs + Ext : CompatibleVars xs ys -> CompatibleVars (xs :< n) (ys :< m) + +export +invertExt : CompatibleVars (xs :< n) (ys :< m) -> CompatibleVars xs ys +invertExt Pre = Pre +invertExt (Ext p) = p + +export +extendCompats : (args : SnocList a) -> + CompatibleVars xs ys -> + CompatibleVars (xs ++ args) (ys ++ args) +extendCompats args Pre = Pre +extendCompats args prf = go args prf where + + go : (args : SnocList a) -> + CompatibleVars xs ys -> + CompatibleVars (xs ++ args) (ys ++ args) + go [<] prf = prf + go (xs :< x) prf = Ext (go xs prf) + +export +decCompatibleVars : (xs, ys : SnocList a) -> Dec (CompatibleVars xs ys) +decCompatibleVars [<] [<] = Yes Pre +decCompatibleVars [<] (xs :< x) = No (\case p impossible) +decCompatibleVars (xs :< x) [<] = No (\case p impossible) +decCompatibleVars (xs :< x) (ys :< y) = case decCompatibleVars xs ys of + Yes prf => Yes (Ext prf) + No nprf => No (nprf . invertExt) + +export +areCompatibleVars : (xs, ys : SnocList a) -> + Maybe (CompatibleVars xs ys) +areCompatibleVars [<] [<] = pure Pre +areCompatibleVars (xs :< x) (ys :< y) + = do compat <- areCompatibleVars xs ys + pure (Ext compat) +areCompatibleVars _ _ = Nothing diff --git a/src/Core/Name/Scoped.idr b/src/Core/Name/Scoped.idr index 8d66b57fce..094f12ef3a 100644 --- a/src/Core/Name/Scoped.idr +++ b/src/Core/Name/Scoped.idr @@ -1,10 +1,12 @@ module Core.Name.Scoped import Core.Name +import Core.Name.CompatibleVars -import public Data.List.HasLength - -import public Libraries.Data.List.SizeOf +import Data.SnocList +import Libraries.Data.SnocList.HasLength +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.List.SizeOf %default total @@ -20,8 +22,7 @@ import public Libraries.Data.List.SizeOf ||| Γ ⊢ λx. t : A → B public export Scope : Type -Scope = List Name --- TODO: make that a SnocList +Scope = SnocList Name ||| A scoped definition is one indexed by a scope public export @@ -29,119 +30,81 @@ Scoped : Type Scoped = Scope -> Type ------------------------------------------------------------------------ --- Semi-decidable equality - -export -scopeEq : (xs, ys : Scope) -> Maybe (xs = ys) -scopeEq [] [] = Just Refl -scopeEq (x :: xs) (y :: ys) - = do Refl <- nameEq x y - Refl <- scopeEq xs ys - Just Refl -scopeEq _ _ = Nothing +-- Thinnings ------------------------------------------------------------------------- --- Generate a fresh name (for a given scope) +public export +data Thin : SnocList a -> SnocList a -> Type where + Refl : Thin xs xs + Drop : Thin xs ys -> Thin xs (ys :< y) + Keep : Thin xs ys -> Thin (xs :< x) (ys :< x) + +namespace Thin + -- At runtime, Thin's `Refl` does not carry any additional + -- information. So this is safe! + export + embed : Thin xs ys -> Thin (outer ++ xs) (outer ++ ys) + embed = believe_me export -mkFresh : Scope -> Name -> Name -mkFresh vs n - = if n `elem` vs - then assert_total $ mkFresh vs (next n) - else n - - ------------------------------------------------------------------------- --- Compatible variables - -public export -data CompatibleVars : (xs, ys : List a) -> Type where - Pre : CompatibleVars xs xs - Ext : CompatibleVars xs ys -> CompatibleVars (n :: xs) (m :: ys) +covering +{xs, ys : _} -> Show (Thin xs ys) where + show Refl = "ThinRefl" + show (Drop t) = "ThinDrop \{show t}" + show (Keep t) = "ThinKeep \{show t}" export -invertExt : CompatibleVars (n :: xs) (m :: ys) -> CompatibleVars xs ys -invertExt Pre = Pre -invertExt (Ext p) = p +none : {xs : SnocList a} -> Thin [<] xs +none {xs = [<]} = Refl +none {xs = _ :< _} = Drop none +-- we actually sometimes want Refl vs. Keep! +||| Smart constructor. We should use this to maximise the length +||| of the Refl segment thus getting more short-circuiting behaviours export -extendCompats : (args : List a) -> - CompatibleVars xs ys -> - CompatibleVars (args ++ xs) (args ++ ys) -extendCompats args Pre = Pre -extendCompats args prf = go args prf where - - go : (args : List a) -> - CompatibleVars xs ys -> - CompatibleVars (args ++ xs) (args ++ ys) - go [] prf = prf - go (x :: xs) prf = Ext (go xs prf) +keep : Thin xs ys -> Thin (xs :< x) (ys :< x) +keep Refl = Refl +keep p = Keep p export -decCompatibleVars : (xs, ys : List a) -> Dec (CompatibleVars xs ys) -decCompatibleVars [] [] = Yes Pre -decCompatibleVars [] (x :: xs) = No (\case p impossible) -decCompatibleVars (x :: xs) [] = No (\case p impossible) -decCompatibleVars (x :: xs) (y :: ys) = case decCompatibleVars xs ys of - Yes prf => Yes (Ext prf) - No nprf => No (nprf . invertExt) +keeps : (args : SnocList a) -> Thin xs ys -> Thin (xs ++ args) (ys ++ args) +keeps [<] th = th +keeps (sx :< x) th = Keep (keeps sx th) export -areCompatibleVars : (xs, ys : List a) -> - Maybe (CompatibleVars xs ys) -areCompatibleVars [] [] = pure Pre -areCompatibleVars (x :: xs) (y :: ys) - = do compat <- areCompatibleVars xs ys - pure (Ext compat) -areCompatibleVars _ _ = Nothing +keepz : (args : List a) -> Thin xs ys -> Thin (xs <>< args) (ys <>< args) +keepz [] th = th +keepz (x :: xs) th = keepz xs (keep th) ------------------------------------------------------------------------ --- Thinnings - -public export -data Thin : List a -> List a -> Type where - Refl : Thin xs xs - Drop : Thin xs ys -> Thin xs (y :: ys) - Keep : Thin xs ys -> Thin (x :: xs) (x :: ys) +-- Semi-decidable equality export -none : {xs : List a} -> Thin [] xs -none {xs = []} = Refl -none {xs = _ :: _} = Drop none +scopeEq : (xs, ys : Scope) -> Maybe (xs = ys) +scopeEq [<] [<] = Just Refl +scopeEq (xs :< x) (ys :< y) + = do Refl <- nameEq x y + Refl <- scopeEq xs ys + Just Refl +scopeEq _ _ = Nothing -{- UNUSED: we actually sometimes want Refl vs. Keep! -||| Smart constructor. We should use this to maximise the length -||| of the Refl segment thus getting more short-circuiting behaviours export -Keep : Thin xs ys -> Thin (x :: xs) (x :: ys) -Keep Refl = Refl -Keep p = Keep p --} +localEq : (xs, ys : List Name) -> Maybe (xs = ys) +localEq [] [] = Just Refl +localEq (x :: xs) (y :: ys) + = do Refl <- nameEq x y + Refl <- localEq xs ys + Just Refl +localEq _ _ = Nothing -export -keeps : (args : List a) -> Thin xs ys -> Thin (args ++ xs) (args ++ ys) -keeps [] th = th -keeps (x :: xs) th = Keep (keeps xs th) +------------------------------------------------------------------------ +-- Generate a fresh name (for a given scope) -||| Compute the thinning getting rid of the listed de Bruijn indices. --- TODO: is the list of erased arguments guaranteed to be sorted? --- Should it? export -removeByIndices : - (erasedArgs : List Nat) -> - (args : Scope) -> - (args' ** Thin args' args) -removeByIndices es = go 0 where - - go : (currentIdx : Nat) -> (args : Scope) -> - (args' ** Thin args' args) - go idx [] = ([] ** Refl) - go idx (x :: xs) = - let (vs ** th) = go (S idx) xs in - if idx `elem` es - then (vs ** Drop th) - else (x :: vs ** Keep th) - +mkFresh : Scope -> Name -> Name +mkFresh vs n + = if n `elem` vs + then assert_total $ mkFresh vs (next n) + else n ------------------------------------------------------------------------ -- Concepts @@ -149,17 +112,17 @@ removeByIndices es = go 0 where public export 0 Weakenable : Scoped -> Type Weakenable tm = {0 vars, ns : Scope} -> - SizeOf ns -> tm vars -> tm (ns ++ vars) + SizeOf ns -> tm vars -> tm (vars ++ ns) public export 0 Strengthenable : Scoped -> Type Strengthenable tm = {0 vars, ns : Scope} -> - SizeOf ns -> tm (ns ++ vars) -> Maybe (tm vars) + SizeOf ns -> tm (vars ++ ns) -> Maybe (tm vars) public export 0 GenWeakenable : Scoped -> Type -GenWeakenable tm = {0 outer, ns, local : Scope} -> - SizeOf local -> SizeOf ns -> tm (local ++ outer) -> tm (local ++ (ns ++ outer)) +GenWeakenable tm = {0 local, ns, outer : Scope} -> + SizeOf outer -> SizeOf ns -> tm (local ++ outer) -> tm (local ++ ns ++ outer) public export 0 Thinnable : Scoped -> Type @@ -171,7 +134,7 @@ Shrinkable tm = {0 xs, ys : Scope} -> tm xs -> Thin ys xs -> Maybe (tm ys) public export 0 Embeddable : Scoped -> Type -Embeddable tm = {0 outer, vars : Scope} -> tm vars -> tm (vars ++ outer) +Embeddable tm = {0 outer, vars : Scope} -> tm vars -> tm (outer ++ vars) ------------------------------------------------------------------------ -- IsScoped interface @@ -180,7 +143,7 @@ public export interface Weaken (0 tm : Scoped) where constructor MkWeaken -- methods - weaken : tm vars -> tm (nm :: vars) + weaken : tm vars -> tm (vars :< nm) weakenNs : Weakenable tm -- default implementations weaken = weakenNs (suc zero) @@ -193,9 +156,17 @@ interface GenWeaken (0 tm : Scoped) where export genWeaken : GenWeaken tm => - SizeOf local -> tm (local ++ outer) -> tm (local ++ n :: outer) + SizeOf outer -> tm (local ++ outer) -> tm (local ++ ([ + {0 vars : Scope} -> {0 ns : List Name} -> + SizeOf ns -> tm vars -> tm (vars <>< ns) +weakensN s t + = rewrite fishAsSnocAppend vars ns in + weakenNs (zero <>< s) t + public export interface Strengthen (0 tm : Scoped) where constructor MkStrengthen @@ -203,9 +174,17 @@ interface Strengthen (0 tm : Scoped) where strengthenNs : Strengthenable tm export -strengthen : Strengthen tm => tm (nm :: vars) -> Maybe (tm vars) +strengthen : Strengthen tm => tm (vars :< nm) -> Maybe (tm vars) strengthen = strengthenNs (suc zero) +export +strengthensN : + Strengthen tm => SizeOf ns -> + tm (vars <>< ns) -> Maybe (tm vars) +strengthensN s t + = strengthenNs (zero <>< s) + $ rewrite sym $ fishAsSnocAppend vars ns in t + public export interface FreelyEmbeddable (0 tm : Scoped) where constructor MkFreelyEmbeddable @@ -213,6 +192,10 @@ interface FreelyEmbeddable (0 tm : Scoped) where embed : Embeddable tm embed = believe_me +export +embedFishily : FreelyEmbeddable tm => tm (cast ns) -> tm (vars <>< ns) +embedFishily t = rewrite fishAsSnocAppend vars ns in embed t + export FunctorFreelyEmbeddable : Functor f => FreelyEmbeddable tm => FreelyEmbeddable (f . tm) FunctorFreelyEmbeddable = MkFreelyEmbeddable believe_me @@ -257,5 +240,5 @@ interface Weaken tm => IsScoped (0 tm : Scoped) where shrink : Shrinkable tm export -compat : IsScoped tm => tm (m :: xs) -> tm (n :: xs) +compat : IsScoped tm => tm (xs :< m) -> tm (xs :< n) compat = compatNs (Ext Pre) diff --git a/src/Core/Normalise.idr b/src/Core/Normalise.idr index 787d22dff8..cec3b9eba2 100644 --- a/src/Core/Normalise.idr +++ b/src/Core/Normalise.idr @@ -18,7 +18,7 @@ import Core.Value -- reduce export normalisePis : {auto c : Ref Ctxt Defs} -> - {vars : List Name} -> + {vars : SnocList Name} -> Defs -> Env Term vars -> Term vars -> Core (Term vars) normalisePis defs env tm = do tmnf <- nf defs env tm @@ -71,9 +71,9 @@ normaliseLHS : {auto c : Ref Ctxt Defs} -> {free : _} -> Defs -> Env Term free -> Term free -> Core (Term free) normaliseLHS defs env (Bind fc n b sc) - = pure $ Bind fc n b !(normaliseLHS defs (b :: env) sc) + = pure $ Bind fc n b !(normaliseLHS defs (env :< b) sc) normaliseLHS defs env tm - = quote defs env !(nfOpts onLHS defs env tm) + = quoteLHS defs env !(nfOpts onLHS defs env tm) export tryNormaliseSizeLimit : {auto c : Ref Ctxt Defs} -> @@ -118,7 +118,7 @@ normaliseScope : {auto c : Ref Ctxt Defs} -> {free : _} -> Defs -> Env Term free -> Term free -> Core (Term free) normaliseScope defs env (Bind fc n b sc) - = pure $ Bind fc n b !(normaliseScope defs (b :: env) sc) + = pure $ Bind fc n b !(normaliseScope defs (env :< b) sc) normaliseScope defs env tm = normalise defs env tm export @@ -173,9 +173,10 @@ logNF : {vars : _} -> logNF str n msg env tmnf = when !(logging str n) $ do defs <- get Ctxt - tm <- quote defs env tmnf + tm <- logQuite $ quote defs env tmnf tm' <- toFullNames tm - logString str n (msg ++ ": " ++ show tm') + depth <- getDepth + logString depth str n (msg ++ ": " ++ show tm') -- Log message with a term, reducing holes and translating back to human -- readable names first @@ -187,9 +188,10 @@ logTermNF' : {vars : _} -> Nat -> Lazy String -> Env Term vars -> Term vars -> Core () logTermNF' str n msg env tm = do defs <- get Ctxt - tmnf <- normaliseHoles defs env tm + tmnf <- logQuite $ normaliseHoles defs env tm tm' <- toFullNames tmnf - logString str n (msg ++ ": " ++ show tm') + depth <- getDepth + logString depth str n (msg ++ ": " ++ show tm') export logTermNF : {vars : _} -> @@ -211,7 +213,8 @@ logGlue str n msg env gtm do defs <- get Ctxt tm <- getTerm gtm tm' <- toFullNames tm - logString str n (msg ++ ": " ++ show tm') + depth <- getDepth + logString depth str n (msg ++ ": " ++ show tm') export logGlueNF : {vars : _} -> @@ -223,9 +226,10 @@ logGlueNF str n msg env gtm = when !(logging str n) $ do defs <- get Ctxt tm <- getTerm gtm - tmnf <- normaliseHoles defs env tm + tmnf <- logQuite $ normaliseHoles defs env tm tm' <- toFullNames tmnf - logString str n (msg ++ ": " ++ show tm') + depth <- getDepth + logString depth str n (msg ++ ": " ++ show tm') export logEnv : {vars : _} -> @@ -235,22 +239,53 @@ logEnv : {vars : _} -> Nat -> String -> Env Term vars -> Core () logEnv str n msg env = when !(logging str n) $ - do logString str n msg + do depth <- getDepth + logString depth str n msg dumpEnv env where - dumpEnv : {vs : List Name} -> Env Term vs -> Core () - dumpEnv [] = pure () - dumpEnv {vs = x :: _} (Let _ c val ty :: bs) + dumpEnv : {vs : SnocList Name} -> Env Term vs -> Core () + dumpEnv [<] = pure () + dumpEnv {vs = _ :< x} (bs :< Let _ c val ty) = do logTermNF' str n (msg ++ ": let " ++ show x) bs val logTermNF' str n (msg ++ ":" ++ show c ++ " " ++ show x) bs ty dumpEnv bs - dumpEnv {vs = x :: _} (b :: bs) + dumpEnv {vs = _ :< x} (bs :< b) = do logTermNF' str n (msg ++ ":" ++ show (multiplicity b) ++ " " ++ show (piInfo b) ++ " " ++ show x) bs (binderType b) dumpEnv bs + +export +-- It is OKAY to use it only for `mkEnv`-generated Environment which is dummy +logEnvRev : {vars : _} -> + {auto c : Ref Ctxt Defs} -> + (s : String) -> + {auto 0 _ : KnownTopic s} -> + Nat -> String -> Env Term vars -> Core () +logEnvRev str n msg env + = when !(logging str n) $ + do depth <- getDepth + logString depth str n msg + dumpEnv env + + where + + dumpEnv : {vs : SnocList Name} -> Env Term vs -> Core () + dumpEnv [<] = pure () + dumpEnv {vs = _ :< x} (bs :< Let _ c val ty) + -- Reversed output + = do dumpEnv bs + logTermNF' str n (msg ++ ": let " ++ show x) bs val + logTermNF' str n (msg ++ ":" ++ show c ++ " " ++ show x) bs ty + dumpEnv {vs = _ :< x} (bs :< b) + -- Reversed output + = do dumpEnv bs + logTermNF' str n (msg ++ ":" ++ show (multiplicity b) ++ " " ++ + show (piInfo b) ++ " " ++ + show x) bs (binderType b) + replace' : {auto c : Ref Ctxt Defs} -> {vars : _} -> Int -> Defs -> Env Term vars -> @@ -273,25 +308,25 @@ replace' {vars} tmpi defs env lhs parg tm sc' <- replace' (tmpi + 1) defs env lhs parg !(scfn defs (toClosure defaultOpts env (Ref fc Bound x'))) pure (Bind fc x b' (refsToLocals (Add x x' None) sc')) - repSub (NApp fc hd []) + repSub (NApp fc hd [<]) = do empty <- clearDefs defs - quote empty env (NApp fc hd []) + quote empty env (NApp fc hd [<]) repSub (NApp fc hd args) = do args' <- traverse (traversePair repArg) args - pure $ applyStackWithFC - !(replace' tmpi defs env lhs parg (NApp fc hd [])) + pure $ applySpineWithFC + !(replace' tmpi defs env lhs parg (NApp fc hd [<])) args' repSub (NDCon fc n t a args) = do args' <- traverse (traversePair repArg) args empty <- clearDefs defs - pure $ applyStackWithFC - !(quote empty env (NDCon fc n t a [])) + pure $ applySpineWithFC + !(quote empty env (NDCon fc n t a [<])) args' repSub (NTCon fc n t a args) = do args' <- traverse (traversePair repArg) args empty <- clearDefs defs - pure $ applyStackWithFC - !(quote empty env (NTCon fc n t a [])) + pure $ applySpineWithFC + !(quote empty env (NTCon fc n t a [<])) args' repSub (NAs fc s a p) = do a' <- repSub a @@ -307,7 +342,7 @@ replace' {vars} tmpi defs env lhs parg tm repSub (NForce fc r tm args) = do args' <- traverse (traversePair repArg) args tm' <- repSub tm - pure $ applyStackWithFC (TForce fc r tm') args' + pure $ applySpineWithFC (TForce fc r tm') args' repSub (NErased fc (Dotted t)) = do t' <- repSub t pure (Erased fc (Dotted t')) @@ -336,7 +371,7 @@ normalisePrims : {auto c : Ref Ctxt Defs} -> {vs : _} -> List Name -> -- view of the potential redex (n : Name) -> -- function name - (args : List arg) -> -- arguments from inside out (arg1, ..., argk) + (args : SnocList arg) -> -- arguments from inside out (arg1, ..., argk) -- actual term to evaluate if needed (tm : Term vs) -> -- original term (n arg1 ... argk) Env Term vs -> -- evaluation environment @@ -345,7 +380,7 @@ normalisePrims : {auto c : Ref Ctxt Defs} -> {vs : _} -> normalisePrims boundSafe viewConstant all prims n args tm env = do let True = isPrimName prims !(getFullName n) -- is a primitive | _ => pure Nothing - let (mc :: _) = reverse args -- with at least one argument + let (_ :< mc) = reverse args -- with at least one argument | _ => pure Nothing let (Just c) = viewConstant mc -- that is a constant | _ => pure Nothing diff --git a/src/Core/Normalise/Convert.idr b/src/Core/Normalise/Convert.idr index 4639d4b269..46eab5375d 100644 --- a/src/Core/Normalise/Convert.idr +++ b/src/Core/Normalise/Convert.idr @@ -11,17 +11,44 @@ import Core.TT import Core.Value import Data.List +import Data.SnocList + +import Libraries.Data.List.SizeOf %default covering +extend : {args, args' : List Name} -> + SizeOf args -> SizeOf args' -> + (List (Var vars, Var vars')) -> + Maybe (List (Var (vars <>< args), Var (vars' <>< args'))) +extend s s' ms + = do guard (size s == size s') + let vs = embedFishily @{ListFreelyEmbeddable} (Var.allVars (cast args)) + let vs' = embedFishily @{ListFreelyEmbeddable} (Var.allVars (cast args')) + pure $ zip vs vs' ++ map (bimap (weakensN s) (weakensN s')) ms + +findIdx : List (Var vars, Var vars') -> Nat -> Maybe (Var vars') +findIdx [] _ = Nothing +findIdx ((MkVar {varIdx = i} _, v) :: ps) n + = if i == n then Just v else findIdx ps n + +dropP : {0 args, args' : List Name} -> + SizeOf args -> SizeOf args' -> + (Var (vars <>< args), Var (vars' <>< args')) -> + Maybe (Var vars, Var vars') +dropP s s' (x, y) + = do x' <- strengthensN s x + y' <- strengthensN s' y + pure (x', y') + public export interface Convert tm where convert : {auto c : Ref Ctxt Defs} -> - {vars : List Name} -> + {vars : SnocList Name} -> Defs -> Env Term vars -> tm vars -> tm vars -> Core Bool convertInf : {auto c : Ref Ctxt Defs} -> - {vars : List Name} -> + {vars : SnocList Name} -> Defs -> Env Term vars -> tm vars -> tm vars -> Core Bool @@ -45,13 +72,8 @@ tryUpdate : {vars, vars' : _} -> List (Var vars, Var vars') -> Term vars -> Maybe (Term vars') tryUpdate ms (Local fc l idx p) - = do MkVar p' <- findIdx ms (MkVar p) + = do MkVar p' <- findIdx ms idx pure $ Local fc l _ p' - where - findIdx : List (Var vars, Var vars') -> Var vars -> Maybe (Var vars') - findIdx [] _ = Nothing - findIdx ((old, v) :: ps) n - = if old == n then Just v else findIdx ps n tryUpdate ms (Ref fc nt n) = pure $ Ref fc nt n tryUpdate ms (Meta fc n i args) = pure $ Meta fc n i !(traverse (tryUpdate ms) args) tryUpdate ms (Bind fc x b sc) @@ -71,7 +93,7 @@ tryUpdate ms (Bind fc x b sc) tryUpdateB _ = Nothing weakenP : {n : _} -> (Var vars, Var vars') -> - (Var (n :: vars), Var (n :: vars')) + (Var (vars :< n), Var (vars' :< n)) weakenP (v, vs) = (weaken v, weaken vs) tryUpdate ms (App fc f a) = pure $ App fc !(tryUpdate ms f) !(tryUpdate ms a) tryUpdate ms (As fc s a p) = pure $ As fc s !(tryUpdate ms a) !(tryUpdate ms p) @@ -86,9 +108,9 @@ mutual allConvNF : {auto c : Ref Ctxt Defs} -> {vars : _} -> Ref QVar Int -> Bool -> Defs -> Env Term vars -> - List (NF vars) -> List (NF vars) -> Core Bool - allConvNF q i defs env [] [] = pure True - allConvNF q i defs env (x :: xs) (y :: ys) + SnocList (NF vars) -> SnocList (NF vars) -> Core Bool + allConvNF q i defs env [<] [<] = pure True + allConvNF q i defs env (xs :< x) (ys :< y) = do ok <- allConvNF q i defs env xs ys if ok then convGen q i defs env x y else pure False @@ -97,9 +119,9 @@ mutual -- return False if anything differs at the head, to quickly find -- conversion failures without going deeply into all the arguments. -- True means they might still match - quickConv : List (NF vars) -> List (NF vars) -> Bool - quickConv [] [] = True - quickConv (x :: xs) (y :: ys) = quickConvArg x y && quickConv xs ys + quickConv : SnocList (NF vars) -> SnocList (NF vars) -> Bool + quickConv [<] [<] = True + quickConv (xs :< x) (ys :< y) = quickConvArg x y && quickConv xs ys where quickConvHead : NHead vars -> NHead vars -> Bool quickConvHead (NLocal _ _ _) (NLocal _ _ _) = True @@ -127,10 +149,10 @@ mutual allConv : {auto c : Ref Ctxt Defs} -> {vars : _} -> Ref QVar Int -> Bool -> Defs -> Env Term vars -> - List (Closure vars) -> List (Closure vars) -> Core Bool + SnocList (FC, Closure vars) -> SnocList (FC, Closure vars) -> Core Bool allConv q i defs env xs ys - = do xsnf <- traverse (evalClosure defs) xs - ysnf <- traverse (evalClosure defs) ys + = do xsnf <- traverse (evalClosure defs . snd) xs + ysnf <- traverse (evalClosure defs . snd) ys if quickConv xsnf ysnf then allConvNF q i defs env xsnf ysnf else pure False @@ -145,41 +167,22 @@ mutual Core (Maybe (List (Var args, Var args'))) getMatchingVarAlt defs ms (ConCase n tag cargs t) (ConCase n' tag' cargs' t') = if n == n' - then do let Just ms' = extend cargs cargs' ms + then do let s = mkSizeOf cargs + let s' = mkSizeOf cargs' + let Just ms' = extend s s' ms | Nothing => pure Nothing Just ms <- getMatchingVars defs ms' t t' | Nothing => pure Nothing -- drop the prefix from cargs/cargs' since they won't -- be in the caller - pure (Just (mapMaybe (dropP cargs cargs') ms)) + pure (Just (mapMaybe (dropP s s') ms)) else pure Nothing where weakenP : {0 c, c' : _} -> {0 args, args' : Scope} -> (Var args, Var args') -> - (Var (c :: args), Var (c' :: args')) + (Var (args :< c), Var (args' :< c')) weakenP (v, vs) = (weaken v, weaken vs) - extend : (cs : List Name) -> (cs' : List Name) -> - (List (Var args, Var args')) -> - Maybe (List (Var (cs ++ args), Var (cs' ++ args'))) - extend [] [] ms = pure ms - extend (c :: cs) (c' :: cs') ms - = do rest <- extend cs cs' ms - pure ((MkVar First, MkVar First) :: map weakenP rest) - extend _ _ _ = Nothing - - dropV : forall args . - (cs : List Name) -> Var (cs ++ args) -> Maybe (Var args) - dropV [] v = Just v - dropV (c :: cs) (MkVar First) = Nothing - dropV (c :: cs) (MkVar (Later x)) - = dropV cs (MkVar x) - - dropP : (cs : List Name) -> (cs' : List Name) -> - (Var (cs ++ args), Var (cs' ++ args')) -> - Maybe (Var args, Var args') - dropP cs cs' (x, y) = pure (!(dropV cs x), !(dropV cs' y)) - getMatchingVarAlt defs ms (ConstCase c t) (ConstCase c' t') = if c == c' then getMatchingVars defs ms t t' @@ -223,7 +226,7 @@ mutual {vars : _} -> Ref QVar Int -> Bool -> Defs -> Env Term vars -> Name -> Name -> - List (Closure vars) -> List (Closure vars) -> Core Bool + SnocList (Closure vars) -> SnocList (Closure vars) -> Core Bool chkSameDefs q i defs env n n' nargs nargs' = do Just (PMDef _ args ct rt _) <- lookupDefExact n (gamma defs) | _ => pure False @@ -239,19 +242,19 @@ mutual where -- We've only got the index into the argument list, and the indices -- don't match up, which is annoying. But it'll always be there! - getArgPos : Nat -> List (Closure vars) -> Maybe (Closure vars) - getArgPos _ [] = Nothing - getArgPos Z (c :: cs) = pure c - getArgPos (S k) (c :: cs) = getArgPos k cs + getArgPos : Nat -> SnocList (Closure vars) -> Maybe (Closure vars) + getArgPos _ [<] = Nothing + getArgPos Z (cs :< c) = pure c + getArgPos (S k) (cs :< c) = getArgPos k cs convertMatches : {vs, vs' : _} -> List (Var vs, Var vs') -> Core Bool convertMatches [] = pure True - convertMatches ((MkVar {varIdx = ix} p, MkVar {varIdx = iy} p') :: vs) - = do let Just varg = getArgPos ix nargs + convertMatches ((MkVar {varIdx=ix} p, MkVar {varIdx=iy} p') :: vs) + = do let Just varg = getArgPos ix (cast nargs) | Nothing => pure False - let Just varg' = getArgPos iy nargs' + let Just varg' = getArgPos iy (cast nargs') | Nothing => pure False pure $ !(convGen q i defs env varg varg') && !(convertMatches vs) @@ -261,8 +264,8 @@ mutual chkConvCaseBlock : {auto c : Ref Ctxt Defs} -> {vars : _} -> FC -> Ref QVar Int -> Bool -> Defs -> Env Term vars -> - NHead vars -> List (Closure vars) -> - NHead vars -> List (Closure vars) -> Core Bool + NHead vars -> SnocList (Closure vars) -> + NHead vars -> SnocList (Closure vars) -> Core Bool chkConvCaseBlock fc q i defs env (NRef _ n) nargs (NRef _ n') nargs' = do NS _ (CaseBlock _ _) <- full (gamma defs) n | _ => pure False @@ -301,9 +304,9 @@ mutual findArgPos (Case idx p _ _) = Just idx findArgPos _ = Nothing - getScrutinee : Nat -> List (Closure vs) -> Maybe (Closure vs) - getScrutinee Z (x :: xs) = Just x - getScrutinee (S k) (x :: xs) = getScrutinee k xs + getScrutinee : Nat -> SnocList (Closure vs) -> Maybe (Closure vs) + getScrutinee Z (xs :< x) = Just x + getScrutinee (S k) (xs :< x) = getScrutinee k xs getScrutinee _ _ = Nothing chkConvCaseBlock _ _ _ _ _ _ _ _ _ = pure False @@ -341,7 +344,7 @@ mutual Convert NF where convGen q i defs env (NBind fc x b sc) (NBind _ x' b' sc') = do var <- genName "conv" - let c = MkClosure defaultOpts [] env (Ref fc Bound var) + let c = MkClosure defaultOpts [<] env (Ref fc Bound var) bok <- convBinders q i defs env b b' if bok then do bsc <- sc defs c @@ -367,7 +370,9 @@ mutual convGen q inf defs env (NApp fc val args) (NApp _ val' args') = if !(chkConvHead q inf defs env val val') then do i <- getInfPos val - allConv q inf defs env (dropInf 0 i args1) (dropInf 0 i args2) + allConv q inf defs env + (cast {from = List (FC, Closure vars)} $ dropInf 0 i $ cast args) -- TODO: UGH! + (cast {from = List (FC, Closure vars)} $ dropInf 0 i $ cast args') else chkConvCaseBlock fc q inf defs env val args1 val' args2 where getInfPos : NHead vars -> Core (List Nat) @@ -388,19 +393,19 @@ mutual else x :: dropInf (S i) ds xs -- Discard file context information irrelevant for conversion checking - args1 : List (Closure vars) + args1 : SnocList (Closure vars) args1 = map snd args - args2 : List (Closure vars) + args2 : SnocList (Closure vars) args2 = map snd args' convGen q i defs env (NDCon _ nm tag _ args) (NDCon _ nm' tag' _ args') = if tag == tag' - then allConv q i defs env (map snd args) (map snd args') + then allConv q i defs env args args' else pure False convGen q i defs env (NTCon _ nm tag _ args) (NTCon _ nm' tag' _ args') = if nm == nm' - then allConv q i defs env (map snd args) (map snd args') + then allConv q i defs env args args' else pure False convGen q i defs env (NAs _ _ _ tm) (NAs _ _ _ tm') = convGen q i defs env tm tm' @@ -421,7 +426,7 @@ mutual convGen q i defs env (NForce _ r arg args) (NForce _ r' arg' args') = if compatible r r' then if !(convGen q i defs env arg arg') - then allConv q i defs env (map snd args) (map snd args') + then allConv q i defs env args args' else pure False else pure False diff --git a/src/Core/Normalise/Eval.idr b/src/Core/Normalise/Eval.idr index 60ee283859..36a8b835c5 100644 --- a/src/Core/Normalise/Eval.idr +++ b/src/Core/Normalise/Eval.idr @@ -10,6 +10,7 @@ import Core.TT import Core.Value import Data.List +import Data.SnocList import Data.Maybe import Data.Nat import Data.String @@ -23,7 +24,7 @@ import Libraries.Data.WithDefault -- from a term (via 'gnf') or a normal form (via 'glueBack') but the other -- part will only be constructed when needed, because it's in Core. public export -data Glued : List Name -> Type where +data Glued : SnocList Name -> Type where MkGlue : (fromTerm : Bool) -> -- is it built from the term; i.e. can -- we read the term straight back? Core (Term vars) -> (Ref Ctxt Defs -> Core (NF vars)) -> Glued vars @@ -41,14 +42,14 @@ getNF : {auto c : Ref Ctxt Defs} -> Glued vars -> Core (NF vars) getNF {c} (MkGlue _ _ nf) = nf c public export -Stack : List Name -> Type +Stack : SnocList Name -> Type Stack vars = List (FC, Closure vars) evalWithOpts : {auto c : Ref Ctxt Defs} -> {free, vars : _} -> Defs -> EvalOpts -> Env Term free -> LocalEnv free vars -> - Term (vars ++ free) -> Stack free -> Core (NF free) + Term (free ++ vars) -> Stack free -> Core (NF free) export evalClosure : {auto c : Ref Ctxt Defs} -> @@ -60,7 +61,7 @@ evalArg defs c = evalClosure defs c export toClosure : EvalOpts -> Env Term outer -> Term outer -> Closure outer -toClosure opts env tm = MkClosure opts [] env tm +toClosure opts env tm = MkClosure opts [<] env tm updateLimit : NameType -> Name -> EvalOpts -> Core (Maybe EvalOpts) updateLimit Func n opts @@ -85,45 +86,52 @@ data CaseResult a | NoMatch -- case alternative didn't match anything | GotStuck -- alternative matched, but got stuck later -record TermWithEnv (free : List Name) where +record TermWithEnv (free : SnocList Name) where constructor MkTermEnv - { varsEnv : List Name } + { varsEnv : SnocList Name } locEnv : LocalEnv free varsEnv - term : Term $ varsEnv ++ free + term : Term $ free ++ varsEnv parameters (defs : Defs) (topopts : EvalOpts) mutual eval : {auto c : Ref Ctxt Defs} -> {free, vars : _} -> Env Term free -> LocalEnv free vars -> - Term (vars ++ free) -> Stack free -> Core (NF free) + Term (free ++ vars) -> Stack free -> Core (NF free) eval env locs (Local fc mrig idx prf) stk - = evalLocal env fc mrig idx prf stk locs + = logDepth $ + do log "eval.ref" 50 "eval Local \{show idx} \{show $ MkVar prf} to \{show stk}" + logDepth $ logLocalEnv "eval.ref" 50 "eval Local locs" locs + evalLocal env fc mrig idx prf stk locs eval env locs (Ref fc nt fn) stk - = evalRef env False fc nt fn stk (NApp fc (NRef nt fn) stk) + = do logC "eval.ref" 50 $ do fn' <- toFullNames fn + pure "Ref \{show nt} \{show fn'} to \{show stk}" + evalRef env False fc nt fn stk (NApp fc (NRef nt fn) (cast stk)) eval {vars} {free} env locs (Meta fc name idx args) stk - = evalMeta env fc name idx (closeArgs args) stk + -- See [Note] Meta args + -- Seemed as a performance issue + = evalMeta env fc name idx (reverse $ closeArgs args) stk where -- Yes, it's just a map, but specialising it by hand since we -- use this a *lot* and it saves the run time overhead of making -- a closure and calling APPLY. - closeArgs : List (Term (vars ++ free)) -> List (Closure free) - closeArgs [] = [] - closeArgs (t :: ts) = MkClosure topopts locs env t :: closeArgs ts + closeArgs : List (Term (free ++ vars)) -> SnocList (FC, Closure free) + closeArgs [] = [<] + closeArgs (t :: ts) = closeArgs ts :< (emptyFC, MkClosure topopts locs env t) eval env locs (Bind fc x (Lam _ r _ ty) scope) (thunk :: stk) - = eval env (snd thunk :: locs) scope stk + = eval env (locs :< snd thunk) scope stk eval env locs (Bind fc x b@(Let _ r val ty) scope) stk = if (holesOnly topopts || argHolesOnly topopts) && not (tcInline topopts) then do let b' = map (MkClosure topopts locs env) b pure $ NBind fc x b' (\defs', arg => evalWithOpts defs' topopts - env (arg :: locs) scope stk) - else eval env (MkClosure topopts locs env val :: locs) scope stk + env (locs :< arg) scope stk) + else eval env (locs :< MkClosure topopts locs env val) scope stk eval env locs (Bind fc x b scope) stk = do let b' = map (MkClosure topopts locs env) b pure $ NBind fc x b' (\defs', arg => evalWithOpts defs' topopts - env (arg :: locs) scope stk) + env (locs :< arg) scope stk) eval env locs (App fc fn arg) stk = case strategy topopts of CBV => do arg' <- eval env locs arg [] @@ -145,8 +153,8 @@ parameters (defs : Defs) (topopts : EvalOpts) = do tm' <- eval env locs tm [] case tm' of NDelay fc r _ arg => - eval env (arg :: locs) (Local {name = UN (Basic "fvar")} fc Nothing _ First) stk - _ => pure (NForce fc r tm' stk) + eval env (locs :< arg) (Local {name = UN (Basic "fvar")} fc Nothing _ First) stk + _ => pure (NForce fc r tm' (cast stk)) eval env locs (PrimVal fc c) stk = pure $ NPrimVal fc c eval env locs (Erased fc a) stk = NErased fc <$> traverse @{%search} @{CORE} (\ t => eval env locs t stk) a @@ -171,16 +179,16 @@ parameters (defs : Defs) (topopts : EvalOpts) = pure (NBind fc x b (\defs', arg => applyToStack env !(sc defs' arg) stk)) applyToStack env (NApp fc (NRef nt fn) args) stk - = evalRef env False fc nt fn (args ++ stk) - (NApp fc (NRef nt fn) (args ++ stk)) + = evalRef env False fc nt fn (args <>> stk) + (NApp fc (NRef nt fn) (args <>< stk)) applyToStack env (NApp fc (NLocal mrig idx p) args) stk - = evalLocal env fc mrig _ p (args ++ stk) [] + = evalLocal env fc mrig _ p (args <>> stk) [<] applyToStack env (NApp fc (NMeta n i args) args') stk - = evalMeta env fc n i args (args' ++ stk) + = evalMeta env fc n i args (args' <>> stk) applyToStack env (NDCon fc n t a args) stk - = pure $ NDCon fc n t a (args ++ stk) + = pure $ NDCon fc n t a (args <>< stk) applyToStack env (NTCon fc n t a args) stk - = pure $ NTCon fc n t a (args ++ stk) + = pure $ NTCon fc n t a (args <>< stk) applyToStack env (NAs fc s p t) stk = if removeAs topopts then applyToStack env t stk @@ -196,8 +204,8 @@ parameters (defs : Defs) (topopts : EvalOpts) = do tm' <- applyToStack env tm [] case tm' of NDelay fc r _ arg => - eval env [arg] (Local {name = UN (Basic "fvar")} fc Nothing _ First) stk - _ => pure (NForce fc r tm' (args ++ stk)) + eval env [ pure (NForce fc r tm' (args <>< stk)) applyToStack env nf@(NPrimVal fc _) _ = pure nf applyToStack env (NErased fc a) stk = NErased fc <$> traverse @{%search} @{CORE} (\ t => applyToStack env t stk) a @@ -219,48 +227,47 @@ parameters (defs : Defs) (topopts : EvalOpts) {free : _} -> Env Term free -> FC -> Maybe Bool -> - (idx : Nat) -> (0 p : IsVar nm idx (vars ++ free)) -> + (idx : Nat) -> (0 p : IsVar nm idx (free ++ vars)) -> Stack free -> LocalEnv free vars -> Core (NF free) -- If it's one of the free variables, we are done unless the free -- variable maps to a let-binding - evalLocal env fc mrig idx prf stk [] + evalLocal env fc mrig idx prf stk [<] = if not (holesOnly topopts || argHolesOnly topopts) -- if we know it's not a let, no point in even running `getBinder` && fromMaybe True mrig then case getBinder prf env of - Let _ _ val _ => eval env [] val stk - _ => pure $ NApp fc (NLocal mrig idx prf) stk - else pure $ NApp fc (NLocal mrig idx prf) stk - evalLocal env fc mrig Z First stk (x :: locs) - = evalLocClosure env fc mrig stk x - evalLocal {vars = x :: xs} {free} - env fc mrig (S idx) (Later p) stk (_ :: locs) + Let _ _ val _ => eval env [<] val stk + _ => pure $ NApp fc (NLocal mrig idx prf) (cast stk) + else pure $ NApp fc (NLocal mrig idx prf) (cast stk) + evalLocal env fc mrig Z First stk (locs :< x) + = do log "eval.ref" 50 $ "evalLocal-2: " ++ show x + evalLocClosure env fc mrig stk x + evalLocal {vars = xs :< x} {free} + env fc mrig (S idx) (Later p) stk (locs :< _) = evalLocal {vars = xs} env fc mrig idx p stk locs updateLocal : EvalOpts -> Env Term free -> - (idx : Nat) -> (0 p : IsVar nm idx (vars ++ free)) -> + (idx : Nat) -> (0 p : IsVar nm idx (free ++ vars)) -> LocalEnv free vars -> NF free -> LocalEnv free vars - updateLocal opts env Z First (x :: locs) nf - = MkNFClosure opts env nf :: locs - updateLocal opts env (S idx) (Later p) (x :: locs) nf - = x :: updateLocal opts env idx p locs nf + updateLocal opts env Z First (locs :< x) nf + = locs :< MkNFClosure opts env nf + updateLocal opts env (S idx) (Later p) (locs :< x) nf + = updateLocal opts env idx p locs nf :< x updateLocal _ _ _ _ locs nf = locs evalMeta : {auto c : Ref Ctxt Defs} -> {free : _} -> Env Term free -> - FC -> Name -> Int -> List (Closure free) -> + FC -> Name -> Int -> SnocList (FC, Closure free) -> Stack free -> Core (NF free) evalMeta env fc nm i args stk - = let args' = if isNil stk then map (EmptyFC,) args - else map (EmptyFC,) args ++ stk - in + = let args' = args <>> stk in evalRef env True fc Func (Resolved i) args' - (NApp fc (NMeta nm i args) stk) + (NApp fc (NMeta nm i args) (cast stk)) -- The commented out logging here might still be useful one day, but -- evalRef is used a lot and even these tiny checks turn out to be @@ -274,11 +281,11 @@ parameters (defs : Defs) (topopts : EvalOpts) evalRef env meta fc (DataCon tag arity) fn stk def = do -- logC "eval.ref.data" 50 $ do fn' <- toFullNames fn -- Can't use ! here, it gets lifted too far -- pure $ "Found data constructor: " ++ show fn' - pure $ NDCon fc fn tag arity stk + pure $ NDCon fc fn tag arity (cast stk) evalRef env meta fc (TyCon tag arity) fn stk def = do -- logC "eval.ref.type" 50 $ do fn' <- toFullNames fn -- pure $ "Found type constructor: " ++ show fn' - pure $ ntCon fc fn tag arity stk + pure $ ntCon fc fn tag arity (cast stk) evalRef env meta fc Bound fn stk def = do -- logC "eval.ref.bound" 50 $ do fn' <- toFullNames fn -- pure $ "Found bound variable: " ++ show fn' @@ -309,20 +316,20 @@ parameters (defs : Defs) (topopts : EvalOpts) pure def -- name is past reduction limit nf <- evalDef env opts' meta fc (multiplicity res) (definition res) (flags res) stk def - -- logC "eval.ref" 50 $ do n' <- toFullNames n - -- nf <- toFullNames nf - -- pure "Reduced \{show n'} to \{show nf}" + logC "eval.ref" 50 $ do n' <- toFullNames n + nf <- toFullNames nf + pure "Reduced \{show n'} to \{show nf}" pure nf else pure def - getCaseBound : List (Closure free) -> - (args : List Name) -> + getCaseBound : SnocList (Closure free) -> + (args : SnocList Name) -> LocalEnv free more -> - Maybe (LocalEnv free (args ++ more)) - getCaseBound [] [] loc = Just loc - getCaseBound [] (_ :: _) loc = Nothing -- mismatched arg length - getCaseBound (arg :: args) [] loc = Nothing -- mismatched arg length - getCaseBound (arg :: args) (n :: ns) loc = (arg ::) <$> getCaseBound args ns loc + Maybe (LocalEnv free (more ++ args)) + getCaseBound [<] [<] loc = Just loc + getCaseBound [<] (_ :< _) loc = Nothing -- mismatched arg length + getCaseBound (args :< arg) [<] loc = Nothing -- mismatched arg length + getCaseBound (args :< arg) (ns :< n) loc = pure $ !(getCaseBound args ns loc) :< arg -- Returns the case term from the matched pattern with the LocalEnv (arguments from constructor pattern ConCase) evalConAlt : {auto c : Ref Ctxt Defs} -> @@ -331,13 +338,14 @@ parameters (defs : Defs) (topopts : EvalOpts) LocalEnv free more -> EvalOpts -> FC -> Stack free -> (args : List Name) -> - List (Closure free) -> - CaseTree (args ++ more) -> + SnocList (Closure free) -> + CaseTree (more <>< args) -> Core (CaseResult (TermWithEnv free)) evalConAlt env loc opts fc stk args args' sc - = do let Just bound = getCaseBound args' args loc + = do let Just bound = getCaseBound args' (cast args) loc | Nothing => pure GotStuck - evalTree env bound opts fc stk sc + evalTree env bound opts fc stk $ + rewrite sym $ fishAsSnocAppend more args in sc tryAlt : {auto c : Ref Ctxt Defs} -> {free, more : _} -> @@ -374,15 +382,14 @@ parameters (defs : Defs) (topopts : EvalOpts) tryAlt {more} env loc opts fc stk (NBind pfc x (Pi fc' r e aty) scty) (ConCase (UN (Basic "->")) tag [s,t] sc) = evalConAlt {more} env loc opts fc stk [s,t] - [aty, - MkNFClosure opts env (NBind pfc x (Lam fc' r e aty) scty)] + [ + argsFromStack : (args : SnocList Name) -> Stack free -> - Maybe (LocalEnv free args, Stack free) - argsFromStack [] stk = Just ([], stk) - argsFromStack (n :: ns) [] = Nothing - argsFromStack (n :: ns) (arg :: args) + Maybe (LocalEnv free (reverse args), Stack free) + argsFromStack [<] stk = Just ([<], stk) + argsFromStack (ns :< n) [] = Nothing + argsFromStack (ns :< n) (arg :: args) = do (loc', stk') <- argsFromStack ns args - pure (snd arg :: loc', stk') + pure (rewrite revOnto [ {arity, free : _} -> @@ -508,17 +515,21 @@ parameters (defs : Defs) (topopts : EvalOpts) || (meta && not (isErased rigd)) || (meta && holesOnly opts) || (tcInline opts && elem TCInline flags) - then case argsFromStack args stk of + then case argsFromStack (reverse args) stk of Nothing => do logC "eval.def.underapplied" 50 $ do def <- toFullNames def pure "Cannot reduce under-applied \{show def}" pure def Just (locs', stk') => - do (Result (MkTermEnv newLoc res)) <- evalTree env locs' opts fc stk' tree + do log "eval.def.stuck" 50 $ "pre-evalTree args: " ++ show (toList args) ++ ", stk: " ++ show stk' ++ ", tree: " ++ show tree + logDepth $ logLocalEnv "eval.def.stuck" 50 "pre-evalTree locs" locs' + (Result (MkTermEnv newLoc res)) <- evalTree env locs' opts fc stk' (rewrite reverseInvolutive args in tree) | _ => do logC "eval.def.stuck" 50 $ do def <- toFullNames def pure "evalTree failed on \{show def}" pure def + logTerm "eval.def.stuck" 50 "post-evalTree res" res + logDepth $ logLocalEnv "eval.def.stuck" 50 "post-evalTree locs" newLoc case fuel opts of Nothing => evalWithOpts defs opts env newLoc res stk' Just Z => log "eval.def.stuck" 50 "Recursion depth limit exceeded" @@ -526,15 +537,15 @@ parameters (defs : Defs) (topopts : EvalOpts) Just (S k) => do let opts' = { fuel := Just k } opts evalWithOpts defs opts' env newLoc res stk' - else do -- logC "eval.def.stuck" 50 $ do - -- def <- toFullNames def - -- pure $ unlines [ "Refusing to reduce \{show def}:" - -- , " holesOnly : \{show $ holesOnly opts}" - -- , " argHolesOnly: \{show $ argHolesOnly opts}" - -- , " tcInline : \{show $ tcInline opts}" - -- , " meta : \{show meta}" - -- , " rigd : \{show rigd}" - -- ] + else do logC "eval.def.stuck" 50 $ do + def <- toFullNames def + pure $ unlines [ "Refusing to reduce \{show def}:" + , " holesOnly : \{show $ holesOnly opts}" + , " argHolesOnly: \{show $ argHolesOnly opts}" + , " tcInline : \{show $ tcInline opts}" + , " meta : \{show meta}" + , " rigd : \{show rigd}" + ] pure def evalDef env opts meta fc rigd (Builtin op) flags stk def = evalOp (getOp op) stk def @@ -568,13 +579,20 @@ export nf : {auto c : Ref Ctxt Defs} -> {vars : _} -> Defs -> Env Term vars -> Term vars -> Core (NF vars) -nf defs env tm = eval defs defaultOpts env [] tm [] +nf defs env tm = logDepth $ eval defs defaultOpts env [<] tm [] export nfOpts : {auto c : Ref Ctxt Defs} -> {vars : _} -> EvalOpts -> Defs -> Env Term vars -> Term vars -> Core (NF vars) -nfOpts opts defs env tm = eval defs opts env [] tm [] +nfOpts opts defs env tm = logDepth $ eval defs opts env [<] tm [] + +export +nfLHS : {auto c : Ref Ctxt Defs} -> + {vars : _} -> + Defs -> Env Term vars -> Term vars -> Core (NF vars) +nfLHS defs env tm + = nfOpts onLHS defs env tm export gnf : {vars : _} -> diff --git a/src/Core/Normalise/Quote.idr b/src/Core/Normalise/Quote.idr index 798db02de5..c7159e1fdf 100644 --- a/src/Core/Normalise/Quote.idr +++ b/src/Core/Normalise/Quote.idr @@ -1,12 +1,16 @@ module Core.Normalise.Quote import Core.Context +import Core.Context.Log import Core.Core import Core.Env import Core.Normalise.Eval import Core.TT import Core.Value +import Data.SnocList +import Libraries.Data.SnocList.SizeOf + %default covering export @@ -24,13 +28,13 @@ record QuoteOpts where public export interface Quote tm where quote : {auto c : Ref Ctxt Defs} -> - {vars : List Name} -> + {vars : SnocList Name} -> Defs -> Env Term vars -> tm vars -> Core (Term vars) quoteLHS : {auto c : Ref Ctxt Defs} -> - {vars : List Name} -> + {vars : SnocList Name} -> Defs -> Env Term vars -> tm vars -> Core (Term vars) quoteOpts : {auto c : Ref Ctxt Defs} -> - {vars : List Name} -> + {vars : SnocList Name} -> QuoteOpts -> Defs -> Env Term vars -> tm vars -> Core (Term vars) quoteGen : {auto c : Ref Ctxt Defs} -> @@ -40,15 +44,15 @@ interface Quote tm where quote defs env tm = do q <- newRef QVar 0 - quoteGen q (MkQuoteOpts True False Nothing) defs env tm + logDepth $ quoteGen q (MkQuoteOpts True False Nothing) defs env tm quoteLHS defs env tm = do q <- newRef QVar 0 - quoteGen q (MkQuoteOpts True True Nothing) defs env tm + logDepth $ quoteGen q (MkQuoteOpts True True Nothing) defs env tm quoteOpts opts defs env tm = do q <- newRef QVar 0 - quoteGen q opts defs env tm + logDepth $ quoteGen q opts defs env tm export genName : {auto q : Ref QVar Int} -> String -> Core Name @@ -57,58 +61,71 @@ genName n put QVar (i + 1) pure (MN n i) +logEnv : {vars : _} -> + {auto c : Ref Ctxt Defs} -> + (s : String) -> + {auto 0 _ : KnownTopic s} -> + Nat -> String -> Env Term vars -> Core () + mutual quoteArg : {auto c : Ref Ctxt Defs} -> {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> Env Term free -> Closure free -> - Core (Term (bound ++ free)) + Core (Term (free ++ bound)) quoteArg q opts defs bounds env a - = quoteGenNF q opts defs bounds env !(evalClosure defs a) + = do log "eval.ref" 50 $ "quoteArg a: " ++ (show a) + a <- evalClosure defs a + log "eval.ref" 50 $ "quoteArg evalClosure a: " ++ (show a) + quoteGenNF q opts defs bounds env a quoteArgWithFC : {auto c : Ref Ctxt Defs} -> {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> Env Term free -> (FC, Closure free) -> - Core ((FC, Term (bound ++ free))) + Core ((FC, Term (free ++ bound))) quoteArgWithFC q opts defs bounds env = traversePair (quoteArg q opts defs bounds env) quoteArgs : {auto c : Ref Ctxt Defs} -> {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> - Env Term free -> List (Closure free) -> - Core (List (Term (bound ++ free))) - quoteArgs q opts defs bounds env = traverse (quoteArg q opts defs bounds env) + Env Term free -> SnocList (FC, Closure free) -> + Core (SnocList (FC, Term (free ++ bound))) + quoteArgs q opts defs bounds env spine = SnocList.traverse quoteArgSpine spine + where + quoteArgSpine : (FC, Closure free) -> Core (FC, Term (free ++ bound)) + quoteArgSpine (fc, c) = do + r <- quoteArg q opts defs bounds env c + pure (fc, r) quoteArgsWithFC : {auto c : Ref Ctxt Defs} -> {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> - Env Term free -> List (FC, Closure free) -> - Core (List (FC, Term (bound ++ free))) + Env Term free -> SnocList (FC, Closure free) -> + Core (SnocList (FC, Term (free ++ bound))) quoteArgsWithFC q opts defs bounds env - = traverse (quoteArgWithFC q opts defs bounds env) + -- [Note] Restore logging sequence + = map reverse . traverse (quoteArgWithFC q opts defs bounds env) . reverse quoteHead : {auto c : Ref Ctxt Defs} -> {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> FC -> Bounds bound -> Env Term free -> NHead free -> - Core (Term (bound ++ free)) + Core (Term (free ++ bound)) quoteHead {bound} q opts defs fc bounds env (NLocal mrig _ prf) - = let MkVar prf' = addLater bound prf in + = let MkVar prf' = weakenNs (mkSizeOf bound) (MkVar prf) in pure $ Local fc mrig _ prf' - where - addLater : {idx : _} -> - (ys : List Name) -> (0 p : IsVar n idx xs) -> - Var (ys ++ xs) - addLater [] isv = MkVar isv - addLater (x :: xs) isv - = let MkVar isv' = addLater xs isv in - MkVar (Later isv') - quoteHead q opts defs fc bounds env (NRef Bound (MN n i)) - = pure $ case findName bounds of - Just (MkVar p) => Local fc Nothing _ (embedIsVar p) - Nothing => Ref fc Bound (MN n i) + quoteHead {bound} {free} q opts defs fc bounds env t@(NRef Bound (MN n i)) + = do + -- TODO: Sometimes `free` has right order, sometimes back order. + -- Back order for calls `LOG totality.termination.sizechange:5: Calculating Size Change` and `LOG elab:10: checkApp-IVar nty_in N` + -- Equal order for calls `LOG compile.casetree:25: addConG nextNames` + log "eval.ref" 50 $ "quoteHead-2 bound: " ++ show (asList bound) ++ ", free: " ++ show (asList free) ++ ", t: " ++ show t ++ ", bounds: " ++ show bounds + case findName bounds of + Just (MkVar p) => do log "eval.ref" 50 $ "quoteHead-2 findName MkVar(p): " ++ show (MkVar p) + pure $ Local fc Nothing _ (embedIsVar p) + Nothing => pure $ Ref fc Bound (MN n i) where findName : Bounds bound' -> Maybe (Var bound') findName None = Nothing @@ -123,14 +140,16 @@ mutual Just (MkVar (Later p)) quoteHead q opts defs fc bounds env (NRef nt n) = pure $ Ref fc nt n quoteHead q opts defs fc bounds env (NMeta n i args) - = do args' <- quoteArgs q opts defs bounds env args - pure $ Meta fc n i args' + -- [Note] Restore logging sequence + = do args' <- quoteArgs q opts defs bounds env (reverse args) + -- See [Note] Meta args + pure $ Meta fc n i (toList . map snd . reverse $ args') quotePi : {auto c : Ref Ctxt Defs} -> {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> Env Term free -> PiInfo (Closure free) -> - Core (PiInfo (Term (bound ++ free))) + Core (PiInfo (Term (free ++ bound))) quotePi q opts defs bounds env Explicit = pure Explicit quotePi q opts defs bounds env Implicit = pure Implicit quotePi q opts defs bounds env AutoImplicit = pure AutoImplicit @@ -142,7 +161,7 @@ mutual {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> Env Term free -> Binder (Closure free) -> - Core (Binder (Term (bound ++ free))) + Core (Binder (Term (free ++ bound))) quoteBinder q opts defs bounds env (Lam fc r p ty) = do ty' <- quoteGenNF q opts defs bounds env !(evalClosure defs ty) p' <- quotePi q opts defs bounds env p @@ -171,15 +190,22 @@ mutual {bound, vars : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> - Env Term vars -> NF vars -> Core (Term (bound ++ vars)) + Env Term vars -> NF vars -> Core (Term (vars ++ bound)) quoteGenNF q opts defs bound env (NBind fc n b sc) = do var <- genName "qv" - sc' <- quoteGenNF q opts defs (Add n var bound) env - !(sc defs (toClosure defaultOpts env (Ref fc Bound var))) + -- logEnv "eval.ref" 50 "NBind env" env + log "eval.ref" 50 $ "NBind n: " ++ show !(toFullNames n) + sc' <- sc defs (toClosure defaultOpts env (Ref fc Bound var)) + log "eval.ref" 50 $ "NBind scQ: " ++ show !(toFullNames sc') + sc'' <- quoteGenNF q opts defs (Add n var bound) env sc' + logTerm "eval.ref" 50 "NBind scQQ" sc'' b' <- quoteBinder q opts defs bound env b - pure (Bind fc n b' sc') + pure (Bind fc n b' sc'') quoteGenNF q opts defs bound env (NApp fc f args) - = do f' <- quoteHead q opts defs fc bound env f + = do logC "eval.ref" 50 $ do f' <- toFullNames f + pure "NApp \{show f'} \{show $ toList args}" + f' <- quoteHead q opts defs fc bound env f + logTerm "eval.ref" 50 "fQ" f' opts' <- case sizeLimit opts of Nothing => pure opts Just Z => throw (InternalError "Size limit exceeded") @@ -189,17 +215,18 @@ mutual quoteArgsWithFC q opts' empty bound env args else quoteArgsWithFC q ({ topLevel := False } opts') defs bound env args - pure $ applyStackWithFC f' args' + logC "eval.ref" 50 $ do pure "NApp args: \{show $ toList $ args'}" + pure $ applySpineWithFC f' args' where isRef : NHead vars -> Bool isRef (NRef{}) = True isRef _ = False quoteGenNF q opts defs bound env (NDCon fc n t ar args) = do args' <- quoteArgsWithFC q opts defs bound env args - pure $ applyStackWithFC (Ref fc (DataCon t ar) n) args' + pure $ applySpineWithFC (Ref fc (DataCon t ar) n) args' quoteGenNF q opts defs bound env (NTCon fc n t ar args) = do args' <- quoteArgsWithFC q opts defs bound env args - pure $ applyStackWithFC (Ref fc (TyCon t ar) n) args' + pure $ applySpineWithFC (Ref fc (TyCon t ar) n) args' quoteGenNF q opts defs bound env (NAs fc s n pat) = do n' <- quoteGenNF q opts defs bound env n pat' <- quoteGenNF q opts defs bound env pat @@ -225,9 +252,9 @@ mutual case arg of NDelay fc _ _ arg => do argNF <- evalClosure defs arg - pure $ applyStackWithFC !(quoteGenNF q opts defs bound env argNF) args' + pure $ applySpineWithFC !(quoteGenNF q opts defs bound env argNF) args' _ => do arg' <- quoteGenNF q opts defs bound env arg - pure $ applyStackWithFC (TForce fc r arg') args' + pure $ applySpineWithFC (TForce fc r arg') args' quoteGenNF q opts defs bound env (NPrimVal fc c) = pure $ PrimVal fc c quoteGenNF q opts defs bound env (NErased fc t) = Erased fc <$> traverse @{%search} @{CORE} (\ nf => quoteGenNF q opts defs bound env nf) t @@ -245,10 +272,40 @@ export Quote Closure where quoteGen q opts defs env c = quoteGen q opts defs env !(evalClosure defs c) +logTermNF' : {vars : _} -> + {auto c : Ref Ctxt Defs} -> + (s : String) -> + {auto 0 _ : KnownTopic s} -> + Nat -> Lazy String -> Env Term vars -> Term vars -> Core () +logTermNF' str n msg env tm + = do tm' <- toFullNames tm + depth <- getDepth + logString depth str n (msg ++ ": " ++ show tm') + +logEnv str n msg env + = when !(logging str n) $ + do depth <- getDepth + logString depth str n msg + dumpEnv env + + where + + dumpEnv : {vs : SnocList Name} -> Env Term vs -> Core () + dumpEnv [<] = pure () + dumpEnv {vs = _ :< x} (bs :< Let _ c val ty) + = do logTermNF' str n (msg ++ ": let " ++ show x) bs val + logTermNF' str n (msg ++ ":" ++ show c ++ " " ++ show x) bs ty + dumpEnv bs + dumpEnv {vs = _ :< x} (bs :< b) + = do logTermNF' str n (msg ++ ":" ++ show (multiplicity b) ++ " " ++ + show (piInfo b) ++ " " ++ + show x) bs (binderType b) + dumpEnv bs + quoteWithPiGen : {auto _ : Ref Ctxt Defs} -> {bound, vars : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> - Env Term vars -> NF vars -> Core (Term (bound ++ vars)) + Env Term vars -> NF vars -> Core (Term (vars ++ bound)) quoteWithPiGen q opts defs bound env (NBind fc n (Pi bfc c p ty) sc) = do var <- genName "qv" empty <- clearDefs defs @@ -267,8 +324,9 @@ quoteWithPiGen q opts defs bound env tm -- are, don't reduce anything else export quoteWithPi : {auto c : Ref Ctxt Defs} -> - {vars : List Name} -> + {vars : SnocList Name} -> Defs -> Env Term vars -> NF vars -> Core (Term vars) quoteWithPi defs env tm = do q <- newRef QVar 0 + -- do q <- newRef QVar 100 in Yaffle quoteWithPiGen q (MkQuoteOpts True False Nothing) defs None env tm diff --git a/src/Core/Options.idr b/src/Core/Options.idr index 542642ba63..27a884f4dd 100644 --- a/src/Core/Options.idr +++ b/src/Core/Options.idr @@ -154,6 +154,7 @@ record Session where -- any logging is enabled. logLevel : LogLevels logTimings : Maybe Nat -- log level, higher means more details + logDepth : Nat -- depth level of logging to separate related stuff visually debugElabCheck : Bool -- do conversion check to verify results of elaborator dumpcases : Maybe String -- file to output compiled case trees dumplifted : Maybe String -- file to output lambda lifted definitions @@ -227,7 +228,7 @@ defaultPPrint = MkPPOpts False False True False export defaultSession : Session defaultSession = MkSessionOpts False CoveringOnly False False Chez [] 1000 False False - defaultLogLevel Nothing False Nothing Nothing + defaultLogLevel Nothing 0 False Nothing Nothing Nothing Nothing False 1 False False True False [] False False diff --git a/src/Core/Options/Log.idr b/src/Core/Options/Log.idr index 21cd4d8d11..24c54cd9ef 100644 --- a/src/Core/Options/Log.idr +++ b/src/Core/Options/Log.idr @@ -53,6 +53,8 @@ knownTopics = [ ("compile.casetree.missing", Just "Log when we add an error case for uncovered branches."), ("compile.casetree.partition", Nothing), ("compile.casetree.pick", Nothing), + ("compile.casetree.subst", Nothing), + ("compile.casetree.updateVar", Nothing), ("compiler.const-fold", Just "Log definitions before and after constant folding."), ("compiler.cse", Just "Log information about common sub-expression elimination."), ("compiler.identity", Just "Log definitions that are equivalent to identity at runtime."), diff --git a/src/Core/Ord.idr b/src/Core/Ord.idr index e3476cff49..cd94bd7301 100644 --- a/src/Core/Ord.idr +++ b/src/Core/Ord.idr @@ -5,6 +5,7 @@ import Core.CompileExpr import Core.Name import Core.TT import Data.Vect +import Data.SnocList import Libraries.Data.Ordering.Extra @@ -47,7 +48,7 @@ mutual export covering Eq (CConAlt vars) where - MkConAlt n1 _ t1 a1 e1 == MkConAlt n2 _ t2 a2 e2 = t1 == t2 && n1 == n2 && case namesEq a1 a2 of + MkConAlt n1 _ t1 a1 e1 == MkConAlt n2 _ t2 a2 e2 = t1 == t2 && n1 == n2 && case localEq a1 a2 of Just Refl => e1 == e2 Nothing => False @@ -104,7 +105,7 @@ mutual covering Ord (CConAlt vars) where MkConAlt n1 _ t1 a1 e1 `compare` MkConAlt n2 _ t2 a2 e2 = - compare t1 t2 `thenCmp` compare n1 n2 `thenCmp` case namesEq a1 a2 of + compare t1 t2 `thenCmp` compare n1 n2 `thenCmp` case localEq a1 a2 of Just Refl => compare e1 e2 Nothing => compare a1 a2 diff --git a/src/Core/Primitives.idr b/src/Core/Primitives.idr index fedb4120db..62ac746db0 100644 --- a/src/Core/Primitives.idr +++ b/src/Core/Primitives.idr @@ -6,6 +6,7 @@ import Core.Value import Libraries.Utils.String import Data.Vect +import Data.SnocList %default covering @@ -532,7 +533,7 @@ doubleTy : ClosedTerm doubleTy = predTy DoubleType DoubleType pi : (x : String) -> RigCount -> PiInfo (Term xs) -> Term xs -> - Term (UN (Basic x) :: xs) -> Term xs + Term (xs :< UN (Basic x)) -> Term xs pi x rig plic ty sc = Bind emptyFC (UN (Basic x)) (Pi emptyFC rig plic ty) sc believeMeTy : ClosedTerm @@ -566,7 +567,7 @@ castTo WorldType = const Nothing export getOp : {0 arity : Nat} -> PrimFn arity -> - {vars : List Name} -> Vect arity (NF vars) -> Maybe (NF vars) + {vars : SnocList Name} -> Vect arity (NF vars) -> Maybe (NF vars) getOp (Add ty) = binOp add getOp (Sub ty) = binOp sub getOp (Mul ty) = binOp mul diff --git a/src/Core/Reflect.idr b/src/Core/Reflect.idr index fa67cdf5aa..b6922c15aa 100644 --- a/src/Core/Reflect.idr +++ b/src/Core/Reflect.idr @@ -1,6 +1,7 @@ module Core.Reflect import Data.List1 +import Data.SnocList import Core.Context import Core.Env @@ -225,7 +226,7 @@ Reify Nat where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "Z"), _) => pure Z - (UN (Basic "S"), [(_, k)]) + (UN (Basic "S"), [<(_, k)]) => do k' <- reify defs !(evalClosure defs k) pure (S k') _ => cantReify val "Nat" @@ -243,7 +244,7 @@ Reify a => Reify (List a) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "Nil"), _) => pure [] - (UN (Basic "::"), [_, (_, x), (_, xs)]) + (UN (Basic "::"), [<_, (_, x), (_, xs)]) => do x' <- reify defs !(evalClosure defs x) xs' <- reify defs !(evalClosure defs xs) pure (x' :: xs') @@ -260,7 +261,7 @@ Reflect a => Reflect (List a) where export Reify a => Reify (List1 a) where - reify defs val@(NDCon _ n _ _ [_, (_, x), (_, xs)]) + reify defs val@(NDCon _ n _ _ [<_, (_, x), (_, xs)]) = case dropAllNS !(full (gamma defs) n) of UN (Basic ":::") => do x' <- reify defs !(evalClosure defs x) @@ -282,7 +283,7 @@ Reify a => Reify (SnocList a) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "Lin"), _) => pure [<] - (UN (Basic ":<"), [_, (_, sx), (_, x)]) + (UN (Basic ":<"), [<_, (_, sx), (_, x)]) => do sx' <- reify defs !(evalClosure defs sx) x' <- reify defs !(evalClosure defs x) pure (sx' :< x') @@ -302,7 +303,7 @@ Reify a => Reify (Maybe a) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "Nothing"), _) => pure Nothing - (UN (Basic "Just"), [_, (_, x)]) + (UN (Basic "Just"), [<_, (_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (Just x') _ => cantReify val "Maybe" @@ -321,7 +322,7 @@ Reify a => Reify (WithDefault a def) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "DefaultedValue"), _) => pure defaulted - (UN (Basic "SpecifiedValue"), [_, _, (_, x)]) + (UN (Basic "SpecifiedValue"), [<_, _, (_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (specified x') _ => cantReify val "WithDefault" @@ -338,7 +339,7 @@ Reflect a => Reflect (WithDefault a def) where export (Reify a, Reify b) => Reify (a, b) where - reify defs val@(NDCon _ n _ _ [_, _, (_, x), (_, y)]) + reify defs val@(NDCon _ n _ _ [<_, _, (_, x), (_, y)]) = case dropAllNS !(full (gamma defs) n) of UN (Basic "MkPair") => do x' <- reify defs !(evalClosure defs x) @@ -356,7 +357,7 @@ export export Reify Namespace where - reify defs val@(NDCon _ n _ _ [(_, ns)]) + reify defs val@(NDCon _ n _ _ [<(_, ns)]) = case dropAllNS !(full (gamma defs) n) of UN (Basic "MkNS") => do ns' <- reify defs !(evalClosure defs ns) @@ -372,7 +373,7 @@ Reflect Namespace where export Reify ModuleIdent where - reify defs val@(NDCon _ n _ _ [(_, ns)]) + reify defs val@(NDCon _ n _ _ [<(_, ns)]) = case dropAllNS !(full (gamma defs) n) of UN (Basic "MkMI") => do ns' <- reify defs !(evalClosure defs ns) @@ -390,13 +391,13 @@ export Reify UserName where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "Basic"), [(_, str)]) + (UN (Basic "Basic"), [<(_, str)]) => do str' <- reify defs !(evalClosure defs str) pure (Basic str') - (UN (Basic "Field"), [(_, str)]) + (UN (Basic "Field"), [<(_, str)]) => do str' <- reify defs !(evalClosure defs str) pure (Field str') - (UN (Basic "Underscore"), []) + (UN (Basic "Underscore"), [<]) => pure Underscore (NS _ (UN _), _) => cantReify val "Name, reifying it is unimplemented or intentionally internal" @@ -418,30 +419,30 @@ export Reify Name where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "UN"), [(_, str)]) + (UN (Basic "UN"), [<(_, str)]) => do str' <- reify defs !(evalClosure defs str) pure (UN str') - (UN (Basic "MN"), [(_, str), (_, i)]) + (UN (Basic "MN"), [<(_, str), (_, i)]) => do str' <- reify defs !(evalClosure defs str) i' <- reify defs !(evalClosure defs i) pure (MN str' i') - (UN (Basic "NS"), [(_, ns), (_, n)]) + (UN (Basic "NS"), [<(_, ns), (_, n)]) => do ns' <- reify defs !(evalClosure defs ns) n' <- reify defs !(evalClosure defs n) pure (NS ns' n') - (UN (Basic "DN"), [(_, str), (_, n)]) + (UN (Basic "DN"), [<(_, str), (_, n)]) => do str' <- reify defs !(evalClosure defs str) n' <- reify defs !(evalClosure defs n) pure (DN str' n') - (UN (Basic "Nested"), [(_, ix), (_, n)]) + (UN (Basic "Nested"), [<(_, ix), (_, n)]) => do ix' <- reify defs !(evalClosure defs ix) n' <- reify defs !(evalClosure defs n) pure (Nested ix' n') - (UN (Basic "CaseBlock"), [(_, outer), (_, i)]) + (UN (Basic "CaseBlock"), [<(_, outer), (_, i)]) => do outer' <- reify defs !(evalClosure defs outer) i' <- reify defs !(evalClosure defs i) pure (CaseBlock outer' i') - (UN (Basic "WithBlock"), [(_, outer), (_, i)]) + (UN (Basic "WithBlock"), [<(_, outer), (_, i)]) => do outer' <- reify defs !(evalClosure defs outer) i' <- reify defs !(evalClosure defs i) pure (WithBlock outer' i') @@ -493,11 +494,11 @@ Reify NameType where = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "Bound"), _) => pure Bound (UN (Basic "Func"), _) => pure Func - (UN (Basic "DataCon"), [(_, t), (_, i)]) + (UN (Basic "DataCon"), [<(_, t), (_, i)]) => do t' <- reify defs !(evalClosure defs t) i' <- reify defs !(evalClosure defs i) pure (DataCon t' i') - (UN (Basic "TyCon"), [(_, t),(_, i)]) + (UN (Basic "TyCon"), [<(_, t),(_, i)]) => do t' <- reify defs !(evalClosure defs t) i' <- reify defs !(evalClosure defs i) pure (TyCon t' i') @@ -521,33 +522,33 @@ export Reify PrimType where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "IntType"), []) + (UN (Basic "IntType"), [<]) => pure IntType - (UN (Basic "Int8Type"), []) + (UN (Basic "Int8Type"), [<]) => pure Int8Type - (UN (Basic "Int16Type"), []) + (UN (Basic "Int16Type"), [<]) => pure Int16Type - (UN (Basic "Int32Type"), []) + (UN (Basic "Int32Type"), [<]) => pure Int32Type - (UN (Basic "Int64Type"), []) + (UN (Basic "Int64Type"), [<]) => pure Int64Type - (UN (Basic "IntegerType"), []) + (UN (Basic "IntegerType"), [<]) => pure IntegerType - (UN (Basic "Bits8Type"), []) + (UN (Basic "Bits8Type"), [<]) => pure Bits8Type - (UN (Basic "Bits16Type"), []) + (UN (Basic "Bits16Type"), [<]) => pure Bits16Type - (UN (Basic "Bits32Type"), []) + (UN (Basic "Bits32Type"), [<]) => pure Bits32Type - (UN (Basic "Bits64Type"), []) + (UN (Basic "Bits64Type"), [<]) => pure Bits64Type - (UN (Basic "StringType"), []) + (UN (Basic "StringType"), [<]) => pure StringType - (UN (Basic "CharType"), []) + (UN (Basic "CharType"), [<]) => pure CharType - (UN (Basic "DoubleType"), []) + (UN (Basic "DoubleType"), [<]) => pure DoubleType - (UN (Basic "WorldType"), []) + (UN (Basic "WorldType"), [<]) => pure WorldType _ => cantReify val "PrimType" reify defs val = cantReify val "PrimType" @@ -556,49 +557,49 @@ export Reify Constant where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "I"), [(_, x)]) + (UN (Basic "I"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (I x') - (UN (Basic "I8"), [(_, x)]) + (UN (Basic "I8"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (I8 x') - (UN (Basic "I16"), [(_, x)]) + (UN (Basic "I16"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (I16 x') - (UN (Basic "I32"), [(_, x)]) + (UN (Basic "I32"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (I32 x') - (UN (Basic "I64"), [(_, x)]) + (UN (Basic "I64"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (I64 x') - (UN (Basic "BI"), [(_, x)]) + (UN (Basic "BI"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (BI x') - (UN (Basic "B8"), [(_, x)]) + (UN (Basic "B8"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (B8 x') - (UN (Basic "B16"), [(_, x)]) + (UN (Basic "B16"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (B16 x') - (UN (Basic "B32"), [(_, x)]) + (UN (Basic "B32"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (B32 x') - (UN (Basic "B64"), [(_, x)]) + (UN (Basic "B64"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (B64 x') - (UN (Basic "Str"), [(_, x)]) + (UN (Basic "Str"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (Str x') - (UN (Basic "Ch"), [(_, x)]) + (UN (Basic "Ch"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (Ch x') - (UN (Basic "Db"), [(_, x)]) + (UN (Basic "Db"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (Db x') - (UN (Basic "PrT"), [(_, x)]) + (UN (Basic "PrT"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (PrT x') - (UN (Basic "WorldVal"), []) + (UN (Basic "WorldVal"), [<]) => pure WorldVal _ => cantReify val "Constant" reify defs val = cantReify val "Constant" @@ -738,7 +739,7 @@ Reify t => Reify (PiInfo t) where (UN (Basic "ImplicitArg"), _) => pure Implicit (UN (Basic "ExplicitArg"), _) => pure Explicit (UN (Basic "AutoImplicit"), _) => pure AutoImplicit - (UN (Basic "DefImplicit"), [_, (_, t)]) + (UN (Basic "DefImplicit"), [<_, (_, t)]) => do t' <- reify defs !(evalClosure defs t) pure (DefImplicit t') _ => cantReify val "PiInfo" @@ -776,7 +777,7 @@ export Reify VirtualIdent where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "Interactive"), []) + (UN (Basic "Interactive"), [<]) => pure Interactive _ => cantReify val "VirtualIdent" reify defs val = cantReify val "VirtualIdent" @@ -794,11 +795,11 @@ export Reify BuiltinType where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "BuiltinNatural"), []) + (UN (Basic "BuiltinNatural"), [<]) => pure BuiltinNatural - (UN (Basic "NaturalToInteger"), []) + (UN (Basic "NaturalToInteger"), [<]) => pure NaturalToInteger - (UN (Basic "IntegerToNatural"), []) + (UN (Basic "IntegerToNatural"), [<]) => pure IntegerToNatural _ => cantReify val "BuiltinType" reify defs val = cantReify val "BuiltinType" @@ -812,13 +813,13 @@ export Reify OriginDesc where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "PhysicalIdrSrc"), [(_, ident)]) + (UN (Basic "PhysicalIdrSrc"), [<(_, ident)]) => do ident' <- reify defs !(evalClosure defs ident) pure (PhysicalIdrSrc ident') - (UN (Basic "PhysicalPkgSrc"), [(_, fname)]) + (UN (Basic "PhysicalPkgSrc"), [<(_, fname)]) => do fname' <- reify defs !(evalClosure defs fname) pure (PhysicalPkgSrc fname') - (UN (Basic "Virtual"), [(_, ident)]) + (UN (Basic "Virtual"), [<(_, ident)]) => do ident' <- reify defs !(evalClosure defs ident) pure (Virtual ident') _ => cantReify val "OriginDesc" @@ -840,7 +841,7 @@ export Reify FC where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "MkFC"), [(_, fn), (_, start), (_, end)]) + (UN (Basic "MkFC"), [<(_, fn), (_, start), (_, end)]) => do fn' <- reify defs !(evalClosure defs fn) start' <- reify defs !(evalClosure defs start) end' <- reify defs !(evalClosure defs end) @@ -868,11 +869,11 @@ export Reify a => Reify (WithFC a) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "MkFCVal"), [fcterm, nestedVal]) => do + (UN (Basic "MkFCVal"), [ do fc <- reify defs !(evalClosure defs fcterm) val <- reify defs !(evalClosure defs nestedVal) pure $ MkFCVal fc val - (UN (Basic "MkFCVal"), [_, fc, l2]) => do + (UN (Basic "MkFCVal"), [<_, fc, l2]) => do fc' <- reify defs !(evalClosure defs fc) val' <- reify defs !(evalClosure defs l2) pure $ MkFCVal fc' val' diff --git a/src/Core/SchemeEval/Compile.idr b/src/Core/SchemeEval/Compile.idr index 2f98457acd..a90e752c61 100644 --- a/src/Core/SchemeEval/Compile.idr +++ b/src/Core/SchemeEval/Compile.idr @@ -20,6 +20,7 @@ import Core.SchemeEval.ToScheme import Core.TT import Data.List +import Data.SnocList import Libraries.Utils.Scheme import System.Info @@ -78,22 +79,22 @@ getName (Bound x) = x getName (Free x) = x public export -data SchVars : List Name -> Type where - Nil : SchVars [] - (::) : SVar -> SchVars ns -> SchVars (n :: ns) +data SchVars : Scoped where + Lin : SchVars [<] + (:<) : SchVars ns -> SVar -> SchVars (ns :< n) Show (SchVars ns) where - show xs = show (toList xs) + show xs = show (toSnocList xs <>> []) where - toList : forall ns . SchVars ns -> List String - toList [] = [] - toList (Bound x :: xs) = x :: toList xs - toList (Free x :: xs) = "'x" :: toList xs + toSnocList : forall ns . SchVars ns -> SnocList String + toSnocList [<] = [<] + toSnocList (xs :< Bound x) = toSnocList xs :< x + toSnocList (xs :< Free x) = toSnocList xs :< "'x" getSchVar : {idx : _} -> (0 _ : IsVar n idx vars) -> SchVars vars -> String -getSchVar First (Bound x :: xs) = x -getSchVar First (Free x :: xs) = "'" ++ x -getSchVar (Later p) (x :: xs) = getSchVar p xs +getSchVar First (xs :< Bound x) = x +getSchVar First (xs :< Free x) = "'" ++ x +getSchVar (Later p) (xs :< x) = getSchVar p xs {- @@ -219,13 +220,13 @@ compileStk svs stk (Bind fc x (Let _ _ val _) scope) = do i <- nextName let x' = schVarName x ++ "-" ++ show i val' <- compileStk svs [] val - sc' <- compileStk (Bound x' :: svs) [] scope + sc' <- compileStk (svs :< Bound x') [] scope pure $ unload (Let x' val' sc') stk compileStk svs stk (Bind fc x (Pi _ rig p ty) scope) = do i <- nextName let x' = schVarName x ++ "-" ++ show i ty' <- compileStk svs [] ty - sc' <- compileStk (Bound x' :: svs) [] scope + sc' <- compileStk (svs :< Bound x') [] scope p' <- compilePiInfo svs p pure $ Vector (-3) [Lambda [x'] sc', toScheme rig, toSchemePi p', ty', toScheme x] @@ -233,7 +234,7 @@ compileStk svs stk (Bind fc x (PVar _ rig p ty) scope) = do i <- nextName let x' = schVarName x ++ "-" ++ show i ty' <- compileStk svs [] ty - sc' <- compileStk (Bound x' :: svs) [] scope + sc' <- compileStk (svs :< Bound x') [] scope p' <- compilePiInfo svs p pure $ Vector (-12) [Lambda [x'] sc', toScheme rig, toSchemePi p', ty', toScheme x] @@ -241,27 +242,27 @@ compileStk svs stk (Bind fc x (PVTy _ rig ty) scope) = do i <- nextName let x' = schVarName x ++ "-" ++ show i ty' <- compileStk svs [] ty - sc' <- compileStk (Bound x' :: svs) [] scope + sc' <- compileStk (svs :< Bound x') [] scope pure $ Vector (-13) [Lambda [x'] sc', toScheme rig, ty', toScheme x] compileStk svs stk (Bind fc x (PLet _ rig val ty) scope) -- we only see this on LHS = do i <- nextName let x' = schVarName x ++ "-" ++ show i val' <- compileStk svs [] val ty' <- compileStk svs [] ty - sc' <- compileStk (Bound x' :: svs) [] scope + sc' <- compileStk (svs :< Bound x') [] scope pure $ Vector (-14) [Lambda [x'] sc', toScheme rig, val', ty', toScheme x] compileStk svs [] (Bind fc x (Lam _ rig p ty) scope) = do i <- nextName let x' = schVarName x ++ "-" ++ show i ty' <- compileStk svs [] ty - sc' <- compileStk (Bound x' :: svs) [] scope + sc' <- compileStk (svs :< Bound x') [] scope p' <- compilePiInfo svs p pure $ Vector (-8) [Lambda [x'] sc', toScheme rig, toSchemePi p', ty', toScheme x] compileStk svs (s :: stk) (Bind fc x (Lam _ _ _ _) scope) = do i <- nextName let x' = schVarName x ++ "-" ++ show i - sc' <- compileStk (Bound x' :: svs) stk scope + sc' <- compileStk (svs :< Bound x') stk scope pure $ Apply (Lambda [x'] sc') [s] compileStk svs stk (App fc fn arg) = compileStk svs (!(compileStk svs [] arg) :: stk) fn @@ -301,12 +302,11 @@ getArgName extend : Ref Sym Integer => (args : List Name) -> SchVars vars -> - Core (List Name, SchVars (args ++ vars)) + Core (List Name, SchVars (vars <>< args)) extend [] svs = pure ([], svs) extend (arg :: args) svs = do n <- getArgName - (args', svs') <- extend args svs - pure (n :: args', Bound (schVarName n) :: svs') + extend args (svs :< Bound (schVarName n)) compileCase : Ref Sym Integer => {auto c : Ref Ctxt Defs} -> @@ -361,7 +361,7 @@ compileCase blk svs (Case idx p scTy xs) (Apply (Var "vector-ref") [Var var, IntegerVal (cast i)]) (project (i + 1) var ns body) - bindArgs : String -> (args : List Name) -> CaseTree (args ++ vars) -> + bindArgs : String -> (args : List Name) -> CaseTree (vars <>< args) -> Core (SchemeObj Write) bindArgs var args sc = do (bind, svs') <- extend args svs @@ -396,7 +396,7 @@ compileCase blk svs (Case idx p scTy xs) (Apply (Var "vector-ref") [Var var, IntegerVal (cast i)]) (project (i + 1) var ns body) - bindArgs : String -> (args : List Name) -> CaseTree (args ++ vars) -> + bindArgs : String -> (args : List Name) -> CaseTree (vars <>< args) -> Core (SchemeObj Write) bindArgs var args sc = do (bind, svs') <- extend args svs @@ -420,8 +420,9 @@ compileCase blk svs (Case idx p scTy xs) addPiMatch var (ConCase (UN (Basic "->")) _ [s, t] sc :: _) def = do sn <- getArgName tn <- getArgName - let svs' = Bound (schVarName sn) :: - Bound (schVarName tn) :: svs + let svs' = svs + :< Bound (schVarName tn) + :< Bound (schVarName sn) sc' <- compileCase blk svs' sc pure $ If (Apply (Var "ct-isPi") [Var var]) (Let (schVarName sn) (Apply (Var "vector-ref") [Var var, IntegerVal 4]) $ @@ -457,8 +458,9 @@ compileCase blk svs (Case idx p scTy xs) = do let var = getSchVar p svs tyn <- getArgName argn <- getArgName - let svs' = Bound (schVarName tyn) :: - Bound (schVarName argn) :: svs + let svs' = svs + :< Bound (schVarName tyn) + :< Bound (schVarName argn) sc' <- compileCase blk svs' sc pure $ If (Apply (Var "ct-isDelay") [Var var]) (Let (schVarName tyn) @@ -474,20 +476,19 @@ compileCase blk vars (STerm _ tm) = compile vars tm compileCase blk vars _ = pure blk varObjs : SchVars ns -> List (SchemeObj Write) -varObjs [] = [] -varObjs (x :: xs) = Var (show x) :: varObjs xs +varObjs [<] = [] +varObjs (xs :< x) = Var (show x) :: varObjs xs -mkArgs : (ns : List Name) -> Core (SchVars ns) -mkArgs [] = pure [] -mkArgs (x :: xs) - = pure $ Bound (schVarName x) :: !(mkArgs xs) +mkArgs : (ns : Scope) -> SchVars ns +mkArgs [<] = [<] +mkArgs (xs :< x) = mkArgs xs :< Bound (schVarName x) bindArgs : Name -> (todo : SchVars ns) -> (done : List (SchemeObj Write)) -> SchemeObj Write -> SchemeObj Write -bindArgs n [] done body = body -bindArgs n (x :: xs) done body +bindArgs n [<] done body = body +bindArgs n (xs :< x) done body = Vector (-9) [blockedAppWith n (reverse done), Lambda [show x] (bindArgs n xs (Var (show x) :: done) body)] @@ -498,7 +499,7 @@ compileBody : {auto c : Ref Ctxt Defs} -> compileBody _ n None = pure $ blockedAppWith n [] compileBody redok n (PMDef pminfo args treeCT treeRT pats) = do i <- newRef Sym 0 - argvs <- mkArgs args + let argvs = mkArgs args let blk = blockedAppWith n (varObjs argvs) body <- compileCase blk argvs treeCT let body' = if redok @@ -516,33 +517,33 @@ compileBody _ n (DCon tag Z newtypeArg) = pure $ Vector (cast tag) [toScheme !(toResolvedNames n), toScheme emptyFC] compileBody _ n (DCon tag arity newtypeArg) = do let args = mkArgNs 0 arity - argvs <- mkArgs args + let argvs = mkArgs args let body = Vector (cast tag) (toScheme n :: toScheme emptyFC :: - map (Var . schVarName) args) + map (Var . schVarName) (toList args)) pure (bindArgs n argvs [] body) where - mkArgNs : Int -> Nat -> List Name - mkArgNs i Z = [] - mkArgNs i (S k) = MN "arg" i :: mkArgNs (i+1) k + mkArgNs : Int -> Nat -> SnocList Name + mkArgNs i Z = [<] + mkArgNs i (S k) = mkArgNs (i+1) k :< MN "arg" i compileBody _ n (TCon tag Z parampos detpos flags mutwith datacons detagabbleBy) = pure $ Vector (-1) [IntegerVal (cast tag), StringVal (show n), toScheme n, toScheme emptyFC] compileBody _ n (TCon tag arity parampos detpos flags mutwith datacons detagabbleBy) = do let args = mkArgNs 0 arity - argvs <- mkArgs args + let argvs = mkArgs args let body = Vector (-1) (IntegerVal (cast tag) :: StringVal (show n) :: toScheme n :: toScheme emptyFC :: - map (Var . schVarName) args) + map (Var . schVarName) (toList args)) pure (bindArgs n argvs [] body) where - mkArgNs : Int -> Nat -> List Name - mkArgNs i Z = [] - mkArgNs i (S k) = MN "arg" i :: mkArgNs (i+1) k + mkArgNs : Int -> Nat -> SnocList Name + mkArgNs i Z = [<] + mkArgNs i (S k) = mkArgNs (i+1) k :< MN "arg" i compileBody _ n (Hole numlocs x) = pure $ blockedMetaApp n compileBody _ n (BySearch x maxdepth defining) = pure $ blockedMetaApp n compileBody _ n (Guess guess envbind constraints) = pure $ blockedMetaApp n diff --git a/src/Core/SchemeEval/Evaluate.idr b/src/Core/SchemeEval/Evaluate.idr index 0afdff6d62..393e4c8849 100644 --- a/src/Core/SchemeEval/Evaluate.idr +++ b/src/Core/SchemeEval/Evaluate.idr @@ -12,7 +12,7 @@ import Libraries.Data.NameMap import Libraries.Utils.Scheme public export -data SObj : List Name -> Type where +data SObj : SnocList Name -> Type where MkSObj : ForeignObj -> SchVars vars -> SObj vars -- Values, which we read off evaluated scheme objects. @@ -22,13 +22,13 @@ data SObj : List Name -> Type where -- recording a LocalEnv for example). mutual public export - data SHead : List Name -> Type where + data SHead : SnocList Name -> Type where SLocal : (idx : Nat) -> (0 p : IsVar nm idx vars) -> SHead vars SRef : NameType -> Name -> SHead vars SMeta : Name -> Int -> List (Core (SNF vars)) -> SHead vars public export - data SNF : List Name -> Type where + data SNF : SnocList Name -> Type where SBind : FC -> (x : Name) -> Binder (SNF vars) -> (SObj vars -> Core (SNF vars)) -> SNF vars SApp : FC -> SHead vars -> List (Core (SNF vars)) -> SNF vars @@ -87,17 +87,17 @@ seval mode env tm Env Term vars -> (SchemeObj Write -> SchemeObj Write) -> Core (SchemeObj Write -> SchemeObj Write, SchVars vars) - mkEnv [] k = pure (k, []) - mkEnv (Let fc c val ty :: es) k + mkEnv [<] k = pure (k, [<]) + mkEnv (es :< Let fc c val ty) k = do i <- nextName (bind, vs) <- mkEnv es k val' <- compile vs val let n = "let-var-" ++ show i - pure (\x => Let n val' (bind x), Bound n :: vs) - mkEnv (_ :: es) k + pure (\x => Let n val' (bind x), vs :< Bound n) + mkEnv (es :< _) k = do i <- nextName (bind, vs) <- mkEnv es k - pure (bind, Free ("free-" ++ show i) :: vs) + pure (bind, vs :< Free ("free-" ++ show i)) invalid : Core (Term vs) invalid = pure (Erased emptyFC Placeholder) @@ -147,9 +147,9 @@ mutual -- Instead, decode the ForeignObj directly, which is uglier but faster. quoteVector : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> + SchVars (vars ++ outer) -> Integer -> List ForeignObj -> - Core (Term (outer ++ vars)) + Core (Term (vars ++ outer)) quoteVector svs (-2) [_, fname_in, args_in] -- Blocked app = quoteOrInvalid fname_in $ \ fname => do let argList = getArgList args_in @@ -275,9 +275,9 @@ mutual quotePiInfo : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> + SchVars (vars ++ outer) -> ForeignObj -> - Core (PiInfo (Term (outer ++ vars))) + Core (PiInfo (Term (vars ++ outer))) quotePiInfo svs obj = if isInteger obj then case unsafeGetInteger obj of @@ -305,49 +305,49 @@ mutual quoteBinder : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> + SchVars (vars ++ outer) -> (forall ty . FC -> RigCount -> PiInfo ty -> ty -> Binder ty) -> ForeignObj -> -- body of binder, represented as a function RigCount -> - PiInfo (Term (outer ++ vars)) -> - Term (outer ++ vars) -> -- decoded type + PiInfo (Term (vars ++ outer)) -> + Term (vars ++ outer) -> -- decoded type Name -> -- bound name - Core (Term (outer ++ vars)) + Core (Term (vars ++ outer)) quoteBinder svs binder proc_in r pi ty name = do let Procedure proc = decodeObj proc_in | _ => invalid i <- nextName let n = show name ++ "-" ++ show i let sc = unsafeApply proc (makeSymbol n) - sc' <- quote' {outer = name :: outer} (Bound n :: svs) sc + sc' <- quote' {outer = outer :< name} (svs :< Bound n) sc pure (Bind emptyFC name (binder emptyFC r pi ty) sc') quotePLet : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> + SchVars (vars ++ outer) -> ForeignObj -> -- body of binder, represented as a function RigCount -> - Term (outer ++ vars) -> -- decoded type - Term (outer ++ vars) -> -- decoded value + Term (vars ++ outer) -> -- decoded type + Term (vars ++ outer) -> -- decoded value Name -> -- bound name - Core (Term (outer ++ vars)) + Core (Term (vars ++ outer)) quotePLet svs proc_in r val ty name = do let Procedure proc = decodeObj proc_in | _ => invalid i <- nextName let n = show name ++ "-" ++ show i let sc = unsafeApply proc (makeSymbol n) - sc' <- quote' {outer = name :: outer} (Bound n :: svs) sc + sc' <- quote' {outer = outer :< name} (svs :< Bound n) sc pure (Bind emptyFC name (PLet emptyFC r val ty) sc') quote' : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> ForeignObj -> - Core (Term (outer ++ vars)) + SchVars (vars ++ outer) -> ForeignObj -> + Core (Term (vars ++ outer)) quote' svs obj = if isVector obj then quoteVector svs (unsafeGetInteger (unsafeVectorRef obj 0)) @@ -364,8 +364,8 @@ mutual else invalid where findName : forall vars . SchVars vars -> String -> Term vars - findName [] n = Ref emptyFC Func (UN (Basic n)) - findName (x :: xs) n + findName [<] n = Ref emptyFC Func (UN (Basic n)) + findName (xs :< x) n = if getName x == n then Local emptyFC Nothing _ First else let Local fc loc _ p = findName xs n @@ -386,7 +386,7 @@ quoteObj : {auto c : Ref Ctxt Defs} -> SObj vars -> Core (Term vars) quoteObj (MkSObj val schEnv) = do i <- newRef Sym 0 - quote' {outer = []} schEnv val + quote' {outer = [<]} schEnv val mutual snfVector : Ref Ctxt Defs => @@ -583,8 +583,8 @@ mutual else invalidS where findName : forall vars . SchVars vars -> String -> SNF vars - findName [] n = SApp emptyFC (SRef Func (UN (Basic n))) [] - findName (x :: xs) n + findName [<] n = SApp emptyFC (SRef Func (UN (Basic n))) [] + findName (xs :< x) n = if getName x == n then SApp emptyFC (SLocal _ First) [] else let SApp fc (SLocal _ p) args = findName xs n diff --git a/src/Core/SchemeEval/Quote.idr b/src/Core/SchemeEval/Quote.idr index a84bc57d3d..2ca2ce29f0 100644 --- a/src/Core/SchemeEval/Quote.idr +++ b/src/Core/SchemeEval/Quote.idr @@ -12,7 +12,7 @@ mutual {bound, free : _} -> Ref Sym Integer -> Bounds bound -> Env Term free -> List (Core (SNF free)) -> - Core (List (Term (bound ++ free))) + Core (List (Term (free ++ bound))) quoteArgs q bound env args = traverse (\arg => do arg' <- arg quoteGen q bound env arg') args @@ -21,7 +21,7 @@ mutual {bound, free : _} -> Ref Sym Integer -> Bounds bound -> Env Term free -> PiInfo (SNF free) -> - Core (PiInfo (Term (bound ++ free))) + Core (PiInfo (Term (free ++ bound))) quotePi q bound env Explicit = pure Explicit quotePi q bound env Implicit = pure Implicit quotePi q bound env AutoImplicit = pure AutoImplicit @@ -33,7 +33,7 @@ mutual {bound, free : _} -> Ref Sym Integer -> Bounds bound -> Env Term free -> Binder (SNF free) -> - Core (Binder (Term (bound ++ free))) + Core (Binder (Term (free ++ bound))) quoteBinder q bound env (Lam fc r p ty) = do ty' <- quoteGen q bound env ty p' <- quotePi q bound env p @@ -62,16 +62,16 @@ mutual {bound, free : _} -> Ref Sym Integer -> FC -> Bounds bound -> Env Term free -> SHead free -> - Core (Term (bound ++ free)) + Core (Term (free ++ bound)) quoteHead {bound} q fc bounds env (SLocal idx prf) = let MkVar prf' = addLater bound prf in pure (Local fc Nothing _ prf') where addLater : {idx : _} -> - (ys : List Name) -> (0 p : IsVar n idx xs) -> - Var (ys ++ xs) - addLater [] isv = MkVar isv - addLater (x :: xs) isv + (ys : SnocList Name) -> (0 p : IsVar n idx xs) -> + Var (xs ++ ys) + addLater [<] isv = MkVar isv + addLater (xs :< x) isv = let MkVar isv' = addLater xs isv in MkVar (Later isv') quoteHead q fc bounds env (SRef nt n) @@ -93,7 +93,7 @@ mutual quoteGen : {auto c : Ref Ctxt Defs} -> {bound, vars : _} -> Ref Sym Integer -> Bounds bound -> - Env Term vars -> SNF vars -> Core (Term (bound ++ vars)) + Env Term vars -> SNF vars -> Core (Term (vars ++ bound)) quoteGen q bound env (SBind fc n b sc) = do i <- nextName let var = UN (Basic ("b-" ++ show (fromInteger i))) diff --git a/src/Core/TT.idr b/src/Core/TT.idr index efa8521ac1..08ec3a0ba9 100644 --- a/src/Core/TT.idr +++ b/src/Core/TT.idr @@ -7,6 +7,7 @@ import public Core.Name.Scoped import Idris.Pretty.Annotations import Data.List +import Data.SnocList import Data.Nat import Data.String import Data.Vect @@ -319,7 +320,7 @@ Pretty Void Terminating where public export data Covering = IsCovering - | MissingCases (List (Term [])) + | MissingCases (List (Term [<])) | NonCoveringCall (List Name) export @@ -382,34 +383,50 @@ notCovering = MkTotality Unchecked (MissingCases []) namespace Bounds public export - data Bounds : List Name -> Type where - None : Bounds [] - Add : (x : Name) -> Name -> Bounds xs -> Bounds (x :: xs) + data Bounds : SnocList Name -> Type where + None : Bounds [<] + Add : (x : Name) -> Name -> Bounds xs -> Bounds (xs :< x) export - sizeOf : Bounds xs -> SizeOf xs + sizeOf : Bounds xs -> Libraries.Data.SnocList.SizeOf.SizeOf xs sizeOf None = zero sizeOf (Add _ _ b) = suc (sizeOf b) +export +cons : (x : Name) -> Name -> Bounds xs -> Bounds (x `cons` xs) +cons n xn None = Add n xn None +cons n xn (Add n' xn' b) = Add n' xn' (cons n xn b) + +export +covering +{vars : _} -> Show (Bounds vars) where + show None = "None" + show (Add x n b) = show x ++ " " ++ show n ++ " + " ++ show b + export addVars : SizeOf outer -> Bounds bound -> - NVar name (outer ++ vars) -> - NVar name (outer ++ (bound ++ vars)) + NVar name (vars ++ outer) -> + NVar name (vars ++ bound ++ outer) addVars p = insertNVarNames p . sizeOf export resolveRef : SizeOf outer -> SizeOf done -> Bounds bound -> FC -> Name -> - Maybe (Var (outer ++ (done <>> bound ++ vars))) + Maybe (Var (vars ++ (bound ++ done) ++ outer)) resolveRef _ _ None _ _ = Nothing -resolveRef {outer} {vars} {done} p q (Add {xs} new old bs) fc n +resolveRef {outer} {done} p q (Add {xs} new old bs) fc n = if n == old - then Just (weakenNs p (mkVarChiply q)) - else resolveRef p (q :< new) bs fc n + then do + rewrite appendAssociative vars ((xs :< new) ++ done) outer + rewrite appendAssociative vars (xs :< new) done + Just $ weakenNs {tm = Var} p (mkVar q) + else do + rewrite sym $ appendAssociative xs [ Bounds bound -> - Term (outer ++ vars) -> Term (outer ++ (bound ++ vars)) + Term (vars ++ outer) -> Term (vars ++ (bound ++ outer)) mkLocals outer bs (Local fc r idx p) = let MkNVar p' = addVars outer bs (MkNVar p) in Local fc r _ p' mkLocals outer bs (Ref fc Bound name) @@ -442,39 +459,39 @@ mkLocals outer bs (Erased fc (Dotted t)) = Erased fc (Dotted (mkLocals outer bs mkLocals outer bs (TType fc u) = TType fc u export -refsToLocals : Bounds bound -> Term vars -> Term (bound ++ vars) +refsToLocals : Bounds bound -> Term vars -> Term (vars ++ bound) refsToLocals None y = y refsToLocals bs y = mkLocals zero bs y -- Replace any reference to 'x' with a locally bound name 'new' export -refToLocal : (x : Name) -> (new : Name) -> Term vars -> Term (new :: vars) +refToLocal : (x : Name) -> (new : Name) -> Term vars -> Term (vars :< new) refToLocal x new tm = refsToLocals (Add new x None) tm -- Replace an explicit name with a term export -substName : Name -> Term vars -> Term vars -> Term vars -substName x new (Ref fc nt name) +substName : SizeOf local -> Name -> Term vars -> Term (vars ++ local) -> Term (vars ++ local) +substName s x new (Ref fc nt name) = case nameEq x name of Nothing => Ref fc nt name - Just Refl => new -substName x new (Meta fc n i xs) - = Meta fc n i (map (substName x new) xs) + Just Refl => weakenNs s new +substName s x new (Meta fc n i xs) + = Meta fc n i (map (substName s x new) xs) -- ASSUMPTION: When we substitute under binders, the name has always been -- resolved to a Local, so no need to check that x isn't shadowing -substName x new (Bind fc y b scope) - = Bind fc y (map (substName x new) b) (substName x (weaken new) scope) -substName x new (App fc fn arg) - = App fc (substName x new fn) (substName x new arg) -substName x new (As fc s as pat) - = As fc s as (substName x new pat) -substName x new (TDelayed fc y z) - = TDelayed fc y (substName x new z) -substName x new (TDelay fc y t z) - = TDelay fc y (substName x new t) (substName x new z) -substName x new (TForce fc r y) - = TForce fc r (substName x new y) -substName x new tm = tm +substName s x new (Bind fc y b scope) + = Bind fc y (map (substName s x new) b) (substName (suc s) x new scope) +substName s x new (App fc fn arg) + = App fc (substName s x new fn) (substName s x new arg) +substName s x new (As fc use as pat) + = As fc use (substName s x new as) (substName s x new pat) +substName s x new (TDelayed fc y z) + = TDelayed fc y (substName s x new z) +substName s x new (TDelay fc y t z) + = TDelay fc y (substName s x new t) (substName s x new z) +substName s x new (TForce fc r y) + = TForce fc r (substName s x new y) +substName s x new tm = tm export addMetas : (usingResolved : Bool) -> NameMap Bool -> Term vars -> NameMap Bool diff --git a/src/Core/TT/Subst.idr b/src/Core/TT/Subst.idr index abe5031188..f02834f03e 100644 --- a/src/Core/TT/Subst.idr +++ b/src/Core/TT/Subst.idr @@ -4,26 +4,35 @@ import Core.Name import Core.Name.Scoped import Core.TT.Var +import Data.SnocList + +import Libraries.Data.SnocList.SizeOf + %default total public export data Subst : Scoped -> Scope -> Scoped where - Nil : Subst tm [] vars - (::) : tm vars -> Subst tm ds vars -> Subst tm (d :: ds) vars + Lin : Subst tm [<] vars + (:<) : Subst tm ds vars -> tm vars -> Subst tm (ds :< d) vars + +export +cons : Subst tm ds vars -> tm vars -> Subst tm (v `cons` ds) vars +cons [<] p = Lin :< p +cons (ns :< s) p = cons ns p :< s namespace Var export index : Subst tm ds vars -> Var ds -> tm vars - index [] (MkVar p) impossible - index (t :: _) (MkVar First) = t - index (_ :: ts) (MkVar (Later p)) = index ts (MkVar p) + index [<] (MkVar p) impossible + index (_ :< t) (MkVar First) = t + index (ts :< _) (MkVar (Later p)) = index ts (MkVar p) export findDrop : (Var vars -> tm vars) -> SizeOf dropped -> - Var (dropped ++ vars) -> + Var (vars ++ dropped) -> Subst tm dropped vars -> tm vars findDrop k s var sub = case locateVar s var of @@ -34,9 +43,9 @@ export find : Weaken tm => (forall vars. Var vars -> tm vars) -> SizeOf outer -> SizeOf dropped -> - Var (outer ++ (dropped ++ vars)) -> + Var ((vars ++ dropped) ++ outer) -> Subst tm dropped vars -> - tm (outer ++ vars) + tm (vars ++ outer) find k outer dropped var sub = case locateVar outer var of Left var => k (embed var) Right var => weakenNs outer (findDrop k dropped var sub) @@ -48,5 +57,5 @@ Substitutable val tm SizeOf outer -> SizeOf dropped -> Subst val dropped vars -> - tm (outer ++ (dropped ++ vars)) -> - tm (outer ++ vars) + tm ((vars ++ dropped) ++ outer) -> + tm (vars ++ outer) diff --git a/src/Core/TT/Term.idr b/src/Core/TT/Term.idr index 94f7b9dad8..465d9cc747 100644 --- a/src/Core/TT/Term.idr +++ b/src/Core/TT/Term.idr @@ -6,11 +6,15 @@ import Core.FC import Core.Name import Core.Name.Scoped +import Core.Name.CompatibleVars import Core.TT.Binder import Core.TT.Primitive import Core.TT.Var import Data.List +import Data.SnocList + +import Libraries.Data.SnocList.SizeOf %default total @@ -55,6 +59,11 @@ data LazyReason = LInf | LLazy | LUnknown public export data UseSide = UseLeft | UseRight +export +Show UseSide where + show UseLeft = "UseLeft" + show UseRight = "UseRight" + %name UseSide side public export @@ -98,10 +107,11 @@ data Term : Scoped where (idx : Nat) -> (0 p : IsVar name idx vars) -> Term vars Ref : FC -> NameType -> (name : Name) -> Term vars -- Metavariables and the scope they are applied to + -- See [Note] Meta args Meta : FC -> Name -> Int -> List (Term vars) -> Term vars Bind : FC -> (x : Name) -> (b : Binder (Term vars)) -> - (scope : Term (x :: vars)) -> Term vars + (scope : Term (vars :< x)) -> Term vars App : FC -> (fn : Term vars) -> (arg : Term vars) -> Term vars -- as patterns; since we check LHS patterns as terms before turning -- them into patterns, this helps us get it right. When normalising, @@ -125,7 +135,7 @@ data Term : Scoped where public export ClosedTerm : Type -ClosedTerm = Term [] +ClosedTerm = Term [<] ------------------------------------------------------------------------ -- Weakening @@ -287,6 +297,11 @@ apply : FC -> Term vars -> List (Term vars) -> Term vars apply loc fn [] = fn apply loc fn (a :: args) = apply loc (App loc fn a) args +export +applySpine : FC -> Term vars -> SnocList (Term vars) -> Term vars +applySpine loc fn [<] = fn +applySpine loc fn (args :< a) = App loc (applySpine loc fn args) a + -- Creates a chain of `App` nodes, each with its own file context export applySpineWithFC : Term vars -> SnocList (FC, Term vars) -> Term vars @@ -317,6 +332,13 @@ getFnArgs tm = getFA [] tm getFA args (App _ f a) = getFA (a :: args) f getFA args tm = (tm, args) +export +getFnArgsSpine : Term vars -> (Term vars, SnocList (Term vars)) +getFnArgsSpine (App _ f a) + = let (fn, sp) = getFnArgsSpine f in + (fn, sp :< a) +getFnArgsSpine tm = (tm, [<]) + export getFn : Term vars -> Term vars getFn (App _ f a) = getFn f @@ -474,15 +496,15 @@ Eq (Term vars) where mutual - resolveNamesBinder : (vars : List Name) -> Binder (Term vars) -> Binder (Term vars) + resolveNamesBinder : (vars : SnocList Name) -> Binder (Term vars) -> Binder (Term vars) resolveNamesBinder vars b = assert_total $ map (resolveNames vars) b - resolveNamesTerms : (vars : List Name) -> List (Term vars) -> List (Term vars) + resolveNamesTerms : (vars : SnocList Name) -> List (Term vars) -> List (Term vars) resolveNamesTerms vars ts = assert_total $ map (resolveNames vars) ts -- Replace any Ref Bound in a type with appropriate local export - resolveNames : (vars : List Name) -> Term vars -> Term vars + resolveNames : (vars : SnocList Name) -> Term vars -> Term vars resolveNames vars (Ref fc Bound name) = case isNVar name vars of Just (MkNVar prf) => Local fc (Just False) _ prf @@ -490,7 +512,7 @@ mutual resolveNames vars (Meta fc n i xs) = Meta fc n i (resolveNamesTerms vars xs) resolveNames vars (Bind fc x b scope) - = Bind fc x (resolveNamesBinder vars b) (resolveNames (x :: vars) scope) + = Bind fc x (resolveNamesBinder vars b) (resolveNames (vars :< x) scope) resolveNames vars (App fc fn arg) = App fc (resolveNames vars fn) (resolveNames vars arg) resolveNames vars (As fc s as pat) diff --git a/src/Core/TT/Term/Subst.idr b/src/Core/TT/Term/Subst.idr index 05e0b3e00d..8d15ea9bdf 100644 --- a/src/Core/TT/Term/Subst.idr +++ b/src/Core/TT/Term/Subst.idr @@ -8,6 +8,10 @@ import Core.TT.Subst import Core.TT.Term import Core.TT.Var +import Data.SnocList + +import Libraries.Data.SnocList.SizeOf + %default total public export @@ -47,9 +51,9 @@ substBinder outer dropped env b = assert_total $ map (substTerm outer dropped env) b export -substs : SizeOf dropped -> SubstEnv dropped vars -> Term (dropped ++ vars) -> Term vars +substs : SizeOf dropped -> SubstEnv dropped vars -> Term (vars ++ dropped) -> Term vars substs dropped env tm = substTerm zero dropped env tm export -subst : Term vars -> Term (x :: vars) -> Term vars -subst val tm = substs (suc zero) [val] tm +subst : Term vars -> Term (vars :< x) -> Term vars +subst val tm = substs (suc zero) [ Exists (\ outer => Term (outer <>> vars)) -unBinds (Bind _ x _ scope) = let (Evidence outer t) = unBinds scope in - Evidence (outer :< x) t -unBinds t = Evidence [<] t - export onPRefs : Monoid m => (Name -> m) -> diff --git a/src/Core/TT/Var.idr b/src/Core/TT/Var.idr index 163c885750..1a91af5116 100644 --- a/src/Core/TT/Var.idr +++ b/src/Core/TT/Var.idr @@ -9,10 +9,15 @@ import Data.Vect import Core.Name import Core.Name.Scoped +import Core.Name.CompatibleVars import Libraries.Data.SnocList.HasLength import Libraries.Data.SnocList.SizeOf +import Data.List.HasLength +import Libraries.Data.List.HasLength +import Libraries.Data.List.SizeOf + import Libraries.Data.Erased %default total @@ -25,9 +30,9 @@ import Libraries.Data.Erased ||| is a position k ||| in the snoclist ns public export -data IsVar : a -> Nat -> List a -> Type where - First : IsVar n Z (n :: ns) - Later : IsVar n i ns -> IsVar n (S i) (m :: ns) +data IsVar : a -> Nat -> SnocList a -> Type where + First : IsVar n Z (ns :< n) + Later : IsVar n i ns -> IsVar n (S i) (ns :< m) %name IsVar idx @@ -40,55 +45,64 @@ finIdx (Later l) = FS (finIdx l) ||| Recover the value pointed at by an IsVar proof ||| O(n) in the size of the index export -nameAt : {vars : List a} -> {idx : Nat} -> (0 p : IsVar n idx vars) -> a -nameAt {vars = n :: _} First = n +nameAt : {vars : SnocList a} -> {idx : Nat} -> (0 p : IsVar n idx vars) -> a +nameAt {vars = _ :< n} First = n nameAt (Later p) = nameAt p +export +snocIdx : {vars : SnocList a} -> {idx : Nat} -> (0 p : IsVar n idx vars) -> Nat +snocIdx {vars} {idx} p = minus (length vars) idx + ||| Inversion principle for Later export -dropLater : IsVar nm (S idx) (n :: ns) -> IsVar nm idx ns +dropLater : IsVar nm (S idx) (ns :< n) -> IsVar nm idx ns dropLater (Later p) = p export -0 mkIsVar : HasLength m inner -> IsVar nm m (inner ++ nm :: outer) -mkIsVar Z = First -mkIsVar (S x) = Later (mkIsVar x) +appendIsVar : HasLength m inner -> IsVar nm m (outer :< nm ++ inner) +appendIsVar Z = First +appendIsVar (S x) = Later (appendIsVar x) export -0 mkIsVarChiply : HasLength m inner -> IsVar nm m (inner <>> nm :: outer) -mkIsVarChiply hl - = rewrite chipsAsListAppend inner (nm :: outer) in - rewrite sym $ plusZeroRightNeutral m in - mkIsVar (hlChips hl Z) +fishyIsVar : HasLength m inner -> IsVar nm m (outer :< nm <>< inner) +fishyIsVar hl + = rewrite fishAsSnocAppend (outer :< nm) inner in + appendIsVar + $ rewrite sym $ plusZeroRightNeutral m in + hlFish Z hl + +export +0 mkIsVar : HasLength m inner -> IsVar nm m (outer :< nm ++ inner) +mkIsVar Z = First +mkIsVar (S x) = Later (mkIsVar x) ||| Compute the remaining scope once the target variable has been removed public export dropIsVar : - (ns : List a) -> + (ns : SnocList a) -> {idx : Nat} -> (0 p : IsVar name idx ns) -> - List a -dropIsVar (_ :: xs) First = xs -dropIsVar (n :: xs) (Later p) = n :: dropIsVar xs p + SnocList a +dropIsVar (xs :< _) First = xs +dropIsVar (xs :< n) (Later p) = dropIsVar xs p :< n ||| Throw in extra variables on the outer side of the context ||| This is essentially the identity function ||| This is slow so we ensure it's only used in a runtime irrelevant manner export -0 embedIsVar : IsVar x idx xs -> IsVar x idx (xs ++ outer) -embedIsVar First = First -embedIsVar (Later p) = Later (embedIsVar p) +0 embedIsVar : IsVar x idx vars -> IsVar x idx (more ++ vars) +embedIsVar tm = believe_me tm ||| Throw in extra variables on the local end of the context. ||| This is slow so we ensure it's only used in a runtime irrelevant manner export -0 weakenIsVar : (s : SizeOf ns) -> IsVar x idx xs -> IsVar x (size s + idx) (ns ++ xs) +0 weakenIsVar : (s : SizeOf ns) -> IsVar x idx xs -> IsVar x (size s + idx) (xs ++ ns) weakenIsVar (MkSizeOf Z Z) p = p weakenIsVar (MkSizeOf (S k) (S l)) p = Later (weakenIsVar (MkSizeOf k l) p) 0 locateIsVarLT : (s : SizeOf local) -> So (idx < size s) -> - IsVar x idx (local ++ outer) -> + IsVar x idx (outer ++ local) -> IsVar x idx local locateIsVarLT (MkSizeOf Z Z) so v = case v of First impossible @@ -100,17 +114,17 @@ locateIsVarLT (MkSizeOf (S k) (S l)) so v = case v of 0 locateIsVarGE : (s : SizeOf local) -> So (idx >= size s) -> - IsVar x idx (local ++ outer) -> + IsVar x idx (outer ++ local) -> IsVar x (idx `minus` size s) outer locateIsVarGE (MkSizeOf Z Z) so v = rewrite minusZeroRight idx in v locateIsVarGE (MkSizeOf (S k) (S l)) so v = case v of Later v => locateIsVarGE (MkSizeOf k l) so v export -locateIsVar : {idx : Nat} -> (s : SizeOf local) -> - (0 p : IsVar x idx (local ++ outer)) -> - Either (Erased (IsVar x idx local)) - (Erased (IsVar x (idx `minus` size s) outer)) +locateIsVar : {idx : Nat} -> (s : SizeOf outer) -> + (0 p : IsVar x idx (inner ++ outer)) -> + Either (Erased (IsVar x idx outer)) + (Erased (IsVar x (idx `minus` size s) inner)) locateIsVar s p = case choose (idx < size s) of Left so => Left (MkErased (locateIsVarLT s so p)) Right so => Right (MkErased (locateIsVarGE s so p)) @@ -122,7 +136,7 @@ locateIsVar s p = case choose (idx < size s) of ||| and a proof that the name is at that position in the scope. ||| Everything but the De Bruijn index is erased. public export -record Var {0 a : Type} (vars : List a) where +record Var {0 a : Type} (vars : SnocList a) where constructor MkVar {varIdx : Nat} {0 varNm : a} @@ -131,52 +145,51 @@ record Var {0 a : Type} (vars : List a) where namespace Var export - later : Var ns -> Var (n :: ns) + later : Var ns -> Var (ns :< n) later (MkVar p) = MkVar (Later p) export - isLater : Var (n :: vs) -> Maybe (Var vs) + isLater : Var (vs :< n) -> Maybe (Var vs) isLater (MkVar First) = Nothing isLater (MkVar (Later p)) = Just (MkVar p) export -mkVar : SizeOf inner -> Var (inner ++ nm :: outer) +mkVar : SizeOf inner -> Var (outer :< nm ++ inner) mkVar (MkSizeOf s p) = MkVar (mkIsVar p) export -mkVarChiply : SizeOf inner -> Var (inner <>> nm :: outer) -mkVarChiply (MkSizeOf s p) = MkVar (mkIsVarChiply p) +fishyVar : SizeOf inner -> Var (outer :< nm <>< inner) +fishyVar (MkSizeOf s p) = MkVar (fishyIsVar p) ||| Generate all variables export allVars : (vars : Scope) -> List (Var vars) -allVars = go [<] where +allVars = go zero where - go : SizeOf local -> (vs : Scope) -> List (Var (local <>> vs)) - go s [] = [] - go s (v :: vs) = mkVarChiply s :: go (s :< v) vs + go : SizeOf local -> (vs : Scope) -> List (Var (vs <>< local)) + go s [<] = [] + go s (vs :< v) = fishyVar s :: go (suc s) vs export Eq (Var xs) where v == w = varIdx v == varIdx w - ||| Removing var 0, strengthening all the other ones export -dropFirst : List (Var (n :: vs)) -> List (Var vs) -dropFirst = List.mapMaybe isLater +dropFirst : SnocList (Var (vs :< n)) -> SnocList (Var vs) +dropFirst = SnocList.mapMaybe isLater ||| Manufacturing a thinning from a list of variables to keep export thinFromVars : - (vars : _) -> List (Var vars) -> + (vars : _) -> SnocList (Var vars) -> (newvars ** Thin newvars vars) -thinFromVars [] els +thinFromVars [<] els = (_ ** Refl) -thinFromVars (x :: xs) els +thinFromVars (xs :< x) els = let (vs ** subRest) = thinFromVars xs (dropFirst els) in if MkVar First `elem` els - then (x :: vs ** Keep subRest) + then (vs :< x ** Keep subRest) else (vs ** Drop subRest) export @@ -187,18 +200,18 @@ Show (Var ns) where -- Named variable in scope public export -record NVar {0 a : Type} (nm : a) (vars : List a) where +record NVar {0 a : Type} (nm : a) (vars : SnocList a) where constructor MkNVar {nvarIdx : Nat} 0 nvarPrf : IsVar nm nvarIdx vars namespace NVar export - later : NVar nm ns -> NVar nm (n :: ns) + later : NVar nm ns -> NVar nm (ns :< n) later (MkNVar p) = MkNVar (Later p) export - isLater : NVar nm (n :: ns) -> Maybe (NVar nm ns) + isLater : NVar nm (ns :< n) -> Maybe (NVar nm ns) isLater (MkNVar First) = Nothing isLater (MkNVar (Later p)) = Just (MkNVar p) @@ -211,48 +224,44 @@ recoverName : (v : Var vars) -> NVar (varNm v) vars recoverName (MkVar p) = MkNVar p export -mkNVar : SizeOf inner -> NVar nm (inner ++ nm :: outer) +mkNVar : SizeOf inner -> NVar nm (outer :< nm ++ inner) mkNVar (MkSizeOf s p) = MkNVar (mkIsVar p) export -mkNVarChiply : SizeOf inner -> NVar nm (inner <>> nm :: outer) -mkNVarChiply (MkSizeOf s p) = MkNVar (mkIsVarChiply p) - -export -locateNVar : SizeOf local -> NVar nm (local ++ outer) -> - Either (NVar nm local) (NVar nm outer) +locateNVar : SizeOf outer -> NVar nm (local ++ outer) -> + Either (NVar nm outer) (NVar nm local) locateNVar s (MkNVar p) = case locateIsVar s p of Left p => Left (MkNVar (runErased p)) Right p => Right (MkNVar (runErased p)) public export -dropNVar : {ns : List a} -> NVar nm ns -> List a +dropNVar : {ns : SnocList a} -> NVar nm ns -> SnocList a dropNVar (MkNVar p) = dropIsVar ns p ------------------------------------------------------------------------ -- Scope checking export -isDeBruijn : Nat -> (vars : List Name) -> Maybe (Var vars) -isDeBruijn Z (_ :: _) = pure (MkVar First) -isDeBruijn (S k) (_ :: vs) = later <$> isDeBruijn k vs +isDeBruijn : Nat -> (vars : SnocList Name) -> Maybe (Var vars) +isDeBruijn Z (_ :< _) = pure (MkVar First) +isDeBruijn (S k) (vs :< _) = later <$> isDeBruijn k vs isDeBruijn _ _ = Nothing export -isNVar : (n : Name) -> (ns : List Name) -> Maybe (NVar n ns) -isNVar n [] = Nothing -isNVar n (m :: ms) +isNVar : (n : Name) -> (ns : SnocList Name) -> Maybe (NVar n ns) +isNVar n [<] = Nothing +isNVar n (ms :< m) = case nameEq n m of Nothing => map later (isNVar n ms) Just Refl => pure (MkNVar First) export -isVar : (n : Name) -> (ns : List Name) -> Maybe (Var ns) +isVar : (n : Name) -> (ns : SnocList Name) -> Maybe (Var ns) isVar n ns = forgetName <$> isNVar n ns export -locateVar : SizeOf local -> Var (local ++ outer) -> - Either (Var local) (Var outer) +locateVar : SizeOf outer -> Var (local ++ outer) -> + Either (Var outer) (Var local) locateVar s v = bimap forgetName forgetName $ locateNVar s (recoverName v) @@ -260,55 +269,53 @@ locateVar s v = bimap forgetName forgetName -- Weakening export -weakenNVar : SizeOf ns -> NVar name outer -> NVar name (ns ++ outer) +weakenNVar : SizeOf ns -> NVar name inner -> NVar name (inner ++ ns) weakenNVar s (MkNVar {nvarIdx} p) = MkNVar {nvarIdx = plus (size s) nvarIdx} (weakenIsVar s p) export -embedNVar : NVar name ns -> NVar name (ns ++ outer) +embedNVar : NVar name vars -> NVar name (more ++ vars) embedNVar (MkNVar p) = MkNVar (embedIsVar p) export -insertNVar : SizeOf local -> +insertNVar : SizeOf outer -> NVar nm (local ++ outer) -> - NVar nm (local ++ n :: outer) + NVar nm (local :< n ++ outer) insertNVar p v = case locateNVar p v of Left v => embedNVar v Right v => weakenNVar p (later v) export -insertNVarChiply : SizeOf local -> - NVar nm (local <>> outer) -> - NVar nm (local <>> n :: outer) -insertNVarChiply p v - = rewrite chipsAsListAppend local (n :: outer) in - insertNVar (p <>> zero) - $ replace {p = NVar nm} (chipsAsListAppend local outer) v +insertNVarFishy : SizeOf local -> + NVar nm (outer <>< local) -> + NVar nm (outer :< n <>< local) +insertNVarFishy p v + = rewrite fishAsSnocAppend (outer :< n) local in + insertNVar (zero <>< p) + $ replace {p = NVar nm} (fishAsSnocAppend outer local) v export insertNVarNames : GenWeakenable (NVar name) insertNVarNames p q v = case locateNVar p v of - Left v => embedNVar v - Right v => - rewrite appendAssociative local ns outer in - weakenNVar (p + q) v + Left v => rewrite appendAssociative local ns outer in embedNVar v + Right v => weakenNVar (q + p) v ||| The (partial) inverse to insertNVar export -removeNVar : SizeOf local -> - NVar nm (local ++ n :: outer) -> - Maybe (NVar nm (local ++ outer)) +removeNVar : SizeOf outer -> + NVar nm (local :< n ++ outer) -> + Maybe (NVar nm (local ++ outer)) removeNVar s var = case locateNVar s var of Left v => pure (embedNVar v) Right v => weakenNVar s <$> isLater v export -insertVar : SizeOf local -> +insertVar : SizeOf outer -> Var (local ++ outer) -> - Var (local ++ n :: outer) + Var (local :< n ++ outer) insertVar p v = forgetName $ insertNVar p (recoverName v) -weakenVar : SizeOf ns -> Var outer -> Var (ns ++ outer) +weakenVar : SizeOf ns -> Var inner -> Var (inner ++ ns) weakenVar p v = forgetName $ weakenNVar p (recoverName v) insertVarNames : GenWeakenable Var @@ -317,29 +324,29 @@ insertVarNames p q v = forgetName $ insertNVarNames p q (recoverName v) ||| The (partial) inverse to insertVar export removeVar : SizeOf local -> - Var (local ++ n :: outer) -> - Maybe (Var (local ++ outer)) + Var (outer :< n ++ local) -> + Maybe (Var (outer ++ local)) removeVar s var = forgetName <$> removeNVar s (recoverName var) ------------------------------------------------------------------------ -- Strengthening export -strengthenIsVar : {n : Nat} -> (s : SizeOf inner) -> - (0 p : IsVar x n (inner ++ vars)) -> +strengthenIsVar : {n : Nat} -> (s : SizeOf outer) -> + (0 p : IsVar x n (vars ++ outer)) -> Maybe (Erased (IsVar x (n `minus` size s) vars)) strengthenIsVar s p = case locateIsVar s p of Left _ => Nothing Right p => pure p -strengthenVar : SizeOf inner -> - Var (inner ++ vars) -> Maybe (Var vars) +strengthenVar : SizeOf outer -> + Var (vars ++ outer) -> Maybe (Var vars) strengthenVar s (MkVar p) = do MkErased p <- strengthenIsVar s p pure (MkVar p) -strengthenNVar : SizeOf inner -> - NVar x (inner ++ vars) -> Maybe (NVar x vars) +strengthenNVar : SizeOf outer -> + NVar x (vars ++ outer) -> Maybe (NVar x vars) strengthenNVar s (MkNVar p) = do MkErased p <- strengthenIsVar s p pure (MkNVar p) @@ -443,7 +450,17 @@ FreelyEmbeddable (NVar {a = Name} nm) where export shiftUnderNs : SizeOf {a = Name} inner -> {idx : _} -> - (0 p : IsVar n idx (x :: inner ++ outer)) -> - NVar n (inner ++ x :: outer) + (0 p : IsVar n idx (outer ++ inner :< x)) -> + NVar n (outer :< x ++ inner) shiftUnderNs s First = weakenNs s (MkNVar First) shiftUnderNs s (Later p) = insertNVar s (MkNVar p) + +||| Moving the zeroth variable under a set number of variables +||| Fishy version (cf. shiftUnderNs for the append one) +export +shiftUndersN : SizeOf {a = Name} args -> + {idx : _} -> + (0 p : IsVar n idx (vars <>< args :< x)) -> + NVar n (vars :< x <>< args) +shiftUndersN s First = weakensN s (MkNVar First) +shiftUndersN s (Later p) = insertNVarFishy s (MkNVar p) diff --git a/src/Core/TT/Views.idr b/src/Core/TT/Views.idr index 1e7b841b92..f27dc64fa6 100644 --- a/src/Core/TT/Views.idr +++ b/src/Core/TT/Views.idr @@ -6,10 +6,10 @@ import Core.TT ||| Go under n Pis (if n < 0 then go under as many as possible) export underPis : (n : Int) -> Env Term vars -> Term vars -> - (bnds : SnocList Name ** (Env Term (bnds <>> vars), Term (bnds <>> vars))) -underPis 0 env t = ([<] ** (env, t)) + (bnds : List Name ** (Env Term (vars <>< bnds), Term (vars <>< bnds))) +underPis 0 env t = ([] ** (env, t)) underPis n env (Bind fc x bd@(Pi{}) scope) = - let (bnds ** (env', scope')) := underPis (n - 1) (bd :: env) scope in - (bnds :< x ** (env', scope')) + let (bnds ** (env', scope')) := underPis (n - 1) (env :< bd) scope in + (x :: bnds ** (env', scope')) underPis n env (Bind fc x bd@(PLet fc1 y val ty) scope) = underPis n env (subst val scope) -underPis n env t = ([<] ** (env, t)) +underPis n env t = ([] ** (env, t)) diff --git a/src/Core/TTC.idr b/src/Core/TTC.idr index 41e9a22aec..6747cc9a26 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -270,13 +270,13 @@ TTC NameType where -- (Indeed, we're expecting the whole IsVar proof to be erased because -- we have the idx...) mkPrf : (idx : Nat) -> IsVar n idx ns -mkPrf {n} {ns} Z = believe_me (First {n} {ns = n :: ns}) +mkPrf {n} {ns} Z = believe_me (First {n} {ns = ns :< n}) mkPrf {n} {ns} (S k) = believe_me (Later {m=n} (mkPrf {n} {ns} k)) -getName : (idx : Nat) -> List Name -> Maybe Name -getName Z (x :: xs) = Just x -getName (S k) (x :: xs) = getName k xs -getName _ [] = Nothing +getName : (idx : Nat) -> SnocList Name -> Maybe Name +getName Z (xs :< x) = Just x +getName (S k) (xs :< x) = getName k xs +getName _ [<] = Nothing mutual export @@ -493,16 +493,16 @@ mutual export {vars : _} -> TTC (Env Term vars) where - toBuf b [] = pure () - toBuf b ((::) bnd env) + toBuf b [<] = pure () + toBuf b (env :< bnd) = do toBuf b bnd; toBuf b env -- Length has to correspond to length of 'vars' - fromBuf {vars = []} b = pure Nil - fromBuf {vars = x :: xs} b + fromBuf {vars = [<]} b = pure Lin + fromBuf {vars = xs :< x} b = do bnd <- fromBuf b env <- fromBuf b - pure (bnd :: env) + pure (env :< bnd) export TTC Visibility where @@ -1161,7 +1161,7 @@ TTC GlobalDef where mul vars vis tot hatch fl refs refsR inv c True def cdef Nothing sc Nothing) else pure (MkGlobalDef loc name (Erased loc Placeholder) [] [] [] [] - mul [] (specified Public) unchecked False [] refs refsR + mul [<] (specified Public) unchecked False [] refs refsR False False True def cdef Nothing [] Nothing) export diff --git a/src/Core/Termination/CallGraph.idr b/src/Core/Termination/CallGraph.idr index a29f716768..7ad83ccd52 100644 --- a/src/Core/Termination/CallGraph.idr +++ b/src/Core/Termination/CallGraph.idr @@ -7,9 +7,11 @@ import Core.Env import Core.Normalise import Core.Options import Core.Value +import Core.Name.CompatibleVars import Libraries.Data.IntMap import Libraries.Data.SparseMatrix +import Libraries.Data.SnocList.SizeOf import Data.String @@ -79,7 +81,7 @@ mutual findSC {vars} defs env g pats (Bind fc n b sc) = pure $ !(findSCbinder b) ++ - !(findSC defs (b :: env) g (map weaken pats) sc) + !(findSC defs (env :< b) g (map weaken pats) sc) where findSCbinder : Binder (Term vars) -> Core (List SCCall) findSCbinder (Let _ c val ty) = findSC defs env g pats val @@ -167,16 +169,16 @@ mutual -- otherwise try to expand RHS meta sizeCompare fuel s@(Meta n _ i args) t = do Just gdef <- lookupCtxtExact (Resolved i) (gamma defs) | _ => pure Unknown - let (PMDef _ [] (STerm _ tm) _ _) = definition gdef | _ => pure Unknown - tm <- substMeta (embed tm) args zero [] + let (PMDef _ [<] (STerm _ tm) _ _) = definition gdef | _ => pure Unknown + tm <- substMeta (embed tm) args zero [<] sizeCompare fuel tm t where substMeta : {0 drop, vs : _} -> - Term (drop ++ vs) -> List (Term vs) -> + Term (vs ++ drop) -> List (Term vs) -> SizeOf drop -> SubstEnv drop vs -> Core (Term vs) substMeta (Bind bfc n (Lam _ c e ty) sc) (a :: as) drop env - = substMeta sc as (suc drop) (a :: env) + = substMeta sc as (suc drop) (env :< a) substMeta (Bind bfc n (Let _ c val ty) sc) as drop env = substMeta (subst val sc) as drop env substMeta rhs [] drop env = pure (substs drop env rhs) @@ -388,6 +390,7 @@ findCalls : {auto c : Ref Ctxt Defs} -> findCalls defs (_ ** (env, lhs, rhs_in)) = do let pargs = getArgs (delazy defs lhs) rhs <- normaliseOpts tcOnly defs env rhs_in + -- Yaffle: (reverse pargs) findSC defs env Toplevel pargs (delazy defs rhs) getSC : {auto c : Ref Ctxt Defs} -> @@ -405,4 +408,6 @@ calculateSizeChange loc n defs <- get Ctxt Just def <- lookupCtxtExact n (gamma defs) | Nothing => undefinedName loc n - getSC defs (definition def) + r <- getSC defs (definition def) + log "totality.termination.sizechange" 5 $ "Calculated: " ++ show r + pure r diff --git a/src/Core/Termination/Positivity.idr b/src/Core/Termination/Positivity.idr index 403a7272cd..ff0a9ab4ea 100644 --- a/src/Core/Termination/Positivity.idr +++ b/src/Core/Termination/Positivity.idr @@ -21,41 +21,41 @@ isAssertTotal (NRef _ fn_in) = isAssertTotal _ = pure False nameIn : {auto c : Ref Ctxt Defs} -> - Defs -> List Name -> NF [] -> Core Bool + Defs -> List Name -> NF [<] -> Core Bool nameIn defs tyns (NBind fc x b sc) = if !(nameIn defs tyns !(evalClosure defs (binderType b))) then pure True else do let nm = Ref fc Bound (MN ("NAMEIN_" ++ show x) 0) - let arg = toClosure defaultOpts [] nm + let arg = toClosure defaultOpts [<] nm sc' <- sc defs arg nameIn defs tyns sc' nameIn defs tyns (NApp _ nh args) = do False <- isAssertTotal nh | True => pure False anyM (nameIn defs tyns) - !(traverse (evalClosure defs . snd) args) + !(traverse (evalClosure defs . snd) (toList args)) nameIn defs tyns (NTCon _ n _ _ args) = if n `elem` tyns then pure True - else do args' <- traverse (evalClosure defs . snd) args + else do args' <- traverse (evalClosure defs . snd) (toList args) anyM (nameIn defs tyns) args' nameIn defs tyns (NDCon _ n _ _ args) = anyM (nameIn defs tyns) - !(traverse (evalClosure defs . snd) args) + !(traverse (evalClosure defs . snd) (toList args)) nameIn defs tyns (NDelayed fc lr ty) = nameIn defs tyns ty nameIn defs tyns _ = pure False -- Check an argument type doesn't contain a negative occurrence of any of -- the given type names posArg : {auto c : Ref Ctxt Defs} -> - Defs -> List Name -> NF [] -> Core Terminating + Defs -> List Name -> NF [<] -> Core Terminating posArgs : {auto c : Ref Ctxt Defs} -> - Defs -> List Name -> List (Closure []) -> Core Terminating + Defs -> List Name -> List (Closure [<]) -> Core Terminating posArgs defs tyn [] = pure IsTerminating posArgs defs tyn (x :: xs) = do xNF <- evalClosure defs x - logNF "totality.positivity" 50 "Checking parameter for positivity" [] xNF + logNF "totality.positivity" 50 "Checking parameter for positivity" [<] xNF IsTerminating <- posArg defs tyn xNF | err => pure err posArgs defs tyn xs @@ -63,21 +63,21 @@ posArgs defs tyn (x :: xs) -- a tyn can only appear in the parameter positions of -- tc; report positivity failure if it appears anywhere else posArg defs tyns nf@(NTCon loc tc _ _ args) = - do logNF "totality.positivity" 50 "Found a type constructor" [] nf + do logNF "totality.positivity" 50 "Found a type constructor" [<] nf testargs <- case !(lookupDefExact tc (gamma defs)) of Just (TCon _ _ params _ _ _ _ _) => do - log "totality.positivity" 50 $ - unwords [show tc, "has", show (length params), "parameters"] - pure $ splitParams 0 params (map snd args) + logC "totality.positivity" 50 $ + do pure $ unwords [show tc, "has", show (length params), "parameters"] + pure $ splitParams 0 params (toList $ map snd args) _ => throw (GenericMsg loc (show tc ++ " not a data type")) let (params, indices) = testargs - False <- anyM (nameIn defs tyns) !(traverse (evalClosure defs) indices) + False <- anyM (nameIn defs tyns) (cast !(traverse (evalClosure defs) indices)) | True => pure (NotTerminating NotStrictlyPositive) posArgs defs tyns params where - splitParams : Nat -> List Nat -> List (Closure []) -> - ( List (Closure []) -- parameters (to be checked for strict positivity) - , List (Closure []) -- indices (to be checked for no mention at all) + splitParams : Nat -> List Nat -> List (Closure [<]) -> + ( List (Closure [<]) -- parameters (to be checked for strict positivity) + , List (Closure [<]) -- indices (to be checked for no mention at all) ) splitParams i ps [] = ([], []) splitParams i ps (x :: xs) @@ -86,38 +86,38 @@ posArg defs tyns nf@(NTCon loc tc _ _ args) = else mapSnd (x ::) (splitParams (S i) ps xs) -- a tyn can not appear as part of ty posArg defs tyns nf@(NBind fc x (Pi _ _ e ty) sc) - = do logNF "totality.positivity" 50 "Found a Pi-type" [] nf + = do logNF "totality.positivity" 50 "Found a Pi-type" [<] nf if !(nameIn defs tyns !(evalClosure defs ty)) then pure (NotTerminating NotStrictlyPositive) else do let nm = Ref fc Bound (MN ("POSCHECK_" ++ show x) 1) - let arg = toClosure defaultOpts [] nm + let arg = toClosure defaultOpts [<] nm sc' <- sc defs arg posArg defs tyns sc' posArg defs tyns nf@(NApp fc nh args) = do False <- isAssertTotal nh - | True => do logNF "totality.positivity" 50 "Trusting an assertion" [] nf + | True => do logNF "totality.positivity" 50 "Trusting an assertion" [<] nf pure IsTerminating - logNF "totality.positivity" 50 "Found an application" [] nf - args <- traverse (evalClosure defs . snd) args + logNF "totality.positivity" 50 "Found an application" [<] nf + args <- traverse (evalClosure defs . snd) (toList args) pure $ if !(anyM (nameIn defs tyns) args) then NotTerminating NotStrictlyPositive else IsTerminating posArg defs tyn (NDelayed fc lr ty) = posArg defs tyn ty posArg defs tyn nf - = do logNF "totality.positivity" 50 "Reached the catchall" [] nf + = do logNF "totality.positivity" 50 "Reached the catchall" [<] nf pure IsTerminating checkPosArgs : {auto c : Ref Ctxt Defs} -> - Defs -> List Name -> NF [] -> Core Terminating + Defs -> List Name -> NF [<] -> Core Terminating checkPosArgs defs tyns (NBind fc x (Pi _ _ e ty) sc) = case !(posArg defs tyns !(evalClosure defs ty)) of IsTerminating => do let nm = Ref fc Bound (MN ("POSCHECK_" ++ show x) 0) - let arg = toClosure defaultOpts [] nm + let arg = toClosure defaultOpts [<] nm checkPosArgs defs tyns !(sc defs arg) bad => pure bad checkPosArgs defs tyns nf - = do logNF "totality.positivity" 50 "Giving up on non-Pi type" [] nf + = do logNF "totality.positivity" 50 "Giving up on non-Pi type" [<] nf pure IsTerminating checkCon : {auto c : Ref Ctxt Defs} -> @@ -130,8 +130,8 @@ checkCon defs tyns cn Just ty => case !(totRefsIn defs ty) of IsTerminating => - do tyNF <- nf defs [] ty - logNF "totality.positivity" 20 "Checking the type " [] tyNF + do tyNF <- nf defs [<] ty + logNF "totality.positivity" 20 "Checking the type " [<] tyNF checkPosArgs defs tyns tyNF bad => pure bad diff --git a/src/Core/Transform.idr b/src/Core/Transform.idr index c7c22819ed..5d4ce45348 100644 --- a/src/Core/Transform.idr +++ b/src/Core/Transform.idr @@ -13,7 +13,7 @@ unload [] fn = fn unload ((fc, arg) :: args) fn = unload args (App fc fn arg) -- List of matches on LHS -data MatchVars : List Name -> List Name -> Type where +data MatchVars : SnocList Name -> SnocList Name -> Type where None : MatchVars lhsvars vs Match : (idx : Nat) -> (0 p : IsVar n idx lhsvars) -> Term vs -> MatchVars lhsvars vs -> MatchVars lhsvars vs @@ -124,7 +124,7 @@ trans env stk (Meta fc n i args) pure $ unload stk (Meta fc n i args') trans env stk (Bind fc x b sc) = do b' <- traverse (trans env []) b - sc' <- trans (b' :: env) [] sc + sc' <- trans (env :< b') [] sc pure $ unload stk (Bind fc x b' sc') trans env stk (App fc fn arg) = do arg' <- trans env [] arg diff --git a/src/Core/Unify.idr b/src/Core/Unify.idr index 3f4cdaafac..c8af45b97b 100644 --- a/src/Core/Unify.idr +++ b/src/Core/Unify.idr @@ -13,10 +13,12 @@ import public Core.UnifyState import Core.Value import Data.List +import Data.SnocList import Data.Maybe import Libraries.Data.IntMap import Libraries.Data.NameMap +import Libraries.Data.SnocList.SizeOf %default covering @@ -89,6 +91,13 @@ record UnifyResult where namesSolved : List Int -- which ones did we solve (as name indices) addLazy : AddLazy +export +Show UnifyResult where + show a = "constraints: " ++ show a.constraints + ++ ", holesSolved: " ++ show a.holesSolved + ++ ", namesSolved: " ++ show a.namesSolved + ++ ", addLazy: " ++ show a.addLazy + union : UnifyResult -> UnifyResult -> UnifyResult union u1 u2 = MkUnifyResult (union (constraints u1) (constraints u2)) (holesSolved u1 || holesSolved u2) @@ -112,7 +121,7 @@ solvedHole n = MkUnifyResult [] True [n] NoLazy public export interface Unify tm where -- Unify returns a list of ids referring to newly added constraints - unifyD : {vars : List Name} -> + unifyD : {vars : SnocList Name} -> Ref Ctxt Defs -> Ref UST UState -> UnifyInfo -> @@ -142,7 +151,7 @@ unify : Unify tm => FC -> Env Term vars -> tm vars -> tm vars -> Core UnifyResult -unify {c} {u} = unifyD c u +unify {c} {u} a b d e f = logDepth $ unifyD c u a b d e f export unifyWithLazy : Unify tm => @@ -264,14 +273,16 @@ unifyArgs : (Unify tm, Quote tm) => {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> UnifyInfo -> FC -> Env Term vars -> - List (tm vars) -> List (tm vars) -> + SnocList (tm vars) -> SnocList (tm vars) -> Core UnifyResult -unifyArgs mode loc env [] [] = pure success -unifyArgs mode loc env (cx :: cxs) (cy :: cys) +unifyArgs mode loc env [<] [<] = pure success +unifyArgs mode loc env (cxs :< cx) (cys :< cy) = do -- Do later arguments first, since they may depend on earlier -- arguments and use their solutions. cs <- unifyArgs mode loc env cxs cys + logC "unify" 20 $ pure $ "unifyArgs done: " ++ show cs res <- unify (lower mode) loc env cx cy + logC "unify" 20 $ pure $ "unify done: " ++ show res pure (union res cs) unifyArgs mode loc env _ _ = ufail loc "" @@ -280,13 +291,13 @@ unifyArgs mode loc env _ _ = ufail loc "" -- We use this to check that the pattern unification rule is applicable -- when solving a metavariable applied to arguments getVars : {vars : _} -> - List Nat -> List (NF vars) -> Maybe (List (Var vars)) -getVars got [] = Just [] -getVars got (NErased fc (Dotted t) :: xs) = getVars got (t :: xs) -getVars got (NApp fc (NLocal r idx v) [] :: xs) + List Nat -> SnocList (NF vars) -> Maybe (SnocList (Var vars)) +getVars got [<] = Just [<] +getVars got (xs :< NErased fc (Dotted t)) = getVars got (xs :< t) +getVars got (xs :< NApp fc (NLocal r idx v) [<]) = if inArgs idx got then Nothing else do xs' <- getVars (idx :: got) xs - pure (MkVar v :: xs') + pure (xs' :< MkVar v) where -- Save the overhead of the call to APPLY, and the fact that == on -- Nat is linear time in Idris 1! @@ -294,35 +305,39 @@ getVars got (NApp fc (NLocal r idx v) [] :: xs) inArgs n [] = False inArgs n (n' :: ns) = natToInteger n == natToInteger n' || inArgs n ns -getVars got (NAs _ _ _ p :: xs) = getVars got (p :: xs) -getVars _ (_ :: xs) = Nothing +getVars got (xs :< NAs _ _ _ p) = getVars got (xs :< p) +getVars _ (xs :< _) = Nothing -- Make a sublist representing the variables used in the application. -- We'll use this to ensure that local variables which appear in a term -- are all arguments to a metavariable application for pattern unification -toThin : (vars : List Name) -> List (Var vars) -> +toSubVars : (vars : SnocList Name) -> SnocList (Var vars) -> (newvars ** Thin newvars vars) -toThin [] xs = ([] ** Refl) -toThin (n :: ns) xs +toSubVars [<] xs = ([<] ** Refl) +toSubVars (ns :< n) xs -- If there's a proof 'First' in 'xs', then 'n' should be kept, -- otherwise dropped -- (Remember: 'n' might be shadowed; looking for 'First' ensures we -- get the *right* proof that the name is in scope!) - = let (_ ** svs) = toThin ns (dropFirst xs) in + = let (_ ** svs) = toSubVars ns (dropFirst xs) in if anyFirst xs then (_ ** Keep svs) else (_ ** Drop svs) where - anyFirst : List (Var (n :: ns)) -> Bool - anyFirst [] = False - anyFirst (MkVar First :: xs) = True - anyFirst (MkVar (Later p) :: xs) = anyFirst xs + anyFirst : SnocList (Var (ns :< n)) -> Bool + anyFirst [<] = False + anyFirst (xs :< MkVar First) = True + anyFirst (xs :< MkVar (Later p)) = anyFirst xs -- Update the variable list to point into the sub environment -- (All of these will succeed because the Thin we have comes from -- the list of variable uses! It's not stated in the type, though.) -updateVars : List (Var {a = Name} vars) -> Thin newvars vars -> List (Var newvars) -updateVars vs th = mapMaybe (\ v => shrink v th) vs +updateVars : SnocList (Var {a = Name} vars) -> Thin newvars vars -> SnocList (Var newvars) +updateVars [<] svs = [<] +updateVars (ps :< p) svs + = case shrink p svs of + Nothing => updateVars ps svs + Just p' => updateVars ps svs :< p' {- Applying the pattern unification rule is okay if: * Arguments are all distinct local variables @@ -342,34 +357,34 @@ updateVars vs th = mapMaybe (\ v => shrink v th) vs patternEnv : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {vars : _} -> - Env Term vars -> List (Closure vars) -> - Core (Maybe (newvars ** (List (Var newvars), + Env Term vars -> SnocList (Closure vars) -> + Core (Maybe (newvars ** (SnocList (Var newvars), Thin newvars vars))) patternEnv {vars} env args = do defs <- get Ctxt empty <- clearDefs defs - args' <- traverse (evalArg empty) args + args' <- traverseSnocList (evalArg empty) args pure $ case getVars [] args' of Nothing => Nothing Just vs => - let (newvars ** svs) = toThin _ vs in + let (newvars ** svs) = toSubVars _ vs in Just (newvars ** (updateVars vs svs, svs)) -getVarsTm : List Nat -> List (Term vars) -> Maybe (List (Var vars)) -getVarsTm got [] = Just [] -getVarsTm got (Local fc r idx v :: xs) +getVarsTm : List Nat -> SnocList (Term vars) -> Maybe (SnocList (Var vars)) +getVarsTm got [<] = Just [<] +getVarsTm got (xs :< Local fc _ idx v) = if idx `elem` got then Nothing else do xs' <- getVarsTm (idx :: got) xs - pure (MkVar v :: xs') -getVarsTm _ (_ :: xs) = Nothing + pure (xs' :< MkVar v) +getVarsTm _ (xs :< _) = Nothing export patternEnvTm : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {vars : _} -> - Env Term vars -> List (Term vars) -> - Core (Maybe (newvars ** (List (Var newvars), + Env Term vars -> SnocList (Term vars) -> + Core (Maybe (newvars ** (SnocList (Var newvars), Thin newvars vars))) patternEnvTm {vars} env args = do defs <- get Ctxt @@ -377,7 +392,7 @@ patternEnvTm {vars} env args pure $ case getVarsTm [] args of Nothing => Nothing Just vs => - let (newvars ** svs) = toThin _ vs in + let (newvars ** svs) = toSubVars _ vs in Just (newvars ** (updateVars vs svs, svs)) -- Check that the metavariable name doesn't occur in the solution. @@ -417,10 +432,10 @@ occursCheck fc env mode mname tm -- How the variables in a metavariable definition map to the variables in -- the solution term (the Var newvars) -data IVars : List Name -> List Name -> Type where - INil : IVars [] newvars +data IVars : SnocList Name -> SnocList Name -> Type where + INil : IVars [<] newvars ICons : Maybe (Var newvars) -> IVars vs newvars -> - IVars (v :: vs) newvars + IVars (vs :< v) newvars Weaken (IVars vs) where weakenNs s INil = INil @@ -445,20 +460,20 @@ tryInstantiate : {auto c : Ref Ctxt Defs} -> Term newvars -> -- shrunk environment Core Bool -- postpone if the type is yet unknown tryInstantiate {newvars} loc mode env mname mref num mdef locs otm tm - = do logTerm "unify.instantiate" 5 ("Instantiating in " ++ show newvars) tm + = do logTerm "unify.instantiate" 5 ("Instantiating in " ++ show !(traverse toFullNames (reverse $ toList newvars))) !(toFullNames tm) -- let Hole _ _ = definition mdef -- | def => ufail {a=()} loc (show mname ++ " already resolved as " ++ show def) case fullname mdef of PV pv pi => throw (PatternVariableUnifies loc (getLoc otm) env (PV pv pi) otm) _ => pure () defs <- get Ctxt - ty <- normalisePis defs [] $ type mdef + ty <- normalisePis defs [<] $ type mdef -- make sure we have all the pi binders we need in the -- type to make the metavariable definition - logTerm "unify.instantiate" 5 ("Type: " ++ show mname) (type mdef) + logTerm "unify.instantiate" 5 ("Type: " ++ show !(toFullNames mname)) (type mdef) logTerm "unify.instantiate" 5 ("Type: " ++ show mname) ty log "unify.instantiate" 5 ("With locs: " ++ show locs) - log "unify.instantiate" 5 ("From vars: " ++ show newvars) + log "unify.instantiate" 5 ("From vars: " ++ show (reverse $ toList newvars)) defs <- get Ctxt -- Try to instantiate the hole @@ -472,7 +487,7 @@ tryInstantiate {newvars} loc mode env mname mref num mdef locs otm tm (not (isUserName mname) && isSimple rhs) False let newdef = { definition := - PMDef simpleDef [] (STerm 0 rhs) (STerm 0 rhs) [] + PMDef simpleDef [<] (STerm 0 rhs) (STerm 0 rhs) [] } mdef ignore $ addDef (Resolved mref) newdef removeHole mref @@ -600,7 +615,8 @@ updateSolution : {vars : _} -> Env Term vars -> Term vars -> Term vars -> Core Bool updateSolution env (Meta fc mname idx args) soln = do defs <- get Ctxt - case !(patternEnvTm env args) of + -- See [Note] Meta args + case !(patternEnvTm env (cast args)) of Nothing => pure False Just (newvars ** (locs, submv)) => case shrink soln submv of @@ -608,7 +624,7 @@ updateSolution env (Meta fc mname idx args) soln Just stm => do Just hdef <- lookupCtxtExact (Resolved idx) (gamma defs) | Nothing => throw (InternalError "Can't happen: no definition") - tryInstantiate fc inTerm env mname idx (length args) hdef locs soln stm + tryInstantiate fc inTerm env mname idx (length args) hdef (toList locs) soln stm updateSolution env metavar soln = pure False @@ -653,13 +669,13 @@ mutual getArgTypes : {vars : _} -> {auto c : Ref Ctxt Defs} -> - Defs -> (fnType : NF vars) -> List (Closure vars) -> - Core (Maybe (List (NF vars))) - getArgTypes defs (NBind _ n (Pi _ _ _ ty) sc) (a :: as) + Defs -> (fnType : NF vars) -> SnocList (Closure vars) -> + Core (Maybe (SnocList (NF vars))) + getArgTypes defs (NBind _ n (Pi _ _ _ ty) sc) (as :< a) = do Just scTys <- getArgTypes defs !(sc defs a) as | Nothing => pure Nothing - pure (Just (!(evalClosure defs ty) :: scTys)) - getArgTypes _ _ [] = pure (Just []) + pure (Just (scTys :< !(evalClosure defs ty))) + getArgTypes _ _ [<] = pure (Just [<]) getArgTypes _ _ _ = pure Nothing headsConvert : {vars : _} -> @@ -667,11 +683,11 @@ mutual {auto u : Ref UST UState} -> UnifyInfo -> FC -> Env Term vars -> - Maybe (List (NF vars)) -> Maybe (List (NF vars)) -> + Maybe (SnocList (NF vars)) -> Maybe (SnocList (NF vars)) -> Core Bool headsConvert mode fc env (Just vs) (Just ns) = case (reverse vs, reverse ns) of - (v :: _, n :: _) => + (_ :< v, _ :< n) => do logNF "unify.head" 10 "Unifying head" env v logNF "unify.head" 10 ".........with" env n res <- unify mode fc env v n @@ -689,11 +705,11 @@ mutual (swaporder : Bool) -> UnifyInfo -> FC -> Env Term vars -> (metaname : Name) -> (metaref : Int) -> - (margs : List (Closure vars)) -> - (margs' : List (Closure vars)) -> + (margs : SnocList (Closure vars)) -> + (margs' : SnocList (Closure vars)) -> Maybe ClosedTerm -> - (List (FC, Closure vars) -> NF vars) -> - List (FC, Closure vars) -> + (SnocList (FC, Closure vars) -> NF vars) -> + SnocList (FC, Closure vars) -> Core UnifyResult unifyInvertible swap mode fc env mname mref margs margs' nty con args' = do defs <- get Ctxt @@ -701,44 +717,45 @@ mutual -- argument types match up Just vty <- lookupTyExact (Resolved mref) (gamma defs) | Nothing => ufail fc ("No such metavariable " ++ show mname) - vargTys <- getArgTypes defs !(nf defs env (embed vty)) (margs ++ margs') + vargTys <- getArgTypes defs !(nf defs env (embed vty)) (reverse $ margs ++ margs') nargTys <- maybe (pure Nothing) - (\ty => getArgTypes defs !(nf defs env (embed ty)) $ map snd args') + (\ty => getArgTypes defs !(nf defs env (embed ty)) $ (reverse $ map snd args')) nty + log "unify.invertible" 10 "Unifying invertible vty: \{show vty}, vargTys: \{show $ map asList vargTys}, nargTys: \{show $ map asList nargTys}" -- If the rightmost arguments have the same type, or we don't -- know the types of the arguments, we'll get on with it. if !(headsConvert mode fc env vargTys nargTys) then -- Unify the rightmost arguments, with the goal of turning the -- hole application into a pattern form - case (reverse margs', reverse args') of - (h :: hargs, f :: fargs) => + case (margs', args') of + (hargs :< h, fargs :< f) => tryUnify (if not swap then do log "unify.invertible" 10 "Unifying invertible" ures <- unify mode fc env h (snd f) log "unify.invertible" 10 $ "Constraints " ++ show (constraints ures) uargs <- unify mode fc env - (NApp fc (NMeta mname mref margs) (reverse $ map (EmptyFC,) hargs)) - (con (reverse fargs)) + (NApp fc (NMeta mname mref (map (EmptyFC,) margs)) (map (EmptyFC,) hargs)) + (con fargs) pure (union ures uargs) else do log "unify.invertible" 10 "Unifying invertible" ures <- unify mode fc env (snd f) h log "unify.invertible" 10 $ "Constraints " ++ show (constraints ures) uargs <- unify mode fc env - (con (reverse fargs)) - (NApp fc (NMeta mname mref margs) (reverse $ map (EmptyFC,) hargs)) + (con fargs) + (NApp fc (NMeta mname mref (map (EmptyFC,) margs)) (map (EmptyFC,) hargs)) pure (union ures uargs)) (postponeS swap fc mode "Postponing hole application [1]" env - (NApp fc (NMeta mname mref margs) $ map (EmptyFC,) margs') + (NApp fc (NMeta mname mref (map (EmptyFC,) margs)) $ (map (EmptyFC,) margs')) (con args')) _ => postponeS swap fc mode "Postponing hole application [2]" env - (NApp fc (NMeta mname mref margs) (map (EmptyFC,) margs')) + (NApp fc (NMeta mname mref (map (EmptyFC,) margs)) (map (EmptyFC,) margs')) (con args') else -- TODO: Cancellable function applications postpone fc mode "Postponing hole application [3]" env - (NApp fc (NMeta mname mref margs) (map (EmptyFC,) margs')) (con args') + (NApp fc (NMeta mname mref (map (EmptyFC,) margs)) (map (EmptyFC,) margs')) (con args') -- Unify a hole application - we have already checked that the hole is -- invertible (i.e. it's a determining argument to a proof search where @@ -749,8 +766,8 @@ mutual (swaporder : Bool) -> UnifyInfo -> FC -> Env Term vars -> (metaname : Name) -> (metaref : Int) -> - (margs : List (Closure vars)) -> - (margs' : List (Closure vars)) -> + (margs : SnocList (Closure vars)) -> + (margs' : SnocList (Closure vars)) -> NF vars -> Core UnifyResult unifyHoleApp swap mode loc env mname mref margs margs' (NTCon nfc n t a args') @@ -773,7 +790,7 @@ mutual then unifyInvertible swap (lower mode) loc env mname mref margs margs' Nothing (NApp nfc (NMeta n i margs2)) args2' else postponeS swap loc mode "Postponing hole application" env - (NApp loc (NMeta mname mref margs) $ map (EmptyFC,) margs') tm + (NApp loc (NMeta mname mref (map (EmptyFC,) margs)) $ map (EmptyFC,) margs') tm where isPatName : Name -> Bool isPatName (PV _ _) = True @@ -781,7 +798,7 @@ mutual unifyHoleApp swap mode loc env mname mref margs margs' tm = postponeS swap loc mode "Postponing hole application" env - (NApp loc (NMeta mname mref margs) $ map (EmptyFC,) margs') tm + (NApp loc (NMeta mname mref (map (EmptyFC,) margs)) $ map (EmptyFC,) margs') tm postponePatVar : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> @@ -789,12 +806,12 @@ mutual (swaporder : Bool) -> UnifyInfo -> FC -> Env Term vars -> (metaname : Name) -> (metaref : Int) -> - (margs : List (Closure vars)) -> - (margs' : List (Closure vars)) -> + (margs : SnocList (Closure vars)) -> + (margs' : SnocList (Closure vars)) -> (soln : NF vars) -> Core UnifyResult postponePatVar swap mode loc env mname mref margs margs' tm - = do let x = NApp loc (NMeta mname mref margs) (map (EmptyFC,) margs') + = do let x = NApp loc (NMeta mname mref (map (EmptyFC,) margs)) (map (EmptyFC,) margs') defs <- get Ctxt if !(convert defs env x tm) then pure success @@ -806,9 +823,9 @@ mutual {newvars, vars : _} -> FC -> UnifyInfo -> Env Term vars -> (metaname : Name) -> (metaref : Int) -> - (margs : List (Closure vars)) -> - (margs' : List (Closure vars)) -> - List (Var newvars) -> + (margs : SnocList (Closure vars)) -> + (margs' : SnocList (Closure vars)) -> + SnocList (Var newvars) -> Thin newvars vars -> (solfull : Term vars) -> -- Original solution (soln : Term newvars) -> -- Solution with shrunk environment @@ -829,7 +846,7 @@ mutual -- metavariables) do Just hdef <- lookupCtxtExact (Resolved mref) (gamma defs) | Nothing => throw (InternalError ("Can't happen: Lost hole " ++ show mname)) - progress <- tryInstantiate loc mode env mname mref (length margs) hdef locs solfull stm + progress <- tryInstantiate loc mode env mname mref (length margs) hdef (toList locs) solfull stm pure $ toMaybe progress (solvedHole mref) where inNoSolve : Int -> IntMap () -> Bool @@ -851,23 +868,26 @@ mutual (swaporder : Bool) -> UnifyInfo -> FC -> Env Term vars -> FC -> (metaname : Name) -> (metaref : Int) -> - (args : List (Closure vars)) -> - (args' : List (Closure vars)) -> + (args : SnocList (Closure vars)) -> + (args' : SnocList (Closure vars)) -> (soln : NF vars) -> Core UnifyResult unifyHole swap mode loc env fc mname mref margs margs' tmnf = do defs <- get Ctxt empty <- clearDefs defs - let args = if isNil margs' then margs else margs ++ margs' + let args = if isLin margs' then cast margs else cast margs ++ margs' logC "unify.hole" 10 - (do args' <- traverse (evalArg empty) args - qargs <- traverse (quote empty env) args' + (do args' <- traverseSnocList (evalArg empty) args + -- [Note] Restore logging sequence + qargs <- map reverse $ traverse (quote empty env) (reverse args') qtm <- quote empty env tmnf - pure $ "Unifying: " ++ show mname ++ " " ++ show qargs ++ - " with " ++ show qtm) -- first attempt, try 'empty', only try 'defs' when on 'retry'? - case !(patternEnv env args) of + pure $ "Unifying: " ++ show !(toFullNames mname) ++ " " ++ show !(traverse toFullNames $ toList qargs) ++ + " with " ++ show !(toFullNames qtm)) -- first attempt, try 'empty', only try 'defs' when on 'retry'? + patEnv <- patternEnv env args + case patEnv of Nothing => - do Just hdef <- lookupCtxtExact (Resolved mref) (gamma defs) + do log "unify.hole" 10 $ "unifyHole patEnv: Nothing" + Just hdef <- lookupCtxtExact (Resolved mref) (gamma defs) | _ => postponePatVar swap mode loc env mname mref margs margs' tmnf let Hole _ _ = definition hdef | _ => postponePatVar swap mode loc env mname mref margs margs' tmnf @@ -875,11 +895,12 @@ mutual then unifyHoleApp swap mode loc env mname mref margs margs' tmnf else postponePatVar swap mode loc env mname mref margs margs' tmnf Just (newvars ** (locs, submv)) => - do Just hdef <- lookupCtxtExact (Resolved mref) (gamma defs) + do log "unify.hole" 10 $ "unifyHole patEnv newvars: \{show $ asList newvars}, locs: \{show $ toList locs}, submv: \{show submv}" + Just hdef <- lookupCtxtExact (Resolved mref) (gamma defs) | _ => postponePatVar swap mode loc env mname mref margs margs' tmnf let Hole _ _ = definition hdef | _ => postponeS swap loc mode "Delayed hole" env - (NApp loc (NMeta mname mref margs) $ map (EmptyFC,) margs') + (NApp loc (NMeta mname mref (map (EmptyFC,) margs)) $ map (EmptyFC,) margs') tmnf let qopts = MkQuoteOpts False False (Just defs.options.elabDirectives.nfThreshold) @@ -888,7 +909,7 @@ mutual (\err => quote defs env tmnf) Just tm <- occursCheck loc env mode mname tm | _ => postponeS swap loc mode "Occurs check failed" env - (NApp loc (NMeta mname mref margs) $ map (EmptyFC,) margs') + (NApp loc (NMeta mname mref (map (EmptyFC,) margs)) $ map (EmptyFC,) margs') tmnf let solveOrElsePostpone : Term newvars -> Core UnifyResult @@ -898,7 +919,7 @@ mutual tm stm tmnf flip fromMaybe (pure <$> mbResult) $ postponeS swap loc mode "Can't instantiate" env - (NApp loc (NMeta mname mref margs) $ map (EmptyFC,) margs') tmnf + (NApp loc (NMeta mname mref (map (EmptyFC,) margs)) $ map (EmptyFC,) margs') tmnf case shrink tm submv of Just stm => solveOrElsePostpone stm @@ -906,7 +927,7 @@ mutual do tm' <- quote defs env tmnf case shrink tm' submv of Nothing => postponeS swap loc mode "Can't shrink" env - (NApp loc (NMeta mname mref margs) $ map (EmptyFC,) margs') + (NApp loc (NMeta mname mref (map (EmptyFC,) margs)) $ map (EmptyFC,) margs') tmnf Just stm => solveOrElsePostpone stm @@ -917,12 +938,12 @@ mutual (swaporder : Bool) -> -- swap the order when postponing -- (this is to preserve second arg being expected type) UnifyInfo -> FC -> Env Term vars -> FC -> - NHead vars -> List (FC, Closure vars) -> NF vars -> + NHead vars -> SnocList (FC, Closure vars) -> NF vars -> Core UnifyResult unifyApp swap mode loc env fc (NMeta n i margs) args tm - = unifyHole swap mode loc env fc n i margs (map snd args) tm + = unifyHole swap mode loc env fc n i (map snd margs) (map snd args) tm unifyApp swap mode loc env fc hd args (NApp mfc (NMeta n i margs) margs') - = unifyHole swap mode loc env mfc n i margs (map snd margs') (NApp fc hd args) + = unifyHole swap mode loc env mfc n i (map snd margs) (map snd margs') (NApp fc hd args) unifyApp swap mode loc env fc hd args (NErased _ (Dotted t)) = unifyApp swap mode loc env fc hd args t -- Postpone if a name application against an application, unless they are @@ -932,12 +953,12 @@ mutual if not swap then unifyIfEq True loc mode env (NApp fc (NRef nt n) args) tm else unifyIfEq True loc mode env tm (NApp fc (NRef nt n) args) - unifyApp swap mode loc env xfc (NLocal rx x xp) [] (NApp yfc (NLocal ry y yp) []) + unifyApp swap mode loc env xfc (NLocal rx x xp) [<] (NApp yfc (NLocal ry y yp) [<]) = do gam <- get Ctxt if x == y then pure success else postponeS swap loc mode "Postponing var" - env (NApp xfc (NLocal rx x xp) []) - (NApp yfc (NLocal ry y yp) []) + env (NApp xfc (NLocal rx x xp) [<]) + (NApp yfc (NLocal ry y yp) [<]) -- A local against something canonical (binder or constructor) is bad unifyApp swap mode loc env xfc (NLocal rx x xp) args y@(NBind _ _ _ _) = convertErrorS swap loc env (NApp xfc (NLocal rx x xp) args) y @@ -968,19 +989,19 @@ mutual {auto u : Ref UST UState} -> {vars : _} -> UnifyInfo -> FC -> Env Term vars -> - FC -> NHead vars -> List (FC, Closure vars) -> - FC -> NHead vars -> List (FC, Closure vars) -> + FC -> NHead vars -> SnocList (FC, Closure vars) -> + FC -> NHead vars -> SnocList (FC, Closure vars) -> Core UnifyResult - unifyBothApps mode loc env xfc (NLocal xr x xp) [] yfc (NLocal yr y yp) [] + unifyBothApps mode loc env xfc (NLocal xr x xp) [<] yfc (NLocal yr y yp) [<] = if x == y then pure success - else convertError loc env (NApp xfc (NLocal xr x xp) []) - (NApp yfc (NLocal yr y yp) []) + else convertError loc env (NApp xfc (NLocal xr x xp) [<]) + (NApp yfc (NLocal yr y yp) [<]) -- Locally bound things, in a term (not LHS). Since we have to unify -- for *all* possible values, we can safely unify the arguments. unifyBothApps mode@(MkUnifyInfo p InTerm) loc env xfc (NLocal xr x xp) xargs yfc (NLocal yr y yp) yargs = if x == y - then unifyArgs mode loc env (map snd xargs) (map snd yargs) + then unifyArgs mode loc env (reverse $ map snd xargs) (reverse $ map snd yargs) else postpone loc mode "Postponing local app" env (NApp xfc (NLocal xr x xp) xargs) (NApp yfc (NLocal yr y yp) yargs) @@ -994,8 +1015,8 @@ mutual if xi == yi && (invx || umode mode == InSearch) -- Invertible, (from auto implicit search) -- so we can also unify the arguments. - then unifyArgs mode loc env (xargs ++ map snd xargs') - (yargs ++ map snd yargs') + then unifyArgs mode loc env (reverse $ map snd $ xargs' ++ xargs) + (reverse $ map snd $ yargs' ++ yargs) else do xlocs <- localsIn xargs ylocs <- localsIn yargs -- Solve the one with the bigger context, and if they're @@ -1014,9 +1035,9 @@ mutual pv (PV _ _) = True pv _ = False - localsIn : List (Closure vars) -> Core Nat - localsIn [] = pure 0 - localsIn (c :: cs) + localsIn : SnocList (FC, Closure vars) -> Core Nat + localsIn [<] = pure 0 + localsIn (cs :< (_, c)) = do defs <- get Ctxt case !(evalClosure defs c) of NApp _ (NLocal _ _ _) _ => pure $ S !(localsIn cs) @@ -1033,7 +1054,7 @@ mutual (NApp yfc (NMeta yn yi yargs) yargs') unifyBothApps mode@(MkUnifyInfo p InSearch) loc env xfc fx@(NRef xt hdx) xargs yfc fy@(NRef yt hdy) yargs = if hdx == hdy - then unifyArgs mode loc env (map snd xargs) (map snd yargs) + then unifyArgs mode loc env (reverse $ map snd xargs) (reverse $ map snd yargs) else unifyApp False mode loc env xfc fx xargs (NApp yfc fy yargs) unifyBothApps mode@(MkUnifyInfo p InMatch) loc env xfc fx@(NRef xt hdx) xargs yfc fy@(NRef yt hdy) yargs = if hdx == hdy @@ -1042,7 +1063,7 @@ mutual xs <- traverse (quote defs env) (map snd xargs) ys <- traverse (quote defs env) (map snd yargs) pure ("Matching args " ++ show xs ++ " " ++ show ys)) - unifyArgs mode loc env (map snd xargs) (map snd yargs) + unifyArgs mode loc env (reverse $ map snd xargs) (reverse $ map snd yargs) else unifyApp False mode loc env xfc fx xargs (NApp yfc fy yargs) unifyBothApps mode loc env xfc fx ax yfc fy ay = unifyApp False mode loc env xfc fx ax (NApp yfc fy ay) @@ -1070,8 +1091,8 @@ mutual pure ("Unifying arg types " ++ show tx' ++ " and " ++ show ty')) ct <- unify (lower mode) loc env tx ty xn <- genVarName "x" - let env' : Env Term (x :: _) - = Pi fcy cy Explicit tx' :: env + let env' : Env Term (_ :< x) + = env :< Pi fcy cy Explicit tx' case constraints ct of [] => -- No constraints, check the scope do tscx <- scx defs (toClosure defaultOpts env (Ref loc Bound xn)) @@ -1107,8 +1128,8 @@ mutual ct <- unify (lower mode) loc env tx ty xn <- genVarName "x" txtm <- quote empty env tx - let env' : Env Term (x :: _) - = Lam fcx cx Explicit txtm :: env + let env' : Env Term (_ :< x) + = env :< Lam fcx cx Explicit txtm tscx <- scx defs (toClosure defaultOpts env (Ref loc Bound xn)) tscy <- scy defs (toClosure defaultOpts env (Ref loc Bound xn)) @@ -1129,14 +1150,15 @@ mutual dumpArg env (MkClosure opts loc lenv tm) = do defs <- get Ctxt empty <- clearDefs defs - logTerm "unify" 20 "Term: " tm + logTerm "unify" 20 "MkClosure Term: " tm nf <- evalClosure empty (MkClosure opts loc lenv tm) - logNF "unify" 20 " " env nf - dumpArg env cl + logNF "unify" 20 "MkClosure NF: " env nf + dumpArg env cl@(MkNFClosure opts lenv nf) = do defs <- get Ctxt empty <- clearDefs defs - nf <- evalClosure empty cl - logNF "unify" 20 " " env nf + logNF "unify" 20 "MkNFClosure NF: " lenv nf + nf' <- evalClosure empty cl + logNF "unify" 20 "MkNFClosure NF': " env nf' export unifyNoEta : {auto c : Ref Ctxt Defs} -> @@ -1161,7 +1183,7 @@ mutual log "unify" 20 "WITH:" traverse_ (dumpArg env) ys -} - unifyArgs mode loc env (map snd xs) (map snd ys) + unifyArgs mode loc env (reverse $ map snd xs) (reverse $ map snd ys) else convertError loc env (NDCon xfc x tagx ax xs) (NDCon yfc y tagy ay ys) @@ -1171,13 +1193,14 @@ mutual y <- toFullNames y pure $ "Comparing type constructors " ++ show x ++ " and " ++ show y if x == y - then do let xs = map snd xs - let ys = map snd ys + then do -- [Note] Restore logging sequence + let xs = reverse $ map snd xs + let ys = reverse $ map snd ys logC "unify" 20 $ pure $ "Constructor " ++ show x - logC "unify" 20 $ map (const "") $ traverse_ (dumpArg env) xs - logC "unify" 20 $ map (const "") $ traverse_ (dumpArg env) ys + logC "unify" 20 $ map (const "xs ↑") $ traverse_ (dumpArg env) $ xs + logC "unify" 20 $ map (const "ys ↑") $ traverse_ (dumpArg env) $ ys unifyArgs mode loc env xs ys -- TODO: Type constructors are not necessarily injective. -- If we don't know it's injective, need to postpone the @@ -1192,10 +1215,10 @@ mutual unifyNoEta mode loc env (NDelayed xfc _ x) (NDelayed yfc _ y) = unify (lower mode) loc env x y unifyNoEta mode loc env (NDelay xfc _ xty x) (NDelay yfc _ yty y) - = unifyArgs mode loc env [xty, x] [yty, y] + = unifyArgs mode loc env [ handleUnify (do tm <- search loc rig (smode == Defaults) depth defining - (type def) [] - let gdef = { definition := PMDef defaultPI [] (STerm 0 tm) (STerm 0 tm) [] } def - logTermNF "unify.retry" 5 ("Solved " ++ show hname) [] tm + (type def) [<] + let gdef = { definition := PMDef defaultPI [<] (STerm 0 tm) (STerm 0 tm) [] } def + logTermNF "unify.retry" 5 ("Solved " ++ show hname) [<] tm ignore $ addDef (Resolved hid) gdef removeGuess hid pure True) @@ -1454,13 +1477,13 @@ retryGuess mode smode (hid, (loc, hname)) err => do logTermNF "unify.retry" 5 ("Search failed at " ++ show rig ++ " for " ++ show hname) - [] (type def) + [<] (type def) case smode of LastChance => throw err _ => if recoverable err then pure False -- Postpone again else throw (CantSolveGoal loc (gamma defs) - [] (type def) (Just err)) + [<] (type def) (Just err)) Guess tm envb [constr] => do let umode = case smode of MatchArgs => inMatch @@ -1471,11 +1494,11 @@ retryGuess mode smode (hid, (loc, hname)) NoLazy => pure tm AddForce r => pure $ forceMeta r envb tm AddDelay r => - do ty <- getType [] tm + do ty <- getType [<] tm logTerm "unify.retry" 5 "Retry Delay" tm pure $ delayMeta r envb !(getTerm ty) tm let gdef = { definition := PMDef (MkPMDefInfo NotHole True False) - [] (STerm 0 tm') (STerm 0 tm') [] } def + [<] (STerm 0 tm') (STerm 0 tm') [] } def logTerm "unify.retry" 5 ("Resolved " ++ show hname) tm' ignore $ addDef (Resolved hid) gdef removeGuess hid @@ -1484,7 +1507,7 @@ retryGuess mode smode (hid, (loc, hname)) NoLazy => pure tm AddForce r => pure $ forceMeta r envb tm AddDelay r => - do ty <- getType [] tm + do ty <- getType [<] tm logTerm "unify.retry" 5 "Retry Delay (constrained)" tm pure $ delayMeta r envb !(getTerm ty) tm let gdef = { definition := Guess tm' envb newcs } def @@ -1501,7 +1524,7 @@ retryGuess mode smode (hid, (loc, hname)) -- proper definition and remove it from the -- hole list [] => do let gdef = { definition := PMDef (MkPMDefInfo NotHole True False) - [] (STerm 0 tm) (STerm 0 tm) [] } def + [<] (STerm 0 tm) (STerm 0 tm) [] } def logTerm "unify.retry" 5 ("Resolved " ++ show hname) tm ignore $ addDef (Resolved hid) gdef removeGuess hid @@ -1564,7 +1587,7 @@ checkArgsSame : {auto u : Ref UST UState} -> checkArgsSame [] = pure False checkArgsSame (x :: xs) = do defs <- get Ctxt - Just (PMDef _ [] (STerm 0 def) _ _) <- + Just (PMDef _ [<] (STerm 0 def) _ _) <- lookupDefExact (Resolved x) (gamma defs) | _ => checkArgsSame xs s <- anySame def xs @@ -1572,14 +1595,14 @@ checkArgsSame (x :: xs) then pure True else checkArgsSame xs where - anySame : Term [] -> List Int -> Core Bool + anySame : Term [<] -> List Int -> Core Bool anySame tm [] = pure False anySame tm (t :: ts) = do defs <- get Ctxt - Just (PMDef _ [] (STerm 0 def) _ _) <- + Just (PMDef _ [<] (STerm 0 def) _ _) <- lookupDefExact (Resolved t) (gamma defs) | _ => anySame tm ts - if !(convert defs [] tm def) + if !(convert defs [<] tm def) then pure True else anySame tm ts @@ -1594,10 +1617,10 @@ checkDots hs <- getCurrentHoles update UST { dotConstraints := [] } where - getHoleName : Term [] -> Core (Maybe Name) + getHoleName : Term [<] -> Core (Maybe Name) getHoleName tm = do defs <- get Ctxt - NApp _ (NMeta n' i args) _ <- nf defs [] tm + NApp _ (NMeta n' i args) _ <- nf defs [<] tm | _ => pure Nothing pure (Just n') @@ -1651,7 +1674,7 @@ checkDots do defs <- get Ctxt Just dty <- lookupTyExact n (gamma defs) | Nothing => undefinedName fc n - logTermNF "unify.constraint" 5 "Dot type" [] dty + logTermNF "unify.constraint" 5 "Dot type" [<] dty -- Clear constraints so we don't report again -- later put UST ({ dotConstraints := [] } ust) diff --git a/src/Core/UnifyState.idr b/src/Core/UnifyState.idr index 84744155b9..e8a5d00a9e 100644 --- a/src/Core/UnifyState.idr +++ b/src/Core/UnifyState.idr @@ -13,6 +13,7 @@ import Core.TTC import Core.Value import Data.List +import Data.SnocList import Libraries.Data.IntMap import Libraries.Data.NameMap import Libraries.Data.WithDefault @@ -316,87 +317,94 @@ addPolyConstraint fc env arg x@(NApp _ (NMeta _ _ _) _) y addPolyConstraint fc env arg x y = pure () -mkLocal : {wkns : SnocList Name} -> FC -> Binder (Term vars) -> Term (wkns <>> x :: (vars ++ done)) -mkLocal fc b = Local fc (Just (isLet b)) _ (mkIsVarChiply (mkHasLength wkns)) +mkLocal : {wkns : SnocList Name} -> FC -> Binder (Term vars) -> Term (((done ++ vars) :< x ++ wkns)) +mkLocal fc b = Local fc (Just (isLet b)) _ (mkIsVar (mkHasLength wkns)) mkConstantAppArgs : {vars : _} -> Bool -> FC -> Env Term vars -> (wkns : SnocList Name) -> - List (Term (wkns <>> (vars ++ done))) -mkConstantAppArgs lets fc [] wkns = [] -mkConstantAppArgs {done} {vars = x :: xs} lets fc (b :: env) wkns - = let rec = mkConstantAppArgs {done} lets fc env (wkns :< x) in + List (Term ((done ++ vars) ++ wkns)) +mkConstantAppArgs lets fc [<] wkns = [] +mkConstantAppArgs {done} {vars = xs :< x} lets fc (env :< b) wkns + = let rec = mkConstantAppArgs {done} lets fc env (cons x wkns) in if lets || not (isLet b) - then mkLocal fc b :: rec - else rec + then mkLocal fc b :: + rewrite sym $ appendAssociative (done ++ xs) [ Bool -> FC -> Env Term vars -> Thin smaller vars -> (wkns : SnocList Name) -> - List (Term (wkns <>> (vars ++ done))) -mkConstantAppArgsSub lets fc [] p wkns = [] -mkConstantAppArgsSub {done} {vars = x :: xs} - lets fc (b :: env) Refl wkns - = mkConstantAppArgs lets fc env (wkns :< x) -mkConstantAppArgsSub {done} {vars = x :: xs} - lets fc (b :: env) (Drop p) wkns - = mkConstantAppArgsSub lets fc env p (wkns :< x) -mkConstantAppArgsSub {done} {vars = x :: xs} - lets fc (b :: env) (Keep p) wkns - = let rec = mkConstantAppArgsSub {done} lets fc env p (wkns :< x) in + List (Term ((done ++ vars) ++ wkns)) +mkConstantAppArgsSub lets fc [<] p wkns = [] +mkConstantAppArgsSub {done} {vars = xs :< x} + lets fc (env :< b) Refl wkns + = rewrite sym $ appendAssociative (done ++ xs) [ Bool -> FC -> Env Term vars -> Thin smaller vars -> (wkns : SnocList Name) -> - List (Term (wkns <>> (vars ++ done))) -mkConstantAppArgsOthers lets fc [] p wkns = [] -mkConstantAppArgsOthers {done} {vars = x :: xs} - lets fc (b :: env) Refl wkns - = mkConstantAppArgsOthers lets fc env Refl (wkns :< x) -mkConstantAppArgsOthers {done} {vars = x :: xs} - lets fc (b :: env) (Keep p) wkns - = mkConstantAppArgsOthers lets fc env p (wkns :< x) -mkConstantAppArgsOthers {done} {vars = x :: xs} - lets fc (b :: env) (Drop p) wkns - = let rec = mkConstantAppArgsOthers {done} lets fc env p (wkns :< x) in + List (Term ((done ++ vars) ++ wkns)) +mkConstantAppArgsOthers lets fc [<] p wkns = [] +mkConstantAppArgsOthers {done} {vars = xs :< x} + lets fc (env :< b) Refl wkns + = rewrite sym $ appendAssociative (done ++ xs) [ FC -> Term vars -> Env Term vars -> Term vars applyTo fc tm env - = let args = reverse (mkConstantAppArgs {done = []} False fc env [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + = let args = reverse (mkConstantAppArgs {done = [<]} False fc env [<]) in + apply fc tm (rewrite sym (appendLinLeftNeutral vars) in args) export applyToFull : {vars : _} -> FC -> Term vars -> Env Term vars -> Term vars applyToFull fc tm env - = let args = reverse (mkConstantAppArgs {done = []} True fc env [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + = let args = reverse (mkConstantAppArgs {done = [<]} True fc env [<]) in + apply fc tm (rewrite sym (appendLinLeftNeutral vars) in args) export applyToSub : {vars : _} -> FC -> Term vars -> Env Term vars -> Thin smaller vars -> Term vars applyToSub fc tm env sub - = let args = reverse (mkConstantAppArgsSub {done = []} True fc env sub [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + = let args = reverse (mkConstantAppArgsSub {done = [<]} True fc env sub [<]) in + apply fc tm (rewrite sym (appendLinLeftNeutral vars) in args) export applyToOthers : {vars : _} -> FC -> Term vars -> Env Term vars -> Thin smaller vars -> Term vars applyToOthers fc tm env sub - = let args = reverse (mkConstantAppArgsOthers {done = []} True fc env sub [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + = let args = reverse (mkConstantAppArgsOthers {done = [<]} True fc env sub [<]) in + apply fc tm (rewrite sym (appendLinLeftNeutral vars) in args) -- Create a new metavariable with the given name and return type, -- and return a term which is the metavariable applied to the environment @@ -415,16 +423,18 @@ newMetaLets {vars} fc rig env n ty def nocyc lets = do let hty = if lets then abstractFullEnvType fc env ty else abstractEnvType fc env ty let hole = { noCycles := nocyc } - (newDef fc n rig [] hty (specified Public) def) + (newDef fc n rig [<] hty (specified Public) def) log "unify.meta" 5 $ "Adding new meta " ++ show (n, fc, rig) logTerm "unify.meta" 10 ("New meta type " ++ show n) hty idx <- addDef n hole + let app = Meta fc n idx envArgs + logTerm "unify.meta" 10 ("New meta app " ++ show n) app addHoleName fc n idx - pure (idx, Meta fc n idx envArgs) + pure (idx, app) where envArgs : List (Term vars) - envArgs = let args = reverse (mkConstantAppArgs {done = []} lets fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + envArgs = let args = reverse (mkConstantAppArgs {done = [<]} lets fc env [<]) in + (rewrite sym (appendLinLeftNeutral vars) in args) export newMeta : {vars : _} -> @@ -438,10 +448,10 @@ newMeta fc r env n ty def cyc = newMetaLets fc r env n ty def cyc False mkConstant : {vars : _} -> FC -> Env Term vars -> Term vars -> ClosedTerm -mkConstant fc [] tm = tm +mkConstant fc [<] tm = tm -- mkConstant {vars = x :: _} fc (Let c val ty :: env) tm -- = mkConstant fc env (Bind fc x (Let c val ty) tm) -mkConstant {vars = x :: _} fc (b :: env) tm +mkConstant {vars = _ :< x} fc (env :< b) tm = let ty = binderType b in mkConstant fc env (Bind fc x (Lam fc (multiplicity b) Explicit ty) tm) @@ -460,7 +470,7 @@ newConstant {vars} fc rig env tm ty constrs = do let def = mkConstant fc env tm let defty = abstractFullEnvType fc env ty cn <- genName "postpone" - let guess = newDef fc cn rig [] defty (specified Public) + let guess = newDef fc cn rig [<] defty (specified Public) (Guess def (length env) constrs) log "unify.constant" 5 $ "Adding new constant " ++ show (cn, fc, rig) logTerm "unify.constant" 10 ("New constant type " ++ show cn) defty @@ -469,8 +479,8 @@ newConstant {vars} fc rig env tm ty constrs pure (Meta fc cn idx envArgs) where envArgs : List (Term vars) - envArgs = let args = reverse (mkConstantAppArgs {done = []} True fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + envArgs = let args = reverse (mkConstantAppArgs {done = [<]} True fc env [<]) in + rewrite sym $ appendLinLeftNeutral vars in args -- Create a new search with the given name and return type, -- and return a term which is the name applied to the environment @@ -483,16 +493,16 @@ newSearch : {vars : _} -> Env Term vars -> Name -> Term vars -> Core (Int, Term vars) newSearch {vars} fc rig depth def env n ty = do let hty = abstractEnvType fc env ty - let hole = newDef fc n rig [] hty (specified Public) (BySearch rig depth def) + let hole = newDef fc n rig [<] hty (specified Public) (BySearch rig depth def) log "unify.search" 10 $ "Adding new search " ++ show fc ++ " " ++ show n - logTermNF "unify.search" 10 "New search type" [] hty + logTermNF "unify.search" 10 "New search type" [<] hty idx <- addDef n hole addGuessName fc n idx pure (idx, Meta fc n idx envArgs) where envArgs : List (Term vars) - envArgs = let args = reverse (mkConstantAppArgs {done = []} False fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + envArgs = let args = reverse (mkConstantAppArgs {done = [<]} False fc env [<]) in + rewrite sym $ appendLinLeftNeutral vars in args -- Add a hole which stands for a delayed elaborator export @@ -504,15 +514,15 @@ newDelayed : {vars : _} -> (ty : Term vars) -> Core (Int, Term vars) newDelayed {vars} fc rig env n ty = do let hty = abstractEnvType fc env ty - let hole = newDef fc n rig [] hty (specified Public) Delayed + let hole = newDef fc n rig [<] hty (specified Public) Delayed idx <- addDef n hole log "unify.delay" 10 $ "Added delayed elaborator " ++ show (n, idx) addHoleName fc n idx pure (idx, Meta fc n idx envArgs) where envArgs : List (Term vars) - envArgs = let args = reverse (mkConstantAppArgs {done = []} False fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + envArgs = let args = reverse (mkConstantAppArgs {done = [<]} False fc env [<]) in + rewrite sym $ appendLinLeftNeutral vars in args export tryErrorUnify : {auto c : Ref Ctxt Defs} -> @@ -585,7 +595,7 @@ checkValidHole base (idx, (fc, n)) do defs <- get Ctxt Just ty <- lookupTyExact n (gamma defs) | Nothing => pure () - throw (CantSolveGoal fc (gamma defs) [] ty Nothing) + throw (CantSolveGoal fc (gamma defs) [<] ty Nothing) Guess tm envb (con :: _) => do ust <- get UST let Just c = lookup con (constraints ust) @@ -620,13 +630,13 @@ checkUserHolesAfter base now = do gs_map <- getGuesses let gs = toList gs_map log "unify.unsolved" 10 $ "Unsolved guesses " ++ show gs - traverse_ (checkValidHole base) gs + Core.Core.traverse_ (checkValidHole base) gs hs_map <- getCurrentHoles let hs = toList hs_map let hs' = if any isUserName (map (snd . snd) hs) then [] else hs when (now && not (isNil hs')) $ - throw (UnsolvedHoles (map snd (nubBy nameEq hs))) + throw (UnsolvedHoles (map snd (nubBy nameEq $ toList hs))) -- Note the hole names, to ensure they are resolved -- by the end of elaborating the current source file traverse_ addDelayedHoleName hs' @@ -655,51 +665,53 @@ dumpHole : {auto u : Ref UST UState} -> dumpHole str n hole = do ust <- get UST defs <- get Ctxt + depth <- getDepth case !(lookupCtxtExact (Resolved hole) (gamma defs)) of Nothing => pure () Just gdef => case (definition gdef, type gdef) of (Guess tm envb constraints, ty) => - do logString str n $ + do logString depth str n $ "!" ++ show !(getFullName (Resolved hole)) ++ " : " - ++ show !(toFullNames !(normaliseHoles defs [] ty)) + ++ show !(toFullNames !(normaliseHoles defs [<] ty)) ++ "\n\t = " - ++ show !(normaliseHoles defs [] tm) + ++ show !(normaliseHoles defs [<] tm) ++ "\n\twhen" traverse_ dumpConstraint constraints (Hole _ p, ty) => - logString str n $ + logString depth str n $ "?" ++ show (fullname gdef) ++ " : " - ++ show !(normaliseHoles defs [] ty) + ++ show !(normaliseHoles defs [<] ty) ++ if implbind p then " (ImplBind)" else "" ++ if invertible gdef then " (Invertible)" else "" (BySearch _ _ _, ty) => - logString str n $ + logString depth str n $ "Search " ++ show hole ++ " : " ++ - show !(toFullNames !(normaliseHoles defs [] ty)) + show !(toFullNames !(normaliseHoles defs [<] ty)) (PMDef _ args t _ _, ty) => log str 4 $ "Solved: " ++ show hole ++ " : " ++ - show !(normalise defs [] ty) ++ - " = " ++ show !(normalise defs [] (Ref emptyFC Func (Resolved hole))) + show !(normalise defs [<] ty) ++ + " = " ++ show !(normalise defs [<] (Ref emptyFC Func (Resolved hole))) (ImpBind, ty) => log str 4 $ "Bound: " ++ show hole ++ " : " ++ - show !(normalise defs [] ty) + show !(normalise defs [<] ty) (Delayed, ty) => log str 4 $ "Delayed elaborator : " ++ - show !(normalise defs [] ty) + show !(normalise defs [<] ty) _ => pure () where dumpConstraint : Int -> Core () dumpConstraint cid = do ust <- get UST defs <- get Ctxt + depth <- getDepth case lookup cid (constraints ust) of Nothing => pure () - Just Resolved => logString str n "\tResolved" + Just Resolved => logString depth str n "\tResolved" Just (MkConstraint _ lazy env x y) => - do logString str n $ + do logString depth str n $ "\t " ++ show !(toFullNames !(quote defs env x)) ++ " =?= " ++ show !(toFullNames !(quote defs env y)) empty <- clearDefs defs @@ -723,5 +735,6 @@ dumpConstraints str n all let hs = toList (guesses ust) ++ toList (if all then holes ust else currentHoles ust) unless (isNil hs) $ - do logString str n "--- CONSTRAINTS AND HOLES ---" + do depth <- getDepth + logString depth str n "--- CONSTRAINTS AND HOLES ---" traverse_ (dumpHole str n) (map fst hs) diff --git a/src/Core/Value.idr b/src/Core/Value.idr index 640e3ad169..5ae90d12fb 100644 --- a/src/Core/Value.idr +++ b/src/Core/Value.idr @@ -5,6 +5,8 @@ import Core.Core import Core.Env import Core.TT +import Data.SnocList + %default covering public export @@ -57,46 +59,52 @@ cbv = { strategy := CBV } defaultOpts mutual public export - data LocalEnv : List Name -> List Name -> Type where - Nil : LocalEnv free [] - (::) : Closure free -> LocalEnv free vars -> LocalEnv free (x :: vars) + data LocalEnv : SnocList Name -> SnocList Name -> Type where + Lin : LocalEnv free [<] + (:<) : LocalEnv free vars -> Closure free -> LocalEnv free (vars :< x) public export - data Closure : List Name -> Type where + data Closure : SnocList Name -> Type where MkClosure : {vars : _} -> (opts : EvalOpts) -> LocalEnv free vars -> Env Term free -> - Term (vars ++ free) -> Closure free + Term (free ++ vars) -> Closure free MkNFClosure : EvalOpts -> Env Term free -> NF free -> Closure free -- The head of a value: things you can apply arguments to public export - data NHead : List Name -> Type where + data NHead : SnocList Name -> Type where NLocal : Maybe Bool -> (idx : Nat) -> (0 p : IsVar nm idx vars) -> NHead vars NRef : NameType -> Name -> NHead vars - NMeta : Name -> Int -> List (Closure vars) -> NHead vars + NMeta : Name -> Int -> SnocList (FC, Closure vars) -> NHead vars + -- [Note] Meta args + -- ---------------- + -- We should use same strategy to process Meta<->NMeta across all occurencies. + -- For now direct strategy is used. It means Meta<->NMeta conversion happens + -- how lists are traversed. Which means in its own order that `cast` is enough + -- but it might be bad by performance. -- Values themselves. 'Closure' is an unevaluated thunk, which means -- we can wait until necessary to reduce constructor arguments public export - data NF : List Name -> Type where + data NF : SnocList Name -> Type where NBind : FC -> (x : Name) -> Binder (Closure vars) -> (Defs -> Closure vars -> Core (NF vars)) -> NF vars -- Each closure is associated with the file context of the App node that -- had it as an argument. It's necessary so as to not lose file context -- information when creating the normal form. - NApp : FC -> NHead vars -> List (FC, Closure vars) -> NF vars + NApp : FC -> NHead vars -> SnocList (FC, Closure vars) -> NF vars NDCon : FC -> Name -> (tag : Int) -> (arity : Nat) -> - List (FC, Closure vars) -> NF vars + SnocList (FC, Closure vars) -> NF vars NTCon : FC -> Name -> (tag : Int) -> (arity : Nat) -> - List (FC, Closure vars) -> NF vars + SnocList (FC, Closure vars) -> NF vars NAs : FC -> UseSide -> NF vars -> NF vars -> NF vars NDelayed : FC -> LazyReason -> NF vars -> NF vars NDelay : FC -> LazyReason -> Closure vars -> Closure vars -> NF vars - NForce : FC -> LazyReason -> NF vars -> List (FC, Closure vars) -> NF vars + NForce : FC -> LazyReason -> NF vars -> SnocList (FC, Closure vars) -> NF vars NPrimVal : FC -> Constant -> NF vars NErased : FC -> WhyErased (NF vars) -> NF vars NType : FC -> Name -> NF vars @@ -107,15 +115,35 @@ mutual %name NF nf export -ntCon : FC -> Name -> Int -> Nat -> List (FC, Closure vars) -> NF vars +ntCon : FC -> Name -> Int -> Nat -> SnocList (FC, Closure vars) -> NF vars -- Part of the machinery for matching on types - I believe this won't affect -- universe checking so put a dummy name. -ntCon fc (UN (Basic "Type")) tag Z [] = NType fc (MN "top" 0) -ntCon fc n tag Z [] = case isConstantType n of +ntCon fc (UN (Basic "Type")) tag Z [<] = NType fc (MN "top" 0) +ntCon fc n tag Z [<] = case isConstantType n of Just c => NPrimVal fc $ PrT c - Nothing => NTCon fc n tag Z [] + Nothing => NTCon fc n tag Z [<] ntCon fc n tag arity args = NTCon fc n tag arity args +export +(++) : LocalEnv free varsl -> LocalEnv free varsr -> LocalEnv free (varsl ++ varsr) +(++) sx Lin = sx +(++) sx (sy :< y) = (sx ++ sy) :< y + +export +reverseOnto : LocalEnv free varsl -> LocalEnv free varsr -> LocalEnv free (varsl ++ reverse varsr) +reverseOnto acc Lin = acc +reverseOnto {varsr=[<] :< r} acc ([<] :< x) = reverseOnto {varsl=varsl :< r} (acc :< x) [<] +reverseOnto {varsr=[<] :< vars :< r} acc (sx :< x) = reverseOnto {varsl=varsl :< r} (acc :< x) sx + +export +reverse : LocalEnv free vars -> LocalEnv free (reverse vars) +reverse {vars} = rewrite sym $ appendLinLeftNeutral (reverse vars) in reverseOnto Lin + +export +cons : LocalEnv free vars -> Closure free -> LocalEnv free (v `cons` vars) +cons [<] p = Lin :< p +cons (ns :< s) p = cons ns p :< s + export getLoc : NF vars -> FC getLoc (NBind fc _ _ _) = fc @@ -130,15 +158,6 @@ getLoc (NPrimVal fc _) = fc getLoc (NErased fc i) = fc getLoc (NType fc _) = fc -export -{free : _} -> Show (NHead free) where - show (NLocal _ idx p) = show (nameAt p) ++ "[" ++ show idx ++ "]" - show (NRef _ n) = show n - show (NMeta n _ args) = "?" ++ show n ++ "_[" ++ show (length args) ++ " closures]" - -Show (Closure free) where - show _ = "[closure]" - export HasNames (NHead free) where full defs (NRef nt n) = NRef nt <$> full defs n @@ -173,34 +192,57 @@ HasNames (NF free) where resolved defs (NErased fc imp) = pure $ NErased fc imp resolved defs (NType fc n) = pure $ NType fc !(resolved defs n) -export -covering -{free : _} -> Show (NF free) where - show (NBind _ x (Lam _ c info ty) _) - = "\\" ++ withPiInfo info (showCount c ++ show x ++ " : " ++ show ty) ++ - " => [closure]" - show (NBind _ x (Let _ c val ty) _) - = "let " ++ showCount c ++ show x ++ " : " ++ show ty ++ - " = " ++ show val ++ " in [closure]" - show (NBind _ x (Pi _ c info ty) _) - = withPiInfo info (showCount c ++ show x ++ " : " ++ show ty) ++ - " -> [closure]" - show (NBind _ x (PVar _ c info ty) _) - = withPiInfo info ("pat " ++ showCount c ++ show x ++ " : " ++ show ty) ++ - " => [closure]" - show (NBind _ x (PLet _ c val ty) _) - = "plet " ++ showCount c ++ show x ++ " : " ++ show ty ++ - " = " ++ show val ++ " in [closure]" - show (NBind _ x (PVTy _ c ty) _) - = "pty " ++ showCount c ++ show x ++ " : " ++ show ty ++ - " => [closure]" - show (NApp _ hd args) = show hd ++ " [" ++ show (length args) ++ " closures]" - show (NDCon _ n _ _ args) = show n ++ " [" ++ show (length args) ++ " closures]" - show (NTCon _ n _ _ args) = show n ++ " [" ++ show (length args) ++ " closures]" - show (NAs _ _ n tm) = show n ++ "@" ++ show tm - show (NDelayed _ _ tm) = "%Delayed " ++ show tm - show (NDelay _ _ _ _) = "%Delay [closure]" - show (NForce _ _ tm args) = "%Force " ++ show tm ++ " [" ++ show (length args) ++ " closures]" - show (NPrimVal _ c) = show c - show (NErased _ _) = "[__]" - show (NType _ _) = "Type" +mutual + export + covering + {free : _} -> Show (NHead free) where + show (NLocal _ idx p) = show (nameAt p) ++ "[" ++ show idx ++ "]" + show (NRef _ n) = show n + show (NMeta n _ args) = "?" ++ show n ++ "_[" ++ show (length args) ++ " closures " ++ showClosureSnocList args ++ "]" + + export + covering + {free : _} -> Show (Closure free) where + show (MkClosure _ _ _ tm) = "[closure] MkClosure: " ++ show tm + show (MkNFClosure _ _ tm) = "[closure] MkNFClosure: " ++ show tm + + export + covering + showClosureSnocList : {free : _} -> SnocList (FC, Closure free) -> String + showClosureSnocList xs = concat ("[" :: intersperse ", " (show' [] xs) ++ ["]"]) + where + show' : List String -> SnocList (FC, Closure free) -> List String + show' acc Lin = acc + show' acc (xs :< (_, x)) = show' (show x :: acc) xs + + export + covering + {free : _} -> Show (NF free) where + show (NBind _ x (Lam _ c info ty) _) + = "\\" ++ withPiInfo info (showCount c ++ show x ++ " : " ++ show ty) ++ + " => [closure]" + show (NBind _ x (Let _ c val ty) _) + = "let " ++ showCount c ++ show x ++ " : " ++ show ty ++ + " = " ++ show val ++ " in [closure]" + show (NBind _ x (Pi _ c info ty) _) + = withPiInfo info (showCount c ++ show x ++ " : " ++ show ty) ++ + " -> [closure]" + show (NBind _ x (PVar _ c info ty) _) + = withPiInfo info ("pat " ++ showCount c ++ show x ++ " : " ++ show ty) ++ + " => [closure]" + show (NBind _ x (PLet _ c val ty) _) + = "plet " ++ showCount c ++ show x ++ " : " ++ show ty ++ + " = " ++ show val ++ " in [closure]" + show (NBind _ x (PVTy _ c ty) _) + = "pty " ++ showCount c ++ show x ++ " : " ++ show ty ++ + " => [closure]" + show (NApp _ hd args) = show hd ++ " [" ++ show (length args) ++ " closures " ++ showClosureSnocList args ++ "]" + show (NDCon _ n _ _ args) = show n ++ " %DCon [" ++ show (length args) ++ " closures " ++ showClosureSnocList args ++ "]" + show (NTCon _ n _ _ args) = show n ++ " %TCon [" ++ show (length args) ++ " closures " ++ showClosureSnocList args ++ "]" + show (NAs _ _ n tm) = show n ++ "@" ++ show tm + show (NDelayed _ _ tm) = "%Delayed " ++ show tm + show (NDelay _ _ _ _) = "%Delay [closure]" + show (NForce _ _ tm args) = "%Force " ++ show tm ++ " [" ++ show (length args) ++ " closures " ++ showClosureSnocList args ++ "]" + show (NPrimVal _ c) = show c + show (NErased _ _) = "[__]" + show (NType _ _) = "Type" diff --git a/src/Idris/Doc/Display.idr b/src/Idris/Doc/Display.idr index aaeafd73af..972c66d9d9 100644 --- a/src/Idris/Doc/Display.idr +++ b/src/Idris/Doc/Display.idr @@ -24,13 +24,13 @@ displayType : {auto c : Ref Ctxt Defs} -> (shortName : Bool) -> Defs -> (Name, Int, GlobalDef) -> Core (Doc IdrisSyntax) displayType shortName defs (n, i, gdef) - = maybe (do tm <- resugar [] !(normaliseHoles defs [] (type gdef)) + = maybe (do tm <- resugar [<] !(normaliseHoles defs [<] (type gdef)) nm <- aliasName (fullname gdef) let nm = ifThenElse shortName (dropNS nm) nm let prig = prettyRig gdef.multiplicity let ann = showCategory id gdef pure (prig <+> ann (cast $ prettyOp True nm) <++> colon <++> pretty tm)) - (\num => prettyHole defs [] n num (type gdef)) + (\num => prettyHole defs [<] n num (type gdef)) (isHole gdef) export displayTerm : {auto c : Ref Ctxt Defs} -> @@ -38,7 +38,7 @@ displayTerm : {auto c : Ref Ctxt Defs} -> Defs -> ClosedTerm -> Core (Doc IdrisSyntax) displayTerm defs tm - = do ptm <- resugar [] !(normaliseHoles defs [] tm) + = do ptm <- resugar [<] !(normaliseHoles defs [<] tm) pure (pretty ptm) export diff --git a/src/Idris/Doc/String.idr b/src/Idris/Doc/String.idr index 4b99d76297..51e6d3f48d 100644 --- a/src/Idris/Doc/String.idr +++ b/src/Idris/Doc/String.idr @@ -88,15 +88,15 @@ prettyType : {auto c : Ref Ctxt Defs} -> (IdrisSyntax -> ann) -> ClosedTerm -> Core (Doc ann) prettyType syn ty = do defs <- get Ctxt - ty <- normaliseHoles defs [] ty + ty <- normaliseHoles defs [<] ty ty <- toFullNames ty - ty <- resugar [] ty + ty <- resugar [<] ty pure (prettyBy syn ty) ||| Look up implementations getImplDocs : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - (keep : Term [] -> Core Bool) -> + (keep : Term [<] -> Core Bool) -> Core (List (Doc IdrisDocAnn)) getImplDocs keep = do defs <- get Ctxt @@ -108,10 +108,10 @@ getImplDocs keep let Just Func = defNameType (definition def) | _ => pure [] -- Check that the type mentions the name of interest - ty <- toFullNames !(normaliseHoles defs [] (type def)) + ty <- toFullNames !(normaliseHoles defs [<] (type def)) True <- keep ty | False => pure [] - ty <- resugar [] ty + ty <- resugar [<] ty pure [annotate (Decl impl) $ prettyBy Syntax ty] pure $ case concat docss of [] => [] @@ -156,7 +156,7 @@ getDocsForPrimitive constant = do let (_, type) = checkPrim EmptyFC constant let typeString = prettyBy Syntax constant <++> colon - <++> prettyBy Syntax !(resugar [] type) + <++> prettyBy Syntax !(resugar [<] type) hintsDoc <- getHintsForPrimitive constant pure $ vcat $ typeString :: indent 2 (primDoc constant) @@ -451,7 +451,7 @@ getDocsForName fc n config (pure (Nothing, [])) -- Then form the type declaration - ty <- resugar [] =<< normaliseHoles defs [] (type def) + ty <- resugar [<] =<< normaliseHoles defs [<] (type def) -- when printing e.g. interface methods there is no point in -- repeating the interface's name let ty = ifThenElse (not dropFirst) ty $ case ty of @@ -504,7 +504,7 @@ getDocsForImplementation t = do -- get the return type of all the candidate hints Just (ix, def) <- lookupCtxtExactI hint (gamma defs) | Nothing => pure Nothing - ty <- resugar [] =<< normaliseHoles defs [] (type def) + ty <- resugar [<] =<< normaliseHoles defs [<] (type def) let (_, retTy) = underPis ty -- try to see whether it approximates what we are looking for -- we throw the head away because it'll be the interface name (I) diff --git a/src/Idris/Elab/Implementation.idr b/src/Idris/Elab/Implementation.idr index 727a3c1067..c285d5f7fd 100644 --- a/src/Idris/Elab/Implementation.idr +++ b/src/Idris/Elab/Implementation.idr @@ -22,6 +22,7 @@ import TTImp.Utils import Control.Monad.State import Data.List +import Data.SnocList import Libraries.Data.ANameMap import Libraries.Data.NameMap @@ -102,12 +103,12 @@ getMethImps : {vars : _} -> Core (List (Name, RigCount, Maybe RawImp, RawImp)) getMethImps env (Bind fc x (Pi fc' c Implicit ty) sc) = do rty <- map (map rawName) $ unelabNoSugar env ty - ts <- getMethImps (Pi fc' c Implicit ty :: env) sc + ts <- getMethImps (env :< Pi fc' c Implicit ty) sc pure ((x, c, Nothing, rty) :: ts) getMethImps env (Bind fc x (Pi fc' c (DefImplicit def) ty) sc) = do rty <- map (map rawName) $ unelabNoSugar env ty rdef <- map (map rawName) $ unelabNoSugar env def - ts <- getMethImps (Pi fc' c (DefImplicit def) ty :: env) sc + ts <- getMethImps (env :< Pi fc' c (DefImplicit def) ty) sc pure ((x, c, Just rdef, rty) :: ts) getMethImps env tm = pure [] @@ -139,6 +140,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i -- alias for something syn <- get Syn defs <- get Ctxt + let varsList = toList vars inames <- lookupCtxtName iname (gamma defs) let [cndata] = concatMap (\n => lookupName n (ifaces syn)) (map fst inames) @@ -177,7 +179,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i let initTy = bindImpls is $ bindConstraints vfc AutoImplicit cons (apply (IVar vfc iname) ps) let paramBinds = if !isUnboundImplicits - then findBindableNames True vars [] initTy + then findBindableNames True varsList [] initTy else [] let impTy = doBind paramBinds initTy @@ -201,10 +203,10 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i (IBindHere vfc (PI erased) impTy) (Just (gType vfc u)) let fullty = abstractFullEnvType vfc env ty - ok <- convert defs [] fullty (type gdef) - unless ok $ do logTermNF "elab.implementation" 1 "Previous" [] (type gdef) - logTermNF "elab.implementation" 1 "Now" [] fullty - throw (CantConvert (getFC impTy) (gamma defs) [] fullty (type gdef)) + ok <- convert defs [<] fullty (type gdef) + unless ok $ do logTermNF "elab.implementation" 1 "Previous" [<] (type gdef) + logTermNF "elab.implementation" 1 "Now" [<] fullty + throw (CantConvert (getFC impTy) (gamma defs) [<] fullty (type gdef)) -- If the body is empty, we're done for now (just declaring that -- the implementation exists and define it later) @@ -213,7 +215,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i defs <- get Ctxt Just impTyc <- lookupTyExact impName (gamma defs) | Nothing => throw (InternalError ("Can't happen, can't find type of " ++ show impName)) - methImps <- getMethImps [] impTyc + methImps <- getMethImps [<] impTyc log "elab.implementation" 3 $ "Bind implicits to each method: " ++ show methImps -- 1.5. Lookup default definitions and add them to the body @@ -253,7 +255,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i -- RHS is the constructor applied to a search for the necessary -- parent constraints, then the method implementations defs <- get Ctxt - let fldTys = getFieldArgs !(normaliseHoles defs [] conty) + let fldTys = getFieldArgs !(normaliseHoles defs [<] conty) log "elab.implementation" 5 $ "Field types " ++ show fldTys let irhs = apply (autoImpsApply (IVar vfc con) $ map (const (ISearch vfc 500)) (parents cdata)) (map (mkMethField methImps fldTys) fns) @@ -404,26 +406,27 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i = do -- Get the specialised type by applying the method to the -- parameters n <- inCurrentNS (methName meth.name) + let varsList = toList vars -- Avoid any name clashes between parameters and method types by -- renaming IBindVars in the method types which appear in the -- parameters let upds' = !(traverse (applyCon impName) allmeths) - let mty_in = substNames vars upds' meth.type + let mty_in = substNames varsList upds' meth.type let (upds, mty_in) = runState Prelude.Nil (renameIBinds impsp (findImplicits mty_in) mty_in) -- Finally update the method type so that implicits from the -- parameters are passed through to any earlier methods which -- appear in the type - let mty_in = substNames vars methupds mty_in + let mty_in = substNames varsList methupds mty_in -- Substitute _ in for the implicit parameters, then -- substitute in the explicit parameters. let mty_iparams - = substBindVars vars + = substBindVars varsList (map (\n => (n, Implicit vfc False)) imppnames) mty_in let mty_params - = substNames vars (zip pnames ps) mty_iparams + = substNames varsList (zip pnames ps) mty_iparams log "elab.implementation" 5 $ "Substitute implicits " ++ show imppnames ++ " parameters " ++ show (zip pnames ps) ++ " " ++ show mty_in ++ " is " ++ @@ -434,7 +437,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i mty_params let ibound = findImplicits mbase - mty <- bindTypeNamesUsed ifc ibound vars mbase + mty <- bindTypeNamesUsed ifc ibound varsList mbase log "elab.implementation" 3 $ "Method " ++ show meth.name ++ " ==> " ++ diff --git a/src/Idris/Elab/Interface.idr b/src/Idris/Elab/Interface.idr index 35c2d9dc98..7337b6e6b2 100644 --- a/src/Idris/Elab/Interface.idr +++ b/src/Idris/Elab/Interface.idr @@ -22,6 +22,7 @@ import TTImp.Utils import Libraries.Data.ANameMap import Libraries.Data.List.Extra import Data.List +import Data.SnocList import Libraries.Data.WithDefault %default covering @@ -111,8 +112,8 @@ mkIfaceData {vars} ifc def_vis env constraints n conName ps dets meths retty = apply (IVar vfc n) (map (IVar EmptyFC) pNames) conty = mkTy Implicit (map jname ps) $ mkTy AutoImplicit (map bhere constraints) (mkTy Explicit (map bname meths) retty) - con = MkImpTy vfc (NoFC conName) !(bindTypeNames ifc [] (pNames ++ map fst meths ++ vars) conty) - bound = pNames ++ map fst meths ++ vars in + con = MkImpTy vfc (NoFC conName) !(bindTypeNames ifc [] (pNames ++ map fst meths ++ toList vars) conty) + bound = pNames ++ map fst meths ++ toList vars in pure $ IData vfc def_vis Nothing {- ?? -} $ MkImpData vfc n @@ -149,7 +150,7 @@ getMethDecl : {vars : _} -> Core (nm, RigCount, RawImp) getMethDecl {vars} env nest params mnames (c, nm, ty) = do let paramNames = map fst params - ty_imp <- bindTypeNames EmptyFC [] (paramNames ++ mnames ++ vars) ty + ty_imp <- bindTypeNames EmptyFC [] (paramNames ++ mnames ++ toList vars) ty pure (nm, c, stripParams paramNames ty_imp) where -- We don't want the parameters to explicitly appear in the method @@ -183,8 +184,8 @@ getMethToplevel {vars} env vis iname cname constraints allmeths params sig -- Make the constraint application explicit for any method names -- which appear in other method types let ty_constr = - substNames vars (map applyCon allmeths) sig.type - ty_imp <- bindTypeNames EmptyFC [] vars (bindPs params $ bindIFace vfc ity ty_constr) + substNames (toList vars) (map applyCon allmeths) sig.type + ty_imp <- bindTypeNames EmptyFC [] (toList vars) (bindPs params $ bindIFace vfc ity ty_constr) cn <- traverseFC inCurrentNS sig.name let tydecl = IClaim (MkFCVal vfc $ MkIClaimData sig.count vis (if sig.isData then [Inline, Invertible] else [Inline]) @@ -251,7 +252,7 @@ getConstraintHint : {vars : _} -> getConstraintHint {vars} fc env vis iname cname constraints meths params (cn, con) = do let ity = apply (IVar fc iname) (map (IVar fc) params) let fty = IPi fc top Explicit Nothing ity con - ty_imp <- bindTypeNames fc [] (meths ++ vars) fty + ty_imp <- bindTypeNames fc [] (meths ++ toList vars) fty let hintname = DN ("Constraint " ++ show con) (UN (Basic $ "__" ++ show iname ++ "_" ++ show con)) @@ -441,9 +442,9 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod tydecls let dty = bindPs params -- bind parameters $ bindIFace vdfc ity -- bind interface (?!) - $ substNames vars methNameMap dty + $ substNames (toList vars) methNameMap dty - dty_imp <- bindTypeNames dfc [] (map name tydecls ++ vars) dty + dty_imp <- bindTypeNames dfc [] (map name tydecls ++ toList vars) dty log "elab.interface.default" 5 $ "Default method " ++ show dn ++ " : " ++ show dty_imp let dtydecl = IClaim $ MkFCVal vdfc @@ -518,6 +519,6 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod meth_names paramNames) nconstraints log "elab.interface" 5 $ "Constraint hints from " ++ show constraints ++ ": " ++ show chints - traverse_ (processDecl [] nest env) (concatMap snd chints) + Core.Core.traverse_ (processDecl [] nest env) (concatMap snd chints) traverse_ (\n => do mn <- inCurrentNS n setFlag vfc mn TCInline) (map fst chints) diff --git a/src/Idris/Error.idr b/src/Idris/Error.idr index 0b358f200a..cc87279a85 100644 --- a/src/Idris/Error.idr +++ b/src/Idris/Error.idr @@ -392,7 +392,7 @@ perrorRaw (NotCovering fc n (MissingCases cs)) = pure $ errorDesc (code (pretty0 !(prettyName n)) <++> reflow "is not covering.") <+> line <+> !(ploc fc) <+> line <+> reflow "Missing cases" <+> colon <+> line - <+> indent 4 (vsep !(traverse (pshow []) cs)) <+> line + <+> indent 4 (vsep !(traverse (pshow [<]) (toList cs))) <+> line perrorRaw (NotCovering fc n (NonCoveringCall ns)) = pure $ errorDesc (pretty0 !(prettyName n) <++> reflow "is not covering.") <+> line <+> !(ploc fc) <+> line @@ -533,8 +533,8 @@ perrorRaw (CantSolveGoal fc gam env g reason) dropEnv : {vars : _} -> Env Term vars -> Term vars -> (ns ** (Env Term ns, Term ns)) - dropEnv env (Bind _ n b@(Pi _ _ _ _) sc) = dropEnv (b :: env) sc - dropEnv env (Bind _ n b@(Let _ _ _ _) sc) = dropEnv (b :: env) sc + dropEnv env (Bind _ n b@(Pi _ _ _ _) sc) = dropEnv (env :< b) sc + dropEnv env (Bind _ n b@(Let _ _ _ _) sc) = dropEnv (env :< b) sc dropEnv env tm = (_ ** (env, tm)) perrorRaw (DeterminingArg fc n i env g) diff --git a/src/Idris/IDEMode/CaseSplit.idr b/src/Idris/IDEMode/CaseSplit.idr index 9e772d4c44..b93c17b6bd 100644 --- a/src/Idris/IDEMode/CaseSplit.idr +++ b/src/Idris/IDEMode/CaseSplit.idr @@ -349,7 +349,7 @@ getClause l n Just (loc, nidx, envlen, ty) <- findTyDeclAt (\p, n => onLine (l-1) p) | Nothing => pure Nothing n <- getFullName nidx - argns <- getEnvArgNames defs envlen !(nf defs [] ty) + argns <- getEnvArgNames defs envlen !(nf defs [<] ty) Just srcLine <- getSourceLine l | Nothing => pure Nothing let (mark, src) = isLitLine srcLine diff --git a/src/Idris/IDEMode/Holes.idr b/src/Idris/IDEMode/Holes.idr index a32a3889e1..982ef3e727 100644 --- a/src/Idris/IDEMode/Holes.idr +++ b/src/Idris/IDEMode/Holes.idr @@ -100,7 +100,7 @@ extractHoleData : {vars : _} -> extractHoleData defs env fn (S args) (Bind fc x (Let _ c val ty) sc) = extractHoleData defs env fn args (subst val sc) extractHoleData defs env fn (S args) (Bind fc x b sc) - = do rest <- extractHoleData defs (b :: env) fn args sc + = do rest <- extractHoleData defs (env :< b) fn args sc let True = showName x | False => do log "ide-mode.hole" 10 $ "Not showing name: " ++ show x pure rest @@ -155,7 +155,7 @@ getUserHolesData traverse (\n_gdef_args => -- Inference can't deal with this for now :/ let (n, gdef, args) = the (Name, GlobalDef, Nat) n_gdef_args in - holeData defs [] n args (type gdef)) + holeData defs [<] n args (type gdef)) holesWithArgs export diff --git a/src/Idris/Parser.idr b/src/Idris/Parser.idr index 0a106d3a49..09c296e2bd 100644 --- a/src/Idris/Parser.idr +++ b/src/Idris/Parser.idr @@ -1115,7 +1115,7 @@ mutual let fc = boundToFC fname x in toLines xs [< StrLiteral fc (last strs)] $ acc :< (line <>> [StrLiteral fc str]) - <>< map (\str => [StrLiteral fc str]) (init strs) + <>< (the (List _) $ map (\str => [StrLiteral fc str]) (init strs)) fnDirectOpt : OriginDesc -> Rule PFnOpt fnDirectOpt fname diff --git a/src/Idris/ProcessIdr.idr b/src/Idris/ProcessIdr.idr index 6657a95f41..c36644cadc 100644 --- a/src/Idris/ProcessIdr.idr +++ b/src/Idris/ProcessIdr.idr @@ -40,6 +40,7 @@ import Idris.Pretty import Idris.Doc.String import Data.List +import Data.SnocList import Data.String import Libraries.Data.SortedMap @@ -87,13 +88,13 @@ processDecl (MkFCVal _ $ PMutual ps) processDecl decl = catch (do impdecls <- desugarDecl [] decl - traverse_ (Check.processDecl [] (MkNested []) []) impdecls + traverse_ (Check.processDecl [] (MkNested []) [<]) impdecls pure []) (\err => do giveUpConstraints -- or we'll keep trying... pure [err]) processDecls decls - = do xs <- concat <$> traverse processDecl decls + = do xs <- concat <$> traverse (logDepthWrap processDecl) decls Nothing <- checkDelayedHoles | Just err => pure (if null xs then [err] else xs) errs <- logTime 3 ("Totality check overall") getTotalityErrors @@ -386,20 +387,23 @@ processMod sourceFileName ttcFileName msg sourcecode origin -- a phase before this which builds the dependency graph -- (also that we only build child dependencies if rebuilding -- changes the interface - will need to store a hash in .ttc!) + logDepthIncrease logTime 2 "Reading imports" $ - traverse_ (readImport False) allImports + logDepthDecrease $ traverse_ (readImport False) allImports -- Before we process the source, make sure the "hide_everywhere" -- names are set to private (TODO, maybe if we want this?) -- defs <- get Ctxt -- traverse (\x => setVisibility emptyFC x Private) (hiddenNames defs) setNS (miAsNamespace ns) + logDepthIncrease errs <- logTime 2 "Processing decls" $ - processDecls (decls mod) + logDepthDecrease $ processDecls (decls mod) -- coreLift $ gc when (isNil errs) $ - logTime 2 "Compile defs" $ compileAndInlineAll + do logDepthIncrease + logTime 2 "Compile defs" $ logDepthDecrease $ compileAndInlineAll -- Save the import hashes for the imports we just read. -- If they haven't changed next time, and the source diff --git a/src/Idris/REPL.idr b/src/Idris/REPL.idr index 1234cda893..3f67088171 100644 --- a/src/Idris/REPL.idr +++ b/src/Idris/REPL.idr @@ -156,7 +156,7 @@ getEnvTerm : {vars : _} -> (vars' ** (Env Term vars', Term vars')) getEnvTerm (n :: ns) env (Bind fc x b sc) = if n == x - then getEnvTerm ns (b :: env) sc + then getEnvTerm ns (env :< b) sc else (_ ** (env, Bind fc x b sc)) getEnvTerm _ env tm = (_ ** (env, tm)) @@ -165,7 +165,7 @@ displayPatTerm : {auto c : Ref Ctxt Defs} -> Defs -> ClosedTerm -> Core String displayPatTerm defs tm - = do ptm <- resugarNoPatvars [] !(normaliseHoles defs [] tm) + = do ptm <- resugarNoPatvars [<] !(normaliseHoles defs [<] tm) pure (show ptm) setOpt : {auto c : Ref Ctxt Defs} -> @@ -352,7 +352,7 @@ dropLamsTm : {vars : _} -> Nat -> Env Term vars -> Term vars -> (vars' ** (Env Term vars', Term vars')) dropLamsTm Z env tm = (_ ** (env, tm)) -dropLamsTm (S k) env (Bind _ _ b sc) = dropLamsTm k (b :: env) sc +dropLamsTm (S k) env (Bind _ _ b sc) = dropLamsTm k (env :< b) sc dropLamsTm _ env tm = (_ ** (env, tm)) findInTree : FilePos -> Name -> PosMap (NonEmptyFC, Name) -> Maybe Name @@ -388,7 +388,7 @@ findInTree p hint m match : (NonEmptyFC, Name) -> Bool match (_, n) = matches hint n && checkCandidate n -record TermWithType (vars : List Name) where +record TermWithType (vars : SnocList Name) where constructor WithType termOf : Term vars typeOf : Term vars @@ -420,7 +420,7 @@ inferAndElab : Env Term vars -> Core (TermWithType vars) inferAndElab emode itm env - = do ttimp <- desugar AnyExpr vars itm + = do ttimp <- desugar AnyExpr (toList vars) itm let ttimpWithIt = ILocal replFC !getItDecls ttimp inidx <- resolveName (UN $ Basic "[input]") -- a TMP HACK to prioritise list syntax for List: hide @@ -504,7 +504,7 @@ processEdit (Intro upd line hole) | _ => pure $ EditError ("Could not find hole named" <++> pretty0 hole) let Hole args _ = definition hgdef | _ => pure $ EditError (pretty0 hole <++> "is not a refinable hole") - let (lhsCtxt ** (env, htyInLhsCtxt)) = underPis (cast args) [] (type hgdef) + let (lhsCtxt ** (env, htyInLhsCtxt)) = underPis (cast args) [<] (type hgdef) (iintrod :: iintrods) <- intro hidx hole env htyInLhsCtxt | [] => pure $ EditError "Don't know what to do." @@ -526,7 +526,7 @@ processEdit (Refine upd line hole e) | _ => pure $ EditError ("Could not find hole named" <++> pretty0 hole) let Hole args _ = definition hgdef | _ => pure $ EditError (pretty0 hole <++> "is not a refinable hole") - let (lhsCtxt ** (env, htyInLhsCtxt)) = underPis (cast args) [] (type hgdef) + let (lhsCtxt ** (env, htyInLhsCtxt)) = underPis (cast args) [<] (type hgdef) -- Then we elaborate the expression we were given and infer its type. -- We have some magic built-in if the expression happens to be a single identifier @@ -537,7 +537,7 @@ processEdit (Refine upd line hole e) -- could not find the variable: it may be a local one! | [] => pure (Right Nothing) let sizes = (n ::: ns) <&> \ (_,_,gdef) => - let ctxt = underPis (-1) [] (type gdef) in + let ctxt = underPis (-1) [<] (type gdef) in lengthExplicitPi $ fst $ snd $ ctxt let True = all (head sizes ==) sizes | _ => pure (Left ("Ambiguous name" <++> pretty0 v <++> "(couldn't infer arity)")) @@ -577,7 +577,7 @@ processEdit (Refine upd line hole e) -- without eta-expansion to (\ a => fun a) -- It is hopefully a good enough approximation for now. A very ambitious approach -- would be to type-align the telescopes. Bonus points for allowing permutations. - let size_tele_hole = lengthExplicitPi $ fst $ snd $ underPis (-1) [] (type hgdef) + let size_tele_hole = lengthExplicitPi $ fst $ snd $ underPis (-1) [<] (type hgdef) let True = size_tele_fun >= size_tele_hole | _ => pure $ EditError $ hsep [ "Cannot seem to refine", pretty0 hole @@ -594,7 +594,7 @@ processEdit (Refine upd line hole e) let pcall = papply replFC e new_holes -- We're desugaring it to the corresponding TTImp - icall <- desugar AnyExpr (lhsCtxt <>> []) pcall + icall <- desugar AnyExpr lhsCtxt pcall -- We're checking this term full of holes against the type of the hole -- TODO: branch before checking the expression fits @@ -632,11 +632,11 @@ processEdit (ExprSearch upd line name hints) if upd then updateFile (proofSearch name (show itm') (integerToNat (cast (line - 1)))) else pure $ DisplayEdit (prettyBy Syntax itm') - [(n, nidx, PMDef pi [] (STerm _ tm) _ _)] => + [(n, nidx, PMDef pi [<] (STerm _ tm) _ _)] => case holeInfo pi of NotHole => pure $ EditError "Not a searchable hole" SolvedHole locs => - do let (_ ** (env, tm')) = dropLamsTm locs [] !(normaliseHoles defs [] tm) + do let (_ ** (env, tm')) = dropLamsTm locs [<] !(normaliseHoles defs [<] tm) itm <- resugar env tm' let itm'= ifThenElse brack (addBracket replFC itm) itm if upd @@ -747,8 +747,8 @@ prepareExp ctm let ttimpWithIt = ILocal replFC !getItDecls ttimp inidx <- resolveName (UN $ Basic "[input]") (tm, ty) <- elabTerm inidx InExpr [] (MkNested []) - [] ttimpWithIt Nothing - tm_erased <- linearCheck replFC linear True [] tm + [<] ttimpWithIt Nothing + tm_erased <- linearCheck replFC linear True [<] tm compileAndInlineAll pure tm_erased @@ -798,8 +798,8 @@ execDecls decls = do execDecl decl = do i <- desugarDecl [] decl inidx <- resolveName (UN $ Basic "[defs]") - _ <- newRef EST (initEStateSub inidx [] Refl) - processLocal [] (MkNested []) [] !getItDecls i + _ <- newRef EST (initEStateSub inidx [<] Refl) + processLocal [] (MkNested []) [<] !getItDecls i export compileExp : {auto c : Ref Ctxt Defs} -> @@ -858,14 +858,14 @@ inferAndNormalize : {auto c : Ref Ctxt Defs} -> {auto o : Ref ROpts REPLOpts} -> REPLEval -> PTerm -> - Core (TermWithType []) + Core (TermWithType [<]) inferAndNormalize emode itm - = do (tm `WithType` ty) <- inferAndElab (elabMode emode) itm [] + = do (tm `WithType` ty) <- inferAndElab (elabMode emode) itm [<] logTerm "repl.eval" 10 "Elaborated input" tm defs <- get Ctxt let norm = replEval emode - ntm <- norm defs [] tm - logTermNF "repl.eval" 5 "Normalised" [] ntm + ntm <- norm defs [<] tm + logTermNF "repl.eval" 5 "Normalised" [<] ntm pure $ ntm `WithType` ty where elabMode : REPLEval -> ElabMode @@ -891,27 +891,27 @@ process (Eval itm) case emode of Execute => do ignore (execExp itm); pure (Executed itm) Scheme => - do (tm `WithType` ty) <- inferAndElab InExpr itm [] + do (tm `WithType` ty) <- inferAndElab InExpr itm [<] qtm <- logTimeWhen !getEvalTiming 0 "Evaluation" $ - (do nf <- snfAll [] tm - quote [] nf) - itm <- logTimeWhen False 0 "Resugar" $ resugar [] qtm + (do nf <- snfAll [<] tm + quote [<] nf) + itm <- logTimeWhen False 0 "Resugar" $ resugar [<] qtm pure (Evaluated itm Nothing) _ => do (ntm `WithType` ty) <- logTimeWhen !getEvalTiming 0 "Evaluation" $ inferAndNormalize emode itm - itm <- resugar [] ntm + itm <- resugar [<] ntm defs <- get Ctxt opts <- get ROpts let norm = replEval emode evalResultName <- DN "it" <$> genName "evalResult" ignore $ addDef evalResultName - $ newDef replFC evalResultName top [] ty defaulted - $ PMDef defaultPI [] (STerm 0 ntm) (STerm 0 ntm) [] + $ newDef replFC evalResultName top [<] ty defaulted + $ PMDef defaultPI [<] (STerm 0 ntm) (STerm 0 ntm) [] addToSave evalResultName put ROpts ({ evalResultName := Just evalResultName } opts) if showTypes opts - then do ity <- resugar [] !(norm defs [] ty) + then do ity <- resugar [<] !(norm defs [<] ty) pure (Evaluated itm (Just ity)) else pure (Evaluated itm Nothing) process (Check (PRef fc (UN (Basic "it")))) @@ -926,11 +926,11 @@ process (Check (PRef fc fn)) ts => do tys <- traverse (displayType False defs) ts pure (Printed $ vsep $ map (reAnnotate Syntax) tys) process (Check itm) - = do (tm `WithType` ty) <- inferAndElab InExpr itm [] + = do (tm `WithType` ty) <- inferAndElab InExpr itm [<] defs <- get Ctxt - itm <- resugar [] !(normaliseHoles defs [] tm) + itm <- resugar [<] !(normaliseHoles defs [<] tm) -- ty <- getTerm gty - ity <- resugar [] !(normalise defs [] ty) + ity <- resugar [<] !(normalise defs [<] ty) pure (TermChecked itm ity) process (CheckWithImplicits itm) = do showImplicits <- showImplicits <$> getPPrint @@ -990,7 +990,7 @@ process (TypeSearch searchTerm) let ctxt = gamma defs rawTy <- desugar AnyExpr [] searchTerm bound <- piBindNames replFC [] rawTy - (ty, _) <- elabTerm 0 InType [] (MkNested []) [] bound Nothing + (ty, _) <- elabTerm 0 InType [] (MkNested []) [<] bound Nothing ty' <- toResolvedNames ty filteredDefs <- do names <- allNames ctxt diff --git a/src/Idris/REPL/Common.idr b/src/Idris/REPL/Common.idr index c6dd9bd4bc..9f96ac564d 100644 --- a/src/Idris/REPL/Common.idr +++ b/src/Idris/REPL/Common.idr @@ -258,7 +258,7 @@ docsOrSignature fc n typeSummary : Defs -> Core (Doc IdrisDocAnn) typeSummary defs = do Just def <- lookupCtxtExact n (gamma defs) | Nothing => pure "" - ty <- resugar [] !(normaliseHoles defs [] (type def)) + ty <- resugar [<] !(normaliseHoles defs [<] (type def)) pure $ pretty0 n <++> ":" <++> prettyBy Syntax ty export @@ -271,11 +271,11 @@ equivTypes ty1 ty2 = | _ => pure False logTerm "typesearch.equiv" 10 "Candidate: " ty1 defs <- get Ctxt - True <- pure (!(getArity defs [] ty1) == !(getArity defs [] ty2)) + True <- pure (!(getArity defs [<] ty1) == !(getArity defs [<] ty2)) | False => pure False _ <- newRef UST initUState b <- catch - (do res <- unify inTerm EmptyFC [] ty1 ty2 + (do res <- unify inTerm EmptyFC [<] ty1 ty2 case res of (MkUnifyResult [] _ [] NoLazy) => pure True _ => pure False) diff --git a/src/Libraries/Data/SnocList/Extra.idr b/src/Libraries/Data/SnocList/Extra.idr new file mode 100644 index 0000000000..aa458bbba7 --- /dev/null +++ b/src/Libraries/Data/SnocList/Extra.idr @@ -0,0 +1,22 @@ +module Libraries.Data.SnocList.Extra + +import Data.SnocList + +public export +take : (n : Nat) -> (xs : Stream a) -> SnocList a +take Z xs = [<] +take (S k) (x :: xs) = take k xs :< x + +public export +snocAppendFishAssociative : + (sx, sy : SnocList a) -> (zs : List a) -> + (sx ++ sy) <>< zs === sx ++ (sy <>< zs) +snocAppendFishAssociative sx sy [] = Refl +snocAppendFishAssociative sx sy (z :: zs) + = snocAppendFishAssociative sx (sy :< z) zs + +export +snocAppendAsFish : (sx, sy : SnocList a) -> sx ++ sy === sx <>< (cast sy) +snocAppendAsFish sx sy = sym + $ trans (fishAsSnocAppend sx (sy <>> [])) + (cong (sx ++) (castToList sy)) diff --git a/src/Libraries/Data/SnocList/HasLength.idr b/src/Libraries/Data/SnocList/HasLength.idr index eda9f7a5e0..8078095859 100644 --- a/src/Libraries/Data/SnocList/HasLength.idr +++ b/src/Libraries/Data/SnocList/HasLength.idr @@ -2,6 +2,8 @@ module Libraries.Data.SnocList.HasLength import Data.Nat +import Libraries.Data.SnocList.Extra + --------------------------------------- -- horrible hack import Data.List.HasLength as L @@ -23,9 +25,9 @@ hasLength Z = Refl hasLength (S p) = cong S (hasLength p) export -sucL : HasLength n sx -> HasLength (S n) ([ HasLength (S n) ([ HasLength n sy -> HasLength (n + m) (sx ++ sy) @@ -49,12 +51,11 @@ hlChips {m = S m} {n} (S x) y = rewrite plusSuccRightSucc m n in hlChips x (S y) -{- export -take : (n : Nat) -> (sx : Stream a) -> HasLength n (take n sx) +take : (n : Nat) -> (xs : Stream a) -> HasLength n (take n xs) take Z _ = Z -take (S n) (x :: sx) = S (take n sx) --} +take (S n) (x :: xs) = S (take n xs) + export cast : {sy : _} -> (0 _ : SnocList.length sx = SnocList.length sy) -> diff --git a/src/Libraries/Data/SnocList/SizeOf.idr b/src/Libraries/Data/SnocList/SizeOf.idr index 5caf966098..0fee534419 100644 --- a/src/Libraries/Data/SnocList/SizeOf.idr +++ b/src/Libraries/Data/SnocList/SizeOf.idr @@ -3,6 +3,7 @@ module Libraries.Data.SnocList.SizeOf import Data.List import Data.SnocList import Data.List.HasLength +import Libraries.Data.SnocList.Extra import Libraries.Data.SnocList.HasLength --------------------------------------- @@ -36,10 +37,18 @@ public export (:<) : SizeOf as -> (0 a : _) -> SizeOf (as :< a) MkSizeOf n p :< _ = MkSizeOf (S n) (S p) --- ||| suc but from the left +public export +zero : SizeOf [<] +zero = MkSizeOf Z Z + +public export +suc : SizeOf as -> SizeOf (as :< a) +suc (MkSizeOf n p) = MkSizeOf (S n) (S p) + +-- ||| suc but from the right export -sucL : SizeOf as -> SizeOf ([ SizeOf ([<) : SizeOf {a} sx -> LSizeOf {a} ys -> SizeOf (sx <>< ys) @@ -73,11 +82,9 @@ map (MkSizeOf n p) = MkSizeOf n (cast (sym $ lengthMap sx) p) where lengthMap [<] = Refl lengthMap (sx :< x) = cong S (lengthMap sx) -{- -export +public export take : {n : Nat} -> {0 sx : Stream a} -> SizeOf (take n sx) take = MkSizeOf n (take n sx) --} namespace SizedView diff --git a/src/TTImp/Elab.idr b/src/TTImp/Elab.idr index 87094e66b1..6ef47d708f 100644 --- a/src/TTImp/Elab.idr +++ b/src/TTImp/Elab.idr @@ -69,8 +69,8 @@ normaliseHoleTypes where updateType : Defs -> Int -> GlobalDef -> Core () updateType defs i def - = do ty' <- catch (tryNormaliseSizeLimit defs 10 [] (type def)) - (\err => normaliseHoles defs [] (type def)) + = do ty' <- catch (tryNormaliseSizeLimit defs 10 [<] (type def)) + (\err => normaliseHoles defs [<] (type def)) ignore $ addDef (Resolved i) ({ type := ty' } def) normaliseH : Defs -> Int -> Core () diff --git a/src/TTImp/Elab/Ambiguity.idr b/src/TTImp/Elab/Ambiguity.idr index 41932f8eff..6592af62d3 100644 --- a/src/TTImp/Elab/Ambiguity.idr +++ b/src/TTImp/Elab/Ambiguity.idr @@ -190,14 +190,14 @@ Show TypeMatch where mutual mightMatchD : {auto c : Ref Ctxt Defs} -> {vars : _} -> - Defs -> NF vars -> NF [] -> Core TypeMatch + Defs -> NF vars -> NF [<] -> Core TypeMatch mightMatchD defs l r = mightMatch defs (stripDelay l) (stripDelay r) mightMatchArg : {auto c : Ref Ctxt Defs} -> {vars : _} -> Defs -> - Closure vars -> Closure [] -> + Closure vars -> Closure [<] -> Core Bool mightMatchArg defs l r = pure $ case !(mightMatchD defs !(evalClosure defs l) !(evalClosure defs r)) of @@ -207,7 +207,7 @@ mutual mightMatchArgs : {auto c : Ref Ctxt Defs} -> {vars : _} -> Defs -> - List (Closure vars) -> List (Closure []) -> + List (Closure vars) -> List (Closure [<]) -> Core Bool mightMatchArgs defs [] [] = pure True mightMatchArgs defs (x :: xs) (y :: ys) @@ -219,18 +219,20 @@ mutual mightMatch : {auto c : Ref Ctxt Defs} -> {vars : _} -> - Defs -> NF vars -> NF [] -> Core TypeMatch + Defs -> NF vars -> NF [<] -> Core TypeMatch mightMatch defs target (NBind fc n (Pi _ _ _ _) sc) - = mightMatchD defs target !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder))) + = mightMatchD defs target !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) mightMatch defs (NBind _ _ _ _) (NBind _ _ _ _) = pure Poly -- lambdas might match mightMatch defs (NTCon _ n t a args) (NTCon _ n' t' a' args') = if n == n' - then do amatch <- mightMatchArgs defs (map snd args) (map snd args') + -- [Note] Restore logging sequence + then do amatch <- mightMatchArgs defs (toList $ map snd args) (toList $ map snd args') if amatch then pure Concrete else pure NoMatch else pure NoMatch mightMatch defs (NDCon _ n t a args) (NDCon _ n' t' a' args') = if t == t' - then do amatch <- mightMatchArgs defs (map snd args) (map snd args') + -- [Note] Restore logging sequence + then do amatch <- mightMatchArgs defs (toList $ map snd args) (toList $ map snd args') if amatch then pure Concrete else pure NoMatch else pure NoMatch mightMatch defs (NPrimVal _ x) (NPrimVal _ y) @@ -249,7 +251,7 @@ couldBeName : {auto c : Ref Ctxt Defs} -> couldBeName defs target n = case !(lookupTyExact n (gamma defs)) of Nothing => pure Poly -- could be a local name, don't rule it out - Just ty => mightMatchD defs target !(nf defs [] ty) + Just ty => mightMatchD defs target !(nf defs [<] ty) couldBeFn : {auto c : Ref Ctxt Defs} -> {vars : _} -> diff --git a/src/TTImp/Elab/App.idr b/src/TTImp/Elab/App.idr index ede3102048..4dedc0cf27 100644 --- a/src/TTImp/Elab/App.idr +++ b/src/TTImp/Elab/App.idr @@ -18,6 +18,7 @@ import TTImp.Elab.Dot import TTImp.TTImp import Data.List +import Data.SnocList import Data.Maybe import Libraries.Data.WithDefault @@ -90,6 +91,7 @@ getNameType elabMode rigc env fc x $ "getNameType is adding " ++ show decor ++ ": " ++ show def.fullname addSemanticDecorations [(nfc, decor, Just def.fullname)] + logTerm "ide-mode.highlight" 8 "def" (embed {outer=vars} (type def)) pure (Ref fc nt (Resolved i), gnf env (embed (type def))) where rigSafe : RigCount -> RigCount -> Core () @@ -438,7 +440,9 @@ mutual checkRestApp rig argRig elabinfo nest env fc tm x aty sc (n, argpos) arg_in expargs autoargs namedargs knownret expty = do defs <- get Ctxt + log "elab" 10 ("arg_in: " ++ show arg_in) arg <- dotErased aty n argpos (elabMode elabinfo) argRig arg_in + log "elab" 10 ("arg: " ++ show arg) kr <- if knownret then pure True else do sc' <- sc defs (toClosure defaultOpts env (Erased fc Placeholder)) @@ -470,6 +474,7 @@ mutual nm <- genMVName x empty <- clearDefs defs metaty <- quote empty env aty + logTerm "elab" 10 "metaty: " metaty (idx, metaval) <- argVar (getFC arg) argRig env nm metaty let fntm = App fc tm metaval logTerm "elab" 10 "...as" metaval @@ -477,6 +482,8 @@ mutual (tm, gty) <- checkAppWith rig elabinfo nest env fc fntm fnty (n, 1 + argpos) expargs autoargs namedargs kr expty defs <- get Ctxt + logEnv "elab" 10 "Metaty Env" env + logMetatyCtxt defs metaty aty' <- nf defs env metaty logNF "elab" 10 ("Now trying " ++ show nm ++ " " ++ show arg) env aty' @@ -507,7 +514,8 @@ mutual -- *may* have as patterns in it and we need to retain them. -- (As patterns are a bit of a hack but I don't yet see a -- better way that leads to good code...) - logTerm "elab" 10 ("Solving " ++ show metaval ++ " with") argv + logTerm "elab" 10 ("Solving " ++ show !(toFullNames metaval) ++ " with") !(toFullNames argv) + logEnv "elab" 10 "In env" env ok <- solveIfUndefined env metaval argv -- If there's a constraint, make a constant, but otherwise -- just return the term as expected @@ -534,6 +542,13 @@ mutual ) removeHole idx pure (tm, gty) + where + logMetatyCtxt : Defs -> Term vars -> Core () + logMetatyCtxt defs (Meta _ _ idx _) = do + m_metagdef <- lookupCtxtExact (Resolved idx) (gamma defs) + log "elab" 10 $ "Meta definition from " ++ show idx ++ ": " ++ show (map definition m_metagdef) + pure () + logMetatyCtxt _ _ = pure () checkLtoR : Bool -> -- return type is known RawImp -> -- argument currently being checked @@ -824,6 +839,11 @@ checkApp rig elabinfo nest env fc (IVar fc' n) expargs autoargs namedargs exp prims <- getPrimitiveNames elabinfo <- updateElabInfo prims elabinfo.elabMode n expargs elabinfo + logTerm "elab" 10 "checkApp-IVar ntm" ntm + log "elab" 10 $ "checkApp-IVar nty_in NF: " ++ show !(toFullNames nty) + logTerm "elab" 10 "checkApp-IVar nty_in Term" !(getTerm nty_in) + -- logEnv "elab" 10 "checkApp-IVar Env" env + logNF "elab" 10 "checkApp-IVar nty_in NF" env nty addNameLoc fc' n logC "elab" 10 @@ -854,7 +874,7 @@ checkApp rig elabinfo nest env fc (IVar fc' n) expargs autoargs namedargs exp = do tm <- Normalise.normalisePrims (`boundSafe` elabMode elabinfo) isIPrimVal (onLHS (elabMode elabinfo)) - prims n expargs (fst res) env + prims n (cast {to=SnocList RawImp} expargs) (fst res) env pure (fromMaybe (fst res) tm, snd res) where diff --git a/src/TTImp/Elab/Binders.idr b/src/TTImp/Elab/Binders.idr index f9062c2f33..33fd99741f 100644 --- a/src/TTImp/Elab/Binders.idr +++ b/src/TTImp/Elab/Binders.idr @@ -70,7 +70,7 @@ checkPi rig elabinfo nest env fc rigf info n argTy retTy expTy (tyv, tyt) <- check pirig elabinfo nest env argTy (Just (gType fc tyu)) info' <- checkPiInfo rigf elabinfo nest env info (Just (gnf env tyv)) - let env' : Env Term (n :: _) = Pi fc rigf info' tyv :: env + let env' : Env Term (_ :< n) = env :< Pi fc rigf info' tyv let nest' = weaken (dropName n nest) scu <- uniVar fc (scopev, scopet) <- @@ -115,7 +115,7 @@ inferLambda rig elabinfo nest env fc rigl info n argTy scope expTy u <- uniVar fc (tyv, tyt) <- check erased elabinfo nest env argTy (Just (gType fc u)) info' <- checkPiInfo rigl elabinfo nest env info (Just (gnf env tyv)) - let env' : Env Term (n :: _) = Lam fc rigb info' tyv :: env + let env' : Env Term (_ :< n) = env :< Lam fc rigb info' tyv let nest' = weaken (dropName n nest) (scopev, scopet) <- inScope fc env' (\e' => check {e=e'} rig elabinfo @@ -172,7 +172,7 @@ checkLambda rig_in elabinfo nest env fc rigl info n argTy scope (Just expty_in) argTy (Just (gType fc u)) info' <- checkPiInfo rigl elabinfo nest env info (Just (gnf env tyv)) let rigb = rigl `glb` c - let env' : Env Term (n :: _) = Lam fc rigb info' tyv :: env + let env' : Env Term (_ :< n) = env :< Lam fc rigb info' tyv ignore $ convert fc elabinfo env (gnf env tyv) (gnf env pty) let nest' = weaken (dropName n nest) (scopev, scopet) <- @@ -199,8 +199,8 @@ checkLambda rig_in elabinfo nest env fc rigl info n argTy scope (Just expty_in) _ => inferLambda rig elabinfo nest env fc rigl info n argTy scope (Just expty_in) weakenExp : {x, vars : _} -> - Env Term (x :: vars) -> - Maybe (Glued vars) -> Core (Maybe (Glued (x :: vars))) + Env Term (vars :< x) -> + Maybe (Glued vars) -> Core (Maybe (Glued (vars :< x))) weakenExp env Nothing = pure Nothing weakenExp env (Just gtm) = do tm <- getTerm gtm @@ -248,7 +248,7 @@ checkLet rigc_in elabinfo nest env fc lhsFC rigl n nTy nVal scope expty {vars} elabinfo -- without preciseInf nest env nVal (Just (gnf env tyv)) pure (fst c, snd c, rigl |*| rigc)) - let env' : Env Term (n :: _) = Lam fc rigb Explicit tyv :: env + let env' : Env Term (_ :< n) = env :< Lam fc rigb Explicit tyv let nest' = weaken (dropName n nest) expScope <- weakenExp env' expty (scopev, gscopet) <- diff --git a/src/TTImp/Elab/Case.idr b/src/TTImp/Elab/Case.idr index 949df82749..9a266ae11c 100644 --- a/src/TTImp/Elab/Case.idr +++ b/src/TTImp/Elab/Case.idr @@ -53,28 +53,28 @@ changeVar old new (TForce fc r p) = TForce fc r (changeVar old new p) changeVar old new tm = tm -findLater : (x : Name) -> (newer : List Name) -> Var (newer ++ x :: older) -findLater x [] = MkVar First -findLater {older} x (_ :: xs) +findLater : (x : Name) -> (newer : SnocList Name) -> Var (older :< x ++ newer) +findLater x [<] = MkVar First +findLater {older} x (xs :< _) = let MkVar p = findLater {older} x xs in MkVar (Later p) toRig1 : {idx : Nat} -> (0 p : IsVar nm idx vs) -> Env Term vs -> Env Term vs -toRig1 First (b :: bs) +toRig1 First (bs :< b) = if isErased (multiplicity b) - then setMultiplicity b linear :: bs - else b :: bs -toRig1 (Later p) (b :: bs) = b :: toRig1 p bs + then bs :< setMultiplicity b linear + else bs :< b +toRig1 (Later p) (bs :< b) = toRig1 p bs :< b toRig0 : {idx : Nat} -> (0 p : IsVar nm idx vs) -> Env Term vs -> Env Term vs -toRig0 First (b :: bs) = setMultiplicity b erased :: bs -toRig0 (Later p) (b :: bs) = b :: toRig0 p bs +toRig0 First (bs :< b) = bs :< setMultiplicity b erased +toRig0 (Later p) (bs :< b) = toRig0 p bs :< b -- When we abstract over the evironment, pi needs to be explicit explicitPi : Env Term vs -> Env Term vs -explicitPi (Pi fc c _ ty :: env) = Pi fc c Explicit ty :: explicitPi env -explicitPi (b :: env) = b :: explicitPi env -explicitPi [] = [] +explicitPi (env :< Pi fc c _ ty) = explicitPi env :< Pi fc c Explicit ty +explicitPi (env :< b) = explicitPi env :< b +explicitPi [<] = [<] allow : Maybe (Var vs) -> Env Term vs -> Env Term vs allow Nothing env = env @@ -90,21 +90,21 @@ findImpsIn : {vars : _} -> FC -> Env Term vars -> List (Name, Term vars) -> Term vars -> Core () findImpsIn fc env ns (Bind _ n b@(Pi _ _ Implicit ty) sc) - = findImpsIn fc (b :: env) + = findImpsIn fc (env :< b) ((n, weaken ty) :: map (\x => (fst x, weaken (snd x))) ns) sc findImpsIn fc env ns (Bind _ n b sc) - = findImpsIn fc (b :: env) + = findImpsIn fc (env :< b) (map (\x => (fst x, weaken (snd x))) ns) sc findImpsIn fc env ns ty = when (not (isNil ns)) $ throw (TryWithImplicits fc env (reverse ns)) -merge : {vs : List Name} -> - List (Var vs) -> List (Var vs) -> List (Var vs) -merge [] xs = xs -merge (v :: vs) xs +merge : {vs : SnocList Name} -> + SnocList (Var vs) -> List (Var vs) -> List (Var vs) +merge [<] xs = xs +merge (vs :< v) xs = merge vs (v :: filter (v /=) xs) -- Extend the list of variables we need in the environment so far, removing @@ -121,7 +121,7 @@ extendNeeded b env needed findScrutinee : {vs : _} -> Env Term vs -> RawImp -> Maybe (Var vs) -findScrutinee {vs = n' :: _} (b :: bs) (IVar loc' n) +findScrutinee {vs = _ :< n'} (bs :< b) (IVar loc' n) = if n' == n && not (isLet b) then Just (MkVar First) else do MkVar p <- findScrutinee bs (IVar loc' n) @@ -218,11 +218,11 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- If we can normalise the type without the result being excessively -- big do it. It's the depth of stuck applications - 10 is already -- pretty much unreadable! - casefnty <- normaliseSizeLimit defs 10 [] casefnty + casefnty <- normaliseSizeLimit defs 10 [<] casefnty (erasedargs, _) <- findErased casefnty logEnv "elab.case" 10 "Case env" env - logTermNF "elab.case" 2 ("Case function type: " ++ show casen) [] casefnty + logTermNF "elab.case" 2 ("Case function type: " ++ show casen) [<] casefnty traverse_ addToSave (keys (getMetas casefnty)) -- If we've had to add implicits to the case type (because there @@ -230,10 +230,10 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- way out is to throw an error and try again with the implicits -- actually bound! This is rather hacky, but a lot less fiddly than -- the alternative of fixing up the environment - when (not (isNil fullImps)) $ findImpsIn fc [] [] casefnty + when (not (isNil fullImps)) $ findImpsIn fc [<] [] casefnty cidx <- addDef casen ({ eraseArgs := erasedargs } (newDef fc casen (if isErased rigc then erased else top) - [] casefnty vis None)) + [<] casefnty vis None)) traverse_ (processFnOpt fc False casen) opts @@ -266,7 +266,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- we come out again, so save them let olddelayed = delayedElab ust put UST ({ delayedElab := [] } ust) - processDecl [InCase] nest' [] (IDef fc casen alts') + processDecl [InCase] nest' [<] (IDef fc casen alts') -- If there's no duplication of the scrutinee in the block, -- flag it as inlinable. @@ -284,12 +284,12 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp pure (appTm, gnf env caseretty) where mkLocalEnv : Env Term vs -> Env Term vs - mkLocalEnv [] = [] - mkLocalEnv (b :: bs) + mkLocalEnv [<] = [<] + mkLocalEnv (bs :< b) = let b' = if isLinear (multiplicity b) then setMultiplicity b erased else b in - b' :: mkLocalEnv bs + mkLocalEnv bs :< b' -- Return the original name in the environment, and what it needs to be -- called in the case block. We need to mapping to build the ICaseLocal @@ -305,8 +305,8 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- the LHS of the case to be applied to. addEnv : {vs : _} -> Int -> Env Term vs -> List Name -> (List (Name, Name), List RawImp) - addEnv idx [] used = ([], []) - addEnv idx {vs = v :: vs} (b :: bs) used + addEnv idx [<] used = ([], []) + addEnv idx {vs = vs :< v} (bs :< b) used = let n = getBindName idx v used (ns, rest) = addEnv (idx + 1) bs (snd n :: used) ns' = n :: ns in @@ -431,23 +431,23 @@ checkCase rig elabinfo nest env fc opts scr scrty_in alts exp = throw (GenericMsg fc "Can't infer type for case scrutinee") checkConcrete _ = pure () - applyTo : Defs -> RawImp -> NF [] -> Core RawImp + applyTo : Defs -> RawImp -> NF [<] -> Core RawImp applyTo defs ty (NBind fc _ (Pi _ _ Explicit _) sc) = applyTo defs (IApp fc ty (Implicit fc False)) - !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder))) + !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) applyTo defs ty (NBind _ x (Pi _ _ _ _) sc) = applyTo defs (INamedApp fc ty x (Implicit fc False)) - !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder))) + !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) applyTo defs ty _ = pure ty -- Get the name and type of the family the scrutinee is in - getRetTy : Defs -> NF [] -> Core (Maybe (Name, NF [])) + getRetTy : Defs -> NF [<] -> Core (Maybe (Name, NF [<])) getRetTy defs (NBind fc _ (Pi _ _ _ _) sc) - = getRetTy defs !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder))) + = getRetTy defs !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) getRetTy defs (NTCon _ n _ arity _) = do Just ty <- lookupTyExact n (gamma defs) | Nothing => pure Nothing - pure (Just (n, !(nf defs [] ty))) + pure (Just (n, !(nf defs [<] ty))) getRetTy _ _ = pure Nothing -- Guess a scrutinee type by looking at the alternatives, so that we @@ -460,7 +460,7 @@ checkCase rig elabinfo nest env fc opts scr scrty_in alts exp do defs <- get Ctxt [(_, (_, ty))] <- lookupTyName (mapNestedName nest n) (gamma defs) | _ => guessScrType xs - Just (tyn, tyty) <- getRetTy defs !(nf defs [] ty) + Just (tyn, tyty) <- getRetTy defs !(nf defs [<] ty) | _ => guessScrType xs applyTo defs (IVar fc tyn) tyty _ => guessScrType xs diff --git a/src/TTImp/Elab/Check.idr b/src/TTImp/Elab/Check.idr index 89073fe982..a40c96a8f2 100644 --- a/src/TTImp/Elab/Check.idr +++ b/src/TTImp/Elab/Check.idr @@ -27,6 +27,8 @@ import Libraries.Data.NameMap import Libraries.Data.UserNameMap import Libraries.Data.WithDefault +import Libraries.Data.SnocList.SizeOf + %default covering public export @@ -62,7 +64,7 @@ Eq ElabOpt where -- Descriptions of implicit name bindings. They're either just the name, -- or a binding of an @-pattern which has an associated pattern. public export -data ImplBinding : List Name -> Type where +data ImplBinding : SnocList Name -> Type where NameBinding : {vars : _} -> FC -> RigCount -> PiInfo (Term vars) -> (elabAs : Term vars) -> (expTy : Term vars) -> @@ -113,9 +115,9 @@ bindingPiInfo (AsBinding _ p _ _ _) = p -- Current elaboration state (preserved/updated throughout elaboration) public export -record EState (vars : List Name) where +record EState (vars : SnocList Name) where constructor MkEState - {outer : List Name} + {outer : SnocList Name} -- The function/constructor name we're currently working on (resolved id) defining : Int -- The outer environment in which we're running the elaborator. Things here should @@ -190,7 +192,7 @@ saveHole n = update EST { saveHoles $= insert n () } weakenedEState : {n, vars : _} -> {auto e : Ref EST (EState vars)} -> - Core (Ref EST (EState (n :: vars))) + Core (Ref EST (EState (vars :< n))) weakenedEState {e} = do est <- get EST eref <- newRef EST $ @@ -203,7 +205,7 @@ weakenedEState {e} pure eref where wknTms : (Name, ImplBinding vs) -> - (Name, ImplBinding (n :: vs)) + (Name, ImplBinding (vs :< n)) wknTms (f, NameBinding fc c p x y) = (f, NameBinding fc c (map weaken p) (weaken x) (weaken y)) wknTms (f, AsBinding c p x y z) @@ -211,8 +213,8 @@ weakenedEState {e} strengthenedEState : {n, vars : _} -> Ref Ctxt Defs -> - Ref EST (EState (n :: vars)) -> - FC -> Env Term (n :: vars) -> + Ref EST (EState (vars :< n)) -> + FC -> Env Term (vars :< n) -> Core (EState vars) strengthenedEState {n} {vars} c e fc env = do est <- get EST @@ -228,7 +230,7 @@ strengthenedEState {n} {vars} c e fc env } est where - dropSub : Thin xs (y :: ys) -> Core (Thin xs ys) + dropSub : Thin xs (ys :< y) -> Core (Thin xs ys) dropSub (Drop sub) = pure sub dropSub _ = throw (InternalError "Badly formed weakened environment") @@ -239,27 +241,27 @@ strengthenedEState {n} {vars} c e fc env -- never actualy *use* that hole - this process is only to ensure that the -- unbound implicit doesn't depend on any variables it doesn't have -- in scope. - removeArgVars : List (Term (n :: vs)) -> Maybe (List (Term vs)) - removeArgVars [] = pure [] - removeArgVars (Local fc r (S k) p :: args) + removeArgVars : SnocList (Term (vs :< n)) -> Maybe (SnocList (Term vs)) + removeArgVars [<] = pure [<] + removeArgVars (args :< Local fc r (S k) p) = do args' <- removeArgVars args - pure (Local fc r _ (dropLater p) :: args') - removeArgVars (Local fc r Z p :: args) + pure (args' :< Local fc r _ (dropLater p)) + removeArgVars (args :< Local fc r Z p) = removeArgVars args - removeArgVars (a :: args) + removeArgVars (args :< a) = do a' <- shrink a (Drop Refl) args' <- removeArgVars args - pure (a' :: args') + pure (args' :< a') - removeArg : Term (n :: vs) -> Maybe (Term vs) + removeArg : Term (vs :< n) -> Maybe (Term vs) removeArg tm - = case getFnArgs tm of + = case getFnArgsSpine tm of (f, args) => do args' <- removeArgVars args f' <- shrink f (Drop Refl) - pure (apply (getLoc f) f' args') + pure (applySpine (getLoc f) f' args') - strTms : Defs -> (Name, ImplBinding (n :: vars)) -> + strTms : Defs -> (Name, ImplBinding (vars :< n)) -> Core (Name, ImplBinding vars) strTms defs (f, NameBinding fc c p x y) = do xnf <- normaliseHoles defs env x @@ -282,7 +284,7 @@ strengthenedEState {n} {vars} c e fc env pure (f, AsBinding c p' x' y' z') _ => throw (BadUnboundImplicit fc env f y) - dropTop : (Var (n :: vs)) -> Maybe (Var vs) + dropTop : (Var (vs :< n)) -> Maybe (Var vs) dropTop (MkVar First) = Nothing dropTop (MkVar (Later p)) = Just (MkVar p) @@ -290,8 +292,8 @@ export inScope : {n, vars : _} -> {auto c : Ref Ctxt Defs} -> {auto e : Ref EST (EState vars)} -> - FC -> Env Term (n :: vars) -> - (Ref EST (EState (n :: vars)) -> Core a) -> + FC -> Env Term (vars :< n) -> + (Ref EST (EState (vars :< n)) -> Core a) -> Core a inScope {c} {e} fc env elab = do e' <- weakenedEState @@ -413,7 +415,7 @@ uniVar : {auto c : Ref Ctxt Defs} -> FC -> Core Name uniVar fc = do n <- genName "u" - idx <- addDef n (newDef fc n erased [] (Erased fc Placeholder) (specified Public) None) + idx <- addDef n (newDef fc n erased [<] (Erased fc Placeholder) (specified Public) None) pure (Resolved idx) export @@ -452,8 +454,8 @@ searchVar fc rig depth def env nest n ty else find x xs envHints : List Name -> Env Term vars -> - Core (vars' ** (Term (vars' ++ vars) -> Term vars, Env Term (vars' ++ vars))) - envHints [] env = pure ([] ** (id, env)) + Core (vars' ** (Term (vars ++ vars') -> Term vars, Env Term (vars ++ vars'))) + envHints [] env = pure ([<] ** (id, env)) envHints (n :: ns) env = do (vs ** (f, env')) <- envHints ns env let Just (nestn, argns, tmf) = find !(toFullNames n) (names nest) @@ -468,9 +470,9 @@ searchVar fc rig depth def env nest n ty let binder = Let fc top (weakenNs (mkSizeOf vs) app) (weakenNs (mkSizeOf vs) tyenv) varn <- toFullNames n' - pure ((varn :: vs) ** + pure ((vs :< varn) ** (\t => f (Bind fc varn binder t), - binder :: env')) + env' :< binder)) -- Elaboration info (passed to recursive calls) public export @@ -743,18 +745,19 @@ convertWithLazy withLazy fc elabinfo env x y (do let lazy = !isLazyActive && withLazy logGlueNF "elab.unify" 5 ("Unifying " ++ show withLazy ++ " " ++ show (elabMode elabinfo)) env x - logGlueNF "elab.unify" 5 "....with" env y vs <- if isFromTerm x && isFromTerm y - then do xtm <- getTerm x + then do logGlueNF "elab.unify" 5 "....with lazy=\{show lazy} from Term" env y + xtm <- getTerm x ytm <- getTerm y if lazy - then unifyWithLazy umode fc env xtm ytm - else unify umode fc env xtm ytm - else do xnf <- getNF x + then logDepth $ unifyWithLazy umode fc env xtm ytm + else logDepth $ unify umode fc env xtm ytm + else do logGlueNF "elab.unify" 5 "....with lazy=\{show lazy} from NF" env y + xnf <- getNF x ynf <- getNF y if lazy - then unifyWithLazy umode fc env xnf ynf - else unify umode fc env xnf ynf + then logDepth $ unifyWithLazy umode fc env xnf ynf + else logDepth $ unify umode fc env xnf ynf when (holesSolved vs) $ solveConstraints umode Normal pure vs) diff --git a/src/TTImp/Elab/Delayed.idr b/src/TTImp/Elab/Delayed.idr index 94d5332b65..9ab4f86fb3 100644 --- a/src/TTImp/Elab/Delayed.idr +++ b/src/TTImp/Elab/Delayed.idr @@ -15,7 +15,9 @@ import TTImp.Elab.Check import Libraries.Data.IntMap import Libraries.Data.NameMap + import Data.List +import Data.SnocList %default covering @@ -25,10 +27,10 @@ mkClosedElab : {vars : _} -> FC -> Env Term vars -> (Core (Term vars, Glued vars)) -> Core ClosedTerm -mkClosedElab fc [] elab +mkClosedElab fc [<] elab = do (tm, _) <- elab pure tm -mkClosedElab {vars = x :: vars} fc (b :: env) elab +mkClosedElab {vars = vars :< x} fc (env :< b) elab = mkClosedElab fc env (do (sc', _) <- elab let b' = newBinder b @@ -163,11 +165,11 @@ mutual mismatchNF defs (NTCon _ xn xt _ xargs) (NTCon _ yn yt _ yargs) = if xn /= yn then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) mismatchNF defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) = if xt /= yt then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) mismatchNF defs (NPrimVal _ xc) (NPrimVal _ yc) = pure (xc /= yc) mismatchNF defs (NDelayed _ _ x) (NDelayed _ _ y) = mismatchNF defs x y mismatchNF defs (NDelay _ _ _ x) (NDelay _ _ _ y) @@ -187,11 +189,11 @@ contra : {auto c : Ref Ctxt Defs} -> contra defs (NTCon _ xn xt xa xargs) (NTCon _ yn yt ya yargs) = if xn /= yn then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) contra defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) = if xt /= yt then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) contra defs (NPrimVal _ x) (NPrimVal _ y) = pure (x /= y) contra defs (NDCon _ _ _ _ _) (NPrimVal _ _) = pure True contra defs (NPrimVal _ _) (NDCon _ _ _ _ _) = pure True @@ -258,9 +260,9 @@ retryDelayed' errmode p acc (d@(_, i, hints, elab) :: ds) updateDef (Resolved i) (const (Just (PMDef (MkPMDefInfo NotHole True False) - [] (STerm 0 tm) (STerm 0 tm) []))) + [<] (STerm 0 tm) (STerm 0 tm) []))) logTerm "elab.update" 5 ("Resolved delayed hole " ++ show i) tm - logTermNF "elab.update" 5 ("Resolved delayed hole NF " ++ show i) [] tm + logTermNF "elab.update" 5 ("Resolved delayed hole NF " ++ show i) [<] tm removeHole i retryDelayed' errmode True acc ds') (\err => do logC "elab" 5 $ do pure $ show errmode ++ ":Error in " ++ show !(getFullName (Resolved i)) diff --git a/src/TTImp/Elab/ImplicitBind.idr b/src/TTImp/Elab/ImplicitBind.idr index 2f173b5674..6639a7f1a1 100644 --- a/src/TTImp/Elab/ImplicitBind.idr +++ b/src/TTImp/Elab/ImplicitBind.idr @@ -100,7 +100,7 @@ mkPatternHole {vars'} loc rig n topenv imode (Just expty_in) Env Term vs -> Term vs -> Thin newvars vs -> Maybe (Term newvars) bindInner env ty Refl = Just ty - bindInner {vs = x :: _} (b :: env) ty (Drop p) + bindInner {vs = _ :< x} (env :< b) ty (Drop p) = bindInner env (Bind loc x b ty) p bindInner _ _ _ = Nothing @@ -169,34 +169,34 @@ bindUnsolved {vars} fc elabmode _ _ => inTerm) fc env tm bindtm -swapIsVarH : {idx : Nat} -> (0 p : IsVar nm idx (x :: y :: xs)) -> - Var (y :: x :: xs) +swapIsVarH : {idx : Nat} -> (0 p : IsVar nm idx (xs :< y :< x)) -> + Var (xs :< x :< y) swapIsVarH First = MkVar (Later First) swapIsVarH (Later p) = swapP p -- it'd be nice to do this all at the top -- level, but that will need an improvement -- in erasability checking where - swapP : forall name . {idx : _} -> (0 p : IsVar name idx (y :: xs)) -> - Var (y :: x :: xs) + swapP : forall name . {idx : _} -> (0 p : IsVar name idx (xs :< y)) -> + Var (xs :< x :< y) swapP First = MkVar First swapP (Later x) = MkVar (Later (Later x)) -swapIsVar : (vs : List Name) -> - {idx : Nat} -> (0 p : IsVar nm idx (vs ++ x :: y :: xs)) -> - Var (vs ++ y :: x :: xs) -swapIsVar [] prf = swapIsVarH prf -swapIsVar (x :: xs) First = MkVar First -swapIsVar (x :: xs) (Later p) +swapIsVar : (vs : SnocList Name) -> + {idx : Nat} -> (0 p : IsVar nm idx (xs :< y :< x ++ vs)) -> + Var (xs :< x :< y ++ vs) +swapIsVar [<] prf = swapIsVarH prf +swapIsVar (xs :< x) First = MkVar First +swapIsVar (xs :< x) (Later p) = let MkVar p' = swapIsVar xs p in MkVar (Later p') -swapVars : {vs : List Name} -> - Term (vs ++ x :: y :: ys) -> Term (vs ++ y :: x :: ys) +swapVars : {vs : SnocList Name} -> + Term (ys :< y :< x ++ vs) -> Term (ys :< x :< y ++ vs) swapVars (Local fc x idx p) = let MkVar p' = swapIsVar _ p in Local fc x _ p' swapVars (Ref fc x name) = Ref fc x name swapVars (Meta fc n i xs) = Meta fc n i (map swapVars xs) swapVars {vs} (Bind fc x b scope) - = Bind fc x (map swapVars b) (swapVars {vs = x :: vs} scope) + = Bind fc x (map swapVars b) (swapVars {vs = vs :< x} scope) swapVars (App fc fn arg) = App fc (swapVars fn) (swapVars arg) swapVars (As fc s nm pat) = As fc s (swapVars nm) (swapVars pat) swapVars (TDelayed fc x tm) = TDelayed fc x (swapVars tm) @@ -212,13 +212,13 @@ swapVars (TType fc u) = TType fc u -- move it under implicit binders that don't depend on it, and stop -- when hitting any non-implicit binder push : {vs : _} -> - FC -> (n : Name) -> Binder (Term vs) -> Term (n :: vs) -> Term vs + FC -> (n : Name) -> Binder (Term vs) -> Term (vs :< n) -> Term vs push ofc n b tm@(Bind fc (PV x i) (Pi fc' c Implicit ty) sc) -- only push past 'PV's = case shrink ty (Drop Refl) of Nothing => -- needs explicit pi, do nothing Bind ofc n b tm Just ty' => Bind fc (PV x i) (Pi fc' c Implicit ty') - (push ofc n (map weaken b) (swapVars {vs = []} sc)) + (push ofc n (map weaken b) (swapVars {vs = [<]} sc)) push ofc n b tm = Bind ofc n b tm -- Move any implicit arguments as far to the left as possible - this helps @@ -259,7 +259,7 @@ bindImplVars {vars} fc mode gam env imps_in scope scty getBinds : (imps : List (Name, Name, ImplBinding vs)) -> Bounds new -> (tm : Term vs) -> (ty : Term vs) -> - (Term (new ++ vs), Term (new ++ vs)) + (Term (vs ++ new), Term (vs ++ new)) getBinds [] bs tm ty = (refsToLocals bs tm, refsToLocals bs ty) getBinds {new} ((n, metan, NameBinding loc c p _ bty) :: imps) bs tm ty = let (tm', ty') = getBinds imps (Add n metan bs) tm ty @@ -285,7 +285,7 @@ normaliseHolesScope defs env (Bind fc n b sc) = pure $ Bind fc n b !(normaliseHolesScope defs -- use Lam because we don't want it reducing in the scope - (Lam fc (multiplicity b) Explicit (binderType b) :: env) sc) + (env :< Lam fc (multiplicity b) Explicit (binderType b)) sc) normaliseHolesScope defs env tm = normaliseHoles defs env tm export @@ -583,6 +583,8 @@ checkBindHere rig elabinfo nest env fc bindmode tm exp -- before binding names logTerm "elab.implicits" 5 "Binding names" tmv + defs <- get Ctxt + log "elab.implicits" 5 $ "Normal form: " ++ show !(toFullNames !(nfOpts withHoles defs env tmv)) logTermNF "elab.implicits" 5 "Normalised" env tmv argImps <- getToBind fc (elabMode elabinfo) bindmode env dontbind diff --git a/src/TTImp/Elab/Local.idr b/src/TTImp/Elab/Local.idr index cd10ca45f1..1fc896b9fe 100644 --- a/src/TTImp/Elab/Local.idr +++ b/src/TTImp/Elab/Local.idr @@ -83,11 +83,11 @@ localHelper {vars} nest env nestdecls_in func -- 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) + dropLinear [<] = [<] + dropLinear (bs :< b) = if isLinear (multiplicity b) - then setMultiplicity b erased :: dropLinear bs - else b :: dropLinear bs + then dropLinear bs :< setMultiplicity b erased + else dropLinear bs :< b applyEnv : Int -> Name -> Core (Name, (Maybe Name, List (Var vars), FC -> NameType -> Term vars)) diff --git a/src/TTImp/Elab/Record.idr b/src/TTImp/Elab/Record.idr index 7cae467d75..df38308dd1 100644 --- a/src/TTImp/Elab/Record.idr +++ b/src/TTImp/Elab/Record.idr @@ -18,6 +18,7 @@ import TTImp.Elab.Delayed import TTImp.TTImp import Data.List +import Data.SnocList import Libraries.Data.SortedSet %default covering @@ -26,12 +27,12 @@ getRecordType : Env Term vars -> NF vars -> Maybe Name getRecordType env (NTCon _ n _ _ _) = Just n getRecordType env _ = Nothing -getNames : {auto c : Ref Ctxt Defs} -> Defs -> NF [] -> Core $ SortedSet Name +getNames : {auto c : Ref Ctxt Defs} -> Defs -> NF [<] -> Core $ SortedSet Name getNames defs (NApp _ hd args) = do eargs <- traverse (evalClosure defs . snd) args pure $ nheadNames hd `union` concat !(traverse (getNames defs) eargs) where - nheadNames : NHead [] -> SortedSet Name + nheadNames : NHead [<] -> SortedSet Name nheadNames (NRef Bound n) = singleton n nheadNames _ = empty getNames defs (NDCon _ _ _ _ args) @@ -87,12 +88,12 @@ findFieldsAndTypeArgs : {auto c : Ref Ctxt Defs} -> Core $ Maybe (List (String, Maybe Name, Maybe Name), SortedSet Name) findFieldsAndTypeArgs defs con = case !(lookupTyExact con (gamma defs)) of - Just t => pure (Just !(getExpNames empty [] !(nf defs [] t))) + Just t => pure (Just !(getExpNames empty [] !(nf defs [<] t))) _ => pure Nothing where getExpNames : SortedSet Name -> List (String, Maybe Name, Maybe Name) -> - NF [] -> + NF [<] -> Core (List (String, Maybe Name, Maybe Name), SortedSet Name) getExpNames names expNames (NBind fc x (Pi _ _ p ty) sc) = do let imp = case p of @@ -100,8 +101,8 @@ findFieldsAndTypeArgs defs con _ => Just x nfty <- evalClosure defs ty let names = !(getNames defs nfty) `union` names - let expNames = (nameRoot x, imp, getRecordType [] nfty) :: expNames - getExpNames names expNames !(sc defs (toClosure defaultOpts [] (Ref fc Bound x))) + let expNames = (nameRoot x, imp, getRecordType [<] nfty) :: expNames + getExpNames names expNames !(sc defs (toClosure defaultOpts [<] (Ref fc Bound x))) getExpNames names expNames nfty = pure (reverse expNames, (!(getNames defs nfty) `union` names)) genFieldName : {auto u : Ref UST UState} -> diff --git a/src/TTImp/Elab/Rewrite.idr b/src/TTImp/Elab/Rewrite.idr index bb0f211f19..242b575035 100644 --- a/src/TTImp/Elab/Rewrite.idr +++ b/src/TTImp/Elab/Rewrite.idr @@ -18,6 +18,9 @@ import TTImp.Elab.Check import TTImp.Elab.Delayed import TTImp.TTImp +import Data.SnocList +import Libraries.Data.SnocList.SizeOf + %default covering -- TODO: Later, we'll get the name of the lemma from the type, if it's one @@ -36,8 +39,8 @@ getRewriteTerms : {vars : _} -> Core (NF vars, NF vars, NF vars) getRewriteTerms loc defs (NTCon nfc eq t a args) err = if !(isEqualTy eq) - then case reverse $ map snd args of - (rhs :: lhs :: rhsty :: lhsty :: _) => + then case map snd args of + (_ :< lhsty :< rhsty :< lhs :< rhs) => pure (!(evalClosure defs lhs), !(evalClosure defs rhs), !(evalClosure defs lhsty)) @@ -135,7 +138,7 @@ checkRewrite {vars} rigc elabinfo nest env ifc rule tm (Just expected) let pbind = Let vfc erased lemma.pred lemma.predTy let rbind = Let vfc erased (weaken rulev) (weaken rulet) - let env' = rbind :: pbind :: env + let env' = env :< pbind :< rbind -- Nothing we do in this last part will affect the EState, -- we're only doing the application this way to make sure the @@ -143,9 +146,9 @@ checkRewrite {vars} rigc elabinfo nest env ifc rule tm (Just expected) -- we still need the right type for the EState, so weaken it once -- for each of the let bindings above. (rwtm, grwty) <- - inScope vfc (pbind :: env) $ \e' => + inScope vfc (env :< pbind) $ \e' => inScope {e=e'} vfc env' $ \e'' => - let offset = mkSizeOf [rname, pname] in + let offset = mkSizeOf [ elabScript rig fc nest env script@(NDCon nfc nm t ar args) exp = do defs <- get Ctxt fnm <- toFullNames nm + log "reflection.reify" 10 $ "elabScript fnm: \{show fnm}, args: \{show $ toList $ map snd args}" case fnm of NS ns (UN (Basic n)) => if ns == reflectionNS @@ -116,7 +119,7 @@ elabScript rig fc nest env script@(NDCon nfc nm t ar args) exp -- parses and resolves `Language.Reflection.LookupDir` lookupDir : Defs -> NF vars -> Core String - lookupDir defs (NDCon _ conName _ _ []) + lookupDir defs (NDCon _ conName _ _ [<]) = do defs <- get Ctxt NS ns (UN (Basic n)) <- toFullNames conName | fnm => failWith defs $ "bad lookup dir fullnames " ++ show fnm @@ -156,25 +159,25 @@ elabScript rig fc nest env script@(NDCon nfc nm t ar args) exp pathDoesNotEscape n ("." ::rest) = pathDoesNotEscape n rest pathDoesNotEscape n (_ ::rest) = pathDoesNotEscape (S n) rest - elabCon : Defs -> String -> List (Closure vars) -> Core (NF vars) - elabCon defs "Pure" [_,val] + elabCon : Defs -> String -> SnocList (Closure vars) -> Core (NF vars) + elabCon defs "Pure" [<_, val] = do empty <- clearDefs defs evalClosure empty val - elabCon defs "Map" [_,_,fm,act] + elabCon defs "Map" [<_, _, fm, act] -- fm : A -> B -- elab : A = do act <- elabScript rig fc nest env !(evalClosure defs act) exp act <- quote defs env act fm <- evalClosure defs fm applyToStack defs withHoles env fm [(getLoc act, toClosure withAll env act)] - elabCon defs "Ap" [_,_,actF,actX] + elabCon defs "Ap" [<_, _, actF, actX] -- actF : Elab (A -> B) -- actX : Elab A = do actF <- elabScript rig fc nest env !(evalClosure defs actF) exp actX <- elabScript rig fc nest env !(evalClosure defs actX) exp actX <- quote defs env actX applyToStack defs withHoles env actF [(getLoc actX, toClosure withAll env actX)] - elabCon defs "Bind" [_,_,act,k] + elabCon defs "Bind" [<_,_,act,k] -- act : Elab A -- k : A -> Elab B -- 1) Run elabScript on act stripping off Elab @@ -187,14 +190,14 @@ elabScript rig fc nest env script@(NDCon nfc nm t ar args) exp k <- evalClosure defs k r <- applyToStack defs withAll env k [(getLoc act, toClosure withAll env act)] elabScript rig fc nest env r exp - elabCon defs "Fail" [_, mbfc, msg] + elabCon defs "Fail" [<_, mbfc, msg] = do msg' <- evalClosure defs msg throw $ RunElabFail $ GenericMsg !(reifyFC defs mbfc) !(reify defs msg') - elabCon defs "Warn" [mbfc, msg] + elabCon defs "Warn" [ failWith defs "Not a lambda" @@ -253,7 +256,7 @@ elabScript rig fc nest env script@(NDCon nfc nm t ar args) exp let lamsc = refToLocal n x qsc qp <- quotePi p qty <- quote empty env ty - let env' = Lam fc' c qp qty :: env + let env' = env :< Lam fc' c qp qty runsc <- elabScript rig fc (weaken nest) env' !(nf defs env' lamsc) Nothing -- (map weaken exp) @@ -264,39 +267,39 @@ elabScript rig fc nest env script@(NDCon nfc nm t ar args) exp quotePi Implicit = pure Implicit quotePi AutoImplicit = pure AutoImplicit quotePi (DefImplicit t) = failWith defs "Can't add default lambda" - elabCon defs "Goal" [] + elabCon defs "Goal" [<] = do let Just gty = exp | Nothing => nfOpts withAll defs env !(reflect fc defs False env (the (Maybe RawImp) Nothing)) ty <- getTerm gty scriptRet (Just $ map rawName $ !(unelabUniqueBinders env ty)) - elabCon defs "LocalVars" [] + elabCon defs "LocalVars" [<] = scriptRet vars - elabCon defs "GenSym" [str] + elabCon defs "GenSym" [ Core (Name, RawImp) unelabType (n, _, ty) - = pure (n, map rawName !(unelabUniqueBinders [] ty)) - elabCon defs "GetInfo" [n] + = pure (n, map rawName !(unelabUniqueBinders [<] ty)) + elabCon defs "GetInfo" [ (n, collapseDefault $ visibility d)) ds - elabCon defs "GetLocalType" [n] + elabCon defs "GetLocalType" [ failWith defs $ show n ++ " is not a local variable" - elabCon defs "GetCons" [n] + elabCon defs "GetCons" [ failWith defs $ show cn ++ " is not a type" scriptRet cons - elabCon defs "GetReferredFns" [n] + elabCon defs "GetReferredFns" [ failWith defs $ show dn ++ " is not a definition" ns <- deepRefersTo def scriptRet ns - elabCon defs "GetCurrentFn" [] + elabCon defs "GetCurrentFn" [<] = do defs <- get Ctxt scriptRet defs.defsStack - elabCon defs "Declare" [d] + elabCon defs "Declare" [ scriptRet $ Nothing {ty=String} contents <- readFile fullPath scriptRet $ Just contents - elabCon defs "WriteFile" [lk, pth, contents] + elabCon defs "WriteFile" [>= lookupDir defs >>= scriptRet elabCon defs n args = failWith defs $ "unexpected Elab constructor " ++ n ++ ", or incorrect count of arguments: " ++ show (length args) @@ -376,6 +379,8 @@ checkRunElab rig elabinfo nest env fc reqExt script exp check rig elabinfo nest env script (Just (gnf env elabtt)) solveConstraints inTerm Normal defs <- get Ctxt -- checking might have resolved some holes + logTerm "reflection.reify" 10 "checkRunElab stm" stm + logEnv "reflection.reify" 10 "checkRunElab env" env ntm <- elabScript rig fc nest env !(nfOpts withAll defs env stm) (Just (gnf env expected)) defs <- get Ctxt -- might have updated as part of the script diff --git a/src/TTImp/Elab/Utils.idr b/src/TTImp/Elab/Utils.idr index 39adffc147..a164eea437 100644 --- a/src/TTImp/Elab/Utils.idr +++ b/src/TTImp/Elab/Utils.idr @@ -11,19 +11,21 @@ import Core.Value import TTImp.Elab.Check import TTImp.TTImp +import Data.SnocList + %default covering detagSafe : {auto c : Ref Ctxt Defs} -> - Defs -> NF [] -> Core Bool + Defs -> NF [<] -> Core Bool detagSafe defs (NTCon _ n _ _ args) = do Just (TCon _ _ _ _ _ _ _ (Just detags)) <- lookupDefExact n (gamma defs) | _ => pure False - args' <- traverse (evalClosure defs . snd) args + args' <- traverse (evalClosure defs . snd) (toList args) pure $ notErased 0 detags args' where -- if any argument positions are in the detaggable set, and unerased, then -- detagging is safe - notErased : Nat -> List Nat -> List (NF []) -> Bool + notErased : Nat -> List Nat -> List (NF [<]) -> Bool notErased i [] _ = True -- Don't need an index available notErased i ns [] = False notErased i ns (NErased _ Impossible :: rest) @@ -33,12 +35,12 @@ detagSafe defs (NTCon _ n _ _ args) detagSafe defs _ = pure False findErasedFrom : {auto c : Ref Ctxt Defs} -> - Defs -> Nat -> NF [] -> Core (List Nat, List Nat) + Defs -> Nat -> NF [<] -> Core (List Nat, List Nat) findErasedFrom defs pos (NBind fc x (Pi _ c _ aty) scf) = do -- In the scope, use 'Erased fc Impossible' to mean 'argument is erased'. -- It's handy here, because we can use it to tell if a detaggable -- argument position is available - sc <- scf defs (toClosure defaultOpts [] (Erased fc (ifThenElse (isErased c) Impossible Placeholder))) + sc <- scf defs (toClosure defaultOpts [<] (Erased fc (ifThenElse (isErased c) Impossible Placeholder))) (erest, dtrest) <- findErasedFrom defs (1 + pos) sc let dt' = if !(detagSafe defs !(evalClosure defs aty)) then (pos :: dtrest) else dtrest @@ -54,7 +56,7 @@ findErased : {auto c : Ref Ctxt Defs} -> ClosedTerm -> Core (List Nat, List Nat) findErased tm = do defs <- get Ctxt - tmnf <- nf defs [] tm + tmnf <- nf defs [<] tm findErasedFrom defs 0 tmnf export @@ -86,16 +88,16 @@ bindNotReq : {vs : _} -> FC -> Int -> Env Term vs -> (sub : Thin pre vs) -> List (PiInfo RawImp, Name) -> Term vs -> (List (PiInfo RawImp, Name), Term pre) -bindNotReq fc i [] Refl ns tm = (ns, embed tm) -bindNotReq fc i (b :: env) Refl ns tm +bindNotReq fc i [<] Refl ns tm = (ns, embed tm) +bindNotReq fc i (env :< b) Refl ns tm = let tmptm = subst (Ref fc Bound (MN "arg" i)) tm (ns', btm) = bindNotReq fc (1 + i) env Refl ns tmptm in (ns', refToLocal (MN "arg" i) _ btm) -bindNotReq fc i (b :: env) (Keep p) ns tm +bindNotReq fc i (env :< b) (Keep p) ns tm = let tmptm = subst (Ref fc Bound (MN "arg" i)) tm (ns', btm) = bindNotReq fc (1 + i) env p ns tmptm in (ns', refToLocal (MN "arg" i) _ btm) -bindNotReq {vs = n :: _} fc i (b :: env) (Drop p) ns tm +bindNotReq {vs = _ :< n} fc i (env :< b) (Drop p) ns tm = bindNotReq fc i env p ((plicit b, n) :: ns) (Bind fc _ (Pi (binderLoc b) (multiplicity b) Explicit (binderType b)) tm) @@ -107,15 +109,15 @@ bindReq : {vs : _} -> bindReq {vs} fc env Refl ns tm = pure (ns, notLets [] _ env, abstractEnvType fc env tm) where - notLets : List Name -> (vars : List Name) -> Env Term vars -> List Name - notLets acc [] _ = acc - notLets acc (v :: vs) (b :: env) = if isLet b then notLets acc vs env + notLets : List Name -> (vars : SnocList Name) -> Env Term vars -> List Name + notLets acc [<] _ = acc + notLets acc (vs :< v) (env :< b) = if isLet b then notLets acc vs env else notLets (v :: acc) vs env -bindReq {vs = n :: _} fc (b :: env) (Keep p) ns tm +bindReq {vs = _ :< n} fc (env :< b) (Keep p) ns tm = do b' <- shrinkBinder b p bindReq fc env p ((plicit b, n) :: ns) (Bind fc _ (Pi (binderLoc b) (multiplicity b) Explicit (binderType b')) tm) -bindReq fc (b :: env) (Drop p) ns tm +bindReq fc (env :< b) (Drop p) ns tm = bindReq fc env p ns tm -- This machinery is to calculate whether any top level argument is used @@ -126,30 +128,33 @@ data ArgUsed = Used1 -- been used | Used0 -- not used | LocalVar -- don't care if it's used -data Usage : List Name -> Type where - Nil : Usage [] - (::) : ArgUsed -> Usage xs -> Usage (x :: xs) +data Usage : SnocList Name -> Type where + Lin : Usage [<] + (:<) : Usage xs -> ArgUsed -> Usage (xs :< x) + +tail : Usage (xs :< x) -> Usage xs +tail (us :< _) = us -initUsed : (xs : List Name) -> Usage xs -initUsed [] = [] -initUsed (x :: xs) = Used0 :: initUsed xs +initUsed : (xs : SnocList Name) -> Usage xs +initUsed [<] = [<] +initUsed (xs :< _) = initUsed xs :< Used0 -initUsedCase : (xs : List Name) -> Usage xs -initUsedCase [] = [] -initUsedCase [x] = [Used0] -initUsedCase (x :: xs) = LocalVar :: initUsedCase xs +initUsedCase : (xs : SnocList Name) -> Usage xs +initUsedCase [<] = [<] +initUsedCase [ (0 _ : IsVar n idx xs) -> Usage xs -> Usage xs -setUsedVar First (Used0 :: us) = Used1 :: us -setUsedVar (Later p) (x :: us) = x :: setUsedVar p us +setUsedVar First (us :< Used0) = us :< Used1 +setUsedVar (Later p) (us :< x) = setUsedVar p us :< x setUsedVar First us = us isUsed : {idx : _} -> (0 _ : IsVar n idx xs) -> Usage xs -> Bool -isUsed First (Used1 :: us) = True -isUsed First (_ :: us) = False -isUsed (Later p) (_ :: us) = isUsed p us +isUsed First (us :< Used1) = True +isUsed First (us :< _) = False +isUsed (Later p) (us :< _) = isUsed p us data Used : Type where @@ -158,17 +163,17 @@ setUsed : {idx : _} -> (0 _ : IsVar n idx vars) -> Core () setUsed p = update Used $ setUsedVar p -extendUsed : ArgUsed -> (new : List Name) -> Usage vars -> Usage (new ++ vars) +extendUsed : ArgUsed -> (new : List Name) -> Usage vars -> Usage (vars <>< new) extendUsed a [] x = x -extendUsed a (y :: xs) x = a :: extendUsed a xs x +extendUsed a (y :: xs) x = extendUsed a xs (x :< a) -dropUsed : (new : List Name) -> Usage (new ++ vars) -> Usage vars +dropUsed : (new : List Name) -> Usage (vars <>< new) -> Usage vars dropUsed [] x = x -dropUsed (x :: xs) (u :: us) = dropUsed xs us +dropUsed (_ :: xs) (us) = tail (dropUsed xs us) inExtended : ArgUsed -> (new : List Name) -> {auto u : Ref Used (Usage vars)} -> - (Ref Used (Usage (new ++ vars)) -> Core a) -> + (Ref Used (Usage (vars <>< new)) -> Core a) -> Core a inExtended a new sc = do used <- get Used diff --git a/src/TTImp/Impossible.idr b/src/TTImp/Impossible.idr index 6777fa115d..a86fe4a5f1 100644 --- a/src/TTImp/Impossible.idr +++ b/src/TTImp/Impossible.idr @@ -22,13 +22,13 @@ import Data.List -- they involve resoling interfaces - they'll just become unmatchable patterns. match : {auto c : Ref Ctxt Defs} -> - NF [] -> (Name, Int, ClosedTerm) -> Core Bool + NF [<] -> (Name, Int, ClosedTerm) -> Core Bool match nty (n, i, rty) = do defs <- get Ctxt - rtynf <- nf defs [] rty + rtynf <- nf defs [<] rty sameRet nty rtynf where - sameRet : NF [] -> NF [] -> Core Bool + sameRet : NF [<] -> NF [<] -> Core Bool sameRet _ (NApp _ _ _) = pure True sameRet _ (NErased _ _) = pure True sameRet (NApp _ _ _) _ = pure True @@ -38,12 +38,12 @@ match nty (n, i, rty) sameRet (NType _ _) (NType _ _) = pure True sameRet nf (NBind fc _ (Pi _ _ _ _) sc) = do defs <- get Ctxt - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) sameRet nf sc' sameRet _ _ = pure False dropNoMatch : {auto c : Ref Ctxt Defs} -> - Maybe (NF []) -> List (Name, Int, GlobalDef) -> + Maybe (NF [<]) -> List (Name, Int, GlobalDef) -> Core (List (Name, Int, GlobalDef)) dropNoMatch Nothing ts = pure ts dropNoMatch (Just nty) ts @@ -51,13 +51,13 @@ dropNoMatch (Just nty) ts filterM (match nty . map (map type)) ts nextVar : {auto q : Ref QVar Int} -> - FC -> Core (Term []) + FC -> Core (Term [<]) nextVar fc = do i <- get QVar put QVar (i + 1) pure (Ref fc Bound (MN "imp" i)) -badClause : Term [] -> List RawImp -> List RawImp -> List (Name, RawImp) -> Core a +badClause : Term [<] -> List RawImp -> List RawImp -> List (Name, RawImp) -> Core a badClause fn exps autos named = throw (GenericMsg (getLoc fn) ("Badly formed impossible clause " @@ -66,7 +66,7 @@ badClause fn exps autos named mutual processArgs : {auto c : Ref Ctxt Defs} -> {auto q : Ref QVar Int} -> - Term [] -> NF [] -> + Term [<] -> NF [<] -> (expargs : List RawImp) -> (autoargs : List RawImp) -> (namedargs : List (Name, RawImp)) -> @@ -75,14 +75,14 @@ mutual processArgs fn (NBind fc x (Pi _ _ Explicit ty) sc) (e :: exps) autos named = do e' <- mkTerm e (Just ty) [] [] [] defs <- get Ctxt - processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [] e')) + processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [<] e')) exps autos named processArgs fn (NBind fc x (Pi _ _ Explicit ty) sc) [] autos named = do defs <- get Ctxt case findNamed x named of Just ((_, e), named') => do e' <- mkTerm e (Just ty) [] [] [] - processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [] e')) + processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [<] e')) [] autos named' Nothing => badClause fn [] autos named processArgs fn (NBind fc x (Pi _ _ Implicit ty) sc) exps autos named @@ -90,29 +90,29 @@ mutual case findNamed x named of Nothing => do e' <- nextVar fc processArgs (App fc fn e') - !(sc defs (toClosure defaultOpts [] e')) + !(sc defs (toClosure defaultOpts [<] e')) exps autos named Just ((_, e), named') => do e' <- mkTerm e (Just ty) [] [] [] - processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [] e')) + processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [<] e')) exps autos named' processArgs fn (NBind fc x (Pi _ _ AutoImplicit ty) sc) exps autos named = do defs <- get Ctxt case autos of (e :: autos') => -- unnamed takes priority do e' <- mkTerm e (Just ty) [] [] [] - processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [] e')) + processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [<] e')) exps autos' named [] => case findNamed x named of Nothing => do e' <- nextVar fc processArgs (App fc fn e') - !(sc defs (toClosure defaultOpts [] e')) + !(sc defs (toClosure defaultOpts [<] e')) exps [] named Just ((_, e), named') => do e' <- mkTerm e (Just ty) [] [] [] - processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [] e')) + processArgs (App fc fn e') !(sc defs (toClosure defaultOpts [<] e')) exps [] named' processArgs fn ty [] [] [] = pure fn processArgs fn ty exps autos named @@ -120,7 +120,7 @@ mutual buildApp : {auto c : Ref Ctxt Defs} -> {auto q : Ref QVar Int} -> - FC -> Name -> Maybe (Closure []) -> + FC -> Name -> Maybe (Closure [<]) -> (expargs : List RawImp) -> (autoargs : List RawImp) -> (namedargs : List (Name, RawImp)) -> @@ -134,7 +134,7 @@ mutual gdefs <- lookupNameBy id n (gamma defs) [(n', i, gdef)] <- dropNoMatch !(traverseOpt (evalClosure defs) mty) gdefs | ts => ambiguousName fc n (map fst ts) - tynf <- nf defs [] (type gdef) + tynf <- nf defs [<] (type gdef) -- #899 we need to make sure that type & data constructors are marked -- as such so that the coverage checker actually uses the matches in -- `impossible` branches to generate parts of the case tree. @@ -149,7 +149,7 @@ mutual mkTerm : {auto c : Ref Ctxt Defs} -> {auto q : Ref QVar Int} -> - RawImp -> Maybe (Closure []) -> + RawImp -> Maybe (Closure [<]) -> (expargs : List RawImp) -> (autoargs : List RawImp) -> (namedargs : List (Name, RawImp)) -> @@ -184,8 +184,8 @@ getImpossibleTerm env nest tm where addEnv : {vars : _} -> FC -> Env Term vars -> List RawImp - addEnv fc [] = [] - addEnv fc (b :: env) = + addEnv fc [<] = [] + addEnv fc (env :< b) = if isLet b then addEnv fc env else Implicit fc False :: addEnv fc env diff --git a/src/TTImp/Interactive/CaseSplit.idr b/src/TTImp/Interactive/CaseSplit.idr index e741314556..1e531cffc7 100644 --- a/src/TTImp/Interactive/CaseSplit.idr +++ b/src/TTImp/Interactive/CaseSplit.idr @@ -78,8 +78,8 @@ findTyName defs env n (Bind _ x b@(PVar _ c p ty) sc) case tynf of NTCon _ tyn _ _ _ => pure $ Just tyn _ => pure Nothing - else findTyName defs (b :: env) n sc -findTyName defs env n (Bind _ x b sc) = findTyName defs (b :: env) n sc + else findTyName defs (env :< b) n sc +findTyName defs env n (Bind _ x b sc) = findTyName defs (env :< b) n sc findTyName _ _ _ _ = pure Nothing getDefining : Term vars -> Maybe Name @@ -92,14 +92,14 @@ getDefining tm -- For the name on the lhs, return the function name being defined, the -- type name, and the possible constructors. findCons : {auto c : Ref Ctxt Defs} -> - Name -> Term [] -> Core (SplitResult (Name, Name, List Name)) + Name -> Term [<] -> Core (SplitResult (Name, Name, List Name)) findCons n lhs = case getDefining lhs of Nothing => pure (SplitFail (CantSplitThis n "Can't find function name on LHS")) Just fn => do defs <- get Ctxt - case !(findTyName defs [] n lhs) of + case !(findTyName defs [<] n lhs) of Nothing => pure (SplitFail (CantSplitThis n ("Can't find type of " ++ show n ++ " in LHS"))) Just tyn => @@ -123,18 +123,18 @@ findAllVars (Bind _ x (PLet _ _ _ _) sc) findAllVars t = toList (dropNS <$> getDefining t) export -explicitlyBound : Defs -> NF [] -> Core (List Name) +explicitlyBound : Defs -> NF [<] -> Core (List Name) explicitlyBound defs (NBind fc x (Pi _ _ _ _) sc) = pure $ x :: !(explicitlyBound defs - !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder)))) + !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)))) explicitlyBound defs _ = pure [] export getEnvArgNames : {auto c : Ref Ctxt Defs} -> - Defs -> Nat -> NF [] -> Core (List String) -getEnvArgNames defs Z sc = getArgNames defs !(explicitlyBound defs sc) [] [] sc + Defs -> Nat -> NF [<] -> Core (List String) +getEnvArgNames defs Z sc = getArgNames defs !(explicitlyBound defs sc) [] [<] sc getEnvArgNames defs (S k) (NBind fc n _ sc) - = getEnvArgNames defs k !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder))) + = getEnvArgNames defs k !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) getEnvArgNames defs n ty = pure [] expandCon : {auto c : Ref Ctxt Defs} -> @@ -145,8 +145,8 @@ expandCon fc usedvars con | Nothing => undefinedName fc con pure (apply (IVar fc con) (map (IBindVar fc) - !(getArgNames defs [] usedvars [] - !(nf defs [] ty)))) + !(getArgNames defs [] usedvars [<] + !(nf defs [<] ty)))) updateArg : {auto c : Ref Ctxt Defs} -> List Name -> -- all the variable names @@ -274,13 +274,13 @@ mkCase {c} {u} fn orig lhs_raw -- once split and turned into a pattern) (lhs, _) <- elabTerm {c} {m} {u} fn (InLHS erased) [] (MkNested []) - [] (IBindHere (getFC lhs_raw) PATTERN lhs_raw) + [<] (IBindHere (getFC lhs_raw) PATTERN lhs_raw) Nothing -- Revert all public back to false setAllPublic False put Ctxt defs -- reset the context, we don't want any updates put UST ust - lhs' <- map (map rawName) $ unelabNoSugar [] lhs + lhs' <- map (map rawName) $ unelabNoSugar [<] lhs log "interaction.casesplit" 3 $ "Original LHS: " ++ show orig log "interaction.casesplit" 3 $ "New LHS: " ++ show lhs' @@ -330,7 +330,7 @@ getSplitsLHS fc envlen lhs_in n OK (fn, tyn, cons) <- findCons n lhs | SplitFail err => pure (SplitFail err) - rawlhs <- map (map rawName) $ unelabNoSugar [] lhs + rawlhs <- map (map rawName) $ unelabNoSugar [<] lhs trycases <- traverse (\c => newLHS fc envlen usedns n c rawlhs) cons let Just idx = getNameID fn (gamma defs) diff --git a/src/TTImp/Interactive/ExprSearch.idr b/src/TTImp/Interactive/ExprSearch.idr index 36fad55967..45be954878 100644 --- a/src/TTImp/Interactive/ExprSearch.idr +++ b/src/TTImp/Interactive/ExprSearch.idr @@ -33,9 +33,11 @@ import TTImp.Unelab import TTImp.Utils import Data.List +import Data.SnocList import Libraries.Data.Tap import Libraries.Data.WithDefault +import Libraries.Data.SnocList.SizeOf %default covering @@ -43,7 +45,7 @@ import Libraries.Data.WithDefault -- of the LHS. Only recursive calls with a different structure are okay. record RecData where constructor MkRecData - {localVars : List Name} + {localVars : SnocList Name} recname : Name -- resolved name lhsapp : Term localVars @@ -147,18 +149,18 @@ search : {auto c : Ref Ctxt Defs} -> getAllEnv : {vars : _} -> FC -> SizeOf done -> Env Term vars -> - List (Term (done ++ vars), Term (done ++ vars)) -getAllEnv fc done [] = [] -getAllEnv {vars = v :: vs} {done} fc p (b :: env) + List (Term (vars ++ done), Term (vars ++ done)) +getAllEnv fc done [<] = [] +getAllEnv {vars = vs :< v} {done} fc p (env :< b) = let rest = getAllEnv fc (sucR p) env 0 var = mkIsVar (hasLength p) usable = usableName v in if usable then (Local fc Nothing _ var, - rewrite appendAssociative done [v] vs in + rewrite sym (appendAssociative vs [ Bool usableName (UN _) = True @@ -334,7 +336,7 @@ getSuccessful {vars} fc rig opts mkHole env ty topty all let base = maybe "arg" (\r => nameRoot (recname r) ++ "_rhs") (recData opts) - hn <- uniqueBasicName defs (map nameRoot vars) base + hn <- uniqueBasicName defs (toList $ map nameRoot vars) base (idx, tm) <- newMeta fc rig env (UN $ Basic hn) ty (Hole (length env) (holeInit False)) False @@ -488,7 +490,7 @@ searchLocalWith {vars} fc nofn rig opts hints env ((p, pty) :: rest) ty topty findPos : Defs -> Term vars -> (Term vars -> Term vars) -> NF vars -> NF vars -> Core (Search (Term vars, ExprDefs)) - findPos defs prf f x@(NTCon pfc pn _ _ [(fc1, xty), (fc2, yty)]) target + findPos defs prf f x@(NTCon pfc pn _ _ [<(fc1, xty), (fc2, yty)]) target = getSuccessful fc rig opts False env ty topty [findDirect defs prf f x target, (do fname <- maybe (throw (InternalError "No fst")) @@ -504,17 +506,10 @@ searchLocalWith {vars} fc nofn rig opts hints env ((p, pty) :: rest) ty topty getSuccessful fc rig opts False env ty topty [(do xtynf <- evalClosure defs xty findPos defs prf - (\arg => applyStackWithFC (Ref fc Func fname) - [(fc1, xtytm), - (fc2, ytytm), - (fc, f arg)]) - xtynf target), + (\arg => applySpineWithFC (Ref fc Func fname) [<(fc, f arg), (fc2, ytytm), (fc1, xtytm)]) xtynf target), (do ytynf <- evalClosure defs yty findPos defs prf - (\arg => applyStackWithFC (Ref fc Func sname) - [(fc1, xtytm), - (fc2, ytytm), - (fc, f arg)]) + (\arg => applySpineWithFC (Ref fc Func sname) [<(fc, f arg), (fc2, ytytm), (fc1, xtytm)]) ytynf target)] else noResult)] findPos defs prf f nty target = findDirect defs prf f nty target @@ -552,7 +547,7 @@ makeHelper fc rig opts env letty targetty ((locapp, ds) :: next) intn <- genVarName "cval" helpern_in <- genCaseName "search" helpern <- inCurrentNS helpern_in - let env' = Lam fc top Explicit letty :: env + let env' = env :< Lam fc top Explicit letty scopeMeta <- metaVar fc top env' helpern (weaken targetty) let scope = toApp scopeMeta @@ -566,7 +561,7 @@ makeHelper fc rig opts env letty targetty ((locapp, ds) :: next) defs <- get Ctxt Just ty <- lookupTyExact helpern (gamma defs) | Nothing => throw (InternalError "Can't happen") - logTermNF "interaction.search" 10 "Type of scope name" [] ty + logTermNF "interaction.search" 10 "Type of scope name" [<] ty -- Generate a definition for the helper, but with more restrictions. -- Always take the first result, to avoid blowing up search space. @@ -670,7 +665,7 @@ tryIntermediateRec fc rig opts hints env ty topty (Just rd) = do defs <- get Ctxt Just rty <- lookupTyExact (recname rd) (gamma defs) | Nothing => noResult - True <- isSingleCon defs !(nf defs [] rty) + True <- isSingleCon defs !(nf defs [<] rty) | _ => noResult intnty <- genVarName "cty" u <- uniVar fc @@ -683,9 +678,9 @@ tryIntermediateRec fc rig opts hints env ty topty (Just rd) recsearch <- tryRecursive fc rig opts' hints env letty topty rd makeHelper fc rig opts' env letty ty recsearch where - isSingleCon : Defs -> NF [] -> Core Bool + isSingleCon : Defs -> NF [<] -> Core Bool isSingleCon defs (NBind fc x (Pi _ _ _ _) sc) - = isSingleCon defs !(sc defs (toClosure defaultOpts [] + = isSingleCon defs !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) isSingleCon defs (NTCon _ n _ _ _) = do Just (TCon _ _ _ _ _ _ [con] _) <- lookupDefExact n (gamma defs) @@ -701,7 +696,7 @@ searchType : {vars : _} -> ClosedTerm -> Nat -> Term vars -> Core (Search (Term vars, ExprDefs)) searchType fc rig opts hints env topty (S k) (Bind bfc n b@(Pi fc' c info ty) sc) - = do let env' : Env Term (n :: _) = b :: env + = do let env' : Env Term (_ :< n) = env :< b log "interaction.search" 10 $ "Introduced lambda, search for " ++ show sc scVal <- searchType fc rig opts hints env' topty k sc pure (map (\ (sc, ds) => (Bind bfc n (Lam fc' c info ty) sc, ds)) scVal) @@ -710,8 +705,8 @@ searchType {vars} fc rig opts hints env topty Z (Bind bfc n b@(Pi fc' c info ty) getSuccessful fc rig opts False env ty topty [searchLocal fc rig opts hints env (Bind bfc n b sc) topty, (do defs <- get Ctxt - let n' = UN $ Basic !(getArgName defs n [] vars !(nf defs env ty)) - let env' : Env Term (n' :: _) = b :: env + let n' = UN $ Basic !(getArgName defs n [] (toList vars) !(nf defs env ty)) + let env' : Env Term (_ :< n') = env :< b let sc' = compat sc log "interaction.search" 10 $ "Introduced lambda, search for " ++ show sc' scVal <- searchType fc rig opts hints env' topty Z sc' @@ -774,10 +769,10 @@ searchHole : {auto c : Ref Ctxt Defs} -> Nat -> ClosedTerm -> Defs -> GlobalDef -> Core (Search (ClosedTerm, ExprDefs)) searchHole fc rig opts hints n locs topty defs glob - = do searchty <- normalise defs [] (type glob) + = do searchty <- normalise defs [<] (type glob) logTerm "interaction.search" 10 "Normalised type" searchty checkTimer - searchType fc rig opts hints [] topty locs searchty + searchType fc rig opts hints [<] topty locs searchty -- Declared at the top search fc rig opts hints topty n_in @@ -789,7 +784,7 @@ search fc rig opts hints topty n_in case definition gdef of Hole locs _ => searchHole fc rig opts hints n locs topty defs gdef BySearch _ _ _ => searchHole fc rig opts hints n - !(getArity defs [] (type gdef)) + !(getArity defs [<] (type gdef)) topty defs gdef _ => do log "interaction.search" 10 $ show n_in ++ " not a hole" throw (InternalError $ "Not a hole: " ++ show n ++ " in " ++ @@ -810,7 +805,7 @@ getLHSData : {auto c : Ref Ctxt Defs} -> Defs -> Maybe ClosedTerm -> Core (Maybe RecData) getLHSData defs Nothing = pure Nothing getLHSData defs (Just tm) - = pure $ getLHS !(toFullNames !(normaliseHoles defs [] tm)) + = pure $ getLHS !(toFullNames !(normaliseHoles defs [<] tm)) where getLHS : {vars : _} -> Term vars -> Maybe RecData getLHS (Bind _ _ (PVar _ _ _ _) sc) = getLHS sc @@ -831,11 +826,11 @@ firstLinearOK fc [] = noResult firstLinearOK fc ((t, ds) :: next) = handleUnify (do unless (isNil ds) $ - traverse_ (processDecl [InCase] (MkNested []) []) ds - ignore $ linearCheck fc linear False [] t + traverse_ (processDecl [InCase] (MkNested []) [<]) ds + ignore $ linearCheck fc linear False [<] t defs <- get Ctxt - nft <- normaliseHoles defs [] t - raw <- unelab [] !(toFullNames nft) + nft <- normaliseHoles defs [<] t + raw <- unelab [<] !(toFullNames nft) pure (map rawName raw :: firstLinearOK fc !next)) (\err => do next' <- next @@ -856,8 +851,8 @@ exprSearchOpts opts fc n_in hints -- the REPL does this step, but doing it here too because -- expression search might be invoked some other way let Hole _ _ = definition gdef - | PMDef pi [] (STerm _ tm) _ _ - => do raw <- unelab [] !(toFullNames !(normaliseHoles defs [] tm)) + | PMDef pi [<] (STerm _ tm) _ _ + => do raw <- unelab [<] !(toFullNames !(normaliseHoles defs [<] tm)) one (map rawName raw) | _ => throw (GenericMsg fc "Name is already defined") lhs <- findHoleLHS !(getFullName (Resolved idx)) diff --git a/src/TTImp/Interactive/GenerateDef.idr b/src/TTImp/Interactive/GenerateDef.idr index 9ef21ec48c..67ea6f6f0c 100644 --- a/src/TTImp/Interactive/GenerateDef.idr +++ b/src/TTImp/Interactive/GenerateDef.idr @@ -63,7 +63,7 @@ expandClause : {auto c : Ref Ctxt Defs} -> Core (Search (List ImpClause)) expandClause loc opts n c = do c <- uniqueRHS c - Right clause <- checkClause linear Private PartialOK False n [] (MkNested []) [] c + Right clause <- checkClause linear Private PartialOK False n [] (MkNested []) [<] c | Left err => noResult -- TODO: impossible clause, do something -- appropriate @@ -159,7 +159,7 @@ generateSplits loc opts fn (ImpossibleClause fc lhs) = pure [] generateSplits loc opts fn (WithClause fc lhs rig wval prf flags cs) = pure [] generateSplits loc opts fn (PatClause fc lhs rhs) = do (lhstm, _) <- - elabTerm fn (InLHS linear) [] (MkNested []) [] + elabTerm fn (InLHS linear) [] (MkNested []) [<] (IBindHere loc PATTERN lhs) Nothing let splitnames = if ltor opts then splittableNames lhs @@ -229,7 +229,7 @@ makeDefFromType loc opts n envlen ty (do defs <- branch meta <- get MD ust <- get UST - argns <- getEnvArgNames defs envlen !(nf defs [] ty) + argns <- getEnvArgNames defs envlen !(nf defs [<] ty) -- Need to add implicit patterns for the outer environment. -- We won't try splitting on these let pre_env = replicate envlen (Implicit loc True) diff --git a/src/TTImp/Interactive/Intro.idr b/src/TTImp/Interactive/Intro.idr index 57973f0dcf..e8e3c3a55f 100644 --- a/src/TTImp/Interactive/Intro.idr +++ b/src/TTImp/Interactive/Intro.idr @@ -19,6 +19,8 @@ import TTImp.TTImp import TTImp.Unelab import TTImp.Utils +import Data.SnocList + %default covering parameters @@ -53,13 +55,13 @@ parameters ics <- for cs $ \ cons => do Just gdef <- lookupCtxtExact cons (gamma defs) | _ => pure Nothing - let nargs = lengthExplicitPi $ fst $ snd $ underPis (-1) [] (type gdef) + let nargs = lengthExplicitPi $ fst $ snd $ underPis (-1) [<] (type gdef) new_hole_names <- uniqueHoleNames defs nargs (nameRoot hole) let new_holes = PHole replFC True <$> new_hole_names let pcons = papply replFC (PRef replFC cons) new_holes res <- catch (do -- We're desugaring it to the corresponding TTImp - icons <- desugar AnyExpr lhsCtxt pcons + icons <- desugar AnyExpr (toList lhsCtxt) pcons ccons <- checkTerm hidx {-is this correct?-} InExpr [] (MkNested []) env icons gty newdefs <- get Ctxt ncons <- normaliseHoles newdefs env ccons diff --git a/src/TTImp/Interactive/MakeLemma.idr b/src/TTImp/Interactive/MakeLemma.idr index 312a6fd5c5..31f0d850de 100644 --- a/src/TTImp/Interactive/MakeLemma.idr +++ b/src/TTImp/Interactive/MakeLemma.idr @@ -14,6 +14,7 @@ import TTImp.TTImp.Functor import TTImp.Utils import Data.List +import Data.SnocList %default covering @@ -49,8 +50,8 @@ getArgs : {vars : _} -> getArgs {vars} env (S k) (Bind _ x b@(Pi _ c _ ty) sc) = do defs <- get Ctxt ty' <- map (map rawName) $ unelab env !(normalise defs env ty) - let x' = UN $ Basic !(uniqueBasicName defs (map nameRoot vars) (nameRoot x)) - (sc', ty) <- getArgs (b :: env) k (compat {n = x'} sc) + let x' = UN $ Basic !(uniqueBasicName defs (toList $ map nameRoot vars) (nameRoot x)) + (sc', ty) <- getArgs (env :< b) k (compat {n = x'} sc) -- Don't need to use the name if it's not used in the scope type let mn = if c == top then case shrink sc (Drop Refl) of @@ -92,5 +93,5 @@ makeLemma : {auto m : Ref MD Metadata} -> Core (RawImp, RawImp) makeLemma loc n nlocs ty = do defs <- get Ctxt - (args, ret) <- getArgs [] nlocs !(normalise defs [] ty) + (args, ret) <- getArgs [<] nlocs !(normalise defs [<] ty) pure (mkType loc args ret, mkApp loc n args) diff --git a/src/TTImp/PartialEval.idr b/src/TTImp/PartialEval.idr index 75a1a26dd4..f81f7b24d6 100644 --- a/src/TTImp/PartialEval.idr +++ b/src/TTImp/PartialEval.idr @@ -22,8 +22,10 @@ import TTImp.Unelab import Protocol.Hex import Data.List +import Data.SnocList import Libraries.Data.NameMap import Libraries.Data.WithDefault +import Libraries.Data.SnocList.SizeOf %default covering @@ -42,12 +44,12 @@ Show a => Show (ArgMode' a) where show Dynamic = "Dynamic" -getStatic : ArgMode -> Maybe (Term []) +getStatic : ArgMode -> Maybe (Term [<]) getStatic Dynamic = Nothing getStatic (Static t) = Just t specialiseTy : {vars : _} -> - Nat -> List (Nat, Term []) -> Term vars -> Term vars + Nat -> List (Nat, Term [<]) -> Term vars -> Term vars specialiseTy i specs (Bind fc x (Pi fc' c p ty) sc) = case lookup i specs of Nothing => Bind fc x (Pi fc' c p ty) $ -- easier later if everything explicit @@ -75,7 +77,7 @@ substLocs : {vs : _} -> substLocs [] tm = tm substLocs ((i, tm') :: subs) tm = substLocs subs (substLoc i tm' tm) -mkSubsts : Nat -> List (Nat, Term []) -> +mkSubsts : Nat -> List (Nat, Term [<]) -> List (Term vs) -> Term vs -> Maybe (List (Nat, Term vs)) mkSubsts i specs [] rhs = Just [] mkSubsts i specs (arg :: args) rhs @@ -93,7 +95,7 @@ mkSubsts i specs (arg :: args) rhs -- In the case where all the specialised positions are variables on the LHS, -- substitute the term in on the RHS -specPatByVar : List (Nat, Term []) -> +specPatByVar : List (Nat, Term [<]) -> (vs ** (Env Term vs, Term vs, Term vs)) -> Maybe (vs ** (Env Term vs, Term vs, Term vs)) specPatByVar specs (vs ** (env, lhs, rhs)) @@ -102,7 +104,7 @@ specPatByVar specs (vs ** (env, lhs, rhs)) let lhs' = apply (getLoc fn) fn args pure (vs ** (env, substLocs psubs lhs', substLocs psubs rhs)) -specByVar : List (Nat, Term []) -> +specByVar : List (Nat, Term [<]) -> List (vs ** (Env Term vs, Term vs, Term vs)) -> Maybe (List (vs ** (Env Term vs, Term vs, Term vs))) specByVar specs [] = pure [] @@ -111,7 +113,7 @@ specByVar specs (p :: ps) ps' <- specByVar specs ps pure (p' :: ps') -dropSpec : Nat -> List (Nat, Term []) -> List a -> List a +dropSpec : Nat -> List (Nat, ClosedTerm) -> List a -> List a dropSpec i sargs [] = [] dropSpec i sargs (x :: xs) = case lookup i sargs of @@ -121,9 +123,9 @@ dropSpec i sargs (x :: xs) getSpecPats : {auto c : Ref Ctxt Defs} -> FC -> Name -> (fn : Name) -> (stk : List (FC, Term vars)) -> - NF [] -> -- Type of 'fn' + NF [<] -> -- Type of 'fn' List (Nat, ArgMode) -> -- All the arguments - List (Nat, Term []) -> -- Just the static ones + List (Nat, Term [<]) -> -- Just the static ones List (vs ** (Env Term vs, Term vs, Term vs)) -> Core (Maybe (List ImpClause)) getSpecPats fc pename fn stk fnty args sargs pats @@ -150,30 +152,30 @@ getSpecPats fc pename fn stk fnty args sargs pats -- Build a RHS from the type of the function to be specialised, the -- dynamic argument names, and the list of given arguments. We assume -- the latter two correspond appropriately. - mkRHSargs : NF [] -> RawImp -> List String -> List (Nat, ArgMode) -> + mkRHSargs : NF [<] -> RawImp -> List String -> List (Nat, ArgMode) -> Core RawImp mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app (a :: as) ((_, Dynamic) :: ds) = do defs <- get Ctxt - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) mkRHSargs sc' (IApp fc app (IVar fc (UN $ Basic a))) as ds mkRHSargs (NBind _ x (Pi _ _ _ _) sc) app (a :: as) ((_, Dynamic) :: ds) = do defs <- get Ctxt - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) mkRHSargs sc' (INamedApp fc app x (IVar fc (UN $ Basic a))) as ds mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) - tm' <- unelabNoSugar [] tm + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) + tm' <- unelabNoSugar [<] tm mkRHSargs sc' (IApp fc app (map rawName tm')) as ds mkRHSargs (NBind _ x (Pi _ _ Implicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) - tm' <- unelabNoSugar [] tm + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) + tm' <- unelabNoSugar [<] tm mkRHSargs sc' (INamedApp fc app x (map rawName tm')) as ds mkRHSargs (NBind _ _ (Pi _ _ AutoImplicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) - tm' <- unelabNoSugar [] tm + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) + tm' <- unelabNoSugar [<] tm mkRHSargs sc' (IAutoApp fc app (map rawName tm')) as ds -- Type will depend on the value here (we assume a variadic function) but -- the argument names are still needed @@ -273,7 +275,7 @@ mkSpecDef {vars} fc gdef pename sargs fn stk " (" ++ show fn ++ ") -> \{show pename} by " ++ showSep ", " args' let sty = specialiseTy 0 staticargs (type gdef) - logTermNF "specialise" 3 ("Specialised type " ++ show pename) [] sty + logTermNF "specialise" 3 ("Specialised type " ++ show pename) [<] sty -- Add as RigW - if it's something else, we don't need it at -- runtime anyway so this is wasted effort, therefore a failure @@ -282,7 +284,7 @@ mkSpecDef {vars} fc gdef pename sargs fn stk log "specialise.flags" 20 "Defining \{show pename} with flags: \{show defflags}" peidx <- addDef pename $ the (GlobalDef -> GlobalDef) { flags := defflags } - $ newDef fc pename top [] sty (specified Public) None + $ newDef fc pename top [<] sty (specified Public) None addToSave (Resolved peidx) -- Reduce the function to be specialised, and reduce any name in @@ -303,12 +305,12 @@ mkSpecDef {vars} fc gdef pename sargs fn stk pure $ "Attempting to specialise:\n" ++ showSep "\n" (map showPat inpats) - Just newpats <- getSpecPats fc pename fn stk !(nf defs [] (type gdef)) + Just newpats <- getSpecPats fc pename fn stk !(nf defs [<] (type gdef)) sargs staticargs pats | Nothing => pure (applyStackWithFC (Ref fc Func fn) stk) log "specialise" 5 $ "New patterns for " ++ show pename ++ ":\n" ++ showSep "\n" (map showPat newpats) - processDecl [InPartialEval] (MkNested []) [] + processDecl [InPartialEval] (MkNested []) [<] (IDef fc (Resolved peidx) newpats) setAllPublic False pure peapp) @@ -408,12 +410,12 @@ specialise {vars} fc env gdef fn stk specs => do fnfull <- toFullNames fn -- If all the arguments are concrete (meaning, no local variables - -- or holes in them, so they can be a Term []) we can specialise + -- or holes in them, so they can be a Term [<]) we can specialise Just sargs <- getSpecArgs 0 specs stk | Nothing => pure Nothing defs <- get Ctxt sargs <- for sargs $ traversePair $ traverseArgMode $ \ tm => - normalise defs [] tm + normalise defs [<] tm let nhash = hash !(traverse toFullNames $ mapMaybe getStatic $ map snd sargs) `hashWithSalt` fnfull -- add function name to hash to avoid namespace clashes let pename = NS partialEvalNS @@ -424,7 +426,7 @@ specialise {vars} fc env gdef fn stk Just _ => pure Nothing where concrete : {vars : _} -> - Term vars -> Maybe (Term []) + Term vars -> Maybe (Term [<]) concrete tm = shrink tm none getSpecArgs : Nat -> List Nat -> List (FC, Term vars) -> @@ -462,7 +464,7 @@ findSpecs env stk (Meta fc n i args) pure $ applyStackWithFC (Meta fc n i args') stk findSpecs env stk (Bind fc x b sc) = do b' <- traverse (findSpecs env []) b - sc' <- findSpecs (b' :: env) [] sc + sc' <- findSpecs (env :< b') [] sc pure $ applyStackWithFC (Bind fc x b' sc') stk findSpecs env stk (App fc fn arg) = do arg' <- findSpecs env [] arg @@ -499,12 +501,12 @@ mutual {auto s : Ref Syn SyntaxInfo} -> {auto o : Ref ROpts REPLOpts} -> Ref QVar Int -> Defs -> Bounds bound -> - Env Term free -> List (Closure free) -> - Core (List (Term (bound ++ free))) - quoteArgs q defs bounds env [] = pure [] - quoteArgs q defs bounds env (a :: args) - = pure $ (!(quoteGenNF q defs bounds env !(evalClosure defs a)) :: - !(quoteArgs q defs bounds env args)) + Env Term free -> SnocList (Closure free) -> + Core (SnocList (Term (free ++ bound))) + quoteArgs q defs bounds env [<] = pure [<] + quoteArgs q defs bounds env (args :< a) + = pure $ (!(quoteArgs q defs bounds env args) :< + !(quoteGenNF q defs bounds env !(evalClosure defs a))) quoteArgsWithFC : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> @@ -513,10 +515,12 @@ mutual {auto o : Ref ROpts REPLOpts} -> {bound, free : _} -> Ref QVar Int -> Defs -> Bounds bound -> - Env Term free -> List (FC, Closure free) -> - Core (List (FC, Term (bound ++ free))) + Env Term free -> SnocList (FC, Closure free) -> + Core (SnocList (FC, Term (free ++ bound))) quoteArgsWithFC q defs bounds env terms - = pure $ zip (map fst terms) !(quoteArgs q defs bounds env (map snd terms)) + -- [Note] Restore logging sequence + = do let rev_terms = reverse terms + pure . reverse $ zip (map fst rev_terms) !(quoteArgs q defs bounds env (map snd rev_terms)) quoteHead : {bound, free : _} -> {auto c : Ref Ctxt Defs} -> @@ -526,17 +530,10 @@ mutual {auto o : Ref ROpts REPLOpts} -> Ref QVar Int -> Defs -> FC -> Bounds bound -> Env Term free -> NHead free -> - Core (Term (bound ++ free)) + Core (Term (free ++ bound)) quoteHead {bound} q defs fc bounds env (NLocal mrig _ prf) - = let MkVar prf' = addLater bound prf in + = let MkVar prf' = weakenNs (mkSizeOf bound) (MkVar prf) in pure $ Local fc mrig _ prf' - where - addLater : {idx : _} -> (ys : List Name) -> (0 p : IsVar n idx xs) -> - Var (ys ++ xs) - addLater [] isv = MkVar isv - addLater (x :: xs) isv - = let MkVar isv' = addLater xs isv in - MkVar (Later isv') quoteHead q defs fc bounds env (NRef Bound (MN n i)) = case findName bounds of Just (MkVar p) => pure $ Local fc Nothing _ (embedIsVar p) @@ -555,8 +552,9 @@ mutual Just (MkVar (Later p)) quoteHead q defs fc bounds env (NRef nt n) = pure $ Ref fc nt n quoteHead q defs fc bounds env (NMeta n i args) - = do args' <- quoteArgs q defs bounds env args - pure $ Meta fc n i args' + = do args' <- quoteArgs q defs bounds env (map snd args) + -- See [Note] Meta args + pure $ Meta fc n i (toList $ args') quotePi : {bound, free : _} -> {auto c : Ref Ctxt Defs} -> @@ -566,7 +564,7 @@ mutual {auto o : Ref ROpts REPLOpts} -> Ref QVar Int -> Defs -> Bounds bound -> Env Term free -> PiInfo (Closure free) -> - Core (PiInfo (Term (bound ++ free))) + Core (PiInfo (Term (free ++ bound))) quotePi q defs bounds env Explicit = pure Explicit quotePi q defs bounds env Implicit = pure Implicit quotePi q defs bounds env AutoImplicit = pure AutoImplicit @@ -582,7 +580,7 @@ mutual {auto o : Ref ROpts REPLOpts} -> Ref QVar Int -> Defs -> Bounds bound -> Env Term free -> Binder (Closure free) -> - Core (Binder (Term (bound ++ free))) + Core (Binder (Term (free ++ bound))) quoteBinder q defs bounds env (Lam fc r p ty) = do ty' <- quoteGenNF q defs bounds env !(evalClosure defs ty) p' <- quotePi q defs bounds env p @@ -615,7 +613,7 @@ mutual {auto o : Ref ROpts REPLOpts} -> Ref QVar Int -> Defs -> Bounds bound -> - Env Term vars -> NF vars -> Core (Term (bound ++ vars)) + Env Term vars -> NF vars -> Core (Term (vars ++ bound)) quoteGenNF q defs bound env (NBind fc n b sc) = do var <- bName "qv" sc' <- quoteGenNF q defs (Add n var bound) env @@ -628,36 +626,36 @@ mutual quoteGenNF q defs bound env (NApp fc (NRef Func fn) args) = do Just gdef <- lookupCtxtExact fn (gamma defs) | Nothing => do args' <- quoteArgsWithFC q defs bound env args - pure $ applyStackWithFC (Ref fc Func fn) args' + pure $ applySpineWithFC (Ref fc Func fn) args' case specArgs gdef of [] => do args' <- quoteArgsWithFC q defs bound env args - pure $ applyStackWithFC (Ref fc Func fn) args' + pure $ applySpineWithFC (Ref fc Func fn) args' _ => do empty <- clearDefs defs args' <- quoteArgsWithFC q defs bound env args - Just r <- specialise fc (extendEnv bound env) gdef fn args' + Just r <- specialise fc (extendEnv bound env) gdef fn (toList args') | Nothing => -- can't specialise, keep the arguments -- unreduced do args' <- quoteArgsWithFC q empty bound env args - pure $ applyStackWithFC (Ref fc Func fn) args' + pure $ applySpineWithFC (Ref fc Func fn) args' pure r where - extendEnv : Bounds bs -> Env Term vs -> Env Term (bs ++ vs) + extendEnv : Bounds bs -> Env Term vs -> Env Term (vs ++ bs) extendEnv None env = env extendEnv (Add x n bs) env -- We're just using this to evaluate holes in the right scope, so -- a placeholder binder is fine - = Lam fc top Explicit (Erased fc Placeholder) :: extendEnv bs env + = extendEnv bs env :< Lam fc top Explicit (Erased fc Placeholder) quoteGenNF q defs bound env (NApp fc f args) = do f' <- quoteHead q defs fc bound env f args' <- quoteArgsWithFC q defs bound env args - pure $ applyStackWithFC f' args' + pure $ applySpineWithFC f' args' quoteGenNF q defs bound env (NDCon fc n t ar args) = do args' <- quoteArgsWithFC q defs bound env args - pure $ applyStackWithFC (Ref fc (DataCon t ar) n) args' + pure $ applySpineWithFC (Ref fc (DataCon t ar) n) args' quoteGenNF q defs bound env (NTCon fc n t ar args) = do args' <- quoteArgsWithFC q defs bound env args - pure $ applyStackWithFC (Ref fc (TyCon t ar) n) args' + pure $ applySpineWithFC (Ref fc (TyCon t ar) n) args' quoteGenNF q defs bound env (NAs fc s n pat) = do n' <- quoteGenNF q defs bound env n pat' <- quoteGenNF q defs bound env pat @@ -682,9 +680,9 @@ mutual case arg of NDelay fc _ _ arg => do argNF <- evalClosure defs arg - pure $ applyStackWithFC !(quoteGenNF q defs bound env argNF) args' + pure $ applySpineWithFC !(quoteGenNF q defs bound env argNF) args' _ => do arg' <- quoteGenNF q defs bound env arg - pure $ applyStackWithFC (TForce fc r arg') args' + pure $ applySpineWithFC (TForce fc r arg') args' quoteGenNF q defs bound env (NPrimVal fc c) = pure $ PrimVal fc c quoteGenNF q defs bound env (NErased fc Impossible) = pure $ Erased fc Impossible quoteGenNF q defs bound env (NErased fc Placeholder) = pure $ Erased fc Placeholder diff --git a/src/TTImp/ProcessData.idr b/src/TTImp/ProcessData.idr index f2c0942b13..94836e24cd 100644 --- a/src/TTImp/ProcessData.idr +++ b/src/TTImp/ProcessData.idr @@ -23,6 +23,7 @@ import TTImp.TTImp import Data.DPair import Data.List +import Data.SnocList import Libraries.Data.NameMap import Libraries.Data.WithDefault @@ -112,7 +113,7 @@ checkCon {vars} opts nest env vis tn_in tn (MkImpTy fc cn_in ty_raw) -- Check 'ty' returns something in the right family checkFamily fc cn tn env !(nf defs env ty) let fullty = abstractEnvType fc env ty - logTermNF "declare.data.constructor" 5 ("Constructor " ++ show cn) [] fullty + logTermNF "declare.data.constructor" 5 ("Constructor " ++ show cn) [<] fullty traverse_ addToSave (keys (getMetas ty)) addToSave cn @@ -123,26 +124,27 @@ checkCon {vars} opts nest env vis tn_in tn (MkImpTy fc cn_in ty_raw) addHashWithNames fullty log "module.hash" 15 "Adding hash for data constructor: \{show cn}" _ => pure () - pure (MkCon fc cn !(getArity defs [] fullty) fullty) + pure (MkCon fc cn !(getArity defs [<] fullty) fullty) -- Get the indices of the constructor type (with non-constructor parts erased) getIndexPats : {auto c : Ref Ctxt Defs} -> - ClosedTerm -> Core (List (NF [])) + ClosedTerm -> Core (List (NF [<])) getIndexPats tm = do defs <- get Ctxt - tmnf <- nf defs [] tm + tmnf <- nf defs [<] tm ret <- getRetType defs tmnf getPats defs ret where - getRetType : Defs -> NF [] -> Core (NF []) + getRetType : Defs -> NF [<] -> Core (NF [<]) getRetType defs (NBind fc _ (Pi _ _ _ _) sc) - = do sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + = do sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) getRetType defs sc' getRetType defs t = pure t - getPats : Defs -> NF [] -> Core (List (NF [])) + getPats : Defs -> NF [<] -> Core (List (NF [<])) getPats defs (NTCon fc _ _ _ args) - = traverse (evalClosure defs . snd) args + = do args' <- traverse (evalClosure defs . snd) args + pure (cast args') getPats defs _ = pure [] -- Can't happen if we defined the type successfully! getDetags : {auto c : Ref Ctxt Defs} -> @@ -156,15 +158,15 @@ getDetags fc tys xs => pure $ Just xs where mutual - disjointArgs : List (NF []) -> List (NF []) -> Core Bool - disjointArgs [] _ = pure False - disjointArgs _ [] = pure False - disjointArgs (a :: args) (a' :: args') + disjointArgs : SnocList (NF [<]) -> SnocList (NF [<]) -> Core Bool + disjointArgs [<] _ = pure False + disjointArgs _ [<] = pure False + disjointArgs (args :< a) (args' :< a') = if !(disjoint a a') then pure True else disjointArgs args args' - disjoint : NF [] -> NF [] -> Core Bool + disjoint : NF [<] -> NF [<] -> Core Bool disjoint (NDCon _ _ t _ args) (NDCon _ _ t' _ args') = if t /= t' then pure True @@ -182,7 +184,7 @@ getDetags fc tys disjoint (NPrimVal _ c) (NPrimVal _ c') = pure (c /= c') disjoint _ _ = pure False - allDisjointWith : NF [] -> List (NF []) -> Core Bool + allDisjointWith : NF [<] -> List (NF [<]) -> Core Bool allDisjointWith val [] = pure True allDisjointWith (NErased _ _) _ = pure False allDisjointWith val (nf :: nfs) @@ -190,7 +192,7 @@ getDetags fc tys if ok then allDisjointWith val nfs else pure False - allDisjoint : List (NF []) -> Core Bool + allDisjoint : List (NF [<]) -> Core Bool allDisjoint [] = pure True allDisjoint (NErased _ _ :: _) = pure False allDisjoint (nf :: nfs) @@ -199,7 +201,7 @@ getDetags fc tys else pure False -- Which argument positions have completely disjoint contructors - getDisjointPos : Nat -> List (List (NF [])) -> Core (List Nat) + getDisjointPos : Nat -> List (List (NF [<])) -> Core (List Nat) getDisjointPos i [] = pure [] getDisjointPos i (args :: argss) = do rest <- getDisjointPos (1 + i) argss @@ -209,23 +211,23 @@ getDetags fc tys -- If exactly one argument is unerased, return its position getRelevantArg : {auto c : Ref Ctxt Defs} -> - Defs -> Nat -> Maybe Nat -> Bool -> NF [] -> + Defs -> Nat -> Maybe Nat -> Bool -> NF [<] -> Core (Maybe (Bool, Nat)) getRelevantArg defs i rel world (NBind fc _ (Pi _ rig _ val) sc) = branchZero (getRelevantArg defs (1 + i) rel world - !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder)))) + !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)))) (case !(evalClosure defs val) of -- %World is never inspected, so might as well be deleted from data types, -- although it needs care when compiling to ensure that the function that -- returns the IO/%World type isn't erased (NPrimVal _ $ PrT WorldType) => getRelevantArg defs (1 + i) rel False - !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder))) + !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) _ => -- if we haven't found a relevant argument yet, make -- a note of this one and keep going. Otherwise, we -- have more than one, so give up. - maybe (do sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + maybe (do sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) getRelevantArg defs (1 + i) (Just i) False sc') (const (pure Nothing)) rel) @@ -240,7 +242,7 @@ findNewtype : {auto c : Ref Ctxt Defs} -> List Constructor -> Core () findNewtype [con] = do defs <- get Ctxt - Just arg <- getRelevantArg defs 0 Nothing True !(nf defs [] (type con)) + Just arg <- getRelevantArg defs 0 Nothing True !(nf defs [<] (type con)) | Nothing => pure () updateDef (name con) $ \case @@ -279,7 +281,7 @@ shaped : {auto c : Ref Ctxt Defs} -> shaped as [] = pure Nothing shaped as (c :: cs) = do defs <- get Ctxt - if as !(normalise defs [] (type c)) + if as !(normalise defs [<] (type c)) then pure (Just (name c)) else shaped as cs @@ -332,7 +334,7 @@ calcEnum fc cs isNullary : Constructor -> Core Bool isNullary c = do defs <- get Ctxt - pure $ hasArgs 0 !(normalise defs [] (type c)) + pure $ hasArgs 0 !(normalise defs [<] (type c)) calcRecord : {auto c : Ref Ctxt Defs} -> FC -> List Constructor -> Core Bool @@ -405,7 +407,7 @@ processData : {vars : _} -> ImpData -> Core () processData {vars} eopts nest env fc def_vis mbtot (MkImpLater dfc n_in ty_raw) = do n <- inCurrentNS n_in - ty_raw <- bindTypeNames fc [] vars ty_raw + ty_raw <- bindTypeNames fc [] (cast {to=List _} vars) ty_raw defs <- get Ctxt -- Check 'n' is undefined @@ -419,10 +421,10 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpLater dfc n_in ty_raw) (IBindHere fc (PI erased) ty_raw) (Just (gType dfc u)) let fullty = abstractEnvType dfc env ty - logTermNF "declare.data" 5 ("data " ++ show n) [] fullty + logTermNF "declare.data" 5 ("data " ++ show n) [<] fullty checkIsType fc n env !(nf defs env ty) - arity <- getArity defs [] fullty + arity <- getArity defs [<] fullty -- Add the type constructor as a placeholder tidx <- addDef n (newDef fc n linear vars fullty def_vis @@ -452,7 +454,7 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpData dfc n_in mty_raw o defs <- get Ctxt mmetasfullty <- flip traverseOpt mty_raw $ \ ty_raw => do - ty_raw <- bindTypeNames fc [] vars ty_raw + ty_raw <- bindTypeNames fc [] (cast {to=List _} vars) ty_raw u <- uniVar fc (ty, _) <- @@ -502,16 +504,16 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpData dfc n_in mty_raw o TCon _ _ _ _ _ mw [] _ => case mfullty of Nothing => pure (mw, vis, tot, type ndef) Just fullty => - do ok <- convert defs [] fullty (type ndef) + do ok <- convert defs [<] fullty (type ndef) if ok then pure (mw, vis, tot, fullty) - else do logTermNF "declare.data" 1 "Previous" [] (type ndef) - logTermNF "declare.data" 1 "Now" [] fullty + else do logTermNF "declare.data" 1 "Previous" [<] (type ndef) + logTermNF "declare.data" 1 "Now" [<] fullty throw (AlreadyDefined fc n) _ => throw (AlreadyDefined fc n) - logTermNF "declare.data" 5 ("data " ++ show n) [] fullty + logTermNF "declare.data" 5 ("data " ++ show n) [<] fullty - arity <- getArity defs [] fullty + arity <- getArity defs [<] fullty -- Add the type constructor as a placeholder while checking -- data constructors diff --git a/src/TTImp/ProcessDecls.idr b/src/TTImp/ProcessDecls.idr index 169db6a2d6..482afb528e 100644 --- a/src/TTImp/ProcessDecls.idr +++ b/src/TTImp/ProcessDecls.idr @@ -172,22 +172,22 @@ processTTImpDecls {vars} nest env decls where bindConNames : ImpTy -> Core ImpTy bindConNames (MkImpTy fc n ty) - = do ty' <- bindTypeNames fc [] vars ty + = do ty' <- bindTypeNames fc [] (toList vars) ty pure (MkImpTy fc n ty') bindDataNames : ImpData -> Core ImpData bindDataNames (MkImpData fc n t opts cons) - = do t' <- traverseOpt (bindTypeNames fc [] vars) t + = do t' <- traverseOpt (bindTypeNames fc [] (toList vars)) t cons' <- traverse bindConNames cons pure (MkImpData fc n t' opts cons') bindDataNames (MkImpLater fc n t) - = do t' <- bindTypeNames fc [] vars t + = do t' <- bindTypeNames fc [] (toList vars) t pure (MkImpLater fc n t') -- bind implicits to make raw TTImp source a bit friendlier bindNames : ImpDecl -> Core ImpDecl bindNames (IClaim (MkFCVal fc (MkIClaimData c vis opts (MkImpTy tfc n ty)))) - = do ty' <- bindTypeNames fc [] vars ty + = do ty' <- bindTypeNames fc [] (toList vars) ty pure (IClaim (MkFCVal fc (MkIClaimData c vis opts (MkImpTy tfc n ty')))) bindNames (IData fc vis mbtot d) = do d' <- bindDataNames d @@ -212,7 +212,7 @@ processTTImpFile fname pure False traverse_ recordWarning ws logTime 0 "Elaboration" $ - catch (do ignore $ processTTImpDecls (MkNested []) [] tti + catch (do ignore $ processTTImpDecls (MkNested []) [<] tti Nothing <- checkDelayedHoles | Just err => throw err pure True) diff --git a/src/TTImp/ProcessDef.idr b/src/TTImp/ProcessDef.idr index 3fd6ebf62d..d569c48d69 100644 --- a/src/TTImp/ProcessDef.idr +++ b/src/TTImp/ProcessDef.idr @@ -41,6 +41,7 @@ import Data.Maybe import Libraries.Data.NameMap import Libraries.Data.WithDefault import Libraries.Text.PrettyPrint.Prettyprinter +import Libraries.Data.SnocList.SizeOf %default covering @@ -51,11 +52,11 @@ mutual mismatchNF defs (NTCon _ xn xt _ xargs) (NTCon _ yn yt _ yargs) = if xn /= yn then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) mismatchNF defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) = if xt /= yt then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) mismatchNF defs (NPrimVal _ xc) (NPrimVal _ yc) = pure (xc /= yc) mismatchNF defs (NDelayed _ _ x) (NDelayed _ _ y) = mismatchNF defs x y mismatchNF defs (NDelay _ _ _ x) (NDelay _ _ _ y) @@ -99,12 +100,12 @@ impossibleOK : {auto c : Ref Ctxt Defs} -> impossibleOK defs (NTCon _ xn xt xa xargs) (NTCon _ yn yt ya yargs) = if xn /= yn then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) -- If it's a data constructor, any mismatch will do impossibleOK defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) = if xt /= yt then pure True - else anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) + else anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs) impossibleOK defs (NPrimVal _ x) (NPrimVal _ y) = pure (x /= y) -- NPrimVal is apart from NDCon, NTCon, NBind, and NType @@ -161,7 +162,7 @@ recoverable : {auto c : Ref Ctxt Defs} -> recoverable defs (NTCon _ xn xt xa xargs) (NTCon _ yn yt ya yargs) = if xn /= yn then pure False - else pure $ not !(anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs)) + else pure $ not !(anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs)) -- Type constructor vs. primitive type recoverable defs (NTCon _ _ _ _ _) (NPrimVal _ _) = pure False recoverable defs (NPrimVal _ _) (NTCon _ _ _ _ _) = pure False @@ -179,7 +180,7 @@ recoverable defs _ (NTCon _ _ _ _ _) = pure True recoverable defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) = if xt /= yt then pure False - else pure $ not !(anyM (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs)) + else pure $ not !(anyMScoped (mismatch defs) (zipWith (curry $ mapHom snd) xargs yargs)) -- Data constructor vs. primitive constant recoverable defs (NDCon _ _ _ _ _) (NPrimVal _ _) = pure False recoverable defs (NPrimVal _ _) (NDCon _ _ _ _ _) = pure False @@ -247,13 +248,13 @@ extendEnv env p nest (Bind _ n (PVar fc c pi tmty) sc) (Bind _ n' (PVTy _ _ _) t extendEnv env p nest (Bind _ n (PVar fc c pi tmty) sc) (Bind _ n' (PVTy _ _ _) tysc) | Nothing = throw (InternalError "Can't happen: names don't match in pattern type") extendEnv env p nest (Bind _ n (PVar fc c pi tmty) sc) (Bind _ n (PVTy _ _ _) tysc) | (Just Refl) - = extendEnv (PVar fc c pi tmty :: env) (Drop p) (weaken nest) sc tysc + = extendEnv (env :< PVar fc c pi tmty) (Drop p) (weaken nest) sc tysc extendEnv env p nest (Bind _ n (PLet fc c tmval tmty) sc) (Bind _ n' (PLet _ _ _ _) tysc) with (nameEq n n') extendEnv env p nest (Bind _ n (PLet fc c tmval tmty) sc) (Bind _ n' (PLet _ _ _ _) tysc) | Nothing = throw (InternalError "Can't happen: names don't match in pattern type") -- PLet on the left becomes Let on the right, to give it computational force extendEnv env p nest (Bind _ n (PLet fc c tmval tmty) sc) (Bind _ n (PLet _ _ _ _) tysc) | (Just Refl) - = extendEnv (Let fc c tmval tmty :: env) (Drop p) (weaken nest) sc tysc + = extendEnv (env :< Let fc c tmval tmty) (Drop p) (weaken nest) sc tysc extendEnv env p nest tm ty = pure (_ ** (p, env, nest, tm, ty)) @@ -278,7 +279,10 @@ findLinear top bound rig tm => do defs <- get Ctxt Just nty <- lookupTyExact n (gamma defs) | Nothing => pure [] - findLinArg (accessible nt rig) !(nf defs [] nty) args + logTerm "declare.def.lhs" 5 ("Type of " ++ show !(toFullNames n)) nty + log "declare.def.lhs" 5 ("Type NF of " ++ show !(toFullNames n) ++ ": " ++ show !(nfLHS defs [<] nty)) + log "declare.def.lhs" 5 ("Args: " ++ show !(traverse toFullNames args)) + findLinArg (accessible nt rig) !(nfLHS defs [<] nty) args _ => pure [] where accessible : NameType -> RigCount -> RigCount @@ -286,27 +290,28 @@ findLinear top bound rig tm accessible _ r = r findLinArg : {vars : _} -> - RigCount -> NF [] -> List (Term vars) -> + RigCount -> NF [<] -> List (Term vars) -> Core (List (Name, RigCount)) findLinArg rig ty@(NBind _ _ (Pi _ c _ _) _) (As fc u a p :: as) = if isLinear c then case u of UseLeft => findLinArg rig ty (p :: as) UseRight => findLinArg rig ty (a :: as) + -- Yaffle: else findLinArg rig ty (as :< p :< a) else pure $ !(findLinArg rig ty [a]) ++ !(findLinArg rig ty (p :: as)) findLinArg rig (NBind _ x (Pi _ c _ _) sc) (Local {name=a} fc _ idx prf :: as) = do defs <- get Ctxt let a = nameAt prf if idx < bound - then do sc' <- sc defs (toClosure defaultOpts [] (Ref fc Bound x)) + then do sc' <- sc defs (toClosure defaultOpts [<] (Ref fc Bound x)) pure $ (a, rigMult c rig) :: !(findLinArg rig sc' as) - else do sc' <- sc defs (toClosure defaultOpts [] (Ref fc Bound x)) + else do sc' <- sc defs (toClosure defaultOpts [<] (Ref fc Bound x)) findLinArg rig sc' as findLinArg rig (NBind fc x (Pi _ c _ _) sc) (a :: as) = do defs <- get Ctxt pure $ !(findLinear False bound (c |*| rig) a) ++ - !(findLinArg rig !(sc defs (toClosure defaultOpts [] (Ref fc Bound x))) as) + !(findLinArg rig !(sc defs (toClosure defaultOpts [<] (Ref fc Bound x))) as) findLinArg rig ty (a :: as) = pure $ !(findLinear False bound rig a) ++ !(findLinArg rig ty as) findLinArg _ _ [] = pure [] @@ -389,7 +394,7 @@ checkLHS {vars} trans mult n opts nest env fc lhs_in lhs <- if trans then pure lhs_bound - else implicitsAs n defs vars lhs_bound + else implicitsAs n defs (reverse $ toList vars) lhs_bound logC "declare.def.lhs" 5 $ do pure $ "Checking LHS of " ++ show !(getFullName (Resolved n)) -- todo: add Pretty RawImp instance @@ -413,12 +418,14 @@ checkLHS {vars} trans mult n opts nest env fc lhs_in -- so we only need to do the holes. If there's a lot of type level -- computation, this is a huge saving! lhstm <- normaliseHoles defs lhsenv lhstm - lhsty <- normaliseHoles defs env lhsty - linvars_in <- findLinear True 0 linear lhstm logTerm "declare.def.lhs" 10 "Checked LHS term after normalise" lhstm + linvars_in <- findLinear True 0 linear lhstm log "declare.def.lhs" 5 $ "Linearity of names in " ++ show n ++ ": " ++ show linvars_in + lhsty <- normaliseHoles defs env lhsty + logTerm "declare.def.lhs" 10 "lhsty" lhsty + linvars <- combineLinear fc linvars_in let lhstm_lin = setLinear linvars lhstm let lhsty_lin = setLinear linvars lhsty @@ -440,7 +447,7 @@ hasEmptyPat : {vars : _} -> Defs -> Env Term vars -> Term vars -> Core Bool hasEmptyPat defs env (Bind fc x b sc) = pure $ !(isEmpty defs env !(nf defs env (binderType b))) - || !(hasEmptyPat defs (b :: env) sc) + || !(hasEmptyPat defs (env :< b) sc) hasEmptyPat defs env _ = pure False -- For checking with blocks as nested names @@ -628,31 +635,31 @@ checkClause {vars} mult vis totreq hashit n opts nest env vfc = virtualiseFC ifc mkExplicit : forall vs . Env Term vs -> Env Term vs - mkExplicit [] = [] - mkExplicit (Pi fc c _ ty :: env) = Pi fc c Explicit ty :: mkExplicit env - mkExplicit (b :: env) = b :: mkExplicit env + mkExplicit [<] = [<] + mkExplicit (env :< Pi fc c _ ty) = mkExplicit env :< Pi fc c Explicit ty + mkExplicit (env :< b) = mkExplicit env :< b bindWithArgs : (rig : RigCount) -> (wvalTy : Term xs) -> Maybe ((RigCount, Name), Term xs) -> (wvalEnv : Env Term xs) -> - Core (ext : List Name - ** ( Env Term (ext ++ xs) - , Term (ext ++ xs) - , (Term (ext ++ xs) -> Term xs) + Core (ext : SnocList Name + ** ( Env Term (xs ++ ext) + , Term (xs ++ ext) + , (Term (xs ++ ext) -> Term xs) )) bindWithArgs {xs} rig wvalTy Nothing wvalEnv = let wargn : Name wargn = MN "warg" 0 - wargs : List Name - wargs = [wargn] + wargs : SnocList Name + wargs = [ Term xs + binder : Term (xs ++ wargs) -> Term xs := Bind vfc wargn (Pi vfc rig Explicit wvalTy) in pure (wargs ** (scenv, var, binder)) @@ -667,11 +674,11 @@ checkClause {vars} mult vis totreq hashit n opts nest env let wargn : Name wargn = MN "warg" 0 - wargs : List Name - wargs = [name, wargn] + wargs : SnocList Name + wargs = [ Term xs + binder : Term (xs ++ wargs) -> Term xs := \ t => Bind vfc wargn (Pi vfc rig Explicit wvalTy) $ Bind vfc name (Pi vfc rigPrf Implicit eqTy) t @@ -698,7 +705,7 @@ checkClause {vars} mult vis totreq hashit n opts nest env -- function. Hence, turn it to Keep whatever keepOldEnv : {0 outer : _} -> {vs : _} -> (outprf : Thin outer vs) -> Thin vs' vs -> - (vs'' : List Name ** Thin vs'' vs) + (vs'' : SnocList Name ** Thin vs'' vs) keepOldEnv {vs} Refl p = (vs ** Refl) keepOldEnv {vs} p Refl = (vs ** Refl) keepOldEnv (Drop p) (Drop p') @@ -738,13 +745,13 @@ checkClause {vars} mult vis totreq hashit n opts nest env pure (ImpossibleClause ploc newlhs) -- TODO: remove -nameListEq : (xs : List Name) -> (ys : List Name) -> Maybe (xs = ys) -nameListEq [] [] = Just Refl -nameListEq (x :: xs) (y :: ys) with (nameEq x y) - nameListEq (x :: xs) (x :: ys) | (Just Refl) with (nameListEq xs ys) - nameListEq (x :: xs) (x :: xs) | (Just Refl) | Just Refl= Just Refl - nameListEq (x :: xs) (x :: ys) | (Just Refl) | Nothing = Nothing - nameListEq (x :: xs) (y :: ys) | Nothing = Nothing +nameListEq : (xs : SnocList Name) -> (ys : SnocList Name) -> Maybe (xs = ys) +nameListEq [<] [<] = Just Refl +nameListEq (xs :< x) (ys :< y) with (nameEq x y) + nameListEq (xs :< x) (ys :< x) | (Just Refl) with (nameListEq xs ys) + nameListEq (xs :< x) (xs :< x) | (Just Refl) | Just Refl= Just Refl + nameListEq (xs :< x) (ys :< x) | (Just Refl) | Nothing = Nothing + nameListEq (xs :< x) (ys :< y) | Nothing = Nothing nameListEq _ _ = Nothing -- Calculate references for the given name, and recursively if they haven't @@ -819,6 +826,7 @@ mkRunTime fc n [ show cov ++ ":" , "Runtime tree for " ++ show (fullname gdef) ++ ":" , show (indent 2 $ prettyTree tree_rt) + , show (toList rargs) ] log "compile.casetree" 10 $ show tree_rt log "compile.casetree.measure" 15 $ show (measure tree_rt) @@ -1002,7 +1010,7 @@ processDef opts nest env fc n_in cs_in -- Dynamically rebind default totality requirement to this function's totality requirement -- and use this requirement when processing `with` blocks - log "declare.def" 5 $ "Traversing clauses of " ++ show n ++ " with mult " ++ show mult + log "declare.def" 5 $ "Traversing clauses of " ++ show n ++ " with mult " ++ show mult ++ " in " ++ show cs_in let treq = fromMaybe !getDefaultTotalityOption (findSetTotal (flags gdef)) cs <- withTotality treq $ traverse (checkClause mult (collapseDefault $ visibility gdef) treq @@ -1094,7 +1102,7 @@ processDef opts nest env fc n_in cs_in checkImpossible : Int -> RigCount -> ClosedTerm -> Core (Maybe ClosedTerm) checkImpossible n mult tm - = do itm <- unelabNoPatvars [] tm + = do itm <- unelabNoPatvars [<] tm let itm = map rawName itm handleUnify (do ctxt <- get Ctxt @@ -1103,17 +1111,17 @@ processDef opts nest env fc n_in cs_in setUnboundImplicits True (_, lhstm) <- bindNames False itm setUnboundImplicits autoimp - (lhstm, _) <- elabTerm n (InLHS mult) [] (MkNested []) [] + (lhstm, _) <- elabTerm n (InLHS mult) [] (MkNested []) [<] (IBindHere fc COVERAGE lhstm) Nothing defs <- get Ctxt - lhs <- normaliseHoles defs [] lhstm - if !(hasEmptyPat defs [] lhs) + lhs <- normaliseHoles defs [<] lhstm + if !(hasEmptyPat defs [<] lhs) then do log "declare.def.impossible" 5 "Some empty pat" put Ctxt ctxt pure Nothing else do log "declare.def.impossible" 5 "No empty pat" empty <- clearDefs ctxt - rtm <- closeEnv empty !(nf empty [] lhs) + rtm <- closeEnv empty !(nf empty [<] lhs) put Ctxt ctxt pure (Just rtm)) (\err => do defs <- get Ctxt @@ -1121,16 +1129,16 @@ processDef opts nest env fc n_in cs_in then pure Nothing else pure (Just tm)) where - closeEnv : Defs -> NF [] -> Core ClosedTerm + closeEnv : Defs -> NF [<] -> Core ClosedTerm closeEnv defs (NBind _ x (PVar _ _ _ _) sc) - = closeEnv defs !(sc defs (toClosure defaultOpts [] (Ref fc Bound x))) - closeEnv defs nf = quote defs [] nf + = closeEnv defs !(sc defs (toClosure defaultOpts [<] (Ref fc Bound x))) + closeEnv defs nf = quote defs [<] nf getClause : Either RawImp Clause -> Core (Maybe Clause) getClause (Left rawlhs) = catch (do lhsp <- getImpossibleTerm env nest rawlhs log "declare.def.impossible" 3 $ "Generated impossible LHS: " ++ show lhsp - pure $ Just $ MkClause [] lhsp (Erased (getFC rawlhs) Impossible)) + pure $ Just $ MkClause [<] lhsp (Erased (getFC rawlhs) Impossible)) (\e => do log "declare.def" 5 $ "Error in getClause " ++ show e pure Nothing) getClause (Right c) = pure (Just c) diff --git a/src/TTImp/ProcessFnOpt.idr b/src/TTImp/ProcessFnOpt.idr index 818687fee6..d33ef77863 100644 --- a/src/TTImp/ProcessFnOpt.idr +++ b/src/TTImp/ProcessFnOpt.idr @@ -10,9 +10,11 @@ import TTImp.TTImp import Libraries.Data.NameMap -getRetTy : Defs -> NF [] -> Core Name +import Data.SnocList + +getRetTy : Defs -> NF [<] -> Core Name getRetTy defs (NBind fc _ (Pi _ _ _ _) sc) - = getRetTy defs !(sc defs (toClosure defaultOpts [] (Erased fc Placeholder))) + = getRetTy defs !(sc defs (toClosure defaultOpts [<] (Erased fc Placeholder))) getRetTy defs (NTCon _ n _ _ _) = pure n getRetTy defs ty = throw (GenericMsg (getLoc ty) @@ -50,7 +52,7 @@ processFnOpt fc True ndef (Hint d) = do defs <- get Ctxt Just ty <- lookupTyExact ndef (gamma defs) | Nothing => undefinedName fc ndef - target <- getRetTy defs !(nf defs [] ty) + target <- getRetTy defs !(nf defs [<] ty) addHintFor fc target ndef d False processFnOpt fc _ ndef (Hint d) = do logC "elab" 5 $ do pure $ "Adding local hint " ++ show !(toFullNames ndef) @@ -78,7 +80,7 @@ processFnOpt fc _ ndef (SpecArgs ns) = do defs <- get Ctxt Just gdef <- lookupCtxtExact ndef (gamma defs) | Nothing => undefinedName fc ndef - nty <- nf defs [] (type gdef) + nty <- nf defs [<] (type gdef) ps <- getNamePos 0 nty ddeps <- collectDDeps nty specs <- collectSpec [] ddeps ps nty @@ -94,14 +96,14 @@ processFnOpt fc _ ndef (SpecArgs ns) else insertDeps (pos :: acc) ps ns -- Collect the argument names which the dynamic args depend on - collectDDeps : NF [] -> Core (List Name) + collectDDeps : NF [<] -> Core (List Name) collectDDeps (NBind tfc x (Pi _ _ _ nty) sc) = do defs <- get Ctxt empty <- clearDefs defs - sc' <- sc defs (toClosure defaultOpts [] (Ref tfc Bound x)) + sc' <- sc defs (toClosure defaultOpts [<] (Ref tfc Bound x)) if x `elem` ns then collectDDeps sc' - else do aty <- quote empty [] nty + else do aty <- quote empty [<] nty -- Get names depended on by nty let deps = keys (getRefs (UN Underscore) aty) rest <- collectDDeps sc' @@ -110,24 +112,24 @@ processFnOpt fc _ ndef (SpecArgs ns) -- Return names the type depends on, and whether it's a parameter mutual - getDepsArgs : Bool -> List (NF []) -> NameMap Bool -> + getDepsArgs : Bool -> SnocList (NF [<]) -> NameMap Bool -> Core (NameMap Bool) - getDepsArgs inparam [] ns = pure ns - getDepsArgs inparam (a :: as) ns + getDepsArgs inparam [<] ns = pure ns + getDepsArgs inparam (as :< a) ns = do ns' <- getDeps inparam a ns getDepsArgs inparam as ns' - getDeps : Bool -> NF [] -> NameMap Bool -> + getDeps : Bool -> NF [<] -> NameMap Bool -> Core (NameMap Bool) getDeps inparam (NBind _ x (Pi _ _ _ pty) sc) ns = do defs <- get Ctxt ns' <- getDeps inparam !(evalClosure defs pty) ns - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) getDeps inparam sc' ns' getDeps inparam (NBind _ x b sc) ns = do defs <- get Ctxt ns' <- getDeps False !(evalClosure defs (binderType b)) ns - sc' <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + sc' <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) getDeps False sc' ns getDeps inparam (NApp _ (NRef Bound n) args) ns = do defs <- get Ctxt @@ -141,19 +143,19 @@ processFnOpt fc _ ndef (SpecArgs ns) params <- case !(lookupDefExact n (gamma defs)) of Just (TCon _ _ ps _ _ _ _ _) => pure ps _ => pure [] - let (ps, ds) = splitPs 0 params (map snd args) + let (ps, ds) = splitPs 0 params (map snd (toList args)) ns' <- getDepsArgs True !(traverse (evalClosure defs) ps) ns getDepsArgs False !(traverse (evalClosure defs) ds) ns' where -- Split into arguments in parameter position, and others - splitPs : Nat -> List Nat -> List (Closure []) -> - (List (Closure []), List (Closure [])) - splitPs n params [] = ([], []) + splitPs : Nat -> List Nat -> List (Closure [<]) -> + (SnocList (Closure [<]), SnocList (Closure [<])) + splitPs n params [] = ([<], [<]) splitPs n params (x :: xs) = let (ps', ds') = splitPs (1 + n) params xs in if n `elem` params - then (x :: ps', ds') - else (ps', x :: ds') + then (ps' :< x, ds') + else (ps', ds' :< x) getDeps inparam (NDelayed _ _ t) ns = getDeps inparam t ns getDeps inparams nf ns = pure ns @@ -164,11 +166,11 @@ processFnOpt fc _ ndef (SpecArgs ns) List Name -> -- things depended on by dynamic args -- We're assuming it's a short list, so just use -- List and don't worry about duplicates. - List (Name, Nat) -> NF [] -> Core (List Nat) + List (Name, Nat) -> NF [<] -> Core (List Nat) collectSpec acc ddeps ps (NBind tfc x (Pi _ _ _ nty) sc) = do defs <- get Ctxt empty <- clearDefs defs - sc' <- sc defs (toClosure defaultOpts [] (Ref tfc Bound x)) + sc' <- sc defs (toClosure defaultOpts [<] (Ref tfc Bound x)) if x `elem` ns then do deps <- getDeps True !(evalClosure defs nty) NameMap.empty -- Get names depended on by nty @@ -183,9 +185,9 @@ processFnOpt fc _ ndef (SpecArgs ns) else collectSpec acc ddeps ps sc' collectSpec acc ddeps ps _ = pure acc - getNamePos : Nat -> NF [] -> Core (List (Name, Nat)) + getNamePos : Nat -> NF [<] -> Core (List (Name, Nat)) getNamePos i (NBind tfc x (Pi _ _ _ _) sc) = do defs <- get Ctxt - ns' <- getNamePos (1 + i) !(sc defs (toClosure defaultOpts [] (Erased tfc Placeholder))) + ns' <- getNamePos (1 + i) !(sc defs (toClosure defaultOpts [<] (Erased tfc Placeholder))) pure ((x, i) :: ns') getNamePos _ _ = pure [] diff --git a/src/TTImp/ProcessParams.idr b/src/TTImp/ProcessParams.idr index 71a948c30d..ac2bfc90ae 100644 --- a/src/TTImp/ProcessParams.idr +++ b/src/TTImp/ProcessParams.idr @@ -16,6 +16,8 @@ import TTImp.Elab import TTImp.Elab.Check import TTImp.TTImp +import Data.SnocList + %default covering extend : {extvs : _} -> @@ -24,7 +26,7 @@ extend : {extvs : _} -> Term extvs -> (vars' ** (Thin vs vars', Env Term vars', NestedNames vars')) extend env p nest (Bind _ n b@(Pi fc c pi ty) sc) - = extend (b :: env) (Drop p) (weaken nest) sc + = extend (env :< b) (Drop p) (weaken nest) sc extend env p nest tm = (_ ** (p, env, nest)) export @@ -43,7 +45,7 @@ processParams {vars} {c} {m} {u} nest env fc ps ds -- then read off the environment from the elaborated type. This way -- we'll get all the implicit names we need let pty_raw = mkParamTy ps - pty_imp <- bindTypeNames fc [] vars (IBindHere fc (PI erased) pty_raw) + pty_imp <- bindTypeNames fc [] (toList vars) (IBindHere fc (PI erased) pty_raw) log "declare.param" 10 $ "Checking " ++ show pty_imp u <- uniVar fc pty <- checkTerm (-1) InType [] diff --git a/src/TTImp/ProcessRecord.idr b/src/TTImp/ProcessRecord.idr index 9d882a1549..c5c2f09eba 100644 --- a/src/TTImp/ProcessRecord.idr +++ b/src/TTImp/ProcessRecord.idr @@ -70,13 +70,13 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- Go into new namespace, if there is one, for getters case newns of - Nothing => elabGetters tn conName params 0 [] [] conty + Nothing => elabGetters tn conName params 0 [] [<] conty Just ns => do let cns = currentNS defs let nns = nestedNS defs extendNS (mkNamespace ns) newns <- getNS - elabGetters tn conName params 0 [] [] conty + elabGetters tn conName params 0 [] [<] conty -- Record that the current namespace is allowed to look -- at private names in the nested namespace update Ctxt { currentNS := cns, @@ -144,7 +144,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa Core (List ImpParameter) -- New telescope of parameters, including missing bindings preElabAsData tn = do let fc = virtualiseFC fc - let dataTy = IBindHere fc (PI erased) !(bindTypeNames fc [] vars (mkDataTy fc params0)) + let dataTy = IBindHere fc (PI erased) !(bindTypeNames fc [] (toList vars) (mkDataTy fc params0)) -- we don't use MkImpLater because users may have already declared the record ahead of time let dt = MkImpData fc tn (Just dataTy) opts [] log "declare.record" 10 $ "Pre-declare record data type: \{show dt}" @@ -153,7 +153,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa Just ty <- lookupTyExact tn (gamma defs) | Nothing => throw (InternalError "Missing data type \{show tn}, despite having just declared it!") log "declare.record" 20 "Obtained type: \{show ty}" - (_ ** (tyenv, ty)) <- dropLeadingPis vars ty [] + (_ ** (tyenv, ty)) <- dropLeadingPis vars ty [<] ty <- unelabNest (NoSugar True) !nestDrop tyenv ty log "declare.record.parameters" 30 "Unelaborated type: \{show ty}" params <- getParameters [<] ty @@ -165,9 +165,9 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- a LHS, or inside a `parameters` block) and so we need to start by dropping -- these local variables from the fully elaborated record's type -- We'll use the `env` thus obtained to unelab the remaining scope - dropLeadingPis : {vs : _} -> (vars : List Name) -> Term vs -> Env Term vs -> + dropLeadingPis : {vs : _} -> (vars : SnocList Name) -> Term vs -> Env Term vs -> Core (vars' ** (Env Term vars', Term vars')) - dropLeadingPis [] ty env + dropLeadingPis [<] ty env = do unless (null vars) $ logC "declare.record.parameters" 60 $ pure $ unlines [ "We elaborated \{show tn} in a non-empty local context." @@ -175,8 +175,8 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa , " Remaining type: \{show !(toFullNames ty)}" ] pure (_ ** (env, ty)) - dropLeadingPis (var :: vars) (Bind fc n b@(Pi _ _ _ _) ty) env - = dropLeadingPis vars ty (b :: env) + dropLeadingPis (vars :< var) (Bind fc n b@(Pi _ _ _ _) ty) env + = dropLeadingPis vars ty (env :< b) dropLeadingPis _ ty _ = throw (InternalError "Malformed record type \{show ty}") getParameters : @@ -219,7 +219,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa = do let fc = virtualiseFC fc let conty = mkTy (paramTelescope params) $ mkTy (map farg fields) (recTy tn params) - let boundNames = paramNames params ++ map fname fields ++ vars + let boundNames = paramNames params ++ map fname fields ++ (toList vars) let con = MkImpTy (virtualiseFC fc) (NoFC cname) !(bindTypeNames fc [] boundNames conty) let dt = MkImpData fc tn Nothing opts [con] @@ -253,20 +253,20 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa then elabGetters tn con params (if imp == Explicit && not (n `elem` vars) then S done else done) - upds (b :: tyenv) sc + upds (tyenv :< b) sc else do let fldNameStr = nameRoot n rfNameNS <- inCurrentNS (UN $ Field fldNameStr) unNameNS <- inCurrentNS (UN $ Basic fldNameStr) ty <- unelabNest (NoSugar True) !nestDrop tyenv ty_chk - let ty' = substNames vars upds $ map rawName ty + let ty' = substNames (toList vars) upds $ map rawName ty log "declare.record.field" 5 $ "Field type: " ++ show ty' let rname = MN "rec" 0 -- Claim the projection type projTy <- bindTypeNames fc [] - (map fst params ++ map fname fields ++ vars) $ + (map fst params ++ map fname fields ++ toList vars) $ mkTy (paramTelescope params) $ IPi bfc top Explicit (Just rname) (recTy tn params) ty' let fc' = virtualiseFC fc @@ -343,7 +343,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa elabGetters tn con params (if imp == Explicit then S done else done) - upds' (b :: tyenv) sc + upds' (tyenv :< b) sc elabGetters tn con _ done upds _ _ = pure () diff --git a/src/TTImp/ProcessType.idr b/src/TTImp/ProcessType.idr index c2ae488e23..a99849ba22 100644 --- a/src/TTImp/ProcessType.idr +++ b/src/TTImp/ProcessType.idr @@ -39,10 +39,10 @@ getFnString (IPrimVal _ (Str st)) = pure st getFnString tm = do inidx <- resolveName (UN $ Basic "[foreign]") let fc = getFC tm - let gstr = gnf [] (PrimVal fc $ PrT StringType) - etm <- checkTerm inidx InExpr [] (MkNested []) [] tm gstr + let gstr = gnf [<] (PrimVal fc $ PrT StringType) + etm <- checkTerm inidx InExpr [] (MkNested []) [<] tm gstr defs <- get Ctxt - case !(nf defs [] etm) of + case !(nf defs [<] etm) of NPrimVal fc (Str st) => pure st _ => throw (GenericMsg fc "%foreign calling convention must evaluate to a String") @@ -91,35 +91,35 @@ initDef fc n env ty (_ :: opts) = initDef fc n env ty opts -- generalising partially evaluated definitions and (potentially) in interactive -- editing findInferrable : {auto c : Ref Ctxt Defs} -> - Defs -> NF [] -> Core (List Nat) + Defs -> NF [<] -> Core (List Nat) findInferrable defs ty = fi 0 0 [] [] ty where mutual -- Add to the inferrable arguments from the given type. An argument is -- inferrable if it's guarded by a constructor, or on its own findInf : List Nat -> List (Name, Nat) -> - NF [] -> Core (List Nat) - findInf acc pos (NApp _ (NRef Bound n) []) + NF [<] -> Core (List Nat) + findInf acc pos (NApp _ (NRef Bound n) [<]) = case lookup n pos of Nothing => pure acc Just p => if p `elem` acc then pure acc else pure (p :: acc) findInf acc pos (NDCon _ _ _ _ args) - = do args' <- traverse (evalClosure defs . snd) args + = do args' <- traverse (evalClosure defs . snd) (toList args) findInfs acc pos args' findInf acc pos (NTCon _ _ _ _ args) - = do args' <- traverse (evalClosure defs . snd) args + = do args' <- traverse (evalClosure defs . snd) (toList args) findInfs acc pos args' findInf acc pos (NDelayed _ _ t) = findInf acc pos t findInf acc _ _ = pure acc - findInfs : List Nat -> List (Name, Nat) -> List (NF []) -> Core (List Nat) + findInfs : List Nat -> List (Name, Nat) -> List (NF [<]) -> Core (List Nat) findInfs acc pos [] = pure acc findInfs acc pos (n :: ns) = findInf !(findInfs acc pos ns) pos n - fi : Nat -> Int -> List (Name, Nat) -> List Nat -> NF [] -> Core (List Nat) + fi : Nat -> Int -> List (Name, Nat) -> List Nat -> NF [<] -> Core (List Nat) fi pos i args acc (NBind fc x (Pi _ _ _ aty) sc) = do let argn = MN "inf" i - sc' <- sc defs (toClosure defaultOpts [] (Ref fc Bound argn)) + sc' <- sc defs (toClosure defaultOpts [<] (Ref fc Bound argn)) acc' <- findInf acc args !(evalClosure defs aty) rest <- fi (1 + pos) (1 + i) ((argn, pos) :: args) acc' sc' pure rest @@ -164,7 +164,7 @@ processType {vars} eopts nest env fc rig vis opts (MkImpTy tfc n_in ty_raw) checkTerm idx InType (HolesOkay :: eopts) nest env (IBindHere fc (PI erased) ty_raw) (gType fc u) - logTermNF "declare.type" 3 ("Type of " ++ show n) [] (abstractFullEnvType tfc env ty) + logTermNF "declare.type" 3 ("Type of " ++ show n) [<] (abstractFullEnvType tfc env ty) def <- initDef fc n env ty opts let fullty = abstractFullEnvType tfc env ty @@ -172,7 +172,7 @@ processType {vars} eopts nest env fc rig vis opts (MkImpTy tfc n_in ty_raw) (erased, dterased) <- findErased fullty defs <- get Ctxt empty <- clearDefs defs - infargs <- findInferrable empty !(nf defs [] fullty) + infargs <- findInferrable empty !(nf defs [<] fullty) ignore $ addDef (Resolved idx) ({ eraseArgs := erased, diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr index cad45d6600..eb6a50a63d 100644 --- a/src/TTImp/Reflect.idr +++ b/src/TTImp/Reflect.idr @@ -10,13 +10,15 @@ import Core.Value import TTImp.TTImp import Libraries.Data.WithDefault +import Data.SnocList + %default covering export Reify BindMode where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "PI"), [(_, c)]) + (UN (Basic "PI"), [<(_, c)]) => do c' <- reify defs !(evalClosure defs c) pure (PI c') (UN (Basic "PATTERN"), _) => pure PATTERN @@ -90,11 +92,11 @@ mutual Reify RawImp where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "IVar"), [fc, n]) + (UN (Basic "IVar"), [ do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) pure (IVar fc' n') - (UN (Basic "IPi"), [fc, c, p, mn, aty, rty]) + (UN (Basic "IPi"), [ do fc' <- reify defs !(evalClosure defs fc) c' <- reify defs !(evalClosure defs c) p' <- reify defs !(evalClosure defs p) @@ -102,7 +104,7 @@ mutual aty' <- reify defs !(evalClosure defs aty) rty' <- reify defs !(evalClosure defs rty) pure (IPi fc' c' p' mn' aty' rty') - (UN (Basic "ILam"), [fc, c, p, mn, aty, lty]) + (UN (Basic "ILam"), [ do fc' <- reify defs !(evalClosure defs fc) c' <- reify defs !(evalClosure defs c) p' <- reify defs !(evalClosure defs p) @@ -110,7 +112,7 @@ mutual aty' <- reify defs !(evalClosure defs aty) lty' <- reify defs !(evalClosure defs lty) pure (ILam fc' c' p' mn' aty' lty') - (UN (Basic "ILet"), [fc, lhsFC, c, n, ty, val, sc]) + (UN (Basic "ILet"), [ do fc' <- reify defs !(evalClosure defs fc) lhsFC' <- reify defs !(evalClosure defs lhsFC) c' <- reify defs !(evalClosure defs c) @@ -119,124 +121,124 @@ mutual val' <- reify defs !(evalClosure defs val) sc' <- reify defs !(evalClosure defs sc) pure (ILet fc' lhsFC' c' n' ty' val' sc') - (UN (Basic "ICase"), [fc, opts, sc, ty, cs]) + (UN (Basic "ICase"), [ do fc' <- reify defs !(evalClosure defs fc) opts' <- reify defs !(evalClosure defs opts) sc' <- reify defs !(evalClosure defs sc) ty' <- reify defs !(evalClosure defs ty) cs' <- reify defs !(evalClosure defs cs) pure (ICase fc' opts' sc' ty' cs') - (UN (Basic "ILocal"), [fc, ds, sc]) + (UN (Basic "ILocal"), [ do fc' <- reify defs !(evalClosure defs fc) ds' <- reify defs !(evalClosure defs ds) sc' <- reify defs !(evalClosure defs sc) pure (ILocal fc' ds' sc') - (UN (Basic "IUpdate"), [fc, ds, sc]) + (UN (Basic "IUpdate"), [ do fc' <- reify defs !(evalClosure defs fc) ds' <- reify defs !(evalClosure defs ds) sc' <- reify defs !(evalClosure defs sc) pure (IUpdate fc' ds' sc') - (UN (Basic "IApp"), [fc, f, a]) + (UN (Basic "IApp"), [ do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) pure (IApp fc' f' a') - (UN (Basic "INamedApp"), [fc, f, m, a]) + (UN (Basic "INamedApp"), [ do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) m' <- reify defs !(evalClosure defs m) a' <- reify defs !(evalClosure defs a) pure (INamedApp fc' f' m' a') - (UN (Basic "IAutoApp"), [fc, f, a]) + (UN (Basic "IAutoApp"), [ do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) pure (IAutoApp fc' f' a') - (UN (Basic "IWithApp"), [fc, f, a]) + (UN (Basic "IWithApp"), [ do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) pure (IWithApp fc' f' a') - (UN (Basic "ISearch"), [fc, d]) + (UN (Basic "ISearch"), [ do fc' <- reify defs !(evalClosure defs fc) d' <- reify defs !(evalClosure defs d) pure (ISearch fc' d') - (UN (Basic "IAlternative"), [fc, t, as]) + (UN (Basic "IAlternative"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) as' <- reify defs !(evalClosure defs as) pure (IAlternative fc' t' as') - (UN (Basic "IRewrite"), [fc, t, sc]) + (UN (Basic "IRewrite"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) sc' <- reify defs !(evalClosure defs sc) pure (IRewrite fc' t' sc') - (UN (Basic "IBindHere"), [fc, t, sc]) + (UN (Basic "IBindHere"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) sc' <- reify defs !(evalClosure defs sc) pure (IBindHere fc' t' sc') - (UN (Basic "IBindVar"), [fc, n]) + (UN (Basic "IBindVar"), [ do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) pure (IBindVar fc' n') - (UN (Basic "IAs"), [fc, nameFC, s, n, t]) + (UN (Basic "IAs"), [ do fc' <- reify defs !(evalClosure defs fc) nameFC' <- reify defs !(evalClosure defs nameFC) s' <- reify defs !(evalClosure defs s) n' <- reify defs !(evalClosure defs n) t' <- reify defs !(evalClosure defs t) pure (IAs fc' nameFC' s' n' t') - (UN (Basic "IMustUnify"), [fc, r, t]) + (UN (Basic "IMustUnify"), [ do fc' <- reify defs !(evalClosure defs fc) r' <- reify defs !(evalClosure defs r) t' <- reify defs !(evalClosure defs t) pure (IMustUnify fc' r' t') - (UN (Basic "IDelayed"), [fc, r, t]) + (UN (Basic "IDelayed"), [ do fc' <- reify defs !(evalClosure defs fc) r' <- reify defs !(evalClosure defs r) t' <- reify defs !(evalClosure defs t) pure (IDelayed fc' r' t') - (UN (Basic "IDelay"), [fc, t]) + (UN (Basic "IDelay"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IDelay fc' t') - (UN (Basic "IForce"), [fc, t]) + (UN (Basic "IForce"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IForce fc' t') - (UN (Basic "IQuote"), [fc, t]) + (UN (Basic "IQuote"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IQuote fc' t') - (UN (Basic "IQuoteName"), [fc, t]) + (UN (Basic "IQuoteName"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IQuoteName fc' t') - (UN (Basic "IQuoteDecl"), [fc, t]) + (UN (Basic "IQuoteDecl"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IQuoteDecl fc' t') - (UN (Basic "IUnquote"), [fc, t]) + (UN (Basic "IUnquote"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IUnquote fc' t') - (UN (Basic "IPrimVal"), [fc, t]) + (UN (Basic "IPrimVal"), [ do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IPrimVal fc' t') - (UN (Basic "IType"), [fc]) + (UN (Basic "IType"), [ do fc' <- reify defs !(evalClosure defs fc) pure (IType fc') - (UN (Basic "IHole"), [fc, n]) + (UN (Basic "IHole"), [ do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) pure (IHole fc' n') - (UN (Basic "Implicit"), [fc, n]) + (UN (Basic "Implicit"), [ do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) pure (Implicit fc' n') - (UN (Basic "IWithUnambigNames"), [fc, ns, t]) + (UN (Basic "IWithUnambigNames"), [ do fc' <- reify defs !(evalClosure defs fc) ns' <- reify defs !(evalClosure defs ns) t' <- reify defs !(evalClosure defs t) @@ -248,11 +250,11 @@ mutual Reify IFieldUpdate where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "ISetField"), [(_, x), (_, y)]) + (UN (Basic "ISetField"), [<(_, x), (_, y)]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) pure (ISetField x' y') - (UN (Basic "ISetFieldApp"), [(_, x), (_, y)]) + (UN (Basic "ISetFieldApp"), [<(_, x), (_, y)]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) pure (ISetFieldApp x' y') @@ -267,7 +269,7 @@ mutual => pure FirstSuccess (UN (Basic "Unique"), _) => pure Unique - (UN (Basic "UniqueDefault"), [(_, x)]) + (UN (Basic "UniqueDefault"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (UniqueDefault x') _ => cantReify val "AltType" @@ -282,25 +284,25 @@ mutual (UN (Basic "NoInline"), _) => pure NoInline (UN (Basic "Deprecate"), _) => pure Deprecate (UN (Basic "TCInline"), _) => pure TCInline - (UN (Basic "Hint"), [(_, x)]) + (UN (Basic "Hint"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (Hint x') - (UN (Basic "GlobalHint"), [(_, x)]) + (UN (Basic "GlobalHint"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (GlobalHint x') (UN (Basic "ExternFn"), _) => pure ExternFn - (UN (Basic "ForeignFn"), [(_, x)]) + (UN (Basic "ForeignFn"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (ForeignFn x') - (UN (Basic "ForeignExport"), [(_, x)]) + (UN (Basic "ForeignExport"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (ForeignExport x') (UN (Basic "Invertible"), _) => pure Invertible - (UN (Basic "Totality"), [(_, x)]) + (UN (Basic "Totality"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (Totality x') (UN (Basic "Macro"), _) => pure Macro - (UN (Basic "SpecArgs"), [(_, x)]) + (UN (Basic "SpecArgs"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (SpecArgs x') _ => cantReify val "FnOpt" @@ -310,7 +312,7 @@ mutual Reify ImpTy where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "MkTy"), [w, y, z]) + (UN (Basic "MkTy"), [ do w' <- reify defs !(evalClosure defs w) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) @@ -322,7 +324,7 @@ mutual Reify DataOpt where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of - (UN (Basic "SearchBy"), [(_, x)]) + (UN (Basic "SearchBy"), [<(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (SearchBy x') (UN (Basic "NoHints"), _) => pure NoHints @@ -336,14 +338,14 @@ mutual Reify ImpData where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "MkData"), [v,w,x,y,z]) + (UN (Basic "MkData"), [ do v' <- reify defs !(evalClosure defs v) w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) pure (MkImpData v' w' x' y' z') - (UN (Basic "MkLater"), [x,y,z]) + (UN (Basic "MkLater"), [ do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) @@ -355,7 +357,7 @@ mutual Reify IField where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "MkIField"), [v,w,x,y,z]) + (UN (Basic "MkIField"), [ do v' <- reify defs !(evalClosure defs v) w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) @@ -369,7 +371,7 @@ mutual Reify ImpRecord where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "MkRecord"), [v,w,x,y,z,a]) + (UN (Basic "MkRecord"), [ do v' <- reify defs !(evalClosure defs v) w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) @@ -384,7 +386,7 @@ mutual Reify WithFlag where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "Syntactic"), []) + (UN (Basic "Syntactic"), [<]) => pure Syntactic _ => cantReify val "WithFlag" reify defs val = cantReify val "WithFlag" @@ -393,12 +395,12 @@ mutual Reify ImpClause where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "PatClause"), [x,y,z]) + (UN (Basic "PatClause"), [ do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) pure (PatClause x' y' z') - (UN (Basic "WithClause"), [u,v,w,x,y,z,a]) + (UN (Basic "WithClause"), [ do u' <- reify defs !(evalClosure defs u) v' <- reify defs !(evalClosure defs v) w' <- reify defs !(evalClosure defs w) @@ -407,7 +409,7 @@ mutual z' <- reify defs !(evalClosure defs z) a' <- reify defs !(evalClosure defs a) pure (WithClause u' v' w' x' y' z' a') - (UN (Basic "ImpossibleClause"), [x,y]) + (UN (Basic "ImpossibleClause"), [ do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) pure (ImpossibleClause x' y') @@ -418,7 +420,7 @@ mutual Reify (IClaimData Name) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "MkIClaimData"), [w, x, y, z]) + (UN (Basic "IClaim"), [ do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) @@ -431,49 +433,49 @@ mutual Reify ImpDecl where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of - (UN (Basic "IClaim"), [v]) + (UN (Basic "IClaim"), [ do v' <- reify defs !(evalClosure defs v) pure (IClaim v') - (UN (Basic "IData"), [x,y,z,w]) + (UN (Basic "IData"), [ do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) w' <- reify defs !(evalClosure defs w) pure (IData x' y' z' w') - (UN (Basic "IDef"), [x,y,z]) + (UN (Basic "IDef"), [ do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) pure (IDef x' y' z') - (UN (Basic "IParameters"), [x,y,z]) + (UN (Basic "IParameters"), [ do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) pure (IParameters x' y' z') - (UN (Basic "IRecord"), [w,x,y,z,u]) + (UN (Basic "IRecord"), [ do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) u' <- reify defs !(evalClosure defs u) pure (IRecord w' x' y' z' u') - (UN (Basic "IFail"), [w,x,y]) + (UN (Basic "IFail"), [ do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) pure (IFail w' x' y') - (UN (Basic "INamespace"), [w,x,y]) + (UN (Basic "INamespace"), [ do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) pure (INamespace w' x' y') - (UN (Basic "ITransform"), [w,x,y,z]) + (UN (Basic "ITransform"), [ do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) pure (ITransform w' x' y' z') - (UN (Basic "ILog"), [x]) + (UN (Basic "ILog"), [ do x' <- reify defs !(evalClosure defs x) pure (ILog x') _ => cantReify val "Decl" diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index 0a4443bf3e..f7a372ee51 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -15,12 +15,13 @@ import Data.Maybe import Libraries.Data.SortedSet import Libraries.Data.WithDefault +import Libraries.Data.SnocList.SizeOf %default covering -- Information about names in nested blocks public export -record NestedNames (vars : List Name) where +record NestedNames (vars : SnocList Name) where constructor MkNested -- A map from names to the decorated version of the name, and the new name -- applied to its enclosing environment @@ -35,7 +36,7 @@ Weaken NestedNames where weakenNs {ns = wkns} s (MkNested ns) = MkNested (map wknName ns) where wknName : (Name, (Maybe Name, List (Var vars), FC -> NameType -> Term vars)) -> - (Name, (Maybe Name, List (Var (wkns ++ vars)), FC -> NameType -> Term (wkns ++ vars))) + (Name, (Maybe Name, List (Var (vars ++ wkns)), FC -> NameType -> Term (vars ++ wkns))) wknName (n, (mn, vars, rep)) = (n, (mn, map (weakenNs s) vars, \fc, nt => weakenNs s (rep fc nt))) @@ -715,7 +716,7 @@ implicitsAs n defs ns tm "Could not find variable " ++ show n pure $ IVar loc nm Just ty => - do ty' <- nf defs [] ty + do ty' <- nf defs [<] ty implicits <- findImps is es ns ty' log "declare.def.lhs.implicits" 30 $ "\n In the type of " ++ show n ++ ": " ++ show ty ++ @@ -744,7 +745,7 @@ implicitsAs n defs ns tm -- in the lhs: this is used to determine when to stop searching for further -- implicits to add. findImps : List (Maybe Name) -> List (Maybe Name) -> - List Name -> NF [] -> + List Name -> NF [<] -> Core (List (Name, PiInfo RawImp)) -- #834 When we are in a local definition, we have an explicit telescope -- corresponding to the variables bound in the parent function. @@ -752,12 +753,12 @@ implicitsAs n defs ns tm -- and explicit variables. So we first peel off all of the quantifiers -- corresponding to these variables. findImps ns es (_ :: locals) (NBind fc x (Pi _ _ _ _) sc) - = do body <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + = do body <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) findImps ns es locals body -- ^ TODO? check that name of the pi matches name of local? -- don't add implicits coming after explicits that aren't given findImps ns es [] (NBind fc x (Pi _ _ Explicit _) sc) - = do body <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + = do body <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) case es of -- Explicits were skipped, therefore all explicits are given anyway Just (UN Underscore) :: _ => findImps ns es [] body @@ -767,13 +768,13 @@ implicitsAs n defs ns tm Just es' => findImps ns es' [] body -- if the implicit was given, skip it findImps ns es [] (NBind fc x (Pi _ _ AutoImplicit _) sc) - = do body <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + = do body <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) case updateNs x ns of Nothing => -- didn't find explicit call pure $ (x, AutoImplicit) :: !(findImps ns es [] body) Just ns' => findImps ns' es [] body findImps ns es [] (NBind fc x (Pi _ _ p _) sc) - = do body <- sc defs (toClosure defaultOpts [] (Erased fc Placeholder)) + = do body <- sc defs (toClosure defaultOpts [<] (Erased fc Placeholder)) if Just x `elem` ns then findImps ns es [] body else pure $ (x, forgetDef p) :: !(findImps ns es [] body) @@ -1009,4 +1010,5 @@ logRaw : {auto c : Ref Ctxt Defs} -> Nat -> Lazy String -> RawImp -> Core () logRaw str n msg tm = when !(logging str n) $ - do logString str n (msg ++ ": " ++ show tm) + do depth <- getDepth + logString depth str n (msg ++ ": " ++ show tm) diff --git a/src/TTImp/Unelab.idr b/src/TTImp/Unelab.idr index 4db55867de..b1efa022ae 100644 --- a/src/TTImp/Unelab.idr +++ b/src/TTImp/Unelab.idr @@ -13,6 +13,8 @@ import TTImp.TTImp import Data.List import Data.String +import Libraries.Data.SnocList.SizeOf + %default covering used : (idx : Nat) -> Term vars -> Bool @@ -116,10 +118,10 @@ mutual = TForce fc r (substVars xs y) substVars xs tm = tm - substArgs : SizeOf vs -> List (List (Var vs), Term vars) -> Term vs -> Term (vs ++ vars) + substArgs : SizeOf vs -> List (List (Var vs), Term vars) -> Term vs -> Term (vars ++ vs) substArgs p substs tm = let - substs' = map (bimap (map $ embed {outer = vars}) (weakenNs p)) substs + substs' = map (bimap (map embed) (weakenNs p)) substs tm' = embed tm in substVars substs' tm' @@ -156,7 +158,7 @@ mutual (argpos : Nat) -> List (Term vars) -> Core (Maybe IRawImp) mkCase pats argpos args = do unless (null args) $ log "unelab.case.clause" 20 $ - unwords $ "Ignoring" :: map show args + unwords $ "Ignoring" :: map show (toList $ args) let Just scrutinee = idxOrMaybe argpos args | _ => pure Nothing fc = getLoc scrutinee @@ -238,7 +240,7 @@ mutual _ => pure (term, gErased fc) pure (term, gnf env (embed ty)) unelabTy' umode nest env (Bind fc x b sc) - = do (sc', scty) <- unelabTy umode nest (b :: env) sc + = do (sc', scty) <- unelabTy umode nest (env :< b) sc case umode of NoSugar True => let x' = uniqueLocal vars x in @@ -253,7 +255,7 @@ mutual next (NS ns n) = NS ns (next n) next n = MN (show n) 0 - uniqueLocal : List Name -> Name -> Name + uniqueLocal : SnocList Name -> Name -> Name uniqueLocal vs n = if n `elem` vs then uniqueLocal vs (next n) @@ -330,8 +332,8 @@ mutual (umode : UnelabMode) -> (nest : List (Name, Nat)) -> FC -> Env Term vars -> (x : Name) -> - Binder (Term vars) -> Term (x :: vars) -> - IRawImp -> Term (x :: vars) -> + Binder (Term vars) -> Term (vars :< x) -> + IRawImp -> Term (vars :< x) -> Core (IRawImp, Glued vars) unelabBinder umode nest fc env x (Lam fc' rig p ty) sctm sc scty = do (ty', _) <- unelabTy umode nest env ty @@ -403,7 +405,7 @@ unelabNest : {vars : _} -> Env Term vars -> Term vars -> Core IRawImp unelabNest mode nest env (Meta fc n i args) - = do let mkn = nameRoot n ++ showScope args + = do let mkn = nameRoot n ++ (showScope $ toList args) pure (IHole fc mkn) where toName : Term vars -> Maybe Name diff --git a/src/TTImp/Utils.idr b/src/TTImp/Utils.idr index 95c5bd593c..9e78fafc29 100644 --- a/src/TTImp/Utils.idr +++ b/src/TTImp/Utils.idr @@ -590,7 +590,7 @@ getArgName defs x bound allvars ty findNamesM : NF vars -> Core (Maybe (List String)) findNamesM (NBind _ x (Pi _ _ _ _) _) = pure (Just ["f", "g"]) - findNamesM (NTCon _ n _ d [(_, v)]) = do + findNamesM (NTCon _ n _ d [<(_, v)]) = do case dropNS !(full (gamma defs) n) of UN (Basic "List") => do nf <- evalClosure defs v diff --git a/src/Yaffle/REPL.idr b/src/Yaffle/REPL.idr index e6f06415df..d4fe8aaa20 100644 --- a/src/Yaffle/REPL.idr +++ b/src/Yaffle/REPL.idr @@ -42,10 +42,10 @@ process : {auto c : Ref Ctxt Defs} -> {auto o : Ref ROpts REPLOpts} -> ImpREPL -> Core Bool process (Eval ttimp) - = do (tm, _) <- elabTerm 0 InExpr [] (MkNested []) [] ttimp Nothing + = do (tm, _) <- elabTerm 0 InExpr [] (MkNested []) [<] ttimp Nothing defs <- get Ctxt - tmnf <- normalise defs [] tm - coreLift_ (printLn !(unelab [] tmnf)) + tmnf <- normalise defs [<] tm + coreLift_ (printLn !(unelab [<] tmnf)) pure True process (Check (IVar _ n)) = do defs <- get Ctxt @@ -56,23 +56,23 @@ process (Check (IVar _ n)) printName : (Name, Int, ClosedTerm) -> Core () printName (n, _, tyh) = do defs <- get Ctxt - ty <- normaliseHoles defs [] tyh + ty <- normaliseHoles defs [<] tyh coreLift_ $ putStrLn $ show n ++ " : " ++ - show !(unelab [] ty) + show !(unelab [<] ty) process (Check ttimp) - = do (tm, gty) <- elabTerm 0 InExpr [] (MkNested []) [] ttimp Nothing + = do (tm, gty) <- elabTerm 0 InExpr [] (MkNested []) [<] ttimp Nothing defs <- get Ctxt tyh <- getTerm gty - ty <- normaliseHoles defs [] tyh - coreLift_ (printLn !(unelab [] ty)) + ty <- normaliseHoles defs [<] tyh + coreLift_ (printLn !(unelab [<] ty)) pure True process (ProofSearch n_in) = do defs <- get Ctxt [(n, i, ty)] <- lookupTyName n_in (gamma defs) | ns => ambiguousName (justFC defaultFC) n_in (map fst ns) - def <- search (justFC defaultFC) top False 1000 n ty [] + def <- search (justFC defaultFC) top False 1000 n ty [<] defs <- get Ctxt - defnf <- normaliseHoles defs [] def + defnf <- normaliseHoles defs [<] def coreLift_ (printLn !(toFullNames defnf)) pure True process (ExprSearch n_in)