From 47a908197c3df8d81161dc9343c2c0a9bdf5598a Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Sun, 2 Nov 2025 18:34:20 +0300 Subject: [PATCH 01/14] [ refactor ] replace showSep and join by `Data.String.joinBy` Co-authored-by: Justus Matthiesen --- src/Compiler/ANF.idr | 17 ++++++++-------- src/Compiler/ES/Codegen.idr | 12 ++++++----- src/Compiler/Interpreter/VMCode.idr | 13 ++++++------ src/Compiler/LambdaLift.idr | 17 ++++++++-------- src/Compiler/NoMangle.idr | 7 +++++-- src/Compiler/RefC/RefC.idr | 18 ++++++++--------- src/Compiler/Scheme/Chez.idr | 12 +++++------ src/Compiler/Scheme/Racket.idr | 13 ++++++------ src/Compiler/VMCode.idr | 14 +++++++------ src/Core/Case/CaseTree.idr | 7 ++++--- src/Core/CompileExpr.idr | 5 +++-- src/Core/Context.idr | 19 +++++++++--------- src/Core/Context/Data.idr | 2 ++ src/Core/Core.idr | 13 ++++++------ src/Core/Name/Namespace.idr | 9 +++------ src/Core/TT.idr | 9 +++++---- src/Core/TT/Term.idr | 3 ++- src/Idris/CommandLine.idr | 9 ++------- src/Idris/Elab/Implementation.idr | 8 +++++--- src/Idris/IDEMode/REPL.idr | 11 +++++----- src/Idris/ModTree.idr | 2 +- src/Idris/Package/Types.idr | 7 +++++-- src/Idris/Parser.idr | 7 ++++--- src/Idris/REPL.idr | 29 ++++++++++++++------------- src/Idris/SetOptions.idr | 9 +++++---- src/Idris/Syntax.idr | 20 +++++++++--------- src/Libraries/Data/SnocList/Extra.idr | 24 ++++++++++++++++++++++ src/Libraries/Data/String/Extra.idr | 16 +++++++-------- src/Libraries/Utils/Path.idr | 2 +- src/Libraries/Utils/Scheme.idr | 17 +++++++--------- src/TTImp/PartialEval.idr | 8 +++++--- src/TTImp/ProcessDef.idr | 3 ++- src/TTImp/TTImp.idr | 23 +++++++++++---------- src/TTImp/Unelab.idr | 3 +-- src/Yaffle/REPL.idr | 6 ++++-- 35 files changed, 220 insertions(+), 174 deletions(-) diff --git a/src/Compiler/ANF.idr b/src/Compiler/ANF.idr index e5b25a3d750..13f072c6478 100644 --- a/src/Compiler/ANF.idr +++ b/src/Compiler/ANF.idr @@ -5,6 +5,7 @@ import Compiler.LambdaLift import Core.CompileExpr import Core.Context +import Data.String import Data.SortedSet import Data.Vect @@ -82,26 +83,26 @@ mutual Show ANF where show (AV _ v) = show v show (AAppName fc lazy n args) - = show n ++ showLazy lazy ++ "(" ++ showSep ", " (map show args) ++ ")" + = show n ++ showLazy lazy ++ "(" ++ joinBy ", " (map show args) ++ ")" show (AUnderApp fc n m args) = "<" ++ show n ++ " underapp " ++ show m ++ ">(" ++ - showSep ", " (map show args) ++ ")" + joinBy ", " (map show args) ++ ")" show (AApp fc lazy c arg) = show c ++ showLazy lazy ++ " @ (" ++ show arg ++ ")" show (ALet fc x val sc) = "%let v" ++ show x ++ " = (" ++ show val ++ ") in (" ++ show sc ++ ")" show (ACon fc n _ t args) - = "%con " ++ show n ++ "(" ++ showSep ", " (map show args) ++ ")" + = "%con " ++ show n ++ "(" ++ joinBy ", " (map show args) ++ ")" show (AOp fc lazy op args) - = "%op " ++ show op ++ showLazy lazy ++ "(" ++ showSep ", " (toList (map show args)) ++ ")" + = "%op " ++ show op ++ showLazy lazy ++ "(" ++ joinBy ", " (toList (map show args)) ++ ")" show (AExtPrim fc lazy p args) - = "%extprim " ++ show p ++ showLazy lazy ++ "(" ++ showSep ", " (map show args) ++ ")" + = "%extprim " ++ show p ++ showLazy lazy ++ "(" ++ joinBy ", " (map show args) ++ ")" show (AConCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def ++ " }" + ++ joinBy "| " (map show alts) ++ " " ++ show def ++ " }" show (AConstCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def ++ " }" + ++ joinBy "| " (map show alts) ++ " " ++ show def ++ " }" show (APrimVal _ x) = show x show (AErased _) = "___" show (ACrash _ x) = "%CRASH(" ++ show x ++ ")" @@ -111,7 +112,7 @@ mutual Show AConAlt where show (MkAConAlt n _ t args sc) = "%conalt " ++ show n ++ - "(" ++ showSep ", " (map showArg args) ++ ") => " ++ show sc + "(" ++ joinBy ", " (map showArg args) ++ ") => " ++ show sc where showArg : Int -> String showArg i = "v" ++ show i diff --git a/src/Compiler/ES/Codegen.idr b/src/Compiler/ES/Codegen.idr index e86df834748..0a75c6d557c 100644 --- a/src/Compiler/ES/Codegen.idr +++ b/src/Compiler/ES/Codegen.idr @@ -1,11 +1,10 @@ module Compiler.ES.Codegen -import Compiler.Common import Core.CompileExpr import Core.Directory import Core.Env -import Data.String -import Data.SortedMap + +import Compiler.Common import Compiler.ES.Ast import Compiler.ES.Doc import Compiler.ES.ToAst @@ -13,14 +12,17 @@ import Compiler.ES.TailRec import Compiler.ES.State import Compiler.NoMangle import Protocol.Hex -import Libraries.Data.String.Extra import Idris.Pretty.Annotations import Idris.Syntax import Idris.Doc.String +import Data.String +import Data.SortedMap import Data.Vect +import Libraries.Data.String.Extra + -------------------------------------------------------------------------------- -- Utilities -------------------------------------------------------------------------------- @@ -834,6 +836,6 @@ compileToES c s cg tm ccTypes = do -- complete preamble, including content from additional -- support files (if any) - let pre = showSep "\n" $ static_preamble :: (values $ preamble st) + let pre = joinBy "\n" $ static_preamble :: (values $ preamble st) pure $ fastUnlines [pre,allDecls,main] diff --git a/src/Compiler/Interpreter/VMCode.idr b/src/Compiler/Interpreter/VMCode.idr index b5d816aab9f..6146e70bff4 100644 --- a/src/Compiler/Interpreter/VMCode.idr +++ b/src/Compiler/Interpreter/VMCode.idr @@ -10,6 +10,7 @@ import Idris.Syntax import Data.IOArray import Data.Vect + import Libraries.Data.NameMap public export @@ -26,14 +27,14 @@ showType (Const {}) = "Constant" showType Null = "Null" mutual - showSep : Nat -> List Object -> String - showSep k [] = "" - showSep k [o] = showDepth k o - showSep k (o :: os) = showDepth k o ++ ", " ++ showSep k os + joinBy : Nat -> List Object -> String + joinBy k [] = "" + joinBy k [o] = showDepth k o + joinBy k (o :: os) = showDepth k o ++ ", " ++ joinBy k os showDepth : Nat -> Object -> String - showDepth (S k) (Closure mis args fn) = show fn ++ "-" ++ show mis ++ "(" ++ showSep k (args <>> []) ++ ")" - showDepth (S k) (Constructor (Left t) args) = "tag" ++ show t ++ "(" ++ showSep k args ++ ")" + showDepth (S k) (Closure mis args fn) = show fn ++ "-" ++ show mis ++ "(" ++ joinBy k (args <>> []) ++ ")" + showDepth (S k) (Constructor (Left t) args) = "tag" ++ show t ++ "(" ++ joinBy k args ++ ")" showDepth (S k) (Const c) = show c showDepth _ obj = showType obj diff --git a/src/Compiler/LambdaLift.idr b/src/Compiler/LambdaLift.idr index d035f661a95..d6e2b8b1a40 100644 --- a/src/Compiler/LambdaLift.idr +++ b/src/Compiler/LambdaLift.idr @@ -13,6 +13,7 @@ module Compiler.LambdaLift import Core.CompileExpr import Core.Context +import Data.String import Data.Vect import Libraries.Data.SnocList.SizeOf @@ -268,26 +269,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 ++ "(" ++ joinBy ", " (map show args) ++ ")" show (LUnderApp fc n m args) = "<" ++ show n ++ " underapp " ++ show m ++ ">(" ++ - showSep ", " (map show args) ++ ")" + joinBy ", " (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 ++ "(" ++ joinBy ", " (map show args) ++ ")" show (LOp fc lazy op args) - = "%op " ++ show op ++ showLazy lazy ++ "(" ++ showSep ", " (toList (map show args)) ++ ")" + = "%op " ++ show op ++ showLazy lazy ++ "(" ++ joinBy ", " (toList (map show args)) ++ ")" show (LExtPrim fc lazy p args) - = "%extprim " ++ show p ++ showLazy lazy ++ "(" ++ showSep ", " (map show args) ++ ")" + = "%extprim " ++ show p ++ showLazy lazy ++ "(" ++ joinBy ", " (map show args) ++ ")" show (LConCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def + ++ joinBy "| " (map show alts) ++ " " ++ show def show (LConstCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def + ++ joinBy "| " (map show alts) ++ " " ++ show def show (LPrimVal _ x) = show x show (LErased _) = "___" show (LCrash _ x) = "%CRASH(" ++ show x ++ ")" @@ -297,7 +298,7 @@ mutual {vs : _} -> Show (LiftedConAlt vs) where show (MkLConAlt n _ t args sc) = "%conalt " ++ show n ++ - "(" ++ showSep ", " (map show args) ++ ") => " ++ show sc + "(" ++ joinBy ", " (map show args) ++ ") => " ++ show sc export covering diff --git a/src/Compiler/NoMangle.idr b/src/Compiler/NoMangle.idr index cb79970c9ba..5e6ecaa775f 100644 --- a/src/Compiler/NoMangle.idr +++ b/src/Compiler/NoMangle.idr @@ -2,6 +2,9 @@ module Compiler.NoMangle import Core.Context + +import Data.String + import Libraries.Data.NameMap import Libraries.Data.NameMap.Traversable @@ -29,8 +32,8 @@ initNoMangle backends valid = do let Just (backend, expName) = lookupBackend backends exps | Nothing => throw (GenericMsg EmptyFC """ No valid %export specifier for \{show name} - Supported backends: \{showSep ", " backends} - Given backends: \{showSep ", " (fst <$> exps)} + Supported backends: \{joinBy ", " backends} + Given backends: \{joinBy ", " (fst <$> exps)} """) let True = valid expName | False => throw (GenericMsg EmptyFC "\"\{expName}\" is not a valid name on \{backend} backend") diff --git a/src/Compiler/RefC/RefC.idr b/src/Compiler/RefC/RefC.idr index 0f42fdccb7f..796f8841926 100644 --- a/src/Compiler/RefC/RefC.idr +++ b/src/Compiler/RefC/RefC.idr @@ -1,7 +1,6 @@ module Compiler.RefC.RefC import Compiler.RefC.CC - import Compiler.Common import Compiler.CompileExpr import Compiler.ANF @@ -11,15 +10,16 @@ import Core.Directory import Idris.Syntax -import Libraries.Data.DList import Data.SortedSet import Data.SortedMap import Data.Vect +import Data.String import System import System.File import Protocol.Hex +import Libraries.Data.DList import Libraries.Utils.Path %default covering @@ -179,7 +179,7 @@ cOp StrAppend [x, y] = "strAppend(" ++ x ++ ", " ++ y ++ ")" cOp StrSubstr [x, y, z] = "strSubstr(" ++ x ++ ", " ++ y ++ ", " ++ z ++ ")" cOp BelieveMe [_, _, x] = "idris2_newReference(" ++ x ++ ")" cOp Crash [_, msg] = "idris2_crash(" ++ msg ++ ");" -cOp fn args = show fn ++ "(" ++ (showSep ", " $ toList args) ++ ")" +cOp fn args = show fn ++ "(" ++ (joinBy ", " $ toList args) ++ ")" varName : AVar -> String varName (ALocal i) = "var_" ++ (show i) @@ -561,7 +561,7 @@ mutual unless (elem pn prims) $ throw $ InternalError $ "[refc] Unknown primitive: " ++ cName p _ => throw $ InternalError $ "[refc] Unknown primitive: " ++ cName p emit fc $ "// call to external primitive " ++ cName p - pure $ "idris2_\{cName p}("++ showSep ", " (map varName args) ++")" + pure $ "idris2_\{cName p}("++ joinBy ", " (map varName args) ++")" cStatementsFromANF (AConCase fc sc alts mDef) tailPosition = do let sc' = varName sc @@ -812,7 +812,7 @@ createCFunctions n (MkAFun args anf) = do let fn = "Value *\{cName !(getFullName n)}" ++ (if nargs == 0 then "(void)" else if nargs > MaxExtractFunArgs then "(Value *var_arglist[\{show nargs}])" - else ("\n(\n" ++ (showSep "\n" $ addCommaToList (map (\i => " Value * var_" ++ (show i)) args))) ++ "\n)") + else ("\n(\n" ++ (joinBy "\n" $ addCommaToList (map (\i => " Value * var_" ++ (show i)) args))) ++ "\n)") update FunctionDefinitions $ \otherDefs => (fn ++ ";\n") :: otherDefs let argsVars = fromList $ ALocal <$> args @@ -861,7 +861,7 @@ createCFunctions n (MkAForeign ccs fargs ret) = do [lib, header] => update HeaderFiles $ insert header _ => pure () else emit EmptyFC $ additionalFFIStub fctName fargs ret - let fnDef = "Value *" ++ (cName n) ++ "(" ++ showSep ", " (replicate (length fargs) "Value *") ++ ");" + let fnDef = "Value *" ++ (cName n) ++ "(" ++ joinBy ", " (replicate (length fargs) "Value *") ++ ");" update FunctionDefinitions $ \otherDefs => (fnDef ++ "\n") :: otherDefs typeVarNameArgList <- createFFIArgList fargs @@ -874,21 +874,21 @@ createCFunctions n (MkAForeign ccs fargs ret) = do CFIORes CFUnit => do emit EmptyFC $ cName fctName ++ "(" - ++ showSep ", " (map (\(_, vn, vt) => extractValue cLang vt vn) (discardLastArgument typeVarNameArgList)) + ++ joinBy ", " (map (\(_, vn, vt) => extractValue cLang vt vn) (discardLastArgument typeVarNameArgList)) ++ ");" removeVarsArgList emit EmptyFC "return NULL;" CFIORes ret => do emit EmptyFC $ cTypeOfCFType ret ++ " retVal = " ++ cName fctName ++ "(" - ++ showSep ", " (map (\(_, vn, vt) => extractValue cLang vt vn) (discardLastArgument typeVarNameArgList)) + ++ joinBy ", " (map (\(_, vn, vt) => extractValue cLang vt vn) (discardLastArgument typeVarNameArgList)) ++ ");" removeVarsArgList emit EmptyFC $ "return (Value*)" ++ packCFType ret "retVal" ++ ";" _ => do emit EmptyFC $ cTypeOfCFType ret ++ " retVal = " ++ cName fctName ++ "(" - ++ showSep ", " (map (\(_, vn, vt) => extractValue cLang vt vn) typeVarNameArgList) + ++ joinBy ", " (map (\(_, vn, vt) => extractValue cLang vt vn) typeVarNameArgList) ++ ");" removeVarsArgList emit EmptyFC $ "return (Value*)" ++ packCFType ret "retVal" ++ ";" diff --git a/src/Compiler/Scheme/Chez.idr b/src/Compiler/Scheme/Chez.idr index 467d76f303a..d3dd30b77b4 100644 --- a/src/Compiler/Scheme/Chez.idr +++ b/src/Compiler/Scheme/Chez.idr @@ -8,22 +8,22 @@ import Compiler.Scheme.Common import Core.Directory import Protocol.Hex -import Libraries.Utils.Path -import Libraries.Data.String.Builder + +import Idris.Env +import Idris.Syntax import Data.Maybe import Data.SortedSet import Data.String -import Idris.Env -import Idris.Syntax - import System import System.Directory import System.Info import Libraries.Data.Version import Libraries.Utils.String +import Libraries.Utils.Path +import Libraries.Data.String.Builder %default covering @@ -93,7 +93,7 @@ schHeader chez libs whole [(i3nt ti3nt a6nt ta6nt) (load-shared-object "msvcrt.dll")] [else (load-shared-object "libc.so")]) - \{ showSep "\n" (map (\x => "(load-shared-object \"" ++ escapeStringChez x ++ "\")") libs) } + \{ joinBy "\n" (map (\x => "(load-shared-object \"" ++ escapeStringChez x ++ "\")") libs) } \{ ifThenElse whole "(let ()" diff --git a/src/Compiler/Scheme/Racket.idr b/src/Compiler/Scheme/Racket.idr index 9ee5537704b..c31c8d4a38f 100644 --- a/src/Compiler/Scheme/Racket.idr +++ b/src/Compiler/Scheme/Racket.idr @@ -8,20 +8,21 @@ import Compiler.Scheme.Common import Core.Directory import Protocol.Hex -import Libraries.Data.String.Builder -import Libraries.Utils.Path + +import Idris.Env +import Idris.Syntax import Data.Maybe import Data.String import Data.SortedSet -import Idris.Env -import Idris.Syntax - import System import System.Directory import System.Info +import Libraries.Data.String.Builder +import Libraries.Utils.Path + %default covering findRacket : IO String @@ -161,7 +162,7 @@ getLibVers libspec (root, rest) => (root, "") (fn :: vers) => (fst (span (/='.') fn), - "'(" ++ showSep " " (map show vers) ++ " #f)" ) + "'(" ++ joinBy " " (map show vers) ++ " #f)" ) cToRkt : CFType -> Builder -> Builder cToRkt CFChar op = "(integer->char " ++ op ++ ")" diff --git a/src/Compiler/VMCode.idr b/src/Compiler/VMCode.idr index 0f9f7cdef71..6e530ba54fc 100644 --- a/src/Compiler/VMCode.idr +++ b/src/Compiler/VMCode.idr @@ -5,9 +5,11 @@ import Compiler.ANF import Core.CompileExpr import Core.TT -import Libraries.Data.IntMap import Data.List import Data.Vect +import Data.String + +import Libraries.Data.IntMap %default covering @@ -73,21 +75,21 @@ Show VMInst where show (ASSIGN r v) = show r ++ " := " ++ show v show (MKCON r t args) = show r ++ " := MKCON " ++ show t ++ " (" ++ - showSep ", " (map show args) ++ ")" + joinBy ", " (map show args) ++ ")" show (MKCLOSURE r n m args) = show r ++ " := MKCLOSURE " ++ show n ++ " " ++ show m ++ " (" ++ - showSep ", " (map show args) ++ ")" + joinBy ", " (map show args) ++ ")" show (MKCONSTANT r c) = show r ++ " := MKCONSTANT " ++ show c show (APPLY r f a) = show r ++ " := " ++ show f ++ " @ " ++ show a show (CALL r t n args) = show r ++ " := " ++ (if t then "TAILCALL " else "CALL ") ++ - show n ++ "(" ++ showSep ", " (map show args) ++ ")" + show n ++ "(" ++ joinBy ", " (map show args) ++ ")" show (OP r op args) = show r ++ " := " ++ "OP " ++ - show op ++ "(" ++ showSep ", " (map show (toList args)) ++ ")" + show op ++ "(" ++ joinBy ", " (map show (toList args)) ++ ")" show (EXTPRIM r n args) = show r ++ " := " ++ "EXTPRIM " ++ - show n ++ "(" ++ showSep ", " (map show args) ++ ")" + show n ++ "(" ++ joinBy ", " (map show args) ++ ")" show (CASE scr alts def) = "CASE " ++ show scr ++ " " ++ show alts ++ " {default: " ++ show def ++ "}" diff --git a/src/Core/Case/CaseTree.idr b/src/Core/Case/CaseTree.idr index 2c7b1d07044..90df008ac7c 100644 --- a/src/Core/Case/CaseTree.idr +++ b/src/Core/Case/CaseTree.idr @@ -2,10 +2,11 @@ module Core.Case.CaseTree import Core.TT +import Idris.Pretty.Annotations + import Data.List import Data.So import Data.String -import Idris.Pretty.Annotations import Libraries.Data.NameMap import Libraries.Text.PrettyPrint.Prettyprinter @@ -135,7 +136,7 @@ showCA : {vars : _} -> (indent : String) -> CaseAlt vars -> String showCT indent (Case {name} idx prf ty alts) = "case " ++ show name ++ "[" ++ show idx ++ "] : " ++ show ty ++ " of" ++ "\n" ++ indent ++ " { " - ++ showSep ("\n" ++ indent ++ " | ") + ++ joinBy ("\n" ++ indent ++ " | ") (assert_total (map (showCA (" " ++ indent)) alts)) ++ "\n" ++ indent ++ " }" showCT indent (STerm i tm) = "[" ++ show i ++ "] " ++ show tm @@ -143,7 +144,7 @@ showCT indent (Unmatched msg) = "Error: " ++ show msg showCT indent Impossible = "Impossible" showCA indent (ConCase n tag args sc) - = showSep " " (map show (n :: args)) ++ " => " ++ + = joinBy " " (map show (n :: args)) ++ " => " ++ showCT indent sc showCA indent (DelayCase _ arg sc) = "Delay " ++ show arg ++ " => " ++ showCT indent sc diff --git a/src/Core/CompileExpr.idr b/src/Core/CompileExpr.idr index ab125936c9e..478aba8e751 100644 --- a/src/Core/CompileExpr.idr +++ b/src/Core/CompileExpr.idr @@ -5,6 +5,7 @@ module Core.CompileExpr import Core.TT import Data.List +import Data.String import Data.Vect import Libraries.Data.List.SizeOf @@ -397,8 +398,8 @@ Show CFType where show CFWorld = "%World" 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 (CFStruct n args) = "struct " ++ show n ++ " " ++ joinBy " " (map show args) + show (CFUser n args) = show n ++ " " ++ joinBy " " (map show args) export covering diff --git a/src/Core/Context.idr b/src/Core/Context.idr index bbbbdf8b442..e8ac7994ba5 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -11,17 +11,21 @@ import Core.Options import public Core.Options.Log import public Core.TT -import Libraries.Utils.Binary -import Libraries.Utils.Path -import Libraries.Utils.Scheme -import Libraries.Text.PrettyPrint.Prettyprinter - import Idris.Syntax.Pragmas import Data.Either import Data.IOArray import Data.List1 import Data.Nat +import Data.String + +import System.Clock +import System.Directory + +import Libraries.Utils.Binary +import Libraries.Utils.Path +import Libraries.Utils.Scheme +import Libraries.Text.PrettyPrint.Prettyprinter import Libraries.Data.IntMap import Libraries.Data.NameMap import Libraries.Data.NatSet @@ -30,9 +34,6 @@ import Libraries.Data.UserNameMap import Libraries.Data.WithDefault import Libraries.Text.Distance.Levenshtein -import System.Clock -import System.Directory - %default covering export @@ -1815,7 +1816,7 @@ setDetermining fc tyn args else getPos (1 + i) ns sc getPos _ [] _ = pure NatSet.empty getPos _ ns ty = throw (GenericMsg fc ("Unknown determining arguments: " - ++ showSep ", " (map show ns))) + ++ joinBy ", " (map show ns))) export setDetags : {auto c : Ref Ctxt Defs} -> diff --git a/src/Core/Context/Data.idr b/src/Core/Context/Data.idr index 12f02198831..a2cd7a13107 100644 --- a/src/Core/Context/Data.idr +++ b/src/Core/Context/Data.idr @@ -5,6 +5,8 @@ module Core.Context.Data import Core.Context.Log import Core.Normalise +import Data.String + import Libraries.Data.NatSet import Libraries.Data.WithDefault diff --git a/src/Core/Core.idr b/src/Core/Core.idr index ab2137cb6a5..65348ecb42d 100644 --- a/src/Core/Core.idr +++ b/src/Core/Core.idr @@ -6,6 +6,7 @@ import public Core.WithData import Data.List1 import Data.SnocList +import Data.String import Data.Vect import Libraries.Data.List01 @@ -261,11 +262,11 @@ 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) + joinBy "\n\t" (map show cs) NonCoveringCall ns => "Calls non covering function" ++ (case ns of [fn] => " " ++ show fn - _ => "s: " ++ showSep ", " (map show ns)) + _ => "s: " ++ joinBy ", " (map show ns)) show (NotTotal fc n r) = show fc ++ ":" ++ show n ++ " is not total" @@ -309,12 +310,12 @@ Show Error where show (NotRecordType fc ty) = show fc ++ ":" ++ show ty ++ " is not a record type" show (IncompatibleFieldUpdate fc flds) - = show fc ++ ":Field update " ++ showSep "->" flds ++ " not compatible with other updates" + = show fc ++ ":Field update " ++ joinBy "->" flds ++ " not compatible with other updates" show (InvalidArgs fc env ns tm) = show fc ++ ":" ++ show ns ++ " are not valid arguments in " ++ show tm show (TryWithImplicits fc env imps) = show fc ++ ":Need to bind implicits " - ++ showSep "," (map (\x => show (fst x) ++ " : " ++ show (snd x)) imps) + ++ joinBy "," (map (\x => show (fst x) ++ " : " ++ show (snd x)) imps) ++ "\n(The front end should probably have done this for you. Please report!)" show (BadUnboundImplicit fc env n ty) = show fc ++ ":Can't bind name " ++ nameRoot n ++ @@ -374,7 +375,7 @@ Show Error where show (ModuleNotFound fc ns) = show fc ++ ":" ++ show ns ++ " not found" show (CyclicImports ns) - = "Module imports form a cycle: " ++ showSep " -> " (map show ns) + = "Module imports form a cycle: " ++ joinBy " -> " (map show ns) show ForceNeeded = "Internal error when resolving implicit laziness" show (InternalError str) = "INTERNAL ERROR: " ++ str show (UserError str) = "Error: " ++ str @@ -405,7 +406,7 @@ Show Error where show (MaybeMisspelling err ns) = show err ++ "\nDid you mean" ++ case ns of (n ::: []) => ": " ++ n ++ "?" - _ => " any of: " ++ showSep ", " (map show (forget ns)) ++ "?" + _ => " any of: " ++ joinBy ", " (map show (forget ns)) ++ "?" show (WarningAsError w) = show w show (OperatorBindingMismatch fc (DeclaredFixity expected) actual opName rhs _) = show fc ++ ": Operator " ++ show opName ++ " is " ++ show expected diff --git a/src/Core/Name/Namespace.idr b/src/Core/Name/Namespace.idr index cb9a44d3089..89c4706db96 100644 --- a/src/Core/Name/Namespace.idr +++ b/src/Core/Name/Namespace.idr @@ -2,7 +2,9 @@ module Core.Name.Namespace import Data.List import Data.String + import Decidable.Equality + import Libraries.Data.String.Extra import Libraries.Text.PrettyPrint.Prettyprinter import Libraries.Utils.Path @@ -209,14 +211,9 @@ DecEq Namespace where decEq (MkNS ms) (MkNS ns) | No contra = No (contra . mkNSInjective) decEq (MkNS ms) (MkNS ns) | Yes eqmsns = Yes (cong MkNS eqmsns) --- TODO: move somewhere more appropriate -export -showSep : String -> List String -> String -showSep sep = Libraries.Data.String.Extra.join sep - export showNSWithSep : String -> Namespace -> String -showNSWithSep sep (MkNS ns) = showSep sep (reverse ns) +showNSWithSep sep (MkNS ns) = joinBy sep (reverse ns) export Show Namespace where diff --git a/src/Core/TT.idr b/src/Core/TT.idr index fd576405b98..8925a9752aa 100644 --- a/src/Core/TT.idr +++ b/src/Core/TT.idr @@ -5,6 +5,7 @@ import public Core.Name import public Core.Name.Scoped import Data.Maybe +import Data.String import Libraries.Data.NameMap import Libraries.Text.PrettyPrint.Prettyprinter @@ -285,13 +286,13 @@ Show PartialReason where show (BadCall [n]) = "possibly not terminating due to call to " ++ show n show (BadCall ns) - = "possibly not terminating due to calls to " ++ showSep ", " (map show ns) + = "possibly not terminating due to calls to " ++ joinBy ", " (map show ns) show (BadPath [_] n) = "possibly not terminating due to call to " ++ show n show (BadPath init n) - = "possibly not terminating due to function " ++ show n ++ " being reachable via " ++ showSep " -> " (map show init) + = "possibly not terminating due to function " ++ show n ++ " being reachable via " ++ joinBy " -> " (map show init) show (RecPath loop) - = "possibly not terminating due to recursive path " ++ showSep " -> " (map (show . snd) loop) + = "possibly not terminating due to recursive path " ++ joinBy " -> " (map (show . snd) loop) export Pretty Void PartialReason where @@ -340,7 +341,7 @@ Show Covering where show (NonCoveringCall [f]) = "not covering due to call to function " ++ show f show (NonCoveringCall cs) - = "not covering due to calls to functions " ++ showSep ", " (map show cs) + = "not covering due to calls to functions " ++ joinBy ", " (map show cs) export Pretty Void Covering where diff --git a/src/Core/TT/Term.idr b/src/Core/TT/Term.idr index e68d634fcb9..b1e613f6cf7 100644 --- a/src/Core/TT/Term.idr +++ b/src/Core/TT/Term.idr @@ -10,6 +10,7 @@ import Core.TT.Primitive import Core.TT.Var import Data.List +import Data.String import Libraries.Data.List.SizeOf @@ -554,5 +555,5 @@ covering showApp (TType _ u) [] = "Type" showApp _ [] = "???" showApp f args = "(" ++ assert_total (show f) ++ " " ++ - assert_total (showSep " " (map show args)) + assert_total (joinBy " " (map show args)) ++ ")" diff --git a/src/Idris/CommandLine.idr b/src/Idris/CommandLine.idr index 53dbbb2a4b5..07c2a4a26df 100644 --- a/src/Idris/CommandLine.idr +++ b/src/Idris/CommandLine.idr @@ -398,14 +398,9 @@ options = [MkOpt ["--check", "-c"] [] [CheckOnly] optShow : OptDesc -> (String, Maybe String) optShow (MkOpt [] _ _ _) = ("", Just "") -optShow (MkOpt flags argdescs action help) = (showSep ", " flags ++ " " ++ - showSep " " (map show argdescs), +optShow (MkOpt flags argdescs action help) = (joinBy ", " flags ++ " " ++ + joinBy " " (map show argdescs), help) - where - showSep : String -> List String -> String - showSep sep [] = "" - showSep sep [x] = x - showSep sep (x :: xs) = x ++ sep ++ showSep sep xs firstColumnWidth : Nat firstColumnWidth = let maxOpt = foldr max 0 $ map (length . fst . optShow) options diff --git a/src/Idris/Elab/Implementation.idr b/src/Idris/Elab/Implementation.idr index e8f5b0e44af..193fbbde528 100644 --- a/src/Idris/Elab/Implementation.idr +++ b/src/Idris/Elab/Implementation.idr @@ -16,7 +16,9 @@ import TTImp.TTImp.Functor import TTImp.Unelab import TTImp.Utils +import Data.String import Control.Monad.State + import Libraries.Data.ANameMap import Libraries.Data.NameMap @@ -38,7 +40,7 @@ mkImplName : FC -> Name -> List RawImp -> Name mkImplName fc n ps = DN (show n ++ " implementation at " ++ replaceSep (show fc)) (UN $ Basic ("__Impl_" ++ show n ++ "_" ++ - showSep "_" (map show ps))) + joinBy "_" (map show ps))) bindConstraints : FC -> PiInfo RawImp -> List (Maybe Name, RawImp) -> RawImp -> RawImp @@ -227,7 +229,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i log "elab.implementation" 5 $ "Missing methods: " ++ show missing when (not (isNil missing)) $ throw (GenericMsg ifc ("Missing methods in " ++ show iname ++ ": " - ++ showSep ", " (map show missing))) + ++ joinBy ", " (map show missing))) -- Add the 'using' hints defs <- get Ctxt @@ -376,7 +378,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i = DN (show n) (UN $ Basic (show n ++ "_" ++ show iname ++ "_" ++ (if named then show impName_in else "") ++ - showSep "_" (map show ps))) + joinBy "_" (map show ps))) applyCon : Name -> Name -> Core (Name, RawImp) applyCon impl n diff --git a/src/Idris/IDEMode/REPL.idr b/src/Idris/IDEMode/REPL.idr index 72cd819c2e8..b42167d2322 100644 --- a/src/Idris/IDEMode/REPL.idr +++ b/src/Idris/IDEMode/REPL.idr @@ -20,7 +20,6 @@ import Idris.IDEMode.SyntaxHighlight import Idris.IDEMode.Pretty import Protocol.Hex -import Libraries.Utils.Path import Data.String import System @@ -33,6 +32,8 @@ import Network.Socket.Raw import TTImp.Interactive.Completion +import Libraries.Utils.Path + %default covering export @@ -353,11 +354,11 @@ displayIDEResult outf i (REPL $ ProofFound x) = printIDEResult outf i $ AString $ show x displayIDEResult outf i (REPL $ Missed cases) = printIDEResult outf i - $ AString $ showSep "\n" + $ AString $ joinBy "\n" $ map handleMissing' cases displayIDEResult outf i (REPL $ CheckedTotal xs) = printIDEResult outf i - $ AString $ showSep "\n" + $ AString $ joinBy "\n" $ map (\ (fn, tot) => (show fn ++ " is " ++ show tot)) xs displayIDEResult outf i (REPL $ LogLevelSet k) = printIDEResult outf i @@ -383,10 +384,10 @@ displayIDEResult outf i (REPL $ Edited (MadeLemma lit name pty pappstr)) } displayIDEResult outf i (REPL $ Edited (MadeWith lit wapp)) = printIDEResult outf i - $ AString $ showSep "\n" (map (relit lit) wapp) + $ AString $ joinBy "\n" (map (relit lit) wapp) displayIDEResult outf i (REPL $ (Edited (MadeCase lit cstr))) = printIDEResult outf i - $ AString $ showSep "\n" (map (relit lit) cstr) + $ AString $ joinBy "\n" (map (relit lit) cstr) displayIDEResult outf i (FoundHoles holes) = printIDEResult outf i $ AHoleList $ map holeIDE holes displayIDEResult outf i (CompletionList ns r) diff --git a/src/Idris/ModTree.idr b/src/Idris/ModTree.idr index a59e1fd3504..8e3334eb835 100644 --- a/src/Idris/ModTree.idr +++ b/src/Idris/ModTree.idr @@ -48,7 +48,7 @@ record BuildMod where export Show BuildMod where - show t = buildFile t ++ " [" ++ showSep ", " (map show (imports t)) ++ "]" + show t = buildFile t ++ " [" ++ joinBy ", " (map show (imports t)) ++ "]" data AllMods : Type where diff --git a/src/Idris/Package/Types.idr b/src/Idris/Package/Types.idr index 4266699caac..34f739af66a 100644 --- a/src/Idris/Package/Types.idr +++ b/src/Idris/Package/Types.idr @@ -2,10 +2,13 @@ module Idris.Package.Types import Core.FC import Core.Name.Namespace + +import Idris.Version + import Data.List import Data.Maybe import Data.String -import Idris.Version + import Libraries.Text.PrettyPrint.Prettyprinter import Libraries.Text.PrettyPrint.Prettyprinter.Util @@ -19,7 +22,7 @@ data PkgVersion = MkPkgVersion (List1 Nat) export Show PkgVersion where - show (MkPkgVersion vs) = showSep "." (map show (forget vs)) + show (MkPkgVersion vs) = joinBy "." (map show (forget vs)) export Pretty Void PkgVersion where diff --git a/src/Idris/Parser.idr b/src/Idris/Parser.idr index 3ac9110487a..095156c7544 100644 --- a/src/Idris/Parser.idr +++ b/src/Idris/Parser.idr @@ -6,14 +6,15 @@ import Idris.Syntax.Traversals import public Parser.Source import TTImp.TTImp -import public Libraries.Text.Parser import Data.Either -import Libraries.Data.IMaybe import Data.List.Quantifiers import Data.List1 import Data.Maybe import Data.Nat import Data.String + +import public Libraries.Text.Parser +import Libraries.Data.IMaybe import Libraries.Utils.String import Libraries.Data.WithDefault @@ -2148,7 +2149,7 @@ mutual Show CmdArg where show NoArg = "" show OnOffArg = "(on|off)" - show (Args args) = showSep " " (map show args) + show (Args args) = joinBy " " (map show args) show arg = "<" ++ showCmdArg arg ++ ">" public export diff --git a/src/Idris/REPL.idr b/src/Idris/REPL.idr index 84c00483b05..15c7f1a2490 100644 --- a/src/Idris/REPL.idr +++ b/src/Idris/REPL.idr @@ -56,21 +56,22 @@ import TTImp.BindImplicits import TTImp.ProcessDecls import Data.Maybe +import Data.Stream +import Data.String + +import System +import System.File + import Libraries.Data.NatSet import Libraries.Data.NameMap import Libraries.Data.PosMap import Libraries.Data.String as L -import Data.Stream -import Data.String import Libraries.Data.SparseMatrix import Libraries.Data.Tap import Libraries.Data.WithDefault import Libraries.Utils.Path import Libraries.System.Directory.Tree -import System -import System.File - %default covering -- Do NOT remove: it can be used instead of prettyInfo in case the prettier output @@ -96,7 +97,7 @@ showInfo (n, idx, d) let scinfo = map (\s => show (fnCall s) ++ ": " ++ show (fnArgs s)) !(traverse toFullNames (sizeChange d)) in coreLift_ $ putStrLn $ - "Size change: " ++ showSep ", " scinfo + "Size change: " ++ joinBy ", " scinfo prettyInfo : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> @@ -221,7 +222,7 @@ printClause l i (WithClause _ lhsraw rig wvraw prf flags csraw) -- TODO: remove `the` after fix idris-lang/Idris2#3418 ++ maybe "" (the (_ -> _) $ \(rg, nm) => " proof " ++ showCount rg ++ show nm) prf ++ "\n") - ++ showSep "\n" cs) + ++ joinBy "\n" cs) printClause l i (ImpossibleClause _ lhsraw) = do lhs <- pterm $ map defaultKindedName lhsraw -- hack pure (relit l (pack (replicate i ' ') ++ show lhs ++ " impossible")) @@ -1190,11 +1191,11 @@ mutual export handleMissing' : MissedResult -> String - handleMissing' (CasesMissing x xs) = show x ++ ":\n" ++ showSep "\n" xs + handleMissing' (CasesMissing x xs) = show x ++ ":\n" ++ joinBy "\n" xs handleMissing' (CallsNonCovering fn ns) = (show fn ++ ": Calls non covering function" ++ (case ns of [f] => " " ++ show f - _ => "s: " ++ showSep ", " (map show ns))) + _ => "s: " ++ joinBy ", " (map show ns))) handleMissing' (AllCasesCovered fn) = show fn ++ ": All cases covered" export @@ -1267,9 +1268,9 @@ mutual displayResult (Edited (EditError x)) = printResult x displayResult (Edited (MadeLemma lit name pty pappstr)) = printResult $ pretty0 (relit lit (show name ++ " : " ++ show pty ++ "\n") ++ pappstr) - displayResult (Edited (MadeWith lit wapp)) = printResult $ pretty0 $ showSep "\n" (map (relit lit) wapp) - displayResult (Edited (MadeCase lit cstr)) = printResult $ pretty0 $ showSep "\n" (map (relit lit) cstr) - displayResult (Edited (MadeIntro is)) = printResult $ pretty0 $ showSep "\n" (toList is) + displayResult (Edited (MadeWith lit wapp)) = printResult $ pretty0 $ joinBy "\n" (map (relit lit) wapp) + displayResult (Edited (MadeCase lit cstr)) = printResult $ pretty0 $ joinBy "\n" (map (relit lit) cstr) + displayResult (Edited (MadeIntro is)) = printResult $ pretty0 $ joinBy "\n" (toList is) displayResult (OptionsSet opts) = printResult (vsep (pretty0 <$> opts)) -- do not use a catchall so that we are warned when a new constructor is added @@ -1281,7 +1282,7 @@ mutual export displayHelp : String displayHelp = - showSep "\n" $ map cmdInfo help + joinBy "\n" $ map cmdInfo help where makeSpace : Nat -> String makeSpace n = pack $ take n (repeat ' ') @@ -1292,7 +1293,7 @@ mutual m ++ (makeSpace $ c2 `minus` length m) ++ r cmdInfo : (List String, CmdArg, String) -> String - cmdInfo (cmds, args, text) = " " ++ col 18 36 (showSep " " cmds) (show args) text + cmdInfo (cmds, args, text) = " " ++ col 18 36 (joinBy " " cmds) (show args) text ||| Display errors that may occur when starting the REPL. ||| Does not force the REPL to exit, just prints the error(s). diff --git a/src/Idris/SetOptions.idr b/src/Idris/SetOptions.idr index 057bedbcf8d..e777d22a314 100644 --- a/src/Idris/SetOptions.idr +++ b/src/Idris/SetOptions.idr @@ -6,8 +6,6 @@ import Core.Binary import Core.Directory import Core.Metadata import Core.Unify -import Libraries.Utils.Path -import Libraries.Data.List.Extra import Idris.CommandLine import Idris.Package.Types @@ -24,6 +22,9 @@ import Data.String import System import System.Directory +import Libraries.Utils.Path +import Libraries.Data.List.Extra + %default covering ||| Dissected information about a package directory @@ -377,7 +378,7 @@ setIncrementalCG failOnError cgn if failOnError then do coreLift $ putStrLn "No such code generator" coreLift $ putStrLn $ "Code generators available: " ++ - showSep ", " (map fst (availableCGs (options defs))) + joinBy ", " (map fst (availableCGs (options defs))) coreLift $ exitWith (ExitFailure 1) else pure () @@ -423,7 +424,7 @@ preOptions (SetCG e :: opts) Nothing => do coreLift $ putStrLn "No such code generator" coreLift $ putStrLn $ "Code generators available: " ++ - showSep ", " (map fst (availableCGs (options defs))) + joinBy ", " (map fst (availableCGs (options defs))) coreLift $ exitWith (ExitFailure 1) preOptions (Directive d :: opts) = do setSession ({ directives $= (d::) } !getSession) diff --git a/src/Idris/Syntax.idr b/src/Idris/Syntax.idr index 49b75928d46..1febc3bd4db 100644 --- a/src/Idris/Syntax.idr +++ b/src/Idris/Syntax.idr @@ -7,11 +7,11 @@ import public Core.Options import TTImp.TTImp +import public Idris.Syntax.Pragmas + import Data.SortedMap import Data.String -import public Idris.Syntax.Pragmas - import Libraries.Data.ANameMap import Libraries.Data.NameMap import Libraries.Data.String.Extra @@ -819,8 +819,8 @@ parameters {0 nm : Type} (toName : nm -> Name) showPStr (StrLiteral _ str) = show str showPStr (StrInterp _ tm) = showPTerm tm - showUpdate (PSetField p v) = showSep "." p ++ " = " ++ showPTerm v - showUpdate (PSetFieldApp p v) = showSep "." p ++ " $= " ++ showPTerm v + showUpdate (PSetField p v) = joinBy "." p ++ " = " ++ showPTerm v + showUpdate (PSetFieldApp p v) = joinBy "." p ++ " $= " ++ showPTerm v showBasicMultiBinder (MkBasicMultiBinder rig names type) = "\{showCount rig} \{showNames}: \{showPTerm type}" @@ -869,7 +869,7 @@ parameters {0 nm : Type} (toName : nm -> Name) " in " ++ showPTermPrec d sc showPTermPrec _ (PCase _ _ tm cs) = "case " ++ showPTerm tm ++ " of { " ++ - showSep " ; " (map showCase cs) ++ " }" + joinBy " ; " (map showCase cs) ++ " }" where showCase : PClause' nm -> String showCase (MkPatClause _ lhs rhs _) = showPTerm lhs ++ " => " ++ showPTerm rhs @@ -878,7 +878,7 @@ parameters {0 nm : Type} (toName : nm -> Name) showPTermPrec d (PLocal _ ds sc) -- We'll never see this when displaying a normal form... = "let { << definitions >> } in " ++ showPTermPrec d sc showPTermPrec d (PUpdate _ fs) - = "record { " ++ showSep ", " (map showUpdate fs) ++ " }" + = "record { " ++ joinBy ", " (map showUpdate fs) ++ " }" showPTermPrec d (PApp _ f a) = let catchall : Lazy String := showPTermPrec App f ++ " " ++ showPTermPrec App a in case f of @@ -933,14 +933,14 @@ parameters {0 nm : Type} (toName : nm -> Name) showPTermPrec d (PString _ _ xs) = join " ++ " $ showPStr <$> xs showPTermPrec d (PMultiline _ _ indent xs) = "multiline (" ++ (join " ++ " $ showPStr <$> concat xs) ++ ")" showPTermPrec d (PDoBlock _ ns ds) - = "do " ++ showSep " ; " (map showDo ds) + = "do " ++ joinBy " ; " (map showDo ds) showPTermPrec d (PBang _ tm) = "!" ++ showPTermPrec d tm showPTermPrec d (PIdiom _ Nothing tm) = "[|" ++ showPTermPrec d tm ++ "|]" showPTermPrec d (PIdiom _ (Just ns) tm) = show ns ++ ".[|" ++ showPTermPrec d tm ++ "|]" showPTermPrec d (PList _ _ xs) - = "[" ++ showSep ", " (map (showPTermPrec d . snd) xs) ++ "]" + = "[" ++ joinBy ", " (map (showPTermPrec d . snd) xs) ++ "]" showPTermPrec d (PSnocList _ _ xs) - = "[<" ++ showSep ", " (map (showPTermPrec d . snd) (xs <>> [])) ++ "]" + = "[<" ++ joinBy ", " (map (showPTermPrec d . snd) (xs <>> [])) ++ "]" showPTermPrec d (PPair _ l r) = "(" ++ showPTermPrec d l ++ ", " ++ showPTermPrec d r ++ ")" showPTermPrec d (PDPair _ _ l (PImplicit _) r) = "(" ++ showPTermPrec d l ++ " ** " ++ showPTermPrec d r ++ ")" showPTermPrec d (PDPair _ _ l ty r) = "(" ++ showPTermPrec d l ++ " : " ++ showPTermPrec d ty ++ @@ -950,7 +950,7 @@ parameters {0 nm : Type} (toName : nm -> Name) " else " ++ showPTermPrec d e showPTermPrec d (PComprehension _ ret es) = "[" ++ showPTermPrec d (dePure ret) ++ " | " ++ - showSep ", " (map (showDo . deGuard) es) ++ "]" + joinBy ", " (map (showDo . deGuard) es) ++ "]" where dePure : PTerm' nm -> PTerm' nm dePure tm@(PApp _ (PRef _ n) arg) diff --git a/src/Libraries/Data/SnocList/Extra.idr b/src/Libraries/Data/SnocList/Extra.idr index 82956cea2a6..47999fd2bd4 100644 --- a/src/Libraries/Data/SnocList/Extra.idr +++ b/src/Libraries/Data/SnocList/Extra.idr @@ -2,6 +2,7 @@ module Libraries.Data.SnocList.Extra import Data.Nat import Data.SnocList + import Syntax.PreorderReasoning -- TODO left-to-right reversal of the stream @@ -49,3 +50,26 @@ lengthDistributesOverFish sx (y :: ys) = Calc $ ~~ S (length sx) + length ys ...( Refl ) ~~ length sx + S (length ys) ...( plusSuccRightSucc _ _ ) ~~ length sx + length (y :: ys) ...( Refl ) + +||| Insert some separator between the elements of a snoc-list. +||| +||| @ sep the value to intersperse +||| @ xs the snoc-list of elements to intersperse with the separator +||| +||| ```idris example +||| > with SnocList (intersperse ',' [<'a', 'b', 'c', 'd', 'e']) +||| [<'a', ',', 'b', ',', 'c', ',', 'd', ',', 'e'] +||| ``` +public export +intersperse : (sep : a) -> (xs : SnocList a) -> SnocList a +intersperse sep [<] = [<] +intersperse sep [ SnocList String -> String +joinBy sep ws = concat (intersperse sep ws) diff --git a/src/Libraries/Data/String/Extra.idr b/src/Libraries/Data/String/Extra.idr index 48db1ba6170..f0b6bb847dd 100644 --- a/src/Libraries/Data/String/Extra.idr +++ b/src/Libraries/Data/String/Extra.idr @@ -71,13 +71,6 @@ public export shrink : (n : Nat) -> (input : String) -> String shrink n str = dropLast n (drop n str) -||| Concatenate the strings from a `Foldable` containing strings, separated by -||| the given string. -public export -join : (sep : String) -> Foldable t => (xs : t String) -> String -join sep xs = drop (length sep) - (foldl (\acc, x => acc ++ sep ++ x) "" xs) - ||| Get a character from a string if the string is long enough. public export index : (n : Nat) -> (input : String) -> Maybe Char @@ -94,4 +87,11 @@ indent n x = replicate n ' ' ++ x ||| Indent each line of a given string by `n` spaces. public export indentLines : (n : Nat) -> String -> String -indentLines n str = (join "\n") $ map (Extra.indent n) $ lines str +indentLines n str = joinBy "\n" $ map (Extra.indent n) $ lines str + +-- Copied from libs/contrib/Data/String/Extra.idr +-- TODO: move/reuse +public export +join : (sep : String) -> Foldable t => (xs : t String) -> String +join sep xs = drop (length sep) + (foldl (\acc, x => acc ++ sep ++ x) "" xs) diff --git a/src/Libraries/Utils/Path.idr b/src/Libraries/Utils/Path.idr index 047a18ecb3e..5be6cf3e058 100644 --- a/src/Libraries/Utils/Path.idr +++ b/src/Libraries/Utils/Path.idr @@ -123,7 +123,7 @@ Show Path where sep = String.singleton dirSeparator showVol = maybe "" show path.volume showRoot = if path.hasRoot then sep else "" - showBody = join sep $ map show path.body + showBody = joinBy sep $ map show path.body showTrail = if path.hasTrailSep then sep else "" in showVol ++ showRoot ++ showBody ++ showTrail diff --git a/src/Libraries/Utils/Scheme.idr b/src/Libraries/Utils/Scheme.idr index 29af6335287..792eca07a01 100644 --- a/src/Libraries/Utils/Scheme.idr +++ b/src/Libraries/Utils/Scheme.idr @@ -1,5 +1,7 @@ module Libraries.Utils.Scheme +import Data.String + export data ForeignObj : Type where [external] @@ -202,11 +204,6 @@ evalSchemeObj obj = do let str = toString obj evalSchemeStr str where - showSep : String -> List String -> String - showSep sep [] = "" - showSep sep [x] = x - showSep sep (x :: xs) = x ++ sep ++ showSep sep xs - toString : SchemeObj Write -> String toString Null = "'()" toString (Cons x y) = "(cons " ++ toString x ++ " " ++ toString y ++ ")" @@ -218,19 +215,19 @@ evalSchemeObj obj then "#\\" ++ cast x else "(integer->char " ++ show (the Int (cast x)) ++ ")" toString (Symbol x) = "'" ++ x - toString (Vector i xs) = "(vector " ++ show i ++ " " ++ showSep " " (map toString xs) ++ ")" + toString (Vector i xs) = "(vector " ++ show i ++ " " ++ joinBy " " (map toString xs) ++ ")" toString (Box x) = "(box " ++ toString x ++ ")" toString (Define x body) = "(define (" ++ x ++ ") " ++ toString body ++ ")" toString (Var x) = x toString (Lambda xs x) - = "(lambda (" ++ showSep " " xs ++ ") " ++ toString x ++ ")" + = "(lambda (" ++ joinBy " " xs ++ ") " ++ toString x ++ ")" toString (Let var val x) = "(let ((" ++ var ++ " " ++ toString val ++ ")) " ++ toString x ++ ")" toString (If x t e) = "(if " ++ toString x ++ " " ++ toString t ++ " " ++ toString e ++ ")" toString (Case x alts def) = "(case " ++ toString x ++ " " ++ - showSep " " (map showAlt alts) ++ + joinBy " " (map showAlt alts) ++ showDef def ++ ")" where showAlt : (SchemeObj Write, SchemeObj Write) -> String @@ -242,7 +239,7 @@ evalSchemeObj obj showDef (Just e) = " (else " ++ toString e ++ ")" toString (Cond alts def) = "(cond " ++ - showSep " " (map showAlt alts) ++ + joinBy " " (map showAlt alts) ++ showDef def ++ ")" where showAlt : (SchemeObj Write, SchemeObj Write) -> String @@ -253,7 +250,7 @@ evalSchemeObj obj showDef Nothing = "" showDef (Just e) = " (else " ++ toString e ++ ")" toString (Apply x xs) - = "(" ++ toString x ++ " " ++ showSep " " (map toString xs) ++ ")" + = "(" ++ toString x ++ " " ++ joinBy " " (map toString xs) ++ ")" export decodeObj : ForeignObj -> SchemeObj Readback diff --git a/src/TTImp/PartialEval.idr b/src/TTImp/PartialEval.idr index 1b1940f7a06..e4814723527 100644 --- a/src/TTImp/PartialEval.idr +++ b/src/TTImp/PartialEval.idr @@ -17,6 +17,8 @@ import TTImp.Unelab import Protocol.Hex +import Data.String + import Libraries.Data.NameMap import Libraries.Data.NatSet import Libraries.Data.WithDefault @@ -268,7 +270,7 @@ mkSpecDef {vars} fc gdef pename sargs fn stk pure (show (i, arg'))) sargs pure $ "Specialising " ++ show fnfull ++ " (" ++ show fn ++ ") -> \{show pename} by " ++ - showSep ", " args' + joinBy ", " args' let sty = specialiseTy 0 staticargs (type gdef) logTermNF "specialise" 3 ("Specialised type " ++ show pename) Env.empty sty @@ -298,13 +300,13 @@ mkSpecDef {vars} fc gdef pename sargs fn stk logC "specialise" 5 $ do inpats <- traverse unelabDef pats pure $ "Attempting to specialise:\n" ++ - showSep "\n" (map showPat inpats) + joinBy "\n" (map showPat inpats) Just newpats <- getSpecPats fc pename fn stk !(nf defs Env.empty (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) + joinBy "\n" (map showPat newpats) processDecl [InPartialEval] (MkNested []) Env.empty (IDef fc (Resolved peidx) newpats) setAllPublic False diff --git a/src/TTImp/ProcessDef.idr b/src/TTImp/ProcessDef.idr index 6430411c658..e7e57e918c2 100644 --- a/src/TTImp/ProcessDef.idr +++ b/src/TTImp/ProcessDef.idr @@ -35,6 +35,7 @@ import Data.Either import Data.List import Data.String import Data.Maybe + import Libraries.Data.NameMap import Libraries.Data.WithDefault import Libraries.Text.PrettyPrint.Prettyprinter @@ -1141,7 +1142,7 @@ processDef opts nest env fc n_in cs_in do mc <- traverse toFullNames missCase pure ("Initially missing in " ++ show !(getFullName (Resolved n)) ++ ":\n" ++ - showSep "\n" (map show mc)) + joinBy "\n" (map show mc)) -- Filter out the ones which are impossible missImp <- traverse (checkImpossible n mult) missCase -- Filter out the ones which are actually matched (perhaps having diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index 708ad506640..8cb9104e251 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -5,6 +5,7 @@ import Core.Env import Core.Normalise import Core.Value +import Data.String import public Data.List1 import Data.SortedSet @@ -174,7 +175,7 @@ mutual = "(%caselocal (" ++ show uname ++ " " ++ show iname ++ " " ++ show args ++ ") " ++ show sc ++ ")" show (IUpdate _ flds rec) - = "(%record " ++ showSep ", " (map show flds) ++ " " ++ show rec ++ ")" + = "(%record " ++ joinBy ", " (map show flds) ++ " " ++ show rec ++ ")" show (IApp fc f a) = "(" ++ show f ++ " " ++ show a ++ ")" show (INamedApp fc f n a) @@ -186,7 +187,7 @@ mutual show (ISearch fc d) = "%search" show (IAlternative fc ty alts) - = "(|" ++ showSep "," (map show alts) ++ "|)" + = "(|" ++ joinBy "," (map show alts) ++ "|)" show (IRewrite _ rule tm) = "(%rewrite (" ++ show rule ++ ") (" ++ show tm ++ "))" show (ICoerced _ tm) = "(%coerced " ++ show tm ++ ")" @@ -215,8 +216,8 @@ mutual export covering Show nm => Show (IFieldUpdate' nm) where - show (ISetField p val) = showSep "->" p ++ " = " ++ show val - show (ISetFieldApp p val) = showSep "->" p ++ " $= " ++ show val + show (ISetField p val) = joinBy "->" p ++ " = " ++ show val + show (ISetFieldApp p val) = joinBy "->" p ++ " $= " ++ show val public export FnOpt : Type @@ -272,14 +273,14 @@ mutual show (Hint t) = "%hint " ++ show t show (GlobalHint t) = "%globalhint " ++ show t show ExternFn = "%extern" - show (ForeignFn cs) = "%foreign " ++ showSep " " (map show cs) - show (ForeignExport cs) = "%export " ++ showSep " " (map show cs) + show (ForeignFn cs) = "%foreign " ++ joinBy " " (map show cs) + show (ForeignExport cs) = "%export " ++ joinBy " " (map show cs) show Invertible = "%invertible" show (Totality Total) = "total" show (Totality CoveringOnly) = "covering" show (Totality PartialOK) = "partial" show Macro = "%macro" - show (SpecArgs ns) = "%spec " ++ showSep " " (map show ns) + show (SpecArgs ns) = "%spec " ++ joinBy " " (map show ns) export Eq FnOpt where @@ -402,7 +403,7 @@ mutual show (MkImpRecord header body) = "record " ++ show header.name.val ++ " " ++ show header.val ++ " " ++ show body.name.val ++ "\n\t" ++ - showSep "\n\t" (map show body.val) ++ "\n" + joinBy "\n\t" (map show body.val) ++ "\n" public export data WithFlag @@ -496,14 +497,14 @@ mutual show (IDef _ n cs) = "(%def " ++ show n ++ " " ++ show cs ++ ")" show (IParameters _ ps ds) = "parameters " ++ show ps ++ "\n\t" ++ - showSep "\n\t" (assert_total $ map show ds) + joinBy "\n\t" (assert_total $ map show ds) show (IRecord _ _ _ _ d) = show d.val show (IFail _ msg decls) = "fail" ++ maybe "" ((" " ++) . show) msg ++ "\n" ++ - showSep "\n" (assert_total $ map ((" " ++) . show) decls) + joinBy "\n" (assert_total $ map ((" " ++) . show) decls) show (INamespace _ ns decls) = "namespace " ++ show ns ++ - showSep "\n" (assert_total $ map show decls) + joinBy "\n" (assert_total $ map show decls) show (ITransform _ n lhs rhs) = "%transform " ++ show n ++ " " ++ show lhs ++ " ==> " ++ show rhs show (IRunElabDecl _ tm) diff --git a/src/TTImp/Unelab.idr b/src/TTImp/Unelab.idr index b5ddeb58096..52cc3d6ef0f 100644 --- a/src/TTImp/Unelab.idr +++ b/src/TTImp/Unelab.idr @@ -11,7 +11,6 @@ import TTImp.TTImp import Data.String import Libraries.Data.VarSet - import Libraries.Data.List.SizeOf %default covering @@ -410,7 +409,7 @@ unelabNest mode nest env (Meta fc n i args) showNScope : List Name -> String showNScope [] = "[no locals in scope]" - showNScope ns = "[locals in scope: " ++ showSep ", " (map show (nub ns)) ++ "]" + showNScope ns = "[locals in scope: " ++ joinBy ", " (map show (nub ns)) ++ "]" showScope : List (Term vars) -> String showScope ts = " " ++ showNScope (mapMaybe toName ts) diff --git a/src/Yaffle/REPL.idr b/src/Yaffle/REPL.idr index 03a4f68585a..d5f74eb6057 100644 --- a/src/Yaffle/REPL.idr +++ b/src/Yaffle/REPL.idr @@ -20,6 +20,8 @@ import TTImp.Unelab import Parser.Source +import Data.String + %default covering showInfo : (Name, Int, GlobalDef) -> Core () @@ -101,13 +103,13 @@ process (Missing n_in) case isCovering tot of MissingCases cs => coreLift_ (putStrLn (show fn ++ ":\n" ++ - showSep "\n" (map show cs))) + joinBy "\n" (map show cs))) NonCoveringCall ns => coreLift_ (putStrLn (show fn ++ ": Calls non covering function" ++ case ns of [fn] => " " ++ show fn - _ => "s: " ++ showSep ", " (map show ns))) + _ => "s: " ++ joinBy ", " (map show ns))) _ => coreLift_ $ putStrLn (show fn ++ ": All cases covered")) (map fst ts) pure True From c119d1cb04acb24943f31a24e8ad2cd6fc186dd9 Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Mon, 2 Jun 2025 14:50:49 +0300 Subject: [PATCH 02/14] [ refactor ] ScopedSnocList: Swap Scope on SnocList (Phase 2) + Cherry-picked refactor from https://github.com/GulinSS/Idris2/pull/16 Co-authored-by: Viktor Yudov --- idris2api.ipkg | 1 + src/Compiler/ANF.idr | 57 +- src/Compiler/CaseOpts.idr | 54 +- src/Compiler/CompileExpr.idr | 141 ++-- src/Compiler/Inline.idr | 157 ++-- src/Compiler/LambdaLift.idr | 109 +-- src/Compiler/Opts/CSE.idr | 17 +- src/Compiler/Opts/ConstantFold.idr | 62 +- src/Compiler/Opts/Identity.idr | 27 +- src/Core/AutoSearch.idr | 42 +- src/Core/Case/CaseBuilder.idr | 749 ++++++++++-------- src/Core/Case/CaseTree.idr | 47 +- src/Core/Case/Util.idr | 2 +- src/Core/CompileExpr.idr | 149 ++-- src/Core/CompileExpr/Pretty.idr | 8 +- src/Core/Context.idr | 12 +- src/Core/Context/Pretty.idr | 6 +- src/Core/Core.idr | 8 +- src/Core/Coverage.idr | 60 +- src/Core/Env.idr | 212 +++-- src/Core/GetType.idr | 4 +- src/Core/LinearCheck.idr | 87 +- src/Core/Metadata.idr | 10 +- src/Core/Name.idr | 6 +- src/Core/Name/Scoped.idr | 132 ++- src/Core/Normalise.idr | 34 +- src/Core/Normalise/Convert.idr | 99 +-- src/Core/Normalise/Eval.idr | 122 +-- src/Core/Normalise/Quote.idr | 48 +- src/Core/Ord.idr | 4 +- src/Core/Primitives.idr | 2 +- src/Core/Reflect.idr | 124 +-- src/Core/SchemeEval/Compile.idr | 108 +-- src/Core/SchemeEval/Evaluate.idr | 52 +- src/Core/SchemeEval/Quote.idr | 16 +- src/Core/TT.idr | 68 +- src/Core/TT/Subst.idr | 46 +- src/Core/TT/Term.idr | 21 +- src/Core/TT/Term/Subst.idr | 11 +- src/Core/TT/Traversals.idr | 6 - src/Core/TT/Var.idr | 241 +++--- src/Core/TT/Views.idr | 10 +- src/Core/TTC.idr | 23 +- src/Core/Termination/CallGraph.idr | 18 +- src/Core/Termination/Positivity.idr | 10 +- src/Core/Transform.idr | 2 +- src/Core/Unify.idr | 176 ++-- src/Core/UnifyState.idr | 100 +-- src/Core/Value.idr | 31 +- src/Idris/Elab/Implementation.idr | 4 +- src/Idris/Elab/Interface.idr | 4 +- src/Idris/Error.idr | 4 +- src/Idris/IDEMode/Holes.idr | 2 +- src/Idris/Parser.idr | 2 +- src/Idris/REPL.idr | 8 +- src/Libraries/Data/List/Thin.idr | 53 +- src/Libraries/Data/NatSet.idr | 67 +- src/Libraries/Data/SnocList/Extra.idr | 18 +- src/Libraries/Data/SnocList/HasLength.idr | 9 +- .../Data/SnocList/Quantifiers/Extra.idr | 20 + src/Libraries/Data/SnocList/SizeOf.idr | 6 +- src/Libraries/Data/VarSet.idr | 8 +- src/Libraries/Data/VarSet/Core.idr | 6 +- src/TTImp/Elab/Ambiguity.idr | 4 +- src/TTImp/Elab/App.idr | 4 +- src/TTImp/Elab/Binders.idr | 12 +- src/TTImp/Elab/Case.idr | 32 +- src/TTImp/Elab/Check.idr | 46 +- src/TTImp/Elab/Delayed.idr | 6 +- src/TTImp/Elab/ImplicitBind.idr | 44 +- src/TTImp/Elab/Record.idr | 1 + src/TTImp/Elab/Rewrite.idr | 14 +- src/TTImp/Elab/RunElab.idr | 72 +- src/TTImp/Elab/Utils.idr | 47 +- src/TTImp/Impossible.idr | 4 +- src/TTImp/Interactive/CaseSplit.idr | 4 +- src/TTImp/Interactive/ExprSearch.idr | 38 +- src/TTImp/Interactive/Intro.idr | 2 + src/TTImp/Interactive/MakeLemma.idr | 4 +- src/TTImp/PartialEval.idr | 67 +- src/TTImp/ProcessData.idr | 12 +- src/TTImp/ProcessDecls.idr | 2 + src/TTImp/ProcessDef.idr | 50 +- src/TTImp/ProcessFnOpt.idr | 8 +- src/TTImp/ProcessParams.idr | 4 +- src/TTImp/ProcessRecord.idr | 10 +- src/TTImp/ProcessType.idr | 6 +- src/TTImp/Reflect.idr | 123 +-- src/TTImp/TTImp.idr | 4 +- src/TTImp/Unelab.idr | 37 +- src/TTImp/Utils.idr | 2 +- tests/idris2/basic/basic044/expected | 6 +- tests/idris2/data/data006/expected | 24 +- tests/idris2/data/record019/expected | 2 +- tests/idris2/evaluator/spec001/expected | 44 +- tests/idris2/perf/perf012/expected | 12 +- tests/idris2/reg/reg055_2/Declaration.idr | 4 + tests/idris2/reg/reg055_2/Main.idr | 10 + tests/idris2/reg/reg055_2/expected | 2 + tests/idris2/reg/reg055_2/run | 3 + tests/refc/callingConvention/expected | 212 ++--- 101 files changed, 2625 insertions(+), 2095 deletions(-) create mode 100644 src/Libraries/Data/SnocList/Quantifiers/Extra.idr create mode 100644 tests/idris2/reg/reg055_2/Declaration.idr create mode 100644 tests/idris2/reg/reg055_2/Main.idr create mode 100644 tests/idris2/reg/reg055_2/expected create mode 100644 tests/idris2/reg/reg055_2/run diff --git a/idris2api.ipkg b/idris2api.ipkg index bef1bfec1a4..59e73ba3133 100644 --- a/idris2api.ipkg +++ b/idris2api.ipkg @@ -198,6 +198,7 @@ modules = Libraries.Data.SnocList.HasLength, Libraries.Data.SnocList.LengthMatch, Libraries.Data.SnocList.SizeOf, + Libraries.Data.SnocList.Quantifiers.Extra, Libraries.Data.Span, Libraries.Data.SparseMatrix, Libraries.Data.String, diff --git a/src/Compiler/ANF.idr b/src/Compiler/ANF.idr index 13f072c6478..68d2e7af957 100644 --- a/src/Compiler/ANF.idr +++ b/src/Compiler/ANF.idr @@ -5,10 +5,13 @@ import Compiler.LambdaLift import Core.CompileExpr import Core.Context +import Data.SnocList.Quantifiers import Data.String import Data.SortedSet import Data.Vect +import Libraries.Data.SnocList.Extra + %default covering -- Convert the lambda lifted form to ANF, with variable names made explicit. @@ -137,6 +140,12 @@ Show ANFDef where AVars : Scope -> Type AVars = All (\_ => Int) +namespace AVars + public export + empty : AVars Scope.empty + empty = [<] + + data Next : Type where nextVar : {auto v : Ref Next Int} -> @@ -147,8 +156,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)) @@ -184,6 +193,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 (Scope.ext vars' args)) +bindAsFresh [] vs = pure ([], vs) +bindAsFresh (n :: ns) vs + = do i <- nextVar + mapFst (i ::) <$> bindAsFresh ns (vs :< i) + mutual anfArgs : {auto v : Ref Next Int} -> FC -> AVars vars -> @@ -206,7 +224,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) @@ -235,16 +253,8 @@ mutual anfConAlt : {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 : {auto v : Ref Next Int} -> AVars vars -> LiftedConstAlt vars -> Core AConstAlt @@ -255,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) AVars.empty + let vs : AVars args + := rewrite sym $ appendLinLeftNeutral args in + rewrite snocAppendAsFish Scope.empty args in vsNil + (iargs', vs) <- bindAsFresh (cast scope) vs + sc' <- anf (rewrite snocAppendAsFish args scope in vs) sc + pure $ MkAFun (iargs ++ 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 AVars.empty err) export freeVariables : ANF -> SortedSet AVar diff --git a/src/Compiler/CaseOpts.idr b/src/Compiler/CaseOpts.idr index be40e389eff..305dd015259 100644 --- a/src/Compiler/CaseOpts.idr +++ b/src/Compiler/CaseOpts.idr @@ -8,6 +8,8 @@ import Core.Context import Data.Vect import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra %default covering @@ -29,38 +31,38 @@ case t of shiftUnder : {args : _} -> {idx : _} -> - (0 p : IsVar n idx (x :: args ++ vars)) -> - NVar n (args ++ x :: vars) + (0 p : IsVar n idx (Scope.addInner vars (Scope.bind args x))) -> + NVar n (Scope.addInner (Scope.bind vars x) args) shiftUnder First = weakenNVar (mkSizeOf args) (MkNVar First) shiftUnder (Later p) = insertNVar (mkSizeOf args) (MkNVar p) shiftVar : {outer : Scope} -> {args : List Name} -> - NVar n (outer ++ (x :: args ++ vars)) -> - NVar n (outer ++ (args ++ x :: vars)) + NVar n ((vars <>< args :< x) ++ outer) -> + NVar n ((vars :< x <>< args) ++ outer) shiftVar nvar = let out = mkSizeOf outer in 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 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 : 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 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) @@ -84,34 +86,34 @@ mutual 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) + CExp (Scope.bind (Scope.ext vars args) old) -> + CExp (Scope.ext (Scope.bind vars new) args) liftOutLambda = shiftBinder {outer = Scope.empty} -- 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 (Scope.bind vars new))) tryLiftOut new [] = Just [] tryLiftOut new (MkConAlt n ci t args (CLam fc x sc) :: as) = do as' <- tryLiftOut new as @@ -121,7 +123,7 @@ tryLiftOut _ _ = Nothing tryLiftOutConst : (new : Name) -> List (CConstAlt vars) -> - Maybe (List (CConstAlt (new :: vars))) + Maybe (List (CConstAlt (Scope.bind vars new))) tryLiftOutConst new [] = Just [] tryLiftOutConst new (MkConstAlt c (CLam fc x sc) :: as) = do as' <- tryLiftOutConst new as @@ -131,7 +133,7 @@ tryLiftOutConst _ _ = Nothing tryLiftDef : (new : Name) -> Maybe (CExp vars) -> - Maybe (Maybe (CExp (new :: vars))) + Maybe (Maybe (CExp (Scope.bind vars new))) tryLiftDef new Nothing = Just Nothing tryLiftDef new (Just (CLam fc x sc)) = let sc' = liftOutLambda {args = []} new sc in @@ -310,8 +312,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/CompileExpr.idr b/src/Compiler/CompileExpr.idr index cd6e07463b6..8308ec4cdfb 100644 --- a/src/Compiler/CompileExpr.idr +++ b/src/Compiler/CompileExpr.idr @@ -9,11 +9,15 @@ import Core.Normalise import Core.Options import Core.Value -import Data.List.HasLength +import Data.SnocList +import Data.SnocList.Quantifiers import Data.Vect import Libraries.Data.NatSet import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.HasLength +import Libraries.Data.SnocList.Extra %default covering @@ -39,7 +43,7 @@ numArgs defs (Ref _ _ n) _ => pure (Arity 0) numArgs _ tm = pure (Arity 0) -weakenVar : Var ns -> Var (a :: ns) +weakenVar : Var ns -> Var (ns :< a) weakenVar (MkVar p) = (MkVar (Later p)) etaExpand : Int -> Nat -> CExp vars -> List (Var vars) -> CExp vars @@ -112,15 +116,21 @@ eraseConArgs arity epos fn args else dropPos epos fn' -- fn' might be lambdas, after eta expansion mkDropSubst : Nat -> NatSet -> - (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 + (vars : Scope) -> + (args : Scope) -> + (args' ** Thin (Scope.addInner vars args') (Scope.addInner vars args)) + -- (vars' ** Thin (Scope.ext vars' rest) (Scope.ext vars rest)) +mkDropSubst i es rest [<] = ([<] ** Refl) +mkDropSubst (S i) es rest (xs :< x) + = let (vs ** sub) = mkDropSubst i es rest xs in if i `elem` es then (vs ** Drop sub) - else (x :: vs ** Keep sub) + else (vs :< x ** Keep sub) +-- Next case can't happen if called with the right Nat from mkDropSubst +-- FIXME: rule it out with a type! +-- Dupe see: Libraries.Data.List.Thin.fromNatSet +-- Dupe see: Libraries.Data.NatSet.partition +mkDropSubst Z es rest (xs :< x) = let (vs ** sub) = mkDropSubst Z es rest xs in (vs ** Drop sub) -- See if the constructor is a special constructor type, e.g a nil or cons -- shaped thing. @@ -220,16 +230,24 @@ mutual DCon _ arity (Just pos) => conCases n ns -- skip it _ => do xn <- getFullName x let (args' ** sub) - = mkDropSubst 0 (eraseArgs gdef) vars args + = mkDropSubst (length args) (eraseArgs gdef) vars (cast args) + let subList = subThinList sub sc' <- toCExpTree n sc ns' <- conCases n ns 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' + then pure $ MkConAlt xn !(dconFlag xn) (Just tag) (toList args') (shrinkCExp subList sc') :: ns' + else pure $ MkConAlt xn !(dconFlag xn) Nothing (toList args') (shrinkCExp subList sc') :: ns' where dcon : Def -> Bool dcon (DCon {}) = True dcon _ = False + + subThinList : Thin (vars ++ args') (vars ++ ([<] <>< args)) -> Thin (vars <>< (args' <>> [])) (vars <>< args) + subThinList t = do rewrite fishAsSnocAppend vars (toList args') + rewrite castToList args' + rewrite fishAsSnocAppend vars args + t + conCases n (_ :: ns) = conCases n ns constCases : {vars : _} -> @@ -276,32 +294,40 @@ mutual if noworld -- just substitute the scrutinee into -- the RHS then - let (s, env) : (SizeOf args, SubstCEnv args vars) + let (s, env) : (SizeOf args, SubstCEnv (cast 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)) + sc' <- toCExpTree n sc + let sc'' : CExp (Scope.addInner vars (cast args)) + := rewrite sym $ fishAsSnocAppend vars args in sc' + 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)) + let (s, env) : (_, SubstCEnv (cast args) (vars :< MN "eff" 0)) = mkSubst 0 (CLocal fc First) pos args in do sc' <- toCExpTree n sc - let scope = insertNames {outer=args} + let sc'' : CExp (Scope.addInner vars (cast args)) + := rewrite sym $ fishAsSnocAppend vars args in sc' + + 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, Subst.empty) + Nat -> (args : List Name) -> (SizeOf args, SubstCEnv (cast args) vs) + mkSubst _ _ _ [] = (zero, Subst.empty {tm = CExp}) 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 [ @@ -322,8 +348,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 @@ -369,13 +395,8 @@ ArgList = HasLength mkArgList : Int -> (n : Nat) -> (ns ** ArgList n ns) mkArgList i Z = (_ ** Z) mkArgList i (S k) - = let (ns ** rec) = mkArgList (i + 1) k in - ((MN "arg" i) :: ns ** S rec) - --- TODO has quadratic runtime -getVars : ArgList k ns -> Vect k (Var ns) -getVars Z = [] -getVars (S rest) = first :: map weakenVar (getVars rest) + = let (ns ** rec) = mkArgList (i - 1) k in + (ns :< (MN "arg" (i - 1)) ** S rec) data NArgs : Type where User : Name -> List ClosedClosure -> NArgs @@ -392,8 +413,8 @@ getPArgs : {auto c : Ref Ctxt Defs} -> 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) @@ -406,7 +427,7 @@ getFieldArgs 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') @@ -459,7 +480,7 @@ nfToCFType _ (NBind fc _ _ _) True nfToCFType _ (NTCon fc n_in _ args) s = 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 (\ arg => nfToCFType fc arg s) nargs @@ -503,20 +524,20 @@ getCFTypes args t = pure (reverse args, !(nfToCFType (getLoc t) t False)) lamRHSenv : Int -> FC -> (ns : Scope) -> (SizeOf ns, SubstCEnv ns Scope.empty) -lamRHSenv i fc [] = (zero, Subst.empty) -lamRHSenv i fc (n :: ns) +lamRHSenv i fc [<] = (zero, Subst.empty {tm = CExp}) +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 -> Scope -getNewArgs [] = [] -getNewArgs (CRef _ n :: xs) = n :: getNewArgs xs -getNewArgs {done = x :: xs} (_ :: sub) = x :: getNewArgs sub +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 @@ -525,15 +546,15 @@ getNewArgs {done = x :: xs} (_ :: sub) = x :: getNewArgs sub lamRHS : (ns : Scope) -> CExp ns -> ClosedCExp lamRHS ns tm = let (s, env) = lamRHSenv 0 (getFC tm) ns - tmExp = substs s env (rewrite appendNilRightNeutral ns in tm) - newArgs = reverse $ getNewArgs env + tmExp = substs s env (rewrite appendLinLeftNeutral ns in tm) + newArgs = getNewArgs env bounds = mkBounds newArgs expLocs = mkLocals zero {vars = Scope.empty} bounds tmExp in lamBind (getFC tm) _ expLocs where lamBind : FC -> (ns : Scope) -> CExp ns -> ClosedCExp - lamBind fc [] tm = tm - lamBind fc (n :: ns) tm = lamBind fc ns (CLam fc n tm) + lamBind fc [<] tm = tm + lamBind fc (ns :< n) tm = lamBind fc ns (CLam fc n tm) toArgExp : (Var ns) -> CExp ns toArgExp (MkVar p) = CLocal emptyFC p @@ -548,22 +569,32 @@ toCDef n ty erased (PMDef pi args _ tree _) comptree <- toCExpTree n tree pure $ toLam (externalDecl pi) $ if isEmpty erased then MkFun args comptree - else MkFun args' (shrinkCExp p comptree) + else MkFun (cast args') (shrinkCExp p comptree) where toLam : Bool -> CDef -> CDef toLam True (MkFun args rhs) = MkFun Scope.empty (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 (toList $ getVars args))) + = let (ns ** args) = mkArgList (cast arity) arity in + pure $ MkFun _ (CExtPrim emptyFC !(getFullName n) (reverse $ map toArgExp (getVars args))) + where + -- TODO has quadratic runtime + getVars : ArgList k ns -> List (Var ns) + getVars Z = [] + getVars (S rest) = first :: map weakenVar (getVars rest) toCDef n ty _ (ForeignDef arity cs) = do defs <- get Ctxt (atys, retty) <- getCFTypes [] !(nf defs Env.empty 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))) + = let (ns ** args) = mkArgList (cast arity) arity in + pure $ MkFun _ (COp emptyFC op (reverse $ map toArgExp (getVars args))) + where + -- TODO has quadratic runtime + getVars : ArgList k ns -> Vect k (Var ns) + getVars Z = [] + getVars (S rest) = first :: map weakenVar (getVars rest) toCDef n _ _ (DCon tag arity pos) = do let nt = snd <$> pos diff --git a/src/Compiler/Inline.idr b/src/Compiler/Inline.idr index fe8530ebb25..45c24df5979 100644 --- a/src/Compiler/Inline.idr +++ b/src/Compiler/Inline.idr @@ -10,24 +10,32 @@ import Core.Context.Log import Core.Hash import Core.Options -import Data.List.Quantifiers +import Data.SnocList +import Data.SnocList.Quantifiers import Data.Vect -import Libraries.Data.List.LengthMatch import Libraries.Data.NameMap import Libraries.Data.WithDefault import Libraries.Data.List.SizeOf +import Libraries.Data.List.LengthMatch +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra %default covering +public export EEnv : Scope -> Scope -> Type EEnv free = All (\_ => CExp free) -extend : EEnv free vars -> (args : List (CExp free)) -> (args' : List Name) -> - LengthMatch args args' -> EEnv free (Scope.addInner vars args') +namespace EEnv + public export + empty : EEnv free Scope.empty + empty = [<] + +extend : EEnv free vars -> (args : List Name) -> (args' : List (CExp free)) -> + LengthMatch args args' -> EEnv free (Scope.ext vars args) extend env [] [] NilMatch = env -extend env (a :: xs) (n :: ns) (ConsMatch w) - = a :: extend env xs ns w +extend env (_ :: ns) (v :: vs) (ConsMatch w) = extend (env :< v) ns vs w Stack : Scoped Stack vars = List (CExp vars) @@ -45,13 +53,28 @@ getArity (MkCon _ arity _) = arity getArity (MkForeign _ args _) = length args getArity (MkError _) = 0 +getArgsFromStack : Stack free -> (args : Scope) -> + List (CExp free) -> + Maybe (List (CExp free), Stack free) +getArgsFromStack (e :: es) (as :< a) acc + = getArgsFromStack es as (e :: acc) +getArgsFromStack stk [<] acc = Just (acc, stk) +getArgsFromStack _ _ _ = Nothing + +takeArgs : EEnv free vars -> List (CExp free) -> (args : Scope) -> + Maybe (EEnv free (Scope.addInner vars args)) +takeArgs env (e :: es) (as :< a) + = do env' <- takeArgs env es as + pure (env' :< e) +takeArgs env stk [<] = pure env +takeArgs env [] args = Nothing + takeFromStack : EEnv free vars -> Stack free -> (args : Scope) -> Maybe (EEnv free (Scope.addInner vars args), 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 +takeFromStack env es as + = do (args, stk') <- getArgsFromStack es as [] + env' <- takeArgs env args as + pure (env', stk') data LVar : Type where @@ -62,7 +85,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 @@ -101,7 +124,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 : _} -> @@ -114,15 +137,15 @@ 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 (Scope.addInner free vars)) -> Core (CExp free) - evalLocal {vars = []} fc rec stk env p + evalLocal {vars = [<]} fc rec stk env p = pure $ unload stk (CLocal fc p) - evalLocal {vars = x :: xs} fc rec stk (v :: env) First + evalLocal {vars = xs :< x} fc rec stk (env :< v) First = case stk of [] => pure v _ => eval rec env stk (weakenNs (mkSizeOf xs) v) - evalLocal {vars = x :: xs} fc rec stk (_ :: env) (Later p) + evalLocal {vars = xs :< x} fc rec stk (env :< _) (Later p) = evalLocal fc rec stk env p tryApply : {vars, free : _} -> @@ -133,9 +156,7 @@ mutual tryApply {free} {vars} rec stk env (MkFun args exp) = do let Just (env', stk') = takeFromStack env stk args | Nothing => pure Nothing - res <- eval rec env' stk' - (rewrite sym (appendAssociative args vars free) in - embed {outer = vars ++ free} exp) + res <- eval rec env' stk' (embed $ embed exp) pure (Just res) tryApply rec stk env _ = pure Nothing @@ -143,7 +164,7 @@ mutual {auto c : Ref Ctxt Defs} -> {auto l : Ref LVar Int} -> List Name -> -- TODO should be a set - EEnv free vars -> Stack free -> CExp (vars ++ free) -> + EEnv free vars -> Stack free -> CExp (Scope.addInner free vars) -> Core (CExp free) eval rec env stk (CLocal fc p) = evalLocal fc rec stk env p -- This is hopefully a temporary hack, giving a special case for io_bind. @@ -158,7 +179,7 @@ mutual 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 EEnv.empty [] (CApp fc cont [CRef fc xn, world]) pure $ unload stk $ CLet fc xn NotInline (CApp fc act [world]) @@ -167,7 +188,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 EEnv.empty [] (CApp fc cont [CRef fc xn, world]) pure $ CLam fc wn $ refToLocal wn wn $ CLet fc xn NotInline (CApp fc act [world]) @@ -189,12 +210,12 @@ mutual 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 + sc' <- eval rec (env :< CRef fc xn) [] 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) @@ -203,9 +224,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) @@ -227,7 +248,7 @@ mutual = pure $ unload stk $ CExtPrim fc p !(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 EEnv.empty 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)) @@ -241,14 +262,14 @@ mutual def' where updateLoc : {idx, vs : _} -> - (0 p : IsVar x idx (vs ++ free)) -> + (0 p : IsVar x idx (Scope.addInner 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 (Scope.addInner free vs) -> EEnv free vs -> CExp free -> EEnv free vs update (CLocal _ p) env sc = updateLoc p env sc update _ env _ = env @@ -263,30 +284,38 @@ mutual 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 l : Ref LVar Int} -> FC -> EEnv free vars -> (args' : List Name) -> - Core (Bounds args', EEnv free (args' ++ vars)) + Core (Bounds (cast args'), EEnv free (Scope.ext 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') + let env' = env :< CRef fc xn + (bs', env'') <- 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 (Scope.addInner 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 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 Scope.empty 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 (Scope.addInner free vars) -> Core (CConstAlt free) evalConstAlt rec env stk (MkConstAlt c sc) = MkConstAlt c <$> eval rec env stk sc @@ -295,21 +324,20 @@ 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 (Scope.addInner free vars)) -> + Maybe (CExp (Scope.addInner 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 + = + 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 + do let env' = extend env args' args m pure $ Just !(eval rec env' stk - (rewrite sym (appendAssociative args' vars free) in - sc)) + (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 @@ -322,8 +350,8 @@ 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 (Scope.addInner free vars)) -> + Maybe (CExp (Scope.addInner free vars)) -> Core (Maybe (CExp free)) pickConstAlt rec env stk (CPrimVal fc c) [] def = traverseOpt (eval rec env stk) def @@ -409,22 +437,22 @@ 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 (Scope.addInner args done) -> + (args' ** (SizeOf args', SubstCEnv args' args, CExp (Scope.addInner 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) -- TODO `getNewArgs` is always used in reverse, revisit! getNewArgs : {done : _} -> SubstCEnv done args -> Scope -getNewArgs [] = [] -getNewArgs (CRef _ n :: xs) = n :: getNewArgs xs -getNewArgs {done = x :: xs} (_ :: sub) = x :: getNewArgs sub +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 @@ -432,11 +460,10 @@ getNewArgs {done = x :: xs} (_ :: sub) = x :: getNewArgs sub -- not the highest, as you'd expect if they were all lambdas). mergeLambdas : (args : Scope) -> CExp args -> (args' ** CExp args') mergeLambdas args (CLam fc x sc) - = let (args' ** (s, env, exp')) = getLams zero 0 Subst.empty (CLam fc x sc) + = let (args' ** (s, env, exp')) = getLams zero 0 (Subst.empty {tm = CExp}) (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 + newArgs = getNewArgs env + expLocs = refsToLocals (mkBounds newArgs) expNs in (_ ** expLocs) mergeLambdas args exp = (args ** exp) @@ -449,7 +476,7 @@ doEval : {args : _} -> doEval n exp = do l <- newRef LVar (the Int 0) log "compiler.inline.eval" 10 (show n ++ ": " ++ show exp) - exp' <- eval [] [] [] exp + exp' <- eval [] EEnv.empty [] exp log "compiler.inline.eval" 10 ("Inlined: " ++ show exp') pure exp' diff --git a/src/Compiler/LambdaLift.idr b/src/Compiler/LambdaLift.idr index d6e2b8b1a40..20c998fd16e 100644 --- a/src/Compiler/LambdaLift.idr +++ b/src/Compiler/LambdaLift.idr @@ -15,8 +15,10 @@ import Core.Context import Data.String import Data.Vect +import Data.SnocList.Operations import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra %default covering @@ -92,7 +94,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 (Scope.bind vars x)) -> Lifted vars ||| Use of a constructor to construct a compound data type value. ||| @@ -187,7 +189,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 (Scope.ext vars args)) -> LiftedConAlt vars ||| A branch of an "LConst" (constant expression) case statement. @@ -364,19 +366,34 @@ lengthDistributesOverAppend [] ys = Refl lengthDistributesOverAppend (x :: xs) ys = cong S $ lengthDistributesOverAppend xs ys -weakenUsed : {outer : _} -> Used vars -> Used (outer ++ vars) +weakenUsed : {outer : _} -> Used vars -> Used (Scope.addInner vars outer) weakenUsed {outer} (MkUsed xs) = - MkUsed (rewrite lengthDistributesOverAppend outer vars in - (replicate (length outer) False ++ xs)) - -contractUsed : (Used (x::vars)) -> Used vars + MkUsed (rewrite lengthHomomorphism vars outer in + rewrite plusCommutative (length vars) (length outer) in + replicate (length outer) False ++ xs) + +weakenUsedFish : {outer : _} -> Used vars -> Used (Scope.ext vars outer) +weakenUsedFish {outer} (MkUsed xs) = + do rewrite fishAsSnocAppend vars outer + MkUsed $ do rewrite lengthHomomorphism vars (cast outer) + rewrite Extra.lengthDistributesOverFish [<] outer + rewrite plusCommutative (length vars) (length outer) + replicate (length outer) False ++ xs + +contractUsed : (Used (Scope.bind vars x)) -> Used vars contractUsed (MkUsed xs) = MkUsed (tail xs) contractUsedMany : {remove : _} -> - (Used (remove ++ vars)) -> + (Used (Scope.addInner 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) -> @@ -386,12 +403,6 @@ markUsed : {vars : _} -> markUsed {vars} {prf} idx (MkUsed us) = let newUsed = replaceAt (finIdx prf) True us in MkUsed newUsed - where - finIdx : {vars : _} -> {idx : _} -> - (0 prf : IsVar x idx vars) -> - Fin (length vars) - finIdx {idx=Z} First = FZ - finIdx {idx=S x} (Later l) = FS (finIdx l) getUnused : Used vars -> Vect (length vars) Bool @@ -401,9 +412,9 @@ total dropped : (vars : Scope) -> (drop : Vect (length vars) Bool) -> Scope -dropped [] _ = [] -dropped (x::xs) (False::us) = x::(dropped xs us) -dropped (x::xs) (True::us) = dropped xs us +dropped [<] _ = Scope.empty +dropped (xs :< x) (False::us) = dropped xs us :< x +dropped (xs :< x) (True::us) = dropped xs us usedVars : {vars : _} -> {auto l : Ref Lifts LDefs} -> @@ -435,7 +446,7 @@ usedVars used (LConCase fc sc alts def) = usedConAlt : {default Nothing lazy : Maybe LazyReason} -> 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 @@ -453,22 +464,22 @@ dropIdx : {vars : _} -> {idx : _} -> (outer : Scope) -> (unused : Vect (length vars) Bool) -> - (0 p : IsVar x idx (outer ++ vars)) -> - Var (outer ++ (dropped vars unused)) -dropIdx [] (False::_) First = first -dropIdx [] (True::_) First = assert_total $ + (0 p : IsVar x idx (Scope.addInner vars outer)) -> + Var (Scope.addInner (dropped vars unused) outer) +dropIdx [<] (False::_) First = first +dropIdx [<] (True::_) First = assert_total $ idris_crash "INTERNAL ERROR: Referenced variable marked as unused" -dropIdx [] (False::rest) (Later p) = Var.later $ dropIdx Scope.empty rest p -dropIdx [] (True::rest) (Later p) = dropIdx Scope.empty rest p -dropIdx (_::xs) unused First = first -dropIdx (_::xs) unused (Later p) = Var.later $ dropIdx xs unused p +dropIdx [<] (False::rest) (Later p) = Var.later $ dropIdx Scope.empty rest p +dropIdx [<] (True::rest) (Later p) = dropIdx Scope.empty rest p +dropIdx (xs :< _) unused First = first +dropIdx (xs :< _) unused (Later p) = Var.later $ dropIdx xs unused p dropUnused : {vars : _} -> {auto _ : Ref Lifts LDefs} -> {outer : Scope} -> (unused : Vect (length vars) Bool) -> - (l : Lifted (outer ++ vars)) -> - Lifted (outer ++ (dropped vars unused)) + (l : Lifted (Scope.addInner vars outer)) -> + Lifted (Scope.addInner (dropped vars unused) outer) dropUnused _ (LPrimVal fc val) = LPrimVal fc val dropUnused _ (LErased fc) = LErased fc dropUnused _ (LCrash fc msg) = LCrash fc msg @@ -479,7 +490,7 @@ dropUnused unused (LCon fc n ci tag args) = 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 @@ -501,18 +512,24 @@ dropUnused {vars} {outer} unused (LConCase fc sc alts def) = 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 (Scope.addInner vars outer) -> + LiftedConAlt (Scope.addInner (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 (Scope.addInner vars outer) -> + LiftedConstAlt (Scope.addInner (dropped vars unused) outer) dropConstCase (MkLConstAlt c val) = MkLConstAlt c (dropUnused unused val) mutual @@ -521,8 +538,8 @@ mutual {doLazyAnnots : Bool} -> {default Nothing lazy : Maybe LazyReason} -> FC -> (bound : Scope) -> - CExp (bound ++ vars) -> Core (Lifted vars) - makeLam fc bound (CLam _ x sc') = makeLam fc {doLazyAnnots} {lazy} (x :: bound) sc' + CExp (Scope.addInner 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 @@ -536,18 +553,16 @@ mutual pure $ LUnderApp fc n (length bound) (allVars fc vars unused) where - allPrfs : (vs : Scope) -> SizeOf seen -> - (unused : Vect (length vs) Bool) -> - List (Var (seen <>> vs)) - allPrfs [] _ _ = [] - allPrfs (v :: vs) p (False::uvs) = mkVarChiply p :: allPrfs vs (p :< _) uvs - allPrfs (v :: vs) p (True::uvs) = allPrfs vs (p :< _) uvs + allPrfs : (vs : Scope) -> (unused : Vect (length vs) Bool) -> List (Var vs) + allPrfs [<] _ = [] + allPrfs (vs :< v) (False::uvs) = 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 : Scope) -> (unused : Vect (length vs) Bool) -> List (Lifted vs) - allVars fc vs unused = map (\ (MkVar p) => LLocal fc p) (allPrfs vs [<] unused) + allVars fc vs unused = map (\ (MkVar p) => LLocal fc p) (allPrfs vs unused) -- if doLazyAnnots = True then annotate function application with laziness -- otherwise use old behaviour (thunk is a function) diff --git a/src/Compiler/Opts/CSE.idr b/src/Compiler/Opts/CSE.idr index 3d35ee6156b..d5e6bc3f989 100644 --- a/src/Compiler/Opts/CSE.idr +++ b/src/Compiler/Opts/CSE.idr @@ -37,7 +37,7 @@ import Data.SortedMap import Data.Vect import Libraries.Data.Erased -import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf ||| Maping from a pairing of closed terms together with ||| their size (for efficiency) to the number of @@ -117,7 +117,7 @@ store sz exp = dropVar : SizeOf inner -> {n : Nat} - -> (0 p : IsVar x n (inner ++ outer)) + -> (0 p : IsVar x n (Scope.addInner outer inner)) -> Maybe (Erased (IsVar x n inner)) dropVar inn p = case locateIsVar inn p of Left p => Just p @@ -131,7 +131,7 @@ dropVar inn p = case locateIsVar inn p of Drop tm = {0 inner, outer : Scope} -> SizeOf inner -> - tm (inner ++ outer) -> + tm (Scope.addInner outer inner) -> Maybe (tm inner) @@ -167,8 +167,15 @@ mutual dropConAlt : Drop CConAlt dropConAlt inn (MkConAlt x y tag args z) = MkConAlt x y tag args <$> - dropCExp (mkSizeOf args + inn) - (replace {p = CExp} (appendAssociative args inner outer) z) + rewrite fishAsSnocAppend inner args in + dropCExp + (inn + mkSizeOf (cast args)) + (replace {p = CExp} rule z) + where + rule : (outer ++ inner) <>< args = outer ++ (inner ++ (cast args)) + rule = do rewrite appendAssociative outer inner (cast args) + rewrite fishAsSnocAppend (outer ++ inner) args + Builtin.Refl dropConstAlt : Drop CConstAlt dropConstAlt inn (MkConstAlt x y) = MkConstAlt x <$> dropCExp inn y diff --git a/src/Compiler/Opts/ConstantFold.idr b/src/Compiler/Opts/ConstantFold.idr index 4c038ab0e75..142118e4c6b 100644 --- a/src/Compiler/Opts/ConstantFold.idr +++ b/src/Compiler/Opts/ConstantFold.idr @@ -4,10 +4,12 @@ import Core.CompileExpr import Core.Context.Log import Core.Primitives import Core.Value + import Data.Vect +import Data.SnocList -import Data.List.HasLength import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf findConstAlt : Constant -> List (CConstAlt vars) -> @@ -25,39 +27,49 @@ foldableOp (Cast from to) = isJust (intKind from) && isJust (intKind to) foldableOp _ = True -data Subst : Scope -> Scoped where - Nil : Subst Scope.empty vars - (::) : CExp vars -> Subst ds vars -> Subst (d :: ds) vars - Wk : SizeOf ws -> Subst ds vars -> Subst (ws ++ ds) (ws ++ vars) +data Subst : Scope -> Scope -> Type where + Lin : Subst Scope.empty vars + (:<) : Subst ds vars -> CExp vars -> Subst (Scope.bind ds d) vars + Wk : Subst ds vars -> SizeOf ws -> Subst (Scope.addInner ds ws) (Scope.addInner vars ws) namespace Subst public export empty : Subst Scope.empty vars - empty = [] + empty = [<] + + public export + bind : Subst ds vars -> CExp vars -> Subst (Scope.bind ds d) vars + bind = (:<) initSubst : (vars : Scope) -> Subst vars vars -initSubst [] = Subst.empty +initSubst [<] = Subst.empty initSubst vars - = rewrite sym $ appendNilRightNeutral vars in - Wk (mkSizeOf vars) Subst.empty - -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 + = rewrite sym $ appendLinLeftNeutral vars in + Wk Subst.empty (mkSizeOf vars) + +wk : SizeOf out -> Subst ds vars -> Subst (Scope.addInner ds out) (Scope.addInner vars out) +wk sout (Wk {ws, ds, vars} rho sws) + = rewrite sym $ appendAssociative ds ws out in + rewrite sym $ appendAssociative vars ws out in + Wk rho (sws + sout) +wk ws rho = Wk rho ws + +wksN : Subst ds vars -> SizeOf out -> Subst (Scope.ext ds out) (Scope.ext vars out) +wksN s s' + = rewrite fishAsSnocAppend ds out in + rewrite fishAsSnocAppend vars out in + wk (zero <>< s') s record WkCExp (vars : Scope) where constructor MkWkCExp {0 outer, supp : Scope} size : SizeOf outer - 0 prf : vars === outer ++ supp + 0 prf : vars === Scope.addInner 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 @@ -68,13 +80,13 @@ 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 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 @@ -101,7 +113,7 @@ constFold rho (CLam fc x y) constFold rho (CLet fc x inl y z) = let val := constFold rho y in case replace val of - True => constFold (val::rho) z + True => constFold (Subst.bind rho val) z False => case constFold (wk (mkSizeOf (Scope.single x)) rho) z of CLocal {idx = 0} _ _ => val body => CLet fc x inl val body @@ -163,7 +175,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 714a99b332a..04783ba73f5 100644 --- a/src/Compiler/Opts/Identity.idr +++ b/src/Compiler/Opts/Identity.idr @@ -2,17 +2,28 @@ module Compiler.Opts.Identity import Core.CompileExpr import Core.Context.Log + import Data.Vect +import Data.SnocList import Libraries.Data.List.SizeOf -makeArgs : (args : Scope) -> List (Var (args ++ vars)) -makeArgs args = embed @{ListFreelyEmbeddable} (Var.allVars args) +makeArgs : (args : Scope) -> List (Var (Scope.addInner vars args)) +makeArgs args = makeArgs' args id + where + makeArgs' : (args : Scope) -> (Var (Scope.addInner vars args) -> a) -> List a + makeArgs' [<] f = [] + makeArgs' (xs :< x) f = f first :: makeArgs' xs (f . weaken) + +makeArgz : (args : List Name) -> List (Var (Scope.ext vars args)) +makeArgz args + = embedFishily @{ListFreelyEmbeddable} + $ reverse $ Var.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 (Scope.bind vars x)) isUnsucc var (COp _ (Sub _) [CLocal _ p, CPrimVal _ c]) = if var == MkVar p then Just (c, first) @@ -81,8 +92,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,9 +124,9 @@ calcIdentity fn (MkFun args exp) = checkIdentity fn (Var.allVars args) exp Z calcIdentity _ _ = Nothing getArg : FC -> Nat -> (args : Scope) -> Maybe (CExp args) -getArg _ _ [] = Nothing -getArg fc Z (a :: _) = Just $ CLocal fc First -getArg fc (S k) (_ :: as) = weaken <$> getArg fc k as +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/Core/AutoSearch.idr b/src/Core/AutoSearch.idr index 6668e69e074..1b6b12e9d8e 100644 --- a/src/Core/AutoSearch.idr +++ b/src/Core/AutoSearch.idr @@ -8,9 +8,11 @@ import Core.Value import Data.Either import Data.Maybe +import Data.SnocList import Libraries.Data.NatSet import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf import Libraries.Data.WithDefault %default covering @@ -200,17 +202,17 @@ getUsableEnv : FC -> RigCount -> SizeOf done -> Env Term vars -> -- TODO this will be `vars <>< done` after refactoring - List (Term (done ++ vars), Term (done ++ vars)) -getUsableEnv fc rigc p [] = [] -getUsableEnv {vars = v :: vs} {done} fc rigc p (b :: env) - = let rest = getUsableEnv fc rigc (sucR p) env in + List (Term (Scope.addInner vars done), Term (Scope.addInner vars done)) +getUsableEnv fc rigc p [<] = [] +getUsableEnv {vars = vs :< v} {done} fc rigc p (env :< b) + = let rest = getUsableEnv fc rigc (sucL 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 (Scope.single v) vs in - weakenNs (sucR p) (binderType b)) :: - rewrite appendAssociative done (Scope.single v) vs in rest - else rewrite appendAssociative done (Scope.single v) vs in rest + rewrite sym (appendAssociative vs (Scope.single v) done) in + weakenNs (sucL p) (binderType b)) :: + rewrite sym (appendAssociative vs (Scope.single v) done) in rest + else rewrite sym (appendAssociative vs (Scope.single v) done) in rest -- A local is usable if it contains no holes in a determining argument position usableLocal : {vars : _} -> @@ -224,7 +226,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 @@ -271,9 +273,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) = Env.bind (clearEnvType p fc env) b clearEnv : Term vars -> Env Term vars -> Env Term vars clearEnv (Local fc _ idx p) env @@ -315,7 +317,7 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env (prf, ty) targe 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) Env.empty top Nothing)) pure @@ -389,7 +391,7 @@ searchName fc rigc defaults trying depth def top env target (n, ndef) let ty = type ndef when (isErased ty) $ - throw (CantSolveGoal fc (gamma defs) [] top Nothing) + throw (CantSolveGoal fc (gamma defs) Env.empty top Nothing) nty <- nf defs env (embed ty) logNF "auto" 10 ("Searching Name " ++ show n) env nty @@ -459,7 +461,7 @@ concreteDets {vars} fc defaults env top pos dets (arg :: args) concrete defs scnf False concrete defs (NTCon nfc n a args) atTop = do sd <- getSearchData nfc False n - let args' = NatSet.take (detArgs sd) args + let args' = NatSet.take (detArgs sd) (cast {to = List (FC, Closure vars)} args) traverse_ (\ parg => do argnf <- evalClosure defs parg concrete defs argnf False) (map snd args') concrete defs (NDCon nfc n t a args) atTop @@ -487,19 +489,19 @@ checkConcreteDets fc defaults env top (NTCon tfc tyn 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 () @@ -518,11 +520,11 @@ abandonIfCycle env tm (ty :: tys) 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)) + (Env.bind 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)) + (Env.bind env b) sc)) searchType {vars} fc rigc defaults trying depth def checkdets top env target = do defs <- get Ctxt abandonIfCycle env target trying diff --git a/src/Core/Case/CaseBuilder.idr b/src/Core/Case/CaseBuilder.idr index 2cbd3869da3..38d3b48a713 100644 --- a/src/Core/Case/CaseBuilder.idr +++ b/src/Core/Case/CaseBuilder.idr @@ -11,20 +11,22 @@ import Core.Value import Idris.Pretty.Annotations import Data.DPair -import Data.List.Quantifiers +import Data.SnocList.Quantifiers import Data.SortedSet import Data.String import Data.Vect -import Libraries.Data.IMaybe -import Libraries.Data.List.SizeOf +import Data.List.HasLength + import Libraries.Data.List.LengthMatch import Libraries.Data.List01 import Libraries.Data.List01.Quantifiers +import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.Quantifiers.Extra as Lib +import Libraries.Data.SnocList.SizeOf +import Libraries.Text.PrettyPrint.Prettyprinter import Decidable.Equality -import Libraries.Text.PrettyPrint.Prettyprinter - %default covering %hide Symbols.equals @@ -95,7 +97,17 @@ NamedPats always have the same 'Elem' proof, though this isn't expressed in a type anywhere. -} -data NamedPats : List Name -> -- the pattern variables still to process, in order +-- TODO: All +-- NamedPats : List Name -> -- the pattern variables still to process, +-- -- in order +-- Scoped +-- NamedPats vars +-- = All (\pvar => 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 +data NamedPats : List Name -> -- the pattern variables still to process, + -- in order Scoped where Nil : NamedPats [] vars (::) : PatInfo pvar vars -> @@ -134,21 +146,21 @@ substInPatInfo : {pvar, vars, todo : _} -> FC -> Name -> Term vars -> PatInfo pvar vars -> NamedPats todo vars -> Core (PatInfo pvar vars, NamedPats todo vars) -substInPatInfo fc n tm p ps +substInPatInfo {pvar} {vars} fc n tm p ps = case argType p of Known c ty => do defs <- get Ctxt - tynf <- nf defs (mkEnv fc vars) ty + tynf <- nf defs (mkEnv fc _) ty case tynf of - NApp {} => - pure ({ argType := Known c (substName n tm ty) } p, ps) + NApp _ _ _ => + 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 @@ -169,13 +181,13 @@ substInPats fc n tm (p :: ps) pure (p' :: !(substInPats fc n tm ps')) getPat : {idx : Nat} -> - (0 el : IsVar nm idx ps) -> NamedPats ps ns -> PatInfo nm ns + (0 el : IsVarL nm idx ps) -> NamedPats ps ns -> PatInfo nm ns getPat First (x :: xs) = x getPat (Later p) (x :: xs) = getPat p xs dropPat : {idx : Nat} -> - (0 el : IsVar nm idx ps) -> - NamedPats ps ns -> NamedPats (dropIsVar ps el) ns + (0 el : IsVarL nm idx ps) -> + NamedPats ps ns -> NamedPats (dropIsVarL ps el) ns dropPat First (x :: xs) = xs dropPat (Later p) (x :: xs) = x :: dropPat p xs @@ -216,8 +228,13 @@ 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) + weaken (MkInfo p el fty) = MkInfo p (Later el) (weaken fty) Weaken (NamedPats todo) where weaken [] = [] @@ -226,6 +243,27 @@ Weaken (NamedPats todo) where weakenNs ns [] = [] weakenNs ns (p :: ps) = weakenNs ns p :: weakenNs ns ps +FreelyEmbeddable (PatInfo p) where + +FreelyEmbeddable (NamedPats todo) where + embed [] = [] + embed (x :: xs) = embed x :: embed xs + +FreelyEmbeddable ArgType where + embed Unknown = Unknown + embed (Stuck t) = Stuck (embed t) + embed (Known c t) = Known c (embed t) + +GenWeaken (PatInfo p) where + genWeakenNs p q (MkInfo pat loc at) = do + let MkNVar loc' = genWeakenNs p q $ MkNVar loc + let at' = genWeakenNs p q at + MkInfo pat loc' at' + +GenWeaken (NamedPats todo) where + genWeakenNs p q [] = [] + genWeakenNs p q (pi :: np) = genWeakenNs p q pi :: genWeakenNs p q np + (++) : NamedPats ms vars -> NamedPats ns vars -> NamedPats (ms ++ ns) vars (++) [] ys = ys (++) (x :: xs) ys = x :: xs ++ ys @@ -257,42 +295,34 @@ HasNames (PatClause todo vars) where resolved gam (MkPatClause ns nps i rhs) = [| MkPatClause (traverse (resolved gam) ns) (resolved gam nps) (pure i) (resolved gam rhs) |] -0 IsConClause : PatClause (a :: todo) vars -> Type -IsConClause (MkPatClause _ (MkInfo pat _ _ :: _) _ _) = IsConPat pat - substInClause : {a, vars, todo : _} -> {auto c : Ref Ctxt Defs} -> - FC -> Subset (PatClause (a :: todo) vars) IsConClause -> - Core (Subset (PatClause (a :: todo) vars) IsConClause) -substInClause fc (Element (MkPatClause pvars (MkInfo pat pprf fty :: pats) pid rhs) isCons) + FC -> PatClause (a :: todo) vars -> + Core (PatClause (a :: todo) vars) +substInClause {vars} {a} fc (MkPatClause pvars (MkInfo pat pprf fty :: pats) pid rhs) = do pats' <- substInPats fc a (mkTerm vars pat) pats - pure $ Element (MkPatClause pvars (MkInfo pat pprf fty :: pats') pid rhs) isCons + pure (MkPatClause pvars (MkInfo pat pprf fty :: pats') pid rhs) -data Partitions : List01 ne (PatClause (a :: todo) vars) -> Type where - ConClauses : {a, todo, vars : _} -> - {ps : List01 ne (PatClause (a :: todo) vars)} -> - (cs : List01 True (PatClause (a :: todo) vars )) -> - (0 isCons : All IsConClause cs) => +data Partitions : List (PatClause todo vars) -> Type where + ConClauses : {todo, vars, ps : _} -> + (cs : List (PatClause todo vars)) -> Partitions ps -> Partitions (cs ++ ps) - VarClauses : {a, todo, vars : _} -> - {ps : List01 ne (PatClause (a :: todo) vars)} -> - (vs : List01 True (PatClause (a :: todo) vars)) -> + VarClauses : {todo, vars, ps : _} -> + (vs : List (PatClause todo vars)) -> Partitions ps -> Partitions (vs ++ ps) NoClauses : Partitions [] covering {ps : _} -> Show (Partitions ps) where show (ConClauses cs rest) - = unlines ("CON" :: map ((" " ++) . show) (forget cs)) + = unlines ("CON" :: map ((" " ++) . show) cs) ++ "\n, " ++ show rest show (VarClauses vs rest) - = unlines ("VAR" :: map ((" " ++) . show) (forget vs)) + = unlines ("VAR" :: map ((" " ++) . show) vs) ++ "\n, " ++ show rest show NoClauses = "NONE" -data ClauseType : PatClause (a :: todo) vars -> Type where - ConClause : (0 isCon : IsConClause p) => ClauseType p - VarClause : ClauseType p +data ClauseType = ConClause | VarClause namesIn : List Name -> Pat -> Bool namesIn pvars (PAs _ n p) = (n `elem` pvars) && namesIn pvars p @@ -312,54 +342,55 @@ namesFrom (PDelay _ _ t p) = namesFrom t ++ namesFrom p namesFrom (PLoc _ n) = [n] namesFrom _ = [] -clauseType : Phase -> (p : PatClause (a :: as) vars) -> ClauseType p +clauseType : Phase -> PatClause (a :: as) vars -> 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 -- also treat it as a variable -- Or, if it's an under-applied constructor then do NOT attempt to split on it! clauseType phase (MkPatClause pvars (MkInfo arg _ ty :: rest) pid rhs) - = maybe VarClause (\isCon => ConClause @{isCon}) $ getClauseType phase arg ty + = getClauseType phase arg ty where -- used when we are tempted to split on a constructor: is -- this actually a fully applied one? - splitCon : Nat -> List Pat -> Maybe (So True) - splitCon arity xs = toMaybe (arity == length xs) Oh + splitCon : Nat -> SnocList Pat -> ClauseType + splitCon arity xs + = if arity == length xs then ConClause else VarClause -- used to get the remaining clause types - clauseType' : (p : Pat) -> Maybe (IsConPat p) + clauseType' : Pat -> ClauseType clauseType' (PCon _ _ _ a xs) = splitCon a xs clauseType' (PTyCon _ _ a xs) = splitCon a xs - clauseType' (PConst _ x) = Just Oh - clauseType' (PArrow _ _ s t) = Just Oh - clauseType' (PDelay {}) = Just Oh - clauseType' _ = Nothing + clauseType' (PConst _ x) = ConClause + clauseType' (PArrow _ _ s t) = ConClause + clauseType' (PDelay _ _ _ _) = ConClause + clauseType' _ = VarClause - getClauseType : Phase -> (p : Pat) -> ArgType vars -> Maybe (IsConPat p) + getClauseType : Phase -> Pat -> ArgType vars -> ClauseType getClauseType (CompileTime cr) (PCon _ _ _ a xs) (Known r t) = if (isErased r && not (isErased cr) && all (namesIn (pvars ++ concatMap namesFrom (getPatInfo rest))) xs) - then Nothing + then VarClause else splitCon a xs getClauseType phase (PAs _ _ p) t = getClauseType phase p t getClauseType phase l (Known r t) = if isErased r - then Nothing + then VarClause else clauseType' l getClauseType phase l _ = clauseType' l partition : {a, as, vars : _} -> - Phase -> (ps : List01 ne (PatClause (a :: as) vars)) -> Partitions ps + Phase -> (ps : List (PatClause (a :: as) vars)) -> Partitions ps partition phase [] = NoClauses partition phase (x :: xs) with (partition phase xs) - partition phase (x :: .(cs ++ ps)) | (ConClauses cs rest) + partition phase (x :: (cs ++ ps)) | (ConClauses cs rest) = case clauseType phase x of ConClause => ConClauses (x :: cs) rest VarClause => VarClauses [x] (ConClauses cs rest) - partition phase (x :: .(vs ++ ps)) | (VarClauses vs rest) + partition phase (x :: (vs ++ ps)) | (VarClauses vs rest) = case clauseType phase x of ConClause => ConClauses [x] (VarClauses vs rest) VarClause => VarClauses (x :: vs) rest - partition phase [x] | NoClauses + partition phase (x :: []) | NoClauses = case clauseType phase x of ConClause => ConClauses [x] NoClauses VarClause => VarClauses [x] NoClauses @@ -383,13 +414,13 @@ data Group : List Name -> -- pattern variables still to process Scoped where ConGroup : {newargs : _} -> Name -> (tag : Int) -> - List01 True (PatClause (newargs ++ todo) (newargs ++ vars)) -> + List (PatClause (newargs ++ todo) (vars <>< newargs)) -> Group todo vars DelayGroup : {tyarg, valarg : _} -> - List01 True (PatClause (tyarg :: valarg :: todo) - (tyarg :: valarg :: vars)) -> + List (PatClause (tyarg :: valarg :: todo) + (vars :< tyarg :< valarg)) -> Group todo vars - ConstGroup : Constant -> List01 True (PatClause todo vars) -> + ConstGroup : Constant -> List (PatClause todo vars) -> Group todo vars covering @@ -399,14 +430,14 @@ covering show (ConstGroup c cs) = "Const " ++ show c ++ ": " ++ show cs data GroupMatch : ConType -> List Pat -> Group todo vars -> 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 [] - (DelayGroup {tyarg} {valarg} (MkPatClause pvs pats pid rhs :: rest)) - ConstMatch : GroupMatch (CConst c) [] - (ConstGroup c (MkPatClause pvs pats pid rhs :: rest)) - NoMatch : GroupMatch ct ps g + ConMatch : {tag : Int} -> (0 _ : LengthMatch ps newargs) -> + GroupMatch (CName n tag) ps + (ConGroup {newargs} n tag (MkPatClause pvs pats pid rhs :: rest)) + DelayMatch : GroupMatch CDelay [] + (DelayGroup {tyarg} {valarg} (MkPatClause pvs pats pid rhs :: rest)) + 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 todo vars) -> GroupMatch c ps g @@ -434,39 +465,60 @@ 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 -> List Name -> Maybe (NF vars) -> Core (List (ArgType vars)) +getArgTys {vars} env (n :: ns) (Just t@(NBind pfc _ (Pi _ c _ fargc) fsc)) + = do defs <- get Ctxt + empty <- clearDefs defs + argty <- case !(evalClosure defs fargc) of + NErased _ _ => pure Unknown + farg => Known c <$> quote empty env farg + scty <- fsc defs (toClosure defaultOpts env (Ref pfc Bound n)) + rest <- getArgTys env ns (Just scty) + pure (argty :: rest) +getArgTys env (_ :: _) (Just t) + = do empty <- clearDefs =<< get Ctxt + pure [Stuck !(quote empty env t)] +getArgTys _ _ _ = pure [] + +nextNames' : (pats : List Pat) -> + (ns : List Name) -> + (0 _ : LengthMatch pats ns) -> + List (ArgType vars) -> + (args ** (SizeOf args, NamedPats args (vars <>< args))) +nextNames' [] [] NilMatch _ = ([] ** (zero, [])) +nextNames' (p :: pats) (n :: ns) (ConsMatch prf) as + = do let (ty, as) : (ArgType (vars :< n), List (ArgType vars)) + := case as of + [] => (Unknown, []) + (a :: as) => (weaken a, as) + let (args ** (l, ps)) = nextNames' pats ns prf as + (n :: args ** (suc l, weakensN l (MkInfo p First ty) :: genWeakenFishily l ps)) + 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 (args ++ vars))) -nextNames fc root [] fty = pure ([] ** (zero, [])) -nextNames fc root (p :: pats) fty - = do defs <- get Ctxt - empty <- clearDefs defs - n <- nextName root + Core (args ** (SizeOf args, NamedPats args (Scope.ext vars args))) +nextNames _ _ [] _ = pure ([] ** (zero, [])) +nextNames {vars} fc root pats m_nty + = do (Element args p) <- 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 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)) + argTys <- getArgTys env args m_nty + pure $ nextNames' pats args p argTys + where + mkNames : (vars : List a) -> Core $ Subset (List Name) (LengthMatch vars) + mkNames [] = pure (Element [] NilMatch) + mkNames (x :: xs) + = do n <- nextName root + (Element ns p) <- mkNames xs + pure $ Element (n :: ns) (ConsMatch p) -- replace the prefix of patterns with 'pargs' -newPats : (pargs : List Pat) -> LengthMatch pargs ns -> +newPats : (pargs : List Pat) -> (0 _ : LengthMatch pargs ns) -> NamedPats (ns ++ todo) vars -> NamedPats ns vars newPats [] NilMatch rest = [] @@ -505,23 +557,22 @@ groupCons : {a, vars, todo : _} -> {auto ct : Ref Ctxt Defs} -> FC -> Name -> List Name -> - (cs : List01 True (PatClause (a :: todo) vars)) -> - (0 isCons : All IsConClause cs) => - Core (List01 True (Group todo vars)) -groupCons fc fn pvars (x :: xs) {isCons = p :: ps} - = foldlC (uncurry . gc) !(gc [] x p) $ pushIn xs ps + List (PatClause (a :: todo) vars) -> + Core (List (Group todo vars)) +groupCons fc fn pvars cs + = gc [] cs where addConG : {vars', todo' : _} -> Name -> (tag : Int) -> List Pat -> NamedPats todo' vars' -> Int -> (rhs : Term vars') -> - (acc : List01 ne (Group todo' vars')) -> - Core (List01 True (Group todo' vars')) + (acc : List (Group todo' vars')) -> + Core (List (Group todo' vars')) -- Group all the clauses that begin with the same constructor, and -- add new pattern arguments for each of that constructor's arguments. -- The type of 'ConGroup' ensures that we refer to the arguments by -- the same name in each of the clauses - addConG n tag pargs pats pid rhs [] + addConG {vars'} {todo'} n tag pargs pats pid rhs [] = do cty <- if n == UN (Basic "->") then pure $ NBind fc (MN "_" 0) (Pi fc top Explicit (MkNFClosure defaultOpts (mkEnv fc vars') (NType fc (MN "top" 0)))) $ (\d, a => pure $ NBind fc (MN "_" 1) (Pi fc top Explicit (MkNFClosure defaultOpts (mkEnv fc vars') (NErased fc Placeholder))) @@ -530,26 +581,29 @@ groupCons fc fn pvars (x :: xs) {isCons = p :: ps} Just t <- lookupTyExact n (gamma defs) | Nothing => pure (NErased fc Placeholder) nf defs (mkEnv fc vars') (embed t) - (patnames ** (l, newargs)) <- nextNames fc "e" pargs (Just cty) + (patnames ** (l, newargs)) <- nextNames {vars=vars'} fc "e" pargs (Just cty) -- 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 pvars (newargs ++ pats') pid (weakenNs l rhs) + (weakensN l pats) + let clause = MkPatClause pvars (newargs ++ pats') pid (weakensN l rhs) pure [ConGroup n tag [clause]] - addConG n tag pargs pats pid rhs (g :: gs) with (checkGroupMatch (CName n tag) pargs g) - addConG n tag pargs pats pid rhs - (ConGroup n tag (MkPatClause pvars ps tid tm :: rest) :: gs) | ConMatch {newargs} lprf + addConG {vars'} {todo'} n tag pargs pats pid rhs (g :: gs) with (checkGroupMatch (CName n tag) pargs g) + 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 let l = mkSizeOf newargs let pats' = updatePatNames (updateNames (zip newargs pargs)) - (weakenNs l pats) - let newclause = MkPatClause pvars (newps ++ pats') pid (weakenNs l rhs) + (weakensN l pats) + let newclause = MkPatClause pvars (newps ++ pats') pid (weakensN l rhs) -- put the new clause at the end of the group, since we -- match the clauses top to bottom. - pure $ ConGroup n tag (MkPatClause pvars ps tid tm :: rest ++ [newclause]) :: gs + pure ((ConGroup n tag (MkPatClause pvars ps tid tm :: rest ++ [newclause])) + :: gs) addConG n tag pargs pats pid rhs (g :: gs) | NoMatch - = (g ::) <$> addConG n tag pargs pats pid rhs gs + = do gs' <- addConG n tag pargs pats pid rhs gs + pure (g :: gs') -- This rather ugly special case is to deal with laziness, where Delay -- is like a constructor, but with a special meaning that it forces @@ -558,67 +612,73 @@ groupCons fc fn pvars (x :: xs) {isCons = p :: ps} addDelayG : {vars', todo' : _} -> Pat -> Pat -> NamedPats todo' vars' -> Int -> (rhs : Term vars') -> - (acc : List01 ne (Group todo' vars')) -> - Core (List01 True (Group todo' vars')) - addDelayG pty parg pats pid rhs [] + (acc : List (Group todo' vars')) -> + Core (List (Group todo' vars')) + addDelayG {vars'} {todo'} pty parg pats pid rhs [] = do let dty = NBind fc (MN "a" 0) (Pi fc erased Explicit (MkNFClosure defaultOpts (mkEnv fc vars') (NType fc (MN "top" 0)))) $ (\d, a => 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 fc "e" [pty, parg] + ([tyname, argname] ** (l, newargs)) <- nextNames {vars=vars'} fc "e" [pty, parg] (Just dty) | _ => throw (InternalError "Error compiling Delay pattern match") - let pats' = updatePatNames (updateNames [(tyname, pty), - (argname, parg)]) - (weakenNs l pats) - let clause = MkPatClause pvars (newargs ++ pats') pid (weakenNs l rhs) + let pats' = updatePatNames (updateNames [(tyname, pty), (argname, parg)]) + (weakensN l pats) + let clause = MkPatClause pvars (newargs ++ pats') pid (weakensN l rhs) pure [DelayGroup [clause]] - addDelayG pty parg pats pid rhs (g :: gs) with (checkGroupMatch CDelay [] g) - addDelayG pty parg pats pid rhs - (DelayGroup (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)]) - (weakenNs l pats) - let newclause = MkPatClause pvars (newps ++ pats') pid (weakenNs l rhs) - pure $ DelayGroup (MkPatClause pvars ps tid tm :: rest ++ [newclause]) :: gs + 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 [(valarg, parg), (tyarg, pty)]) + (weakensN l pats) + let newclause : PatClause (tyarg :: valarg :: todo') + (vars' :< tyarg :< valarg) + = MkPatClause pvars (newps ++ pats') pid + (weakensN l rhs) + pure ((DelayGroup (MkPatClause pvars ps tid tm :: rest ++ [newclause])) + :: gs) addDelayG pty parg pats pid rhs (g :: gs) | NoMatch - = (g ::) <$> addDelayG pty parg pats pid rhs gs + = do gs' <- addDelayG pty parg pats pid rhs gs + pure (g :: gs') addConstG : {vars', todo' : _} -> Constant -> NamedPats todo' vars' -> Int -> (rhs : Term vars') -> - (acc : List01 ne (Group todo' vars')) -> - Core (List01 True (Group todo' vars')) + (acc : List (Group todo' vars')) -> + Core (List (Group todo' vars')) addConstG c pats pid rhs [] - = pure [ConstGroup c [MkPatClause pvars pats pid rhs]] - addConstG c pats pid rhs (g :: gs) with (checkGroupMatch (CConst c) [] g) - addConstG c pats pid rhs - (ConstGroup c (MkPatClause pvars ps tid tm :: rest) :: gs) | ConstMatch - = do let newclause = MkPatClause pvars pats pid rhs - pure $ ConstGroup c (MkPatClause pvars ps tid tm :: rest ++ [newclause]) :: gs + = pure [ConstGroup c [MkPatClause pvars pats pid rhs]] + addConstG {todo'} {vars'} c pats pid rhs (g :: gs) with (checkGroupMatch (CConst c) [] g) + addConstG {todo'} {vars'} c pats pid rhs + ((ConstGroup c ((MkPatClause pvars ps tid tm) :: rest)) :: gs) | ConstMatch + = let newclause : PatClause todo' vars' + = MkPatClause pvars pats pid rhs in + pure ((ConstGroup c + (MkPatClause pvars ps tid tm :: rest ++ [newclause])) :: gs) addConstG c pats pid rhs (g :: gs) | NoMatch - = (g ::) <$> addConstG c pats pid rhs gs + = do gs' <- addConstG c pats pid rhs gs + pure (g :: gs') addGroup : {vars, todo, idx : _} -> - (pat : Pat) -> (0 _ : IsConPat pat) => - (0 p : IsVar nm idx vars) -> + Pat -> (0 p : IsVar nm idx vars) -> NamedPats todo vars -> Int -> Term vars -> - List01 ne (Group todo vars) -> - Core (List01 True (Group todo vars)) + List (Group todo vars) -> + Core (List (Group todo vars)) -- In 'As' replace the name on the RHS with a reference to the -- variable we're doing the case split on addGroup (PAs fc n p) pprf pats pid rhs acc - = addGroup p pprf pats pid (substName n (Local fc (Just True) idx pprf) rhs) acc + = addGroup p pprf pats pid (substName zero n (Local fc (Just True) _ pprf) rhs) acc addGroup (PCon cfc n t a pargs) pprf pats pid rhs acc = if a == length pargs - then addConG n t pargs pats pid rhs acc + then addConG n t (cast pargs) pats pid rhs acc else throw (CaseCompile cfc fn (NotFullyApplied n)) addGroup (PTyCon cfc n a pargs) pprf pats pid rhs acc = if a == length pargs - then addConG n 0 pargs pats pid rhs acc + then addConG n 0 (cast pargs) pats pid rhs acc else throw (CaseCompile cfc fn (NotFullyApplied n)) addGroup (PArrow _ _ s t) pprf pats pid rhs acc = addConG (UN $ Basic "->") 0 [s, t] pats pid rhs acc @@ -628,14 +688,17 @@ groupCons fc fn pvars (x :: xs) {isCons = p :: ps} = addDelayG pty parg pats pid rhs acc addGroup (PConst _ c) pprf pats pid rhs acc = addConstG c pats pid rhs acc + addGroup _ pprf pats pid rhs acc = pure acc -- Can't happen, not a constructor + -- FIXME: Is this possible to rule out with a type? Probably. gc : {a, vars, todo : _} -> - List01 ne (Group todo vars) -> - (p : PatClause (a :: todo) vars) -> - (0 _ : IsConClause p) -> - Core (List01 True (Group todo vars)) - gc acc (MkPatClause _ (MkInfo pat pprf _ :: pats) pid rhs) isCon - = addGroup pat pprf pats pid rhs acc + List (Group todo vars) -> + List (PatClause (a :: todo) vars) -> + Core (List (Group todo vars)) + gc acc [] = pure acc + 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 (p :: ps) ns -> Pat getFirstPat (p :: _) = pat p @@ -646,82 +709,96 @@ 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 -> Scoped where - Scored : List01 True (NamedPats (p :: ps) ns) -> Vect (length (p :: ps)) Int -> ScoredPats (p :: ps) ns + Scored : List (NamedPats (p :: ps) ns) -> Vect (length (p :: ps)) Int -> ScoredPats (p :: ps) ns {ps : _} -> Show (ScoredPats ps ns) where show (Scored xs ys) = (show ps) ++ "//" ++ (show ys) -zeroedScore : {ps : _} -> List01 True (NamedPats (p :: ps) ns) -> ScoredPats (p :: ps) ns +zeroedScore : {ps : _} -> List (NamedPats (p :: ps) ns) -> ScoredPats (p :: ps) ns 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 +||| `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 + ||| 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 : Scope) -> + (names : List Name) -> (scores : Vect (length names) Int) -> (highVal : Int) -> - (highIdx : (n ** NVar n (prev ++ names))) -> -- TODO should be `names <>< prev` + (highIdx : (n ** NVarL n (prev ++ names))) -> (duped : Bool) -> - Maybe (n ** NVar n (prev ++ names)) + Maybe (n ** NVarL 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 - prf = appendAssociative prev [x] xs + prf = elemInsertedMiddle x prev xs in rewrite prf in case compare y high of LT => next high (rewrite sym $ prf in idx) duped EQ => next high (rewrite sym $ prf in idx) True - GT => next y (x ** rewrite sym $ prf in weakenNVar (mkSizeOf prev) (MkNVar First)) False + GT => next y (x ** rewrite sym $ prf in weakenNVarL (mkSizeOf prev) (MkNVarL First)) False ||| Get the index of the highest scoring column if there is one. ||| If no column has a higher score than all other columns then ||| 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 (p :: ps) ns -> 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 (p :: ps) ns -> Maybe (n ** NVarL n (p :: ps)) +highScoreIdx (Scored xs (y :: ys)) = highScore {prev = []} (p :: ps) (y :: ys) (y - 1) (p ** MkNVarL First) False ||| Apply the penalty function to the head constructor's ||| arity. Produces 0 for all non-head-constructors. headConsPenalty : (penality : Nat -> Int) -> Pat -> Int -headConsPenalty p (PAs _ _ w) = headConsPenalty p w +headConsPenalty p (PAs _ _ w) = headConsPenalty p w headConsPenalty p (PCon _ n _ arity pats) = p arity headConsPenalty p (PTyCon _ _ arity _) = p arity -headConsPenalty _ (PConst {}) = 0 -headConsPenalty _ (PArrow {}) = 0 -headConsPenalty p (PDelay _ _ _ w) = headConsPenalty p w -headConsPenalty _ (PLoc {}) = 0 -headConsPenalty _ (PUnmatchable {}) = 0 - -splitColumn : (nps : List01 True (NamedPats (p :: ps) ns)) -> (Vect (length nps) (PatInfo p ns), List01 True (NamedPats ps ns)) -splitColumn [(w :: ws)] = ([w], [ws]) -splitColumn ((w :: ws) :: nps@(_ :: _)) = bimap (w ::) (ws ::) $ splitColumn nps +headConsPenalty _ (PConst _ _) = 0 +headConsPenalty _ (PArrow _ _ _ _) = 0 +headConsPenalty p (PDelay _ _ _ w) = headConsPenalty p w +headConsPenalty _ (PLoc _ _) = 0 +headConsPenalty _ (PUnmatchable _ _) = 0 ||| Apply the given function that scores a pattern to all patterns and then ||| sum up the column scores and add to the ScoredPats passed in. consScoreHeuristic : {ps : _} -> (scorePat : Pat -> Int) -> ScoredPats ps ns -> ScoredPats ps ns +consScoreHeuristic _ sps@(Scored [] _) = sps -- can't update scores without any patterns consScoreHeuristic scorePat (Scored xs ys) = - let columnScores = scoreColumns xs + let columnScores = sum <$> scoreColumns xs ys' = zipWith (+) ys columnScores in Scored xs ys' where - scoreColumns : {ps' : _} -> (nps : List01 True (NamedPats ps' ns)) -> Vect (length ps') Int + -- also returns NamePats of remaining columns while its in there + -- scoring the first column. + scoreFirstColumn : (nps : List (NamedPats (p' :: ps') ns)) -> + (res : List (NamedPats ps' ns) ** (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 ps' ns)) -> Vect (length ps') (Vect (length nps) Int) scoreColumns {ps' = []} nps = [] - scoreColumns {ps' = w :: ws} nps = - let (col, nps') = splitColumn nps - in sum (scorePat . pat <$> col) :: scoreColumns nps' + scoreColumns {ps' = (w :: ws)} 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 (p :: ps) ns -> ScoredPats (p :: ps) ns +heuristicF sps@(Scored [] _) = sps heuristicF (Scored (x :: xs) ys) = let columnScores = scores x ys' = zipWith (+) ys columnScores in Scored (x :: xs) ys' where isBlank : Pat -> Bool - isBlank (PLoc {}) = True + isBlank (PLoc _ _) = True isBlank _ = False scores : NamedPats ps' ns' -> Vect (length ps') Int @@ -742,7 +819,7 @@ applyHeuristics : {p : _} -> {ps : _} -> ScoredPats (p :: ps) ns -> List (ScoredPats (p :: ps) ns -> ScoredPats (p :: ps) ns) -> - Maybe (n ** NVar n (p :: ps)) + Maybe (n ** NVarL n (p :: ps)) applyHeuristics x [] = highScoreIdx x applyHeuristics x (f :: fs) = highScoreIdx x <|> applyHeuristics (f x) fs @@ -755,12 +832,12 @@ nextIdxByScore : {p : _} -> {ps : _} -> (useHeuristics : Bool) -> Phase -> - List01 True (NamedPats (p :: ps) ns) -> - (n ** NVar n (p :: ps)) -nextIdxByScore False _ _ = (_ ** (MkNVar First)) -nextIdxByScore _ (CompileTime _) _ = (_ ** (MkNVar First)) + List (NamedPats (p :: ps) ns) -> + (n ** NVarL n (p :: ps)) +nextIdxByScore False _ _ = (_ ** (MkNVarL First)) +nextIdxByScore _ (CompileTime _) _ = (_ ** (MkNVarL First)) nextIdxByScore True RunTime xs = - fromMaybe (_ ** (MkNVar First)) $ + fromMaybe (_ ** (MkNVarL First)) $ applyHeuristics (zeroedScore xs) [heuristicF, heuristicB, heuristicA] -- Check whether all the initial patterns have the same concrete, known @@ -769,7 +846,7 @@ nextIdxByScore True RunTime xs = sameType : {ns : _} -> {auto c : Ref Ctxt Defs} -> FC -> Phase -> Name -> - Env Term ns -> List01 ne (NamedPats (p :: ps) ns) -> + Env Term ns -> List (NamedPats (p :: ps) ns) -> Core () sameType fc phase fn env [] = pure () sameType {ns} fc phase fn env (p :: xs) @@ -784,18 +861,18 @@ sameType {ns} fc phase fn env (p :: xs) firstPat (pinf :: _) = pat pinf headEq : NF ns -> NF ns -> Phase -> Bool - headEq (NBind _ _ (Pi {}) _) (NBind _ _ (Pi {}) _) _ = True + headEq (NBind _ _ (Pi _ _ _ _) _) (NBind _ _ (Pi _ _ _ _) _) _ = True headEq (NTCon _ n _ _) (NTCon _ n' _ _) _ = n == n' headEq (NPrimVal _ c) (NPrimVal _ c') _ = c == c' - headEq (NType {}) (NType {}) _ = True + headEq (NType _ _) (NType _ _) _ = True headEq (NApp _ (NRef _ n) _) (NApp _ (NRef _ n') _) RunTime = n == n' headEq (NErased _ (Dotted x)) y ph = headEq x y ph headEq x (NErased _ (Dotted y)) ph = headEq x y ph - headEq (NErased {}) _ RunTime = True - headEq _ (NErased {}) RunTime = True + headEq (NErased _ _) _ RunTime = True + headEq _ (NErased _ _) RunTime = True headEq _ _ _ = False - sameTypeAs : forall ne. Phase -> NF ns -> List01 ne (ArgType ns) -> Core () + sameTypeAs : Phase -> NF ns -> List (ArgType ns) -> Core () sameTypeAs _ ty [] = pure () sameTypeAs ph ty (Known r t :: xs) = do defs <- get Ctxt @@ -806,7 +883,8 @@ 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 : List01 True (NamedPats (p :: ps) ns) -> Bool +samePat : List (NamedPats (p :: ps) ns) -> Bool +samePat [] = True samePat (pi :: xs) = samePatAs (dropAs (getFirstPat pi)) (map (dropAs . getFirstPat) xs) @@ -815,7 +893,7 @@ samePat (pi :: xs) dropAs (PAs _ _ p) = p dropAs p = p - samePatAs : Pat -> List01 ne Pat -> Bool + samePatAs : Pat -> List Pat -> Bool samePatAs p [] = True samePatAs (PTyCon fc n a args) (PTyCon _ n' _ _ :: ps) = n == n' && samePatAs (PTyCon fc n a args) ps @@ -830,44 +908,79 @@ samePat (pi :: xs) samePatAs (PLoc fc n) (PLoc _ _ :: ps) = samePatAs (PLoc fc n) ps samePatAs x y = False +getFirstCon : NamedPats (p :: ps) ns -> Pat +getFirstCon (p :: _) = pat p + +-- Count the number of distinct constructors in the initial pattern +countDiff : List (NamedPats (p :: ps) ns) -> Nat +countDiff xs = length (distinct [] (map getFirstCon xs)) + where + isVar : Pat -> Bool + isVar (PAs _ _ p) = isVar p + isVar (PCon _ _ _ _ _) = False + isVar (PTyCon _ _ _ _) = False + isVar (PConst _ _) = False + isVar (PArrow _ _ _ _) = False + isVar (PDelay _ _ _ p) = False + isVar _ = True + + -- Return whether two patterns would lead to the same match + sameCase : Pat -> Pat -> Bool + sameCase (PAs _ _ p) p' = sameCase p p' + sameCase p (PAs _ _ p') = sameCase p p' + sameCase (PCon _ _ t _ _) (PCon _ _ t' _ _) = t == t' + sameCase (PTyCon _ t _ _) (PTyCon _ t' _ _) = t == t' + sameCase (PConst _ c) (PConst _ c') = c == c' + sameCase (PArrow _ _ _ _) (PArrow _ _ _ _) = True + sameCase (PDelay _ _ _ _) (PDelay _ _ _ _) = True + sameCase x y = isVar x && isVar y + + distinct : List Pat -> List Pat -> List Pat + distinct acc [] = acc + distinct acc (p :: ps) + = if elemBy sameCase p acc + then distinct acc ps + else distinct (p :: acc) ps + getScore : {ns : _} -> {auto c : Ref Ctxt Defs} -> FC -> Phase -> Name -> - List01 True (NamedPats (p :: ps) ns) -> + List (NamedPats (p :: ps) ns) -> Core (Either CaseError ()) getScore fc phase name npss - = catch (Right () <$ sameType fc phase name (mkEnv fc ns) npss) - $ \case - CaseCompile _ _ err => pure $ Left err - err => throw err + = do catch (do sameType fc phase name (mkEnv fc ns) npss + pure (Right ())) + $ \case + CaseCompile _ _ err => pure $ Left err + err => throw err ||| Pick the leftmost matchable thing with all constructors in the ||| same family, or all variables, or all the same type constructor. pickNextViable : {p, ns, ps : _} -> - {auto c : Ref Ctxt Defs} -> - FC -> Phase -> Name -> List01 True (NamedPats (p :: ps) ns) -> - Core (n ** NVar n (p :: ps)) + {auto c : Ref Ctxt Defs} -> + FC -> Phase -> Name -> List (NamedPats (p :: ps) ns) -> + Core (n ** NVarL n (p :: ps)) -- last possible variable pickNextViable {ps = []} fc phase fn npss = if samePat npss - then pure (_ ** MkNVar First) + then pure (_ ** MkNVarL First) else do Right () <- getScore fc phase fn npss | Left err => throw (CaseCompile fc fn err) - pure (_ ** MkNVar First) + pure (_ ** MkNVarL First) pickNextViable {ps = q :: qs} fc phase fn npss = if samePat npss - then pure (_ ** MkNVar First) - else case !(getScore fc phase fn npss) of - Right () => pure (_ ** MkNVar First) - _ => do (_ ** MkNVar var) <- pickNextViable fc phase fn (map tail npss) - pure (_ ** MkNVar (Later var)) - -moveFirst : {idx : Nat} -> (0 el : IsVar nm idx ps) -> NamedPats ps ns -> - NamedPats (nm :: dropIsVar ps el) ns + then pure (_ ** MkNVarL First) + else case !(getScore fc phase fn npss) of + Right () => pure (_ ** MkNVarL First) + _ => do (_ ** MkNVarL var) <- pickNextViable fc phase fn (map tail npss) + pure (_ ** MkNVarL (Later var)) + +moveFirst : {idx : Nat} -> (0 el : IsVarL nm idx ps) -> NamedPats ps ns -> + NamedPats (nm :: dropIsVarL ps el) ns moveFirst el nps = getPat el nps :: dropPat el nps -shuffleVars : {idx : Nat} -> (0 el : IsVar nm idx todo) -> PatClause todo vars -> - PatClause (nm :: dropIsVar todo el) vars +shuffleVars : {idx : Nat} -> (0 el : IsVarL nm idx todo) -> PatClause todo vars -> + PatClause (nm :: dropIsVarL todo el) vars 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 @@ -883,29 +996,36 @@ mutual {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> - List01 True (PatClause todo vars) -> - IMaybe ne (CaseTree vars) -> + List (PatClause todo vars) -> (err : Maybe (CaseTree vars)) -> Core (CaseTree vars) -- 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 (_ ** (MkNVarL next)) = nextIdxByScore (caseTreeHeuristics !getSession) phase nps let prioritizedClauses = shuffleVars next <$> clauses - (n ** MkNVar next') <- pickNextViable fc phase fn (getNPs <$> prioritizedClauses) + (n ** MkNVarL next') <- pickNextViable fc phase fn (getNPs <$> prioritizedClauses) log "compile.casetree.pick" 25 $ "Picked " ++ show n ++ " as the next split" let clauses' = shuffleVars next' <$> prioritizedClauses log "compile.casetree.clauses" 25 $ - unlines ("Using clauses:" :: map ((" " ++) . show) (forget clauses')) + unlines ("Using clauses:" :: map ((" " ++) . show) clauses') let ps = partition phase clauses' log "compile.casetree.partition" 25 $ "Got Partition:\n" ++ show ps - Just mix <- mixture fc fn phase ps err - log "compile.casetree.intermediate" 25 $ "match: new case tree " ++ show mix - pure mix - match {todo = []} fc fn phase (MkPatClause pvars [] pid (Erased _ Impossible) :: _) err + mix <- mixture fc fn phase ps err + case mix of + Nothing => + do log "compile.casetree.intermediate" 25 "match: No clauses" + pure (Unmatched "No clauses") + Just m => + do log "compile.casetree.intermediate" 25 $ "match: new case tree " ++ show m + Core.pure m + match {todo = []} fc fn phase [] err + = maybe (pure (Unmatched "No patterns")) + pure 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 : _} -> @@ -913,19 +1033,22 @@ mutual {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> {idx : Nat} -> (0 p : IsVar pvar idx vars) -> Term vars -> - List01 True (Group todo vars) -> IMaybe ne (CaseTree vars) -> + List (Group todo vars) -> Maybe (CaseTree vars) -> Core (CaseTree vars) - caseGroups fc fn phase el ty gs errorCase - = Case idx el (resolveNames vars ty) <$> altGroups gs + caseGroups {vars} fc fn phase el ty gs errorCase + = do g <- altGroups gs + pure (Case _ el (resolveNames vars ty) g) where - altGroups : forall ne. List01 ne (Group todo vars) -> Core (List (CaseAlt vars)) - altGroups [] = pure $ toList $ DefaultCase <$> errorCase + altGroups : List (Group todo vars) -> Core (List (CaseAlt vars)) + altGroups [] = maybe (pure []) + (\e => pure [DefaultCase e]) + errorCase altGroups (ConGroup {newargs} cn tag rest :: cs) - = do crest <- match fc fn phase rest (map (weakenNs (mkSizeOf newargs)) errorCase) + = do crest <- match fc fn phase rest (map (weakensN (mkSizeOf newargs)) errorCase) cs' <- altGroups cs pure (ConCase cn tag newargs 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 -> - (cs : List01 True (PatClause (a :: todo) vars)) -> - (0 isCons : All IsConClause cs) => - IMaybe ne (CaseTree vars) -> + List (PatClause (a :: todo) vars) -> + Maybe (CaseTree vars) -> Core (CaseTree vars) + conRule fc fn phase [] err = maybe (pure (Unmatched "No constructor clauses")) pure err -- ASSUMPTION, not expressed in the type, that the patterns all have -- the same variable (pprf) for the first argument. If not, the result -- will be a broken case tree... so we should find a way to express this -- in the type if we can. conRule {a} fc fn phase cs@(MkPatClause pvars (MkInfo pat pprf fty :: pats) pid rhs :: rest) err - = do Element refinedcs _ <- pullOut <$> traverseList01 (substInClause fc) (pushIn cs isCons) + = do refinedcs <- traverse (substInClause fc) cs groups <- groupCons fc fn pvars refinedcs ty <- case fty of Known _ t => pure t @@ -957,11 +1080,11 @@ mutual {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> - List01 True (PatClause (a :: todo) vars) -> - IMaybe ne (CaseTree vars) -> + List (PatClause (a :: todo) vars) -> + Maybe (CaseTree vars) -> Core (CaseTree vars) - varRule fc fn phase cs err - = do alts' <- traverseList01 updateVar cs + varRule {vars} {a} fc fn phase cs err + = do alts' <- traverse updateVar cs match fc fn phase alts' err where updateVar : PatClause (a :: todo) vars -> Core (PatClause todo vars) @@ -969,12 +1092,12 @@ mutual updateVar (MkPatClause pvars (MkInfo (PLoc pfc n) prf fty :: pats) pid rhs) = pure $ MkPatClause (n :: pvars) !(substInPats fc a (Local pfc (Just False) _ prf) pats) - pid (substName n (Local pfc (Just False) _ prf) rhs) + pid (substName zero n (Local pfc (Just False) _ prf) 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 + let rhs' = substName zero n (Local pfc (Just True) _ prf) 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 @@ -985,28 +1108,28 @@ mutual mixture : {a, vars, todo : _} -> {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> - {ps : List01 ne (PatClause (a :: todo) vars)} -> + {ps : List (PatClause (a :: todo) vars)} -> FC -> Name -> Phase -> Partitions ps -> - IMaybe neErr (CaseTree vars) -> - Core (IMaybe (ne || neErr) (CaseTree vars)) + Maybe (CaseTree vars) -> + Core (Maybe (CaseTree vars)) mixture fc fn phase (ConClauses cs rest) err = do fallthrough <- mixture fc fn phase rest err - Just <$> conRule fc fn phase cs fallthrough + pure (Just !(conRule fc fn phase cs fallthrough)) mixture fc fn phase (VarClauses vs rest) err = do fallthrough <- mixture fc fn phase rest err - Just <$> varRule fc fn phase vs fallthrough - mixture fc fn phase NoClauses 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 a) n) = pure $ PTyCon fc n a args +mkPat args orig (Ref fc (DataCon t a) n) = pure $ PCon fc n t a (cast args) +mkPat args orig (Ref fc (TyCon a) n) = pure $ PTyCon fc n a (cast args) mkPat args orig (Ref fc Func n) = do prims <- getPrimitiveNames - mtm <- normalisePrims (const True) isPConst True prims n args orig Env.empty + mtm <- normalisePrims (const True) isPConst True prims n (cast args) orig Env.empty case mtm of Just tm => if tm /= orig -- check we made progress; if there's an -- unresolved interface, we might be stuck @@ -1021,11 +1144,12 @@ mkPat args orig (Ref fc Func n) mkPat args orig (Bind fc x (Pi _ _ _ s) 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') + 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 +-- 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) mkPat args orig (As fc _ _ ptm) @@ -1033,9 +1157,9 @@ mkPat args orig (As fc _ _ ptm) mkPat args orig (TDelay fc r ty 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" @@ -1047,74 +1171,75 @@ argToPat tm = mkPat [] tm tm mkPatClause : {auto c : Ref Ctxt Defs} -> FC -> Name -> - (args : Scope) -> ClosedTerm -> + (args : List Name) -> SizeOf args -> ClosedTerm -> Int -> (List Pat, ClosedTerm) -> - Core (PatClause args args) -mkPatClause fc fn args ty pid (ps, rhs) + Core (PatClause args (cast args)) +mkPatClause fc fn args s ty pid (ps, rhs) = maybe (throw (CaseCompile fc fn DifferingArgNumbers)) (\eq => do defs <- get Ctxt nty <- nf defs Env.empty ty - ns <- mkNames args ps eq (Just nty) + -- The arguments are in reverse order, so we need to + -- read what we know off 'nty', and reverse it + argTys <- getArgTys Env.empty args (Just nty) + ns <- mkNames args ps eq s.hasLength argTys log "compile.casetree" 20 $ "Make pat clause for names " ++ show ns ++ " in LHS " ++ show ps - pure (MkPatClause [] ns pid - (rewrite sym (appendNilRightNeutral args) in - (weakenNs (mkSizeOf args) rhs)))) + pure (MkPatClause [] ns pid (weakensN s rhs))) (checkLengthMatch args ps) where - mkNames : (vars : Scope) -> (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 !(quote empty [] farg))) - Just t => - pure (Nothing, Stuck (embed !(quote empty [] t))) - pure (MkInfo p First (Builtin.snd fa_tys) - :: weaken !(mkNames args ps eq (Builtin.fst fa_tys))) + mkNames : (vars : List Name) -> (ps : List Pat) -> + (0 _ : LengthMatch vars ps) -> + {n : _} -> (0 _ : HasLength n vars) -> + List (ArgType [<]) -> + Core (NamedPats vars (cast vars)) + mkNames [] [] NilMatch _ _ = pure [] + mkNames (r :: args) (p :: ps) (ConsMatch eq) (S h) as + = do let (ty, as) : (ArgType ([< args), List (ArgType [<])) + := case as of + [] => (Unknown, []) + (a :: as) => (embed a, as) + let info = MkInfo {name=r} p (fishyIsVar {outer=[<]} h) ty + rest <- mkNames args ps eq h as + pure (info :: rewrite fishAsSnocAppend [ FC -> Name -> Phase -> - ClosedTerm -> List01 True (List Pat, ClosedTerm) -> + ClosedTerm -> List (List Pat, ClosedTerm) -> + Maybe (CaseTree Scope.empty) -> Core (args ** CaseTree args) -patCompile fc fn phase ty (p :: ps) - = do let (ns ** n) = getNames 0 (fst p) - pats <- mkPatClausesFrom 0 ns (p :: ps) +patCompile fc fn phase ty [] def + = maybe (pure (Scope.empty ** Unmatched "No definition")) + (\e => pure (Scope.empty ** e)) + def +patCompile fc fn phase ty (p :: ps) def + = do let ns = getNames 0 (fst p) + pats <- mkPatClausesFrom 0 ns (mkSizeOf ns) (p :: ps) -- low verbosity level: pretty print fully resolved names logC "compile.casetree" 5 $ do - pats <- traverse toFullNames $ forget pats + pats <- traverse toFullNames pats pure $ "Pattern clauses:\n" ++ show (indent 2 $ vcat $ pretty <$> pats) -- 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 Nothing + cases <- match fc fn phase pats (embed @{MaybeFreelyEmbeddable} def) pure (_ ** cases) where - mkPatClausesFrom : Int -> (args : Scope) -> - List01 ne (List Pat, ClosedTerm) -> - Core (List01 ne (PatClause args 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 + mkPatClausesFrom : Int -> (args : List Name) -> SizeOf args -> + List (List Pat, ClosedTerm) -> + Core (List (PatClause args (cast args))) + mkPatClausesFrom _ _ _ [] = pure [] + mkPatClausesFrom i ns s (p :: ps) + = do p' <- mkPatClause fc fn ns s ty i p + ps' <- mkPatClausesFrom (i + 1) ns s ps pure (p' :: ps') - getNames : Int -> List Pat -> (ns : Scope ** SizeOf ns) - getNames i [] = ([] ** zero) - getNames i (x :: xs) = - let (ns ** n) = getNames (i + 1) xs - in (MN "arg" i :: ns ** suc n) + getNames : Int -> List Pat -> List Name + getNames i [] = [] + getNames i (_ :: xs) = MN "arg" i :: getNames (i + 1) xs toPatClause : {auto c : Ref Ctxt Defs} -> FC -> Name -> (ClosedTerm, ClosedTerm) -> @@ -1135,18 +1260,18 @@ 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 -> - (clauses : List01 True (ClosedTerm, ClosedTerm)) -> + FC -> Phase -> Name -> ClosedTerm -> (def : Maybe (CaseTree Scope.empty)) -> + (clauses : List (ClosedTerm, ClosedTerm)) -> Core (args ** CaseTree args) -simpleCase fc phase fn ty clauses +simpleCase fc phase fn ty def clauses = do logC "compile.casetree" 5 $ - do cs <- traverse (\ (c,d) => [| MkPair (toFullNames c) (toFullNames d) |]) (forget clauses) + do cs <- traverse (\ (c,d) => [| MkPair (toFullNames c) (toFullNames d) |]) clauses pure $ "simpleCase: Clauses:\n" ++ show ( indent 2 $ vcat $ flip map cs $ \ lrhs => byShow (fst lrhs) <++> pretty "=" <++> byShow (snd lrhs)) - ps <- traverseList01 (toPatClause fc fn) clauses + ps <- traverse (toPatClause fc fn) clauses defs <- get Ctxt - patCompile fc fn phase ty ps + patCompile fc fn phase ty ps def mutual findReachedAlts : CaseAlt ns' -> List Int @@ -1171,8 +1296,8 @@ identifyUnreachableDefaults : {auto c : Ref Ctxt Defs} -> Core (SortedSet Int) -- Leave it alone if it's a primitive type though, since we need the catch -- all case there -identifyUnreachableDefaults fc defs (NPrimVal {}) cs = pure empty -identifyUnreachableDefaults fc defs (NType {}) cs = pure empty +identifyUnreachableDefaults fc defs (NPrimVal _ _) cs = pure empty +identifyUnreachableDefaults fc defs (NType _ _) cs = pure empty identifyUnreachableDefaults fc defs nfty cs = do cs' <- traverse rep cs let (cs'', extraClauseIdxs) = dropRep (concat cs') empty @@ -1214,22 +1339,22 @@ identifyUnreachableDefaults fc defs nfty cs ||| to the number of ways to reach a RHS for that clause then the clause is totally ||| superfluous (it will never be reached). findExtraDefaults : {auto c : Ref Ctxt Defs} -> - {vars : _} -> - FC -> Defs -> CaseTree vars -> - Core (List Int) -findExtraDefaults fc defs (Case idx el ty altsIn) - = do let fenv = mkEnv fc vars + {vars : _} -> + FC -> Defs -> CaseTree vars -> + Core (List Int) +findExtraDefaults fc defs ctree@(Case {name = var} idx el ty altsIn) + = do let fenv = mkEnv fc _ nfty <- nf defs fenv ty extraCases <- identifyUnreachableDefaults fc defs nfty altsIn extraCases' <- concat <$> traverse findExtraAlts altsIn pure (Prelude.toList extraCases ++ extraCases') where findExtraAlts : CaseAlt vars -> Core (List Int) - findExtraAlts (ConCase x tag args ctree) = findExtraDefaults fc defs ctree - findExtraAlts (DelayCase x arg ctree) = findExtraDefaults fc defs ctree - findExtraAlts (ConstCase x ctree) = findExtraDefaults fc defs ctree + findExtraAlts (ConCase x tag args ctree') = findExtraDefaults fc defs ctree' + findExtraAlts (DelayCase x arg ctree') = findExtraDefaults fc defs ctree' + findExtraAlts (ConstCase x ctree') = findExtraDefaults fc defs ctree' -- already handled defaults by elaborating them to all possible cons - findExtraAlts (DefaultCase ctree) = pure [] + findExtraAlts (DefaultCase ctree') = pure [] findExtraDefaults fc defs ctree = pure [] @@ -1244,18 +1369,18 @@ getPMDef : {auto c : Ref Ctxt Defs} -> getPMDef fc phase fn ty [] = do log "compile.casetree.getpmdef" 20 "getPMDef: No clauses!" defs <- get Ctxt - pure (!(getArgs 0 !(nf defs Env.empty ty)) ** (Unmatched "No clauses in \{show fn}", [])) + pure (cast !(getArgs 0 !(nf defs Env.empty ty)) ** (Unmatched "No clauses", [])) where getArgs : Int -> ClosedNF -> Core (List Name) - getArgs i (NBind fc x (Pi {}) sc) + getArgs i (NBind fc x (Pi _ _ _ _) sc) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) pure (MN "arg" i :: !(getArgs i sc')) getArgs i _ = pure [] -getPMDef fc phase fn ty clauses@(_ :: _) +getPMDef fc phase fn ty clauses = do defs <- get Ctxt - let cs = map (toClosed defs) (labelPat 0 $ fromList clauses) - (_ ** t) <- simpleCase fc phase fn ty cs + let cs = map (toClosed defs) (labelPat 0 clauses) + (_ ** t) <- simpleCase fc phase fn ty Nothing cs logC "compile.casetree.getpmdef" 20 $ pure $ "Compiled to: " ++ show !(toFullNames t) let reached = findReached t @@ -1272,7 +1397,7 @@ getPMDef fc phase fn ty clauses@(_ :: _) then getUnreachable (i + 1) is cs else c :: getUnreachable (i + 1) is cs - labelPat : Int -> List01 ne a -> List01 ne (String, a) + labelPat : Int -> List a -> List (String, a) labelPat i [] = [] labelPat i (x :: xs) = ("pat" ++ show i ++ ":", x) :: labelPat (i + 1) xs diff --git a/src/Core/Case/CaseTree.idr b/src/Core/Case/CaseTree.idr index 90df008ac7c..ae5411eb8c5 100644 --- a/src/Core/Case/CaseTree.idr +++ b/src/Core/Case/CaseTree.idr @@ -4,13 +4,14 @@ import Core.TT import Idris.Pretty.Annotations -import Data.List import Data.So import Data.String import Libraries.Data.NameMap import Libraries.Text.PrettyPrint.Prettyprinter import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra %default covering @@ -40,10 +41,10 @@ mutual data CaseAlt : Scoped where ||| Constructor for a data type; bind the arguments and subterms. ConCase : Name -> (tag : Int) -> (args : List Name) -> - CaseTree (Scope.addInner vars args) -> CaseAlt vars + CaseTree (Scope.ext vars args) -> CaseAlt vars ||| Lazy match for the Delay type use for codata types DelayCase : (ty : Name) -> (arg : Name) -> - CaseTree (Scope.addInner vars [ty, arg]) -> CaseAlt vars + CaseTree (Scope.addInner vars [ CaseAlt vars -- TODO `arg` and `ty` should be swapped, as in Yaffle ||| Match against a literal ConstCase : Constant -> CaseTree vars -> CaseAlt vars @@ -102,8 +103,8 @@ 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 @@ -202,9 +203,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 @@ -215,8 +216,8 @@ Pretty IdrisSyntax Pat where mutual insertCaseNames : SizeOf outer -> SizeOf ns -> - CaseTree (outer ++ inner) -> - CaseTree (outer ++ (ns ++ inner)) + CaseTree (Scope.addInner inner outer) -> + CaseTree (Scope.addInner 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) @@ -227,14 +228,22 @@ mutual insertCaseAltNames : SizeOf outer -> SizeOf ns -> - CaseAlt (outer ++ inner) -> - CaseAlt (outer ++ (ns ++ inner)) + CaseAlt (Scope.addInner inner outer) -> + CaseAlt (Scope.addInner 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) @@ -285,14 +294,14 @@ export mkTerm : (vars : Scope) -> 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 arity) x) + = applySpine fc (Ref fc (TyCon 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 (Scope.bind 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/Util.idr b/src/Core/Case/Util.idr index d5a9d659930..d1d76026195 100644 --- a/src/Core/Case/Util.idr +++ b/src/Core/Case/Util.idr @@ -49,7 +49,7 @@ export mkAlt : 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 478aba8e751..a9ef0c60897 100644 --- a/src/Core/CompileExpr.idr +++ b/src/Core/CompileExpr.idr @@ -4,12 +4,12 @@ module Core.CompileExpr import Core.TT -import Data.List import Data.String import Data.Vect import Libraries.Data.List.SizeOf import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra %default covering @@ -75,11 +75,11 @@ mutual 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 (Scope.bind 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 (Scope.bind 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) @@ -113,7 +113,7 @@ mutual -- 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 (Scope.ext vars args) -> CConAlt vars public export data CConstAlt : Scoped where @@ -121,7 +121,7 @@ mutual public export ClosedCExp : Type -ClosedCExp = CExp [] +ClosedCExp = CExp Scope.empty mutual ||| NamedCExp - as above, but without the name index, so with explicit @@ -276,12 +276,17 @@ mutual export data Names : Scoped where - Nil : Names [] - (::) : Name -> Names xs -> Names (x :: xs) + Lin : Names Scope.empty + (:<) : Names xs -> Name -> Names (Scope.bind xs x) + +namespace Names + public export + empty : Names Scope.empty + empty = [<] 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 @@ -296,19 +301,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 +addLocz : (args : Scope) -> Names vars -> Names (Scope.addInner vars args) +addLocz [<] ns = ns +addLocz (xs :< x) ns + = let rec = addLocz xs ns in + rec :< uniqueName x rec export -addLocs : (args : List Name) -> Names vars -> Names (args ++ vars) +initLocs : (vars : Scope) -> Names vars +initLocs vars + = rewrite sym $ appendLinLeftNeutral vars in + addLocz vars [<] + +export +addLocs : (args : List Name) -> Names vars -> Names (Scope.ext 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) -conArgs : (args : List Name) -> Names (args ++ vars) -> List Name -conArgs [] ns = [] -conArgs (a :: as) (n :: ns) = n :: conArgs as ns +conArgz : (args : SnocList Name) -> Names (Scope.addInner vars args) -> SnocList Name +conArgz [<] ns = [<] +conArgz (as :< a) (ns :< n) = conArgz as ns :< n + +conArgs : (args : List Name) -> Names (Scope.ext 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 @@ -355,16 +379,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 = Scope.empty} args ns in - MkNmFun args' (forget def) + = let ns = addLocz args Names.empty + args' = conArgz {vars = Scope.empty} 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) @@ -429,8 +451,8 @@ mutual export insertNames : SizeOf outer -> SizeOf ns -> - CExp (outer ++ inner) -> - CExp (outer ++ (ns ++ inner)) + CExp (Scope.addInner inner outer) -> + CExp (Scope.addInner inner (ns ++ outer)) insertNames outer ns (CLocal fc prf) = let MkNVar var' = insertNVarNames outer ns (MkNVar prf) in CLocal fc var' @@ -463,19 +485,28 @@ mutual insertNamesConAlt : SizeOf outer -> SizeOf ns -> - CConAlt (outer ++ inner) -> - CConAlt (outer ++ (ns ++ inner)) + CConAlt (Scope.addInner inner outer) -> + CConAlt (Scope.addInner 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 (Scope.addInner inner outer) -> + CConstAlt (Scope.addInner inner (ns ++ outer)) insertNamesConstAlt outer ns (MkConstAlt x sc) = MkConstAlt x (insertNames outer ns sc) export @@ -521,7 +552,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) @@ -573,11 +604,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) @@ -585,15 +619,15 @@ mutual export substs : {dropped, vars : _} -> SizeOf dropped -> - SubstCEnv dropped vars -> CExp (dropped ++ vars) -> CExp vars + SubstCEnv dropped vars -> CExp (Scope.addInner vars dropped) -> CExp vars substs = substEnv zero mutual export mkLocals : SizeOf outer -> Bounds bound -> - CExp (outer ++ vars) -> - CExp (outer ++ (bound ++ vars)) + CExp (Scope.addInner vars outer) -> + CExp (Scope.addInner 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) @@ -632,23 +666,32 @@ mutual mkLocalsConAlt : SizeOf outer -> Bounds bound -> - CConAlt (outer ++ vars) -> - CConAlt (outer ++ (bound ++ vars)) + CConAlt (Scope.addInner vars outer) -> + CConAlt (Scope.addInner 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 (Scope.addInner vars outer) -> + CConstAlt (Scope.addInner 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 (Scope.addInner 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 5c17674585b..38e16a8af44 100644 --- a/src/Core/CompileExpr/Pretty.idr +++ b/src/Core/CompileExpr/Pretty.idr @@ -16,13 +16,11 @@ import Idris.Doc.Annotations %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 CList.(::) %hide CList.Nil %hide Stream.(::) @@ -114,7 +112,7 @@ 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 $ toList args) <++> fatArrow <++> prettyCExp exp diff --git a/src/Core/Context.idr b/src/Core/Context.idr index e8ac7994ba5..34946d2e892 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -560,13 +560,13 @@ mutual export HasNames (Env Term vars) where - full gam [] = pure Env.empty - full gam (b :: bs) - = pure $ !(traverse (full gam) b) :: !(full gam bs) + full gam [<] = pure Env.empty + full gam (bs :< b) + = pure $ !(full gam bs) :< !(traverse (full gam) b) - resolved gam [] = pure Env.empty - resolved gam (b :: bs) - = pure $ !(traverse (resolved gam) b) :: !(resolved gam bs) + resolved gam [<] = pure Env.empty + resolved gam (bs :< b) + = pure $ !(resolved gam bs) :< !(traverse (resolved gam) b) export HasNames Clause where diff --git a/src/Core/Context/Pretty.idr b/src/Core/Context/Pretty.idr index 132f3880a6d..aafd4464855 100644 --- a/src/Core/Context/Pretty.idr +++ b/src/Core/Context/Pretty.idr @@ -12,13 +12,11 @@ import Core.Case.CaseTree.Pretty import Libraries.Data.NatSet -%hide Env.(::) -%hide Env.Nil +%hide Env.(:<) +%hide Env.Lin %hide String.(::) %hide String.Nil %hide Doc.Nil -%hide Subst.(::) -%hide Subst.Nil %hide CList.(::) %hide CList.Nil %hide Stream.(::) diff --git a/src/Core/Core.idr b/src/Core/Core.idr index 65348ecb42d..8384b630df8 100644 --- a/src/Core/Core.idr +++ b/src/Core/Core.idr @@ -769,14 +769,14 @@ 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 acc + 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 (reverse xs) [<] + traverse f xs = traverse' f xs [<] export mapMaybeM : (a -> Core (Maybe b)) -> List a -> Core (List b) @@ -860,7 +860,7 @@ namespace SnocList export traverse_ : (a -> Core b) -> SnocList a -> Core () - traverse_ f xs = traverse_' f (reverse xs) + traverse_ f xs = traverse_' f xs namespace WithData %inline export @@ -928,7 +928,7 @@ namespace SnocList export anyM : (a -> Core Bool) -> SnocList a -> Core Bool - anyM f xs = anyM' f (reverse xs) + anyM f xs = anyM' f xs export allM : (a -> Core Bool) -> List a -> Core Bool diff --git a/src/Core/Coverage.idr b/src/Core/Coverage.idr index 17f47d36c77..b0b06cc7467 100644 --- a/src/Core/Coverage.idr +++ b/src/Core/Coverage.idr @@ -8,11 +8,13 @@ import Core.Normalise import Core.Value import Data.Maybe +import Data.SnocList import Libraries.Data.NameMap import Libraries.Data.NatSet import Libraries.Data.String.Extra import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf import Libraries.Text.PrettyPrint.Prettyprinter %default covering @@ -85,10 +87,10 @@ conflict defs env nfty n _ => pure False where mutual - conflictArgs : Int -> List (Closure vars) -> List ClosedClosure -> + conflictArgs : Int -> SnocList (Closure vars) -> SnocList ClosedClosure -> 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' @@ -113,7 +115,7 @@ conflict defs env nfty n = let x' = MN (show x) i in conflictNF (i + 1) t !(sc defs (toClosure defaultOpts Env.empty (Ref fc Bound x'))) - conflictNF i nf (NApp _ (NRef Bound n) []) + conflictNF i nf (NApp _ (NRef Bound n) [<]) = pure (Just [(n, !(quote defs env nf))]) conflictNF i (NDCon _ n t a args) (NDCon _ n' t' a' args') = if t == t' @@ -194,6 +196,10 @@ getMissingAlts fc defs nfty alts KnownVars : Scope -> Type -> Type KnownVars vars a = List (Var vars, a) +getName : {idx : Nat} -> {vars : Scope} -> (0 p : IsVar n idx vars) -> Name +getName {vars = _ :< v} First = v +getName (Later p) = getName p + showK : {ns : _} -> Show a => KnownVars ns a -> String showK {a} xs = show (map aString xs) @@ -203,11 +209,16 @@ showK {a} xs = show (map aString xs) aString (MkVar v, t) = (nameAt v, t) -- TODO re-use `Thinnable` -weakenNs : SizeOf args -> KnownVars vars a -> KnownVars (args ++ vars) a +weakenNs : SizeOf args -> KnownVars vars a -> KnownVars (Scope.addInner vars args) a weakenNs args [] = [] weakenNs args ((v, t) :: xs) = (weakenNs args v, t) :: weakenNs args xs +weakensN : SizeOf args -> KnownVars vars a -> KnownVars (Scope.ext 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 @@ -270,8 +281,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 @@ -288,30 +299,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 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 + let known' = (MkVar el, t) :: known + 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) ++ @@ -344,7 +356,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. @@ -407,19 +419,19 @@ 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 NatSet.empty eraseArgs mgdef - args' <- traverse eraseApps (NatSet.overwrite (Erased fc Placeholder) eargs args) - pure (apply fc (Ref fc nt n) args') + args' <- traverseSnocList eraseApps (NatSet.overwrite (Erased fc Placeholder) 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') -- 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. diff --git a/src/Core/Env.idr b/src/Core/Env.idr index 4a24d5d03bd..c6d6c2def5f 100644 --- a/src/Core/Env.idr +++ b/src/Core/Env.idr @@ -1,78 +1,81 @@ module Core.Env import Core.TT -import Data.List +import Core.Name.CompatibleVars -import Libraries.Data.List.SizeOf +import Data.SnocList +import Data.SnocList.Quantifiers import Libraries.Data.VarSet - import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra %default total -- Environment containing types and values of local variables public export data Env : (tm : Scoped) -> Scope -> Type where - Nil : Env tm Scope.empty - (::) : Binder (tm vars) -> Env tm vars -> Env tm (x :: vars) + Lin : Env tm Scope.empty + (:<) : Env tm vars -> Binder (tm vars) -> Env tm (Scope.bind vars x) %name Env rho -public export -empty : Env tm Scope.empty -empty = [] +namespace Env + public export + empty : Env tm Scope.empty + empty = [<] + + public export + bind : Env tm vars -> Binder (tm vars) -> Env tm (Scope.bind vars x) + bind vars n = vars :< n 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 (Scope.bind 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 (Scope.addInner vars ns) +(++) {ns = ns :< n} (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 = _ :< _} (xs :< Let _ _ _ _) = namesNoLet xs +namesNoLet {xs = _ :< x} (env :< _) = namesNoLet env :< x export eraseLinear : Env tm vs -> Env tm vs -eraseLinear [] = Env.empty -eraseLinear (b :: bs) +eraseLinear [<] = Env.empty +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 export getErased : {0 vs : _} -> Env tm vs -> List (Var vs) -getErased env = go env [<] where - - go : Env tm vars -> SizeOf seen -> List (Var (seen <>> vars)) - go [] p = [] - go (b :: bs) p +getErased [<] = [] +getErased (bs :< b) = if isErased (multiplicity b) - then mkVarChiply p :: go bs (p :< _) - else go bs (p :< _) + then first :: map weaken (getErased bs) + else map weaken (getErased bs) public export data IsDefined : Name -> Scope -> Type where @@ -83,8 +86,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)) @@ -94,20 +97,13 @@ 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 {vars = _ :< _} 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 - -- Weaken by all the names at once at the end, to save multiple traversals -- in big environments @@ -118,10 +114,12 @@ getBinderUnder : Weaken tm => (ns : Scope) -> (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 Extra.revOnto (Scope.bind vs x) ns in + rewrite sym $ appendAssociative vs [ @@ -133,8 +131,8 @@ getBinder el env = getBinderUnder Scope.empty el env -- 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 {vars = _ :< _} {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 @@ -142,12 +140,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 {vars = _ :< _} 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 {vars = _ :< _} 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 {vars = _ :< _} fc (env :< b) tm = let bnd = Pi (binderLoc b) (multiplicity b) Explicit (binderType b) in abstractEnvType fc env (Bind fc _ bnd tm) @@ -155,10 +153,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 {vars = _ :< _} 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 {vars = _ :< _} fc (env :< b) tm = let bnd = Lam (binderLoc b) (multiplicity b) Explicit (binderType b) in abstractEnv fc env (Bind fc _ bnd tm) @@ -166,24 +164,24 @@ 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 {vars = _ :< _} 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 {vars = _ :< _} fc (env :< b) tm = let bnd = Pi fc (multiplicity b) Explicit (binderType b) in abstractFullEnvType fc env (Bind fc _ bnd tm) export mkExplicit : Env Term vs -> Env Term vs -mkExplicit [] = Env.empty -mkExplicit (Pi fc c _ ty :: env) = Pi fc c Explicit ty :: mkExplicit env -mkExplicit (b :: env) = b :: mkExplicit env +mkExplicit [<] = Env.empty +mkExplicit (env :< Pi fc c _ ty) = Env.bind (mkExplicit env) (Pi fc c Explicit ty) +mkExplicit (env :< b) = Env.bind (mkExplicit env) b 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) = Env.bind (letToLam env) $ Lam fc c Explicit ty +letToLam (env :< b) = Env.bind (letToLam env) b mutual findUsed : {vars : _} -> @@ -203,7 +201,7 @@ mutual = findUsedArgs env (findUsed env u a) as findUsed env used (Bind fc x b tm) = assert_total $ - VarSet.dropFirst (findUsed (b :: env) + VarSet.dropFirst (findUsed (Env.bind env b) (weaken {tm = VarSet} (findUsedInBinder env used b)) tm) findUsed env used (App fc fn arg) @@ -235,13 +233,13 @@ findUsedLocs : {vars : _} -> findUsedLocs env tm = findUsed env VarSet.empty tm mkShrinkSub : {n : _} -> - (vars : _) -> VarSet (n :: vars) -> - (newvars ** Thin newvars (n :: vars)) -mkShrinkSub [] els + (vars : _) -> VarSet (Scope.bind vars n) -> + (newvars ** Thin newvars (Scope.bind vars n)) +mkShrinkSub [<] els = if first `VarSet.elem` els then (_ ** Keep Refl) else (_ ** Drop Refl) -mkShrinkSub (x :: xs) els +mkShrinkSub (xs :< x) els = let (_ ** subRest) = mkShrinkSub xs (VarSet.dropFirst els) in if first `VarSet.elem` els then (_ ** Keep subRest) @@ -250,8 +248,8 @@ mkShrinkSub (x :: xs) els mkShrink : {vars : _} -> VarSet 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 @@ -264,26 +262,26 @@ 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 (Scope.ext 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 : Scope) -> Env Term vs -mkEnv fc [] = [] -mkEnv fc (n :: ns) = PVar fc top Explicit (Erased fc Placeholder) :: mkEnv fc ns +mkEnv fc [<] = Env.empty +mkEnv fc (ns :< _) = Env.bind (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. @@ -293,7 +291,7 @@ export uniqifyEnv : {vars : _} -> Env Term vars -> (vars' ** (Env Term vars', CompatibleVars vars vars')) -uniqifyEnv env = uenv [] env +uniqifyEnv env = uenv Scope.empty env where next : Name -> Name next (MN n i) = MN n (i + 1) @@ -301,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 : Scope -> Name -> Name uniqueLocal vs n = if n `elem` vs -- we'll find a new name eventualy since the list of names @@ -313,50 +311,40 @@ uniqifyEnv env = uenv [] env else n uenv : {vars : _} -> - List Name -> Env Term vars -> + Scope -> 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 : {0 vars : _} -> Env Term vars -> List (Var vars) -allVars env = go env [<] where - - go : {0 vars : _} -> Env Term vars -> - {0 seen : SnocList Name} -> SizeOf seen -> - List (Var (seen <>> vars)) - go [] _ = [] - go (v :: vs) p = mkVarChiply p :: go vs (p :< _) +allVars [<] = [] +allVars (vs :< v) = first :: map weaken (allVars vs) export allVarsNoLet : {0 vars : _} -> Env Term vars -> List (Var vars) -allVarsNoLet env = go env [<] where - - go : {0 vars : _} -> Env Term vars -> - {0 seen : SnocList Name} -> SizeOf seen -> - List (Var (seen <>> vars)) - go [] _ = [] - go (Let _ _ _ _ :: vs) p = go vs (p :< _) - go (v :: vs) p = mkVarChiply p :: go vs (p :< _) +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 Scope.empty) - mkSubstEnv i [] = (zero, Subst.empty) - mkSubstEnv i (v :: vs) + mkSubstEnv i [<] = (zero, Subst.empty {tm = Term}) + 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 eb27c627891..75943480d18 100644 --- a/src/Core/GetType.idr +++ b/src/Core/GetType.idr @@ -32,7 +32,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.bind 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 @@ -84,7 +84,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/LinearCheck.idr b/src/Core/LinearCheck.idr index 6dbfac2cf6b..9316948f1ab 100644 --- a/src/Core/LinearCheck.idr +++ b/src/Core/LinearCheck.idr @@ -8,7 +8,9 @@ import Core.Options import Core.UnifyState import Core.Value -import Libraries.Data.List.SizeOf +import Data.SnocList +import Data.SnocList.Quantifiers + import Libraries.Data.SnocList.SizeOf %default covering @@ -16,14 +18,23 @@ 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 Usage : Scoped -Usage vars = List (Var vars) +Usage vars = SnocList (Var vars) -doneScope : Usage (n :: vars) -> Usage vars +doneScope : Usage (vars :< n) -> Usage vars doneScope = mapMaybe isLater +namespace Usage + public export + empty : Usage vars + empty = [<] + + public export + single : Var vars -> Usage vars + single a = [ 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 @@ -173,12 +184,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 Usage.single (MkVar prf) else Usage.empty lcheck rig erase env (Ref fc nt fn) = do logC "quantity" 15 $ do pure "lcheck Ref \{show (nt)} \{show !(toFullNames fn)}" ty <- lcheckDef fc rig erase env fn - pure (Ref fc nt fn, gnf env (embed ty), []) + pure (Ref fc nt fn, gnf env (embed ty), Usage.empty) -- If the meta has a definition, and we're not in Rig0, expand it first -- and check the result. @@ -238,7 +249,7 @@ mutual Lam {} => eraseLinear env _ => env else env - (sc', sct, usedsc) <- lcheck rig erase (b' :: env') sc + (sc', sct, usedsc) <- lcheck rig erase (Env.bind env' b') sc let used_in = count 0 usedsc holeFound <- if not erase && isLinear (multiplicity b) @@ -314,7 +325,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, Usage.empty) _ => needFunctionType f' gfty where @@ -349,14 +360,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, Usage.empty) 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, Usage.empty) 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), Usage.empty) lcheckBinder : {vars : _} -> {auto c : Ref Ctxt Defs} -> @@ -366,29 +377,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, Usage.empty) 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, Usage.empty) 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, Usage.empty) 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, Usage.empty) discharge : {vars : _} -> Defs -> Env Term vars -> FC -> (nm : Name) -> Binder (Term vars) -> Glued vars -> - Term (nm :: vars) -> Glued (nm :: vars) -> Usage vars -> + Term (Scope.bind vars nm) -> Glued (Scope.bind 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 @@ -487,12 +498,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) @@ -505,7 +516,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)) @@ -607,16 +621,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 Subst.empty + expandMeta rig erase env n idx (PMDef _ [<] (STerm _ fn) _ _) args + = do tm <- substMeta (embed fn) args zero (Subst.empty {tm = Term}) lcheck rig erase env tm where substMeta : {drop, vs : _} -> - Term (drop ++ vs) -> List (Term vs) -> + Term (Scope.addInner 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) (Subst.bind {tm = Term} 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) @@ -653,19 +667,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, Usage.empty) 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) @@ -676,7 +690,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 d75452e62a7..c4d236a344b 100644 --- a/src/Core/Metadata.idr +++ b/src/Core/Metadata.idr @@ -200,9 +200,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) = Env.bind (toPat bs) $ PVar fc c p ty + toPat (bs :< b) = Env.bind (toPat bs) b + toPat [<] = Env.empty -- For giving local variable names types, just substitute the name -- rather than storing the whole environment, otherwise we'll repeatedly @@ -214,8 +214,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 diff --git a/src/Core/Name.idr b/src/Core/Name.idr index d34e0776a7a..2e97822b70a 100644 --- a/src/Core/Name.idr +++ b/src/Core/Name.idr @@ -448,9 +448,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, 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/Scoped.idr b/src/Core/Name/Scoped.idr index 9eb207e7557..735ec7b1efe 100644 --- a/src/Core/Name/Scoped.idr +++ b/src/Core/Name/Scoped.idr @@ -1,10 +1,14 @@ module Core.Name.Scoped import public Core.Name +import Core.Name.CompatibleVars -import Libraries.Data.List.SizeOf +import Data.SnocList import public Libraries.Data.List.Thin +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.HasLength +import Libraries.Data.List.SizeOf %default total @@ -14,7 +18,7 @@ import public Libraries.Data.List.Thin ||| Something which is having similar order as Scope itself public export Scopeable : (a: Type) -> Type -Scopeable = List +Scopeable = SnocList ||| A scope is represented by a list of names. E.g. in the following ||| rule, the scope Γ is extended with x when going under the λx. @@ -30,28 +34,23 @@ Scope = Scopeable Name namespace Scope public export empty : Scopeable a - empty = [] + empty = [<] - {- public export ext : Scopeable a -> List a -> Scopeable a - ext vars ns = ns ++ vars - --- TODO replace by `vars <>< ns` - -} + ext vars ns = vars <>< ns public export addInner : Scopeable a -> Scopeable a -> Scopeable a - addInner vars inner = inner ++ vars - --- TODO replace by `vars ++ inner` + addInner vars inner = vars ++ inner public export bind : Scopeable a -> a -> Scopeable a - bind vars n = n :: vars - --- TODO replace with `<:` + bind vars n = vars :< n public export single : a -> Scopeable a - single n = [n] + single n = [ Type export scopeEq : (xs, ys : Scope) -> Maybe (xs = ys) -scopeEq [] [] = Just Refl -scopeEq (x :: xs) (y :: ys) +scopeEq [<] [<] = Just Refl +scopeEq (xs :< x) (ys :< y) = do Refl <- nameEq x y Refl <- scopeEq xs ys Just Refl scopeEq _ _ = Nothing +export +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 + ------------------------------------------------------------------------ -- Generate a fresh name (for a given scope) @@ -80,68 +88,23 @@ mkFresh vs n 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) - -export -invertExt : CompatibleVars (n :: xs) (m :: ys) -> CompatibleVars xs ys -invertExt Pre = Pre -invertExt (Ext p) = p - -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) - -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) - -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 - ------------------------------------------------------------------------ -- Concepts public export 0 Weakenable : Scoped -> Type Weakenable tm = {0 vars, ns : Scope} -> - SizeOf ns -> tm vars -> tm (ns ++ vars) + SizeOf ns -> tm vars -> tm (Scope.addInner 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 (Scope.addInner 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 (Scope.addInner local outer) -> tm (Scope.addInner local (Scope.addInner ns outer)) public export 0 Thinnable : Scoped -> Type @@ -153,7 +116,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 (Scope.addInner outer vars) ------------------------------------------------------------------------ -- IsScoped interface @@ -162,10 +125,13 @@ public export interface Weaken (0 tm : Scoped) where constructor MkWeaken -- methods - weaken : tm vars -> tm (nm :: vars) + weaken : tm vars -> tm (Scope.bind vars nm) weakenNs : Weakenable tm -- default implementations weaken = weakenNs (suc zero) + weakenNs p t = case sizedView p of + Z => t + S p => weaken (weakenNs p t) -- This cannot be merged with Weaken because of WkCExp public export @@ -175,8 +141,24 @@ interface GenWeaken (0 tm : Scoped) where export genWeaken : GenWeaken tm => - SizeOf local -> tm (local ++ outer) -> tm (local ++ n :: outer) -genWeaken l = genWeakenNs l (suc zero) + SizeOf outer -> tm (Scope.addInner local outer) -> tm (Scope.addInner (Scope.bind local n) outer) +genWeaken l = rewrite sym $ appendAssociative local [ + SizeOf outer -> tm (Scope.ext local outer) -> tm (Scope.ext (Scope.bind local n) outer) +genWeakenFishily + = rewrite fishAsSnocAppend local outer in + rewrite fishAsSnocAppend (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 @@ -185,9 +167,17 @@ interface Strengthen (0 tm : Scoped) where strengthenNs : Strengthenable tm export -strengthen : Strengthen tm => tm (nm :: vars) -> Maybe (tm vars) +strengthen : Strengthen tm => tm (Scope.bind vars nm) -> Maybe (tm vars) strengthen = strengthenNs (suc zero) +export +strengthensN : + Strengthen tm => SizeOf ns -> + tm (Scope.ext 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 @@ -195,6 +185,10 @@ interface FreelyEmbeddable (0 tm : Scoped) where embed : Embeddable tm embed = believe_me +export +embedFishily : FreelyEmbeddable tm => tm (cast ns) -> tm (Scope.ext vars ns) +embedFishily t = rewrite fishAsSnocAppend vars ns in embed t + export FunctorFreelyEmbeddable : Functor f => FreelyEmbeddable tm => FreelyEmbeddable (f . tm) FunctorFreelyEmbeddable = MkFreelyEmbeddable believe_me @@ -239,5 +233,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 (Scope.bind xs m) -> tm (Scope.bind xs n) compat = compatNs (Ext Pre) diff --git a/src/Core/Normalise.idr b/src/Core/Normalise.idr index e64610aada5..9f797d3da02 100644 --- a/src/Core/Normalise.idr +++ b/src/Core/Normalise.idr @@ -67,7 +67,7 @@ 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.bind env b) sc) normaliseLHS defs env tm = quote defs env !(nfOpts onLHS defs env tm) @@ -114,7 +114,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.bind env b) sc) normaliseScope defs env tm = normalise defs env tm export @@ -230,12 +230,12 @@ logEnv s n msg env where dumpEnv : {vs : Scope} -> Env Term vs -> Core () - dumpEnv [] = pure () - dumpEnv {vs = x :: _} (Let _ c val ty :: bs) + dumpEnv [<] = pure () + dumpEnv {vs = _ :< x} (bs :< Let _ c val ty) = do logTermNF' s n (msg ++ ": let " ++ show x) bs val logTermNF' s n (msg ++ ":" ++ show c ++ " " ++ show x) bs ty dumpEnv bs - dumpEnv {vs = x :: _} (b :: bs) + dumpEnv {vs = _ :< x} (bs :< b) = do logTermNF' s n (msg ++ ":" ++ show (multiplicity b) ++ " " ++ show (piInfo b) ++ " " ++ show x) bs (binderType b) @@ -262,25 +262,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 Scope.empty) 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 Scope.empty)) 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 Scope.empty)) args' repSub (NTCon fc n a args) = do args' <- traverse (traversePair repArg) args empty <- clearDefs defs - pure $ applyStackWithFC - !(quote empty env (NTCon fc n a [])) + pure $ applySpineWithFC + !(quote empty env (NTCon fc n a Scope.empty)) args' repSub (NAs fc s a p) = do a' <- repSub a @@ -296,7 +296,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')) @@ -324,8 +324,8 @@ normalisePrims : {auto c : Ref Ctxt Defs} -> {vs : _} -> -- list of primitives List Name -> -- view of the potential redex - (n : Name) -> -- function name - (args : List arg) -> -- arguments from inside out (arg1, ..., argk) + (n : Name) -> -- function name + (args : SnocList arg) -> -- arguments in reversed order [ -- original term (n arg1 ... argk) Env Term vs -> -- evaluation environment @@ -334,7 +334,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) = 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 8f65a4a4a3f..43ff0f3acce 100644 --- a/src/Core/Normalise/Convert.idr +++ b/src/Core/Normalise/Convert.idr @@ -8,11 +8,37 @@ import Core.Context import Core.Env import Core.Value +import Data.SnocList + import Libraries.Data.NatSet import Libraries.Data.List.SizeOf %default covering +extend : {args, args' : List Name} -> + SizeOf args -> SizeOf args' -> + (List (Var vars, Var vars')) -> + Maybe (List (Var (Scope.ext vars args), Var (Scope.ext vars' args'))) +extend s s' ms + = do guard (Libraries.Data.List.SizeOf.SizeOf.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 (Scope.ext vars args), Var (Scope.ext 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} -> @@ -44,13 +70,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) @@ -70,7 +91,7 @@ tryUpdate ms (Bind fc x b sc) tryUpdateB _ = Nothing weakenP : {n : _} -> (Var vars, Var vars') -> - (Var (n :: vars), Var (n :: vars')) + (Var (Scope.bind vars n), Var (Scope.bind 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) @@ -85,9 +106,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 @@ -96,9 +117,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 @@ -126,7 +147,7 @@ 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 (Closure vars) -> SnocList (Closure vars) -> Core Bool allConv q i defs env xs ys = do xsnf <- traverse (evalClosure defs) xs ysnf <- traverse (evalClosure defs) ys @@ -144,34 +165,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 (mkSizeOf cargs) (mkSizeOf 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 ((first, first) :: map weakenP rest) - extend _ _ _ = Nothing - - dropP : SizeOf cs -> SizeOf cs' -> - (Var (cs ++ args), Var (cs' ++ args')) -> - Maybe (Var args, Var args') - dropP cs cs' (x, y) = pure (!(strengthenNs cs x), !(strengthenNs cs' y)) - getMatchingVarAlt defs ms (ConstCase c t) (ConstCase c' t') = if c == c' then getMatchingVars defs ms t t' @@ -215,7 +224,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 @@ -231,10 +240,10 @@ 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') -> @@ -253,8 +262,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 @@ -280,9 +289,9 @@ mutual | Nothing => pure False let Just scpos' = findArgPos tree' | Nothing => pure False - let Just sc = getScrutinee scpos nargs + let Just sc = getScrutinee ((length nargs) `minus` scpos + 1) nargs | Nothing => pure False - let Just sc' = getScrutinee scpos' nargs' + let Just sc' = getScrutinee ((length nargs') `minus` scpos' + 1) nargs' | Nothing => pure False ignore $ convGen q i defs env sc sc' pure (location def == location def') @@ -293,9 +302,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 @@ -379,10 +388,10 @@ mutual getInfPos _ = pure NatSet.empty -- 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') diff --git a/src/Core/Normalise/Eval.idr b/src/Core/Normalise/Eval.idr index 2a5009dfc2a..9dd8bd13cd9 100644 --- a/src/Core/Normalise/Eval.idr +++ b/src/Core/Normalise/Eval.idr @@ -7,8 +7,11 @@ import Core.Primitives import Core.Value import Data.Vect +import Data.SnocList +import Data.SnocList.Quantifiers import Libraries.Data.WithDefault +import Libraries.Data.SnocList.Extra %default covering @@ -41,7 +44,7 @@ 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 (Scope.addInner free vars) -> Stack free -> Core (NF free) export evalClosure : {auto c : Ref Ctxt Defs} -> @@ -89,34 +92,34 @@ parameters (defs : Defs) (topopts : EvalOpts) eval : {auto c : Ref Ctxt Defs} -> {free, vars : _} -> Env Term free -> LocalEnv free vars -> - Term (vars ++ free) -> Stack free -> Core (NF free) + Term (Scope.addInner free vars) -> Stack free -> Core (NF free) eval env locs (Local fc mrig idx prf) stk = 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) + = 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 + = 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 (Scope.addInner free vars)) -> List (Closure free) - closeArgs [] = [] - closeArgs (t :: ts) = MkClosure topopts locs env t :: closeArgs ts + closeArgs : List (Term (Scope.addInner free vars)) -> SnocList (Closure free) + closeArgs [] = Scope.empty + closeArgs (t :: ts) = closeArgs ts :< 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 [] @@ -138,8 +141,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 @@ -164,16 +167,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) LocalEnv.empty + = evalLocal env fc mrig _ p (args <>> stk) LocalEnv.empty 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 a args) stk - = pure $ NTCon fc n a (args ++ stk) + = pure $ NTCon fc n a (args <>< stk) applyToStack env (NAs fc s p t) stk = if removeAs topopts then applyToStack env t stk @@ -189,8 +192,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' (Scope.ext 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 @@ -212,48 +215,48 @@ 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 (Scope.addInner 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 LocalEnv.empty 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) + _ => 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) = evalLocClosure env fc mrig stk x - evalLocal {vars = x :: xs} {free} - env fc mrig (S idx) (Later p) stk (_ :: locs) + 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 (Scope.addInner 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 (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 + = let args' = if isNil stk then map (EmptyFC,) (toList args) + else map (EmptyFC,) 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 @@ -267,11 +270,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 arity) fn stk def = do -- logC "eval.ref.type" 50 $ do fn' <- toFullNames fn -- pure $ "Found type constructor: " ++ show fn' - pure $ ntCon fc fn arity stk + pure $ ntCon fc fn 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,14 +312,14 @@ parameters (defs : Defs) (topopts : EvalOpts) else pure def -- TODO note the list of closures is stored RTL - getCaseBound : List (Closure free) -> + getCaseBound : SnocList (Closure free) -> (args : Scope) -> LocalEnv free more -> Maybe (LocalEnv free (Scope.addInner more args)) - 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 + 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} -> @@ -325,13 +328,14 @@ parameters (defs : Defs) (topopts : EvalOpts) LocalEnv free more -> EvalOpts -> FC -> Stack free -> (args : List Name) -> - List (Closure free) -> - CaseTree (Scope.addInner more args) -> + SnocList (Closure free) -> + CaseTree (Scope.ext 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 : _} -> @@ -368,15 +372,15 @@ 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 (LocalEnv.empty, stk) + argsFromStack (ns :< n) [] = Nothing + argsFromStack (ns :< n) (arg :: args) = do (loc', stk') <- argsFromStack ns args - pure (snd arg :: loc', stk') + pure (rewrite Extra.revOnto [ {arity, free : _} -> @@ -502,13 +506,13 @@ 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 (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}" diff --git a/src/Core/Normalise/Quote.idr b/src/Core/Normalise/Quote.idr index 9a400cdc6bd..6297e34f56d 100644 --- a/src/Core/Normalise/Quote.idr +++ b/src/Core/Normalise/Quote.idr @@ -5,6 +5,10 @@ import Core.Env import Core.Normalise.Eval import Core.Value +import Data.SnocList + +import Libraries.Data.SnocList.SizeOf + %default covering export @@ -60,7 +64,7 @@ mutual {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> Env Term free -> Closure free -> - Core (Term (bound ++ free)) + Core (Term (Scope.addInner free bound)) quoteArg q opts defs bounds env a = quoteGenNF q opts defs bounds env !(evalClosure defs a) @@ -68,22 +72,22 @@ mutual {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> Bounds bound -> Env Term free -> (FC, Closure free) -> - Core ((FC, Term (bound ++ free))) + Core ((FC, Term (Scope.addInner 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))) + Env Term free -> SnocList (Closure free) -> + Core (SnocList (Term (Scope.addInner free bound))) quoteArgs q opts defs bounds env = traverse (quoteArg q opts defs bounds env) 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 (Scope.addInner free bound))) quoteArgsWithFC q opts defs bounds env = traverse (quoteArgWithFC q opts defs bounds env) @@ -91,18 +95,10 @@ mutual {bound, free : _} -> Ref QVar Int -> QuoteOpts -> Defs -> FC -> Bounds bound -> Env Term free -> NHead free -> - Core (Term (bound ++ free)) + Core (Term (Scope.addInner 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) @@ -122,13 +118,13 @@ mutual 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' + pure $ Meta fc n i (toList 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 (Scope.addInner 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 @@ -140,7 +136,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 (Scope.addInner 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 @@ -169,7 +165,7 @@ 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 (Scope.addInner 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 @@ -187,17 +183,17 @@ mutual quoteArgsWithFC q opts' empty bound env args else quoteArgsWithFC q ({ topLevel := False } opts') defs bound env args - pure $ applyStackWithFC f' 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 ar args) = do args' <- quoteArgsWithFC q opts defs bound env args - pure $ applyStackWithFC (Ref fc (TyCon ar) n) args' + pure $ applySpineWithFC (Ref fc (TyCon 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 @@ -223,9 +219,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 @@ -246,7 +242,7 @@ Quote Closure where 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 (Scope.addInner vars bound)) quoteWithPiGen q opts defs bound env (NBind fc n (Pi bfc c p ty) sc) = do var <- genName "qv" empty <- clearDefs defs diff --git a/src/Core/Ord.idr b/src/Core/Ord.idr index 6e5ab99eb77..ed23d7789d7 100644 --- a/src/Core/Ord.idr +++ b/src/Core/Ord.idr @@ -46,7 +46,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 @@ -103,7 +103,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 1fe1a2a8cb4..0eafea6566b 100644 --- a/src/Core/Primitives.idr +++ b/src/Core/Primitives.idr @@ -531,7 +531,7 @@ doubleTy : ClosedTerm doubleTy = predTy DoubleType DoubleType pi : (x : String) -> RigCount -> PiInfo (Term xs) -> Term xs -> - Term (UN (Basic x) :: xs) -> Term xs + Term (Scope.bind 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 diff --git a/src/Core/Reflect.idr b/src/Core/Reflect.idr index c415b9599d1..805583d27ab 100644 --- a/src/Core/Reflect.idr +++ b/src/Core/Reflect.idr @@ -7,6 +7,8 @@ import Core.Env import Core.Normalise import Core.Value +import Data.SnocList + import Libraries.Data.WithDefault %default covering @@ -224,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" @@ -242,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') @@ -259,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) @@ -281,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') @@ -301,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" @@ -320,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" @@ -337,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) @@ -355,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) @@ -371,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) @@ -389,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" @@ -417,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') @@ -492,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"), [(_, i)]) + (UN (Basic "TyCon"), [<(_, i)]) => do i' <- reify defs !(evalClosure defs i) pure (TyCon i') _ => cantReify val "NameType" @@ -518,33 +520,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" @@ -553,49 +555,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" @@ -735,7 +737,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" @@ -773,7 +775,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" @@ -791,11 +793,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" @@ -809,13 +811,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" @@ -837,7 +839,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) @@ -865,11 +867,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 170485bec48..26219eb43ff 100644 --- a/src/Core/SchemeEval/Compile.idr +++ b/src/Core/SchemeEval/Compile.idr @@ -17,7 +17,8 @@ import Core.Directory import Core.SchemeEval.Builtins import Core.SchemeEval.ToScheme -import Data.List.Quantifiers +import Data.SnocList +import Data.SnocList.Quantifiers import Libraries.Utils.Scheme import System.Info @@ -80,18 +81,25 @@ SchVars : Scoped SchVars = All (\_ => SVar) Show (SchVars ns) where - show xs = show (toList xs) + show xs = show (toSnocList xs <>> []) where - -- TODO move to Data.List.Quantifiers - toList : forall ns . SchVars ns -> List String - toList [] = [] - toList (Bound x :: xs) = x :: toList xs - toList (Free x :: xs) = "'x" :: toList xs + -- TODO move to Data.SnocList.Quantifiers + toSnocList : forall ns . SchVars ns -> SnocList String + toSnocList [<] = [<] + toSnocList (xs :< Bound x) = toSnocList xs :< x + toSnocList (xs :< Free x) = toSnocList xs :< "'x" + +reverseOnto : SchVars varsl -> SchVars varsr -> SchVars (reverseOnto varsl varsr) +reverseOnto acc [<] = acc +reverseOnto acc (sx :< x) = reverseOnto (acc :< x) sx + +reverse : SchVars vars -> SchVars (reverse vars) +reverse = reverseOnto [<] 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 {- @@ -216,13 +224,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] @@ -230,7 +238,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] @@ -238,27 +246,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 @@ -298,12 +306,12 @@ getArgName extend : Ref Sym Integer => (args : List Name) -> SchVars vars -> - Core (List Name, SchVars (args ++ vars)) + Core (List Name, SchVars (Scope.ext 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') + (args', svs') <- extend args (svs :< Bound (schVarName n)) + pure (n :: args', svs') compileCase : Ref Sym Integer => {auto c : Ref Ctxt Defs} -> @@ -358,7 +366,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 (Scope.ext vars args) -> Core (SchemeObj Write) bindArgs var args sc = do (bind, svs') <- extend args svs @@ -393,7 +401,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 (Scope.ext vars args) -> Core (SchemeObj Write) bindArgs var args sc = do (bind, svs') <- extend args svs @@ -417,8 +425,8 @@ 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 sn) :< + Bound (schVarName tn) sc' <- compileCase blk svs' sc pure $ If (Apply (Var "ct-isPi") [Var var]) (Let (schVarName sn) (Apply (Var "vector-ref") [Var var, IntegerVal 4]) $ @@ -454,8 +462,8 @@ 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) @@ -471,20 +479,23 @@ 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 : Scope) -> SchVars ns +mkArgs [<] = [<] +mkArgs (xs :< x) = mkArgs xs :< Bound (schVarName x) -mkArgs : (ns : Scope) -> Core (SchVars ns) -mkArgs [] = pure [] -mkArgs (x :: xs) - = pure $ Bound (schVarName x) :: !(mkArgs xs) +mkArgNs : Int -> Nat -> Scope +mkArgNs i Z = [<] +mkArgNs i (S k) = mkArgNs (i-1) k :< MN "arg" i 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)] @@ -495,8 +506,9 @@ 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 blk = blockedAppWith n (varObjs argvs) + let argvs = mkArgs args + let argvsr = reverse argvs + let blk = blockedAppWith n (varObjs argvsr) body <- compileCase blk argvs treeCT let body' = if redok then If (Apply (Var "ct-isBlockAll") []) blk body @@ -504,40 +516,32 @@ compileBody redok n (PMDef pminfo args treeCT treeRT pats) -- If it arose from a hole, we need to take an extra argument for -- the arity since that's what Meta gets applied to case holeInfo pminfo of - NotHole => pure (bindArgs n argvs [] body') - SolvedHole _ => pure (Lambda ["h-0"] (bindArgs n argvs [] body')) + NotHole => pure (bindArgs n argvsr [] body') + SolvedHole _ => pure (Lambda ["h-0"] (bindArgs n argvsr [] body')) compileBody _ n (ExternDef arity) = pure $ blockedAppWith n [] compileBody _ n (ForeignDef arity xs) = pure $ blockedAppWith n [] compileBody _ n (Builtin x) = pure $ compileBuiltin n x 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 + = do let args = mkArgNs (cast arity - 1) arity + let argvs = mkArgs $ reverse 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 compileBody _ n (TCon Z parampos detpos flags mutwith datacons detagabbleBy) = pure $ Vector (-1) [StringVal (show n), toScheme n, toScheme emptyFC] compileBody _ n (TCon arity parampos detpos flags mutwith datacons detagabbleBy) - = do let args = mkArgNs 0 arity - argvs <- mkArgs args + = do let args = mkArgNs (cast arity - 1) arity + let argvs = mkArgs $ reverse args let body = Vector (-1) (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 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 b2453bae211..5acb6e1120f 100644 --- a/src/Core/SchemeEval/Evaluate.idr +++ b/src/Core/SchemeEval/Evaluate.idr @@ -5,6 +5,8 @@ import Core.Env import Core.SchemeEval.Compile import Core.SchemeEval.ToScheme +import Data.SnocList.Quantifiers + import Libraries.Data.NameMap import Libraries.Utils.Scheme @@ -84,17 +86,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) @@ -144,9 +146,9 @@ mutual -- Instead, decode the ForeignObj directly, which is uglier but faster. quoteVector : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> + SchVars (Scope.addInner vars outer) -> Integer -> List ForeignObj -> - Core (Term (outer ++ vars)) + Core (Term (Scope.addInner vars outer)) quoteVector svs (-2) [_, fname_in, args_in] -- Blocked app = quoteOrInvalid fname_in $ \ fname => do let argList = getArgList args_in @@ -271,9 +273,9 @@ mutual quotePiInfo : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> + SchVars (Scope.addInner vars outer) -> ForeignObj -> - Core (PiInfo (Term (outer ++ vars))) + Core (PiInfo (Term (Scope.addInner vars outer))) quotePiInfo svs obj = if isInteger obj then case unsafeGetInteger obj of @@ -301,49 +303,49 @@ mutual quoteBinder : Ref Sym Integer => Ref Ctxt Defs => - SchVars (outer ++ vars) -> + SchVars (Scope.addInner 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 (Scope.addInner vars outer)) -> + Term (Scope.addInner vars outer) -> -- decoded type Name -> -- bound name - Core (Term (outer ++ vars)) + Core (Term (Scope.addInner 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 (Scope.addInner vars outer) -> ForeignObj -> -- body of binder, represented as a function RigCount -> - Term (outer ++ vars) -> -- decoded type - Term (outer ++ vars) -> -- decoded value + Term (Scope.addInner vars outer) -> -- decoded type + Term (Scope.addInner vars outer) -> -- decoded value Name -> -- bound name - Core (Term (outer ++ vars)) + Core (Term (Scope.addInner 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 (Scope.addInner vars outer) -> ForeignObj -> + Core (Term (Scope.addInner vars outer)) quote' svs obj = if isVector obj then quoteVector svs (unsafeGetInteger (unsafeVectorRef obj 0)) @@ -360,8 +362,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 @@ -578,8 +580,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 6d64f46abb5..7c3ae92849e 100644 --- a/src/Core/SchemeEval/Quote.idr +++ b/src/Core/SchemeEval/Quote.idr @@ -10,7 +10,7 @@ mutual {bound, free : _} -> Ref Sym Integer -> Bounds bound -> Env Term free -> List (Core (SNF free)) -> - Core (List (Term (bound ++ free))) + Core (List (Term (Scope.addInner free bound))) quoteArgs q bound env args = traverse (\arg => do arg' <- arg quoteGen q bound env arg') args @@ -19,7 +19,7 @@ mutual {bound, free : _} -> Ref Sym Integer -> Bounds bound -> Env Term free -> PiInfo (SNF free) -> - Core (PiInfo (Term (bound ++ free))) + Core (PiInfo (Term (Scope.addInner free bound))) quotePi q bound env Explicit = pure Explicit quotePi q bound env Implicit = pure Implicit quotePi q bound env AutoImplicit = pure AutoImplicit @@ -31,7 +31,7 @@ mutual {bound, free : _} -> Ref Sym Integer -> Bounds bound -> Env Term free -> Binder (SNF free) -> - Core (Binder (Term (bound ++ free))) + Core (Binder (Term (Scope.addInner free bound))) quoteBinder q bound env (Lam fc r p ty) = do ty' <- quoteGen q bound env ty p' <- quotePi q bound env p @@ -60,16 +60,16 @@ mutual {bound, free : _} -> Ref Sym Integer -> FC -> Bounds bound -> Env Term free -> SHead free -> - Core (Term (bound ++ free)) + Core (Term (Scope.addInner 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 : Scope) -> (0 p : IsVar n idx xs) -> - Var (ys ++ xs) - addLater [] isv = MkVar isv - addLater (x :: xs) isv + Var (Scope.addInner 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) @@ -91,7 +91,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 (Scope.addInner 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 8925a9752aa..b36e196cba1 100644 --- a/src/Core/TT.idr +++ b/src/Core/TT.idr @@ -396,33 +396,43 @@ namespace Bounds public export data Bounds : Scoped where None : Bounds Scope.empty - Add : (x : Name) -> Name -> Bounds xs -> Bounds (x :: xs) + Add : (x : Name) -> Name -> Bounds xs -> Bounds (Scope.bind xs x) -- TODO add diagonal constructor 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 addVars : SizeOf outer -> Bounds bound -> - NVar name (outer ++ vars) -> - NVar name (outer ++ (bound ++ vars)) + NVar name (Scope.addInner vars outer) -> + NVar name (Scope.addInner 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 (Scope.addInner 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 (Scope.single new) done + resolveRef p (sucL q) bs fc n mkLocals : SizeOf outer -> Bounds bound -> - Term (outer ++ vars) -> Term (outer ++ (bound ++ vars)) + Term (Scope.addInner vars outer) -> Term (Scope.addInner 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) @@ -455,39 +465,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 (Scope.addInner 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 (Scope.bind 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 (Scope.addInner vars local) -> Term (Scope.addInner 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 3f15ac88983..63817b5c9b2 100644 --- a/src/Core/TT/Subst.idr +++ b/src/Core/TT/Subst.idr @@ -3,51 +3,61 @@ module Core.TT.Subst import Core.Name.Scoped import Core.TT.Var -import Libraries.Data.List.SizeOf +import Data.SnocList +import Data.SnocList.Quantifiers + +import Libraries.Data.SnocList.SizeOf %default total --- TODO replace by pointwise lifting: `Subst tm ds vars = All (\_. tm vars) ds` public export -data Subst : Scoped -> Scope -> Scoped where - Nil : Subst tm Scope.empty vars - (::) : tm vars -> Subst tm ds vars -> Subst tm (d :: ds) vars +Subst : Scoped -> Scope -> Scoped +Subst tm ds vars = All (\_ => tm vars) ds -public export -empty : Subst tm Scope.empty vars -empty = [] +export +cons : Subst tm ds vars -> tm vars -> Subst tm (v `cons` ds) vars +cons [<] p = Lin :< p +cons (ns :< s) p = cons ns {tm} p :< s + +namespace Subst + public export + empty : Subst tm Scope.empty vars + empty = [<] + public export + bind : Subst tm ds vars -> tm vars -> Subst tm (Scope.bind ds v) vars + bind = (:<) 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 {tm} (MkVar p) -- TODO revisit order of `dropped` and `Subst` export findDrop : (Var vars -> tm vars) -> SizeOf dropped -> - Var (dropped ++ vars) -> + Var (Scope.addInner vars dropped) -> Subst tm dropped vars -> tm vars findDrop k s var sub = case locateVar s var of - Left var => index sub var + Left var => index sub {tm} var Right var => k var export find : Weaken tm => (forall vars. Var vars -> tm vars) -> SizeOf outer -> SizeOf dropped -> - Var (outer ++ (dropped ++ vars)) -> + Var (Scope.addInner (Scope.addInner vars dropped) outer) -> Subst tm dropped vars -> - tm (outer ++ vars) + tm (Scope.addInner 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) + Right var => weakenNs outer (findDrop k {tm} dropped var sub) -- TODO rename `outer` public export @@ -57,5 +67,5 @@ Substitutable val tm SizeOf outer -> SizeOf dropped -> Subst val dropped vars -> - tm (outer ++ (dropped ++ vars)) -> - tm (outer ++ vars) + tm (Scope.addInner (Scope.addInner vars dropped) outer) -> + tm (Scope.addInner vars outer) diff --git a/src/Core/TT/Term.idr b/src/Core/TT/Term.idr index b1e613f6cf7..c3ecec3b3d6 100644 --- a/src/Core/TT/Term.idr +++ b/src/Core/TT/Term.idr @@ -3,16 +3,15 @@ module Core.TT.Term import Algebra import Core.FC - 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.String -import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf %default total @@ -126,7 +125,7 @@ data Term : Scoped where public export ClosedTerm : Type -ClosedTerm = Term [] +ClosedTerm = Term Scope.empty ------------------------------------------------------------------------ -- Weakening @@ -288,6 +287,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 @@ -318,6 +322,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 @@ -491,7 +502,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 (Scope.bind 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 95ee9e415b3..2209a69e81e 100644 --- a/src/Core/TT/Term/Subst.idr +++ b/src/Core/TT/Term/Subst.idr @@ -7,7 +7,9 @@ import Core.TT.Subst import Core.TT.Term import Core.TT.Var -import Libraries.Data.List.SizeOf +import Data.SnocList.Quantifiers + +import Libraries.Data.SnocList.SizeOf %default total @@ -15,6 +17,9 @@ public export SubstEnv : Scope -> Scoped SubstEnv = Subst Term +single : Term vars -> SubstEnv [ SubstEnv dropped vars -> Term (dropped ++ vars) -> Term vars +substs : SizeOf dropped -> SubstEnv dropped vars -> Term (Scope.addInner vars dropped) -> Term vars substs dropped env tm = substTerm zero dropped env tm export subst : Term vars -> Term (Scope.bind vars x) -> Term vars -subst val tm = substs (suc zero) [val] tm +subst val tm = substs (suc zero) (Subst.single val) tm diff --git a/src/Core/TT/Traversals.idr b/src/Core/TT/Traversals.idr index 7d853ab8742..316f9d55a27 100644 --- a/src/Core/TT/Traversals.idr +++ b/src/Core/TT/Traversals.idr @@ -9,12 +9,6 @@ import Libraries.Data.NameMap %default covering -- TODO fix future type error -export -unBinds : Term vars -> 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 19dfcc5eccf..1830cd940ce 100644 --- a/src/Core/TT/Var.idr +++ b/src/Core/TT/Var.idr @@ -1,20 +1,18 @@ module Core.TT.Var +import Core.Name.Scoped +import Core.Name.CompatibleVars + +import Data.DPair import Data.Fin import Data.List +import Data.List.HasLength import Data.So import Data.SnocList -import Core.Name.Scoped - import Libraries.Data.SnocList.HasLength import Libraries.Data.SnocList.SizeOf - -import Data.List.HasLength -import Data.DPair - import Libraries.Data.List.SizeOf - import Libraries.Data.Erased %default total @@ -29,15 +27,27 @@ 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 +namespace List + ||| IsVar n k ns is a proof that + ||| the name n + ||| is a position k + ||| in the list ns + public export + data IsVarL : a -> Nat -> List a -> Type where + First : IsVarL n Z (n :: ns) + Later : IsVarL n i ns -> IsVarL n (S i) (m :: ns) + + %name IsVarL idx + export 0 Last : HasLength (S n) vs -> Exists (\ nm => IsVar nm n vs) -Last {vs = []} p impossible +Last {vs = [<]} p impossible Last (S Z) = Evidence _ First Last (S (S p)) = bimap id Later (Last (S p)) @@ -50,55 +60,74 @@ 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 ||| 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 +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 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) +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 + +||| Compute the remaining scope once the target variable has been removed +public export +dropIsVarL : (ns : List a) -> {idx : Nat} -> (0 _ : IsVarL nm idx ns) -> List a +dropIsVarL (_ :: xs) First = xs +dropIsVarL (n :: xs) (Later p) = n :: dropIsVarL xs p ||| 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) +0 embedIsVar : IsVar x idx vars -> IsVar x idx (more ++ vars) embedIsVar First = First embedIsVar (Later p) = Later (embedIsVar p) ||| 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) +||| 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 weakenIsVarL : (s : SizeOf ns) -> IsVarL x idx xs -> IsVarL x (size s + idx) (ns ++ xs) +weakenIsVarL (MkSizeOf Z Z) p = p +weakenIsVarL (MkSizeOf (S k) (S l)) p = Later (weakenIsVarL (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 @@ -110,17 +139,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)) @@ -132,7 +161,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} @@ -141,15 +170,15 @@ record Var {0 a : Type} (vars : List a) where namespace Var export - first : Var (n :: ns) + first : Var (ns :< n) first = MkVar First 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) @@ -159,21 +188,21 @@ namespace Var last (MkSizeOf (S n) p) = Just (MkVar (snd $ Last p)) export -mkVar : SizeOf inner -> Var (inner ++ nm :: outer) +mkVar : SizeOf inner -> Var (Scope.addInner (Scope.bind 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 @@ -187,23 +216,30 @@ 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 List + public export + record NVarL {0 a : Type} (nm : a) (vars : List a) where + constructor MkNVarL + {nvarIdx : Nat} + 0 nvarPrf : IsVarL nm nvarIdx vars + namespace NVar export - first : NVar n (n :: ns) + first : NVar n (ns :< n) first = MkNVar First 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) @@ -216,48 +252,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 first -isDeBruijn (S k) (_ :: vs) = later <$> isDeBruijn k vs +isDeBruijn : Nat -> (vars : SnocList Name) -> Maybe (Var vars) +isDeBruijn Z (_ :< _) = pure 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) @@ -265,55 +297,56 @@ locateVar s v = bimap forgetName forgetName -- Weakening export -weakenNVar : SizeOf ns -> NVar name outer -> NVar name (ns ++ outer) -weakenNVar s (MkNVar {nvarIdx} p) - = MkNVar {nvarIdx = plus (size s) nvarIdx} (weakenIsVar s p) +weakenNVar : SizeOf ns -> NVar name inner -> NVar name (inner ++ ns) +weakenNVar s (MkNVar p) = MkNVar (weakenIsVar s p) export -embedNVar : NVar name ns -> NVar name (ns ++ outer) +weakenNVarL : SizeOf ns -> NVarL nm inner -> NVarL nm (ns ++ inner) +weakenNVarL s (MkNVarL p) = MkNVarL (weakenIsVarL s p) + +export +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 @@ -322,29 +355,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) @@ -448,7 +481,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 219873a1fdd..14e7fed61d7 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 (Scope.ext vars bnds), Term (Scope.ext 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.bind 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 aba6aa4dbea..8c1db75b313 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -296,9 +296,14 @@ 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) -> Scope -> Maybe Name +getName Z (xs :< x) = Just x +getName (S k) (xs :< x) = getName k xs +getName _ [<] = Nothing + mutual export {vars : _} -> TTC (Binder (Term vars)) where @@ -384,7 +389,7 @@ mutual 0 => do c <- fromBuf idx <- fromBuf name <- maybe (corrupt "Term") pure - (getAt idx vars) + (getName idx vars) pure (Local {name} emptyFC c idx (mkPrf idx)) 1 => do nt <- fromBuf; name <- fromBuf pure (Ref emptyFC nt name) @@ -415,7 +420,7 @@ mutual pure (apply emptyFC fn args) idxp => do c <- fromBuf let idx : Nat = fromInteger (cast (idxp - 13)) - let Just name = getAt idx vars + let Just name = getName idx vars | Nothing => corrupt "Term" pure (Local {name} emptyFC c idx (mkPrf idx)) @@ -514,16 +519,16 @@ mutual export {vars : _} -> TTC (Env Term vars) where - toBuf [] = pure () - toBuf ((::) bnd env) + toBuf [<] = pure () + toBuf {vars = _ :< _} (env :< bnd) = do toBuf bnd; toBuf env -- Length has to correspond to length of 'vars' - fromBuf {vars = []} = pure [] - fromBuf {vars = x :: xs} + fromBuf {vars = [<]} = pure Env.empty + fromBuf {vars = xs :< x} = do bnd <- fromBuf env <- fromBuf - pure (bnd :: env) + pure (Env.bind env bnd) export TTC Visibility where @@ -757,7 +762,7 @@ mutual = assert_total $ case !getTag of 0 => do fc <- fromBuf idx <- fromBuf - let Just x = getAt idx vars + let Just x = getName idx vars | Nothing => corrupt "CExp" pure (CLocal {x} fc (mkPrf idx)) 1 => do fc <- fromBuf diff --git a/src/Core/Termination/CallGraph.idr b/src/Core/Termination/CallGraph.idr index 4bfa8d7b0a4..3b3c1b93b77 100644 --- a/src/Core/Termination/CallGraph.idr +++ b/src/Core/Termination/CallGraph.idr @@ -6,11 +6,13 @@ import Core.Env import Core.Normalise import Core.Options import Core.Value - -import Libraries.Data.List.SizeOf -import Libraries.Data.SparseMatrix +import Core.Name.CompatibleVars import Data.String +import Data.SnocList.Quantifiers + +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SparseMatrix %default covering @@ -78,7 +80,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.bind 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 @@ -175,16 +177,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 Subst.empty + let (PMDef _ [<] (STerm _ tm) _ _) = definition gdef | _ => pure Unknown + tm <- substMeta (embed tm) args zero (Subst.empty {tm = Term}) sizeCompare fuel tm t where substMeta : {0 drop, vs : _} -> - Term (drop ++ vs) -> List (Term vs) -> + Term (Scope.addInner 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) diff --git a/src/Core/Termination/Positivity.idr b/src/Core/Termination/Positivity.idr index c81cf8d66e0..08ac11aaf1a 100644 --- a/src/Core/Termination/Positivity.idr +++ b/src/Core/Termination/Positivity.idr @@ -32,15 +32,15 @@ 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 (NDelay fc lr ty tm) = nameIn defs tyns !(evalClosure defs tm) nameIn defs tyns _ = pure False @@ -73,7 +73,7 @@ posArg defs tyns nf@(NTCon loc tc _ args) = let (params, indices) = testargs False <- anyM (nameIn defs tyns) !(traverse (evalClosure defs) indices) | True => pure (NotTerminating NotStrictlyPositive) - posArgs defs tyns params + posArgs defs tyns (toList params) -- 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" Env.empty nf @@ -88,7 +88,7 @@ posArg defs tyns nf@(NApp fc nh args) | True => do logNF "totality.positivity" 50 "Trusting an assertion" Env.empty nf pure IsTerminating logNF "totality.positivity" 50 "Found an application" Env.empty nf - args <- traverse (evalClosure defs . snd) args + args <- traverse (evalClosure defs . snd) (toList args) pure $ if !(anyM (nameIn defs tyns) args) then NotTerminating NotStrictlyPositive else IsTerminating diff --git a/src/Core/Transform.idr b/src/Core/Transform.idr index 2d0904a0b94..916218f5d2c 100644 --- a/src/Core/Transform.idr +++ b/src/Core/Transform.idr @@ -123,7 +123,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.bind 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 adf9a204a3c..8bf8ccc3404 100644 --- a/src/Core/Unify.idr +++ b/src/Core/Unify.idr @@ -10,11 +10,11 @@ import public Core.UnifyState import Core.Value import Data.Maybe +import Data.SnocList +import Data.SnocList.Quantifiers -import Libraries.Data.List.SizeOf - +import Libraries.Data.SnocList.SizeOf import Libraries.Data.VarSet - import Libraries.Data.IntMap import Libraries.Data.NameMap @@ -275,31 +275,51 @@ unifyArgs mode loc env (cx :: cxs) (cy :: cys) pure (union res cs) unifyArgs mode loc env _ _ = ufail loc "" +unifySpine : (Unify tm, Quote tm) => + {vars : _} -> + {auto c : Ref Ctxt Defs} -> + {auto u : Ref UST UState} -> + UnifyInfo -> FC -> Env Term vars -> + SnocList (tm vars) -> SnocList (tm vars) -> + Core UnifyResult +unifySpine mode loc env [<] [<] = pure success +unifySpine mode loc env (cxs :< cx) (cys :< cy) + = do -- Do later arguments first, since they may depend on earlier + -- arguments and use their solutions. + res <- unify (lower mode) loc env cx cy + cs <- unifySpine mode loc env cxs cys + pure (union cs res) +unifySpine mode loc env _ _ = ufail loc "" + -- Get the variables in an application argument list; fail if any arguments -- are not variables, fail if there's any repetition of variables -- We use this to check that the pattern unification rule is applicable -- when solving a metavariable applied to arguments -- We return a list (because the order matters) and a set (for easy -- querying) -getVars : List (NF vars) -> Maybe (List (Var vars), VarSet vars) +getVars : SnocList (NF vars) -> Maybe (SnocList (Var vars), VarSet vars) getVars = go [<] VarSet.empty where go : SnocList (Var vars) -> VarSet vars -> - List (NF vars) -> Maybe (List (Var vars), VarSet vars) - go acc got [] = Just (acc <>> [], got) - go acc got (NErased fc (Dotted t) :: xs) = go acc got (t :: xs) - go acc got (NApp fc (NLocal r idx p) [] :: xs) + SnocList (NF vars) -> Maybe (SnocList (Var vars), VarSet vars) + go acc got [<] = Just (acc, got) + go acc got (xs :< NErased fc (Dotted t)) = go acc got (xs :< t) + go acc got (xs :< NApp fc (NLocal r idx p) [<]) = let v := MkVar p in if v `VarSet.elem` got then Nothing else go (acc :< v) (VarSet.insert v got) xs - go acc got (NAs _ _ _ p :: xs) = go acc got (p :: xs) - go acc _ (_ :: xs) = Nothing + go acc got (xs :< NAs _ _ _ p) = go acc got (xs :< p) + go acc _ (xs :< _) = Nothing -- 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 @@ -319,8 +339,8 @@ 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 @@ -333,24 +353,24 @@ patternEnv {vars} env args let (newvars ** svs) = fromVarSet _ vsset in Just (newvars ** (updateVars vslist svs, svs)) -getVarsTm : List (Term vars) -> Maybe (List (Var vars), VarSet vars) +getVarsTm : SnocList (Term vars) -> Maybe (SnocList (Var vars), VarSet vars) getVarsTm = go [<] VarSet.empty where go : SnocList (Var vars) -> VarSet vars -> - List (Term vars) -> Maybe (List (Var vars), VarSet vars) - go acc got [] = Just (acc <>> [], got) - go acc got (Local fc r idx p :: xs) + SnocList (Term vars) -> Maybe (SnocList (Var vars), VarSet vars) + go acc got [<] = Just (acc, got) + go acc got (xs :< Local fc r idx p) = let v := MkVar p in if v `VarSet.elem` got then Nothing else go (acc :< v) (VarSet.insert v got) xs - go acc _ (_ :: xs) = Nothing + go acc _ (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 @@ -404,7 +424,7 @@ occursCheck fc env mode mname tm data IVars : Scope -> Scoped where INil : IVars Scope.empty newvars ICons : Maybe (Var newvars) -> IVars vs newvars -> - IVars (v :: vs) newvars + IVars (Scope.bind vs v) newvars Weaken (IVars vs) where weakenNs s INil = INil @@ -584,7 +604,7 @@ 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 + case !(patternEnvTm env (cast args)) of Nothing => pure False Just (newvars ** (locs, submv)) => case shrink soln submv of @@ -637,13 +657,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 : _} -> @@ -651,11 +671,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 @@ -673,11 +693,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 @@ -685,9 +705,9 @@ 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 -- If the rightmost arguments have the same type, or we don't -- know the types of the arguments, we'll get on with it. @@ -695,24 +715,24 @@ mutual 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 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 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') @@ -733,8 +753,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 a args') @@ -773,8 +793,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)) -> (soln : NF vars) -> Core UnifyResult postponePatVar swap mode loc env mname mref margs margs' tm @@ -790,9 +810,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 @@ -835,14 +855,14 @@ 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' @@ -900,7 +920,7 @@ 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 @@ -915,12 +935,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 @@ -951,19 +971,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 unifySpine mode loc env (map snd xargs) (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) @@ -977,8 +997,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 unifySpine mode loc env (Scope.addInner (map snd xargs') xargs) + (Scope.addInner (map snd yargs') yargs) else do xlocs <- localsIn xargs ylocs <- localsIn yargs -- Solve the one with the bigger context, and if they're @@ -997,9 +1017,9 @@ mutual pv (PV {}) = True pv _ = False - localsIn : List (Closure vars) -> Core Nat - localsIn [] = pure 0 - localsIn (c :: cs) + localsIn : SnocList (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) @@ -1016,7 +1036,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 unifySpine mode loc env (map snd xargs) (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 @@ -1025,7 +1045,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) + unifySpine mode loc env (map snd xargs) (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) @@ -1067,8 +1087,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.bind 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 +1127,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.bind 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)) @@ -1161,7 +1181,7 @@ mutual log "unify" 20 "WITH:" traverse_ (dumpArg env) ys -} - unifyArgs mode loc env (map snd xs) (map snd ys) + unifySpine mode loc env (map snd xs) (map snd ys) else convertError loc env (NDCon xfc x tagx ax xs) (NDCon yfc y tagy ay ys) @@ -1178,7 +1198,7 @@ mutual pure $ "Constructor " ++ show x logC "unify" 20 $ map (const "") $ traverse_ (dumpArg env) xs logC "unify" 20 $ map (const "") $ traverse_ (dumpArg env) ys - unifyArgs mode loc env xs ys + unifySpine mode loc env xs ys -- TODO: Type constructors are not necessarily injective. -- If we don't know it's injective, need to postpone the -- constraint. But before then, we need some way to decide @@ -1195,7 +1215,7 @@ mutual = unifyArgs mode loc env [xty, x] [yty, y] unifyNoEta mode loc env (NForce xfc _ x axs) (NForce yfc _ y ays) = do cs <- unify (lower mode) loc env x y - cs' <- unifyArgs mode loc env (map snd axs) (map snd ays) + cs' <- unifySpine mode loc env (map snd axs) (map snd ays) pure (union cs cs') unifyNoEta mode loc env x@(NApp xfc fx@(NMeta {}) axs) y@(NApp yfc fy@(NMeta {}) ays) @@ -1564,7 +1584,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 @@ -1576,7 +1596,7 @@ checkArgsSame (x :: xs) 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 Env.empty tm def) diff --git a/src/Core/UnifyState.idr b/src/Core/UnifyState.idr index 1c7c5f081e2..b15a70c097f 100644 --- a/src/Core/UnifyState.idr +++ b/src/Core/UnifyState.idr @@ -6,10 +6,11 @@ import Core.Env import Core.Normalise import Core.Value +import Data.SnocList + import Libraries.Data.IntMap import Libraries.Data.NameMap import Libraries.Data.WithDefault - import Libraries.Data.SnocList.HasLength %default covering @@ -309,71 +310,78 @@ 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) (Scope.single x) wkns in + mkConstantAppArgs lets fc env (cons x wkns) +mkConstantAppArgsSub {done} {vars = xs :< x} + lets fc (env :< b) (Drop p) wkns + = rewrite sym $ appendAssociative (done ++ xs) (Scope.single x) wkns in + mkConstantAppArgs lets fc env (cons x wkns) +mkConstantAppArgsSub {done} {vars = xs :< x} + lets fc (env :< b) (Keep p) wkns + = let rec = mkConstantAppArgsSub {done} lets fc env p (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) (Scope.single x) wkns in rec + else rewrite sym $ appendAssociative (done ++ xs) (Scope.single x) wkns in rec mkConstantAppArgsOthers : {vars : _} -> 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) (Scope.single x) wkns in + mkConstantAppArgsOthers lets fc env Refl (cons x wkns) +mkConstantAppArgsOthers {done} {vars = xs :< x} + lets fc (env :< b) (Keep p) wkns + = rewrite sym $ appendAssociative (done ++ xs) (Scope.single x) wkns in + mkConstantAppArgsOthers lets fc env p (cons x wkns) +mkConstantAppArgsOthers {done} {vars = xs :< x} + lets fc (env :< b) (Drop p) wkns + = let rec = mkConstantAppArgsOthers {done} lets fc env p (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) (Scope.single x) wkns in rec + else rewrite sym $ appendAssociative (done ++ xs) (Scope.single x) wkns in rec export applyTo : {vars : _} -> FC -> Term vars -> Env Term vars -> Term vars applyTo fc tm env = let args = reverse (mkConstantAppArgs {done = Scope.empty} False fc env [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + 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 = Scope.empty} True fc env [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + apply fc tm (rewrite sym (appendLinLeftNeutral vars) in args) export applyToSub : {vars : _} -> @@ -381,7 +389,7 @@ applyToSub : {vars : _} -> Thin smaller vars -> Term vars applyToSub fc tm env sub = let args = reverse (mkConstantAppArgsSub {done = Scope.empty} True fc env sub [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + apply fc tm (rewrite sym (appendLinLeftNeutral vars) in args) export applyToOthers : {vars : _} -> @@ -389,7 +397,7 @@ applyToOthers : {vars : _} -> Thin smaller vars -> Term vars applyToOthers fc tm env sub = let args = reverse (mkConstantAppArgsOthers {done = Scope.empty} True fc env sub [<]) in - apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) + 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 @@ -417,7 +425,7 @@ newMetaLets {vars} fc rig env n ty def nocyc lets where envArgs : List (Term vars) envArgs = let args = reverse (mkConstantAppArgs {done = Scope.empty} lets fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + (rewrite sym (appendLinLeftNeutral vars) in args) export newMeta : {vars : _} -> @@ -431,10 +439,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) @@ -463,7 +471,7 @@ newConstant {vars} fc rig env tm ty constrs where envArgs : List (Term vars) envArgs = let args = reverse (mkConstantAppArgs {done = Scope.empty} True fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + 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 @@ -485,7 +493,7 @@ newSearch {vars} fc rig depth def env n ty where envArgs : List (Term vars) envArgs = let args = reverse (mkConstantAppArgs {done = Scope.empty} False fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + rewrite sym (appendLinLeftNeutral vars) in args -- Add a hole which stands for a delayed elaborator export @@ -505,7 +513,7 @@ newDelayed {vars} fc rig env n ty where envArgs : List (Term vars) envArgs = let args = reverse (mkConstantAppArgs {done = Scope.empty} False fc env [<]) in - rewrite sym (appendNilRightNeutral vars) in args + rewrite sym (appendLinLeftNeutral vars) in args export tryErrorUnify : {auto c : Ref Ctxt Defs} -> @@ -612,7 +620,7 @@ checkUserHolesAfter base now = do gs_map <- getGuesses let gs = toList gs_map log "unify.unsolved" 10 $ "Unsolved guesses " ++ show gs - List.traverse_ (checkValidHole base) gs + Core.Core.List.traverse_ (checkValidHole base) gs hs_map <- getCurrentHoles let hs = toList hs_map let hs' = if any isUserName (map (snd . snd) hs) diff --git a/src/Core/Value.idr b/src/Core/Value.idr index f0fea423b7f..924021c24ef 100644 --- a/src/Core/Value.idr +++ b/src/Core/Value.idr @@ -3,7 +3,7 @@ module Core.Value import Core.Context import Core.Env -import Data.List.Quantifiers +import Data.SnocList.Quantifiers %default covering @@ -112,7 +112,7 @@ mutual 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 (Closure vars) -> NHead vars -- Values themselves. 'Closure' is an unevaluated thunk, which means @@ -124,16 +124,16 @@ mutual -- 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 -- TODO it looks like the list of closures is stored in spine order, c.f. `getCaseBounds` NTCon : FC -> Name -> (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 @@ -145,27 +145,32 @@ mutual public export ClosedClosure : Type -ClosedClosure = Closure [] +ClosedClosure = Closure Scope.empty public export ClosedNF : Type -ClosedNF = NF [] +ClosedNF = NF Scope.empty namespace LocalEnv public export empty : LocalEnv free Scope.empty - empty = [] + empty = [<] export -ntCon : FC -> Name -> Nat -> List (FC, Closure vars) -> NF vars +ntCon : FC -> Name -> 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")) Z [] = NType fc (MN "top" 0) -ntCon fc n Z [] = case isConstantType n of +ntCon fc (UN (Basic "Type")) Z [<] = NType fc (MN "top" 0) +ntCon fc n Z [<] = case isConstantType n of Just c => NPrimVal fc $ PrT c - Nothing => NTCon fc n Z [] + Nothing => NTCon fc n Z [<] ntCon fc n arity args = NTCon fc n arity args +export +cons : LocalEnv free vars -> Closure free -> LocalEnv free ([ FC getLoc (NBind fc _ _ _) = fc diff --git a/src/Idris/Elab/Implementation.idr b/src/Idris/Elab/Implementation.idr index 193fbbde528..9dae1293247 100644 --- a/src/Idris/Elab/Implementation.idr +++ b/src/Idris/Elab/Implementation.idr @@ -103,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.bind 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.bind env $ Pi fc' c (DefImplicit def) ty) sc pure ((x, c, Just rdef, rty) :: ts) getMethImps env tm = pure [] diff --git a/src/Idris/Elab/Interface.idr b/src/Idris/Elab/Interface.idr index 6436ac5727a..bb7bcb2cac1 100644 --- a/src/Idris/Elab/Interface.idr +++ b/src/Idris/Elab/Interface.idr @@ -14,6 +14,8 @@ import TTImp.Elab.Check import TTImp.TTImp import TTImp.Utils +import Data.SnocList + import Libraries.Data.ANameMap import Libraries.Data.List.Extra import Libraries.Data.WithDefault @@ -470,6 +472,6 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod meth_names params) nconstraints log "elab.interface" 5 $ "Constraint hints from " ++ show constraints ++ ": " ++ show chints - List.traverse_ (processDecl [] nest env) (concatMap snd chints) + Core.Core.List.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 b261dd85317..2fa5bf6cd26 100644 --- a/src/Idris/Error.idr +++ b/src/Idris/Error.idr @@ -526,8 +526,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.bind env b) sc + dropEnv env (Bind _ n b@(Let {}) sc) = dropEnv (Env.bind env b) sc dropEnv env tm = (_ ** (env, tm)) perrorRaw (DeterminingArg fc n i env g) diff --git a/src/Idris/IDEMode/Holes.idr b/src/Idris/IDEMode/Holes.idr index 9da5ff38ee3..0e918da837d 100644 --- a/src/Idris/IDEMode/Holes.idr +++ b/src/Idris/IDEMode/Holes.idr @@ -97,7 +97,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.bind env b) fn args sc let True = showName x | False => do log "ide-mode.hole" 10 $ "Not showing name: " ++ show x pure rest diff --git a/src/Idris/Parser.idr b/src/Idris/Parser.idr index 095156c7544..52b6846f6cf 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/REPL.idr b/src/Idris/REPL.idr index 15c7f1a2490..fb2fe2fae0b 100644 --- a/src/Idris/REPL.idr +++ b/src/Idris/REPL.idr @@ -151,7 +151,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.bind env b) sc else (_ ** (env, Bind fc x b sc)) getEnvTerm _ env tm = (_ ** (env, tm)) @@ -341,7 +341,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.bind env b) sc dropLamsTm _ env tm = (_ ** (env, tm)) findInTree : FilePos -> Name -> PosMap (NonEmptyFC, Name) -> Maybe Name @@ -583,7 +583,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 @@ -621,7 +621,7 @@ 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 => diff --git a/src/Libraries/Data/List/Thin.idr b/src/Libraries/Data/List/Thin.idr index 56fdb8b4660..4ed3f2351d4 100644 --- a/src/Libraries/Data/List/Thin.idr +++ b/src/Libraries/Data/List/Thin.idr @@ -4,41 +4,54 @@ import Libraries.Data.NatSet %default total --- TODO implement: --- Guillaume Allais: Builtin Types Viewed as Inductive Families --- https://doi.org/10.48550/arXiv.2301.02194 public export -data Thin : List a -> List a -> Type where +data Thin : SnocList a -> SnocList a -> Type where Refl : Thin xs xs - Drop : Thin xs ys -> Thin xs (y :: ys) - Keep : Thin xs ys -> Thin (x :: xs) (x :: ys) + Drop : Thin xs ys -> Thin xs (ys :< y) + Keep : Thin xs ys -> Thin (xs :< x) (ys :< x) +-- At runtime, Thin's `Refl` does not carry any additional +-- information. So this is safe! export -none : {xs : List a} -> Thin [] xs -none {xs = []} = Refl -none {xs = _ :: _} = Drop none +embed : Thin xs ys -> Thin (outer ++ xs) (outer ++ ys) +embed = believe_me + +export +none : {xs : SnocList a} -> Thin [<] xs +none {xs = [<]} = Refl +none {xs = _ :< _} = Drop none ||| 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 : Thin xs ys -> Thin (xs :< x) (ys :< x) keep Refl = Refl keep p = Keep p export -keeps : (args : List a) -> Thin xs ys -> Thin (args ++ xs) (args ++ ys) -keeps [] th = th -keeps (x :: xs) th = Keep (keeps xs th) +keeps : (args : SnocList a) -> Thin xs ys -> Thin (xs ++ args) (ys ++ args) +keeps [<] th = th +keeps (sx :< x) th = Keep (keeps sx th) + +export +keepz : (args : List a) -> Thin xs ys -> Thin (xs <>< args) (ys <>< args) +keepz [] th = th +keepz (x :: xs) th = keepz xs (keep th) export -fromNatSet : NatSet -> (xs : List a) -> (xs' ** Thin xs' xs) +fromNatSet : NatSet -> (xs : SnocList a) -> (xs' ** Thin xs' xs) fromNatSet ns xs = - if isEmpty ns then (_ ** Refl) else go 0 xs + if isEmpty ns then (_ ** Refl) else go (length xs) xs where - go : Nat -> (xs : List a) -> (xs' ** Thin xs' xs) - go i [] = (_ ** Refl) - go i (x :: xs) - = let (xs' ** th) = go (S i) xs in + go : Nat -> (xs : SnocList a) -> (xs' ** Thin xs' xs) + go i [<] = (_ ** Refl) + go (S i) (xs :< x) + = let (xs' ** th) = go i xs in if i `elem` ns then (xs' ** Drop th) - else (x :: xs' ** Keep th) + else (xs' :< x ** Keep th) + -- Next case can't happen if called with the right Nat from fromNatSet + -- FIXME: rule it out with a type! + -- Dupe see: Compiler.CompileExpr.mkDropSubst + -- Dupe see: Libraries.Data.NatSet.partition + go Z (xs :< x) = let (xs' ** th) = go Z xs in (xs' ** Drop th) diff --git a/src/Libraries/Data/NatSet.idr b/src/Libraries/Data/NatSet.idr index 5511b052a20..c52e889dfee 100644 --- a/src/Libraries/Data/NatSet.idr +++ b/src/Libraries/Data/NatSet.idr @@ -16,17 +16,31 @@ export %inline elem : Nat -> NatSet -> Bool elem = flip testBit -export -drop : NatSet -> List a -> List a -drop 0 xs = xs -drop ds xs = go 0 xs - where - go : Nat -> List a -> List a - go _ [] = [] - go i (x :: xs) - = if i `elem` ds - then go (S i) xs - else x :: go (S i) xs +namespace List + export + drop : NatSet -> List a -> List a + drop 0 xs = xs + drop ds xs = go 0 xs + where + go : Nat -> List a -> List a + go _ [] = [] + go i (x :: xs) + = if i `elem` ds + then go (S i) xs + else x :: go (S i) xs + +namespace SnocList + export + drop : NatSet -> SnocList a -> SnocList a + drop 0 xs = xs + drop ds xs = go 0 xs + where + go : Nat -> SnocList a -> SnocList a + go _ [<] = [<] + go i (xs :< x) + = if i `elem` ds + then go (S i) xs + else go (S i) xs :< x export %inline take : NatSet -> List a -> List a @@ -82,16 +96,21 @@ Show NatSet where show ns = show (toList ns) export -partition : NatSet -> List a -> (List a , List a) +partition : NatSet -> SnocList a -> (SnocList a , SnocList a) partition ps = go 0 where - go : Nat -> List a -> (List a , List a) - go i [] = ([], []) - go i (x :: xs) - = let xys = go (S i) xs in + go : Nat -> SnocList a -> (SnocList a , SnocList a) + go i [<] = ([<], [<]) + go (S i) (xs :< x) + = let (ps', ds') = go i xs in if i `elem` ps - then mapFst (x ::) xys - else mapSnd (x ::) xys + then (ps' :< x, ds') + else (ps', ds' :< x) + -- Next case can't happen if called with the right Nat from fromNatSet + -- FIXME: rule it out with a type! + -- Dupe see: Compiler.CompileExpr.mkDropSubst + -- Dupe see: Libraries.Data.List.Thin.fromNatSet + go Z (xs :< x) = let (ps', ds') = go Z xs in (ps' :< x, ds') export intersection : NatSet -> NatSet -> NatSet @@ -117,16 +136,16 @@ allLessThanSpecEmpty = Refl allLessThanSpecNonEmpty = Refl export -overwrite : a -> NatSet -> List a -> List a +overwrite : a -> NatSet -> SnocList a -> SnocList a overwrite c 0 xs = xs overwrite c ds xs = go 0 xs where - go : Nat -> List a -> List a - go _ [] = [] - go i (x :: xs) + go : Nat -> SnocList a -> SnocList a + go _ [<] = [<] + go i (xs :< x) = if i `elem` ds - then c :: go (S i) xs - else x :: go (S i) xs + then go (S i) xs :< c + else go (S i) xs :< x diff --git a/src/Libraries/Data/SnocList/Extra.idr b/src/Libraries/Data/SnocList/Extra.idr index 47999fd2bd4..c5700e2ee25 100644 --- a/src/Libraries/Data/SnocList/Extra.idr +++ b/src/Libraries/Data/SnocList/Extra.idr @@ -7,12 +7,10 @@ import Syntax.PreorderReasoning -- TODO left-to-right reversal of the stream -- is this what we want? -{- 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 : @@ -29,16 +27,12 @@ snocAppendAsFish sx sy = sym (cong (sx ++) (castToList sy)) export -lookup : Eq a => a -> SnocList (a, b) -> Maybe b -lookup n [<] = Nothing -lookup n (ns :< (x, n')) = if x == n then Just n' else lookup n ns - -lengthDistributesOverAppend - : (xs, ys : SnocList a) - -> length (ys ++ xs) = length xs + length ys -lengthDistributesOverAppend [<] ys = Refl -lengthDistributesOverAppend (xs :< x) ys = - cong S $ lengthDistributesOverAppend xs ys +revOnto : (xs, vs : SnocList a) -> reverseOnto xs vs = xs ++ reverse vs +revOnto xs [<] = Refl +revOnto xs (vs :< v) + = rewrite Extra.revOnto (xs :< v) vs in + rewrite Extra.revOnto [ (ys : List a) -> diff --git a/src/Libraries/Data/SnocList/HasLength.idr b/src/Libraries/Data/SnocList/HasLength.idr index b46ac1151da..3c5af2c19f0 100644 --- a/src/Libraries/Data/SnocList/HasLength.idr +++ b/src/Libraries/Data/SnocList/HasLength.idr @@ -5,6 +5,8 @@ import Data.Nat -- horrible hack import Data.List.HasLength as L +import Libraries.Data.SnocList.Extra + public export LHasLength : Nat -> List a -> Type LHasLength = L.HasLength @@ -52,12 +54,13 @@ hlChips {m = S m} {n} (S x) y = rewrite plusSuccRightSucc m n in hlChips x (S y) -{- + +-- TODO left-to-right reversal of the stream +-- is this what we want? export take : (n : Nat) -> (xs : Stream a) -> HasLength n (take n xs) take Z _ = Z -take (S n) (x :: xs) = S (take n xs) --} +take (S n) (x :: sx) = S (take n sx) export cast : {sy : _} -> (0 _ : SnocList.length sx = SnocList.length sy) -> diff --git a/src/Libraries/Data/SnocList/Quantifiers/Extra.idr b/src/Libraries/Data/SnocList/Quantifiers/Extra.idr new file mode 100644 index 00000000000..6b81683614e --- /dev/null +++ b/src/Libraries/Data/SnocList/Quantifiers/Extra.idr @@ -0,0 +1,20 @@ +module Libraries.Data.SnocList.Quantifiers.Extra + +import Data.SnocList +import Data.SnocList.Quantifiers +import Decidable.Equality + +%default total + +export +tail : All p (xs :< x) -> All p xs +tail (pxs :< _) = pxs + +export +head : All p (xs :< x) -> p x +head (_ :< px) = px + +export +tabulate : ((x : a) -> p x) -> (xs : SnocList a) -> All p xs +tabulate f [<] = [<] +tabulate f (xs :< x) = tabulate f xs :< f x diff --git a/src/Libraries/Data/SnocList/SizeOf.idr b/src/Libraries/Data/SnocList/SizeOf.idr index 2aee090eef6..a09172d5064 100644 --- a/src/Libraries/Data/SnocList/SizeOf.idr +++ b/src/Libraries/Data/SnocList/SizeOf.idr @@ -1,6 +1,8 @@ module Libraries.Data.SnocList.SizeOf import Data.SnocList + +import Libraries.Data.SnocList.Extra import Libraries.Data.SnocList.HasLength --------------------------------------- @@ -79,11 +81,11 @@ map (MkSizeOf n p) = MkSizeOf n (cast (sym $ lengthMap sx) p) where lengthMap [<] = Refl lengthMap (sx :< x) = cong S (lengthMap sx) -{- +-- TODO left-to-right reversal of the stream +-- is this what we want? 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/Libraries/Data/VarSet.idr b/src/Libraries/Data/VarSet.idr index ed4bf416372..a7481927be4 100644 --- a/src/Libraries/Data/VarSet.idr +++ b/src/Libraries/Data/VarSet.idr @@ -9,7 +9,7 @@ module Libraries.Data.VarSet import Core.Name.Scoped import Core.TT.Var -import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf import public Libraries.Data.VarSet.Core as VarSet @@ -21,13 +21,13 @@ singleton v = insert v Core.empty export %inline append : SizeOf inner -> VarSet inner -> VarSet outer -> - VarSet (inner ++ outer) + VarSet (addInner outer inner) append p inn out = union (embed {tm = VarSet} inn) (weakenNs {tm = VarSet} p out) export fromVarSet : (vars : Scope) -> VarSet vars -> (newvars ** Thin newvars vars) -fromVarSet [] xs = (Scope.empty ** Refl) -fromVarSet (n :: ns) xs = +fromVarSet [<] xs = (Scope.empty ** Refl) +fromVarSet (ns :< n) xs = let (_ ** svs) = fromVarSet ns (VarSet.dropFirst xs) in if first `VarSet.elem` xs then (_ ** Keep svs) diff --git a/src/Libraries/Data/VarSet/Core.idr b/src/Libraries/Data/VarSet/Core.idr index 98b6c4a62f9..49250cc2aea 100644 --- a/src/Libraries/Data/VarSet/Core.idr +++ b/src/Libraries/Data/VarSet/Core.idr @@ -7,7 +7,7 @@ import Libraries.Data.NatSet import Core.Name.Scoped import Core.TT.Var -import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf %default total @@ -63,11 +63,11 @@ toList = mapMaybe (`isDeBruijn` vs) . NatSet.toList -- other positions by -1 (useful when coming back from under -- a binder) export %inline -dropFirst : VarSet (v :: vs) -> VarSet vs +dropFirst : VarSet (vs :< v) -> VarSet vs dropFirst = NatSet.popZ export %inline -dropInner : SizeOf inner -> VarSet (inner ++ vs) -> VarSet vs +dropInner : SizeOf inner -> VarSet (Scope.addInner vs inner) -> VarSet vs dropInner p = NatSet.popNs p.size export %hint diff --git a/src/TTImp/Elab/Ambiguity.idr b/src/TTImp/Elab/Ambiguity.idr index aa553395f7f..badf502990c 100644 --- a/src/TTImp/Elab/Ambiguity.idr +++ b/src/TTImp/Elab/Ambiguity.idr @@ -203,8 +203,8 @@ mutual Defs -> Scopeable (Closure vars) -> Scopeable ClosedClosure -> Core Bool - mightMatchArgs defs [] [] = pure True - mightMatchArgs defs (x :: xs) (y :: ys) + mightMatchArgs defs [<] [<] = pure True + mightMatchArgs defs (xs :< x) (ys :< y) = do amatch <- mightMatchArg defs x y if amatch then mightMatchArgs defs xs ys diff --git a/src/TTImp/Elab/App.idr b/src/TTImp/Elab/App.idr index 9e992100ac4..11da1a6724b 100644 --- a/src/TTImp/Elab/App.idr +++ b/src/TTImp/Elab/App.idr @@ -12,7 +12,7 @@ import TTImp.Elab.Check import TTImp.Elab.Dot import TTImp.TTImp -import Data.List +import Data.SnocList import Data.Maybe import Libraries.Data.NatSet @@ -851,7 +851,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 dcf28e42438..74677e9a663 100644 --- a/src/TTImp/Elab/Binders.idr +++ b/src/TTImp/Elab/Binders.idr @@ -65,7 +65,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.bind env $ Pi fc rigf info' tyv let nest' = weaken (dropName n nest) scu <- uniVar fc (scopev, scopet) <- @@ -110,7 +110,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.bind env $ Lam fc rigb info' tyv let nest' = weaken (dropName n nest) (scopev, scopet) <- inScope fc env' (\e' => check {e=e'} rig elabinfo @@ -167,7 +167,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.bind env $ Lam fc rigb info' tyv ignore $ convert fc elabinfo env (gnf env tyv) (gnf env pty) let nest' = weaken (dropName n nest) pscnf <- normaliseHoles defs env' $ compat psc @@ -195,8 +195,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 (Scope.bind vars x))) weakenExp env Nothing = pure Nothing weakenExp env (Just gtm) = do tm <- getTerm gtm @@ -244,7 +244,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.bind 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 f4e6873b99a..91c509d49c5 100644 --- a/src/TTImp/Elab/Case.idr +++ b/src/TTImp/Elab/Case.idr @@ -49,11 +49,11 @@ changeVar old new (TForce fc r p) changeVar old new tm = tm 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 allow : Maybe (Var vs) -> Env Term vs -> Env Term vs allow Nothing env = env @@ -68,22 +68,22 @@ updateMults vars env where go : {0 vs : Scope} -> VarSet vs -> Env Term vs -> Env Term vs - go vars [] = [] - go vars (b :: env) - = (if first `VarSet.elem` vars + go vars [<] = Env.empty + go vars (env :< b) + = updateMults (VarSet.dropFirst vars) env + :< (if first `VarSet.elem` vars then setMultiplicity b erased else b) - :: updateMults (VarSet.dropFirst vars) env 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 @@ -104,7 +104,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 first else do MkVar p <- findScrutinee bs (IVar loc' n) @@ -267,12 +267,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 [] = Env.empty - mkLocalEnv (b :: bs) + mkLocalEnv [<] = Env.empty + 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 @@ -288,8 +288,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 diff --git a/src/TTImp/Elab/Check.idr b/src/TTImp/Elab/Check.idr index 186632e3f4e..297ab3e21d7 100644 --- a/src/TTImp/Elab/Check.idr +++ b/src/TTImp/Elab/Check.idr @@ -18,9 +18,7 @@ import Libraries.Data.IntMap import Libraries.Data.NameMap import Libraries.Data.UserNameMap import Libraries.Data.WithDefault - -import Libraries.Data.List.SizeOf - +import Libraries.Data.SnocList.SizeOf import Libraries.Data.VarSet %default covering @@ -186,7 +184,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 $ @@ -199,7 +197,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) @@ -207,8 +205,8 @@ weakenedEState {e} strengthenedEState : {n, vars : _} -> Ref Ctxt Defs -> - Ref EST (EState (n :: vars)) -> - FC -> Env Term (n :: vars) -> + Ref EST (EState (Scope.bind vars n)) -> + FC -> Env Term (Scope.bind vars n) -> Core (EState vars) strengthenedEState {n} {vars} c e fc env = do est <- get EST @@ -224,7 +222,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") @@ -235,27 +233,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 (Scope.bind 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 (Scope.bind vars n)) -> Core (Name, ImplBinding vars) strTms defs (f, NameBinding fc c p x y) = do xnf <- normaliseHoles defs env x @@ -282,8 +280,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 (Scope.bind vars n) -> + (Ref EST (EState (Scope.bind vars n)) -> Core a) -> Core a inScope {c} {e} fc env elab = do e' <- weakenedEState @@ -444,7 +442,7 @@ 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))) + Core (vars' ** (Term (Scope.addInner vars vars') -> Term vars, Env Term (Scope.addInner vars vars'))) envHints [] env = pure (Scope.empty ** (id, env)) envHints (n :: ns) env = do (vs ** (f, env')) <- envHints ns env @@ -460,9 +458,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 ((Scope.bind vs varn) ** (\t => f (Bind fc varn binder t), - binder :: env')) + Env.bind env' binder)) -- Elaboration info (passed to recursive calls) public export diff --git a/src/TTImp/Elab/Delayed.idr b/src/TTImp/Elab/Delayed.idr index 0e33395bf96..bc975346fad 100644 --- a/src/TTImp/Elab/Delayed.idr +++ b/src/TTImp/Elab/Delayed.idr @@ -10,6 +10,8 @@ import Core.Value import TTImp.Elab.Check +import Data.SnocList + import Libraries.Data.IntMap import Libraries.Data.NameMap @@ -21,10 +23,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 diff --git a/src/TTImp/Elab/ImplicitBind.idr b/src/TTImp/Elab/ImplicitBind.idr index 345a4407491..d26200dd667 100644 --- a/src/TTImp/Elab/ImplicitBind.idr +++ b/src/TTImp/Elab/ImplicitBind.idr @@ -17,6 +17,7 @@ import TTImp.TTImp import Libraries.Data.NameMap import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.HasLength %default covering @@ -77,16 +78,15 @@ mkPatternHole {vars'} loc rig n topenv imode (Just expty_in) Nothing => mkPatternHole loc rig n topenv imode Nothing Just exp' => do tm <- implBindVar loc rig env n exp' - pure (apply loc (thin tm sub) (mkArgs [<] sub), + pure (Core.TT.Term.apply loc (thin tm sub) (mkArgs sub), expected, thin exp' sub) where - mkArgs : {0 vs : _} -> SizeOf seen -> Thin newvars vs -> List (Term (seen <>> vs)) - mkArgs p Refl = [] - mkArgs p (Drop th) = - let MkVar v := mkVarChiply p in - Local loc Nothing _ v :: mkArgs (p :< _) th - mkArgs p _ = [] + -- TODO: generalise and get rid of (map weaken) + mkArgs : {vs : _} -> Thin newvars vs -> List (Term vs) + mkArgs Refl = [] + mkArgs {vs = _ :< _} (Drop p) = Local loc Nothing 0 First :: map weaken (mkArgs p) + mkArgs _ = [] -- This is for the specific situation where we're pattern matching on -- function types, which is realistically the only time we'll legitimately @@ -95,7 +95,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 @@ -164,34 +164,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 = first swapP (Later x) = MkVar (Later (Later x)) swapIsVar : (vs : Scope) -> - {idx : Nat} -> (0 p : IsVar nm idx (vs ++ x :: y :: xs)) -> - Var (vs ++ y :: x :: xs) -swapIsVar [] prf = swapIsVarH prf -swapIsVar (x :: xs) First = first -swapIsVar (x :: xs) (Later p) + {idx : Nat} -> (0 p : IsVar nm idx (xs :< y :< x ++ vs)) -> + Var (xs :< x :< y ++ vs) +swapIsVar [<] prf = swapIsVarH prf +swapIsVar (xs :< x) First = first +swapIsVar (xs :< x) (Later p) = let MkVar p' = swapIsVar xs p in MkVar (Later p') swapVars : {vs : Scope} -> - Term (vs ++ x :: y :: ys) -> Term (vs ++ y :: x :: ys) + 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) @@ -207,7 +207,7 @@ 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 @@ -254,7 +254,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 (Scope.addInner vs new), Term (Scope.addInner 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 @@ -280,7 +280,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 diff --git a/src/TTImp/Elab/Record.idr b/src/TTImp/Elab/Record.idr index 7f1694d0fe6..9778f3dd2f4 100644 --- a/src/TTImp/Elab/Record.idr +++ b/src/TTImp/Elab/Record.idr @@ -13,6 +13,7 @@ import TTImp.Elab.Delayed import TTImp.TTImp import Data.SortedSet +import Data.SnocList %default covering diff --git a/src/TTImp/Elab/Rewrite.idr b/src/TTImp/Elab/Rewrite.idr index 7c901ed2bd2..029d1fc49b7 100644 --- a/src/TTImp/Elab/Rewrite.idr +++ b/src/TTImp/Elab/Rewrite.idr @@ -13,7 +13,9 @@ import TTImp.Elab.Check import TTImp.Elab.Delayed import TTImp.TTImp -import Libraries.Data.List.SizeOf +import Data.SnocList + +import Libraries.Data.SnocList.SizeOf %default covering @@ -33,8 +35,8 @@ getRewriteTerms : {vars : _} -> Core (NF vars, NF vars, NF vars) getRewriteTerms loc defs (NTCon nfc eq 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)) @@ -132,7 +134,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 @@ -140,9 +142,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 [ 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 @@ -147,25 +149,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 @@ -178,14 +180,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" [ AvailablePerLine (cast w) 1) mlw scriptRet $ render' pw Nothing $ pretty {ann=IdrisSyntax} ptm - elabCon defs "Check" [exp, ttimp] + elabCon defs "Check" [ failWith defs "Not a lambda" @@ -249,7 +251,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) @@ -260,23 +262,23 @@ 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" [] - = scriptRet vars - elabCon defs "GenSym" [str] + elabCon defs "LocalVars" [<] + = scriptRet $ asList vars + elabCon defs "GenSym" [ Core (Name, RawImp) unelabType (n, _, ty) = pure (n, map rawName !(unelabUniqueBinders Env.empty ty)) - elabCon defs "GetInfo" [n] + 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 $ fromMaybe [] 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) diff --git a/src/TTImp/Elab/Utils.idr b/src/TTImp/Elab/Utils.idr index 7e6c4c649e7..131b4cdec7e 100644 --- a/src/TTImp/Elab/Utils.idr +++ b/src/TTImp/Elab/Utils.idr @@ -9,10 +9,14 @@ import Core.Value import TTImp.Elab.Check import TTImp.TTImp +import Data.SnocList +import Data.SnocList.Quantifiers + import Libraries.Data.NatSet import Libraries.Data.VarSet - import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Quantifiers.Extra as Lib %default covering @@ -22,7 +26,7 @@ detagSafe defs (NTCon _ n _ args) = do Just (TCon _ _ _ _ _ _ (Just detags)) <- lookupDefExact n (gamma defs) | _ => pure False args' <- traverse (evalClosure defs . snd) args - pure $ NatSet.isEmpty detags || notErased 0 detags args' + pure $ NatSet.isEmpty detags || notErased 0 detags (toList args') where -- if any argument positions are in the non-empty(!) detaggable set, and unerased, then -- detagging is safe @@ -88,16 +92,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 {vs = _ :< _} 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 {vs = _ :< _} 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) @@ -110,14 +114,14 @@ bindReq {vs} fc env Refl ns tm = pure (ns, notLets [] _ env, abstractEnvType fc env tm) where notLets : List Name -> (vars : Scope) -> Env Term vars -> List Name - notLets acc [] _ = acc - notLets acc (v :: vs) (b :: env) = if isLet b then notLets acc vs env + 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 {vs = _ :< _} 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 @@ -162,20 +166,29 @@ setUsed : {auto u : Ref Used (Usage vars)} -> Var vars -> Core () setUsed p = update Used $ setUsedVar p -extendUsed : ArgUsed -> SizeOf inner -> Usage vars -> Usage (inner ++ vars) +extendUsed : ArgUsed -> SizeOf inner -> Usage vars -> Usage (Scope.ext vars inner) extendUsed LocalVar p (MkUsage iu il) - = MkUsage (weakenNs {tm = VarSet} p iu) (append p (full p) il) + = let p' = cast p in + rewrite fishAsSnocAppend vars inner in + MkUsage (weakenNs {tm = VarSet} p' iu) (append p' (full p') il) extendUsed Used0 p (MkUsage iu il) - = MkUsage (weakenNs {tm = VarSet} p iu) (weakenNs {tm = VarSet} p il) + = let p' = cast p in + rewrite fishAsSnocAppend vars inner in + MkUsage (weakenNs {tm = VarSet} p' iu) (weakenNs {tm = VarSet} p' il) extendUsed Used1 p (MkUsage iu il) - = MkUsage (append p (full p) iu) (weakenNs {tm = VarSet} p il) + = let p' = cast p in + rewrite fishAsSnocAppend vars inner in + MkUsage (append p' (full p') iu) (weakenNs {tm = VarSet} p' il) -dropUsed : SizeOf inner -> Usage (inner ++ vars) -> Usage vars -dropUsed p (MkUsage iu il) = MkUsage (VarSet.dropInner p iu) (dropInner p il) +dropUsed : SizeOf inner -> Usage (Scope.ext vars inner) -> Usage vars +dropUsed p (MkUsage iu il) = let p' = cast p in + MkUsage + (VarSet.dropInner {vs = vars} p' (rewrite sym $ fishAsSnocAppend vars inner in iu)) + (dropInner {vs = vars} p' (rewrite sym $ fishAsSnocAppend vars inner in il)) inExtended : ArgUsed -> SizeOf new -> {auto u : Ref Used (Usage vars)} -> - (Ref Used (Usage (new ++ vars)) -> Core a) -> + (Ref Used (Usage (Scope.ext 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 0d83090bc84..c31efb22bd7 100644 --- a/src/TTImp/Impossible.idr +++ b/src/TTImp/Impossible.idr @@ -188,8 +188,8 @@ getImpossibleTerm env nest tm where addEnv : {vars : _} -> FC -> Env Term vars -> List RawImp - addEnv fc [] = [] - addEnv fc (b :: env) = + addEnv fc [<] = [] + addEnv {vars = _ :< _} 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 2a34be93414..abc6a89489c 100644 --- a/src/TTImp/Interactive/CaseSplit.idr +++ b/src/TTImp/Interactive/CaseSplit.idr @@ -69,8 +69,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.bind env b) n sc findTyName _ _ _ _ = pure Nothing getDefining : Term vars -> Maybe Name diff --git a/src/TTImp/Interactive/ExprSearch.idr b/src/TTImp/Interactive/ExprSearch.idr index 89e9bd81215..cbff34cf632 100644 --- a/src/TTImp/Interactive/ExprSearch.idr +++ b/src/TTImp/Interactive/ExprSearch.idr @@ -27,7 +27,9 @@ import TTImp.TTImp.Functor import TTImp.Unelab import TTImp.Utils -import Libraries.Data.List.SizeOf +import Data.SnocList + +import Libraries.Data.SnocList.SizeOf import Libraries.Data.Tap import Libraries.Data.WithDefault @@ -141,18 +143,18 @@ getAllEnv : {vars : _} -> FC -> SizeOf done -> Env Term vars -> -- TODO should be `vars <>< done` - List (Term (done ++ vars), Term (done ++ vars)) -getAllEnv fc done [] = [] -getAllEnv {vars = v :: vs} {done} fc p (b :: env) - = let rest = getAllEnv fc (sucR p) env + List (Term (Scope.addInner vars done), Term (Scope.addInner vars done)) +getAllEnv fc done [<] = [] +getAllEnv {vars = vs :< v} {done} fc p (env :< b) + = let rest = getAllEnv fc (sucL p) env 0 var = mkIsVar (hasLength p) usable = usableName v in if usable then (Local fc Nothing _ var, - rewrite appendAssociative done [v] vs in - weakenNs (sucR p) (binderType b)) :: - rewrite appendAssociative done [v] vs in rest - else rewrite appendAssociative done [v] vs in rest + rewrite sym (appendAssociative vs (Scope.single v) done) in + weakenNs (sucL p) (binderType b)) :: + rewrite sym (appendAssociative vs (Scope.single v) done) in rest + else rewrite sym (appendAssociative vs (Scope.single v) done) in rest where usableName : Name -> Bool usableName (UN _) = True @@ -471,7 +473,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")) @@ -487,15 +489,15 @@ 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), + (\arg => applySpineWithFC (Ref fc Func fname) + [<(fc1, xtytm), (fc2, ytytm), (fc, f arg)]) xtynf target), (do ytynf <- evalClosure defs yty findPos defs prf - (\arg => applyStackWithFC (Ref fc Func sname) - [(fc1, xtytm), + (\arg => applySpineWithFC (Ref fc Func sname) + [<(fc1, xtytm), (fc2, ytytm), (fc, f arg)]) ytynf target)] @@ -533,7 +535,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.bind env $ Lam fc top Explicit letty scopeMeta <- metaVar fc top env' helpern (weaken targetty) let scope = toApp scopeMeta @@ -678,7 +680,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.bind 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) @@ -688,7 +690,7 @@ searchType {vars} fc rig opts hints env topty Z (Bind bfc n b@(Pi fc' c info ty) [searchLocal fc rig opts hints env (Bind bfc n b sc) topty, (do defs <- get Ctxt let n' = UN $ Basic !(getArgName defs n [] (toList vars) !(nf defs env ty)) - let env' : Env Term (n' :: _) = b :: env + let env' : Env Term (_ :< n') = Env.bind 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' @@ -832,7 +834,7 @@ 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) _ _ + | PMDef pi [<] (STerm _ tm) _ _ => do raw <- unelab Env.empty !(toFullNames !(normaliseHoles defs Env.empty tm)) one (map rawName raw) | _ => throw (GenericMsg fc "Name is already defined") diff --git a/src/TTImp/Interactive/Intro.idr b/src/TTImp/Interactive/Intro.idr index 241a782117a..e4b87526ca6 100644 --- a/src/TTImp/Interactive/Intro.idr +++ b/src/TTImp/Interactive/Intro.idr @@ -16,6 +16,8 @@ import TTImp.TTImp import TTImp.Unelab import TTImp.Utils +import Data.SnocList + import Libraries.Data.NatSet %default covering diff --git a/src/TTImp/Interactive/MakeLemma.idr b/src/TTImp/Interactive/MakeLemma.idr index f854a59af8f..32d5d4b5acd 100644 --- a/src/TTImp/Interactive/MakeLemma.idr +++ b/src/TTImp/Interactive/MakeLemma.idr @@ -10,6 +10,8 @@ import TTImp.TTImp import TTImp.TTImp.Functor import TTImp.Utils +import Data.SnocList + %default covering used : RigCount -> Bool @@ -45,7 +47,7 @@ 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 (toList $ map nameRoot vars) (nameRoot x)) - (sc', ty) <- getArgs (b :: env) k (compat {n = x'} sc) + (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 diff --git a/src/TTImp/PartialEval.idr b/src/TTImp/PartialEval.idr index e4814723527..f0d35f96e6e 100644 --- a/src/TTImp/PartialEval.idr +++ b/src/TTImp/PartialEval.idr @@ -369,18 +369,18 @@ eraseInferred (Bind fc x b tm) tm' <- eraseInferred tm pure (Bind fc x b' tm') eraseInferred tm - = case getFnArgs tm of - (f, []) => pure f + = case getFnArgsSpine tm of + (f, [<]) => pure f (Ref fc Func n, args) => do defs <- get Ctxt Just gdef <- lookupCtxtExact n (gamma defs) | Nothing => pure tm let argsE = NatSet.overwrite (Erased fc Placeholder) (inferrable gdef) args argsE' <- traverse eraseInferred argsE - pure (apply fc (Ref fc Func n) argsE') + pure (applySpine fc (Ref fc Func n) argsE') (f, args) => do args' <- traverse eraseInferred args - pure (apply (getLoc f) f args) + pure (applySpine (getLoc f) f args) -- Specialise a function name according to arguments. Return the specialised -- application on success, or Nothing if it's not specialisable (due to static @@ -453,7 +453,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.bind env b') [] sc pure $ applyStackWithFC (Bind fc x b' sc') stk findSpecs env stk (App fc fn arg) = do arg' <- findSpecs env [] arg @@ -490,12 +490,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 (Scope.addInner 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} -> @@ -504,8 +504,8 @@ 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 (Scope.addInner free bound))) quoteArgsWithFC q defs bounds env terms = pure $ zip (map fst terms) !(quoteArgs q defs bounds env (map snd terms)) @@ -517,17 +517,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 (Scope.addInner 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) @@ -547,7 +540,7 @@ mutual 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' + pure $ Meta fc n i (toList args') quotePi : {bound, free : _} -> {auto c : Ref Ctxt Defs} -> @@ -557,7 +550,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 (Scope.addInner 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 @@ -573,7 +566,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 (Scope.addInner 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 @@ -606,7 +599,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 (Scope.addInner 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 @@ -619,35 +612,35 @@ 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' args' <- quoteArgsWithFC q defs bound env args let False = NatSet.isEmpty (specArgs gdef) - | _ => pure $ applyStackWithFC (Ref fc Func fn) args' - Just r <- specialise fc (extendEnv bound env) gdef fn args' + | _ => pure $ applySpineWithFC (Ref fc Func fn) args' + Just r <- specialise fc (extendEnv bound env) gdef fn (toList args') | Nothing => -- can't specialise, keep the arguments -- unreduced do empty <- clearDefs defs 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 (Scope.addInner 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 ar args) = do args' <- quoteArgsWithFC q defs bound env args - pure $ applyStackWithFC (Ref fc (TyCon ar) n) args' + pure $ applySpineWithFC (Ref fc (TyCon 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 @@ -672,9 +665,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 43c9a9ab63e..aa9de3da48a 100644 --- a/src/TTImp/ProcessData.idr +++ b/src/TTImp/ProcessData.idr @@ -18,6 +18,8 @@ import TTImp.Elab import TTImp.TTImp import Data.DPair +import Data.SnocList + import Libraries.Data.NameMap import Libraries.Data.NatSet import Libraries.Data.WithDefault @@ -154,10 +156,10 @@ getDetags fc tys pure $ ds <$ guard (not (isEmpty ds)) where mutual - disjointArgs : List ClosedNF -> List ClosedNF -> Core Bool - disjointArgs [] _ = pure False - disjointArgs _ [] = pure False - disjointArgs (a :: args) (a' :: args') + disjointArgs : SnocList ClosedNF -> SnocList ClosedNF -> Core Bool + disjointArgs [<] _ = pure False + disjointArgs _ [<] = pure False + disjointArgs (args :< a) (args' :< a') = if !(disjoint a a') then pure True else disjointArgs args args' @@ -504,7 +506,7 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpData dfc n_in mty_raw o if ok then pure (mw, vis, tot, fullty) else do logTermNF "declare.data" 1 "Previous" Env.empty (type ndef) logTermNF "declare.data" 1 "Now" Env.empty fullty - throw (CantConvert fc (gamma defs) Env.empty (type ndef) fullty) + throw (AlreadyDefined fc n) _ => throw (AlreadyDefined fc n) logTermNF "declare.data" 5 ("data " ++ show n) Env.empty fullty diff --git a/src/TTImp/ProcessDecls.idr b/src/TTImp/ProcessDecls.idr index c79bbf429d2..5717028d747 100644 --- a/src/TTImp/ProcessDecls.idr +++ b/src/TTImp/ProcessDecls.idr @@ -27,6 +27,8 @@ import TTImp.TTImp import TTImp.ProcessDecls.Totality +import Data.SnocList + import Libraries.Text.PrettyPrint.Prettyprinter.Doc %default covering diff --git a/src/TTImp/ProcessDef.idr b/src/TTImp/ProcessDef.idr index e7e57e918c2..0d0373af64e 100644 --- a/src/TTImp/ProcessDef.idr +++ b/src/TTImp/ProcessDef.idr @@ -39,7 +39,7 @@ import Data.Maybe import Libraries.Data.NameMap import Libraries.Data.WithDefault import Libraries.Text.PrettyPrint.Prettyprinter -import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf %default covering @@ -246,13 +246,13 @@ extendEnv env p nest (Bind _ n (PVar fc c pi tmty) sc) (Bind _ n' (PVTy {}) tysc 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 (dropName n nest)) sc tysc + = extendEnv (Env.bind env $ PVar fc c pi tmty) (Drop p) (weaken (dropName n 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 (dropName n nest)) sc tysc + = extendEnv (Env.bind env $ Let fc c tmval tmty) (Drop p) (weaken (dropName n nest)) sc tysc extendEnv env p nest tm ty = pure (_ ** (p, env, nest, tm, ty)) @@ -388,7 +388,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 (asList vars) lhs_bound logC "declare.def.lhs" 5 $ do pure $ "Checking LHS of " ++ show !(getFullName (Resolved n)) -- todo: add Pretty RawImp instance @@ -439,7 +439,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.bind env b) sc) hasEmptyPat defs env _ = pure False -- For checking with blocks as nested names @@ -630,23 +630,23 @@ checkClause {vars} mult vis totreq hashit n opts nest env (rig : RigCount) -> (wvalTy : Term xs) -> Maybe ((RigCount, Name), Term xs) -> (wvalEnv : Env Term xs) -> Core (ext : Scope - ** ( Env Term (ext ++ xs) - , Term (ext ++ xs) - , (Term (ext ++ xs) -> Term xs) + ** ( Env Term (Scope.addInner xs ext) + , Term (Scope.addInner xs ext) + , (Term (Scope.addInner xs ext) -> Term xs) )) bindWithArgs {xs} rig wvalTy Nothing wvalEnv = let wargn : Name wargn = MN "warg" 0 wargs : Scope - wargs = [wargn] + wargs = [ Term xs + binder : Term (Scope.addInner xs wargs) -> Term xs := Bind vfc wargn (Pi vfc rig Explicit wvalTy) in pure (wargs ** (scenv, var, binder)) @@ -662,10 +662,10 @@ checkClause {vars} mult vis totreq hashit n opts nest env let wargn : Name wargn = MN "warg" 0 wargs : Scope - wargs = [name, wargn] + wargs = [ Term xs + binder : Term (Scope.addInner xs wargs) -> Term xs := \ t => Bind vfc wargn (Pi vfc rig Explicit wvalTy) $ Bind vfc name (Pi vfc rigPrf Implicit eqTy) t @@ -695,16 +695,16 @@ checkClause {vars} mult vis totreq hashit n opts nest env (vs'' : Scope ** Thin vs'' vs) keepOldEnv {vs} Refl p = (vs ** Refl) keepOldEnv {vs} p Refl = (vs ** Refl) - keepOldEnv (Drop p) (Drop p') + keepOldEnv {vs = _ :< _} (Drop p) (Drop p') = let (_ ** rest) = keepOldEnv p p' in (_ ** Drop rest) - keepOldEnv (Drop p) (Keep p') + keepOldEnv {vs = _ :< _} (Drop p) (Keep p') = let (_ ** rest) = keepOldEnv p p' in (_ ** Keep rest) - keepOldEnv (Keep p) (Drop p') + keepOldEnv {vs = _ :< _} (Keep p) (Drop p') = let (_ ** rest) = keepOldEnv p p' in (_ ** Keep rest) - keepOldEnv (Keep p) (Keep p') + keepOldEnv {vs = _ :< _} (Keep p) (Keep p') = let (_ ** rest) = keepOldEnv p p' in (_ ** Keep rest) diff --git a/src/TTImp/ProcessFnOpt.idr b/src/TTImp/ProcessFnOpt.idr index 0b019ab1916..177ae1f14fa 100644 --- a/src/TTImp/ProcessFnOpt.idr +++ b/src/TTImp/ProcessFnOpt.idr @@ -7,6 +7,8 @@ import Core.Value import TTImp.TTImp +import Data.SnocList + import Libraries.Data.NameMap import Libraries.Data.NatSet @@ -110,10 +112,10 @@ processFnOpt fc _ ndef (SpecArgs ns) -- Return names the type depends on, and whether it's a parameter mutual - getDepsArgs : Bool -> List ClosedNF -> NameMap Bool -> + getDepsArgs : Bool -> SnocList ClosedNF -> 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' diff --git a/src/TTImp/ProcessParams.idr b/src/TTImp/ProcessParams.idr index 35ca12f8b54..1a4d0feadd6 100644 --- a/src/TTImp/ProcessParams.idr +++ b/src/TTImp/ProcessParams.idr @@ -12,6 +12,8 @@ import TTImp.Elab import TTImp.Elab.Check import TTImp.TTImp +import Data.SnocList + %default covering extend : {extvs : _} -> @@ -20,7 +22,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 diff --git a/src/TTImp/ProcessRecord.idr b/src/TTImp/ProcessRecord.idr index 7f1712befd2..72bff9c0f3b 100644 --- a/src/TTImp/ProcessRecord.idr +++ b/src/TTImp/ProcessRecord.idr @@ -164,7 +164,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- We'll use the `env` thus obtained to unelab the remaining scope dropLeadingPis : {vs : _} -> (vars : Scope) -> Term vs -> Env Term vs -> Core (vars' : Scope ** (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." @@ -172,8 +172,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.bind env b) dropLeadingPis _ ty _ = throw (InternalError "Malformed record type \{show ty}") getParameters : @@ -251,7 +251,7 @@ 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 (Env.bind tyenv b) sc else do let fldNameStr = nameRoot n let unName = UN $ Basic fldNameStr @@ -334,7 +334,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' (Env.bind tyenv b) sc elabGetters tn con _ done upds _ _ = pure () diff --git a/src/TTImp/ProcessType.idr b/src/TTImp/ProcessType.idr index 6fd5105bb9c..a0ed560b731 100644 --- a/src/TTImp/ProcessType.idr +++ b/src/TTImp/ProcessType.idr @@ -93,15 +93,15 @@ findInferrable defs ty = fi 0 0 [] NatSet.empty ty -- inferrable if it's guarded by a constructor, or on its own findInf : NatSet -> List (Name, Nat) -> ClosedNF -> Core NatSet - findInf acc pos (NApp _ (NRef Bound n) []) + 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 (NatSet.insert 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 diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr index 55d8f6ea40a..0be86516faa 100644 --- a/src/TTImp/Reflect.idr +++ b/src/TTImp/Reflect.idr @@ -7,6 +7,9 @@ import Core.Reflect import Core.Value import TTImp.TTImp + +import Data.SnocList + import Libraries.Data.WithDefault %default covering @@ -15,7 +18,7 @@ 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 @@ -89,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) @@ -101,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) @@ -109,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) @@ -118,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) @@ -247,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') @@ -266,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" @@ -281,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" @@ -309,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 fc' <- reify defs !(evalClosure defs w) name' <- the (Core (WithFC Name)) (reify defs !(evalClosure defs y)) term' <- reify defs !(evalClosure defs z) @@ -321,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 @@ -335,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) @@ -354,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 fc <- reify defs !(evalClosure defs v) rig <- reify defs !(evalClosure defs w) info <- reify defs !(evalClosure defs x) @@ -368,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 fc <- reify defs !(evalClosure defs v) tyName <- reify defs !(evalClosure defs w) params <- reify defs !(evalClosure defs x) @@ -384,7 +387,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 +396,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 +410,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 +421,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 "MkIClaimData"), [ do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) @@ -431,49 +434,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' (map fromOldParams 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 8cb9104e251..5f68563aa4a 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -9,7 +9,7 @@ import Data.String import public Data.List1 import Data.SortedSet -import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf import Libraries.Data.WithDefault %default covering @@ -31,7 +31,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 (Scope.addInner vars wkns)), FC -> NameType -> Term (Scope.addInner vars wkns))) wknName (n, (mn, vars, rep)) = (n, (mn, map (weakenNs s) vars, \fc, nt => weakenNs s (rep fc nt))) diff --git a/src/TTImp/Unelab.idr b/src/TTImp/Unelab.idr index 52cc3d6ef0f..2465b3a7e15 100644 --- a/src/TTImp/Unelab.idr +++ b/src/TTImp/Unelab.idr @@ -11,7 +11,7 @@ import TTImp.TTImp import Data.String import Libraries.Data.VarSet -import Libraries.Data.List.SizeOf +import Libraries.Data.SnocList.SizeOf %default covering @@ -69,7 +69,7 @@ mutual List (Name, Nat) -> Env Term vars -> Name -> - List (Term vars) -> + SnocList (Term vars) -> Core (Maybe IRawImp) unelabCase nest env n args = do defs <- get Ctxt @@ -89,8 +89,13 @@ mutual findArgPos (Case idx p _ _) = Just idx findArgPos _ = Nothing + idxOrMaybe : Nat -> SnocList a -> Maybe a + idxOrMaybe Z (_ :< x) = Just x + idxOrMaybe (S k) (xs :< _) = idxOrMaybe k xs + idxOrMaybe _ [<] = Nothing + -- TODO: some utility like this should probably be implemented in Core - substVars : List (VarSet vs, Term vs) -> Term vs -> Term vs + substVars : SnocList (VarSet vs, Term vs) -> Term vs -> Term vs substVars xs tm@(Local fc _ idx prf) = case find ((MkVar prf `VarSet.elem`) . fst) xs of Just (_, new) => new @@ -111,7 +116,7 @@ mutual = TForce fc r (substVars xs y) substVars xs tm = tm - substArgs : SizeOf vs -> List (VarSet vs, Term vars) -> Term vs -> Term (vs ++ vars) + substArgs : SizeOf vs -> SnocList (VarSet vs, Term vars) -> Term vs -> Term (Scope.addInner vars vs) substArgs p substs tm = let substs' = map (bimap (embed {tm = VarSet} {outer = vars}) (weakenNs p)) substs @@ -125,13 +130,13 @@ mutual argVars acc _ = acc mkClause : FC -> Nat -> - List (Term vars) -> + SnocList (Term vars) -> (vs ** (Env Term vs, Term vs, Term vs)) -> Core (Maybe IImpClause) mkClause fc argpos args (vs ** (clauseEnv, lhs, rhs)) = do logTerm "unelab.case.clause" 20 "Unelaborating clause" lhs - let patArgs = snd (getFnArgs lhs) - Just pat = getAt argpos patArgs + let patArgs = snd (getFnArgsSpine lhs) + Just pat = idxOrMaybe argpos patArgs | _ => pure Nothing rhs = substArgs (mkSizeOf vs) (zip (map (argVars (VarSet.empty {vs})) patArgs) args) rhs logTerm "unelab.case.clause" 20 "Unelaborating LHS" pat @@ -148,11 +153,11 @@ mutual ||| Once we have the scrutinee `e`, we can form `case e of` and so focus ||| on manufacturing the clauses. mkCase : List (vs ** (Env Term vs, Term vs, Term vs)) -> - (argpos : Nat) -> List (Term vars) -> Core (Maybe IRawImp) + (argpos : Nat) -> SnocList (Term vars) -> Core (Maybe IRawImp) mkCase pats argpos args = do unless (null args) $ log "unelab.case.clause" 20 $ - unwords $ "Ignoring" :: map show args - let Just scrutinee = getAt argpos args + unwords $ "Ignoring" :: map show (toList args) + let Just scrutinee = idxOrMaybe argpos args | _ => pure Nothing fc = getLoc scrutinee (tm, _) <- unelabTy Full nest env scrutinee @@ -235,13 +240,13 @@ mutual = case umode of NoSugar True => do let x' = uniqueLocal vars x - let sc : Term (x' :: vars) = compat sc - (sc', scty) <- unelabTy umode nest (b :: env) sc + let sc : Term (Scope.bind vars x') = compat sc + (sc', scty) <- unelabTy umode nest (Env.bind env b) sc unelabBinder umode nest fc env x' b (compat sc) sc' (compat !(getTerm scty)) _ => do - (sc', scty) <- unelabTy umode nest (b :: env) sc + (sc', scty) <- unelabTy umode nest (Env.bind env b) sc unelabBinder umode nest fc env x b sc sc' !(getTerm scty) where next : Name -> Name @@ -264,7 +269,7 @@ mutual case umode of (NoSugar _) => pure Nothing ImplicitHoles => pure Nothing - _ => case getFnArgs tm of + _ => case getFnArgsSpine tm of (Ref _ _ fnName, args) => do fullName <- getFullName fnName let (NS ns (CaseBlock n i)) = fullName @@ -327,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 (Scope.bind vars x) -> + IRawImp -> Term (Scope.bind 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 diff --git a/src/TTImp/Utils.idr b/src/TTImp/Utils.idr index 4146040eb7d..9be2ac8eec8 100644 --- a/src/TTImp/Utils.idr +++ b/src/TTImp/Utils.idr @@ -580,7 +580,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/tests/idris2/basic/basic044/expected b/tests/idris2/basic/basic044/expected index e6d7a545bdc..f3f215437c9 100644 --- a/tests/idris2/basic/basic044/expected +++ b/tests/idris2/basic/basic044/expected @@ -96,13 +96,13 @@ LOG declare.def:3: Initially missing in Term.NF: Term> Bye for now! 1/1: Building Vec (Vec.idr) LOG declare.type:1: Processing Vec.Vec -LOG declare.def:2: Case tree for Vec.Vec: [0] ({arg:1} : (Data.Fin.Fin {arg:2}[1])) -> {arg:3}[1] +LOG declare.def:2: Case tree for Vec.Vec: [0] ({arg:1} : (Data.Fin.Fin {arg:2}[0])) -> {arg:3}[2] LOG declare.type:1: Processing Vec.Nil LOG declare.def:2: Case tree for Vec.Nil: [0] (Prelude.Uninhabited.absurd {arg:3}[0] (Data.Fin.Fin Prelude.Types.Z) Data.Fin.Uninhabited implementation at Data.Fin:1) LOG declare.type:1: Processing Vec.(::) -LOG declare.def:2: Case tree for Vec.(::): case {arg:4}[4] : (Data.Fin.Fin (Prelude.Types.S {arg:3}[0])) of +LOG declare.def:2: Case tree for Vec.(::): case {arg:4}[0] : (Data.Fin.Fin (Prelude.Types.S {arg:3}[4])) of { Data.Fin.FZ {e:1} => [0] {arg:5}[3] - | Data.Fin.FS {e:2} {e:3} => [1] ({arg:6}[5] {e:3}[1]) + | Data.Fin.FS {e:2} {e:3} => [1] ({arg:6}[3] {e:3}[0]) } LOG declare.type:1: Processing Vec.test LOG elab.ambiguous:5: Ambiguous elaboration at Vec:1: diff --git a/tests/idris2/data/data006/expected b/tests/idris2/data/data006/expected index 6d967382a9d..cb82a1d4552 100644 --- a/tests/idris2/data/data006/expected +++ b/tests/idris2/data/data006/expected @@ -1,5 +1,5 @@ 1/1: Building ConvertPiInfo (ConvertPiInfo.idr) -Error: Mismatch between: Type -> Type and Type. +Error: Main.EI is already defined. ConvertPiInfo:6:1--6:35 2 | -- Explicit -- @@ -9,7 +9,7 @@ ConvertPiInfo:6:1--6:35 6 | data EI : {_ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type -> Type and Type => Type. +Error: Main.EA is already defined. ConvertPiInfo:9:1--9:40 5 | data EI : Type -> Type @@ -19,7 +19,7 @@ ConvertPiInfo:9:1--9:40 9 | data EA : {auto _ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type -> Type and {default Int _ : Type} -> Type. +Error: Main.ED is already defined. ConvertPiInfo:12:1--12:47 08 | data EA : Type -> Type @@ -29,7 +29,7 @@ ConvertPiInfo:12:1--12:47 12 | data ED : {default Int _ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type and Type -> Type. +Error: Main.IE is already defined. ConvertPiInfo:19:1--19:29 15 | -- Implicit -- @@ -39,7 +39,7 @@ ConvertPiInfo:19:1--19:29 19 | data IE : Type -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type and Type => Type. +Error: Main.IA is already defined. ConvertPiInfo:22:1--22:40 18 | data IE : {_ : Type} -> Type @@ -49,7 +49,7 @@ ConvertPiInfo:22:1--22:40 22 | data IA : {auto _ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type and {default Int _ : Type} -> Type. +Error: Main.ID is already defined. ConvertPiInfo:25:1--25:47 21 | data IA : {_ : Type} -> Type @@ -59,7 +59,7 @@ ConvertPiInfo:25:1--25:47 25 | data ID : {default Int _ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type => Type and Type -> Type. +Error: Main.AE is already defined. ConvertPiInfo:32:1--32:29 28 | -- Auto -- @@ -69,7 +69,7 @@ ConvertPiInfo:32:1--32:29 32 | data AE : Type -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type => Type and Type. +Error: Main.AI is already defined. ConvertPiInfo:35:1--35:35 31 | data AE : {auto _ : Type} -> Type @@ -79,7 +79,7 @@ ConvertPiInfo:35:1--35:35 35 | data AI : {_ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: Type => Type and {default Int _ : Type} -> Type. +Error: Main.AD is already defined. ConvertPiInfo:38:1--38:47 34 | data AI : {auto _ : Type} -> Type @@ -89,7 +89,7 @@ ConvertPiInfo:38:1--38:47 38 | data AD : {default Int _ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: {default Int _ : Type} -> Type and Type -> Type. +Error: Main.DE is already defined. ConvertPiInfo:45:1--45:29 41 | -- Default -- @@ -99,7 +99,7 @@ ConvertPiInfo:45:1--45:29 45 | data DE : Type -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: {default Int _ : Type} -> Type and Type. +Error: Main.DI is already defined. ConvertPiInfo:48:1--48:35 44 | data DE : {default Int _ : Type} -> Type @@ -109,7 +109,7 @@ ConvertPiInfo:48:1--48:35 48 | data DI : {_ : Type} -> Type where ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Mismatch between: {default Int _ : Type} -> Type and Type => Type. +Error: Main.DA is already defined. ConvertPiInfo:51:1--51:40 47 | data DI : {default Int _ : Type} -> Type diff --git a/tests/idris2/data/record019/expected b/tests/idris2/data/record019/expected index 73808c60e6e..f3fb08ee2fb 100644 --- a/tests/idris2/data/record019/expected +++ b/tests/idris2/data/record019/expected @@ -11,7 +11,7 @@ LOG declare.record.parameters:50: Decided to bind the following extra parameters {0 ys : ((Main.Vect a) n)} LOG declare.record.parameters:60: We elaborated Main.EtaProof in a non-empty local context. - Dropped: [b, a] + Dropped: [< a, b] Remaining type: (p : (Main.Product a[1] b[0])) -> Type LOG declare.record.parameters:30: Unelaborated type: (%pi RigW Explicit (Just p) Main.Product %type) diff --git a/tests/idris2/evaluator/spec001/expected b/tests/idris2/evaluator/spec001/expected index 1152f560510..f5bbac11dc1 100644 --- a/tests/idris2/evaluator/spec001/expected +++ b/tests/idris2/evaluator/spec001/expected @@ -56,30 +56,30 @@ LOG specialise:5: New patterns for _PE.PE_identity_1: (_PE.PE_identity_1 (Prelude.Basics.Nil [a = Prelude.Types.Nat])) = (Prelude.Basics.Nil [a = Prelude.Types.Nat]) (_PE.PE_identity_1 (((Prelude.Basics.(::) [a = Prelude.Types.Nat]) x) xs)) = (((Prelude.Basics.(::) [a = Prelude.Types.Nat]) x) ((Main.identity [a = Prelude.Types.Nat]) xs)) LOG specialise:5: New RHS: (Prelude.Basics.Nil Prelude.Types.Nat) -LOG specialise:5: Already specialised _PE.PE_identity_1 -LOG specialise:5: New RHS: (Prelude.Basics.(::) Prelude.Types.Nat x[1] (_PE.PE_identity_1 xs[0])) -LOG specialise:5: Already specialised _PE.PE_identity_1 -LOG compiler.identity:5: found identity flag for: _PE.PE_identity_1, 0 - old def: Just [{arg:2}]: (%case !{arg:2} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (_PE.PE_identity_1 [!{e:2}])]))] Nothing) -LOG compiler.identity:5: new def: [{arg:2}]: !{arg:2} +LOG specialise:5: Already specialised _PE.PE_identity_3c7f5598e5c9b732 +LOG specialise:5: New RHS: (Prelude.Basics.(::) Prelude.Types.Nat x[1] (_PE.PE_identity_3c7f5598e5c9b732 xs[0])) +LOG specialise:5: Already specialised _PE.PE_identity_3c7f5598e5c9b732 +LOG compiler.identity:5: found identity flag for: _PE.PE_identity_3c7f5598e5c9b732, 0 + old def: Just [< {arg:11}]: (%case !{arg:11} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (_PE.PE_identity_3c7f5598e5c9b732 [!{e:2}])]))] Nothing) +LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} LOG compiler.identity:5: found identity flag for: Main.identity, 0 - old def: Just [{arg:3}]: (%case !{arg:3} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (Main.identity [!{e:2}])]))] Nothing) -LOG compiler.identity:5: new def: [{arg:3}]: !{arg:3} -LOG compiler.identity:5: found identity flag for: _PE.PE_identity_1, 0 - old def: Just [{arg:2}]: !{arg:2} -LOG compiler.identity:5: new def: [{arg:2}]: !{arg:2} + old def: Just [< {arg:12}]: (%case !{arg:12} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (Main.identity [!{e:2}])]))] Nothing) +LOG compiler.identity:5: new def: [< {arg:12}]: !{arg:12} +LOG compiler.identity:5: found identity flag for: _PE.PE_identity_3c7f5598e5c9b732, 0 + old def: Just [< {arg:11}]: !{arg:11} +LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} LOG compiler.identity:5: found identity flag for: Main.identity, 0 - old def: Just [{arg:3}]: !{arg:3} -LOG compiler.identity:5: new def: [{arg:3}]: !{arg:3} + old def: Just [< {arg:12}]: !{arg:12} +LOG compiler.identity:5: new def: [< {arg:12}]: !{arg:12} LOG compiler.identity:5: found identity flag for: Main.test, 0 - old def: Just [{arg:2}]: !{arg:2} -LOG compiler.identity:5: new def: [{arg:2}]: !{arg:2} -LOG compiler.identity:5: found identity flag for: _PE.PE_identity_1, 0 - old def: Just [{arg:2}]: !{arg:2} -LOG compiler.identity:5: new def: [{arg:2}]: !{arg:2} + old def: Just [< {arg:11}]: !{arg:11} +LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} +LOG compiler.identity:5: found identity flag for: _PE.PE_identity_3c7f5598e5c9b732, 0 + old def: Just [< {arg:11}]: !{arg:11} +LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} LOG compiler.identity:5: found identity flag for: Main.identity, 0 - old def: Just [{arg:3}]: !{arg:3} -LOG compiler.identity:5: new def: [{arg:3}]: !{arg:3} + old def: Just [< {arg:12}]: !{arg:12} +LOG compiler.identity:5: new def: [< {arg:12}]: !{arg:12} LOG compiler.identity:5: found identity flag for: Main.test, 0 - old def: Just [{arg:2}]: !{arg:2} -LOG compiler.identity:5: new def: [{arg:2}]: !{arg:2} + old def: Just [< {arg:11}]: !{arg:11} +LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} diff --git a/tests/idris2/perf/perf012/expected b/tests/idris2/perf/perf012/expected index 05b89b94761..86a31ab7965 100644 --- a/tests/idris2/perf/perf012/expected +++ b/tests/idris2/perf/perf012/expected @@ -1,9 +1,9 @@ LOG compiler.identity:5: found identity flag for: Main.id, 0 - old def: Just [{arg:1}]: (%case !{arg:1} [(%constcase 0 0)] Just (%let {e:1} (-Integer [!{arg:1}, 1]) (+Integer [(Main.id [!{e:1}]), 1]))) -LOG compiler.identity:5: new def: [{arg:1}]: !{arg:1} + old def: Just [< {arg:1}]: (%case !{arg:1} [(%constcase 0 0)] Just (%let {e:1} (-Integer [!{arg:1}, 1]) (+Integer [(Main.id [!{e:1}]), 1]))) +LOG compiler.identity:5: new def: [< {arg:1}]: !{arg:1} LOG compiler.identity:5: found identity flag for: Main.id, 0 - old def: Just [{arg:1}]: !{arg:1} -LOG compiler.identity:5: new def: [{arg:1}]: !{arg:1} + old def: Just [< {arg:1}]: !{arg:1} +LOG compiler.identity:5: new def: [< {arg:1}]: !{arg:1} LOG compiler.identity:5: found identity flag for: Main.id, 0 - old def: Just [{arg:1}]: !{arg:1} -LOG compiler.identity:5: new def: [{arg:1}]: !{arg:1} + old def: Just [< {arg:1}]: !{arg:1} +LOG compiler.identity:5: new def: [< {arg:1}]: !{arg:1} diff --git a/tests/idris2/reg/reg055_2/Declaration.idr b/tests/idris2/reg/reg055_2/Declaration.idr new file mode 100644 index 00000000000..6ca0ae34bab --- /dev/null +++ b/tests/idris2/reg/reg055_2/Declaration.idr @@ -0,0 +1,4 @@ +module Declaration + +export +f : String -> String -> IO () diff --git a/tests/idris2/reg/reg055_2/Main.idr b/tests/idris2/reg/reg055_2/Main.idr new file mode 100644 index 00000000000..b83065e5a34 --- /dev/null +++ b/tests/idris2/reg/reg055_2/Main.idr @@ -0,0 +1,10 @@ +module Main + +import Declaration + +Declaration.f x y = do + putStrLn x + putStrLn y + +main : IO () +main = f "first" "second" diff --git a/tests/idris2/reg/reg055_2/expected b/tests/idris2/reg/reg055_2/expected new file mode 100644 index 00000000000..66a52ee7a1d --- /dev/null +++ b/tests/idris2/reg/reg055_2/expected @@ -0,0 +1,2 @@ +first +second diff --git a/tests/idris2/reg/reg055_2/run b/tests/idris2/reg/reg055_2/run new file mode 100644 index 00000000000..2f1eae173f3 --- /dev/null +++ b/tests/idris2/reg/reg055_2/run @@ -0,0 +1,3 @@ +. ../../../testutils.sh + +run Main.idr diff --git a/tests/refc/callingConvention/expected b/tests/refc/callingConvention/expected index eb8a50083df..59e40dfebd6 100644 --- a/tests/refc/callingConvention/expected +++ b/tests/refc/callingConvention/expected @@ -43,79 +43,79 @@ Value *Main_last } Value *Main_main_0 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ); Value *Main_main_1 ( - Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 ); Value *Main_main_2 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ); Value *Main_main_3 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ); Value *Main_main_4 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ); Value *Main_main_5 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ); Value *Main_main_6 ( - Value * var_6 -, Value * var_5 -, Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 +, Value * var_5 +, Value * var_6 ); Value *Main_main_7 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ); Value *Main_main_8 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ); Value *Main_main_9 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ); Value *Main_main_10 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ); Value *Main_main_11 ( @@ -190,12 +190,12 @@ Value *Main_main_11 } Value *Main_main_10 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ) { Value * var_2 = idris2_getPredefinedInteger(0); // Main:14:25--14:31 - Value * var_3 = idris2_trampoline(Main_last(var_1, var_2)); + Value * var_3 = idris2_trampoline(Main_last(var_0, var_2)); // Prelude.Show:110:1--112:50 Value * var_4 = idris2_trampoline(Prelude_Show_show_Show_Integer(var_3)); Value * var_5 = ((Value*)&idris2_constant_String_46); @@ -206,13 +206,13 @@ Value *Main_main_10 Value *closure_51 = (Value *)idris2_mkClosure((Value *(*)())Prelude_IO_prim__putStr, 2, 2); // Prelude.IO:98:22--98:34 ((Value_Closure*)closure_51)->args[0] = var_6; - ((Value_Closure*)closure_51)->args[1] = var_0; + ((Value_Closure*)closure_51)->args[1] = var_1; return closure_51; } Value *Main_main_9 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ) { Value *closure_52 = (Value *)idris2_mkClosure((Value *(*)())Main_main_0, 5, 0); @@ -254,128 +254,128 @@ Value *Main_main_9 // Main:14:8--14:12 ((Value_Closure*)closure_63)->args[0] = var_11; ((Value_Closure*)closure_63)->args[1] = var_12; - ((Value_Closure*)closure_63)->args[2] = var_1; - ((Value_Closure*)closure_63)->args[3] = var_0; + ((Value_Closure*)closure_63)->args[2] = var_0; + ((Value_Closure*)closure_63)->args[3] = var_1; return closure_63; } Value *Main_main_8 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ) { - idris2_removeReference(var_3); - idris2_removeReference(var_4); + idris2_removeReference(var_0); + idris2_removeReference(var_1); Value *closure_64 = (Value *)idris2_mkClosure((Value *(*)())Prelude_Types_foldMap_Foldable_List, 3, 3); // Prelude.Types:656:1--669:59 ((Value_Closure*)closure_64)->args[0] = var_2; - ((Value_Closure*)closure_64)->args[1] = var_1; - ((Value_Closure*)closure_64)->args[2] = var_0; + ((Value_Closure*)closure_64)->args[1] = var_3; + ((Value_Closure*)closure_64)->args[2] = var_4; return closure_64; } Value *Main_main_7 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ) { - idris2_removeReference(var_1); - return var_0; + idris2_removeReference(var_0); + return var_1; } Value *Main_main_6 ( - Value * var_6 -, Value * var_5 -, Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 +, Value * var_5 +, Value * var_6 ) { - idris2_removeReference(var_4); - idris2_removeReference(var_5); - idris2_removeReference(var_6); + idris2_removeReference(var_0); + idris2_removeReference(var_1); + idris2_removeReference(var_2); Value *closure_65 = (Value *)idris2_mkClosure((Value *(*)())Prelude_Types_foldlM_Foldable_List, 4, 4); // Prelude.Types:656:1--669:59 ((Value_Closure*)closure_65)->args[0] = var_3; - ((Value_Closure*)closure_65)->args[1] = var_2; - ((Value_Closure*)closure_65)->args[2] = var_1; - ((Value_Closure*)closure_65)->args[3] = var_0; + ((Value_Closure*)closure_65)->args[1] = var_4; + ((Value_Closure*)closure_65)->args[2] = var_5; + ((Value_Closure*)closure_65)->args[3] = var_6; return closure_65; } Value *Main_main_5 ( - Value * var_1 -, Value * var_0 + Value * var_0 +, Value * var_1 ) { - idris2_removeReference(var_1); + idris2_removeReference(var_0); Value *closure_66 = (Value *)idris2_mkClosure((Value *(*)())Prelude_Types_null_Foldable_List, 1, 1); // Prelude.Types:656:1--669:59 - ((Value_Closure*)closure_66)->args[0] = var_0; + ((Value_Closure*)closure_66)->args[0] = var_1; return closure_66; } Value *Main_main_4 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ) { - idris2_removeReference(var_3); - idris2_removeReference(var_4); + idris2_removeReference(var_0); + idris2_removeReference(var_1); Value *closure_67 = (Value *)idris2_mkClosure((Value *(*)())Prelude_Types_foldl_Foldable_List, 3, 3); // Prelude.Types:656:1--669:59 ((Value_Closure*)closure_67)->args[0] = var_2; - ((Value_Closure*)closure_67)->args[1] = var_1; - ((Value_Closure*)closure_67)->args[2] = var_0; + ((Value_Closure*)closure_67)->args[1] = var_3; + ((Value_Closure*)closure_67)->args[2] = var_4; return closure_67; } Value *Main_main_3 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ) { - idris2_removeReference(var_3); - idris2_removeReference(var_4); + idris2_removeReference(var_0); + idris2_removeReference(var_1); Value *closure_68 = (Value *)idris2_mkClosure((Value *(*)())Prelude_Types_foldr_Foldable_List, 3, 3); // Prelude.Types:656:1--669:59 ((Value_Closure*)closure_68)->args[0] = var_2; - ((Value_Closure*)closure_68)->args[1] = var_1; - ((Value_Closure*)closure_68)->args[2] = var_0; + ((Value_Closure*)closure_68)->args[1] = var_3; + ((Value_Closure*)closure_68)->args[2] = var_4; return closure_68; } Value *Main_main_2 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ) { - idris2_removeReference(var_3); - idris2_removeReference(var_4); - Value * var_5 = idris2_apply_closure(var_2, idris2_newReference(var_0)); + idris2_removeReference(var_0); + idris2_removeReference(var_1); + Value * var_5 = idris2_apply_closure(var_2, idris2_newReference(var_4)); // Prelude.IO:24:9--24:16 - Value * var_6 = idris2_apply_closure(var_1, var_0); // Prelude.IO:25:11--25:18 + Value * var_6 = idris2_apply_closure(var_3, var_4); // Prelude.IO:25:11--25:18 return idris2_tailcall_apply_closure(var_5, var_6); } Value *Main_main_1 ( - Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 ) { idris2_removeReference(var_0); @@ -384,19 +384,19 @@ Value *Main_main_1 } Value *Main_main_0 ( - Value * var_4 -, Value * var_3 -, Value * var_2 + Value * var_0 , Value * var_1 -, Value * var_0 +, Value * var_2 +, Value * var_3 +, Value * var_4 ) { - idris2_removeReference(var_3); - idris2_removeReference(var_4); + idris2_removeReference(var_0); + idris2_removeReference(var_1); Value *closure_69 = (Value *)idris2_mkClosure((Value *(*)())Prelude_IO_map_Functor_IO, 3, 3); // Prelude.IO:15:1--17:38 ((Value_Closure*)closure_69)->args[0] = var_2; - ((Value_Closure*)closure_69)->args[1] = var_1; - ((Value_Closure*)closure_69)->args[2] = var_0; + ((Value_Closure*)closure_69)->args[1] = var_3; + ((Value_Closure*)closure_69)->args[2] = var_4; return closure_69; } From 333d74d070c7ff3ca7e47cc2b642f7720f0029fe Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Sat, 15 Nov 2025 11:00:28 +0300 Subject: [PATCH 03/14] [ refactor ] NatSet: correct indexing logic --- src/Compiler/CompileExpr.idr | 2 +- src/Core/Coverage.idr | 5 ----- src/Core/Unify.idr | 4 ++-- src/Libraries/Data/List/Thin.idr | 2 +- src/Libraries/Data/NatSet.idr | 32 +++++++++++++++++++++----------- 5 files changed, 25 insertions(+), 20 deletions(-) diff --git a/src/Compiler/CompileExpr.idr b/src/Compiler/CompileExpr.idr index 8308ec4cdfb..d6cc3a89a3b 100644 --- a/src/Compiler/CompileExpr.idr +++ b/src/Compiler/CompileExpr.idr @@ -129,7 +129,7 @@ mkDropSubst (S i) es rest (xs :< x) -- Next case can't happen if called with the right Nat from mkDropSubst -- FIXME: rule it out with a type! -- Dupe see: Libraries.Data.List.Thin.fromNatSet --- Dupe see: Libraries.Data.NatSet.partition +-- Dupe see: Libraries.Data.NatSet.drop mkDropSubst Z es rest (xs :< x) = let (vs ** sub) = mkDropSubst Z es rest xs in (vs ** Drop sub) -- See if the constructor is a special constructor type, e.g a nil or cons diff --git a/src/Core/Coverage.idr b/src/Core/Coverage.idr index b0b06cc7467..d510b7fce2f 100644 --- a/src/Core/Coverage.idr +++ b/src/Core/Coverage.idr @@ -209,11 +209,6 @@ showK {a} xs = show (map aString xs) aString (MkVar v, t) = (nameAt v, t) -- TODO re-use `Thinnable` -weakenNs : SizeOf args -> KnownVars vars a -> KnownVars (Scope.addInner vars args) a -weakenNs args [] = [] -weakenNs args ((v, t) :: xs) - = (weakenNs args v, t) :: weakenNs args xs - weakensN : SizeOf args -> KnownVars vars a -> KnownVars (Scope.ext vars args) a weakensN args [] = [] weakensN args ((v, t) :: xs) diff --git a/src/Core/Unify.idr b/src/Core/Unify.idr index 8bf8ccc3404..4c4155937dc 100644 --- a/src/Core/Unify.idr +++ b/src/Core/Unify.idr @@ -351,7 +351,7 @@ patternEnv {vars} env args Nothing => Nothing Just (vslist, vsset) => let (newvars ** svs) = fromVarSet _ vsset in - Just (newvars ** (updateVars vslist svs, svs)) + Just (newvars ** (updateVars (reverse vslist) svs, svs)) getVarsTm : SnocList (Term vars) -> Maybe (SnocList (Var vars), VarSet vars) getVarsTm = go [<] VarSet.empty where @@ -379,7 +379,7 @@ patternEnvTm {vars} env args Nothing => Nothing Just (vslist, vsset) => let (newvars ** svs) = fromVarSet _ vsset in - Just (newvars ** (updateVars vslist svs, svs)) + Just (newvars ** (updateVars (reverse vslist) svs, svs)) -- Check that the metavariable name doesn't occur in the solution. -- If it does, normalising might help. If it still does, that's an error. diff --git a/src/Libraries/Data/List/Thin.idr b/src/Libraries/Data/List/Thin.idr index 4ed3f2351d4..4f6e5655d14 100644 --- a/src/Libraries/Data/List/Thin.idr +++ b/src/Libraries/Data/List/Thin.idr @@ -53,5 +53,5 @@ fromNatSet ns xs = -- Next case can't happen if called with the right Nat from fromNatSet -- FIXME: rule it out with a type! -- Dupe see: Compiler.CompileExpr.mkDropSubst - -- Dupe see: Libraries.Data.NatSet.partition + -- Dupe see: Libraries.Data.NatSet.drop go Z (xs :< x) = let (xs' ** th) = go Z xs in (xs' ** Drop th) diff --git a/src/Libraries/Data/NatSet.idr b/src/Libraries/Data/NatSet.idr index c52e889dfee..6af37c361c7 100644 --- a/src/Libraries/Data/NatSet.idr +++ b/src/Libraries/Data/NatSet.idr @@ -33,14 +33,19 @@ namespace SnocList export drop : NatSet -> SnocList a -> SnocList a drop 0 xs = xs - drop ds xs = go 0 xs + drop ds xs = go (length xs) xs where go : Nat -> SnocList a -> SnocList a go _ [<] = [<] - go i (xs :< x) + go (S i) (xs :< x) = if i `elem` ds - then go (S i) xs - else go (S i) xs :< x + then go i xs + else go i xs :< x + -- Next case can't happen if called with the right Nat from drop + -- FIXME: rule it out with a type! + -- Dupe see: Compiler.CompileExpr.mkDropSubst + -- Dupe see: Libraries.Data.List.Thin.fromNatSet + go Z (xs :< x) = go Z xs export %inline take : NatSet -> List a -> List a @@ -97,7 +102,7 @@ Show NatSet where export partition : NatSet -> SnocList a -> (SnocList a , SnocList a) -partition ps = go 0 +partition ps l = go (length l) l where go : Nat -> SnocList a -> (SnocList a , SnocList a) go i [<] = ([<], [<]) @@ -106,11 +111,11 @@ partition ps = go 0 if i `elem` ps then (ps' :< x, ds') else (ps', ds' :< x) - -- Next case can't happen if called with the right Nat from fromNatSet + -- Next case can't happen if called with the right Nat from drop -- FIXME: rule it out with a type! -- Dupe see: Compiler.CompileExpr.mkDropSubst -- Dupe see: Libraries.Data.List.Thin.fromNatSet - go Z (xs :< x) = let (ps', ds') = go Z xs in (ps' :< x, ds') + go Z (xs :< x) = go Z xs export intersection : NatSet -> NatSet -> NatSet @@ -138,14 +143,19 @@ allLessThanSpecNonEmpty = Refl export overwrite : a -> NatSet -> SnocList a -> SnocList a overwrite c 0 xs = xs -overwrite c ds xs = go 0 xs +overwrite c ds xs = go (length xs) xs where go : Nat -> SnocList a -> SnocList a go _ [<] = [<] - go i (xs :< x) + go (S i) (xs :< x) = if i `elem` ds - then go (S i) xs :< c - else go (S i) xs :< x + then go i xs :< c + else go i xs :< x + -- Next case can't happen if called with the right Nat from drop + -- FIXME: rule it out with a type! + -- Dupe see: Compiler.CompileExpr.mkDropSubst + -- Dupe see: Libraries.Data.List.Thin.fromNatSet + go Z (xs :< x) = go Z xs From 4c3f1c567b4587df5feed4e00ba306b68a6da4b7 Mon Sep 17 00:00:00 2001 From: Justus Matthiesen Date: Wed, 30 Jul 2025 11:12:56 +0100 Subject: [PATCH 04/14] [ refactor ] generalised lookup --- src/Compiler/ANF.idr | 4 ---- src/Core/TT/Var.idr | 50 ++++++++++++++++++++++++++------------------ 2 files changed, 30 insertions(+), 24 deletions(-) diff --git a/src/Compiler/ANF.idr b/src/Compiler/ANF.idr index 68d2e7af957..1018c995043 100644 --- a/src/Compiler/ANF.idr +++ b/src/Compiler/ANF.idr @@ -155,10 +155,6 @@ nextVar put Next (i + 1) pure i -lookup : {idx : _} -> (0 p : IsVar x idx vs) -> AVars vs -> Int -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)) bindArgs [] = pure [] diff --git a/src/Core/TT/Var.idr b/src/Core/TT/Var.idr index 1830cd940ce..94fb0710109 100644 --- a/src/Core/TT/Var.idr +++ b/src/Core/TT/Var.idr @@ -10,6 +10,8 @@ import Data.List.HasLength import Data.So import Data.SnocList +import Data.SnocList.Quantifiers + import Libraries.Data.SnocList.HasLength import Libraries.Data.SnocList.SizeOf import Libraries.Data.List.SizeOf @@ -385,25 +387,27 @@ strengthenNVar s (MkNVar p) ------------------------------------------------------------------------ -- Reindexing -0 lookup : - CompatibleVars xs ys -> - {idx : Nat} -> - (0 p : IsVar {a} name idx xs) -> - a -lookup Pre p = name -lookup (Ext {m} x) First = m -lookup (Ext x) (Later p) = lookup x p - -0 compatIsVar : - (ns : CompatibleVars xs ys) -> - {idx : Nat} -> (0 p : IsVar name idx xs) -> - IsVar (lookup ns p) idx ys -compatIsVar Pre p = p -compatIsVar (Ext {n} x) First = First -compatIsVar (Ext {n} x) (Later p) = Later (compatIsVar x p) - -compatVar : CompatibleVars xs ys -> Var xs -> Var ys -compatVar prf (MkVar p) = MkVar (compatIsVar prf p) +namespace CompatibleVars + 0 lookup : + CompatibleVars xs ys -> + {idx : Nat} -> + (0 p : IsVar {a} name idx xs) -> + a + lookup Pre p = name + lookup (Ext {m} x) First = m + lookup (Ext x) (Later p) = lookup x p + + 0 compatIsVar : + (ns : CompatibleVars xs ys) -> + {idx : Nat} -> (0 p : IsVar name idx xs) -> + IsVar (lookup ns p) idx ys + compatIsVar Pre p = p + compatIsVar (Ext {n} x) First = First + compatIsVar (Ext {n} x) (Later p) = Later (compatIsVar x p) + + export + compatVar : CompatibleVars xs ys -> Var xs -> Var ys + compatVar prf (MkVar p) = MkVar (compatIsVar prf p) ------------------------------------------------------------------------ -- Thinning @@ -452,7 +456,7 @@ FreelyEmbeddable (Var {a = Name}) where export IsScoped (Var {a = Name}) where - compatNs = compatVar + compatNs = CompatibleVars.compatVar thin (MkVar p) = thinIsVar p shrink (MkVar p) = shrinkIsVar p @@ -495,3 +499,9 @@ shiftUndersN : SizeOf {a = Name} args -> NVar n (vars :< x <>< args) shiftUndersN s First = weakensN s (MkNVar First) shiftUndersN s (Later p) = insertNVarFishy s (MkNVar p) + +namespace SnocList.All + export + lookup : {idx : _} -> (0 _ : IsVar x idx vs) -> All p vs -> p x + lookup First (xs :< x) = x + lookup (Later p) (xs :< x) = lookup p xs From d6b2a0422465904c9db88d5cebdcde4da3ef9f01 Mon Sep 17 00:00:00 2001 From: Justus Matthiesen Date: Wed, 30 Jul 2025 15:56:07 +0100 Subject: [PATCH 05/14] [ refactor ] define resolveRef as the weakening of findBound, add missing cases to substName --- src/Core/TT.idr | 106 +++++++++++++++++++++++++----------------------- 1 file changed, 55 insertions(+), 51 deletions(-) diff --git a/src/Core/TT.idr b/src/Core/TT.idr index b36e196cba1..8e54b55090f 100644 --- a/src/Core/TT.idr +++ b/src/Core/TT.idr @@ -410,64 +410,65 @@ cons n xn None = Add n xn None cons n xn (Add n' xn' b) = Add n' xn' (cons n xn b) export -addVars : SizeOf outer -> Bounds bound -> - NVar name (Scope.addInner vars outer) -> - NVar name (Scope.addInner vars (bound ++ outer)) -addVars p = insertNVarNames p . sizeOf - -export -resolveRef : SizeOf outer -> - SizeOf done -> - Bounds bound -> FC -> Name -> - Maybe (Var (Scope.addInner vars $ (bound ++ done) ++ outer)) -resolveRef _ _ None _ _ = Nothing -resolveRef {outer} {done} p q (Add {xs} new old bs) fc n - = if n == old - 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 (Scope.single new) done - resolveRef p (sucL q) bs fc n - -mkLocals : SizeOf outer -> Bounds bound -> - Term (Scope.addInner vars outer) -> Term (Scope.addInner 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) +addVars : SizeOf inner -> Bounds bound -> + NVar name (Scope.addInner outer inner) -> + NVar name (Scope.addInner (outer ++ bound) inner) +addVars p b = insertNVarNames (sizeOf b) p + +export +findBound : Name -> + Bounds bound -> + SizeOf done -> + Maybe (Var (Scope.ext bound done)) +findBound _ None _ = Nothing +findBound nm (Add {xs} new old bs) p + = if nm == old + then Just (mkVarFishily p) + else findBound nm bs (suc p) + +resolveRef : Name -> + Bounds bound -> + SizeOf inner -> + Maybe (Var (Scope.addInner (outer ++ bound) inner)) +resolveRef nm bs inn = weakenNs inn . embed <$> (findBound nm bs zero) + +mkLocals : SizeOf inner -> Bounds bound -> + Term (Scope.addInner outer inner) -> Term (Scope.addInner (outer ++ bound) inner) +mkLocals inn bs (Local fc r idx p) + = let MkNVar p' = addVars inn bs (MkNVar p) in Local fc r _ p' +mkLocals inn bs (Ref fc Bound name) = fromMaybe (Ref fc Bound name) $ do - MkVar p <- resolveRef outer [<] bs fc name + MkVar p <- resolveRef name bs inn pure (Local fc Nothing _ p) -mkLocals outer bs (Ref fc nt name) +mkLocals inn bs (Ref fc nt name) = Ref fc nt name -mkLocals outer bs (Meta fc name y xs) - = fromMaybe (Meta fc name y (map (mkLocals outer bs) xs)) $ do - MkVar p <- resolveRef outer [<] bs fc name +mkLocals inn bs (Meta fc name y xs) + = fromMaybe (Meta fc name y (map (mkLocals inn bs) xs)) $ do + MkVar p <- resolveRef name bs inn pure (Local fc Nothing _ p) -mkLocals outer bs (Bind fc x b scope) - = Bind fc x (map (mkLocals outer bs) b) - (mkLocals (suc outer) bs scope) -mkLocals outer bs (App fc fn arg) - = App fc (mkLocals outer bs fn) (mkLocals outer bs arg) -mkLocals outer bs (As fc s as tm) - = As fc s (mkLocals outer bs as) (mkLocals outer bs tm) -mkLocals outer bs (TDelayed fc x y) - = TDelayed fc x (mkLocals outer bs y) -mkLocals outer bs (TDelay fc x t y) - = TDelay fc x (mkLocals outer bs t) (mkLocals outer bs y) -mkLocals outer bs (TForce fc r x) - = TForce fc r (mkLocals outer bs x) -mkLocals outer bs (PrimVal fc c) = PrimVal fc c -mkLocals outer bs (Erased fc Impossible) = Erased fc Impossible -mkLocals outer bs (Erased fc Placeholder) = Erased fc Placeholder -mkLocals outer bs (Erased fc (Dotted t)) = Erased fc (Dotted (mkLocals outer bs t)) -mkLocals outer bs (TType fc u) = TType fc u +mkLocals inn bs (Bind fc x b scope) + = Bind fc x (map (mkLocals inn bs) b) + (mkLocals (suc inn) bs scope) +mkLocals inn bs (App fc fn arg) + = App fc (mkLocals inn bs fn) (mkLocals inn bs arg) +mkLocals inn bs (As fc s as tm) + = As fc s (mkLocals inn bs as) (mkLocals inn bs tm) +mkLocals inn bs (TDelayed fc x y) + = TDelayed fc x (mkLocals inn bs y) +mkLocals inn bs (TDelay fc x t y) + = TDelay fc x (mkLocals inn bs t) (mkLocals inn bs y) +mkLocals inn bs (TForce fc r x) + = TForce fc r (mkLocals inn bs x) +mkLocals inn bs (PrimVal fc c) = PrimVal fc c +mkLocals inn bs (Erased fc Impossible) = Erased fc Impossible +mkLocals inn bs (Erased fc Placeholder) = Erased fc Placeholder +mkLocals inn bs (Erased fc (Dotted t)) = Erased fc (Dotted (mkLocals inn bs t)) +mkLocals inn bs (TType fc u) = TType fc u export refsToLocals : Bounds bound -> Term vars -> Term (Scope.addInner vars bound) refsToLocals None y = y -refsToLocals bs y = mkLocals zero bs y +refsToLocals bs y = mkLocals zero bs y -- Replace any reference to 'x' with a locally bound name 'new' export @@ -497,7 +498,10 @@ 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 +substName s x new tm@(Local{}) = tm +substName s x new tm@(PrimVal{}) = tm +substName s x new (Erased fc why) = Erased fc (substName s x new <$> why) +substName s x new tm@(TType{}) = tm export addMetas : (usingResolved : Bool) -> NameMap Bool -> Term vars -> NameMap Bool From 1e581061d07fb7d9301c7ee76b748990c1a6746f Mon Sep 17 00:00:00 2001 From: Justus Matthiesen Date: Wed, 30 Jul 2025 17:23:31 +0100 Subject: [PATCH 06/14] [ refactor ] define underBinders, fix argument order --- src/Core/CompileExpr.idr | 253 +++++++++++++++---------------------- src/Core/Name/Scoped.idr | 42 +++--- src/Core/TT.idr | 8 +- src/Core/TT/Subst.idr | 47 +++---- src/Core/TT/Term.idr | 43 +++---- src/Core/TT/Term/Subst.idr | 56 ++++---- src/Core/TT/Var.idr | 156 +++++++++++------------ 7 files changed, 273 insertions(+), 332 deletions(-) diff --git a/src/Core/CompileExpr.idr b/src/Core/CompileExpr.idr index a9ef0c60897..279d7fbe47a 100644 --- a/src/Core/CompileExpr.idr +++ b/src/Core/CompileExpr.idr @@ -6,6 +6,7 @@ import Core.TT import Data.String import Data.Vect +import Data.SnocList.Quantifiers import Libraries.Data.List.SizeOf import Libraries.Data.SnocList.SizeOf @@ -112,8 +113,10 @@ mutual data CConAlt : Scoped 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 (Scope.ext vars args) -> CConAlt vars + -- + -- TODO should args be a List? + MkConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : Scope) -> + CExp (Scope.addInner vars args) -> CConAlt vars public export data CConstAlt : Scoped where @@ -166,7 +169,7 @@ mutual public export data NamedConAlt : Type where - MkNConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : List Name) -> + MkNConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : Scope) -> -- TODO should args be a List? NamedCExp -> NamedConAlt public export @@ -275,9 +278,8 @@ mutual = "(%constcase " ++ show x ++ " " ++ show exp ++ ")" export -data Names : Scoped where - Lin : Names Scope.empty - (:<) : Names xs -> Name -> Names (Scope.bind xs x) +Names : Scoped +Names = All (\_ => Name) namespace Names public export @@ -299,11 +301,6 @@ uniqueName s ns = then uniqueName (tryNext s) ns else s -export -getLocName : (idx : Nat) -> Names vars -> (0 p : IsVar name idx vars) -> Name -getLocName Z (xs :< x) First = x -getLocName (S k) (xs :< x) (Later p) = getLocName k xs p - export addLocz : (args : Scope) -> Names vars -> Names (Scope.addInner vars args) addLocz [<] ns = ns @@ -328,22 +325,16 @@ conArgz : (args : SnocList Name) -> Names (Scope.addInner vars args) -> SnocList conArgz [<] ns = [<] conArgz (as :< a) (ns :< n) = conArgz as ns :< n -conArgs : (args : List Name) -> Names (Scope.ext 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 - forgetExp locs (CLocal fc p) = NmLocal fc (getLocName _ locs p) + forgetExp locs (CLocal fc p) = NmLocal fc (lookup locs p) forgetExp locs (CRef fc n) = NmRef fc n forgetExp locs (CLam fc x sc) = let locs' = addLocs [x] locs in - NmLam fc (getLocName _ locs' First) (forgetExp locs' sc) + NmLam fc (lookup locs' First) (forgetExp locs' sc) forgetExp locs (CLet fc x _ val sc) = let locs' = addLocs [x] locs in - NmLet fc (getLocName _ locs' First) + NmLet fc (lookup locs' First) (forgetExp locs val) (forgetExp locs' sc) forgetExp locs (CApp fc f args) @@ -370,8 +361,8 @@ mutual forgetConAlt : Names vars -> CConAlt vars -> NamedConAlt forgetConAlt locs (MkConAlt n ci t args exp) - = let args' = addLocs args locs in - MkNConAlt n ci t (conArgs args args') (forgetExp args' exp) + = let args' = addLocz args locs in + MkNConAlt n ci t (conArgz args args') (forgetExp args' exp) forgetConstAlt : Names vars -> CConstAlt vars -> NamedConstAlt forgetConstAlt locs (MkConstAlt c exp) @@ -449,64 +440,42 @@ Show NamedDef where mutual export - insertNames : SizeOf outer -> - SizeOf ns -> - CExp (Scope.addInner inner outer) -> - CExp (Scope.addInner inner (ns ++ outer)) - insertNames outer ns (CLocal fc prf) - = let MkNVar var' = insertNVarNames outer ns (MkNVar prf) in + insertNames : GenWeakenable CExp + insertNames mid inn (CLocal fc prf) + = let MkNVar var' = insertNVarNames mid inn (MkNVar prf) in CLocal fc var' insertNames _ _ (CRef fc x) = CRef fc x - insertNames outer ns (CLam fc x sc) - = let sc' = insertNames (suc outer) ns sc in + insertNames mid inn (CLam fc x sc) + = let sc' = insertNames mid (suc inn) sc in CLam fc x sc' - insertNames outer ns (CLet fc x inl val sc) - = let sc' = insertNames (suc outer) ns sc in - CLet fc x inl (insertNames outer ns val) sc' - insertNames outer ns (CApp fc x xs) - = CApp fc (insertNames outer ns x) (assert_total (map (insertNames outer ns) xs)) - insertNames outer ns (CCon fc ci x tag xs) - = CCon fc ci x tag (assert_total (map (insertNames outer ns) xs)) - insertNames outer ns (COp fc x xs) - = COp fc x (assert_total (map (insertNames outer ns) xs)) - insertNames outer ns (CExtPrim fc p xs) - = CExtPrim fc p (assert_total (map (insertNames outer ns) xs)) - insertNames outer ns (CForce fc lr x) = CForce fc lr (insertNames outer ns x) - insertNames outer ns (CDelay fc lr x) = CDelay fc lr (insertNames outer ns x) - insertNames outer ns (CConCase fc sc xs def) - = CConCase fc (insertNames outer ns sc) (assert_total (map (insertNamesConAlt outer ns) xs)) - (assert_total (map (insertNames outer ns) def)) - insertNames outer ns (CConstCase fc sc xs def) - = CConstCase fc (insertNames outer ns sc) (assert_total (map (insertNamesConstAlt outer ns) xs)) - (assert_total (map (insertNames outer ns) def)) + insertNames mid inn (CLet fc x inl val sc) + = let sc' = insertNames mid (suc inn) sc in + CLet fc x inl (insertNames mid inn val) sc' + insertNames mid inn (CApp fc x xs) + = CApp fc (insertNames mid inn x) (assert_total (map (insertNames mid inn) xs)) + insertNames mid inn (CCon fc ci x tag xs) + = CCon fc ci x tag (assert_total (map (insertNames mid inn) xs)) + insertNames mid inn (COp fc x xs) + = COp fc x (assert_total (map (insertNames mid inn) xs)) + insertNames mid inn (CExtPrim fc p xs) + = CExtPrim fc p (assert_total (map (insertNames mid inn) xs)) + insertNames mid inn (CForce fc lr x) = CForce fc lr (insertNames mid inn x) + insertNames mid inn (CDelay fc lr x) = CDelay fc lr (insertNames mid inn x) + insertNames mid inn (CConCase fc sc xs def) + = CConCase fc (insertNames mid inn sc) (assert_total (map (insertNamesConAlt mid inn) xs)) + (assert_total (map (insertNames mid inn) def)) + insertNames mid inn (CConstCase fc sc xs def) + = CConstCase fc (insertNames mid inn sc) (assert_total (map (insertNamesConstAlt mid inn) xs)) + (assert_total (map (insertNames mid inn) def)) insertNames _ _ (CPrimVal fc x) = CPrimVal fc x insertNames _ _ (CErased fc) = CErased fc insertNames _ _ (CCrash fc x) = CCrash fc x - insertNamesConAlt : SizeOf outer -> - SizeOf ns -> - CConAlt (Scope.addInner inner outer) -> - CConAlt (Scope.addInner inner (ns ++ outer)) - insertNamesConAlt {outer} {ns} p q (MkConAlt x ci tag args 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 (Scope.addInner inner outer) -> - CConstAlt (Scope.addInner inner (ns ++ outer)) + insertNamesConAlt : GenWeakenable CConAlt + insertNamesConAlt mid inn (MkConAlt x ci tag args sc) + = MkConAlt x ci tag args (underBinders CExp (CompileExpr.insertNames mid) inn (mkSizeOf args) sc) + + insertNamesConstAlt : GenWeakenable CConstAlt insertNamesConstAlt outer ns (MkConstAlt x sc) = MkConstAlt x (insertNames outer ns sc) export @@ -552,18 +521,18 @@ mutual shrinkConAlt : Thin newvars vars -> CConAlt vars -> CConAlt newvars shrinkConAlt sub (MkConAlt x ci tag args sc) - = MkConAlt x ci tag args (shrinkCExp (keepz args sub) sc) + = MkConAlt x ci tag args (shrinkCExp (keeps args sub) sc) shrinkConstAlt : Thin newvars vars -> CConstAlt vars -> CConstAlt newvars shrinkConstAlt sub (MkConstAlt x sc) = MkConstAlt x (shrinkCExp sub sc) export Weaken CExp where - weakenNs ns tm = insertNames zero ns tm + weakenNs ns tm = insertNames ns zero tm export Weaken CConAlt where - weakenNs ns tm = insertNamesConAlt zero ns tm + weakenNs ns tm = insertNamesConAlt ns zero tm public export SubstCEnv : Scope -> Scoped @@ -575,10 +544,10 @@ mutual = find (\ (MkVar p) => CLocal fc p) outer dropped (MkVar prf) env substEnv _ _ _ (CRef fc x) = CRef fc x substEnv outer dropped env (CLam fc x sc) - = let sc' = substEnv (suc outer) dropped env sc in + = let sc' = substEnv outer (suc dropped) env sc in CLam fc x sc' substEnv outer dropped env (CLet fc x inl val sc) - = let sc' = substEnv (suc outer) dropped env sc in + = let sc' = substEnv outer (suc dropped) env sc in CLet fc x inl (substEnv outer dropped env val) sc' substEnv outer dropped env (CApp fc x xs) = CApp fc (substEnv outer dropped env x) (assert_total (map (substEnv outer dropped env) xs)) @@ -603,97 +572,77 @@ mutual substEnv _ _ _ (CCrash fc x) = CCrash fc x substConAlt : Substitutable CExp CConAlt - substConAlt {vars} {outer} {dropped} p q env (MkConAlt x ci tag args 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 + substConAlt {outer} {dropped} {inner} drp inn env (MkConAlt x ci tag args sc) + = MkConAlt x ci tag args (underBinders CExp (\inn => substEnv drp inn env) inn (mkSizeOf args) sc) substConstAlt : Substitutable CExp CConstAlt substConstAlt outer dropped env (MkConstAlt x sc) = MkConstAlt x (substEnv outer dropped env sc) export -substs : {dropped, vars : _} -> +substs : {0 dropped, vars : _} -> SizeOf dropped -> SubstCEnv dropped vars -> CExp (Scope.addInner vars dropped) -> CExp vars -substs = substEnv zero +substs drp = substEnv drp zero mutual export - mkLocals : SizeOf outer -> - Bounds bound -> - CExp (Scope.addInner vars outer) -> - CExp (Scope.addInner 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) + mkLocals : Bounds bound -> + SizeOf inner -> + CExp (Scope.addInner outer inner) -> + CExp ((outer ++ bound) ++ inner) + mkLocals bs inn (CLocal {idx} {x} fc p) + = let MkNVar p' = addVars bs inn (MkNVar p) in CLocal {x} fc p' + mkLocals bs inn (CRef fc var) = fromMaybe (CRef fc var) $ do - MkVar p <- resolveRef later [<] bs fc var + MkVar p <- resolveRef var bs inn pure (CLocal fc p) - mkLocals later bs (CLam fc x sc) - = let sc' = mkLocals (suc later) bs sc in + mkLocals bs inn (CLam fc x sc) + = let sc' = mkLocals bs (suc inn) sc in CLam fc x sc' - mkLocals later bs (CLet fc x inl val sc) - = let sc' = mkLocals (suc later) bs sc in - CLet fc x inl (mkLocals later bs val) sc' - mkLocals later bs (CApp fc f xs) - = CApp fc (mkLocals later bs f) (assert_total (map (mkLocals later bs) xs)) - mkLocals later bs (CCon fc ci x tag xs) - = CCon fc ci x tag (assert_total (map (mkLocals later bs) xs)) - mkLocals later bs (COp fc x xs) - = COp fc x (assert_total (map (mkLocals later bs) xs)) - mkLocals later bs (CExtPrim fc x xs) - = CExtPrim fc x (assert_total (map (mkLocals later bs) xs)) - mkLocals later bs (CForce fc lr x) - = CForce fc lr (mkLocals later bs x) - mkLocals later bs (CDelay fc lr x) - = CDelay fc lr (mkLocals later bs x) - mkLocals later bs (CConCase fc sc xs def) - = CConCase fc (mkLocals later bs sc) - (assert_total (map (mkLocalsConAlt later bs) xs)) - (assert_total (map (mkLocals later bs) def)) - mkLocals later bs (CConstCase fc sc xs def) - = CConstCase fc (mkLocals later bs sc) - (assert_total (map (mkLocalsConstAlt later bs) xs)) - (assert_total (map (mkLocals later bs) def)) - mkLocals later bs (CPrimVal fc x) = CPrimVal fc x - mkLocals later bs (CErased fc) = CErased fc - mkLocals later bs (CCrash fc x) = CCrash fc x - - mkLocalsConAlt : SizeOf outer -> - Bounds bound -> - CConAlt (Scope.addInner vars outer) -> - CConAlt (Scope.addInner vars (bound ++ outer)) - mkLocalsConAlt {bound} {outer} {vars} p bs (MkConAlt x ci tag args 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 (Scope.addInner vars outer) -> - CConstAlt (Scope.addInner vars (bound ++ outer)) - mkLocalsConstAlt later bs (MkConstAlt x sc) = MkConstAlt x (mkLocals later bs sc) + mkLocals bs inn (CLet fc x inl val sc) + = let sc' = mkLocals bs (suc inn) sc in + CLet fc x inl (mkLocals bs inn val) sc' + mkLocals bs inn (CApp fc f xs) + = CApp fc (mkLocals bs inn f) (assert_total (map (mkLocals bs inn) xs)) + mkLocals bs inn (CCon fc ci x tag xs) + = CCon fc ci x tag (assert_total (map (mkLocals bs inn) xs)) + mkLocals bs inn (COp fc x xs) + = COp fc x (assert_total (map (mkLocals bs inn) xs)) + mkLocals bs inn (CExtPrim fc x xs) + = CExtPrim fc x (assert_total (map (mkLocals bs inn) xs)) + mkLocals bs inn (CForce fc lr x) + = CForce fc lr (mkLocals bs inn x) + mkLocals bs inn (CDelay fc lr x) + = CDelay fc lr (mkLocals bs inn x) + mkLocals bs inn (CConCase fc sc xs def) + = CConCase fc (mkLocals bs inn sc) + (assert_total (map (mkLocalsConAlt bs inn) xs)) + (assert_total (map (mkLocals bs inn) def)) + mkLocals bs inn (CConstCase fc sc xs def) + = CConstCase fc (mkLocals bs inn sc) + (assert_total (map (mkLocalsConstAlt bs inn) xs)) + (assert_total (map (mkLocals bs inn) def)) + mkLocals bs inn (CPrimVal fc x) = CPrimVal fc x + mkLocals bs inn (CErased fc) = CErased fc + mkLocals bs inn (CCrash fc x) = CCrash fc x + + mkLocalsConAlt : Bounds bound -> + SizeOf inner -> + CConAlt (Scope.addInner outer inner) -> + CConAlt ((outer ++ bound) ++ inner) + mkLocalsConAlt bs inn (MkConAlt x ci tag args sc) + = MkConAlt x ci tag args (underBinders CExp (mkLocals bs) inn (mkSizeOf args) sc) + + mkLocalsConstAlt : Bounds bound -> + SizeOf inner -> + CConstAlt (outer ++ inner) -> + CConstAlt ((outer ++ bound) ++ inner) + mkLocalsConstAlt bs inn (MkConstAlt x sc) = MkConstAlt x (mkLocals bs inn sc) export refsToLocals : Bounds bound -> CExp vars -> CExp (Scope.addInner vars bound) refsToLocals None tm = tm -refsToLocals bs y = mkLocals zero bs y +refsToLocals bs y = mkLocals bs zero y export getFC : CExp args -> FC diff --git a/src/Core/Name/Scoped.idr b/src/Core/Name/Scoped.idr index 735ec7b1efe..adf9ccb7e35 100644 --- a/src/Core/Name/Scoped.idr +++ b/src/Core/Name/Scoped.idr @@ -92,19 +92,31 @@ mkFresh vs n -- Concepts public export -0 Weakenable : Scoped -> Type -Weakenable tm = {0 vars, ns : Scope} -> - SizeOf ns -> tm vars -> tm (Scope.addInner vars ns) +0 Weakenable : (Scopeable a -> Type) -> Type +Weakenable tm = {0 outer, inner : Scopeable a} -> + SizeOf inner -> tm outer -> tm (Scope.addInner outer inner) public export -0 Strengthenable : Scoped -> Type -Strengthenable tm = {0 vars, ns : Scope} -> - SizeOf ns -> tm (Scope.addInner vars ns) -> Maybe (tm vars) +0 Strengthenable : (Scopeable a -> Type) -> Type +Strengthenable tm = {0 outer, inner : Scopeable a} -> + SizeOf inner -> tm (Scope.addInner outer inner) -> Maybe (tm outer) public export -0 GenWeakenable : Scoped -> Type -GenWeakenable tm = {0 local, ns, outer : Scope} -> - SizeOf outer -> SizeOf ns -> tm (Scope.addInner local outer) -> tm (Scope.addInner local (Scope.addInner ns outer)) +0 GenWeakenable : (Scopeable a -> Type) -> Type +GenWeakenable tm = {0 outer, middle, inner : Scopeable a} -> + SizeOf middle -> SizeOf inner -> tm (Scope.addInner outer inner) -> tm (Scope.addInner (Scope.addInner outer middle) inner) + +export +underBinders : + (0 tm : Scopeable a -> Type) -> + (forall inner. SizeOf inner -> tm (outer ++ inner) -> tm (outer' ++ inner)) -> + SizeOf innerLeft -> + SizeOf innerRight -> + tm ((outer ++ innerLeft) ++ innerRight) -> + tm ((outer' ++ innerLeft) ++ innerRight) +underBinders _ f innL innR t = + rewrite sym $ appendAssociative outer' innerLeft innerRight in + f (innL + innR) (rewrite appendAssociative outer innerLeft innerRight in t) public export 0 Thinnable : Scoped -> Type @@ -122,7 +134,7 @@ Embeddable tm = {0 outer, vars : Scope} -> tm vars -> tm (Scope.addInner outer v -- IsScoped interface public export -interface Weaken (0 tm : Scoped) where +interface Weaken (0 tm : Scopeable a -> Type) | tm where constructor MkWeaken -- methods weaken : tm vars -> tm (Scope.bind vars nm) @@ -135,14 +147,14 @@ interface Weaken (0 tm : Scoped) where -- This cannot be merged with Weaken because of WkCExp public export -interface GenWeaken (0 tm : Scoped) where +interface GenWeaken (0 tm : Scopeable a -> Type) | tm where constructor MkGenWeaken genWeakenNs : GenWeakenable tm export genWeaken : GenWeaken tm => - SizeOf outer -> tm (Scope.addInner local outer) -> tm (Scope.addInner (Scope.bind local n) outer) -genWeaken l = rewrite sym $ appendAssociative local [ tm (Scope.addInner outer inner) -> tm (Scope.addInner (Scope.bind outer n) inner) +genWeaken = genWeakenNs (suc zero) export genWeakenFishily : GenWeaken tm => @@ -154,7 +166,7 @@ genWeakenFishily export weakensN : Weaken tm => - {0 vars : Scope} -> {0 ns : List Name} -> + {0 vars : Scopeable a} -> {0 ns : List a} -> SizeOf ns -> tm vars -> tm (vars <>< ns) weakensN s t = rewrite fishAsSnocAppend vars ns in @@ -203,7 +215,7 @@ MaybeFreelyEmbeddable = FunctorFreelyEmbeddable export GenWeakenWeakens : GenWeaken tm => Weaken tm -GenWeakenWeakens = MkWeaken (genWeakenNs zero (suc zero)) (genWeakenNs zero) +GenWeakenWeakens = MkWeaken (genWeakenNs (suc zero) zero) (flip genWeakenNs zero) export FunctorGenWeaken : Functor f => GenWeaken tm => GenWeaken (f . tm) diff --git a/src/Core/TT.idr b/src/Core/TT.idr index 8e54b55090f..19f87092a75 100644 --- a/src/Core/TT.idr +++ b/src/Core/TT.idr @@ -410,10 +410,11 @@ cons n xn None = Add n xn None cons n xn (Add n' xn' b) = Add n' xn' (cons n xn b) export -addVars : SizeOf inner -> Bounds bound -> +addVars : Bounds bound -> + SizeOf inner -> NVar name (Scope.addInner outer inner) -> NVar name (Scope.addInner (outer ++ bound) inner) -addVars p b = insertNVarNames (sizeOf b) p +addVars = insertNVarNames . sizeOf export findBound : Name -> @@ -426,6 +427,7 @@ findBound nm (Add {xs} new old bs) p then Just (mkVarFishily p) else findBound nm bs (suc p) +export resolveRef : Name -> Bounds bound -> SizeOf inner -> @@ -435,7 +437,7 @@ resolveRef nm bs inn = weakenNs inn . embed <$> (findBound nm bs zero) mkLocals : SizeOf inner -> Bounds bound -> Term (Scope.addInner outer inner) -> Term (Scope.addInner (outer ++ bound) inner) mkLocals inn bs (Local fc r idx p) - = let MkNVar p' = addVars inn bs (MkNVar p) in Local fc r _ p' + = let MkNVar p' = addVars bs inn (MkNVar p) in Local fc r _ p' mkLocals inn bs (Ref fc Bound name) = fromMaybe (Ref fc Bound name) $ do MkVar p <- resolveRef name bs inn diff --git a/src/Core/TT/Subst.idr b/src/Core/TT/Subst.idr index 63817b5c9b2..2ca3e99f315 100644 --- a/src/Core/TT/Subst.idr +++ b/src/Core/TT/Subst.idr @@ -28,44 +28,35 @@ namespace Subst bind : Subst tm ds vars -> tm vars -> Subst tm (Scope.bind ds v) vars bind = (:<) -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 {tm} (MkVar p) - --- TODO revisit order of `dropped` and `Subst` export findDrop : - (Var vars -> tm vars) -> + (Var outer -> tm outer) -> SizeOf dropped -> - Var (Scope.addInner vars dropped) -> - Subst tm dropped vars -> - tm vars + Var (Scope.addInner outer dropped) -> + Subst tm dropped outer -> + tm outer findDrop k s var sub = case locateVar s var of - Left var => index sub {tm} var - Right var => k var + Left var => k var + Right var => lookup sub var export find : Weaken tm => (forall vars. Var vars -> tm vars) -> - SizeOf outer -> SizeOf dropped -> - Var (Scope.addInner (Scope.addInner vars dropped) outer) -> - Subst tm dropped vars -> - tm (Scope.addInner vars outer) -find k outer dropped var sub = case locateVar outer var of - Left var => k (embed var) - Right var => weakenNs outer (findDrop k {tm} dropped var sub) + SizeOf dropped -> + SizeOf inner -> + Var (Scope.addInner (Scope.addInner outer dropped) inner) -> + Subst tm dropped outer -> + tm (Scope.addInner outer inner) +find k dropped inner var sub = case locateVar inner var of + Left var => weakenNs inner (findDrop {tm} k dropped var sub) + Right var => k (embed var) --- TODO rename `outer` public export 0 Substitutable : Scoped -> Scoped -> Type Substitutable val tm - = {0 outer, dropped, vars : Scope} -> - SizeOf outer -> + = {0 outer, dropped, inner : Scope} -> SizeOf dropped -> - Subst val dropped vars -> - tm (Scope.addInner (Scope.addInner vars dropped) outer) -> - tm (Scope.addInner vars outer) + SizeOf inner -> + Subst val dropped outer -> + tm (Scope.addInner (Scope.addInner outer dropped) inner) -> + tm (Scope.addInner outer inner) diff --git a/src/Core/TT/Term.idr b/src/Core/TT/Term.idr index c3ecec3b3d6..82ad1b56ab1 100644 --- a/src/Core/TT/Term.idr +++ b/src/Core/TT/Term.idr @@ -129,31 +129,30 @@ ClosedTerm = Term Scope.empty ------------------------------------------------------------------------ -- Weakening - export covering insertNames : GenWeakenable Term -insertNames out ns (Local fc r idx prf) - = let MkNVar prf' = insertNVarNames out ns (MkNVar prf) in +insertNames mid inn (Local fc r idx prf) + = let MkNVar prf' = insertNVarNames mid inn (MkNVar prf) in Local fc r _ prf' -insertNames out ns (Ref fc nt name) = Ref fc nt name -insertNames out ns (Meta fc name idx args) - = Meta fc name idx (map (insertNames out ns) args) -insertNames out ns (Bind fc x b scope) - = Bind fc x (assert_total (map (insertNames out ns) b)) - (insertNames (suc out) ns scope) -insertNames out ns (App fc fn arg) - = App fc (insertNames out ns fn) (insertNames out ns arg) -insertNames out ns (As fc s as tm) - = As fc s (insertNames out ns as) (insertNames out ns tm) -insertNames out ns (TDelayed fc r ty) = TDelayed fc r (insertNames out ns ty) -insertNames out ns (TDelay fc r ty tm) - = TDelay fc r (insertNames out ns ty) (insertNames out ns tm) -insertNames out ns (TForce fc r tm) = TForce fc r (insertNames out ns tm) -insertNames out ns (PrimVal fc c) = PrimVal fc c -insertNames out ns (Erased fc Impossible) = Erased fc Impossible -insertNames out ns (Erased fc Placeholder) = Erased fc Placeholder -insertNames out ns (Erased fc (Dotted t)) = Erased fc (Dotted (insertNames out ns t)) -insertNames out ns (TType fc u) = TType fc u +insertNames mid inn (Ref fc nt name) = Ref fc nt name +insertNames mid inn (Meta fc name idx args) + = Meta fc name idx (map (insertNames mid inn) args) +insertNames mid inn (Bind fc x b scope) + = Bind fc x (assert_total (map (insertNames mid inn) b)) + (insertNames mid (suc inn) scope) +insertNames mid inn (App fc fn arg) + = App fc (insertNames mid inn fn) (insertNames mid inn arg) +insertNames mid inn (As fc s as tm) + = As fc s (insertNames mid inn as) (insertNames mid inn tm) +insertNames mid inn (TDelayed fc r ty) = TDelayed fc r (insertNames mid inn ty) +insertNames mid inn (TDelay fc r ty tm) + = TDelay fc r (insertNames mid inn ty) (insertNames mid inn tm) +insertNames mid inn (TForce fc r tm) = TForce fc r (insertNames mid inn tm) +insertNames mid inn (PrimVal fc c) = PrimVal fc c +insertNames mid inn (Erased fc Impossible) = Erased fc Impossible +insertNames mid inn (Erased fc Placeholder) = Erased fc Placeholder +insertNames mid inn (Erased fc (Dotted t)) = Erased fc (Dotted (insertNames mid inn t)) +insertNames mid inn (TType fc u) = TType fc u export compatTerm : CompatibleVars xs ys -> Term xs -> Term ys diff --git a/src/Core/TT/Term/Subst.idr b/src/Core/TT/Term/Subst.idr index 2209a69e81e..eceba3c82cb 100644 --- a/src/Core/TT/Term/Subst.idr +++ b/src/Core/TT/Term/Subst.idr @@ -24,37 +24,37 @@ substTerm : Substitutable Term Term substTerms : Substitutable Term (List . Term) substBinder : Substitutable Term (Binder . Term) -substTerm outer dropped env (Local fc r _ prf) - = find (\ (MkVar p) => Local fc r _ p) outer dropped (MkVar prf) env -substTerm outer dropped env (Ref fc x name) = Ref fc x name -substTerm outer dropped env (Meta fc n i xs) - = Meta fc n i (substTerms outer dropped env xs) -substTerm outer dropped env (Bind fc x b scope) - = Bind fc x (substBinder outer dropped env b) - (substTerm (suc outer) dropped env scope) -substTerm outer dropped env (App fc fn arg) - = App fc (substTerm outer dropped env fn) (substTerm outer dropped env arg) -substTerm outer dropped env (As fc s as pat) - = As fc s (substTerm outer dropped env as) (substTerm outer dropped env pat) -substTerm outer dropped env (TDelayed fc x y) = TDelayed fc x (substTerm outer dropped env y) -substTerm outer dropped env (TDelay fc x t y) - = TDelay fc x (substTerm outer dropped env t) (substTerm outer dropped env y) -substTerm outer dropped env (TForce fc r x) = TForce fc r (substTerm outer dropped env x) -substTerm outer dropped env (PrimVal fc c) = PrimVal fc c -substTerm outer dropped env (Erased fc Impossible) = Erased fc Impossible -substTerm outer dropped env (Erased fc Placeholder) = Erased fc Placeholder -substTerm outer dropped env (Erased fc (Dotted t)) = Erased fc (Dotted (substTerm outer dropped env t)) -substTerm outer dropped env (TType fc u) = TType fc u - -substTerms outer dropped env xs - = assert_total $ map (substTerm outer dropped env) xs - -substBinder outer dropped env b - = assert_total $ map (substTerm outer dropped env) b +substTerm drp inn env (Local fc r _ prf) + = find (\ (MkVar p) => Local fc r _ p) drp inn (MkVar prf) env +substTerm drp inn env (Ref fc x name) = Ref fc x name +substTerm drp inn env (Meta fc n i xs) + = Meta fc n i (substTerms drp inn env xs) +substTerm drp inn env (Bind fc x b scope) + = Bind fc x (substBinder drp inn env b) + (substTerm drp (suc inn) env scope) +substTerm drp inn env (App fc fn arg) + = App fc (substTerm drp inn env fn) (substTerm drp inn env arg) +substTerm drp inn env (As fc s as pat) + = As fc s (substTerm drp inn env as) (substTerm drp inn env pat) +substTerm drp inn env (TDelayed fc x y) = TDelayed fc x (substTerm drp inn env y) +substTerm drp inn env (TDelay fc x t y) + = TDelay fc x (substTerm drp inn env t) (substTerm drp inn env y) +substTerm drp inn env (TForce fc r x) = TForce fc r (substTerm drp inn env x) +substTerm drp inn env (PrimVal fc c) = PrimVal fc c +substTerm drp inn env (Erased fc Impossible) = Erased fc Impossible +substTerm drp inn env (Erased fc Placeholder) = Erased fc Placeholder +substTerm drp inn env (Erased fc (Dotted t)) = Erased fc (Dotted (substTerm drp inn env t)) +substTerm drp inn env (TType fc u) = TType fc u + +substTerms drp inn env xs + = assert_total $ map (substTerm drp inn env) xs + +substBinder drp inn env b + = assert_total $ map (substTerm drp inn env) b export substs : SizeOf dropped -> SubstEnv dropped vars -> Term (Scope.addInner vars dropped) -> Term vars -substs dropped env tm = substTerm zero dropped env tm +substs dropped env tm = substTerm dropped zero env tm export subst : Term vars -> Term (Scope.bind vars x) -> Term vars diff --git a/src/Core/TT/Var.idr b/src/Core/TT/Var.idr index 94fb0710109..5a02337821a 100644 --- a/src/Core/TT/Var.idr +++ b/src/Core/TT/Var.idr @@ -72,13 +72,13 @@ dropLater : IsVar nm (S idx) (ns :< n) -> IsVar nm idx ns dropLater (Later p) = p export -appendIsVar : HasLength m inner -> IsVar nm m (outer :< nm ++ inner) +0 appendIsVar : HasLength m inner -> IsVar nm m (outer :< nm ++ inner) appendIsVar Z = First appendIsVar (S x) = Later (appendIsVar x) export -fishyIsVar : HasLength m inner -> IsVar nm m (outer :< nm <>< inner) -fishyIsVar hl +0 isVarFishily : HasLength m inner -> IsVar nm m (outer :< nm <>< inner) +isVarFishily hl = rewrite fishAsSnocAppend (outer :< nm) inner in appendIsVar $ rewrite sym $ plusZeroRightNeutral m in @@ -127,10 +127,10 @@ weakenIsVarL (MkSizeOf Z Z) p = p weakenIsVarL (MkSizeOf (S k) (S l)) p = Later (weakenIsVarL (MkSizeOf k l) p) 0 locateIsVarLT : - (s : SizeOf local) -> + (s : SizeOf inner) -> So (idx < size s) -> - IsVar x idx (outer ++ local) -> - IsVar x idx local + IsVar x idx (outer ++ inner) -> + IsVar x idx inner locateIsVarLT (MkSizeOf Z Z) so v = case v of First impossible Later v impossible @@ -139,22 +139,22 @@ locateIsVarLT (MkSizeOf (S k) (S l)) so v = case v of Later v => Later (locateIsVarLT (MkSizeOf k l) so v) 0 locateIsVarGE : - (s : SizeOf local) -> + (s : SizeOf inner) -> So (idx >= size s) -> - IsVar x idx (outer ++ local) -> + IsVar x idx (outer ++ inner) -> 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 outer) -> - (0 p : IsVar x idx (inner ++ outer)) -> - Either (Erased (IsVar x idx outer)) - (Erased (IsVar x (idx `minus` size s) inner)) +locateIsVar : {idx : Nat} -> (s : SizeOf inner) -> + (0 p : IsVar x idx (outer ++ inner)) -> + Either (Erased (IsVar x (idx `minus` size s) outer)) + (Erased (IsVar x idx 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)) + Left so => Right (MkErased (locateIsVarLT s so p)) + Right so => Left (MkErased (locateIsVarGE s so p)) ------------------------------------------------------------------------ -- Variable in scope @@ -194,17 +194,17 @@ mkVar : SizeOf inner -> Var (Scope.addInner (Scope.bind outer nm) inner) mkVar (MkSizeOf s p) = MkVar (mkIsVar p) export -fishyVar : SizeOf inner -> Var (outer :< nm <>< inner) -fishyVar (MkSizeOf s p) = MkVar (fishyIsVar p) +mkVarFishily : SizeOf inner -> Var (outer :< nm <>< inner) +mkVarFishily (MkSizeOf s p) = MkVar (isVarFishily p) ||| Generate all variables export allVars : (vars : Scope) -> List (Var vars) allVars = go zero where - go : SizeOf local -> (vs : Scope) -> List (Var (vs <>< local)) + go : SizeOf inner -> (vs : Scope) -> List (Var (vs <>< inner)) go s [<] = [] - go s (vs :< v) = fishyVar s :: go (suc s) vs + go s (vs :< v) = mkVarFishily s :: go (suc s) vs export Eq (Var xs) where @@ -258,8 +258,8 @@ mkNVar : SizeOf inner -> NVar nm (outer :< nm ++ inner) mkNVar (MkSizeOf s p) = MkNVar (mkIsVar p) export -locateNVar : SizeOf outer -> NVar nm (local ++ outer) -> - Either (NVar nm outer) (NVar nm local) +locateNVar : SizeOf inner -> NVar nm (outer ++ inner) -> + Either (NVar nm outer) (NVar nm inner) locateNVar s (MkNVar p) = case locateIsVar s p of Left p => Left (MkNVar (runErased p)) Right p => Right (MkNVar (runErased p)) @@ -282,7 +282,7 @@ 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) + Nothing => map later (isNVar n ms) -- TODO make tail-recursive Just Refl => pure (MkNVar First) export @@ -290,16 +290,16 @@ isVar : (n : Name) -> (ns : SnocList Name) -> Maybe (Var ns) isVar n ns = forgetName <$> isNVar n ns export -locateVar : SizeOf outer -> Var (local ++ outer) -> - Either (Var outer) (Var local) +locateVar : SizeOf inner -> Var (outer ++ inner) -> + Either (Var outer) (Var inner) locateVar s v = bimap forgetName forgetName $ locateNVar s (recoverName v) ------------------------------------------------------------------------ -- Weakening -export -weakenNVar : SizeOf ns -> NVar name inner -> NVar name (inner ++ ns) +%inline export +weakenNVar : Weakenable (NVar name) weakenNVar s (MkNVar p) = MkNVar (weakenIsVar s p) export @@ -307,79 +307,62 @@ weakenNVarL : SizeOf ns -> NVarL nm inner -> NVarL nm (ns ++ inner) weakenNVarL s (MkNVarL p) = MkNVarL (weakenIsVarL s p) export -embedNVar : NVar name vars -> NVar name (more ++ vars) +embedNVar : NVar name inner -> NVar name (outer ++ inner) embedNVar (MkNVar p) = MkNVar (embedIsVar p) export -insertNVar : SizeOf outer -> - NVar nm (local ++ outer) -> - NVar nm (local :< n ++ outer) +insertNVar : SizeOf inner -> + NVar nm (outer ++ inner) -> + NVar nm (outer :< n ++ inner) insertNVar p v = case locateNVar p v of - Left v => embedNVar v - Right v => weakenNVar p (later v) + Left v => weakenNVar p (later v) + Right v => embedNVar v +-- TODO clean-up implementation export -insertNVarFishy : SizeOf local -> - NVar nm (outer <>< local) -> - NVar nm (outer :< n <>< local) -insertNVarFishy p v - = rewrite fishAsSnocAppend (outer :< n) local in +insertNVarFishily : SizeOf inner -> + NVar nm (outer <>< inner) -> + NVar nm (outer :< n <>< inner) +insertNVarFishily p v + = rewrite fishAsSnocAppend (outer :< n) inner in insertNVar (zero <>< p) - $ replace {p = NVar nm} (fishAsSnocAppend outer local) v + $ replace {p = NVar nm} (fishAsSnocAppend outer inner) v export insertNVarNames : GenWeakenable (NVar name) -insertNVarNames p q v = case locateNVar p v of - Left v => rewrite appendAssociative local ns outer in embedNVar v - Right v => weakenNVar (q + p) v - -||| The (partial) inverse to insertNVar -export -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 +insertNVarNames p q v = case locateNVar q v of + Left v => weakenNVar q (weakenNVar p v) + Right v => embedNVar v export -insertVar : SizeOf outer -> - Var (local ++ outer) -> - Var (local :< n ++ outer) +insertVar : SizeOf inner -> + Var (outer ++ inner) -> + Var (outer :< n ++ inner) insertVar p v = forgetName $ insertNVar p (recoverName v) -weakenVar : SizeOf ns -> Var inner -> Var (inner ++ ns) +weakenVar : Weakenable Var weakenVar p v = forgetName $ weakenNVar p (recoverName v) insertVarNames : GenWeakenable Var insertVarNames p q v = forgetName $ insertNVarNames p q (recoverName v) -||| The (partial) inverse to insertVar -export -removeVar : SizeOf local -> - Var (outer :< n ++ local) -> - Maybe (Var (outer ++ local)) -removeVar s var = forgetName <$> removeNVar s (recoverName var) - ------------------------------------------------------------------------ -- Strengthening export -strengthenIsVar : {n : Nat} -> (s : SizeOf outer) -> - (0 p : IsVar x n (vars ++ outer)) -> - Maybe (Erased (IsVar x (n `minus` size s) vars)) +strengthenIsVar : {n : Nat} -> (s : SizeOf inner) -> + (0 p : IsVar x n (outer ++ inner)) -> + Maybe (Erased (IsVar x (n `minus` size s) outer)) strengthenIsVar s p = case locateIsVar s p of - Left _ => Nothing - Right p => pure p + Left p => pure p + Right _ => Nothing -strengthenVar : SizeOf outer -> - Var (vars ++ outer) -> Maybe (Var vars) +strengthenVar : Strengthenable Var strengthenVar s (MkVar p) = do MkErased p <- strengthenIsVar s p pure (MkVar p) -strengthenNVar : SizeOf outer -> - NVar x (vars ++ outer) -> Maybe (NVar x vars) +strengthenNVar : Strengthenable (NVar name) strengthenNVar s (MkNVar p) = do MkErased p <- strengthenIsVar s p pure (MkNVar p) @@ -438,44 +421,44 @@ export FreelyEmbeddableIsVar = MkFreelyEmbeddable embedIsVar export -GenWeaken (Var {a = Name}) where +GenWeaken Var where genWeakenNs = insertVarNames %hint export -WeakenVar : Weaken (Var {a = Name}) +WeakenVar : Weaken Var WeakenVar = GenWeakenWeakens export -Strengthen (Var {a = Name}) where +Strengthen Var where strengthenNs = strengthenVar export -FreelyEmbeddable (Var {a = Name}) where +FreelyEmbeddable Var where embed (MkVar p) = MkVar (embedIsVar p) export -IsScoped (Var {a = Name}) where +IsScoped Var where compatNs = CompatibleVars.compatVar thin (MkVar p) = thinIsVar p shrink (MkVar p) = shrinkIsVar p export -GenWeaken (NVar {a = Name} nm) where +GenWeaken (NVar nm) where genWeakenNs = insertNVarNames %hint export -WeakenNVar : Weaken (NVar {a = Name} nm) +WeakenNVar : Weaken (NVar nm) WeakenNVar = GenWeakenWeakens export -Strengthen (NVar {a = Name} nm) where +Strengthen (NVar nm) where strengthenNs = strengthenNVar export -FreelyEmbeddable (NVar {a = Name} nm) where +FreelyEmbeddable (NVar nm) where embed (MkNVar p) = MkNVar (embedIsVar p) ------------------------------------------------------------------------ @@ -493,15 +476,20 @@ 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 -> +shiftUndersN : SizeOf 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) +shiftUndersN s (Later p) = insertNVarFishily s (MkNVar p) -namespace SnocList.All +namespace IsVar export - lookup : {idx : _} -> (0 _ : IsVar x idx vs) -> All p vs -> p x - lookup First (xs :< x) = x - lookup (Later p) (xs :< x) = lookup p xs + lookup : {idx : _} -> All p vs -> (0 _ : IsVar x idx vs) -> p x + lookup (xs :< x) First = x + lookup (xs :< x) (Later p) = lookup xs p + +namespace Var + export %inline + lookup : All p vs -> (v : Var vs) -> p (varNm v) + lookup vs (MkVar p) = lookup vs p From 05207751615ab45c8b034c5e879cb246ff86a0e2 Mon Sep 17 00:00:00 2001 From: Justus Matthiesen Date: Wed, 30 Jul 2025 17:44:25 +0100 Subject: [PATCH 07/14] [ refactor ] added underBinderz, more GenWeakenable instances --- src/Core/Case/CaseTree.idr | 51 +++++++++++++------------------------- src/Core/Name/Scoped.idr | 14 ++++++++++- 2 files changed, 30 insertions(+), 35 deletions(-) diff --git a/src/Core/Case/CaseTree.idr b/src/Core/Case/CaseTree.idr index ae5411eb8c5..9dfd030f175 100644 --- a/src/Core/Case/CaseTree.idr +++ b/src/Core/Case/CaseTree.idr @@ -214,47 +214,30 @@ Pretty IdrisSyntax Pat where prettyPrec d (PUnmatchable _ tm) = keyword "." <+> parens (byShow tm) mutual - insertCaseNames : SizeOf outer -> - SizeOf ns -> - CaseTree (Scope.addInner inner outer) -> - CaseTree (Scope.addInner 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) - (map (insertCaseAltNames outer ns) alts) - insertCaseNames outer ns (STerm i x) = STerm i (insertNames outer ns x) + insertCaseNames : GenWeakenable CaseTree + insertCaseNames mid inn (Case idx prf scTy alts) + = let MkNVar prf' = insertNVarNames mid inn (MkNVar prf) in + Case _ prf' (insertNames mid inn scTy) + (map (insertCaseAltNames mid inn) alts) + insertCaseNames mid inn (STerm i x) = STerm i (insertNames mid inn x) insertCaseNames _ _ (Unmatched msg) = Unmatched msg insertCaseNames _ _ Impossible = Impossible - insertCaseAltNames : SizeOf outer -> - SizeOf ns -> - CaseAlt (Scope.addInner inner outer) -> - CaseAlt (Scope.addInner inner (ns ++ outer)) - insertCaseAltNames p q (ConCase x tag args 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) + insertCaseAltNames : GenWeakenable CaseAlt + insertCaseAltNames mid inn (ConCase x tag args ct) + = ConCase x tag args (underBinderz CaseTree (insertCaseNames mid) inn (mkSizeOf args) ct) + + insertCaseAltNames mid inn (DelayCase tyn valn ct) = DelayCase tyn valn - (insertCaseNames (suc (suc outer)) ns ct) - insertCaseAltNames outer ns (ConstCase x ct) - = ConstCase x (insertCaseNames outer ns ct) - insertCaseAltNames outer ns (DefaultCase ct) - = DefaultCase (insertCaseNames outer ns ct) + (insertCaseNames mid (suc (suc inn)) ct) + insertCaseAltNames mid inn (ConstCase x ct) + = ConstCase x (insertCaseNames mid inn ct) + insertCaseAltNames mid inn (DefaultCase ct) + = DefaultCase (insertCaseNames mid inn ct) export Weaken CaseTree where - weakenNs ns t = insertCaseNames zero ns t + weakenNs ns t = insertCaseNames ns zero t total getNames : (forall vs . NameMap Bool -> Term vs -> NameMap Bool) -> diff --git a/src/Core/Name/Scoped.idr b/src/Core/Name/Scoped.idr index adf9ccb7e35..2985f5bd685 100644 --- a/src/Core/Name/Scoped.idr +++ b/src/Core/Name/Scoped.idr @@ -106,7 +106,7 @@ public export GenWeakenable tm = {0 outer, middle, inner : Scopeable a} -> SizeOf middle -> SizeOf inner -> tm (Scope.addInner outer inner) -> tm (Scope.addInner (Scope.addInner outer middle) inner) -export +export %inline underBinders : (0 tm : Scopeable a -> Type) -> (forall inner. SizeOf inner -> tm (outer ++ inner) -> tm (outer' ++ inner)) -> @@ -118,6 +118,18 @@ underBinders _ f innL innR t = rewrite sym $ appendAssociative outer' innerLeft innerRight in f (innL + innR) (rewrite appendAssociative outer innerLeft innerRight in t) +export %inline +underBinderz : + (0 tm : Scopeable a -> Type) -> + (forall inner. SizeOf inner -> tm (outer ++ inner) -> tm (outer' ++ inner)) -> + SizeOf innerLeft -> + SizeOf innerRight -> + tm ((outer ++ innerLeft) <>< innerRight) -> + tm ((outer' ++ innerLeft) <>< innerRight) +underBinderz tm f innL innR t = + rewrite fishAsSnocAppend (outer' ++ innerLeft) innerRight in + underBinders {outer} tm f innL (cast innR) (rewrite sym $ fishAsSnocAppend (outer ++ innerLeft) innerRight in t) + public export 0 Thinnable : Scoped -> Type Thinnable tm = {0 xs, ys : Scope} -> tm xs -> Thin xs ys -> tm ys From a118f1a27f8f891be5b8718acc06081aff3f9ba5 Mon Sep 17 00:00:00 2001 From: Justus Matthiesen Date: Wed, 6 Aug 2025 14:33:14 +0100 Subject: [PATCH 08/14] [ refactor ] complete refactors regarding swapping inner/outer --- src/Compiler/ANF.idr | 20 ++-- src/Compiler/CaseOpts.idr | 64 +++++----- src/Compiler/CompileExpr.idr | 27 +++-- src/Compiler/ES/TailRec.idr | 3 +- src/Compiler/ES/ToAst.idr | 3 +- src/Compiler/Inline.idr | 37 +++--- src/Compiler/LambdaLift.idr | 156 ++++++++++++++----------- src/Compiler/Opts/CSE.idr | 14 +-- src/Compiler/Opts/ConstantFold.idr | 10 +- src/Compiler/Opts/Constructor.idr | 8 +- src/Compiler/Opts/Identity.idr | 9 +- src/Compiler/Scheme/Common.idr | 11 +- src/Core/Case/CaseBuilder.idr | 2 +- src/Core/Case/CaseTree.idr | 1 - src/Core/CompileExpr/Pretty.idr | 4 +- src/Core/Context/Context.idr | 2 +- src/Core/Name/Scoped.idr | 9 -- src/Core/Ord.idr | 4 +- src/Core/TT/Subst.idr | 2 + src/Core/TT/Var.idr | 27 +---- src/Libraries/Data/SnocList/SizeOf.idr | 2 +- src/TTImp/TTImp.idr | 2 +- 22 files changed, 195 insertions(+), 222 deletions(-) diff --git a/src/Compiler/ANF.idr b/src/Compiler/ANF.idr index 1018c995043..93f20009207 100644 --- a/src/Compiler/ANF.idr +++ b/src/Compiler/ANF.idr @@ -191,12 +191,12 @@ mlet fc val sc bindAsFresh : {auto v : Ref Next Int} -> - (args : List Name) -> AVars vars' -> - Core (List Int, AVars (Scope.ext vars' args)) -bindAsFresh [] vs = pure ([], vs) -bindAsFresh (n :: ns) vs + (args : Scope) -> AVars vars' -> + Core (List Int, AVars (vars' ++ args)) +bindAsFresh [<] vs = pure ([], vs) +bindAsFresh (ns :< n) vs = do i <- nextVar - mapFst (i ::) <$> bindAsFresh ns (vs :< i) + bimap (i ::) (:< i) <$> bindAsFresh ns vs mutual anfArgs : {auto v : Ref Next Int} -> @@ -208,7 +208,7 @@ mutual anf : {auto v : Ref Next Int} -> AVars vars -> Lifted vars -> Core ANF - anf vs (LLocal fc p) = pure $ AV fc (ALocal (lookup p vs)) + anf vs (LLocal fc p) = pure $ AV fc (ALocal (lookup vs p)) anf vs (LAppName fc lazy n args) = anfArgs fc vs args (AAppName fc lazy n) anf vs (LUnderApp fc n m args) @@ -261,12 +261,12 @@ export toANF : LiftedDef -> Core ANFDef toANF (MkLFun args scope sc) = do v <- newRef Next (the Int 0) - (iargs, vsNil) <- bindAsFresh (cast args) AVars.empty + (iargs, vsNil) <- bindAsFresh args AVars.empty let vs : AVars args := rewrite sym $ appendLinLeftNeutral args in - rewrite snocAppendAsFish Scope.empty args in vsNil - (iargs', vs) <- bindAsFresh (cast scope) vs - sc' <- anf (rewrite snocAppendAsFish args scope in vs) sc + vsNil + (iargs', vs) <- bindAsFresh scope vs + sc' <- anf vs sc pure $ MkAFun (iargs ++ iargs') sc' toANF (MkLCon t a ns) = pure $ MkACon t a ns toANF (MkLForeign ccs fargs t) = pure $ MkAForeign ccs fargs t diff --git a/src/Compiler/CaseOpts.idr b/src/Compiler/CaseOpts.idr index 305dd015259..1726e79d99d 100644 --- a/src/Compiler/CaseOpts.idr +++ b/src/Compiler/CaseOpts.idr @@ -36,33 +36,33 @@ shiftUnder : {args : _} -> shiftUnder First = weakenNVar (mkSizeOf args) (MkNVar First) shiftUnder (Later p) = insertNVar (mkSizeOf args) (MkNVar p) -shiftVar : {outer : Scope} -> {args : List Name} -> - NVar n ((vars <>< args :< x) ++ outer) -> - NVar n ((vars :< x <>< args) ++ outer) +shiftVar : {inner : Scope} -> {args : Scope} -> + NVar n ((vars ++ args :< x) ++ inner) -> + NVar n ((vars :< x ++ args) ++ inner) shiftVar nvar - = let out = mkSizeOf outer in - case locateNVar out nvar of - Left nvar => embed nvar - Right (MkNVar p) => weakenNs out (shiftUndersN (mkSizeOf _) p) + = let inn = mkSizeOf inner in + case locateNVar inn nvar of + Left (MkNVar p) => weakenNs inn (shiftUnderNs (mkSizeOf args) p) + Right nvar => embed nvar mutual - shiftBinder : {outer, args : _} -> + shiftBinder : {inner, args : _} -> (new : Name) -> - CExp (((vars <>< args) :< old) ++ outer) -> - CExp ((vars :< new <>< args) ++ outer) + CExp (((vars ++ args) :< old) ++ inner) -> + CExp ((vars :< new ++ args) ++ inner) shiftBinder new (CLocal fc p) = case shiftVar (MkNVar p) of MkNVar p' => CLocal fc (renameVar p') where - renameVar : IsVar x i ((vars :< old <>< args) ++ local) -> - IsVar x i ((vars :< new <>< args) ++ local) + 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 new (CRef fc n) = CRef fc n - shiftBinder {outer} new (CLam fc n sc) - = CLam fc n $ shiftBinder {outer = outer :< n} new sc + shiftBinder {inner} new (CLam fc n sc) + = CLam fc n $ shiftBinder {inner = inner :< n} new sc shiftBinder new (CLet fc n inlineOK val sc) = CLet fc n inlineOK (shiftBinder new val) - $ shiftBinder {outer = outer :< n} new sc + $ shiftBinder {inner = inner :< 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) @@ -84,30 +84,30 @@ mutual shiftBinder new (CErased fc) = CErased fc shiftBinder new (CCrash fc msg) = CCrash fc msg - shiftBinderConAlt : {outer, args : _} -> + shiftBinderConAlt : {inner, args : _} -> (new : Name) -> - CConAlt (((vars <>< args) :< old) ++ outer) -> - CConAlt ((vars :< new <>< args) ++ outer) + CConAlt (((vars ++ args) :< old) ++ inner) -> + CConAlt ((vars :< new ++ args) ++ inner) shiftBinderConAlt new (MkConAlt n ci t args' sc) - = let sc' : CExp (((vars <>< args) :< old) ++ (outer <>< args')) - = rewrite sym $ snocAppendFishAssociative (vars <>< args :< old) outer args' in sc in + = let sc' : CExp (((vars ++ args) :< old) ++ (inner ++ args')) + = (rewrite appendAssociative ((vars ++ args) :< old) inner args' in sc) in MkConAlt n ci t args' $ - rewrite snocAppendFishAssociative (vars :< new <>< args) outer args' - in shiftBinder new {outer = outer <>< args'} sc' + rewrite sym $ appendAssociative (vars :< new ++ args) inner args' in + shiftBinder new sc' - shiftBinderConstAlt : {outer, args : _} -> + shiftBinderConstAlt : {inner, args : _} -> (new : Name) -> - CConstAlt (((vars <>< args) :< old) ++ outer) -> - CConstAlt ((vars :< new <>< args) ++ outer) + CConstAlt (((vars ++ args) :< old) ++ inner) -> + CConstAlt ((vars :< new ++ args) ++ inner) 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 (Scope.bind (Scope.ext vars args) old) -> - CExp (Scope.ext (Scope.bind vars new) args) -liftOutLambda = shiftBinder {outer = Scope.empty} + CExp (Scope.bind (Scope.addInner vars args) old) -> + CExp (Scope.addInner (Scope.bind vars new) args) +liftOutLambda = shiftBinder {inner = Scope.empty} -- If all the alternatives start with a lambda, we can have a single lambda -- binding outside @@ -127,7 +127,7 @@ tryLiftOutConst : (new : Name) -> tryLiftOutConst new [] = Just [] tryLiftOutConst new (MkConstAlt c (CLam fc x sc) :: as) = do as' <- tryLiftOutConst new as - let sc' = liftOutLambda {args = []} new sc + let sc' = liftOutLambda {args = [<]} new sc pure (MkConstAlt c sc' :: as') tryLiftOutConst _ _ = Nothing @@ -136,7 +136,7 @@ tryLiftDef : (new : Name) -> Maybe (Maybe (CExp (Scope.bind vars new))) tryLiftDef new Nothing = Just Nothing tryLiftDef new (Just (CLam fc x sc)) - = let sc' = liftOutLambda {args = []} new sc in + = let sc' = liftOutLambda {args = [<]} new sc in pure (Just sc') tryLiftDef _ _ = Nothing @@ -312,8 +312,8 @@ doCaseOfCase fc x xalts xdef alts def updateAlt (MkConAlt n ci t args sc) = MkConAlt n ci t args $ CConCase fc sc - (map (weakensN (mkSizeOf args)) alts) - (map (weakensN (mkSizeOf args)) def) + (map (weakenNs (mkSizeOf args)) alts) + (map (weakenNs (mkSizeOf args)) def) updateDef : CExp vars -> CExp vars updateDef sc = CConCase fc sc alts def diff --git a/src/Compiler/CompileExpr.idr b/src/Compiler/CompileExpr.idr index d6cc3a89a3b..e7f8bcfe6d7 100644 --- a/src/Compiler/CompileExpr.idr +++ b/src/Compiler/CompileExpr.idr @@ -61,7 +61,7 @@ etaExpand i Z exp args = mkApp exp (map (mkLocal (getFC exp)) (reverse args)) etaExpand i (S k) exp args = CLam (getFC exp) (MN "eta" i) (etaExpand (i + 1) k (weaken exp) - (first :: map weakenVar args)) + (first :: map later args)) export expandToArity : Nat -> CExp vars -> List (CExp vars) -> CExp vars @@ -224,7 +224,7 @@ mutual Just gdef <- lookupCtxtExact x (gamma defs) | Nothing => -- primitive type match do xn <- getFullName x - pure $ MkConAlt xn TYCON Nothing args !(toCExpTree n sc) + pure $ MkConAlt xn TYCON Nothing (cast args) !(toCExpTree n (rewrite sym $ fishAsSnocAppend vars args in sc)) :: !(conCases n ns) case (definition gdef) of DCon _ arity (Just pos) => conCases n ns -- skip it @@ -235,16 +235,16 @@ mutual sc' <- toCExpTree n sc ns' <- conCases n ns if dcon (definition gdef) - then pure $ MkConAlt xn !(dconFlag xn) (Just tag) (toList args') (shrinkCExp subList sc') :: ns' - else pure $ MkConAlt xn !(dconFlag xn) Nothing (toList args') (shrinkCExp subList sc') :: ns' + then pure $ MkConAlt xn !(dconFlag xn) (Just tag) args' (shrinkCExp subList sc') :: ns' + else pure $ MkConAlt xn !(dconFlag xn) Nothing args' (shrinkCExp subList sc') :: ns' where dcon : Def -> Bool dcon (DCon {}) = True dcon _ = False - subThinList : Thin (vars ++ args') (vars ++ ([<] <>< args)) -> Thin (vars <>< (args' <>> [])) (vars <>< args) - subThinList t = do rewrite fishAsSnocAppend vars (toList args') - rewrite castToList args' + subThinList : Thin (vars ++ args') (vars ++ ([<] <>< args)) -> Thin (vars ++ args') (vars <>< args) + subThinList t = do -- rewrite fishAsSnocAppend vars (toList args') + -- rewrite castToList args' rewrite fishAsSnocAppend vars args t @@ -310,10 +310,9 @@ mutual := rewrite sym $ fishAsSnocAppend vars args in sc' let scope : CExp ((vars ++ [ (ns : Scope) -> CExp ns -> ClosedCExp @@ -581,7 +580,7 @@ toCDef n ty _ (ExternDef arity) -- TODO has quadratic runtime getVars : ArgList k ns -> List (Var ns) getVars Z = [] - getVars (S rest) = first :: map weakenVar (getVars rest) + getVars (S rest) = first :: map later (getVars rest) toCDef n ty _ (ForeignDef arity cs) = do defs <- get Ctxt @@ -594,7 +593,7 @@ toCDef n ty _ (Builtin {arity} op) -- TODO has quadratic runtime getVars : ArgList k ns -> Vect k (Var ns) getVars Z = [] - getVars (S rest) = first :: map weakenVar (getVars rest) + getVars (S rest) = first :: map later (getVars rest) toCDef n _ _ (DCon tag arity pos) = do let nt = snd <$> pos diff --git a/src/Compiler/ES/TailRec.idr b/src/Compiler/ES/TailRec.idr index 8361a466862..92114468cbf 100644 --- a/src/Compiler/ES/TailRec.idr +++ b/src/Compiler/ES/TailRec.idr @@ -117,6 +117,7 @@ module Compiler.ES.TailRec import Data.List1 +import Data.SnocList import Data.SortedSet import Data.SortedMap as M import Libraries.Data.Graph @@ -246,7 +247,7 @@ tcDoneName gi = MN "TcDone" gi conAlt : TcGroup -> TcFunction -> NamedConAlt conAlt (MkTcGroup tcIx funs) (MkTcFunction n ix args exp) = let name = tcContinueName tcIx ix - in MkNConAlt name DATACON (Just ix) args (toTc exp) + in MkNConAlt name DATACON (Just ix) (cast args) (toTc exp) where mutual diff --git a/src/Compiler/ES/ToAst.idr b/src/Compiler/ES/ToAst.idr index f4937ae7f46..f4f343bc689 100644 --- a/src/Compiler/ES/ToAst.idr +++ b/src/Compiler/ES/ToAst.idr @@ -3,6 +3,7 @@ module Compiler.ES.ToAst import Data.Vect +import Data.SnocList import Core.CompileExpr import Core.Context import Compiler.ES.Ast @@ -223,7 +224,7 @@ mutual -- We map the list of args to the corresponding -- data projections (field accessors). They'll -- be then properly inlined when converting `x`. - projections sc args + projections sc (toList args) MkEConAlt (tag n tg) ci <$> stmt e x -- a single branch in a pattern match on a constant diff --git a/src/Compiler/Inline.idr b/src/Compiler/Inline.idr index 45c24df5979..35715a659d1 100644 --- a/src/Compiler/Inline.idr +++ b/src/Compiler/Inline.idr @@ -124,7 +124,7 @@ mutual usedCon : {free : _} -> {idx : Nat} -> (0 p : IsVar n idx free) -> CConAlt free -> Int usedCon n (MkConAlt _ _ _ args sc) - = let MkVar n' = weakensN (mkSizeOf args) (MkVar n) in + = let MkVar n' = weakenNs (mkSizeOf args) (MkVar n) in used n' sc usedConst : {free : _} -> @@ -286,20 +286,13 @@ mutual extendLoc : {vars, free : _} -> {auto l : Ref LVar Int} -> - FC -> EEnv free vars -> (args' : List Name) -> - Core (Bounds (cast args'), EEnv free (Scope.ext vars args')) - extendLoc fc env [] = pure (None, env) - extendLoc fc env (n :: ns) + FC -> EEnv free vars -> (args' : Scope) -> + Core (Bounds args', EEnv free (Scope.addInner vars args')) + extendLoc fc env [<] = pure (None, env) + extendLoc fc env (ns :< n) = do xn <- genName "cv" - let env' = env :< CRef fc xn - (bs', env'') <- extendLoc fc env' ns - - let - bs'' : Bounds ([< ns) - bs'' = do - rewrite snocAppendFishAssociative [ {auto c : Ref Ctxt Defs} -> @@ -308,9 +301,8 @@ mutual Core (CConAlt free) evalAlt {free} {vars} fc rec env stk (MkConAlt n ci t args sc) = do (bs, env') <- extendLoc fc env args - scEval <- eval rec env' stk - (rewrite sym $ snocAppendFishAssociative free vars args in sc) - pure $ MkConAlt n ci t args (rewrite snocAppendFishAssociative free Scope.empty args in refsToLocals bs scEval) + scEval <- eval rec env' stk (rewrite appendAssociative free vars args in sc) + pure $ MkConAlt n ci t args (refsToLocals bs scEval) evalConstAlt : {vars, free : _} -> {auto c : Ref Ctxt Defs} -> @@ -330,14 +322,17 @@ mutual 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 - = + = let args'' = toList args' in if matches n t n' t' - then case checkLengthMatch args' args of + then case checkLengthMatch (toList args') args of Nothing => pure Nothing Just m => - do let env' = extend env args' args m + do let env' = extend env (toList args') args m pure $ Just !(eval rec env' stk - (rewrite sym $ snocAppendFishAssociative free vars args' in sc)) + (do rewrite sym $ snocAppendFishAssociative free vars (toList args') + rewrite sym $ snocAppendAsFish (free ++ vars) args' + sc + )) else pickAlt rec env stk con alts def where matches : Name -> Maybe Int -> Name -> Maybe Int -> Bool diff --git a/src/Compiler/LambdaLift.idr b/src/Compiler/LambdaLift.idr index 20c998fd16e..ded7aea2419 100644 --- a/src/Compiler/LambdaLift.idr +++ b/src/Compiler/LambdaLift.idr @@ -17,6 +17,7 @@ import Data.String import Data.Vect import Data.SnocList.Operations +import Libraries.Data.List.SizeOf import Libraries.Data.SnocList.SizeOf import Libraries.Data.SnocList.Extra @@ -189,7 +190,8 @@ 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 (Scope.ext vars args)) -> + -- TODO should args be a List? + (args : Scope) -> (body : Lifted (Scope.addInner vars args)) -> LiftedConAlt vars ||| A branch of an "LConst" (constant expression) case statement. @@ -404,6 +406,8 @@ markUsed {vars} {prf} idx (MkUsed us) = let newUsed = replaceAt (finIdx prf) True us in MkUsed newUsed +-- TODO replace ``Vect (length vars) Bool`` by data structure indexed by `vars` so we can erase `vars` +-- TODO this is morally a thinning getUnused : Used vars -> Vect (length vars) Bool getUnused (MkUsed uv) = map not uv @@ -446,7 +450,7 @@ usedVars used (LConCase fc sc alts def) = usedConAlt : {default Nothing lazy : Maybe LazyReason} -> Used vars -> LiftedConAlt vars -> Used vars usedConAlt used (MkLConAlt n ci tag args sc) = - contractUsedManyFish {remove=args} (usedVars (weakenUsedFish used) sc) + contractUsedMany {remove=args} (usedVars (weakenUsed used) sc) usedVars used (LConstCase fc sc alts def) = let defUsed = maybe used (usedVars used {vars}) def @@ -456,81 +460,99 @@ usedVars used (LConstCase fc sc alts def) = usedConstAlt : {default Nothing lazy : Maybe LazyReason} -> Used vars -> LiftedConstAlt vars -> Used vars usedConstAlt used (MkLConstAlt c sc) = usedVars used sc -usedVars used (LPrimVal {}) = used -usedVars used (LErased {}) = used -usedVars used (LCrash {}) = used +usedVars used (LPrimVal _ _) = used +usedVars used (LErased _) = used +usedVars used (LCrash _ _) = used + +unsafeDropVar : + (vars : _) -> + (unused : Vect (length vars) Bool) -> + Var vars -> + Var (dropped vars unused) +unsafeDropVar [<] unused v = v +unsafeDropVar (sx :< x) (False :: us) (MkVar First) = MkVar First +unsafeDropVar (sx :< x) (False :: us) (MkVar (Later idx)) = later $ unsafeDropVar sx us (MkVar idx) +unsafeDropVar (sx :< x) (True :: us) (MkVar First) = assert_total $ + idris_crash "INTERNAL ERROR: Referenced variable marked as unused" +unsafeDropVar (sx :< x) (True :: us) (MkVar (Later idx)) = unsafeDropVar sx us (MkVar idx) + dropIdx : {vars : _} -> {idx : _} -> - (outer : Scope) -> + SizeOf inner -> (unused : Vect (length vars) Bool) -> - (0 p : IsVar x idx (Scope.addInner vars outer)) -> - Var (Scope.addInner (dropped vars unused) outer) -dropIdx [<] (False::_) First = first + (0 p : IsVar x idx (Scope.addInner vars inner)) -> + Var (Scope.addInner (dropped vars unused) inner) +dropIdx inn unused p = + case locateVar inn (MkVar p) of + Left v => weakenNs inn (unsafeDropVar _ unused v) + Right v => embed v + +{- +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 Scope.empty rest p dropIdx [<] (True::rest) (Later p) = dropIdx Scope.empty rest p dropIdx (xs :< _) unused First = first dropIdx (xs :< _) unused (Later p) = Var.later $ dropIdx xs unused p - -dropUnused : {vars : _} -> - {auto _ : Ref Lifts LDefs} -> - {outer : Scope} -> - (unused : Vect (length vars) Bool) -> - (l : Lifted (Scope.addInner vars outer)) -> - Lifted (Scope.addInner (dropped vars unused) outer) -dropUnused _ (LPrimVal fc val) = LPrimVal fc val -dropUnused _ (LErased fc) = LErased fc -dropUnused _ (LCrash fc msg) = LCrash fc msg -dropUnused {outer} unused (LLocal fc p) = - let (MkVar p') = dropIdx outer unused p in LLocal fc p' -dropUnused unused (LCon fc n ci tag args) = - let args' = map (dropUnused unused) args in +-} + +-- TODO this is morally a `Shrinkable`. Replace! +0 DropUnused : Scoped -> Type +DropUnused tm = + {auto _ : Ref Lifts LDefs} -> + {vars : _} -> + {0 inner : _}-> + SizeOf inner -> + (unused : Vect (length vars) Bool) -> + tm (Scope.addInner vars inner) -> + tm (Scope.addInner (dropped vars unused) inner) + +dropUnused : DropUnused Lifted +dropConCase : DropUnused LiftedConAlt +dropConstCase : DropUnused LiftedConstAlt + +dropUnused inn _ (LPrimVal fc val) = LPrimVal fc val +dropUnused inn _ (LErased fc) = LErased fc +dropUnused inn _ (LCrash fc msg) = LCrash fc msg +dropUnused inn unused (LLocal fc p) = + let (MkVar p') = dropIdx inn unused p in LLocal fc p' +dropUnused inn unused (LCon fc n ci tag args) = + let args' = map (dropUnused inn unused) args in LCon fc n ci tag args' -dropUnused {outer} unused (LLet fc n val sc) = - let val' = dropUnused unused val - sc' = dropUnused {outer= outer :< n} (unused) sc in +dropUnused inn unused (LLet fc n val sc) = + let val' = dropUnused inn unused val + sc' = dropUnused (suc inn) (unused) sc in LLet fc n val' sc' -dropUnused unused (LApp fc lazy c arg) = - let c' = dropUnused unused c - arg' = dropUnused unused arg in +dropUnused inn unused (LApp fc lazy c arg) = + let c' = dropUnused inn unused c + arg' = dropUnused inn unused arg in LApp fc lazy c' arg' -dropUnused unused (LOp fc lazy fn args) = - let args' = map (dropUnused unused) args in +dropUnused inn unused (LOp fc lazy fn args) = + let args' = map (dropUnused inn unused) args in LOp fc lazy fn args' -dropUnused unused (LExtPrim fc lazy n args) = - let args' = map (dropUnused unused) args in +dropUnused inn unused (LExtPrim fc lazy n args) = + let args' = map (dropUnused inn unused) args in LExtPrim fc lazy n args' -dropUnused unused (LAppName fc lazy n args) = - let args' = map (dropUnused unused) args in +dropUnused inn unused (LAppName fc lazy n args) = + let args' = map (dropUnused inn unused) args in LAppName fc lazy n args' -dropUnused unused (LUnderApp fc n miss args) = - let args' = map (dropUnused unused) args in +dropUnused inn unused (LUnderApp fc n miss args) = + let args' = map (dropUnused inn unused) args in LUnderApp fc n miss args' -dropUnused {vars} {outer} unused (LConCase fc sc alts def) = - let alts' = map dropConCase alts in - LConCase fc (dropUnused unused sc) alts' (map (dropUnused unused) def) - where - dropConCase : LiftedConAlt (Scope.addInner vars outer) -> - LiftedConAlt (Scope.addInner (dropped vars unused) outer) - dropConCase (MkLConAlt n ci t args sc) = - 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 (Scope.addInner vars outer) -> - LiftedConstAlt (Scope.addInner (dropped vars unused) outer) - dropConstCase (MkLConstAlt c val) = MkLConstAlt c (dropUnused unused val) +dropUnused inn unused (LConCase fc sc alts def) = + let alts' = map (dropConCase inn unused) alts in + LConCase fc (dropUnused inn unused sc) alts' (map (dropUnused inn unused) def) +dropUnused inn unused (LConstCase fc sc alts def) = + let alts' = map (dropConstCase inn unused) alts in + LConstCase fc (dropUnused inn unused sc) alts' (map (dropUnused inn unused) def) + +dropConCase inn unused (MkLConAlt n ci t args sc) = + MkLConAlt n ci t args (underBinders Lifted (\inn => dropUnused inn unused) inn (mkSizeOf args) sc) + +dropConstCase inn unused (MkLConstAlt c val) = MkLConstAlt c (dropUnused inn unused val) + mutual makeLam : {vars : _} -> @@ -547,22 +569,22 @@ mutual let scUsedL = usedVars initUsed scl unusedContracted = contractUsedMany {remove=bound} scUsedL unused = getUnused unusedContracted - scl' = dropUnused {outer=bound} unused scl + scl' = dropUnused (mkSizeOf bound) unused scl n <- genName update Lifts { defs $= ((n, MkLFun (dropped vars unused) bound scl') ::) } pure $ LUnderApp fc n (length bound) (allVars fc vars unused) where - allPrfs : (vs : Scope) -> (unused : Vect (length vs) Bool) -> List (Var vs) - allPrfs [<] _ = [] - allPrfs (vs :< v) (False::uvs) = first :: map weaken (allPrfs vs uvs) - allPrfs (vs :< v) (True::uvs) = map weaken (allPrfs vs uvs) + allPrfs : (vs : Scope) -> SizeOf inner -> (unused : Vect (length vs) Bool) -> List (Var (vs <>< inner)) + allPrfs [<] inn _ = [] + allPrfs (vs :< v) inn (False::uvs) = mkVarFishily inn :: allPrfs vs (suc inn) uvs + allPrfs (vs :< v) inn (True::uvs) = allPrfs vs (suc inn) uvs - -- apply to all the variables. 'First' will be first in the last, which + -- apply to all the variables. 'First' will be first in the list, which -- is good, because the most recently bound name is the first argument to -- the resulting function allVars : FC -> (vs : Scope) -> (unused : Vect (length vs) Bool) -> List (Lifted vs) - allVars fc vs unused = map (\ (MkVar p) => LLocal fc p) (allPrfs vs unused) + allVars fc vs unused = map (\ (MkVar p) => LLocal fc p) (allPrfs vs zero unused) -- if doLazyAnnots = True then annotate function application with laziness -- otherwise use old behaviour (thunk is a function) diff --git a/src/Compiler/Opts/CSE.idr b/src/Compiler/Opts/CSE.idr index d5e6bc3f989..792c1130042 100644 --- a/src/Compiler/Opts/CSE.idr +++ b/src/Compiler/Opts/CSE.idr @@ -120,8 +120,8 @@ dropVar : SizeOf inner -> (0 p : IsVar x n (Scope.addInner outer inner)) -> Maybe (Erased (IsVar x n inner)) dropVar inn p = case locateIsVar inn p of - Left p => Just p - Right p => Nothing + Right p => Just p + Left p => Nothing -- Tries to 'strengthen' an expression by removing an `outer` context. @@ -167,15 +167,9 @@ mutual dropConAlt : Drop CConAlt dropConAlt inn (MkConAlt x y tag args z) = MkConAlt x y tag args <$> - rewrite fishAsSnocAppend inner args in dropCExp - (inn + mkSizeOf (cast args)) - (replace {p = CExp} rule z) - where - rule : (outer ++ inner) <>< args = outer ++ (inner ++ (cast args)) - rule = do rewrite appendAssociative outer inner (cast args) - rewrite fishAsSnocAppend (outer ++ inner) args - Builtin.Refl + (inn + mkSizeOf args) + (replace {p = CExp} (sym $ appendAssociative outer inner args) z) dropConstAlt : Drop CConstAlt dropConstAlt inn (MkConstAlt x y) = MkConstAlt x <$> dropCExp inn y diff --git a/src/Compiler/Opts/ConstantFold.idr b/src/Compiler/Opts/ConstantFold.idr index 142118e4c6b..636b66e5c09 100644 --- a/src/Compiler/Opts/ConstantFold.idr +++ b/src/Compiler/Opts/ConstantFold.idr @@ -54,12 +54,6 @@ wk sout (Wk {ws, ds, vars} rho sws) Wk rho (sws + sout) wk ws rho = Wk rho ws -wksN : Subst ds vars -> SizeOf out -> Subst (Scope.ext ds out) (Scope.ext vars out) -wksN s s' - = rewrite fishAsSnocAppend ds out in - rewrite fishAsSnocAppend vars out in - wk (zero <>< s') s - record WkCExp (vars : Scope) where constructor MkWkCExp {0 outer, supp : Scope} @@ -69,7 +63,7 @@ record WkCExp (vars : Scope) where Weaken WkCExp where weakenNs s' (MkWkCExp {supp, outer} s Refl e) - = MkWkCExp (s + s') (sym $ appendAssociative supp outer ns) e + = MkWkCExp (s + s') (sym $ appendAssociative supp outer inner) e lookup : FC -> Var ds -> Subst ds vars -> CExp vars lookup fc (MkVar p) rho = case go p rho of @@ -175,7 +169,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 (wksN rho (mkSizeOf xs)) e + = MkConAlt n ci t xs $ constFold (wk (mkSizeOf xs) rho) e constFold rho (CConstCase fc sc xs x) = let sc' = constFold rho sc diff --git a/src/Compiler/Opts/Constructor.idr b/src/Compiler/Opts/Constructor.idr index 9b62c89318d..c7bac13dbb4 100644 --- a/src/Compiler/Opts/Constructor.idr +++ b/src/Compiler/Opts/Constructor.idr @@ -103,12 +103,12 @@ natBranch (MkConAlt n SUCC _ _ _) = True natBranch _ = False trySBranch : CExp vars -> CConAlt vars -> Maybe (CExp vars) -trySBranch n (MkConAlt nm SUCC _ [arg] sc) +trySBranch n (MkConAlt nm SUCC _ [ Maybe (CExp vars) -tryZBranch (MkConAlt n ZERO _ [] sc) = Just sc +tryZBranch (MkConAlt n ZERO _ [<] sc) = Just sc tryZBranch _ = Nothing getSBranch : CExp vars -> List (CConAlt vars) -> Maybe (CExp vars) @@ -157,7 +157,7 @@ enum (CConCase fc sc alts def) = do Just $ CConstCase fc sc alts' def where toEnum : CConAlt vars -> Maybe (CConstAlt vars) - toEnum (MkConAlt nm (ENUM n) (Just tag) [] sc) + toEnum (MkConAlt nm (ENUM n) (Just tag) [<] sc) = pure $ MkConstAlt (enumTag n tag) sc toEnum _ = Nothing enum t = Nothing @@ -170,7 +170,7 @@ enum t = Nothing unitTree : Ref NextMN Int => CExp vars -> Core (Maybe (CExp vars)) unitTree exp@(CConCase fc sc alts def) = - let [MkConAlt _ UNIT _ [] e] = alts + let [MkConAlt _ UNIT _ [<] e] = alts | _ => pure Nothing in case sc of -- TODO: Check scrutinee has no effect, and skip let binding CLocal {} => pure $ Just e diff --git a/src/Compiler/Opts/Identity.idr b/src/Compiler/Opts/Identity.idr index 04783ba73f5..9449c8673f5 100644 --- a/src/Compiler/Opts/Identity.idr +++ b/src/Compiler/Opts/Identity.idr @@ -15,11 +15,6 @@ makeArgs args = makeArgs' args id makeArgs' [<] f = [] makeArgs' (xs :< x) f = f first :: makeArgs' xs (f . weaken) -makeArgz : (args : List Name) -> List (Var (Scope.ext vars args)) -makeArgz args - = embedFishily @{ListFreelyEmbeddable} - $ reverse $ Var.allVars ([<] <>< args) - parameters (fn1 : Name) (idIdx : Nat) mutual -- special case for matching on 'Nat'-shaped things @@ -92,8 +87,8 @@ parameters (fn1 : Name) (idIdx : Nat) altEq : CConAlt vars -> Bool altEq (MkConAlt y _ _ args exp) = cexpIdentity - (weakensN (mkSizeOf args) var) - (Just (y, makeArgz args)) + (weakenNs (mkSizeOf args) var) + (Just (y, makeArgs args)) const exp cexpIdentity var con const (CConstCase fc sc xs x) = diff --git a/src/Compiler/Scheme/Common.idr b/src/Compiler/Scheme/Common.idr index 6543af09990..6e642ea9d4e 100644 --- a/src/Compiler/Scheme/Common.idr +++ b/src/Compiler/Scheme/Common.idr @@ -11,6 +11,7 @@ import Compiler.CompileExpr import Core.Context import Libraries.Data.String.Builder +import Data.SnocList import Data.SortedSet import Data.Vect @@ -356,11 +357,11 @@ parameters (constants : SortedSet Name) schConAlt : Nat -> Builder -> NamedConAlt -> Core Builder schConAlt i target (MkNConAlt n ci tag args sc) = pure $ "((" ++ showTag n tag ++ ") " - ++ bindArgs target sc 1 args !(schExp i sc) ++ ")" + ++ bindArgs target sc 1 (toList args) !(schExp i sc) ++ ")" schConUncheckedAlt : Nat -> Builder -> NamedConAlt -> Core Builder schConUncheckedAlt i target (MkNConAlt n ci tag args sc) - = pure $ bindArgs target sc 1 args !(schExp i sc) + = pure $ bindArgs target sc 1 (toList args) !(schExp i sc) schConstAlt : Nat -> Builder -> NamedConstAlt -> Core Builder schConstAlt i target (MkNConstAlt c exp) @@ -433,7 +434,7 @@ parameters (constants : SortedSet Name) where getAltCode : Builder -> NamedConAlt -> Core Builder getAltCode n (MkNConAlt _ _ _ args sc) - = pure $ bindArgs n sc 0 args !(schExp i sc) + = pure $ bindArgs n sc 0 (toList args) !(schExp i sc) schRecordCase _ _ _ _ = throw $ InternalError "Case of a record has multiple alternatives" schListCase : Nat -> NamedCExp -> List NamedConAlt -> Maybe NamedCExp -> @@ -473,7 +474,7 @@ parameters (constants : SortedSet Name) getConsCode : Builder -> List NamedConAlt -> Core (Maybe Builder) getConsCode n [] = pure Nothing - getConsCode n (MkNConAlt _ CONS _ [x,xs] sc :: _) + getConsCode n (MkNConAlt _ CONS _ [ List NamedConAlt -> Core (Maybe Builder) getJustCode n [] = pure Nothing - getJustCode n (MkNConAlt _ JUST _ [x] sc :: _) + getJustCode n (MkNConAlt _ JUST _ [ (Unknown, []) (a :: as) => (embed a, as) - let info = MkInfo {name=r} p (fishyIsVar {outer=[<]} h) ty + let info = MkInfo {name=r} p (isVarFishily {outer=[<]} h) ty rest <- mkNames args ps eq h as pure (info :: rewrite fishAsSnocAppend [ (arg : Name) -> CaseTree (Scope.addInner vars [ CaseAlt vars - -- TODO `arg` and `ty` should be swapped, as in Yaffle ||| Match against a literal ConstCase : Constant -> CaseTree vars -> CaseAlt vars ||| Catch-all case diff --git a/src/Core/CompileExpr/Pretty.idr b/src/Core/CompileExpr/Pretty.idr index 38e16a8af44..971204db6d2 100644 --- a/src/Core/CompileExpr/Pretty.idr +++ b/src/Core/CompileExpr/Pretty.idr @@ -16,8 +16,6 @@ import Idris.Doc.Annotations %hide Core.Name.prettyOp -%hide CompileExpr.(:<) -%hide CompileExpr.Lin %hide String.(::) %hide String.Nil %hide Doc.Nil @@ -94,7 +92,7 @@ mutual prettyNamedConAlt : NamedConAlt -> Doc IdrisSyntax prettyNamedConAlt (MkNConAlt x ci tag args exp) - = sep (prettyCon x ci tag :: map prettyName args ++ [fatArrow <+> softline <+> align (prettyNamedCExp exp) ]) + = sep (prettyCon x ci tag :: map prettyName (toList args) ++ [fatArrow <+> softline <+> align (prettyNamedCExp exp) ]) prettyNamedConstAlt : NamedConstAlt -> Doc IdrisSyntax prettyNamedConstAlt (MkNConstAlt x exp) diff --git a/src/Core/Context/Context.idr b/src/Core/Context/Context.idr index d6b803f9cbb..12f01a0741e 100644 --- a/src/Core/Context/Context.idr +++ b/src/Core/Context/Context.idr @@ -304,7 +304,7 @@ record GlobalDef where location : FC fullname : Name -- original unresolved name type : ClosedTerm - eraseArgs : NatSet -- which argument positions to erase at runtime + eraseArgs : NatSet -- which argument positions to erase at runtime, integers are de Bruijn levels safeErase : NatSet -- which argument positions are safe to assume -- erasable without 'dotting', because their types -- are collapsible relative to non-erased arguments diff --git a/src/Core/Name/Scoped.idr b/src/Core/Name/Scoped.idr index 2985f5bd685..7a6c6320094 100644 --- a/src/Core/Name/Scoped.idr +++ b/src/Core/Name/Scoped.idr @@ -69,15 +69,6 @@ scopeEq (xs :< x) (ys :< y) Just Refl scopeEq _ _ = Nothing -export -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 - ------------------------------------------------------------------------ -- Generate a fresh name (for a given scope) diff --git a/src/Core/Ord.idr b/src/Core/Ord.idr index ed23d7789d7..58bbcef04ff 100644 --- a/src/Core/Ord.idr +++ b/src/Core/Ord.idr @@ -46,7 +46,7 @@ mutual export covering Eq (CConAlt vars) where - MkConAlt n1 _ t1 a1 e1 == MkConAlt n2 _ t2 a2 e2 = t1 == t2 && n1 == n2 && case localEq a1 a2 of + MkConAlt n1 _ t1 a1 e1 == MkConAlt n2 _ t2 a2 e2 = t1 == t2 && n1 == n2 && case scopeEq a1 a2 of Just Refl => e1 == e2 Nothing => False @@ -103,7 +103,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 localEq a1 a2 of + compare t1 t2 `thenCmp` compare n1 n2 `thenCmp` case scopeEq a1 a2 of Just Refl => compare e1 e2 Nothing => compare a1 a2 diff --git a/src/Core/TT/Subst.idr b/src/Core/TT/Subst.idr index 2ca3e99f315..dd0821b60c6 100644 --- a/src/Core/TT/Subst.idr +++ b/src/Core/TT/Subst.idr @@ -11,6 +11,8 @@ import Libraries.Data.SnocList.SizeOf %default total public export +-- TODO revisit order of ds and vars? +-- TODO vars is constantly applied Subst : Scoped -> Scope -> Scoped Subst tm ds vars = All (\_ => tm vars) ds diff --git a/src/Core/TT/Var.idr b/src/Core/TT/Var.idr index 5a02337821a..5eb071fceba 100644 --- a/src/Core/TT/Var.idr +++ b/src/Core/TT/Var.idr @@ -61,6 +61,7 @@ finIdx (Later l) = FS (finIdx l) ||| Recover the value pointed at by an IsVar proof ||| O(n) in the size of the index +-- TODO make return type a Singleton export nameAt : {vars : SnocList a} -> {idx : Nat} -> (0 p : IsVar n idx vars) -> a nameAt {vars = _ :< n} First = n @@ -318,16 +319,6 @@ insertNVar p v = case locateNVar p v of Left v => weakenNVar p (later v) Right v => embedNVar v --- TODO clean-up implementation -export -insertNVarFishily : SizeOf inner -> - NVar nm (outer <>< inner) -> - NVar nm (outer :< n <>< inner) -insertNVarFishily p v - = rewrite fishAsSnocAppend (outer :< n) inner in - insertNVar (zero <>< p) - $ replace {p = NVar nm} (fishAsSnocAppend outer inner) v - export insertNVarNames : GenWeakenable (NVar name) insertNVarNames p q v = case locateNVar q v of @@ -466,23 +457,13 @@ FreelyEmbeddable (NVar nm) where ||| Moving the zeroth variable under a set number of variables export -shiftUnderNs : SizeOf {a = Name} inner -> +shiftUnderNs : SizeOf {a = Name} args -> {idx : _} -> - (0 p : IsVar n idx (outer ++ inner :< x)) -> - NVar n (outer :< x ++ inner) + (0 p : IsVar n idx (vars ++ args :< x)) -> + NVar n (vars :< x ++ args) 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 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) = insertNVarFishily s (MkNVar p) - namespace IsVar export lookup : {idx : _} -> All p vs -> (0 _ : IsVar x idx vs) -> p x diff --git a/src/Libraries/Data/SnocList/SizeOf.idr b/src/Libraries/Data/SnocList/SizeOf.idr index a09172d5064..896e4dc5172 100644 --- a/src/Libraries/Data/SnocList/SizeOf.idr +++ b/src/Libraries/Data/SnocList/SizeOf.idr @@ -44,7 +44,7 @@ public export suc : SizeOf as -> SizeOf (as :< a) suc (MkSizeOf n p) = MkSizeOf (S n) (S p) --- ||| suc but from the right +-- ||| suc but from the left export sucL : SizeOf as -> SizeOf ([ NameType -> Term vars)) -> (Name, (Maybe Name, List (Var (Scope.addInner vars wkns)), FC -> NameType -> Term (Scope.addInner vars wkns))) From 77ca7b2b9f6d00615fd195cb33ad56c7e67f2f7d Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Sat, 22 Nov 2025 01:44:45 +0300 Subject: [PATCH 09/14] [ refactor ] change constructor argument representation from Scope to List Name This refactor changes the representation of constructor arguments throughout the compiler from `Scope` to `List Name`. This simplifies the API and reduces complexity in handling variable indices. Key changes: - Updated `MkConAlt` and related types to use `List Name` instead of `Scope` for constructor arguments - Modified variable binding and weakening operations to work with list-based arguments - Adjusted pattern matching and case analysis code throughout the compiler - Added new helper functions for list-based variable operations The change affects multiple compiler modules including ANF, LambdaLift, CaseOpts, and optimization passes, ensuring consistent handling of constructor arguments across the compilation pipeline. --- src/Compiler/ANF.idr | 20 +++++++------- src/Compiler/CaseOpts.idr | 42 +++++++++++++++--------------- src/Compiler/Common.idr | 2 +- src/Compiler/CompileExpr.idr | 6 ++--- src/Compiler/Inline.idr | 17 ++++++------ src/Compiler/LambdaLift.idr | 19 +++++++------- src/Compiler/Opts/CSE.idr | 6 ++--- src/Compiler/Opts/ConstantFold.idr | 8 +++++- src/Compiler/Opts/Constructor.idr | 8 +++--- src/Compiler/Opts/Identity.idr | 10 +++++-- src/Compiler/Scheme/Common.idr | 4 +-- src/Compiler/Separate.idr | 1 + src/Core/CompileExpr.idr | 25 +++++++++++------- src/Core/Name/Scoped.idr | 9 +++++++ src/Core/Ord.idr | 4 +-- src/Core/TT/Var.idr | 17 ++++++++++++ 16 files changed, 122 insertions(+), 76 deletions(-) diff --git a/src/Compiler/ANF.idr b/src/Compiler/ANF.idr index 93f20009207..fd3f184b962 100644 --- a/src/Compiler/ANF.idr +++ b/src/Compiler/ANF.idr @@ -191,12 +191,12 @@ mlet fc val sc bindAsFresh : {auto v : Ref Next Int} -> - (args : Scope) -> AVars vars' -> - Core (List Int, AVars (vars' ++ args)) -bindAsFresh [<] vs = pure ([], vs) -bindAsFresh (ns :< n) vs + (args : List Name) -> AVars vars' -> + Core (List Int, AVars (Scope.ext vars' args)) +bindAsFresh [] vs = pure ([], vs) +bindAsFresh (n :: ns) vs = do i <- nextVar - bimap (i ::) (:< i) <$> bindAsFresh ns vs + mapFst (i ::) <$> bindAsFresh ns (vs :< i) mutual anfArgs : {auto v : Ref Next Int} -> @@ -262,11 +262,11 @@ toANF : LiftedDef -> Core ANFDef toANF (MkLFun args scope sc) = do v <- newRef Next (the Int 0) (iargs, vsNil) <- bindAsFresh args AVars.empty - let vs : AVars args - := rewrite sym $ appendLinLeftNeutral args in - vsNil - (iargs', vs) <- bindAsFresh scope vs - sc' <- anf vs sc + (iargs', vs) <- bindAsFresh (toList scope) vsNil + sc' <- anf vs $ + do rewrite fishAsSnocAppend (cast args) (toList scope) + rewrite castToList scope + sc pure $ MkAFun (iargs ++ iargs') sc' toANF (MkLCon t a ns) = pure $ MkACon t a ns toANF (MkLForeign ccs fargs t) = pure $ MkAForeign ccs fargs t diff --git a/src/Compiler/CaseOpts.idr b/src/Compiler/CaseOpts.idr index 1726e79d99d..972823db75f 100644 --- a/src/Compiler/CaseOpts.idr +++ b/src/Compiler/CaseOpts.idr @@ -36,26 +36,26 @@ shiftUnder : {args : _} -> shiftUnder First = weakenNVar (mkSizeOf args) (MkNVar First) shiftUnder (Later p) = insertNVar (mkSizeOf args) (MkNVar p) -shiftVar : {inner : Scope} -> {args : Scope} -> - NVar n ((vars ++ args :< x) ++ inner) -> - NVar n ((vars :< x ++ args) ++ inner) +shiftVar : {inner : Scope} -> {args : List Name} -> + NVar n ((vars <>< args :< x) ++ inner) -> + NVar n ((vars :< x <>< args) ++ inner) shiftVar nvar = let inn = mkSizeOf inner in case locateNVar inn nvar of - Left (MkNVar p) => weakenNs inn (shiftUnderNs (mkSizeOf args) p) + Left (MkNVar p) => weakenNs inn (shiftUndersN (mkSizeOf _) p) Right nvar => embed nvar mutual shiftBinder : {inner, args : _} -> (new : Name) -> - CExp (((vars ++ args) :< old) ++ inner) -> - CExp ((vars :< new ++ args) ++ inner) + CExp (((vars <>< args) :< old) ++ inner) -> + CExp ((vars :< new <>< args) ++ inner) shiftBinder new (CLocal fc p) = case shiftVar (MkNVar p) of MkNVar p' => CLocal fc (renameVar p') where - renameVar : IsVar x i ((vars :< old ++ args) ++ local) -> - IsVar x i ((vars :< new ++ args) ++ local) + 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 new (CRef fc n) = CRef fc n shiftBinder {inner} new (CLam fc n sc) @@ -86,27 +86,27 @@ mutual shiftBinderConAlt : {inner, args : _} -> (new : Name) -> - CConAlt (((vars ++ args) :< old) ++ inner) -> - CConAlt ((vars :< new ++ args) ++ inner) + CConAlt (((vars <>< args) :< old) ++ inner) -> + CConAlt ((vars :< new <>< args) ++ inner) shiftBinderConAlt new (MkConAlt n ci t args' sc) - = let sc' : CExp (((vars ++ args) :< old) ++ (inner ++ args')) - = (rewrite appendAssociative ((vars ++ args) :< old) inner args' in sc) in + = let sc' : CExp (((vars <>< args) :< old) ++ (inner <>< args')) + = rewrite sym $ snocAppendFishAssociative (vars <>< args :< old) inner args' in sc in MkConAlt n ci t args' $ - rewrite sym $ appendAssociative (vars :< new ++ args) inner args' in + rewrite snocAppendFishAssociative (vars :< new <>< args) inner args' in shiftBinder new sc' shiftBinderConstAlt : {inner, args : _} -> (new : Name) -> - CConstAlt (((vars ++ args) :< old) ++ inner) -> - CConstAlt ((vars :< new ++ args) ++ inner) + CConstAlt (((vars <>< args) :< old) ++ inner) -> + CConstAlt ((vars :< new <>< args) ++ inner) 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 (Scope.bind (Scope.addInner vars args) old) -> - CExp (Scope.addInner (Scope.bind vars new) args) + CExp (Scope.bind (Scope.ext vars args) old) -> + CExp (Scope.ext (Scope.bind vars new) args) liftOutLambda = shiftBinder {inner = Scope.empty} -- If all the alternatives start with a lambda, we can have a single lambda @@ -127,7 +127,7 @@ tryLiftOutConst : (new : Name) -> tryLiftOutConst new [] = Just [] tryLiftOutConst new (MkConstAlt c (CLam fc x sc) :: as) = do as' <- tryLiftOutConst new as - let sc' = liftOutLambda {args = [<]} new sc + let sc' = liftOutLambda {args = []} new sc pure (MkConstAlt c sc' :: as') tryLiftOutConst _ _ = Nothing @@ -136,7 +136,7 @@ tryLiftDef : (new : Name) -> Maybe (Maybe (CExp (Scope.bind vars new))) tryLiftDef new Nothing = Just Nothing tryLiftDef new (Just (CLam fc x sc)) - = let sc' = liftOutLambda {args = [<]} new sc in + = let sc' = liftOutLambda {args = []} new sc in pure (Just sc') tryLiftDef _ _ = Nothing @@ -312,8 +312,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 a64bdc7744d..dcf30f84cab 100644 --- a/src/Compiler/Common.idr +++ b/src/Compiler/Common.idr @@ -348,7 +348,7 @@ getCompileDataWith exports doLazyAnnots phase_in tm_in traverse (lambdaLift doLazyAnnots) cseDefs else pure [] - let lifted = (mainname, MkLFun Scope.empty Scope.empty liftedtm) :: + let lifted = (mainname, MkLFun [] Scope.empty liftedtm) :: (ldefs ++ concat lifted_in) anf <- if phase >= ANF diff --git a/src/Compiler/CompileExpr.idr b/src/Compiler/CompileExpr.idr index e7f8bcfe6d7..69229f3fae2 100644 --- a/src/Compiler/CompileExpr.idr +++ b/src/Compiler/CompileExpr.idr @@ -224,7 +224,7 @@ mutual Just gdef <- lookupCtxtExact x (gamma defs) | Nothing => -- primitive type match do xn <- getFullName x - pure $ MkConAlt xn TYCON Nothing (cast args) !(toCExpTree n (rewrite sym $ fishAsSnocAppend vars args in sc)) + pure $ MkConAlt xn TYCON Nothing (cast args) !(toCExpTree n sc) :: !(conCases n ns) case (definition gdef) of DCon _ arity (Just pos) => conCases n ns -- skip it @@ -235,8 +235,8 @@ mutual sc' <- toCExpTree n sc ns' <- conCases n ns if dcon (definition gdef) - then pure $ MkConAlt xn !(dconFlag xn) (Just tag) args' (shrinkCExp subList sc') :: ns' - else pure $ MkConAlt xn !(dconFlag xn) Nothing args' (shrinkCExp subList sc') :: ns' + then pure $ MkConAlt xn !(dconFlag xn) (Just tag) (cast args') (rewrite sym $ snocAppendAsFish vars args' in shrinkCExp subList sc') :: ns' + else pure $ MkConAlt xn !(dconFlag xn) Nothing (cast args') (rewrite sym $ snocAppendAsFish vars args' in shrinkCExp subList sc') :: ns' where dcon : Def -> Bool dcon (DCon {}) = True diff --git a/src/Compiler/Inline.idr b/src/Compiler/Inline.idr index 35715a659d1..d8e02e91f9c 100644 --- a/src/Compiler/Inline.idr +++ b/src/Compiler/Inline.idr @@ -124,7 +124,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 : _} -> @@ -300,9 +300,13 @@ mutual FC -> List Name -> EEnv free vars -> Stack free -> CConAlt (Scope.addInner 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 - scEval <- eval rec env' stk (rewrite appendAssociative free vars args in sc) - pure $ MkConAlt n ci t args (refsToLocals bs scEval) + = do (bs, env') <- extendLoc fc env (cast args) + scEval <- eval rec env' stk $ + do rewrite appendAssociative free vars (cast args) + rewrite sym $ fishAsSnocAppend (free ++ vars) (args) + sc + let sc'' = rewrite snocAppendFishAssociative free Scope.empty args in refsToLocals bs scEval + pure $ MkConAlt n ci t args sc'' evalConstAlt : {vars, free : _} -> {auto c : Ref Ctxt Defs} -> @@ -329,10 +333,7 @@ mutual Just m => do let env' = extend env (toList args') args m pure $ Just !(eval rec env' stk - (do rewrite sym $ snocAppendFishAssociative free vars (toList args') - rewrite sym $ snocAppendAsFish (free ++ vars) args' - sc - )) + (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 diff --git a/src/Compiler/LambdaLift.idr b/src/Compiler/LambdaLift.idr index ded7aea2419..98ab2a37210 100644 --- a/src/Compiler/LambdaLift.idr +++ b/src/Compiler/LambdaLift.idr @@ -190,8 +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) -> - -- TODO should args be a List? - (args : Scope) -> (body : Lifted (Scope.addInner vars args)) -> + (args : List Name) -> (body : Lifted (Scope.ext vars args)) -> LiftedConAlt vars ||| A branch of an "LConst" (constant expression) case statement. @@ -228,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 : Scope) -> (scope : Scope) -> - (body : Lifted (Scope.addInner args scope)) -> LiftedDef + MkLFun : (args : List Name) -> (scope : Scope) -> + (body : Lifted (Scope.addInner (cast args) scope)) -> LiftedDef ||| Constructs a definition of a constructor for a compound data type. ||| @@ -450,7 +449,7 @@ usedVars used (LConCase fc sc alts def) = usedConAlt : {default Nothing lazy : Maybe LazyReason} -> 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 @@ -549,7 +548,7 @@ dropUnused inn unused (LConstCase fc sc alts def) = LConstCase fc (dropUnused inn unused sc) alts' (map (dropUnused inn unused) def) dropConCase inn unused (MkLConAlt n ci t args sc) = - MkLConAlt n ci t args (underBinders Lifted (\inn => dropUnused inn unused) inn (mkSizeOf args) sc) + MkLConAlt n ci t args (underBinderz Lifted (\inn => dropUnused inn unused) inn (mkSizeOf args) sc) dropConstCase inn unused (MkLConstAlt c val) = MkLConstAlt c (dropUnused inn unused val) @@ -571,8 +570,10 @@ mutual unused = getUnused unusedContracted scl' = dropUnused (mkSizeOf bound) unused scl n <- genName - update Lifts { defs $= ((n, MkLFun (dropped vars unused) bound scl') ::) } - pure $ LUnderApp fc n (length bound) (allVars fc vars unused) + let scl'' : Lifted ((cast (toList $ dropped vars unused)) ++ bound) + := rewrite castToList (dropped vars unused) in scl' + update Lifts { defs $= ((n, MkLFun (toList $ dropped vars unused) bound scl'') ::) } + pure $ LUnderApp fc n (length bound) (reverse $ allVars fc vars unused) where allPrfs : (vs : Scope) -> SizeOf inner -> (unused : Vect (length vs) Bool) -> List (Var (vs <>< inner)) @@ -646,7 +647,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 Scope.empty expl) :: defs) + pure ((n, MkLFun (toList args) Scope.empty (rewrite castToList args in 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 792c1130042..0f56f32dac2 100644 --- a/src/Compiler/Opts/CSE.idr +++ b/src/Compiler/Opts/CSE.idr @@ -167,9 +167,9 @@ mutual dropConAlt : Drop CConAlt dropConAlt inn (MkConAlt x y tag args z) = MkConAlt x y tag args <$> - dropCExp - (inn + mkSizeOf args) - (replace {p = CExp} (sym $ appendAssociative outer inner args) z) + dropCExp {outer=outer} + (rewrite fishAsSnocAppend inner args in inn + mkSizeOf (cast args)) + (rewrite sym $ snocAppendFishAssociative outer inner args in z) dropConstAlt : Drop CConstAlt dropConstAlt inn (MkConstAlt x y) = MkConstAlt x <$> dropCExp inn y diff --git a/src/Compiler/Opts/ConstantFold.idr b/src/Compiler/Opts/ConstantFold.idr index 636b66e5c09..54aadcafd23 100644 --- a/src/Compiler/Opts/ConstantFold.idr +++ b/src/Compiler/Opts/ConstantFold.idr @@ -54,6 +54,12 @@ wk sout (Wk {ws, ds, vars} rho sws) Wk rho (sws + sout) wk ws rho = Wk rho ws +wksN : Subst ds vars -> SizeOf out -> Subst (Scope.ext ds out) (Scope.ext vars out) +wksN s s' + = rewrite fishAsSnocAppend ds out in + rewrite fishAsSnocAppend vars out in + wk (zero <>< s') s + record WkCExp (vars : Scope) where constructor MkWkCExp {0 outer, supp : Scope} @@ -169,7 +175,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/Constructor.idr b/src/Compiler/Opts/Constructor.idr index c7bac13dbb4..9b62c89318d 100644 --- a/src/Compiler/Opts/Constructor.idr +++ b/src/Compiler/Opts/Constructor.idr @@ -103,12 +103,12 @@ natBranch (MkConAlt n SUCC _ _ _) = True natBranch _ = False trySBranch : CExp vars -> CConAlt vars -> Maybe (CExp vars) -trySBranch n (MkConAlt nm SUCC _ [ Maybe (CExp vars) -tryZBranch (MkConAlt n ZERO _ [<] sc) = Just sc +tryZBranch (MkConAlt n ZERO _ [] sc) = Just sc tryZBranch _ = Nothing getSBranch : CExp vars -> List (CConAlt vars) -> Maybe (CExp vars) @@ -157,7 +157,7 @@ enum (CConCase fc sc alts def) = do Just $ CConstCase fc sc alts' def where toEnum : CConAlt vars -> Maybe (CConstAlt vars) - toEnum (MkConAlt nm (ENUM n) (Just tag) [<] sc) + toEnum (MkConAlt nm (ENUM n) (Just tag) [] sc) = pure $ MkConstAlt (enumTag n tag) sc toEnum _ = Nothing enum t = Nothing @@ -170,7 +170,7 @@ enum t = Nothing unitTree : Ref NextMN Int => CExp vars -> Core (Maybe (CExp vars)) unitTree exp@(CConCase fc sc alts def) = - let [MkConAlt _ UNIT _ [<] e] = alts + let [MkConAlt _ UNIT _ [] e] = alts | _ => pure Nothing in case sc of -- TODO: Check scrutinee has no effect, and skip let binding CLocal {} => pure $ Just e diff --git a/src/Compiler/Opts/Identity.idr b/src/Compiler/Opts/Identity.idr index 9449c8673f5..821b4fe15d1 100644 --- a/src/Compiler/Opts/Identity.idr +++ b/src/Compiler/Opts/Identity.idr @@ -8,6 +8,7 @@ import Data.SnocList import Libraries.Data.List.SizeOf +-- TODO reduce quadratic weakening makeArgs : (args : Scope) -> List (Var (Scope.addInner vars args)) makeArgs args = makeArgs' args id where @@ -15,6 +16,11 @@ makeArgs args = makeArgs' args id makeArgs' [<] f = [] makeArgs' (xs :< x) f = f first :: makeArgs' xs (f . weaken) +makeArgz : (args : List Name) -> List (Var (Scope.ext vars args)) +makeArgz args + = embedFishily @{ListFreelyEmbeddable} + $ reverse $ allVars ([<] <>< args) + parameters (fn1 : Name) (idIdx : Nat) mutual -- special case for matching on 'Nat'-shaped things @@ -87,8 +93,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) = diff --git a/src/Compiler/Scheme/Common.idr b/src/Compiler/Scheme/Common.idr index 6e642ea9d4e..ffdbe1b1d08 100644 --- a/src/Compiler/Scheme/Common.idr +++ b/src/Compiler/Scheme/Common.idr @@ -474,7 +474,7 @@ parameters (constants : SortedSet Name) getConsCode : Builder -> List NamedConAlt -> Core (Maybe Builder) getConsCode n [] = pure Nothing - getConsCode n (MkNConAlt _ CONS _ [ List NamedConAlt -> Core (Maybe Builder) getJustCode n [] = pure Nothing - getJustCode n (MkNConAlt _ JUST _ [ ConInfo -> (tag : Maybe Int) -> (args : Scope) -> - CExp (Scope.addInner vars args) -> CConAlt vars + MkConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : List Name) -> + CExp (Scope.ext vars args) -> CConAlt vars public export data CConstAlt : Scoped where @@ -169,7 +168,7 @@ mutual public export data NamedConAlt : Type where - MkNConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : Scope) -> -- TODO should args be a List? + MkNConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : List Name) -> NamedCExp -> NamedConAlt public export @@ -325,6 +324,12 @@ conArgz : (args : SnocList Name) -> Names (Scope.addInner vars args) -> SnocList conArgz [<] ns = [<] conArgz (as :< a) (ns :< n) = conArgz as ns :< n +conArgs : (args : List Name) -> Names (Scope.ext 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 forgetExp locs (CLocal fc p) = NmLocal fc (lookup locs p) @@ -361,8 +366,8 @@ mutual forgetConAlt : Names vars -> CConAlt vars -> NamedConAlt forgetConAlt locs (MkConAlt n ci t args exp) - = let args' = addLocz args locs in - MkNConAlt n ci t (conArgz args args') (forgetExp args' exp) + = let args' = addLocs args locs in + MkNConAlt n ci t (conArgs args args') (forgetExp args' exp) forgetConstAlt : Names vars -> CConstAlt vars -> NamedConstAlt forgetConstAlt locs (MkConstAlt c exp) @@ -473,7 +478,7 @@ mutual insertNamesConAlt : GenWeakenable CConAlt insertNamesConAlt mid inn (MkConAlt x ci tag args sc) - = MkConAlt x ci tag args (underBinders CExp (CompileExpr.insertNames mid) inn (mkSizeOf args) sc) + = MkConAlt x ci tag args (underBinderz CExp (CompileExpr.insertNames mid) inn (mkSizeOf args) sc) insertNamesConstAlt : GenWeakenable CConstAlt insertNamesConstAlt outer ns (MkConstAlt x sc) = MkConstAlt x (insertNames outer ns sc) @@ -521,7 +526,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) @@ -573,7 +578,7 @@ mutual substConAlt : Substitutable CExp CConAlt substConAlt {outer} {dropped} {inner} drp inn env (MkConAlt x ci tag args sc) - = MkConAlt x ci tag args (underBinders CExp (\inn => substEnv drp inn env) inn (mkSizeOf args) sc) + = MkConAlt x ci tag args (underBinderz CExp (\inn => substEnv drp inn env) inn (mkSizeOf args) sc) substConstAlt : Substitutable CExp CConstAlt substConstAlt outer dropped env (MkConstAlt x sc) = MkConstAlt x (substEnv outer dropped env sc) @@ -631,7 +636,7 @@ mutual CConAlt (Scope.addInner outer inner) -> CConAlt ((outer ++ bound) ++ inner) mkLocalsConAlt bs inn (MkConAlt x ci tag args sc) - = MkConAlt x ci tag args (underBinders CExp (mkLocals bs) inn (mkSizeOf args) sc) + = MkConAlt x ci tag args (underBinderz CExp (mkLocals bs) inn (mkSizeOf args) sc) mkLocalsConstAlt : Bounds bound -> SizeOf inner -> diff --git a/src/Core/Name/Scoped.idr b/src/Core/Name/Scoped.idr index 7a6c6320094..2985f5bd685 100644 --- a/src/Core/Name/Scoped.idr +++ b/src/Core/Name/Scoped.idr @@ -69,6 +69,15 @@ scopeEq (xs :< x) (ys :< y) Just Refl scopeEq _ _ = Nothing +export +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 + ------------------------------------------------------------------------ -- Generate a fresh name (for a given scope) diff --git a/src/Core/Ord.idr b/src/Core/Ord.idr index 58bbcef04ff..ed23d7789d7 100644 --- a/src/Core/Ord.idr +++ b/src/Core/Ord.idr @@ -46,7 +46,7 @@ mutual export covering Eq (CConAlt vars) where - MkConAlt n1 _ t1 a1 e1 == MkConAlt n2 _ t2 a2 e2 = t1 == t2 && n1 == n2 && case scopeEq 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 @@ -103,7 +103,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 scopeEq 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/TT/Var.idr b/src/Core/TT/Var.idr index 5eb071fceba..4b8b9ff2272 100644 --- a/src/Core/TT/Var.idr +++ b/src/Core/TT/Var.idr @@ -319,6 +319,15 @@ insertNVar p v = case locateNVar p v of Left v => weakenNVar p (later v) Right v => embedNVar v +export +insertNVarFishy : SizeOf inner -> + NVar nm (outer <>< inner) -> + NVar nm (outer :< n <>< inner) +insertNVarFishy p v + = rewrite fishAsSnocAppend (outer :< n) inner in + insertNVar (zero <>< p) + $ replace {p = NVar nm} (fishAsSnocAppend outer inner) v + export insertNVarNames : GenWeakenable (NVar name) insertNVarNames p q v = case locateNVar q v of @@ -464,6 +473,14 @@ shiftUnderNs : SizeOf {a = Name} args -> shiftUnderNs s First = weakenNs s (MkNVar First) shiftUnderNs s (Later p) = insertNVar s (MkNVar p) +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) + namespace IsVar export lookup : {idx : _} -> All p vs -> (0 _ : IsVar x idx vs) -> p x From 33840b7abc2915f2f3b7dad0bf44f4667cb0f59b Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Tue, 25 Nov 2025 19:28:08 +0300 Subject: [PATCH 10/14] [ refactor ] fix test regression --- tests/idris2/evaluator/spec001/expected | 44 ++++++++++++------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/tests/idris2/evaluator/spec001/expected b/tests/idris2/evaluator/spec001/expected index f5bbac11dc1..f1608b8250a 100644 --- a/tests/idris2/evaluator/spec001/expected +++ b/tests/idris2/evaluator/spec001/expected @@ -56,30 +56,30 @@ LOG specialise:5: New patterns for _PE.PE_identity_1: (_PE.PE_identity_1 (Prelude.Basics.Nil [a = Prelude.Types.Nat])) = (Prelude.Basics.Nil [a = Prelude.Types.Nat]) (_PE.PE_identity_1 (((Prelude.Basics.(::) [a = Prelude.Types.Nat]) x) xs)) = (((Prelude.Basics.(::) [a = Prelude.Types.Nat]) x) ((Main.identity [a = Prelude.Types.Nat]) xs)) LOG specialise:5: New RHS: (Prelude.Basics.Nil Prelude.Types.Nat) -LOG specialise:5: Already specialised _PE.PE_identity_3c7f5598e5c9b732 -LOG specialise:5: New RHS: (Prelude.Basics.(::) Prelude.Types.Nat x[1] (_PE.PE_identity_3c7f5598e5c9b732 xs[0])) -LOG specialise:5: Already specialised _PE.PE_identity_3c7f5598e5c9b732 -LOG compiler.identity:5: found identity flag for: _PE.PE_identity_3c7f5598e5c9b732, 0 - old def: Just [< {arg:11}]: (%case !{arg:11} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (_PE.PE_identity_3c7f5598e5c9b732 [!{e:2}])]))] Nothing) -LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} +LOG specialise:5: Already specialised _PE.PE_identity_1 +LOG specialise:5: New RHS: (Prelude.Basics.(::) Prelude.Types.Nat x[1] (_PE.PE_identity_1 xs[0])) +LOG specialise:5: Already specialised _PE.PE_identity_1 +LOG compiler.identity:5: found identity flag for: _PE.PE_identity_1, 0 + old def: Just [< {arg:2}]: (%case !{arg:2} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (_PE.PE_identity_1 [!{e:2}])]))] Nothing) +LOG compiler.identity:5: new def: [< {arg:2}]: !{arg:2} LOG compiler.identity:5: found identity flag for: Main.identity, 0 - old def: Just [< {arg:12}]: (%case !{arg:12} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (Main.identity [!{e:2}])]))] Nothing) -LOG compiler.identity:5: new def: [< {arg:12}]: !{arg:12} -LOG compiler.identity:5: found identity flag for: _PE.PE_identity_3c7f5598e5c9b732, 0 - old def: Just [< {arg:11}]: !{arg:11} -LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} + old def: Just [< {arg:3}]: (%case !{arg:3} [(%concase [nil] _builtin.NIL Just 0 [] (%con [nil] _builtin.NIL Just 0 [])), (%concase [cons] _builtin.CONS Just 1 [{e:1}, {e:2}] (%con [cons] _builtin.CONS Just 1 [!{e:1}, (Main.identity [!{e:2}])]))] Nothing) +LOG compiler.identity:5: new def: [< {arg:3}]: !{arg:3} +LOG compiler.identity:5: found identity flag for: _PE.PE_identity_1, 0 + old def: Just [< {arg:2}]: !{arg:2} +LOG compiler.identity:5: new def: [< {arg:2}]: !{arg:2} LOG compiler.identity:5: found identity flag for: Main.identity, 0 - old def: Just [< {arg:12}]: !{arg:12} -LOG compiler.identity:5: new def: [< {arg:12}]: !{arg:12} + old def: Just [< {arg:3}]: !{arg:3} +LOG compiler.identity:5: new def: [< {arg:3}]: !{arg:3} LOG compiler.identity:5: found identity flag for: Main.test, 0 - old def: Just [< {arg:11}]: !{arg:11} -LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} -LOG compiler.identity:5: found identity flag for: _PE.PE_identity_3c7f5598e5c9b732, 0 - old def: Just [< {arg:11}]: !{arg:11} -LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} + old def: Just [< {arg:2}]: !{arg:2} +LOG compiler.identity:5: new def: [< {arg:2}]: !{arg:2} +LOG compiler.identity:5: found identity flag for: _PE.PE_identity_1, 0 + old def: Just [< {arg:2}]: !{arg:2} +LOG compiler.identity:5: new def: [< {arg:2}]: !{arg:2} LOG compiler.identity:5: found identity flag for: Main.identity, 0 - old def: Just [< {arg:12}]: !{arg:12} -LOG compiler.identity:5: new def: [< {arg:12}]: !{arg:12} + old def: Just [< {arg:3}]: !{arg:3} +LOG compiler.identity:5: new def: [< {arg:3}]: !{arg:3} LOG compiler.identity:5: found identity flag for: Main.test, 0 - old def: Just [< {arg:11}]: !{arg:11} -LOG compiler.identity:5: new def: [< {arg:11}]: !{arg:11} + old def: Just [< {arg:2}]: !{arg:2} +LOG compiler.identity:5: new def: [< {arg:2}]: !{arg:2} From 9161a97e429e395d8953b611f14070d52232fbf9 Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Tue, 25 Nov 2025 19:59:03 +0300 Subject: [PATCH 11/14] [ refactor ] fix test regression --- src/Core/Case/CaseBuilder.idr | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Core/Case/CaseBuilder.idr b/src/Core/Case/CaseBuilder.idr index 8d02f0c52c6..e142230bf4d 100644 --- a/src/Core/Case/CaseBuilder.idr +++ b/src/Core/Case/CaseBuilder.idr @@ -1016,12 +1016,12 @@ mutual case mix of Nothing => do log "compile.casetree.intermediate" 25 "match: No clauses" - pure (Unmatched "No clauses") + pure (Unmatched "No clauses in \{show fn}") Just m => do log "compile.casetree.intermediate" 25 $ "match: new case tree " ++ show m Core.pure m match {todo = []} fc fn phase [] err - = maybe (pure (Unmatched "No patterns")) + = maybe (pure (Unmatched "No patterns in \{show fn}")) pure err match {todo = []} fc fn phase ((MkPatClause pvars [] pid (Erased _ Impossible)) :: _) err = pure Impossible @@ -1063,7 +1063,7 @@ mutual List (PatClause (a :: todo) vars) -> Maybe (CaseTree vars) -> Core (CaseTree vars) - conRule fc fn phase [] err = maybe (pure (Unmatched "No constructor clauses")) pure err + conRule fc fn phase [] err = maybe (pure (Unmatched "No constructor clauses in \{show fn}")) pure err -- ASSUMPTION, not expressed in the type, that the patterns all have -- the same variable (pprf) for the first argument. If not, the result -- will be a broken case tree... so we should find a way to express this @@ -1211,7 +1211,7 @@ patCompile : {auto c : Ref Ctxt Defs} -> Maybe (CaseTree Scope.empty) -> Core (args ** CaseTree args) patCompile fc fn phase ty [] def - = maybe (pure (Scope.empty ** Unmatched "No definition")) + = maybe (pure (Scope.empty ** Unmatched "\{show fn} not defined")) (\e => pure (Scope.empty ** e)) def patCompile fc fn phase ty (p :: ps) def @@ -1369,7 +1369,7 @@ getPMDef : {auto c : Ref Ctxt Defs} -> getPMDef fc phase fn ty [] = do log "compile.casetree.getpmdef" 20 "getPMDef: No clauses!" defs <- get Ctxt - pure (cast !(getArgs 0 !(nf defs Env.empty ty)) ** (Unmatched "No clauses", [])) + pure (cast !(getArgs 0 !(nf defs Env.empty ty)) ** (Unmatched "No clauses in \{show fn}", [])) where getArgs : Int -> ClosedNF -> Core (List Name) getArgs i (NBind fc x (Pi _ _ _ _) sc) From 5b575412e64db4015b221598cb6e6f6c64c45235 Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Wed, 26 Nov 2025 12:01:34 +0300 Subject: [PATCH 12/14] [ refactor ] fix import regression --- src/Compiler/Opts/CSE.idr | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Compiler/Opts/CSE.idr b/src/Compiler/Opts/CSE.idr index 0f56f32dac2..d994d236ade 100644 --- a/src/Compiler/Opts/CSE.idr +++ b/src/Compiler/Opts/CSE.idr @@ -38,6 +38,7 @@ import Data.Vect import Libraries.Data.Erased import Libraries.Data.SnocList.SizeOf +import Libraries.Data.SnocList.Extra ||| Maping from a pairing of closed terms together with ||| their size (for efficiency) to the number of From c49a2c496d89ac443c2f9d8c2dcefda1acead35a Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Mon, 1 Dec 2025 11:04:59 +0300 Subject: [PATCH 13/14] [ refactor ] remove useless toLists --- src/Compiler/ES/TailRec.idr | 2 +- src/Compiler/ES/ToAst.idr | 2 +- src/Compiler/Scheme/Common.idr | 6 +++--- src/Core/CompileExpr.idr | 2 +- src/Core/CompileExpr/Pretty.idr | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Compiler/ES/TailRec.idr b/src/Compiler/ES/TailRec.idr index 92114468cbf..c304ba5b4ba 100644 --- a/src/Compiler/ES/TailRec.idr +++ b/src/Compiler/ES/TailRec.idr @@ -247,7 +247,7 @@ tcDoneName gi = MN "TcDone" gi conAlt : TcGroup -> TcFunction -> NamedConAlt conAlt (MkTcGroup tcIx funs) (MkTcFunction n ix args exp) = let name = tcContinueName tcIx ix - in MkNConAlt name DATACON (Just ix) (cast args) (toTc exp) + in MkNConAlt name DATACON (Just ix) args (toTc exp) where mutual diff --git a/src/Compiler/ES/ToAst.idr b/src/Compiler/ES/ToAst.idr index f4f343bc689..c482a96c64a 100644 --- a/src/Compiler/ES/ToAst.idr +++ b/src/Compiler/ES/ToAst.idr @@ -224,7 +224,7 @@ mutual -- We map the list of args to the corresponding -- data projections (field accessors). They'll -- be then properly inlined when converting `x`. - projections sc (toList args) + projections sc args MkEConAlt (tag n tg) ci <$> stmt e x -- a single branch in a pattern match on a constant diff --git a/src/Compiler/Scheme/Common.idr b/src/Compiler/Scheme/Common.idr index ffdbe1b1d08..7de517ab42b 100644 --- a/src/Compiler/Scheme/Common.idr +++ b/src/Compiler/Scheme/Common.idr @@ -357,11 +357,11 @@ parameters (constants : SortedSet Name) schConAlt : Nat -> Builder -> NamedConAlt -> Core Builder schConAlt i target (MkNConAlt n ci tag args sc) = pure $ "((" ++ showTag n tag ++ ") " - ++ bindArgs target sc 1 (toList args) !(schExp i sc) ++ ")" + ++ bindArgs target sc 1 args !(schExp i sc) ++ ")" schConUncheckedAlt : Nat -> Builder -> NamedConAlt -> Core Builder schConUncheckedAlt i target (MkNConAlt n ci tag args sc) - = pure $ bindArgs target sc 1 (toList args) !(schExp i sc) + = pure $ bindArgs target sc 1 args !(schExp i sc) schConstAlt : Nat -> Builder -> NamedConstAlt -> Core Builder schConstAlt i target (MkNConstAlt c exp) @@ -434,7 +434,7 @@ parameters (constants : SortedSet Name) where getAltCode : Builder -> NamedConAlt -> Core Builder getAltCode n (MkNConAlt _ _ _ args sc) - = pure $ bindArgs n sc 0 (toList args) !(schExp i sc) + = pure $ bindArgs n sc 0 args !(schExp i sc) schRecordCase _ _ _ _ = throw $ InternalError "Case of a record has multiple alternatives" schListCase : Nat -> NamedCExp -> List NamedConAlt -> Maybe NamedCExp -> diff --git a/src/Core/CompileExpr.idr b/src/Core/CompileExpr.idr index 4de8755a437..641c8e8d4a3 100644 --- a/src/Core/CompileExpr.idr +++ b/src/Core/CompileExpr.idr @@ -328,7 +328,7 @@ conArgs : (args : List Name) -> Names (Scope.ext vars args) -> List Name conArgs args ns = let ns' : Names (vars ++ cast args) := rewrite sym $ fishAsSnocAppend vars args in ns - in conArgz ([<] <>< args) ns' <>> [] + in toList $ conArgz (cast {to=Scope} args) ns' mutual forgetExp : Names vars -> CExp vars -> NamedCExp diff --git a/src/Core/CompileExpr/Pretty.idr b/src/Core/CompileExpr/Pretty.idr index 971204db6d2..0faf2f27a72 100644 --- a/src/Core/CompileExpr/Pretty.idr +++ b/src/Core/CompileExpr/Pretty.idr @@ -92,7 +92,7 @@ mutual prettyNamedConAlt : NamedConAlt -> Doc IdrisSyntax prettyNamedConAlt (MkNConAlt x ci tag args exp) - = sep (prettyCon x ci tag :: map prettyName (toList args) ++ [fatArrow <+> softline <+> align (prettyNamedCExp exp) ]) + = sep (prettyCon x ci tag :: map prettyName args ++ [fatArrow <+> softline <+> align (prettyNamedCExp exp) ]) prettyNamedConstAlt : NamedConstAlt -> Doc IdrisSyntax prettyNamedConstAlt (MkNConstAlt x exp) From 4bdbf2f64a2c22c571f865ca8fe3e5f055f2d5fb Mon Sep 17 00:00:00 2001 From: "Serge S. Gulin" Date: Mon, 1 Dec 2025 22:37:02 +0300 Subject: [PATCH 14/14] [ refactor ] reverse variable usage initialization logic --- src/TTImp/Elab/Utils.idr | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/TTImp/Elab/Utils.idr b/src/TTImp/Elab/Utils.idr index 131b4cdec7e..6aea59bc027 100644 --- a/src/TTImp/Elab/Utils.idr +++ b/src/TTImp/Elab/Utils.idr @@ -146,7 +146,9 @@ initUsed = MkUsage initUsedCase : SizeOf vs -> Usage vs initUsedCase p = MkUsage { isUsedSet = VarSet.empty - , isLocalSet = maybe id VarSet.delete (last p) (VarSet.full p) + , isLocalSet = case sizedView p of + Z => VarSet.empty + S _ => VarSet.delete first (VarSet.full p) } setUsedVar : Var vs -> Usage vs -> Usage vs