From e6121e09356ed2cb4221d2b375ad3b80407deb9b Mon Sep 17 00:00:00 2001 From: Michael Morgan Date: Fri, 25 Oct 2019 14:24:25 -0700 Subject: [PATCH 01/18] Remove trailing whitespace from Idris sources. This is the result of running the command: $ find . -name '*.idr' -type f -exec sed -i -E 's/\s+$//' {} + I confirmed before running it that this would not affect any markdown formatting in documentation comments. --- libs/base/Control/Monad/Identity.idr | 2 +- libs/base/Control/Monad/State.idr | 16 +- libs/base/Control/WellFounded.idr | 2 +- libs/base/Data/Buffer.idr | 4 +- libs/base/Data/Fin.idr | 6 +- libs/base/Data/IORef.idr | 2 +- libs/base/Data/List.idr | 6 +- libs/base/Data/List/Views.idr | 22 +- libs/base/Data/Nat.idr | 4 +- libs/base/Data/So.idr | 2 +- libs/base/Data/Vect.idr | 12 +- libs/base/Decidable/Equality.idr | 16 +- libs/base/Language/Reflection.idr | 12 +- libs/base/System/File.idr | 10 +- libs/base/System/REPL.idr | 2 +- libs/prelude/Builtin.idr | 2 +- libs/prelude/Prelude.idr | 58 ++-- libs/prelude/PrimIO.idr | 10 +- src/Compiler/Common.idr | 10 +- src/Compiler/Inline.idr | 94 +++---- src/Compiler/Scheme/Chez.idr | 2 +- src/Compiler/Scheme/Chicken.idr | 2 +- src/Compiler/Scheme/Common.idr | 52 ++-- src/Compiler/Scheme/Racket.idr | 20 +- src/Core/AutoSearch.idr | 116 ++++---- src/Core/Binary.idr | 50 ++-- src/Core/CaseBuilder.idr | 244 ++++++++--------- src/Core/CaseTree.idr | 48 ++-- src/Core/CompileExpr.idr | 20 +- src/Core/Context.idr | 6 +- src/Core/Coverage.idr | 50 ++-- src/Core/Env.idr | 70 ++--- src/Core/FC.idr | 8 +- src/Core/GetType.idr | 24 +- src/Core/Hash.idr | 54 ++-- src/Core/InitPrimitives.idr | 4 +- src/Core/LinearCheck.idr | 134 ++++----- src/Core/Metadata.idr | 26 +- src/Core/Name.idr | 6 +- src/Core/Normalise.idr | 230 ++++++++-------- src/Core/Primitives.idr | 30 +- src/Core/Reflect.idr | 14 +- src/Core/TT.idr | 256 +++++++++--------- src/Core/TTC.idr | 114 ++++---- src/Core/Termination.idr | 94 +++---- src/Core/Unify.idr | 210 +++++++------- src/Core/UnifyState.idr | 76 +++--- src/Core/Value.idr | 8 +- src/Data/ANameMap.idr | 6 +- src/Data/IOArray.idr | 6 +- src/Data/IntMap.idr | 14 +- src/Data/NameMap.idr | 14 +- src/Idris/Desugar.idr | 166 ++++++------ src/Idris/Elab/Implementation.idr | 76 +++--- src/Idris/Elab/Interface.idr | 82 +++--- src/Idris/Error.idr | 52 ++-- src/Idris/IDEMode/CaseSplit.idr | 18 +- src/Idris/IDEMode/MakeClause.idr | 12 +- src/Idris/IDEMode/Parser.idr | 16 +- src/Idris/IDEMode/TokenLine.idr | 6 +- src/Idris/REPL.idr | 6 +- src/Idris/REPLCommon.idr | 16 +- src/Idris/REPLOpts.idr | 4 +- src/Idris/Resugar.idr | 32 +-- src/Parser/Lexer.idr | 28 +- src/Parser/Support.idr | 80 +++--- src/TTImp/BindImplicits.idr | 10 +- src/TTImp/Elab.idr | 28 +- src/TTImp/Elab/Ambiguity.idr | 100 +++---- src/TTImp/Elab/App.idr | 74 ++--- src/TTImp/Elab/As.idr | 10 +- src/TTImp/Elab/Binders.idr | 62 ++--- src/TTImp/Elab/Case.idr | 122 ++++----- src/TTImp/Elab/Check.idr | 76 +++--- src/TTImp/Elab/Delayed.idr | 46 ++-- src/TTImp/Elab/Dot.idr | 12 +- src/TTImp/Elab/Hole.idr | 2 +- src/TTImp/Elab/ImplicitBind.idr | 116 ++++---- src/TTImp/Elab/Lazy.idr | 10 +- src/TTImp/Elab/Local.idr | 30 +- src/TTImp/Elab/Record.idr | 42 +-- src/TTImp/Elab/Rewrite.idr | 22 +- src/TTImp/Elab/Term.idr | 24 +- src/TTImp/Elab/Utils.idr | 2 +- src/TTImp/Interactive/CaseSplit.idr | 48 ++-- src/TTImp/Interactive/ExprSearch.idr | 78 +++--- src/TTImp/Interactive/GenerateDef.idr | 36 +-- src/TTImp/Interactive/MakeLemma.idr | 10 +- src/TTImp/Parser.idr | 34 +-- src/TTImp/ProcessData.idr | 34 +-- src/TTImp/ProcessDecls.idr | 8 +- src/TTImp/ProcessDef.idr | 138 +++++----- src/TTImp/ProcessParams.idr | 14 +- src/TTImp/ProcessRecord.idr | 30 +- src/TTImp/ProcessType.idr | 22 +- src/TTImp/TTImp.idr | 130 ++++----- src/TTImp/Unelab.idr | 34 +-- src/TTImp/Utils.idr | 98 +++---- src/Text/Lexer.idr | 2 +- src/Text/Lexer/Core.idr | 4 +- src/Text/Parser/Core.idr | 8 +- src/Utils/Binary.idr | 30 +- src/Utils/Shunting.idr | 28 +- src/Yaffle/REPL.idr | 28 +- tests/chez/chez010/CB.idr | 2 +- tests/idris2/basic002/Do.idr | 2 +- tests/idris2/basic004/Stuff.idr | 2 +- tests/idris2/basic004/Wheres.idr | 2 +- tests/idris2/basic006/PMLet.idr | 2 +- tests/idris2/basic006/Stuff.idr | 2 +- tests/idris2/basic007/Stuff.idr | 2 +- tests/idris2/basic008/If.idr | 2 +- tests/idris2/basic008/Stuff.idr | 2 +- tests/idris2/basic009/Stuff.idr | 2 +- tests/idris2/basic013/Implicits.idr | 2 +- tests/idris2/basic014/Rewrite.idr | 2 +- tests/idris2/basic018/Fin.idr | 4 +- tests/idris2/basic020/Mut.idr | 4 +- tests/idris2/basic021/CaseDep.idr | 2 +- tests/idris2/basic023/Params.idr | 2 +- tests/idris2/basic028/Do.idr | 2 +- tests/idris2/error001/Error.idr | 2 +- tests/idris2/interactive003/IEdit.idr | 2 +- tests/idris2/interactive011/IEdit.idr | 2 +- tests/idris2/interface001/IFace.idr | 6 +- tests/idris2/interface001/IFace1.idr | 6 +- tests/idris2/interface001/Stuff.idr | 2 +- tests/idris2/interface002/Stuff.idr | 2 +- tests/idris2/interface004/Do.idr | 2 +- tests/idris2/interface009/Odd.idr | 2 +- tests/idris2/interface012/Defmeth.idr | 2 +- tests/idris2/linear001/Stuff.idr | 2 +- tests/idris2/linear002/Stuff.idr | 2 +- tests/idris2/linear003/Linear.idr | 2 +- tests/idris2/linear004/Stuff.idr | 2 +- tests/idris2/linear006/ZFun.idr | 4 +- tests/idris2/perf001/Big.idr | 4 +- tests/idris2/record002/Record.idr | 6 +- tests/idris2/reg001/D.idr | 2 +- tests/idris2/total004/Total.idr | 6 +- tests/typedd-book/chapter04/BSTree.idr | 2 +- tests/typedd-book/chapter04/DataStore.idr | 2 +- tests/typedd-book/chapter04/Shape.idr | 2 +- tests/typedd-book/chapter04/SumInputs.idr | 4 +- tests/typedd-book/chapter05/PrintLength.idr | 2 +- tests/typedd-book/chapter07/Expr.idr | 2 +- tests/typedd-book/chapter08/ExactLength.idr | 2 +- tests/typedd-book/chapter10/DataStore.idr | 8 +- tests/typedd-book/chapter10/IsSuffix.idr | 2 +- tests/typedd-book/chapter10/SnocList.idr | 2 +- tests/typedd-book/chapter10/TestStore.idr | 6 +- tests/typedd-book/chapter11/Arith.idr | 2 +- tests/typedd-book/chapter11/ArithCmdDo.idr | 8 +- tests/typedd-book/chapter12/Traverse.idr | 2 +- tests/typedd-book/chapter12/TreeLabel.idr | 6 +- .../typedd-book/chapter12/TreeLabelState.idr | 4 +- tests/typedd-book/chapter12/TreeLabelType.idr | 8 +- 157 files changed, 2328 insertions(+), 2328 deletions(-) diff --git a/libs/base/Control/Monad/Identity.idr b/libs/base/Control/Monad/Identity.idr index f2cdec0..fb0b147 100644 --- a/libs/base/Control/Monad/Identity.idr +++ b/libs/base/Control/Monad/Identity.idr @@ -1,6 +1,6 @@ module Control.Monad.Identity -public export +public export record Identity (a : Type) where constructor Id runIdentity : a diff --git a/libs/base/Control/Monad/State.idr b/libs/base/Control/Monad/State.idr index ffb8fdb..7073fca 100644 --- a/libs/base/Control/Monad/State.idr +++ b/libs/base/Control/Monad/State.idr @@ -27,16 +27,16 @@ public export implementation Monad f => Applicative (StateT stateType f) where pure x = ST (\st => pure (x, st)) - (ST f) <*> (ST a) - = ST (\st => + (ST f) <*> (ST a) + = ST (\st => do (g, r) <- f st (b, t) <- a r pure (g b, t)) public export implementation Monad m => Monad (StateT stateType m) where - (ST f) >>= k - = ST (\st => + (ST f) >>= k + = ST (\st => do (v, st') <- f st let ST kv = k v kv st') @@ -48,8 +48,8 @@ implementation Monad m => MonadState stateType (StateT stateType m) where public export implementation MonadTrans (StateT stateType) where - lift x - = ST (\st => + lift x + = ST (\st => do r <- x pure (r, st)) @@ -61,14 +61,14 @@ implementation (Monad f, Alternative f) => Alternative (StateT st f) where ||| Apply a function to modify the context of this computation public export modify : MonadState stateType m => (stateType -> stateType) -> m () -modify f +modify f = do s <- get put (f s) ||| Evaluate a function in the context held by this computation public export gets : MonadState stateType m => (stateType -> a) -> m a -gets f +gets f = do s <- get pure (f s) diff --git a/libs/base/Control/WellFounded.idr b/libs/base/Control/WellFounded.idr index 654c586..a270b36 100644 --- a/libs/base/Control/WellFounded.idr +++ b/libs/base/Control/WellFounded.idr @@ -66,7 +66,7 @@ sizeInd : Sized a => {0 P : a -> Type} -> sizeInd step z = accInd step z (sizeAccessible z) export -sizeRec : Sized a => +sizeRec : Sized a => (step : (x : a) -> ((y : a) -> Smaller y x -> b) -> b) -> (z : a) -> b sizeRec step z = accRec step z (sizeAccessible z) diff --git a/libs/base/Data/Buffer.idr b/libs/base/Data/Buffer.idr index 242f5ac..57a88f8 100644 --- a/libs/base/Data/Buffer.idr +++ b/libs/base/Data/Buffer.idr @@ -75,7 +75,7 @@ bufferData buf unpackTo (val :: acc) (loc - 1) export -readBufferFromFile : BinaryFile -> Buffer -> (maxbytes : Int) -> +readBufferFromFile : BinaryFile -> Buffer -> (maxbytes : Int) -> IO (Either FileError Buffer) readBufferFromFile (FHandle h) (MkBuffer buf size loc) max = do read <- schemeCall Int "blodwen-readbuffer" [h, buf, loc, max] @@ -84,7 +84,7 @@ readBufferFromFile (FHandle h) (MkBuffer buf size loc) max else pure (Left FileReadError) export -writeBufferToFile : BinaryFile -> Buffer -> (maxbytes : Int) -> +writeBufferToFile : BinaryFile -> Buffer -> (maxbytes : Int) -> IO (Either FileError Buffer) writeBufferToFile (FHandle h) (MkBuffer buf size loc) max = do let maxwrite = size - loc diff --git a/libs/base/Data/Fin.idr b/libs/base/Data/Fin.idr index 85a3d56..f41a7b1 100644 --- a/libs/base/Data/Fin.idr +++ b/libs/base/Data/Fin.idr @@ -103,7 +103,7 @@ last : {n : _} -> Fin (S n) last {n=Z} = FZ last {n=S _} = FS last -export total +export total FSinjective : {f : Fin n} -> {f' : Fin n} -> (FS f = FS f') -> f = f' FSinjective Refl = Refl @@ -119,7 +119,7 @@ implementation Ord (Fin n) where public export natToFin : Nat -> (n : Nat) -> Maybe (Fin n) natToFin Z (S j) = Just FZ -natToFin (S k) (S j) +natToFin (S k) (S j) = case natToFin k j of Just k' => Just (FS k') Nothing => Nothing @@ -157,7 +157,7 @@ restrict n val = let val' = assert_total (abs (mod val (cast (S n)))) in -- DecEq -------------------------------------------------------------------------------- -export total +export total FZNotFS : {f : Fin n} -> FZ {k = n} = FS f -> Void FZNotFS Refl impossible diff --git a/libs/base/Data/IORef.idr b/libs/base/Data/IORef.idr index 930855a..dc6cc42 100644 --- a/libs/base/Data/IORef.idr +++ b/libs/base/Data/IORef.idr @@ -16,7 +16,7 @@ data IORef : Type -> Type where export newIORef : a -> IO (IORef a) -newIORef val +newIORef val = do m <- primIO (prim__newIORef val) pure (MkRef m) diff --git a/libs/base/Data/List.idr b/libs/base/Data/List.idr index 6c63b6d..6ec060d 100644 --- a/libs/base/Data/List.idr +++ b/libs/base/Data/List.idr @@ -299,15 +299,15 @@ appendAssociative (x::xs) c r = revOnto : (xs, vs : _) -> reverseOnto xs vs = reverse vs ++ xs revOnto xs [] = Refl -revOnto xs (v :: vs) - = rewrite revOnto (v :: xs) vs in +revOnto xs (v :: vs) + = rewrite revOnto (v :: xs) vs in rewrite appendAssociative (reverse vs) [v] xs in rewrite revOnto [v] vs in Refl export revAppend : (vs, ns : List a) -> reverse ns ++ reverse vs = reverse (vs ++ ns) revAppend [] ns = rewrite appendNilRightNeutral (reverse ns) in Refl -revAppend (v :: vs) ns +revAppend (v :: vs) ns = rewrite revOnto [v] vs in rewrite revOnto [v] (vs ++ ns) in rewrite sym (revAppend vs ns) in diff --git a/libs/base/Data/List/Views.idr b/libs/base/Data/List/Views.idr index a9239f6..f0672d5 100644 --- a/libs/base/Data/List/Views.idr +++ b/libs/base/Data/List/Views.idr @@ -9,19 +9,19 @@ lengthSuc : (xs : List a) -> (y : a) -> (ys : List a) -> lengthSuc [] _ _ = Refl lengthSuc (x :: xs) y ys = cong S (lengthSuc xs y ys) -lengthLT : (xs : List a) -> (ys : List a) -> +lengthLT : (xs : List a) -> (ys : List a) -> LTE (length xs) (length (ys ++ xs)) lengthLT xs [] = lteRefl lengthLT xs (x :: ys) = lteSuccRight (lengthLT _ _) -smallerLeft : (ys : List a) -> (y : a) -> (zs : List a) -> +smallerLeft : (ys : List a) -> (y : a) -> (zs : List a) -> LTE (S (S (length ys))) (S (length (ys ++ (y :: zs)))) smallerLeft [] y zs = LTESucc (LTESucc LTEZero) smallerLeft (z :: ys) y zs = LTESucc (smallerLeft ys _ _) -smallerRight : (ys : List a) -> (zs : List a) -> +smallerRight : (ys : List a) -> (zs : List a) -> LTE (S (S (length zs))) (S (length (ys ++ (y :: zs)))) -smallerRight {y} ys zs = rewrite lengthSuc ys y zs in +smallerRight {y} ys zs = rewrite lengthSuc ys y zs in (LTESucc (LTESucc (lengthLT _ _))) ||| View for splitting a list in half, non-recursively @@ -29,17 +29,17 @@ public export data Split : List a -> Type where SplitNil : Split [] SplitOne : (x : a) -> Split [x] - SplitPair : (x : a) -> (xs : List a) -> - (y : a) -> (ys : List a) -> + SplitPair : (x : a) -> (xs : List a) -> + (y : a) -> (ys : List a) -> Split (x :: xs ++ y :: ys) splitHelp : (head : a) -> - (xs : List a) -> + (xs : List a) -> (counter : List a) -> Split (head :: xs) splitHelp head [] counter = SplitOne _ splitHelp head (x :: xs) [] = SplitPair head [] x xs splitHelp head (x :: xs) [y] = SplitPair head [] x xs -splitHelp head (x :: xs) (_ :: _ :: ys) +splitHelp head (x :: xs) (_ :: _ :: ys) = case splitHelp head xs ys of SplitOne x => SplitPair x [] _ [] SplitPair x' xs y' ys => SplitPair x' (x :: xs) y' ys @@ -79,11 +79,11 @@ data SnocList : List a -> Type where Snoc : (x : a) -> (xs : List a) -> (rec : SnocList xs) -> SnocList (xs ++ [x]) -snocListHelp : {input : _} -> +snocListHelp : {input : _} -> SnocList input -> (rest : List a) -> SnocList (input ++ rest) snocListHelp snoc [] = rewrite appendNilRightNeutral input in snoc -snocListHelp snoc (x :: xs) - = rewrite appendAssociative input [x] xs in +snocListHelp snoc (x :: xs) + = rewrite appendAssociative input [x] xs in snocListHelp (Snoc x input snoc) xs ||| Covering function for the `SnocList` view diff --git a/libs/base/Data/Nat.idr b/libs/base/Data/Nat.idr index 5d220e0..4b29465 100644 --- a/libs/base/Data/Nat.idr +++ b/libs/base/Data/Nat.idr @@ -89,7 +89,7 @@ export isLTE : (m, n : Nat) -> Dec (LTE m n) isLTE Z n = Yes LTEZero isLTE (S k) Z = No succNotLTEzero -isLTE (S k) (S j) +isLTE (S k) (S j) = case isLTE k j of No contra => No (contra . fromLteSucc) Yes prf => Yes (LTESucc prf) @@ -245,7 +245,7 @@ cmp (S x) (S y) with (cmp x y) cmp (S x) (S x) | CmpEQ = CmpEQ cmp (S (y + (S k))) (S y) | CmpGT k = CmpGT k --- Proofs on + +-- Proofs on export plusZeroLeftNeutral : (right : Nat) -> 0 + right = right diff --git a/libs/base/Data/So.idr b/libs/base/Data/So.idr index a9e9f2f..e413a2e 100644 --- a/libs/base/Data/So.idr +++ b/libs/base/Data/So.idr @@ -10,7 +10,7 @@ module Data.So ||| it may be appropriate to define a type of evidence for the property that you ||| care about instead. public export -data So : Bool -> Type where +data So : Bool -> Type where Oh : So True export diff --git a/libs/base/Data/Vect.idr b/libs/base/Data/Vect.idr index 87341a3..b0b38af 100644 --- a/libs/base/Data/Vect.idr +++ b/libs/base/Data/Vect.idr @@ -23,7 +23,7 @@ length [] = 0 length (x::xs) = 1 + length xs ||| Show that the length function on vectors in fact calculates the length -private +private lengthCorrect : (len : Nat) -> (xs : Vect len elem) -> length xs = len lengthCorrect Z [] = Refl lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl @@ -295,7 +295,7 @@ public export unzip3 : (xs : Vect n (a, b, c)) -> (Vect n a, Vect n b, Vect n c) unzip3 [] = ([], [], []) unzip3 ((l,c,r)::xs) with (unzip3 xs) - unzip3 ((l,c,r)::xs) | (lefts, centers, rights) + unzip3 ((l,c,r)::xs) | (lefts, centers, rights) = (l::lefts, c::centers, r::rights) -------------------------------------------------------------------------------- @@ -315,7 +315,7 @@ implementation (Eq elem) => Eq (Vect len elem) where public export implementation Ord elem => Ord (Vect len elem) where compare [] [] = EQ - compare (x::xs) (y::ys) + compare (x::xs) (y::ys) = case compare x y of EQ => compare xs ys x => x @@ -528,7 +528,7 @@ findIndex p (x :: xs) = if p x then Just FZ else map FS (findIndex p xs) public export findIndices : (elem -> Bool) -> Vect m elem -> List (Fin m) findIndices p [] = [] -findIndices p (x :: xs) +findIndices p (x :: xs) = let is = map FS $ findIndices p xs in if p x then FZ :: is else is @@ -787,7 +787,7 @@ transpose (x :: xs) = zipWith (::) x (transpose xs) -- = [| x :: xs |] -------------------------------------------------------------------------------- -- Applicative/Monad/Traversable -------------------------------------------------------------------------------- --- These only work if the length is known at run time! +-- These only work if the length is known at run time! implementation {k : Nat} -> Applicative (Vect k) where pure = replicate _ @@ -849,7 +849,7 @@ replaceByElem (x::xs) Here y = y :: xs replaceByElem (x::xs) (There xinxs) y = x :: replaceByElem xs xinxs y public export -mapElem : {0 xs : Vect k t} -> {0 f : t -> u} -> +mapElem : {0 xs : Vect k t} -> {0 f : t -> u} -> Elem x xs -> Elem (f x) (map f xs) mapElem Here = Here mapElem (There e) = There (mapElem e) diff --git a/libs/base/Decidable/Equality.idr b/libs/base/Decidable/Equality.idr index 2374b41..48f15c1 100644 --- a/libs/base/Decidable/Equality.idr +++ b/libs/base/Decidable/Equality.idr @@ -18,12 +18,12 @@ interface DecEq t where -------------------------------------------------------------------------------- ||| The negation of equality is symmetric (follows from symmetry of equality) -export total +export total negEqSym : forall a, b . (a = b -> Void) -> (b = a -> Void) negEqSym p h = p (sym h) ||| Everything is decidably equal to itself -export total +export total decEqSelfIsYes : DecEq a => {x : a} -> decEq x x = Yes Refl decEqSelfIsYes {x} with (decEq x x) decEqSelfIsYes {x} | Yes Refl = Refl @@ -78,7 +78,7 @@ implementation (DecEq t) => DecEq (Maybe t) where decEq Nothing Nothing = Yes Refl decEq (Just x') (Just y') with (decEq x' y') decEq (Just x') (Just y') | Yes p = Yes $ cong Just p - decEq (Just x') (Just y') | No p + decEq (Just x') (Just y') | No p = No $ \h : Just x' = Just y' => p $ justInjective h decEq Nothing (Just _) = No nothingNotJust decEq (Just _) Nothing = No (negEqSym nothingNotJust) @@ -86,7 +86,7 @@ implementation (DecEq t) => DecEq (Maybe t) where -- TODO: Other prelude data types -- For the primitives, we have to cheat because we don't have access to their --- internal implementations. We use believe_me for the inequality proofs +-- internal implementations. We use believe_me for the inequality proofs -- because we don't them to reduce (and they should never be needed anyway...) -- A postulate would be better, but erasure analysis may think they're needed -- for computation in a higher order setting. @@ -97,7 +97,7 @@ implementation (DecEq t) => DecEq (Maybe t) where export implementation DecEq Int where decEq x y = case x == y of -- Blocks if x or y not concrete - True => Yes primitiveEq + True => Yes primitiveEq False => No primitiveNotEq where primitiveEq : forall x, y . x = y primitiveEq = believe_me (Refl {x}) @@ -110,7 +110,7 @@ implementation DecEq Int where export implementation DecEq Char where decEq x y = case x == y of -- Blocks if x or y not concrete - True => Yes primitiveEq + True => Yes primitiveEq False => No primitiveNotEq where primitiveEq : forall x, y . x = y primitiveEq = believe_me (Refl {x}) @@ -123,7 +123,7 @@ implementation DecEq Char where export implementation DecEq Integer where decEq x y = case x == y of -- Blocks if x or y not concrete - True => Yes primitiveEq + True => Yes primitiveEq False => No primitiveNotEq where primitiveEq : forall x, y . x = y primitiveEq = believe_me (Refl {x}) @@ -136,7 +136,7 @@ implementation DecEq Integer where export implementation DecEq String where decEq x y = case x == y of -- Blocks if x or y not concrete - True => Yes primitiveEq + True => Yes primitiveEq False => No primitiveNotEq where primitiveEq : forall x, y . x = y primitiveEq = believe_me (Refl {x}) diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr index 37721a4..0b71e53 100644 --- a/libs/base/Language/Reflection.idr +++ b/libs/base/Language/Reflection.idr @@ -21,7 +21,7 @@ data NameType : Type where TyCon : (tag : Int) -> (arity : Nat) -> NameType public export -data Constant +data Constant = I Int | BI Integer | Str String @@ -58,14 +58,14 @@ data LazyReason = LInf | LLazy | LUnknown -- Type checked terms in the core TT public export data TT : List Name -> Type where - Local : FC -> (idx : Nat) -> (n : Name) -> + Local : FC -> (idx : Nat) -> (n : Name) -> (0 prf : IsVar name idx vars) -> TT vars Ref : FC -> NameType -> Name -> TT vars - Pi : FC -> Count -> PiInfo -> - (x : Name) -> (argTy : TT vars) -> (retTy : TT (x :: vars)) -> + Pi : FC -> Count -> PiInfo -> + (x : Name) -> (argTy : TT vars) -> (retTy : TT (x :: vars)) -> TT vars - Lam : FC -> Count -> PiInfo -> - (x : Name) -> (argTy : TT vars) -> (scope : TT (x :: vars)) -> + Lam : FC -> Count -> PiInfo -> + (x : Name) -> (argTy : TT vars) -> (scope : TT (x :: vars)) -> TT vars App : FC -> TT vars -> TT vars -> TT vars TDelayed : FC -> LazyReason -> TT vars -> TT vars diff --git a/libs/base/System/File.idr b/libs/base/System/File.idr index 8ece133..bebd5c8 100644 --- a/libs/base/System/File.idr +++ b/libs/base/System/File.idr @@ -82,13 +82,13 @@ stderr = FHandle prim__stderr export openFile : String -> Mode -> IO (Either FileError File) -openFile f m +openFile f m = do res <- primIO (prim__open f (modeStr m) 0) fpure (map FHandle res) export openBinaryFile : String -> Mode -> IO (Either FileError BinaryFile) -openBinaryFile f m +openBinaryFile f m = do res <- primIO (prim__open f (modeStr m) 1) fpure (map FHandle res) @@ -98,7 +98,7 @@ closeFile (FHandle f) = primIO (prim__close f) export fGetLine : (h : File) -> IO (Either FileError String) -fGetLine (FHandle f) +fGetLine (FHandle f) = do res <- primIO (prim__readLine f) fpure res @@ -110,14 +110,14 @@ fPutStr (FHandle f) str export fPutStrLn : (h : File) -> String -> IO (Either FileError ()) -fPutStrLn f str = fPutStr f (str ++ "\n") +fPutStrLn f str = fPutStr f (str ++ "\n") export fEOF : (h : File) -> IO Bool fEOF (FHandle f) = do res <- primIO (prim__eof f) pure (res /= 0) - + export readFile : String -> IO (Either FileError String) readFile file diff --git a/libs/base/System/REPL.idr b/libs/base/System/REPL.idr index fa23b80..844bf43 100644 --- a/libs/base/System/REPL.idr +++ b/libs/base/System/REPL.idr @@ -17,7 +17,7 @@ replWith acc prompt fn then pure () else do x <- getLine case fn acc x of - Just (out, acc') => + Just (out, acc') => do putStr out replWith acc' prompt fn Nothing => pure () diff --git a/libs/prelude/Builtin.idr b/libs/prelude/Builtin.idr index a0d7f1f..e55969c 100644 --- a/libs/prelude/Builtin.idr +++ b/libs/prelude/Builtin.idr @@ -69,7 +69,7 @@ public export %inline public export -rewrite__impl : {0 x, y : a} -> (0 p : _) -> +rewrite__impl : {0 x, y : a} -> (0 p : _) -> (0 rule : x = y) -> (1 val : p y) -> p x rewrite__impl p Refl prf = prf diff --git a/libs/prelude/Prelude.idr b/libs/prelude/Prelude.idr index 09b18b7..3b7d45b 100644 --- a/libs/prelude/Prelude.idr +++ b/libs/prelude/Prelude.idr @@ -4,7 +4,7 @@ import public Builtin import public PrimIO {- -The Prelude is minimal (since it is effectively part of the language +The Prelude is minimal (since it is effectively part of the language specification, this seems to be desirable - we should, nevertheless, aim to provide a good selection of base libraries). A rule of thumb is that it should contain the basic functions required by almost any non-trivial program. @@ -219,7 +219,7 @@ interface Eq ty => Ord ty where (<) : ty -> ty -> Bool (<) x y = compare x y == LT - + (>) : ty -> ty -> Bool (>) x y = compare x y == GT @@ -352,10 +352,10 @@ Abs Integer where public export Integral Integer where - div x y + div x y = case y == 0 of False => prim__div_Integer x y - mod x y + mod x y = case y == 0 of False => prim__mod_Integer x y @@ -386,10 +386,10 @@ Abs Int where public export Integral Int where - div x y + div x y = case y == 0 of False => prim__div_Int x y - mod x y + mod x y = case y == 0 of False => prim__mod_Int x y @@ -571,9 +571,9 @@ data Nat = Z | S Nat public export integerToNat : Integer -> Nat -integerToNat x +integerToNat x = if intToBool (prim__lte_Integer x 0) - then Z + then Z else S (assert_total (integerToNat (prim__sub_Integer x 1))) -- Define separately so we can spot the name when optimising Nats @@ -756,7 +756,7 @@ Ord a => Ord (List a) where compare [] [] = EQ compare [] (x :: xs) = LT compare (x :: xs) [] = GT - compare (x :: xs) (y ::ys) + compare (x :: xs) (y ::ys) = case compare x y of EQ => compare xs ys c => c @@ -876,7 +876,7 @@ pack (x :: xs) = strCons x (pack xs) export fastPack : List Char -> String -fastPack xs +fastPack xs = unsafePerformIO (schemeCall String "string" (toFArgs xs)) where toFArgs : List Char -> FArgList @@ -927,7 +927,7 @@ isAlphaNum x = isDigit x || isAlpha x public export isSpace : Char -> Bool -isSpace x +isSpace x = x == ' ' || x == '\t' || x == '\r' || x == '\n' || x == '\f' || x == '\v' || x == '\xa0' @@ -938,14 +938,14 @@ isNL x = x == '\r' || x == '\n' public export toUpper : Char -> Char -toUpper x +toUpper x = if (isLower x) then prim__cast_IntChar (prim__cast_CharInt x - 32) else x public export toLower : Char -> Char -toLower x +toLower x = if (isUpper x) then prim__cast_IntChar (prim__cast_CharInt x + 32) else x @@ -964,7 +964,7 @@ isOctDigit x = (x >= '0' && x <= '7') public export isControl : Char -> Bool -isControl x +isControl x = (x >= '\x0000' && x <= '\x001f') || (x >= '\x007f' && x <= '\x009f') @@ -1048,7 +1048,7 @@ showLitChar '\v' = ("\\v" ++) showLitChar '\SO' = protectEsc (== 'H') "\\SO" showLitChar '\DEL' = ("\\DEL" ++) showLitChar '\\' = ("\\\\" ++) -showLitChar c +showLitChar c = case getAt (fromInteger (prim__cast_CharInteger c)) asciiTab of Just k => strCons '\\' . (k ++) Nothing => if (c > '\DEL') @@ -1104,7 +1104,7 @@ export export Show a => Show (List a) where - show xs = "[" ++ show' "" xs ++ "]" + show xs = "[" ++ show' "" xs ++ "]" where show' : String -> List a -> String show' acc [] = acc @@ -1127,7 +1127,7 @@ Functor IO where public export Applicative IO where pure x = io_pure x - f <*> a + f <*> a = io_bind f (\f' => io_bind a (\a' => io_pure (f' a'))) @@ -1166,7 +1166,7 @@ log x = prim__doubleLog x public export pow : Double -> Double -> Double -pow x y = exp (y * log x) +pow x y = exp (y * log x) public export sin : Double -> Double @@ -1335,7 +1335,7 @@ takeBefore p (x :: xs) then [] else x :: takeBefore p xs -public export +public export interface Range a where rangeFromTo : a -> a -> List a rangeFromThenTo : a -> a -> a -> List a @@ -1347,35 +1347,35 @@ interface Range a where -- think it's worth going to those lengths! Let's keep it simple and assert. export Range Nat where - rangeFromTo x y + rangeFromTo x y = if y > x then assert_total $ takeUntil (>= y) (countFrom x S) else if x > y then assert_total $ takeUntil (<= y) (countFrom x (\n => minus n 1)) else [x] - rangeFromThenTo x y z + rangeFromThenTo x y z = if y > x then (if z > x then assert_total $ takeBefore (> z) (countFrom x (plus (minus y x))) else []) - else (if x == y + else (if x == y then (if x == z then [x] else []) else assert_total $ takeBefore (< z) (countFrom x (\n => minus n (minus x y)))) rangeFrom x = countFrom x S - rangeFromThen x y - = if y > x + rangeFromThen x y + = if y > x then countFrom x (plus (minus y x)) else countFrom x (\n => minus n (minus x y)) - + export (Integral a, Ord a, Neg a) => Range a where - rangeFromTo x y + rangeFromTo x y = if y > x then assert_total $ takeUntil (>= y) (countFrom x (+1)) else if x > y then assert_total $ takeUntil (<= y) (countFrom x (\x => x-1)) else [x] - rangeFromThenTo x y z + rangeFromThenTo x y z = if (z - x) > (z - y) then -- go up assert_total $ takeBefore (> z) (countFrom x (+ (y-x))) @@ -1386,8 +1386,8 @@ export if x == y && y == z then [x] else [] rangeFrom x = countFrom x (1+) - rangeFromThen x y - = if y > x + rangeFromThen x y + = if y > x then countFrom x (+ (y - x)) else countFrom x (\n => n - (x - y)) diff --git a/libs/prelude/PrimIO.idr b/libs/prelude/PrimIO.idr index 57db609..f539f36 100644 --- a/libs/prelude/PrimIO.idr +++ b/libs/prelude/PrimIO.idr @@ -17,7 +17,7 @@ io_pure x = MkIO (\w => MkIORes x w) export io_bind : (1 act : IO a) -> (1 k : a -> IO b) -> IO b io_bind (MkIO fn) - = \k => MkIO (\w => let MkIORes x' w' = fn w + = \k => MkIO (\w => let MkIORes x' w' = fn w MkIO res = k x' in res w') @@ -46,9 +46,9 @@ data FArgList : Type where Nil : FArgList (::) : {a : Type} -> (1 arg : a) -> (1 args : FArgList) -> FArgList -%extern prim__cCall : (ret : Type) -> String -> (1 args : FArgList) -> +%extern prim__cCall : (ret : Type) -> String -> (1 args : FArgList) -> (1 x : %World) -> IORes ret -%extern prim__schemeCall : (ret : Type) -> String -> (1 args : FArgList) -> +%extern prim__schemeCall : (ret : Type) -> String -> (1 args : FArgList) -> (1 x : %World) -> IORes ret export %inline @@ -62,11 +62,11 @@ toPrim (MkIO fn) = fn export %inline schemeCall : (ret : Type) -> String -> (1 args : FArgList) -> IO ret schemeCall ret fn args = primIO (prim__schemeCall ret fn args) - + export %inline cCall : (ret : Type) -> String -> FArgList -> IO ret cCall ret fn args = primIO (prim__cCall ret fn args) - + export putStr : String -> IO () putStr str = primIO (prim__putStr str) diff --git a/src/Compiler/Common.idr b/src/Compiler/Common.idr index 69fd9fd..8f349b9 100644 --- a/src/Compiler/Common.idr +++ b/src/Compiler/Common.idr @@ -50,7 +50,7 @@ getAllDesc (n :: rest) ns defs Nothing => case !(lookupCtxtExact n (gamma defs)) of Nothing => getAllDesc rest ns defs - Just def => + Just def => let refs = refersTo def in getAllDesc (rest ++ keys refs) (insert n () ns) defs @@ -76,7 +76,7 @@ natHackNames -- Find all the names which need compiling, from a given expression, and compile -- them to CExp form (and update that in the Defs) export -findUsedNames : {auto c : Ref Ctxt Defs} -> Term vars -> +findUsedNames : {auto c : Ref Ctxt Defs} -> Term vars -> Core (List Name, NameTags) findUsedNames tm = do defs <- get Ctxt @@ -89,7 +89,7 @@ findUsedNames tm -- Use '1' for '->' constructor let tyconInit = insert (UN "->") 1 $ insert (UN "Type") 2 $ - primTags 3 empty + primTags 3 empty [IntType, IntegerType, StringType, CharType, DoubleType, WorldType] tycontags <- mkNameTags defs tyconInit 100 cns @@ -136,8 +136,8 @@ parseCC "" = Nothing parseCC str = case span (/= ':') str of (target, "") => Just (trim target, []) - (target, opts) => Just (trim target, - map trim (getOpts + (target, opts) => Just (trim target, + map trim (getOpts (assert_total (strTail opts)))) where getOpts : String -> List String diff --git a/src/Compiler/Inline.idr b/src/Compiler/Inline.idr index 0a87dc2..baa957e 100644 --- a/src/Compiler/Inline.idr +++ b/src/Compiler/Inline.idr @@ -30,19 +30,19 @@ checkLengthMatch : (xs : List a) -> (ys : List b) -> Maybe (LengthMatch xs ys) checkLengthMatch [] [] = Just NilMatch checkLengthMatch [] (x :: xs) = Nothing checkLengthMatch (x :: xs) [] = Nothing -checkLengthMatch (x :: xs) (y :: ys) +checkLengthMatch (x :: xs) (y :: ys) = Just (ConsMatch !(checkLengthMatch xs ys)) extend : EEnv free vars -> (args : List (CExp free)) -> (args' : List Name) -> LengthMatch args args' -> EEnv free (args' ++ vars) extend env [] [] NilMatch = env -extend env (a :: xs) (n :: ns) (ConsMatch w) +extend env (a :: xs) (n :: ns) (ConsMatch w) = a :: extend env xs ns w -extendLoc : FC -> EEnv free vars -> (args' : List Name) -> +extendLoc : FC -> EEnv free vars -> (args' : List Name) -> EEnv (args' ++ free) (args' ++ vars) extendLoc fc env [] = env -extendLoc fc env (n :: ns) +extendLoc fc env (n :: ns) = CLocal fc First :: weakenEnv (extendLoc fc env ns) Stack : List Name -> Type @@ -61,9 +61,9 @@ getArity (MkCon _ arity) = arity getArity (MkForeign _ args _) = length args getArity (MkError _) = 0 -takeFromStack : EEnv free vars -> Stack free -> (args : List Name) -> +takeFromStack : EEnv free vars -> Stack free -> (args : List Name) -> Maybe (EEnv free (args ++ vars), Stack free) -takeFromStack env (e :: es) (a :: as) +takeFromStack env (e :: es) (a :: as) = do (env', stk') <- takeFromStack env es as pure (e :: env', stk') takeFromStack env stk [] = pure (env, stk) @@ -71,97 +71,97 @@ takeFromStack env [] args = Nothing thinAll : (ns : List Name) -> CExp (outer ++ inner) -> CExp (outer ++ ns ++ inner) thinAll [] exp = exp -thinAll {outer} {inner} (n :: ns) exp +thinAll {outer} {inner} (n :: ns) exp = thin {outer} {inner = ns ++ inner} n (thinAll ns exp) mutual evalLocal : {auto c : Ref Ctxt Defs} -> FC -> List Name -> Stack free -> - EEnv free vars -> + EEnv free vars -> {idx : Nat} -> .(IsVar x idx (vars ++ free)) -> 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 = eval rec env stk (weakenNs xs v) - evalLocal {vars = x :: xs} fc rec stk (_ :: env) (Later p) + evalLocal {vars = x :: xs} fc rec stk (_ :: env) (Later p) = evalLocal fc rec stk env p tryApply : {auto c : Ref Ctxt Defs} -> - List Name -> Stack free -> EEnv free vars -> CDef -> + List Name -> Stack free -> EEnv free vars -> CDef -> Core (Maybe (CExp free)) tryApply {free} {vars} rec stk env (MkFun args exp) = do let Just (env', stk') = takeFromStack env stk args | Nothing => pure Nothing - res <- eval rec env' stk' - (rewrite sym (appendAssociative args vars free) in + res <- eval rec env' stk' + (rewrite sym (appendAssociative args vars free) in embed {vars = vars ++ free} exp) pure (Just res) tryApply rec stk env _ = pure Nothing eval : {auto c : Ref Ctxt Defs} -> - List Name -> EEnv free vars -> Stack free -> CExp (vars ++ free) -> + List Name -> EEnv free vars -> Stack free -> CExp (vars ++ free) -> Core (CExp free) eval rec env stk (CLocal fc p) = evalLocal fc rec stk env p - eval rec env stk (CRef fc n) + eval rec env stk (CRef fc n) = do defs <- get Ctxt Just gdef <- lookupCtxtExact n (gamma defs) | Nothing => pure (unload stk (CRef fc n)) let Just def = compexpr gdef | Nothing => pure (unload stk (CRef fc n)) - let arity = getArity def + let arity = getArity def if (Inline `elem` flags gdef) && (not (n `elem` rec)) then do ap <- tryApply (n :: rec) stk env def pure $ maybe (unloadApp arity stk (CRef fc n)) id ap else pure $ unloadApp arity stk (CRef fc n) - eval {vars} {free} rec env [] (CLam fc x sc) - = do let thinsc = thin x {outer = x :: vars} {inner = free} sc + eval {vars} {free} rec env [] (CLam fc x sc) + = do let thinsc = thin x {outer = x :: vars} {inner = free} sc sc' <- eval rec (CLocal fc First :: weakenEnv env) [] thinsc pure $ CLam fc x sc' eval rec env (e :: stk) (CLam fc x sc) = eval rec (e :: env) stk sc - eval {vars} {free} rec env stk (CLet fc x val sc) - = do let thinsc = thin x {outer = x :: vars} {inner = free} sc + eval {vars} {free} rec env stk (CLet fc x val sc) + = do let thinsc = thin x {outer = x :: vars} {inner = free} sc sc' <- eval rec (CLocal fc First :: weakenEnv env) [] thinsc pure $ CLet fc x !(eval rec env [] val) sc' - eval rec env stk (CApp fc f args) + eval rec env stk (CApp fc f args) = eval rec env (!(traverse (eval rec env []) args) ++ stk) f - eval rec env stk (CCon fc n t args) + eval rec env stk (CCon fc n t args) = pure $ unload stk $ CCon fc n t !(traverse (eval rec env []) args) - eval rec env stk (COp fc p args) + eval rec env stk (COp fc p args) = pure $ unload stk $ COp fc p !(mapV (eval rec env []) args) where mapV : (a -> Core b) -> Vect n a -> Core (Vect n b) mapV f [] = pure [] mapV f (x :: xs) = pure $ !(f x) :: !(mapV f xs) - eval rec env stk (CExtPrim fc p args) + eval rec env stk (CExtPrim fc p args) = pure $ unload stk $ CExtPrim fc p !(traverse (eval rec env []) args) eval rec env stk (CForce fc e) = case !(eval rec env [] e) of CDelay _ e' => eval rec [] stk e' res => pure $ unload stk (CForce fc res) - eval rec env stk (CDelay fc e) + eval rec env stk (CDelay fc e) = pure $ unload stk (CDelay fc !(eval rec env [] e)) - eval rec env stk (CConCase fc sc alts def) + eval rec env stk (CConCase fc sc alts def) = do sc' <- eval rec env [] sc case !(pickAlt rec env stk sc' alts def) of - Nothing => + Nothing => do def' <- case def of Nothing => pure Nothing Just d => pure (Just !(eval rec env stk d)) pure $ - CConCase fc sc' + CConCase fc sc' !(traverse (evalAlt fc rec env stk) alts) def' Just val => pure val - eval rec env stk (CConstCase fc sc alts def) + eval rec env stk (CConstCase fc sc alts def) = do sc' <- eval rec env [] sc case !(pickConstAlt rec env stk sc' alts def) of - Nothing => + Nothing => do def' <- case def of Nothing => pure Nothing Just d => pure (Just !(eval rec env stk d)) pure $ - CConstCase fc sc' + CConstCase fc sc' !(traverse (evalConstAlt rec env stk) alts) def' Just val => pure val @@ -172,8 +172,8 @@ mutual evalAlt : {auto c : Ref Ctxt Defs} -> FC -> List Name -> EEnv free vars -> Stack free -> CConAlt (vars ++ free) -> Core (CConAlt free) - evalAlt {free} {vars} fc rec env stk (MkConAlt n t args sc) - = do let sc' = thinAll {outer=args ++ vars} {inner=free} args + evalAlt {free} {vars} fc rec env stk (MkConAlt n t args sc) + = do let sc' = thinAll {outer=args ++ vars} {inner=free} args (rewrite sym (appendAssociative args vars free) in sc) scEval <- eval rec (extendLoc fc env args) (map (weakenNs args) stk) sc' pure $ MkConAlt n t args scEval @@ -186,37 +186,37 @@ mutual pickAlt : {auto c : Ref Ctxt Defs} -> List Name -> EEnv free vars -> Stack free -> - CExp free -> List (CConAlt (vars ++ free)) -> - Maybe (CExp (vars ++ free)) -> + CExp free -> List (CConAlt (vars ++ free)) -> + Maybe (CExp (vars ++ free)) -> Core (Maybe (CExp free)) - pickAlt rec env stk (CCon fc n t args) [] def + pickAlt rec env stk (CCon fc n t args) [] def = case def of Nothing => pure Nothing Just d => pure $ Just !(eval rec env stk d) - pickAlt {vars} {free} rec env stk (CCon fc n t args) (MkConAlt n' t' args' sc :: alts) def - = if t == t' + pickAlt {vars} {free} rec env stk (CCon fc n t args) (MkConAlt n' t' args' sc :: alts) def + = if t == t' then case checkLengthMatch args args' of Nothing => pure Nothing Just m => - do let env' : EEnv free (args' ++ vars) + do let env' : EEnv free (args' ++ vars) = extend env args args' m - pure $ Just !(eval rec env' stk - (rewrite sym (appendAssociative args' vars free) in + pure $ Just !(eval rec env' stk + (rewrite sym (appendAssociative args' vars free) in sc)) else pickAlt rec env stk (CCon fc n t args) alts def pickAlt rec env stk _ _ _ = pure Nothing pickConstAlt : {auto c : Ref Ctxt Defs} -> List Name -> EEnv free vars -> Stack free -> - CExp free -> List (CConstAlt (vars ++ free)) -> - Maybe (CExp (vars ++ free)) -> + CExp free -> List (CConstAlt (vars ++ free)) -> + Maybe (CExp (vars ++ free)) -> Core (Maybe (CExp free)) - pickConstAlt rec env stk (CPrimVal fc c) [] def + pickConstAlt rec env stk (CPrimVal fc c) [] def = case def of Nothing => pure Nothing Just d => pure $ Just !(eval rec env stk d) - pickConstAlt {vars} {free} rec env stk (CPrimVal fc c) (MkConstAlt c' sc :: alts) def - = if c == c' + pickConstAlt {vars} {free} rec env stk (CPrimVal fc c) (MkConstAlt c' sc :: alts) def + = if c == c' then pure $ Just !(eval rec env stk sc) else pickConstAlt rec env stk (CPrimVal fc c) alts def pickConstAlt rec env stk _ _ _ = pure Nothing @@ -241,4 +241,4 @@ inlineDef n inlined <- inline cexpr -- coreLift $ putStrLn $ show (fullname def) ++ " after: " ++ show inlined setCompiled n inlined - + diff --git a/src/Compiler/Scheme/Chez.idr b/src/Compiler/Scheme/Chez.idr index 1d9778a..c60abbe 100644 --- a/src/Compiler/Scheme/Chez.idr +++ b/src/Compiler/Scheme/Chez.idr @@ -222,7 +222,7 @@ cCall fc cfn clib args ret argTypes <- traverse (cftySpec fc) (filter notWorld args) retType <- cftySpec fc retty pure $ - "(let ([c-code (foreign-callable #f " ++ + "(let ([c-code (foreign-callable #f " ++ mkFun args retty n ++ " (" ++ showSep " " argTypes ++ ") " ++ retType ++ ")])" ++ " (lock-object c-code) (foreign-callable-entry-point c-code))" diff --git a/src/Compiler/Scheme/Chicken.idr b/src/Compiler/Scheme/Chicken.idr index 8300379..3c2ca85 100644 --- a/src/Compiler/Scheme/Chicken.idr +++ b/src/Compiler/Scheme/Chicken.idr @@ -59,7 +59,7 @@ mutual chickenPrim : Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String chickenPrim i vs CCall [ret, fn, args, world] = throw (InternalError ("Can't compile C FFI calls to Chicken Scheme yet")) - chickenPrim i vs prim args + chickenPrim i vs prim args = schExtCommon chickenPrim chickenString i vs prim args compileToSCM : Ref Ctxt Defs -> diff --git a/src/Compiler/Scheme/Common.idr b/src/Compiler/Scheme/Common.idr index 05c88ac..b73adc3 100644 --- a/src/Compiler/Scheme/Common.idr +++ b/src/Compiler/Scheme/Common.idr @@ -49,7 +49,7 @@ data SVars : List Name -> Type where extendSVars : (xs : List Name) -> SVars ns -> SVars (xs ++ ns) extendSVars {ns} xs vs = extSVars' (cast (length ns)) xs vs - where + where extSVars' : Int -> (xs : List Name) -> SVars ns -> SVars (xs ++ ns) extSVars' i [] vs = vs extSVars' i (x :: xs) vs = schName (MN "v" i) :: extSVars' (i + 1) xs vs @@ -74,7 +74,7 @@ op o args = "(" ++ o ++ " " ++ showSep " " args ++ ")" boolop : String -> List String -> String boolop o args = "(or (and " ++ op o args ++ " 1) 0)" -||| Generate scheme for a primitive function. +||| Generate scheme for a primitive function. schOp : PrimFn arity -> Vect arity String -> String schOp (Add IntType) [x, y] = op "b+" [x, y, "63"] schOp (Sub IntType) [x, y] = op "b-" [x, y, "63"] @@ -152,7 +152,7 @@ schOp BelieveMe [_,_,x] = x ||| Extended primitives for the scheme backend, outside the standard set of primFn public export -data ExtPrim = CCall | SchemeCall | PutStr | GetStr +data ExtPrim = CCall | SchemeCall | PutStr | GetStr | FileOpen | FileClose | FileReadLine | FileWriteLine | FileEOF | NewIORef | ReadIORef | WriteIORef | Stdin | Stdout | Stderr @@ -180,7 +180,7 @@ Show ExtPrim where ||| Match on a user given name to get the scheme primitive toPrim : Name -> ExtPrim -toPrim pn@(NS _ n) +toPrim pn@(NS _ n) = cond [(n == UN "prim__schemeCall", SchemeCall), (n == UN "prim__cCall", CCall), (n == UN "prim__putStr", PutStr), @@ -222,7 +222,7 @@ schConstant _ WorldType = "#t" schCaseDef : Maybe String -> String schCaseDef Nothing = "" schCaseDef (Just tm) = "(else " ++ tm ++ ")" - + export schArglist : SVars ns -> String schArglist [] = "" @@ -240,14 +240,14 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx where bindArgs : Int -> (ns : List Name) -> SVars (ns ++ vars) -> String -> String bindArgs i [] vs body = body - bindArgs i (n :: ns) (v :: vs) body + bindArgs i (n :: ns) (v :: vs) body = "(let ((" ++ v ++ " " ++ "(vector-ref " ++ target ++ " " ++ show i ++ "))) " ++ bindArgs (i + 1) ns vs body ++ ")" schConstAlt : Int -> SVars vars -> String -> CConstAlt vars -> Core String schConstAlt i vs target (MkConstAlt c exp) = pure $ "((equal? " ++ target ++ " " ++ schConstant schString c ++ ") " ++ !(schExp i vs exp) ++ ")" - + -- oops, no traverse for Vect in Core schArgs : Int -> SVars vars -> Vect n (CExp vars) -> Core (Vect n String) schArgs i vs [] = pure [] @@ -257,35 +257,35 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx schExp : Int -> SVars vars -> CExp vars -> Core String schExp i vs (CLocal fc el) = pure $ lookupSVar el vs schExp i vs (CRef fc n) = pure $ schName n - schExp i vs (CLam fc x sc) - = do let vs' = extendSVars [x] vs + schExp i vs (CLam fc x sc) + = do let vs' = extendSVars [x] vs sc' <- schExp i vs' sc pure $ "(lambda (" ++ lookupSVar First vs' ++ ") " ++ sc' ++ ")" - schExp i vs (CLet fc x val sc) + schExp i vs (CLet fc x val sc) = do let vs' = extendSVars [x] vs val' <- schExp i vs val sc' <- schExp i vs' sc pure $ "(let ((" ++ lookupSVar First vs' ++ " " ++ val' ++ ")) " ++ sc' ++ ")" - schExp i vs (CApp fc x []) + schExp i vs (CApp fc x []) = pure $ "(" ++ !(schExp i vs x) ++ ")" - schExp i vs (CApp fc x args) + schExp i vs (CApp fc x args) = pure $ "(" ++ !(schExp i vs x) ++ " " ++ showSep " " !(traverse (schExp i vs) args) ++ ")" - schExp i vs (CCon fc x tag args) + schExp i vs (CCon fc x tag args) = pure $ schConstructor tag !(traverse (schExp i vs) args) - schExp i vs (COp fc op args) + schExp i vs (COp fc op args) = pure $ schOp op !(schArgs i vs args) - schExp i vs (CExtPrim fc p args) + schExp i vs (CExtPrim fc p args) = schExtPrim i vs (toPrim p) args schExp i vs (CForce fc t) = pure $ "(force " ++ !(schExp i vs t) ++ ")" schExp i vs (CDelay fc t) = pure $ "(delay " ++ !(schExp i vs t) ++ ")" - schExp i vs (CConCase fc sc alts def) + schExp i vs (CConCase fc sc alts def) = do tcode <- schExp (i+1) vs sc defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i vs v))) def let n = "sc" ++ show i pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (case (get-tag " ++ n ++ ") " ++ showSep " " !(traverse (schConAlt (i+1) vs n) alts) ++ schCaseDef defc ++ "))" - schExp i vs (CConstCase fc sc alts def) + schExp i vs (CConstCase fc sc alts def) = do defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i vs v))) def tcode <- schExp (i+1) vs sc let n = "sc" ++ show i @@ -314,12 +314,12 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx schExtCommon i vs SchemeCall [ret, fn, args, world] = pure $ mkWorld ("(apply (eval (string->symbol " ++ !(schExp i vs fn) ++")) " ++ !(readArgs i vs args) ++ ")") - schExtCommon i vs PutStr [arg, world] + schExtCommon i vs PutStr [arg, world] = pure $ "(display " ++ !(schExp i vs arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit - schExtCommon i vs GetStr [world] + schExtCommon i vs GetStr [world] = pure $ mkWorld "(blodwen-get-line (current-input-port))" schExtCommon i vs FileOpen [file, mode, bin, world] - = pure $ mkWorld $ fileOp $ "(blodwen-open " + = pure $ mkWorld $ fileOp $ "(blodwen-open " ++ !(schExp i vs file) ++ " " ++ !(schExp i vs mode) ++ " " ++ !(schExp i vs bin) ++ ")" @@ -328,7 +328,7 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx schExtCommon i vs FileReadLine [file, world] = pure $ mkWorld $ fileOp $ "(blodwen-get-line " ++ !(schExp i vs file) ++ ")" schExtCommon i vs FileWriteLine [file, str, world] - = pure $ mkWorld $ fileOp $ "(blodwen-putstring " + = pure $ mkWorld $ fileOp $ "(blodwen-putstring " ++ !(schExp i vs file) ++ " " ++ !(schExp i vs str) ++ ")" schExtCommon i vs FileEOF [file, world] @@ -338,17 +338,17 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx schExtCommon i vs ReadIORef [_, ref, world] = pure $ mkWorld $ "(unbox " ++ !(schExp i vs ref) ++ ")" schExtCommon i vs WriteIORef [_, ref, val, world] - = pure $ mkWorld $ "(set-box! " - ++ !(schExp i vs ref) ++ " " + = pure $ mkWorld $ "(set-box! " + ++ !(schExp i vs ref) ++ " " ++ !(schExp i vs val) ++ ")" schExtCommon i vs VoidElim [_, _] = pure "(display \"Error: Executed 'void'\")" - schExtCommon i vs (Unknown n) args + schExtCommon i vs (Unknown n) args = throw (InternalError ("Can't compile unknown external primitive " ++ show n)) schExtCommon i vs Stdin [] = pure "(current-input-port)" schExtCommon i vs Stdout [] = pure "(current-output-port)" schExtCommon i vs Stderr [] = pure "(current-error-port)" - schExtCommon i vs prim args + schExtCommon i vs prim args = throw (InternalError ("Badly formed external primitive " ++ show prim ++ " " ++ show args)) @@ -362,7 +362,7 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx = pure $ "(define (" ++ schName !(getFullName n) ++ " . any-args) " ++ !(schExp 0 [] exp) ++ ")\n" schDef n (MkForeign _ _ _) = pure "" -- compiled by specific back end schDef n (MkCon t a) = pure "" -- Nothing to compile here - + -- Convert the name to scheme code -- (There may be no code generated, for example if it's a constructor) export diff --git a/src/Compiler/Scheme/Racket.idr b/src/Compiler/Scheme/Racket.idr index 8bf78e1..0731c03 100644 --- a/src/Compiler/Scheme/Racket.idr +++ b/src/Compiler/Scheme/Racket.idr @@ -63,7 +63,7 @@ mutual racketPrim : Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String racketPrim i vs CCall [ret, fn, args, world] = throw (InternalError ("Can't compile C FFI calls to Racket yet")) - racketPrim i vs prim args + racketPrim i vs prim args = schExtCommon racketPrim racketString i vs prim args -- Reference label for keeping track of loaded external libraries @@ -91,7 +91,7 @@ cftySpec fc t = throw (GenericMsg fc ("Can't pass argument of type " ++ show t + loadlib : String -> String -> String loadlib libn ver - = "(define-ffi-definer define-" ++ libn ++ + = "(define-ffi-definer define-" ++ libn ++ " (ffi-lib \"" ++ libn ++ "\" " ++ ver ++ "))\n" getLibVers : String -> (String, String) @@ -131,8 +131,8 @@ cCall fc cfn libspec args ret argTypes <- traverse (\a => do s <- cftySpec fc (snd a) pure (a, s)) args retType <- cftySpec fc ret - let cbind = "(define-" ++ libn ++ " " ++ cfn ++ - " (_fun " ++ showSep " " (map snd argTypes) ++ " -> " ++ + let cbind = "(define-" ++ libn ++ " " ++ cfn ++ + " (_fun " ++ showSep " " (map snd argTypes) ++ " -> " ++ retType ++ "))\n" let call = "(" ++ cfn ++ " " ++ showSep " " !(traverse useArg argTypes) ++ ")" @@ -149,7 +149,7 @@ cCall fc cfn libspec args ret applyLams : String -> List (Maybe (String, CFType)) -> String applyLams n [] = n applyLams n (Nothing :: as) = applyLams ("(" ++ n ++ " #f)") as - applyLams n (Just (a, ty) :: as) + applyLams n (Just (a, ty) :: as) = applyLams ("(" ++ n ++ " " ++ cToRkt ty a ++ ")") as getVal : CFType -> String -> String @@ -199,7 +199,7 @@ useCC fc [] args ret useCC fc (cc :: ccs) args ret = case parseCC cc of Nothing => useCC fc ccs args ret - Just ("scheme", [sfn]) => + Just ("scheme", [sfn]) => do body <- schemeCall fc sfn (map fst args) ret pure ("", body) Just ("C", [cfn, clib]) => cCall fc cfn clib args ret @@ -216,7 +216,7 @@ mkArgs i (c :: cs) = (MN "farg" i, True) :: mkArgs (i + 1) cs schFgnDef : {auto c : Ref Ctxt Defs} -> {auto l : Ref Loaded (List String)} -> FC -> Name -> CDef -> Core (String, String) -schFgnDef fc n (MkForeign cs args ret) +schFgnDef fc n (MkForeign cs args ret) = do let argns = mkArgs 0 args let allargns = map fst argns let useargns = map fst (filter snd argns) @@ -251,9 +251,9 @@ compileToRKT c tm outfile let code = concat (map snd fgndefs) ++ concat compdefs main <- schExp racketPrim racketString 0 [] !(compileExp tags tm) support <- readDataFile "racket/support.rkt" - let scm = schHeader (concat (map fst fgndefs)) ++ - support ++ code ++ - "(void " ++ main ++ ")\n" ++ + let scm = schHeader (concat (map fst fgndefs)) ++ + support ++ code ++ + "(void " ++ main ++ ")\n" ++ schFooter Right () <- coreLift $ writeFile outfile scm | Left err => throw (FileErr outfile err) diff --git a/src/Core/AutoSearch.idr b/src/Core/AutoSearch.idr index f959332..a5e7d57 100644 --- a/src/Core/AutoSearch.idr +++ b/src/Core/AutoSearch.idr @@ -18,7 +18,7 @@ searchType : {auto c : Ref Ctxt Defs} -> FC -> RigCount -> (defaults : Bool) -> (trying : List (Term vars)) -> (depth : Nat) -> - (defining : Name) -> + (defining : Name) -> (checkDets : Bool) -> (topTy : ClosedTerm) -> Env Term vars -> (target : Term vars) -> Core (Term vars) @@ -35,7 +35,7 @@ export mkArgs : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> FC -> RigCount -> - Env Term vars -> NF vars -> + Env Term vars -> NF vars -> Core (List (ArgInfo vars), NF vars) mkArgs fc rigc env (NBind nfc x (Pi c p ty) sc) = do defs <- get Ctxt @@ -43,25 +43,25 @@ mkArgs fc rigc env (NBind nfc x (Pi c p ty) sc) nm <- genName "sa" argTy <- quote empty env ty let argRig = rigMult rigc c - (idx, arg) <- newMeta fc argRig env nm argTy + (idx, arg) <- newMeta fc argRig env nm argTy (Hole (length env) False) False setInvertible fc (Resolved idx) - (rest, restTy) <- mkArgs fc rigc env + (rest, restTy) <- mkArgs fc rigc env !(sc defs (toClosure defaultOpts env arg)) pure (MkArgInfo idx argRig p arg argTy :: rest, restTy) mkArgs fc rigc env ty = pure ([], ty) searchIfHole : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> + FC -> (defaults : Bool) -> List (Term vars) -> (ispair : Bool) -> (depth : Nat) -> - (defining : Name) -> (topTy : ClosedTerm) -> Env Term vars -> - (arg : ArgInfo vars) -> - Core () -searchIfHole fc defaults trying ispair Z def top env arg + (defining : Name) -> (topTy : ClosedTerm) -> Env Term vars -> + (arg : ArgInfo vars) -> + Core () +searchIfHole fc defaults trying ispair Z def top env arg = throw (CantSolveGoal fc [] top) -- possibly should say depth limit hit? -searchIfHole fc defaults trying ispair (S depth) def top env arg +searchIfHole fc defaults trying ispair (S depth) def top env arg = do let hole = holeID arg let rig = argRig arg @@ -70,11 +70,11 @@ searchIfHole fc defaults trying ispair (S depth) def top env arg | Nothing => throw (CantSolveGoal fc [] top) let Hole _ _ = definition gdef | _ => pure () -- already solved - top' <- if ispair + top' <- if ispair then normaliseScope defs [] (type gdef) else pure top - argdef <- searchType fc rig defaults trying depth def False top' env + argdef <- searchType fc rig defaults trying depth def False top' env !(normaliseScope defs env (argType arg)) vs <- unify InTerm fc env (metaApp arg) argdef let [] = constraints vs @@ -90,7 +90,7 @@ successful [] = pure [] successful (elab :: elabs) = do ust <- get UST defs <- branch - catch (do -- Run the elaborator + catch (do -- Run the elaborator res <- elab -- Record post-elaborator state ust' <- get UST @@ -122,7 +122,7 @@ exactlyOne : {vars : _} -> FC -> Env Term vars -> (topTy : ClosedTerm) -> List (Core (Term vars)) -> Core (Term vars) -exactlyOne fc env top [elab] +exactlyOne fc env top [elab] = catch elab (\err => case err of CantSolveGoal _ _ _ => throw err @@ -130,13 +130,13 @@ exactlyOne fc env top [elab] exactlyOne {vars} fc env top all = do elabs <- successful all case rights elabs of - [(res, defs, ust)] => + [(res, defs, ust)] => do put UST ust put Ctxt defs commit pure res [] => throw (CantSolveGoal fc [] top) - rs => throw (AmbiguousSearch fc env + rs => throw (AmbiguousSearch fc env !(traverse normRes rs)) where normRes : (Term vars, Defs, UState) -> Core (Term vars) @@ -147,22 +147,22 @@ exactlyOne {vars} fc env top all -- because something is apparently available now, it will be available by the -- time we get to linearity checking. -- It's also fine to use anything if we're working at multiplicity 0 -getAllEnv : FC -> RigCount -> (done : List Name) -> +getAllEnv : FC -> RigCount -> (done : List Name) -> Env Term vars -> List (Term (done ++ vars), Term (done ++ vars)) getAllEnv fc rigc done [] = [] -getAllEnv {vars = v :: vs} fc rigc done (b :: env) - = let rest = getAllEnv fc rigc (done ++ [v]) env in +getAllEnv {vars = v :: vs} fc rigc done (b :: env) + = let rest = getAllEnv fc rigc (done ++ [v]) env in if multiplicity b == RigW || rigc == Rig0 then let MkVar p = weakenVar {name=v} {inner=v :: vs} done First in - (Local fc Nothing _ p, - rewrite appendAssociative done [v] vs in - weakenNs (done ++ [v]) (binderType b)) :: + (Local fc Nothing _ p, + rewrite appendAssociative done [v] vs in + weakenNs (done ++ [v]) (binderType b)) :: rewrite appendAssociative done [v] vs in rest else rewrite appendAssociative done [v] vs in rest -- A local is usable if it contains no holes in a determining argument position usableLocal : {auto c : Ref Ctxt Defs} -> - FC -> (defaults : Bool) -> + FC -> (defaults : Bool) -> Env Term vars -> (locTy : NF vars) -> Core Bool -- pattern variables count as concrete things! usableLocal loc defaults env (NApp fc (NMeta (PV _ _) _ _) args) @@ -180,24 +180,24 @@ usableLocal {vars} loc defaults env (NTCon _ n _ _ args) usableLocalArg i dets (c :: cs) = if i `elem` dets then do defs <- get Ctxt - u <- usableLocal loc defaults env !(evalClosure defs c) + u <- usableLocal loc defaults env !(evalClosure defs c) if u then usableLocalArg (1 + i) dets cs else pure False else usableLocalArg (1 + i) dets cs usableLocal loc defaults env (NDCon _ n _ _ args) = do defs <- get Ctxt - us <- traverse (usableLocal loc defaults env) + us <- traverse (usableLocal loc defaults env) !(traverse (evalClosure defs) args) pure (and (map Delay us)) usableLocal loc defaults env (NApp _ (NLocal _ _ _) args) = do defs <- get Ctxt - us <- traverse (usableLocal loc defaults env) + us <- traverse (usableLocal loc defaults env) !(traverse (evalClosure defs) args) pure (and (map Delay us)) usableLocal loc defaults env (NBind fc x (Pi _ _ _) sc) = do defs <- get Ctxt - usableLocal loc defaults env + usableLocal loc defaults env !(sc defs (toClosure defaultOpts env (Erased fc))) usableLocal loc defaults env (NErased _) = pure False usableLocal loc _ _ _ = pure True @@ -208,20 +208,20 @@ searchLocalWith : {auto c : Ref Ctxt Defs} -> (defaults : Bool) -> List (Term vars) -> (depth : Nat) -> (defining : Name) -> (topTy : ClosedTerm) -> - Env Term vars -> List (Term vars, Term vars) -> + Env Term vars -> List (Term vars, Term vars) -> (target : NF vars) -> Core (Term vars) searchLocalWith fc rigc defaults trying depth def top env [] target = throw (CantSolveGoal fc [] top) searchLocalWith {vars} fc rigc defaults trying depth def top env ((prf, ty) :: rest) target - = tryUnify + = tryUnify (do defs <- get Ctxt nty <- nf defs env ty findPos defs prf id nty target) (searchLocalWith fc rigc defaults trying depth def top env rest target) where - clearEnvType : {idx : Nat} -> .(IsVar name idx vs) -> + clearEnvType : {idx : Nat} -> .(IsVar name idx vs) -> FC -> Env Term vs -> Env Term vs - clearEnvType First fc (b :: env) + clearEnvType First fc (b :: env) = Lam (multiplicity b) Explicit (Erased fc) :: env clearEnvType (Later p) fc (b :: env) = b :: clearEnvType p fc env @@ -230,10 +230,10 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env ((prf, ty) :: r = clearEnvType p fc env clearEnv _ env = env - findDirect : Defs -> Term vars -> + findDirect : Defs -> Term vars -> (Term vars -> Term vars) -> NF vars -> -- local's type - (target : NF vars) -> + (target : NF vars) -> Core (Term vars) findDirect defs prf f ty target = do (args, appTy) <- mkArgs fc rigc env ty @@ -252,16 +252,16 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env ((prf, ty) :: r let env' = clearEnv prf env -- Work right to left, because later arguments may solve -- earlier ones by unification - traverse (searchIfHole fc defaults trying False depth def top env') + traverse (searchIfHole fc defaults trying False depth def top env') (reverse args) pure candidate else do logNF 10 "Can't use " env ty throw (CantSolveGoal fc [] top) - findPos : Defs -> Term vars -> + findPos : Defs -> Term vars -> (Term vars -> Term vars) -> NF vars -> -- local's type - (target : NF vars) -> + (target : NF vars) -> Core (Term vars) findPos defs prf f nty@(NTCon pfc pn _ _ [xty, yty]) target = tryUnify (findDirect defs prf f nty target) @@ -277,14 +277,14 @@ searchLocalWith {vars} fc rigc defaults trying depth def top env ((prf, ty) :: r ytytm <- quote empty env yty tryUnify (do xtynf <- evalClosure defs xty - findPos defs prf + findPos defs prf (\arg => apply fc (Ref fc Func fname) [xtytm, ytytm, f arg]) xtynf target) (do ytynf <- evalClosure defs yty - findPos defs prf + findPos defs prf (\arg => apply fc (Ref fc Func sname) [xtytm, ytytm, @@ -300,10 +300,10 @@ searchLocal : {auto c : Ref Ctxt Defs} -> (defaults : Bool) -> List (Term vars) -> (depth : Nat) -> (defining : Name) -> (topTy : ClosedTerm) -> - Env Term vars -> + Env Term vars -> (target : NF vars) -> Core (Term vars) searchLocal fc rig defaults trying depth def top env target - = searchLocalWith fc rig defaults trying depth def top env + = searchLocalWith fc rig defaults trying depth def top env (getAllEnv fc rig [] env) target isPairNF : {auto c : Ref Ctxt Defs} -> @@ -320,12 +320,12 @@ searchName : {auto c : Ref Ctxt Defs} -> (defaults : Bool) -> List (Term vars) -> (depth : Nat) -> (defining : Name) -> (topTy : ClosedTerm) -> - Env Term vars -> (target : NF vars) -> - (Name, GlobalDef) -> + Env Term vars -> (target : NF vars) -> + (Name, GlobalDef) -> Core (Term vars) searchName fc rigc defaults trying depth def top env target (n, ndef) = do defs <- get Ctxt - when (not (visibleInAny (!getNS :: !getNestedNS) + when (not (visibleInAny (!getNS :: !getNestedNS) (fullname ndef) (visibility ndef))) $ throw (CantSolveGoal fc [] top) when (BlockedHint `elem` flags ndef) $ @@ -348,7 +348,7 @@ searchName fc rigc defaults trying depth def top env target (n, ndef) logTermNF 10 "Candidate " env candidate -- Work right to left, because later arguments may solve earlier -- dependencies by unification - traverse (searchIfHole fc defaults trying ispair depth def top env) + traverse (searchIfHole fc defaults trying ispair depth def top env) (reverse args) pure candidate @@ -358,7 +358,7 @@ searchNames : {auto c : Ref Ctxt Defs} -> (defaults : Bool) -> List (Term vars) -> (depth : Nat) -> (defining : Name) -> (topTy : ClosedTerm) -> - Env Term vars -> Bool -> List Name -> + Env Term vars -> Bool -> List Name -> (target : NF vars) -> Core (Term vars) searchNames fc rigc defaults trying depth defining topty env ambig [] target = throw (CantSolveGoal fc [] topty) @@ -371,7 +371,7 @@ searchNames fc rigc defaults trying depth defining topty env ambig (n :: ns) tar then anyOne fc env topty elabs else exactlyOne fc env topty elabs where - visible : Context -> + visible : Context -> List (List String) -> Name -> Core (Maybe (Name, GlobalDef)) visible gam nspace n = do Just def <- lookupCtxtExact n gam @@ -383,8 +383,8 @@ searchNames fc rigc defaults trying depth defining topty env ambig (n :: ns) tar concreteDets : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> FC -> Bool -> - Env Term vars -> (top : ClosedTerm) -> - (pos : Nat) -> (dets : List Nat) -> + Env Term vars -> (top : ClosedTerm) -> + (pos : Nat) -> (dets : List Nat) -> (args : List (Closure vars)) -> Core () concreteDets fc defaults env top pos dets [] = pure () @@ -421,28 +421,28 @@ concreteDets {vars} fc defaults env top pos dets (arg :: args) checkConcreteDets : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> FC -> Bool -> - Env Term vars -> (top : ClosedTerm) -> + Env Term vars -> (top : ClosedTerm) -> NF vars -> Core () -checkConcreteDets fc defaults env top (NTCon tfc tyn t a args) +checkConcreteDets fc defaults env top (NTCon tfc tyn t a args) = do defs <- get Ctxt if !(isPairType tyn) then case args of - [aty, bty] => + [aty, bty] => do anf <- evalClosure defs aty bnf <- evalClosure defs bty checkConcreteDets fc defaults env top anf checkConcreteDets fc defaults env top bnf _ => do sd <- getSearchData fc defaults tyn concreteDets fc defaults env top 0 (detArgs sd) args - else + else do sd <- getSearchData fc defaults tyn concreteDets fc defaults env top 0 (detArgs sd) args checkConcreteDets fc defaults env top _ = pure () abandonIfCycle : {auto c : Ref Ctxt Defs} -> - Env Term vars -> Term vars -> List (Term vars) -> + Env Term vars -> Term vars -> List (Term vars) -> Core () abandonIfCycle env tm [] = pure () abandonIfCycle env tm (ty :: tys) @@ -470,7 +470,7 @@ searchType {vars} fc rigc defaults trying depth def checkdets top env target if a == length args then do logNF 10 "Next target" env nty sd <- getSearchData fc defaults tyn - -- Check determining arguments are okay for 'args' + -- Check determining arguments are okay for 'args' when checkdets $ checkConcreteDets fc defaults env top (NTCon tfc tyn t a args) @@ -484,7 +484,7 @@ searchType {vars} fc rigc defaults trying depth def checkdets top env target ambig : Error -> Bool ambig (AmbiguousSearch _ _ _) = True ambig _ = False - + -- Take the earliest error message (that's when we look inside pairs, -- typically, and it's best to be more precise) tryGroups : Maybe Error -> @@ -506,14 +506,14 @@ searchType {vars} fc rigc defaults trying depth def checkdets top env target -- {auto u : Ref UST UState} -> -- FC -> RigCount -> -- (defaults : Bool) -> (depth : Nat) -> --- (defining : Name) -> (topTy : Term vars) -> Env Term vars -> +-- (defining : Name) -> (topTy : Term vars) -> Env Term vars -> -- Core (Term vars) Core.Unify.search fc rigc defaults depth def top env = do defs <- get Ctxt logTermNF 2 "Initial target: " env top log 2 $ "Running search with defaults " ++ show defaults - tm <- searchType fc rigc defaults [] depth def - True (abstractEnvType fc env top) env + tm <- searchType fc rigc defaults [] depth def + True (abstractEnvType fc env top) env top logTermNF 2 "Result" env tm defs <- get Ctxt diff --git a/src/Core/Binary.idr b/src/Core/Binary.idr index 202bf18..a9ea326 100644 --- a/src/Core/Binary.idr +++ b/src/Core/Binary.idr @@ -109,7 +109,7 @@ HasNames e => HasNames (TTCFile e) where !(fullRW gam rewritenames) !(fullPrim gam primnames) !(full gam namedirectives) - cgdirectives + cgdirectives !(full gam extra) where fullPair : Context -> Maybe PairNames -> Core (Maybe PairNames) @@ -169,15 +169,15 @@ HasNames e => HasNames (TTCFile e) where asName : List String -> Maybe (List String) -> Name -> Name -asName mod (Just ns) (NS oldns n) - = if mod == oldns +asName mod (Just ns) (NS oldns n) + = if mod == oldns then NS ns n -- TODO: What about if there are nested namespaces in a module? else NS oldns n asName _ _ n = n -- NOTE: TTC files are only compatible if the version number is the same, -- *and* the 'annot/extra' type are the same, or there are no holes/constraints -writeTTCFile : (HasNames extra, TTC extra) => +writeTTCFile : (HasNames extra, TTC extra) => {auto c : Ref Ctxt Defs} -> Ref Bin Binary -> TTCFile extra -> Core () writeTTCFile b file_in @@ -204,7 +204,7 @@ writeTTCFile b file_in toBuf b (cgdirectives file) toBuf b (extraData file) -readTTCFile : TTC extra => +readTTCFile : TTC extra => {auto c : Ref Ctxt Defs} -> List String -> Maybe (List String) -> Ref Bin Binary -> Core (TTCFile extra) @@ -238,12 +238,12 @@ readTTCFile modns as b cgds <- fromBuf b ex <- fromBuf b pure (MkTTCFile ver ifaceHash importHashes - [] [] [] defs uholes -- holes guesses constraints defs + [] [] [] defs uholes -- holes guesses constraints defs autohs typehs imp nextv cns nns pns rws prims nds cgds ex) -- Pull out the list of GlobalDefs that we want to save -getSaveDefs : List Name -> List (Name, Binary) -> Defs -> +getSaveDefs : List Name -> List (Name, Binary) -> Defs -> Core (List (Name, Binary)) getSaveDefs [] acc _ = pure acc getSaveDefs (n :: ns) acc defs @@ -269,10 +269,10 @@ writeToTTC extradata fname ust <- get UST gdefs <- getSaveDefs (keys (toSave defs)) [] defs log 5 $ "Writing " ++ fname ++ " with hash " ++ show (ifaceHash defs) - writeTTCFile buf + writeTTCFile buf (MkTTCFile ttcVersion (ifaceHash defs) (importHashes defs) - (toList (holes ust)) - (toList (guesses ust)) + (toList (holes ust)) + (toList (guesses ust)) (toList (constraints ust)) gdefs (keys (userHoles defs)) @@ -282,10 +282,10 @@ writeToTTC extradata fname (nextName ust) (currentNS defs) (nestedNS defs) - (pairnames (options defs)) - (rewritenames (options defs)) - (primnames (options defs)) - (namedirectives defs) + (pairnames (options defs)) + (rewritenames (options defs)) + (primnames (options defs)) + (namedirectives defs) (cgdirectives defs) extradata) Right ok <- coreLift $ writeToFile fname !(get Bin) @@ -316,8 +316,8 @@ addGlobalDef modns as (n, def) addTypeHint : {auto c : Ref Ctxt Defs} -> FC -> (Name, Name, Bool) -> Core () -addTypeHint fc (tyn, hintn, d) - = do logC 10 (pure (show !(getFullName hintn) ++ " for " ++ +addTypeHint fc (tyn, hintn, d) + = do logC 10 (pure (show !(getFullName hintn) ++ " for " ++ show !(getFullName tyn))) addHintFor fc tyn hintn d True @@ -326,14 +326,14 @@ addAutoHint : {auto c : Ref Ctxt Defs} -> addAutoHint (hintn, d) = addGlobalHint hintn d export -updatePair : {auto c : Ref Ctxt Defs} -> +updatePair : {auto c : Ref Ctxt Defs} -> Maybe PairNames -> Core () updatePair p = do defs <- get Ctxt put Ctxt (record { options->pairnames $= (p <+>) } defs) export -updateRewrite : {auto c : Ref Ctxt Defs} -> +updateRewrite : {auto c : Ref Ctxt Defs} -> Maybe RewriteNames -> Core () updateRewrite r = do defs <- get Ctxt @@ -344,17 +344,17 @@ updatePrimNames : PrimNames -> PrimNames -> PrimNames updatePrimNames p = record { fromIntegerName $= ((fromIntegerName p) <+>), fromStringName $= ((fromStringName p) <+>), - fromCharName $= ((fromCharName p) <+>) } + fromCharName $= ((fromCharName p) <+>) } export -updatePrims : {auto c : Ref Ctxt Defs} -> +updatePrims : {auto c : Ref Ctxt Defs} -> PrimNames -> Core () updatePrims p = do defs <- get Ctxt put Ctxt (record { options->primnames $= updatePrimNames p } defs) export -updateNameDirectives : {auto c : Ref Ctxt Defs} -> +updateNameDirectives : {auto c : Ref Ctxt Defs} -> List (Name, List String) -> Core () updateNameDirectives [] = pure () updateNameDirectives ((t, ns) :: nds) @@ -363,7 +363,7 @@ updateNameDirectives ((t, ns) :: nds) updateNameDirectives nds export -updateCGDirectives : {auto c : Ref Ctxt Defs} -> +updateCGDirectives : {auto c : Ref Ctxt Defs} -> List (CG, String) -> Core () updateCGDirectives cgs = do defs <- get Ctxt @@ -382,7 +382,7 @@ readFromTTC : TTC extra => (fname : String) -> -- file containing the module (modNS : List String) -> -- module namespace (importAs : List String) -> -- namespace to import as - Core (Maybe (extra, Int, + Core (Maybe (extra, Int, List (List String, Bool, List String))) readFromTTC loc reexp fname modNS importAs = do defs <- get Ctxt @@ -394,8 +394,8 @@ readFromTTC loc reexp fname modNS importAs Right buf <- coreLift $ readFromFile fname | Left err => throw (InternalError (fname ++ ": " ++ show err)) bin <- newRef Bin buf -- for reading the file into - let as = if importAs == modNS - then Nothing + let as = if importAs == modNS + then Nothing else Just importAs ttc <- readTTCFile modNS as bin logTime "Adding defs" $ traverse (addGlobalDef modNS as) (context ttc) diff --git a/src/Core/CaseBuilder.idr b/src/Core/CaseBuilder.idr index dc88df2..793a458 100644 --- a/src/Core/CaseBuilder.idr +++ b/src/Core/CaseBuilder.idr @@ -15,7 +15,7 @@ data Phase = CompileTime | RunTime data ArgType : List Name -> Type where Known : RigCount -> (ty : Term vars) -> ArgType vars -- arg has type 'ty' - Stuck : (fty : Term vars) -> ArgType vars + Stuck : (fty : Term vars) -> ArgType vars -- ^ arg will have argument type of 'fty' when we know enough to -- calculate it Unknown : ArgType vars @@ -30,7 +30,7 @@ record PatInfo (pvar : Name) (vars : List Name) where constructor MkInfo pat : Pat loc : IsVar name idx vars - argType : ArgType vars -- Type of the argument being inspected (i.e. + argType : ArgType vars -- Type of the argument being inspected (i.e. -- *not* refined by this particular pattern) Show (PatInfo n vars) where @@ -52,7 +52,7 @@ data NamedPats : List Name -> -- pattern variables still to process -- in order Type where Nil : NamedPats vars [] - (::) : PatInfo pvar vars -> + (::) : PatInfo pvar vars -> -- ^ a pattern, where its variable appears in the vars list, -- and its type. The type has no variable names; any names it -- refers to are explicit @@ -63,7 +63,7 @@ getPatInfo [] = [] getPatInfo (x :: xs) = pat x :: getPatInfo xs updatePats : {auto c : Ref Ctxt Defs} -> - Env Term vars -> + Env Term vars -> NF vars -> NamedPats vars todo -> Core (NamedPats vars todo) updatePats env nf [] = pure [] updatePats {todo = pvar :: ns} env (NBind fc _ (Pi c _ farg) fsc) (p :: ps) @@ -76,7 +76,7 @@ updatePats {todo = pvar :: ns} env (NBind fc _ (Pi c _ farg) fsc) (p :: ps) _ => pure (p :: ps) updatePats env nf (p :: ps) = case argType p of - Unknown => + Unknown => do defs <- get Ctxt empty <- clearDefs defs pure (record { argType = Stuck !(quote empty env nf) } p :: ps) @@ -87,20 +87,20 @@ mkEnv fc [] = [] mkEnv fc (n :: ns) = PVar RigW Explicit (Erased fc) :: mkEnv fc ns substInPatInfo : {auto c : Ref Ctxt Defs} -> - FC -> Name -> Term vars -> PatInfo pvar vars -> - NamedPats vars todo -> + FC -> Name -> Term vars -> PatInfo pvar vars -> + NamedPats vars todo -> Core (PatInfo pvar vars, NamedPats vars todo) -substInPatInfo {pvar} {vars} fc n tm p ps +substInPatInfo {pvar} {vars} fc n tm p ps = case argType p of Known c ty => pure (record { argType = Known c (substName n tm ty) } p, ps) - Stuck fty => + Stuck fty => do defs <- get Ctxt empty <- clearDefs defs let env = mkEnv fc vars case !(nf defs env (substName n tm fty)) of NBind pfc _ (Pi c _ farg) fsc => pure (record { argType = Known c !(quote empty env farg) } p, - !(updatePats env + !(updatePats env !(fsc defs (toClosure defaultOpts env (Ref pfc Bound pvar))) ps)) _ => pure (p, ps) @@ -109,10 +109,10 @@ substInPatInfo {pvar} {vars} fc n tm p ps -- Substitute the name with a term in the pattern types, and reduce further -- (this aims to resolve any 'Stuck' pattern types) substInPats : {auto c : Ref Ctxt Defs} -> - FC -> Name -> Term vars -> NamedPats vars todo -> + FC -> Name -> Term vars -> NamedPats vars todo -> Core (NamedPats vars todo) substInPats fc n tm [] = pure [] -substInPats fc n tm (p :: ps) +substInPats fc n tm (p :: ps) = do (p', ps') <- substInPatInfo fc n tm p ps pure (p' :: !(substInPats fc n tm ps')) @@ -122,7 +122,7 @@ getPat First (x :: xs) = x getPat (Later p) (x :: xs) = getPat p xs dropPat : {idx : Nat} -> - .(el : IsVar name idx ps) -> + .(el : IsVar name idx ps) -> NamedPats ns ps -> NamedPats ns (dropVar ps el) dropPat First (x :: xs) = xs dropPat (Later p) (x :: xs) = x :: dropPat p xs @@ -133,8 +133,8 @@ Show (NamedPats vars todo) where showAll : NamedPats vs ts -> String showAll [] = "" showAll {ts = t :: _ } [x] - = show t ++ " " ++ show (pat x) ++ " [" ++ show (argType x) ++ "]" - showAll {ts = t :: _ } (x :: xs) + = show t ++ " " ++ show (pat x) ++ " [" ++ show (argType x) ++ "]" + showAll {ts = t :: _ } (x :: xs) = show t ++ " " ++ show (pat x) ++ " [" ++ show (argType x) ++ "]" ++ ", " ++ showAll xs @@ -151,10 +151,10 @@ weaken : NamedPats vars todo -> NamedPats (x :: vars) todo weaken [] = [] weaken (p :: ps) = weaken p :: weaken ps -weakenNs : (ns : List Name) -> +weakenNs : (ns : List Name) -> NamedPats vars todo -> NamedPats (ns ++ vars) todo weakenNs ns [] = [] -weakenNs ns (p :: ps) +weakenNs ns (p :: ps) = weakenNs ns p :: weakenNs ns ps (++) : NamedPats vars ms -> NamedPats vars ns -> NamedPats vars (ms ++ ns) @@ -170,18 +170,18 @@ take (x :: xs) (p :: ps) = p :: take xs ps data PatClause : (vars : List Name) -> (todo : List Name) -> Type where MkPatClause : List Name -> -- names matched so far (from original lhs) - NamedPats vars todo -> + NamedPats vars todo -> (rhs : Term vars) -> PatClause vars todo getNPs : PatClause vars todo -> NamedPats vars todo getNPs (MkPatClause _ lhs rhs) = lhs Show (PatClause vars todo) where - show (MkPatClause _ ps rhs) + show (MkPatClause _ ps rhs) = show ps ++ " => " ++ show rhs -substInClause : {auto c : Ref Ctxt Defs} -> - FC -> PatClause vars (a :: todo) -> +substInClause : {auto c : Ref Ctxt Defs} -> + FC -> PatClause vars (a :: todo) -> Core (PatClause vars (a :: todo)) substInClause {vars} {a} fc (MkPatClause pvars (MkInfo pat pprf fty :: pats) rhs) = do pats' <- substInPats fc a (mkTerm vars pat) pats @@ -195,7 +195,7 @@ checkLengthMatch : (xs : List a) -> (ys : List b) -> Maybe (LengthMatch xs ys) checkLengthMatch [] [] = Just NilMatch checkLengthMatch [] (x :: xs) = Nothing checkLengthMatch (x :: xs) [] = Nothing -checkLengthMatch (x :: xs) (y :: ys) +checkLengthMatch (x :: xs) (y :: ys) = Just (ConsMatch !(checkLengthMatch xs ys)) data Partitions : List (PatClause vars todo) -> Type where @@ -255,11 +255,11 @@ clauseType phase (MkPatClause pvars (MkInfo arg _ ty :: rest) rhs) partition : Phase -> (ps : List (PatClause vars (a :: as))) -> 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 @@ -274,13 +274,13 @@ data ConType : Type where CConst : Constant -> ConType conTypeEq : (x, y : ConType) -> Maybe (x = y) -conTypeEq (CName x tag) (CName x' tag') +conTypeEq (CName x tag) (CName x' tag') = do Refl <- nameEq x x' case decEq tag tag' of Yes Refl => Just Refl No contra => Nothing conTypeEq CDelay CDelay = Just Refl -conTypeEq (CConst x) (CConst y) +conTypeEq (CConst x) (CConst y) = case constantEq x y of Nothing => Nothing Just Refl => Just Refl @@ -289,11 +289,11 @@ conTypeEq _ _ = Nothing data Group : List Name -> -- variables in scope List Name -> -- pattern variables still to process Type where - ConGroup : Name -> (tag : Int) -> + ConGroup : Name -> (tag : Int) -> List (PatClause (newargs ++ vars) (newargs ++ todo)) -> Group vars todo - DelayGroup : List (PatClause (tyarg :: valarg :: vars) - (tyarg :: valarg :: todo)) -> + DelayGroup : List (PatClause (tyarg :: valarg :: vars) + (tyarg :: valarg :: todo)) -> Group vars todo ConstGroup : Constant -> List (PatClause vars todo) -> Group vars todo @@ -305,9 +305,9 @@ Show (Group vars todo) where data GroupMatch : ConType -> List Pat -> Group vars todo -> Type where ConMatch : LengthMatch ps newargs -> - GroupMatch (CName n tag) ps + GroupMatch (CName n tag) ps (ConGroup {newargs} n tag (MkPatClause pvs pats rhs :: rest)) - DelayMatch : GroupMatch CDelay [] + DelayMatch : GroupMatch CDelay [] (DelayGroup {tyarg} {valarg} (MkPatClause pvs pats rhs :: rest)) ConstMatch : GroupMatch (CConst c) [] (ConstGroup c (MkPatClause pvs pats rhs :: rest)) @@ -315,7 +315,7 @@ data GroupMatch : ConType -> List Pat -> Group vars todo -> Type where checkGroupMatch : (c : ConType) -> (ps : List Pat) -> (g : Group vars todo) -> GroupMatch c ps g -checkGroupMatch (CName x tag) ps (ConGroup {newargs} x' tag' (MkPatClause pvs pats rhs :: rest)) +checkGroupMatch (CName x tag) ps (ConGroup {newargs} x' tag' (MkPatClause pvs pats rhs :: rest)) = case checkLengthMatch ps newargs of Nothing => NoMatch Just prf => case (nameEq x x', decEq tag tag') of @@ -324,7 +324,7 @@ checkGroupMatch (CName x tag) ps (ConGroup {newargs} x' tag' (MkPatClause pvs pa checkGroupMatch (CName x tag) ps _ = NoMatch checkGroupMatch CDelay [] (DelayGroup (MkPatClause pvs pats rhs :: rest)) = DelayMatch -checkGroupMatch (CConst c) [] (ConstGroup c' (MkPatClause pvs pats rhs :: rest)) +checkGroupMatch (CConst c) [] (ConstGroup c' (MkPatClause pvs pats rhs :: rest)) = case constantEq c c' of Nothing => NoMatch Just Refl => ConstMatch @@ -370,9 +370,9 @@ nextNames {vars} fc root (p :: pats) fty -- replace the prefix of patterns with 'pargs' newPats : (pargs : List Pat) -> LengthMatch pargs ns -> NamedPats vars (ns ++ todo) -> - NamedPats vars ns + NamedPats vars ns newPats [] NilMatch rest = [] -newPats (newpat :: xs) (ConsMatch w) (pi :: rest) +newPats (newpat :: xs) (ConsMatch w) (pi :: rest) = record { pat = newpat} pi :: newPats xs w rest updateNames : List (Name, Pat) -> List (Name, Name) @@ -388,7 +388,7 @@ updatePatNames ns (pi :: ps) = record { pat $= update } pi :: updatePatNames ns ps where update : Pat -> Pat - update (PAs fc n p) + update (PAs fc n p) = case lookup n ns of Nothing => PAs fc n (update p) Just n' => PAs fc n' (update p) @@ -396,7 +396,7 @@ updatePatNames ns (pi :: ps) update (PTyCon fc n a ps) = PTyCon fc n a (map update ps) update (PArrow fc x s t) = PArrow fc x (update s) (update t) update (PDelay fc r t p) = PDelay fc r (update t) (update p) - update (PLoc fc n) + update (PLoc fc n) = case lookup n ns of Nothing => PLoc fc n Just n' => PLoc fc n' @@ -406,12 +406,12 @@ groupCons : {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> FC -> Name -> List Name -> - List (PatClause vars (a :: todo)) -> + List (PatClause vars (a :: todo)) -> Core (List (Group vars todo)) -groupCons fc fn pvars cs +groupCons fc fn pvars cs = gc [] cs where - addConG : Name -> (tag : Int) -> + addConG : Name -> (tag : Int) -> List Pat -> NamedPats vars todo -> (rhs : Term vars) -> (acc : List (Group vars todo)) -> @@ -420,7 +420,7 @@ groupCons fc fn pvars cs -- 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 {todo} n tag pargs pats rhs [] + addConG {todo} n tag pargs pats rhs [] = do cty <- the (Core (NF vars)) $ if n == UN "->" then pure $ NBind fc (MN "_" 0) (Pi RigW Explicit (NType fc)) $ (\d, a => pure $ NBind fc (MN "_" 1) (Pi RigW Explicit (NErased fc)) @@ -434,15 +434,15 @@ groupCons fc fn pvars cs -- explicit dependencies in types accurate) let pats' = updatePatNames (updateNames (zip patnames pargs)) (weakenNs patnames pats) - let clause = MkPatClause {todo = patnames ++ todo} - pvars - (newargs ++ pats') + let clause = MkPatClause {todo = patnames ++ todo} + pvars + (newargs ++ pats') (weakenNs patnames rhs) pure [ConGroup n tag [clause]] addConG {todo} n tag pargs pats rhs (g :: gs) with (checkGroupMatch (CName n tag) pargs g) addConG {todo} n tag pargs pats rhs ((ConGroup {newargs} n tag ((MkPatClause pvars ps tm) :: rest)) :: gs) - | (ConMatch {newargs} lprf) + | (ConMatch {newargs} lprf) = do let newps = newPats pargs lprf ps let pats' = updatePatNames (updateNames (zip newargs pargs)) (weakenNs newargs pats) @@ -454,7 +454,7 @@ groupCons fc fn pvars cs -- match the clauses top to bottom. pure ((ConGroup n tag (MkPatClause pvars ps tm :: rest ++ [newclause])) :: gs) - addConG n tag pargs pats rhs (g :: gs) | NoMatch + addConG n tag pargs pats rhs (g :: gs) | NoMatch = do gs' <- addConG n tag pargs pats rhs gs pure (g :: gs') @@ -468,11 +468,11 @@ groupCons fc fn pvars cs Core (List (Group vars todo)) addDelayG {todo} pty parg pats rhs [] = do let dty = NBind fc (MN "a" 0) (Pi Rig0 Explicit (NType fc)) $ - (\d, a => + (\d, a => do a' <- evalClosure d a pure (NBind fc (MN "x" 0) (Pi RigW Explicit a') (\dv, av => pure (NDelayed fc LUnknown a')))) - ([tyname, argname] ** newargs) <- nextNames {vars} fc "e" [pty, parg] + ([tyname, argname] ** newargs) <- nextNames {vars} fc "e" [pty, parg] (Just dty) | _ => throw (InternalError "Error compiling Delay pattern match") let pats' = updatePatNames (updateNames [(tyname, pty), @@ -490,9 +490,9 @@ groupCons fc fn pvars cs let pats' = updatePatNames (updateNames [(tyarg, pty), (valarg, parg)]) (weakenNs [tyarg, valarg] pats) - let newclause : PatClause (tyarg :: valarg :: vars) + let newclause : PatClause (tyarg :: valarg :: vars) (tyarg :: valarg :: todo) - = MkPatClause pvars (newps ++ pats') + = MkPatClause pvars (newps ++ pats') (weakenNs [tyarg, valarg] rhs) pure ((DelayGroup (MkPatClause pvars ps tm :: rest ++ [newclause])) :: gs) @@ -504,30 +504,30 @@ groupCons fc fn pvars cs (rhs : Term vars) -> (acc : List (Group vars todo)) -> Core (List (Group vars todo)) - addConstG c pats rhs [] + addConstG c pats rhs [] = pure [ConstGroup c [MkPatClause pvars pats rhs]] addConstG {todo} c pats rhs (g :: gs) with (checkGroupMatch (CConst c) [] g) addConstG {todo} c pats rhs - ((ConstGroup c ((MkPatClause pvars ps tm) :: rest)) :: gs) | ConstMatch + ((ConstGroup c ((MkPatClause pvars ps tm) :: rest)) :: gs) | ConstMatch = let newclause : PatClause vars todo = MkPatClause pvars pats rhs in - pure ((ConstGroup c + pure ((ConstGroup c (MkPatClause pvars ps tm :: rest ++ [newclause])) :: gs) - addConstG c pats rhs (g :: gs) | NoMatch + addConstG c pats rhs (g :: gs) | NoMatch = do gs' <- addConstG c pats rhs gs pure (g :: gs') - + addGroup : {idx : Nat} -> Pat -> .(IsVar name idx vars) -> - NamedPats vars todo -> Term vars -> - List (Group vars todo) -> + NamedPats vars todo -> Term vars -> + List (Group vars todo) -> Core (List (Group vars todo)) -- 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 rhs acc + addGroup (PAs fc n p) pprf pats rhs acc = addGroup p pprf pats (substName n (Local fc (Just True) _ pprf) rhs) acc - addGroup (PCon _ n t a pargs) pprf pats rhs acc + addGroup (PCon _ n t a pargs) pprf pats rhs acc = addConG n t pargs pats rhs acc - addGroup (PTyCon _ n a pargs) pprf pats rhs acc + addGroup (PTyCon _ n a pargs) pprf pats rhs acc = addConG n 0 pargs pats rhs acc addGroup (PArrow _ _ s t) pprf pats rhs acc = addConG (UN "->") 0 [s, t] pats rhs acc @@ -535,16 +535,16 @@ groupCons fc fn pvars cs -- scrutinee (need to check in 'caseGroups below) addGroup (PDelay _ _ pty parg) pprf pats rhs acc = addDelayG pty parg pats rhs acc - addGroup (PConst _ c) pprf pats rhs acc + addGroup (PConst _ c) pprf pats rhs acc = addConstG c pats rhs acc addGroup _ pprf pats rhs acc = pure acc -- Can't happen, not a constructor -- -- FIXME: Is this possible to rule out with a type? Probably. - gc : List (Group vars todo) -> - List (PatClause vars (a :: todo)) -> + gc : List (Group vars todo) -> + List (PatClause vars (a :: todo)) -> Core (List (Group vars todo)) gc acc [] = pure acc - gc {a} acc ((MkPatClause pvars (MkInfo pat pprf fty :: pats) rhs) :: cs) + gc {a} acc ((MkPatClause pvars (MkInfo pat pprf fty :: pats) rhs) :: cs) = do acc' <- addGroup pat pprf pats rhs acc gc acc' cs @@ -555,12 +555,12 @@ getFirstArgType : NamedPats ns (p :: ps) -> ArgType ns getFirstArgType (p :: _) = argType p -- Check whether all the initial patterns have the same concrete, known --- and matchable type, which is multiplicity > 0. +-- and matchable type, which is multiplicity > 0. -- If so, it's okay to match on it sameType : {auto i : Ref PName Int} -> - {auto c : Ref Ctxt Defs} -> + {auto c : Ref Ctxt Defs} -> FC -> Name -> - Env Term ns -> List (NamedPats ns (p :: ps)) -> + Env Term ns -> List (NamedPats ns (p :: ps)) -> Core () sameType fc fn env [] = pure () sameType {ns} fc fn env (p :: xs) @@ -580,10 +580,10 @@ sameType {ns} fc fn env (p :: xs) sameTypeAs : NF ns -> List (ArgType ns) -> Core () sameTypeAs ty [] = pure () - sameTypeAs ty (Known Rig0 t :: xs) + sameTypeAs ty (Known Rig0 t :: xs) = throw (CaseCompile fc fn (MatchErased (_ ** (env, mkTerm _ (firstPat p))))) -- Can't match on erased thing - sameTypeAs ty (Known c t :: xs) + sameTypeAs ty (Known c t :: xs) = do defs <- get Ctxt if headEq ty !(nf defs env t) then sameTypeAs ty xs @@ -594,8 +594,8 @@ sameType {ns} fc fn env (p :: xs) -- If so, we'll match it to refine later types and move on samePat : List (NamedPats ns (p :: ps)) -> Bool samePat [] = True -samePat (pi :: xs) - = samePatAs (dropAs (getFirstPat pi)) +samePat (pi :: xs) + = samePatAs (dropAs (getFirstPat pi)) (map (dropAs . getFirstPat) xs) where dropAs : Pat -> Pat @@ -613,7 +613,7 @@ samePat (pi :: xs) then samePatAs (PCon fc n t a args) ps else False samePatAs (PConst fc c) (PConst _ c' :: ps) - = if c == c' + = if c == c' then samePatAs (PConst fc c) ps else False samePatAs (PArrow fc x s t) (PArrow _ _ s' t' :: ps) @@ -652,17 +652,17 @@ countDiff xs = length (distinct [] (map getFirstCon xs)) distinct : List Pat -> List Pat -> List Pat distinct acc [] = acc - distinct acc (p :: ps) - = if elemBy sameCase p acc + distinct acc (p :: ps) + = if elemBy sameCase p acc then distinct acc ps else distinct (p :: acc) ps getScore : {auto i : Ref PName Int} -> - {auto c : Ref Ctxt Defs} -> - FC -> Name -> - List (NamedPats ns (p :: ps)) -> + {auto c : Ref Ctxt Defs} -> + FC -> Name -> + List (NamedPats ns (p :: ps)) -> Core (Either CaseError ()) -getScore fc name npss +getScore fc name npss = do catch (do sameType fc name (mkEnv fc ns) npss pure (Right ())) (\err => case err of @@ -673,10 +673,10 @@ getScore fc name npss -- same family, or all variables, or all the same type constructor. pickNext : {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> - FC -> Name -> List (NamedPats ns (p :: ps)) -> + FC -> Name -> List (NamedPats ns (p :: ps)) -> Core (Var (p :: ps)) -- last possible variable -pickNext {ps = []} fc fn npss +pickNext {ps = []} fc fn npss = if samePat npss then pure (MkVar First) else do Right () <- getScore fc fn npss @@ -699,7 +699,7 @@ shuffleVars : {idx : Nat} -> .(el : IsVar name idx todo) -> PatClause vars todo shuffleVars el (MkPatClause pvars lhs rhs) = MkPatClause pvars (moveFirst el lhs) rhs mutual - {- 'PatClause' contains a list of patterns still to process (that's the + {- 'PatClause' contains a list of patterns still to process (that's the "todo") and a right hand side with the variables we know about "vars". So "match" builds the remainder of the case tree for the unprocessed patterns. "err" is the tree for when the patterns don't @@ -708,7 +708,7 @@ mutual match : {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> - List (PatClause vars todo) -> (err : Maybe (CaseTree vars)) -> + List (PatClause vars todo) -> (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 @@ -720,14 +720,14 @@ mutual maybe (pure (Unmatched "No clauses")) pure !(mixture fc fn phase ps err) - match {todo = []} fc fn phase [] err + match {todo = []} fc fn phase [] err = maybe (pure (Unmatched "No patterns")) pure err - match {todo = []} fc fn phase ((MkPatClause pvars [] rhs) :: _) err + match {todo = []} fc fn phase ((MkPatClause pvars [] rhs) :: _) err = pure $ STerm rhs caseGroups : {auto i : Ref PName Int} -> - {auto c : Ref Ctxt Defs} -> + {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> {idx : Nat} -> .(IsVar pvar idx vars) -> Term vars -> List (Group vars todo) -> Maybe (CaseTree vars) -> @@ -737,10 +737,10 @@ mutual pure (Case _ el (resolveNames vars ty) g) where altGroups : List (Group vars todo) -> Core (List (CaseAlt vars)) - altGroups [] = maybe (pure []) - (\e => pure [DefaultCase e]) + altGroups [] = maybe (pure []) + (\e => pure [DefaultCase e]) errorCase - altGroups (ConGroup {newargs} cn tag rest :: cs) + altGroups (ConGroup {newargs} cn tag rest :: cs) = do crest <- match fc fn phase rest (map (weakenNs newargs) errorCase) cs' <- altGroups cs pure (ConCase cn tag newargs crest :: cs') @@ -754,17 +754,17 @@ mutual pure (ConstCase c crest :: cs') conRule : {auto i : Ref PName Int} -> - {auto c : Ref Ctxt Defs} -> + {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> List (PatClause vars (a :: todo)) -> - Maybe (CaseTree 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")) 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) rhs :: rest) err + conRule {a} fc fn phase cs@(MkPatClause pvars (MkInfo pat pprf fty :: pats) rhs :: rest) err = do refinedcs <- traverse (substInClause fc) cs groups <- groupCons fc fn pvars refinedcs ty <- case fty of @@ -773,19 +773,19 @@ mutual caseGroups fc fn phase pprf ty groups err varRule : {auto i : Ref PName Int} -> - {auto c : Ref Ctxt Defs} -> + {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> List (PatClause vars (a :: todo)) -> - Maybe (CaseTree vars) -> + Maybe (CaseTree vars) -> Core (CaseTree vars) - varRule {vars} {a} fc fn phase cs err + varRule {vars} {a} fc fn phase cs err = do alts' <- traverse updateVar cs match fc fn phase alts' err where updateVar : PatClause vars (a :: todo) -> Core (PatClause vars todo) -- replace the name with the relevant variable on the rhs updateVar (MkPatClause pvars (MkInfo (PLoc pfc n) prf fty :: pats) rhs) - = pure $ MkPatClause (n :: pvars) + = pure $ MkPatClause (n :: pvars) !(substInPats fc a (Local pfc (Just False) _ prf) pats) (substName n (Local pfc (Just False) _ prf) rhs) -- If it's an as pattern, replace the name with the relevant variable on @@ -797,41 +797,41 @@ mutual -- match anything, name won't appear in rhs but need to update -- LHS pattern types based on what we've learned updateVar (MkPatClause pvars (MkInfo pat prf fty :: pats) rhs) - = pure $ MkPatClause pvars + = pure $ MkPatClause pvars !(substInPats fc a (mkTerm vars pat) pats) rhs mixture : {auto i : Ref PName Int} -> {auto c : Ref Ctxt Defs} -> {ps : List (PatClause vars (a :: todo))} -> FC -> Name -> Phase -> - Partitions ps -> - Maybe (CaseTree vars) -> + Partitions ps -> + Maybe (CaseTree vars) -> Core (Maybe (CaseTree vars)) - mixture fc fn phase (ConClauses cs rest) err + mixture fc fn phase (ConClauses cs rest) err = do fallthrough <- mixture fc fn phase rest err pure (Just !(conRule fc fn phase cs fallthrough)) - mixture fc fn phase (VarClauses vs rest) err + mixture fc fn phase (VarClauses vs rest) err = do fallthrough <- mixture fc fn phase rest err pure (Just !(varRule fc fn phase vs fallthrough)) - mixture fc fn {a} {todo} phase NoClauses err + mixture fc fn {a} {todo} phase NoClauses err = pure err mkPatClause : {auto c : Ref Ctxt Defs} -> FC -> Name -> (args : List Name) -> ClosedTerm -> (List Pat, ClosedTerm) -> Core (PatClause args args) -mkPatClause fc fn args ty (ps, rhs) +mkPatClause fc fn args ty (ps, rhs) = maybe (throw (CaseCompile fc fn DifferingArgNumbers)) - (\eq => + (\eq => do defs <- get Ctxt nty <- nf defs [] ty ns <- mkNames args ps eq (Just nty) pure (MkPatClause [] ns - (rewrite sym (appendNilRightNeutral args) in + (rewrite sym (appendNilRightNeutral args) in (weakenNs args rhs)))) (checkLengthMatch args ps) where - mkNames : (vars : List Name) -> (ps : List Pat) -> + mkNames : (vars : List Name) -> (ps : List Pat) -> LengthMatch vars ps -> Maybe (NF []) -> Core (NamedPats vars vars) mkNames [] [] NilMatch fty = pure [] @@ -841,33 +841,33 @@ mkPatClause fc fn args ty (ps, rhs) fa_tys <- case fty of Nothing => pure (Nothing, Unknown) - Just (NBind pfc _ (Pi c _ farg) fsc) => + Just (NBind pfc _ (Pi c _ farg) fsc) => pure (Just !(fsc defs (toClosure defaultOpts [] (Ref pfc Bound arg))), - Known c (embed {more = arg :: args} + Known c (embed {more = arg :: args} !(quote empty [] farg))) - Just t => - pure (Nothing, - Stuck (embed {more = arg :: args} + Just t => + pure (Nothing, + Stuck (embed {more = arg :: args} !(quote empty [] t))) pure (MkInfo p First (snd fa_tys) :: weaken !(mkNames args ps eq (fst fa_tys))) export -patCompile : {auto c : Ref Ctxt Defs} -> +patCompile : {auto c : Ref Ctxt Defs} -> FC -> Name -> Phase -> - ClosedTerm -> List (List Pat, ClosedTerm) -> + ClosedTerm -> List (List Pat, ClosedTerm) -> Maybe (CaseTree []) -> Core (args ** CaseTree args) -patCompile fc fn phase ty [] def +patCompile fc fn phase ty [] def = maybe (pure ([] ** Unmatched "No definition")) (\e => pure ([] ** e)) def -patCompile fc fn phase ty (p :: ps) def +patCompile fc fn phase ty (p :: ps) def = do let ns = getNames 0 (fst p) pats <- traverse (mkPatClause fc fn ns ty) (p :: ps) log 5 $ "Pattern clauses " ++ show pats i <- newRef PName (the Int 0) - cases <- match fc fn phase pats + cases <- match fc fn phase pats (rewrite sym (appendNilRightNeutral ns) in map (weakenNs ns) def) pure (_ ** cases) @@ -898,7 +898,7 @@ simpleCase : {auto c : Ref Ctxt Defs} -> FC -> Phase -> Name -> ClosedTerm -> (def : Maybe (CaseTree [])) -> (clauses : List (ClosedTerm, ClosedTerm)) -> Core (args ** CaseTree args) -simpleCase fc phase fn ty def clauses +simpleCase fc phase fn ty def clauses = do log 5 $ "Compiling clauses " ++ show clauses ps <- traverse (toPatClause fc fn) clauses defs <- get Ctxt @@ -906,7 +906,7 @@ simpleCase fc phase fn ty def clauses export getPMDef : {auto c : Ref Ctxt Defs} -> - FC -> Phase -> Name -> ClosedTerm -> List Clause -> + FC -> Phase -> Name -> ClosedTerm -> List Clause -> Core (args ** CaseTree args) -- If there's no clauses, make a definition with the right number of arguments -- for the type, which we can use in coverage checking to ensure that one of @@ -928,15 +928,15 @@ getPMDef fc phase fn ty clauses where mkSubstEnv : Int -> Env Term vars -> SubstEnv vars [] mkSubstEnv i [] = Nil - mkSubstEnv i (v :: vs) + mkSubstEnv i (v :: vs) = Ref fc Bound (MN "pat" i) :: mkSubstEnv (i + 1) vs close : Env Term vars -> Term vars -> ClosedTerm - close {vars} env tm - = substs (mkSubstEnv 0 env) + close {vars} env tm + = substs (mkSubstEnv 0 env) (rewrite appendNilRightNeutral vars in tm) toClosed : Defs -> Clause -> (ClosedTerm, ClosedTerm) - toClosed defs (MkClause env lhs rhs) + toClosed defs (MkClause env lhs rhs) = (close env lhs, close env rhs) diff --git a/src/Core/CaseTree.idr b/src/Core/CaseTree.idr index 7b413c3..bfded20 100644 --- a/src/Core/CaseTree.idr +++ b/src/Core/CaseTree.idr @@ -9,7 +9,7 @@ mutual public export data CaseTree : List Name -> Type where Case : {name : _} -> - (idx : Nat) -> + (idx : Nat) -> IsVar name idx vars -> (scTy : Term vars) -> List (CaseAlt vars) -> CaseTree vars @@ -21,7 +21,7 @@ mutual data CaseAlt : List Name -> Type where ConCase : Name -> (tag : Int) -> (args : List Name) -> CaseTree (args ++ vars) -> CaseAlt vars - DelayCase : (ty : Name) -> (arg : Name) -> + DelayCase : (ty : Name) -> (arg : Name) -> CaseTree (ty :: arg :: vars) -> CaseAlt vars ConstCase : Constant -> CaseTree vars -> CaseAlt vars DefaultCase : CaseTree vars -> CaseAlt vars @@ -75,7 +75,7 @@ Show Pat where mutual insertCaseNames : (ns : List Name) -> CaseTree (outer ++ inner) -> CaseTree (outer ++ (ns ++ inner)) - insertCaseNames {inner} {outer} ns (Case idx prf scTy alts) + insertCaseNames {inner} {outer} ns (Case idx prf scTy alts) = let MkVar prf' = insertVarNames {outer} {inner} {ns} _ prf in Case _ prf' (insertNames {outer} ns scTy) (map (insertCaseAltNames {outer} {inner} ns) alts) @@ -83,26 +83,26 @@ mutual insertCaseNames ns (Unmatched msg) = Unmatched msg insertCaseNames ns Impossible = Impossible - insertCaseAltNames : (ns : List Name) -> - CaseAlt (outer ++ inner) -> + insertCaseAltNames : (ns : List Name) -> + CaseAlt (outer ++ inner) -> CaseAlt (outer ++ (ns ++ inner)) - insertCaseAltNames {outer} {inner} ns (ConCase x tag args ct) - = ConCase x tag args + insertCaseAltNames {outer} {inner} ns (ConCase x tag args ct) + = ConCase x tag args (rewrite appendAssociative args outer (ns ++ inner) in insertCaseNames {outer = args ++ outer} {inner} ns (rewrite sym (appendAssociative args outer inner) in ct)) insertCaseAltNames {outer} {inner} ns (DelayCase tyn valn ct) - = DelayCase tyn valn + = DelayCase tyn valn (insertCaseNames {outer = tyn :: valn :: outer} {inner} ns ct) - insertCaseAltNames ns (ConstCase x ct) + insertCaseAltNames ns (ConstCase x ct) = ConstCase x (insertCaseNames ns ct) - insertCaseAltNames ns (DefaultCase ct) + insertCaseAltNames ns (DefaultCase ct) = DefaultCase (insertCaseNames ns ct) - + export thinTree : (n : Name) -> CaseTree (outer ++ inner) -> CaseTree (outer ++ n :: inner) -thinTree n (Case idx prf scTy alts) +thinTree n (Case idx prf scTy alts) = let MkVar prf' = insertVar {n} _ prf in Case _ prf' (thin n scTy) (map (insertCaseAltNames [n]) alts) thinTree n (STerm tm) = STerm (thin n tm) @@ -111,7 +111,7 @@ thinTree n Impossible = Impossible export Weaken CaseTree where - weakenNs ns t = insertCaseNames {outer = []} ns t + weakenNs ns t = insertCaseNames {outer = []} ns t getNames : ({vs : _} -> NameMap Bool -> Term vs -> NameMap Bool) -> NameMap Bool -> CaseTree vars -> NameMap Bool @@ -126,7 +126,7 @@ getNames add ns sc = getSet ns sc getAltSets : NameMap Bool -> List (CaseAlt vs) -> NameMap Bool getAltSets ns [] = ns - getAltSets ns (a :: as) + getAltSets ns (a :: as) = assert_total $ getAltSets (getAltSet ns a) as getSet : NameMap Bool -> CaseTree vs -> NameMap Bool @@ -155,16 +155,16 @@ mkPat' args orig (Ref fc (TyCon t a) n) = PTyCon fc n a args mkPat' args orig (Bind fc x (Pi _ _ s) t) = let t' = subst (Erased fc) t in PArrow fc x (mkPat' [] s s) (mkPat' [] t' t') -mkPat' args orig (App fc fn arg) +mkPat' args orig (App fc fn arg) = let parg = mkPat' [] arg arg in mkPat' (parg :: args) orig fn -mkPat' args orig (As fc (Ref _ Bound n) ptm) +mkPat' args orig (As fc (Ref _ Bound n) ptm) = PAs fc n (mkPat' [] ptm ptm) -mkPat' args orig (As fc _ ptm) +mkPat' args orig (As fc _ ptm) = mkPat' [] orig ptm -mkPat' args orig (TDelay fc r ty p) +mkPat' args orig (TDelay fc r ty p) = PDelay fc r (mkPat' [] orig ty) (mkPat' [] orig p) -mkPat' args orig (PrimVal fc c) +mkPat' args orig (PrimVal fc c) = if constTag c == 0 then PConst fc c else PTyCon fc (UN (show c)) 0 [] @@ -173,24 +173,24 @@ mkPat' args orig tm = PUnmatchable (getLoc orig) orig export argToPat : ClosedTerm -> Pat -argToPat tm +argToPat tm = mkPat' [] tm tm export mkTerm : (vars : List Name) -> Pat -> Term vars mkTerm vars (PAs fc x y) = mkTerm vars y -mkTerm vars (PCon fc x tag arity xs) +mkTerm vars (PCon fc x tag arity xs) = apply fc (Ref fc (DataCon tag arity) x) (map (mkTerm vars) xs) -mkTerm vars (PTyCon fc x arity xs) +mkTerm vars (PTyCon fc x arity xs) = apply fc (Ref fc (TyCon 0 arity) x) (map (mkTerm vars) xs) mkTerm vars (PConst fc c) = PrimVal fc c -mkTerm vars (PArrow fc x s t) +mkTerm vars (PArrow fc x s t) = Bind fc x (Pi RigW Explicit (mkTerm vars s)) (mkTerm (x :: vars) t) mkTerm vars (PDelay fc r ty p) = TDelay fc r (mkTerm vars ty) (mkTerm vars p) -mkTerm vars (PLoc fc n) +mkTerm vars (PLoc fc n) = case isVar n vars of Just (MkVar prf) => Local fc Nothing _ prf _ => Ref fc Bound n diff --git a/src/Core/CompileExpr.idr b/src/Core/CompileExpr.idr index 59ae978..1f9197e 100644 --- a/src/Core/CompileExpr.idr +++ b/src/Core/CompileExpr.idr @@ -74,8 +74,8 @@ data CDef : Type where -- Constructor MkCon : (tag : Int) -> (arity : Nat) -> CDef -- Foreign definition - MkForeign : (ccs : List String) -> - (fargs : List CFType) -> + MkForeign : (ccs : List String) -> + (fargs : List CFType) -> CFType -> CDef -- A function which will fail at runtime (usually due to being a hole) so needs @@ -135,15 +135,15 @@ export Show CDef where show (MkFun args exp) = show args ++ ": " ++ show exp show (MkCon tag arity) = "Constructor tag " ++ show tag ++ " arity " ++ show arity - show (MkForeign ccs args ret) - = "Foreign call " ++ show ccs ++ " " ++ + show (MkForeign ccs args ret) + = "Foreign call " ++ show ccs ++ " " ++ show args ++ " -> " ++ show ret show (MkError exp) = "Error: " ++ show exp mutual export thin : (n : Name) -> CExp (outer ++ inner) -> CExp (outer ++ n :: inner) - thin n (CLocal fc prf) + thin n (CLocal fc prf) = let MkVar var' = insertVar {n} _ prf in CLocal fc var' thin _ (CRef fc x) = CRef fc x @@ -219,15 +219,15 @@ mutual -- in the remaining set with Erased export shrinkCExp : SubVars newvars vars -> CExp vars -> CExp newvars - shrinkCExp sub (CLocal fc prf) + shrinkCExp sub (CLocal fc prf) = case subElem prf sub of Nothing => CErased fc Just (MkVar prf') => CLocal fc prf' shrinkCExp _ (CRef fc x) = CRef fc x - shrinkCExp sub (CLam fc x sc) + shrinkCExp sub (CLam fc x sc) = let sc' = shrinkCExp (KeepCons sub) sc in CLam fc x sc' - shrinkCExp sub (CLet fc x val sc) + shrinkCExp sub (CLet fc x val sc) = let sc' = shrinkCExp (KeepCons sub) sc in CLet fc x (shrinkCExp sub val) sc' shrinkCExp sub (CApp fc x xs) @@ -241,11 +241,11 @@ mutual shrinkCExp sub (CForce fc x) = CForce fc (shrinkCExp sub x) shrinkCExp sub (CDelay fc x) = CDelay fc (shrinkCExp sub x) shrinkCExp sub (CConCase fc sc xs def) - = CConCase fc (shrinkCExp sub sc) + = CConCase fc (shrinkCExp sub sc) (assert_total (map (shrinkConAlt sub) xs)) (assert_total (map (shrinkCExp sub) def)) shrinkCExp sub (CConstCase fc sc xs def) - = CConstCase fc (shrinkCExp sub sc) + = CConstCase fc (shrinkCExp sub sc) (assert_total (map (shrinkConstAlt sub) xs)) (assert_total (map (shrinkCExp sub) def)) shrinkCExp _ (CPrimVal fc x) = CPrimVal fc x diff --git a/src/Core/Context.idr b/src/Core/Context.idr index 78bfa81..f56fa56 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -739,7 +739,7 @@ initDefs pure (MkDefs gam [] ["Main"] [] defaults empty 100 empty empty empty [] [] [] 5381 [] [] [] [] [] empty empty) - + -- Reset the context, except for the options export clearCtxt : {auto c : Ref Ctxt Defs} -> @@ -1898,7 +1898,7 @@ logTimeOver nsecs str act assert_total $ -- We're not dividing by 0 do str' <- str coreLift $ putStrLn $ "TIMING " ++ str' ++ ": " ++ - show (time `div` nano) ++ "." ++ + show (time `div` nano) ++ "." ++ addZeros (unpack (show ((time `mod` nano) `div` 1000000))) ++ "s" pure res @@ -1973,7 +1973,7 @@ showTimeRecord = do coreLift $ putStr (key ++ ": ") let nano = 1000000000 assert_total $ -- We're not dividing by 0 - coreLift $ putStrLn $ show (time `div` nano) ++ "." ++ + coreLift $ putStrLn $ show (time `div` nano) ++ "." ++ addZeros (unpack (show ((time `mod` nano) `div` 1000000))) ++ "s" diff --git a/src/Core/Coverage.idr b/src/Core/Coverage.idr index ec87362..22d21ca 100644 --- a/src/Core/Coverage.idr +++ b/src/Core/Coverage.idr @@ -66,7 +66,7 @@ freeEnv fc (n :: ns) = PVar RigW Explicit (Erased fc) :: freeEnv fc ns getCons : Defs -> NF vars -> Core (List (NF [], Name, Int, Nat)) getCons defs (NTCon _ tn _ _ _) = case !(lookupDefExact tn (gamma defs)) of - Just (TCon _ _ _ _ _ cons) => + Just (TCon _ _ _ _ _ cons) => do cs' <- traverse addTy cons pure (mapMaybe id cs') _ => pure [] @@ -76,7 +76,7 @@ getCons defs (NTCon _ tn _ _ _) = do Just gdef <- lookupCtxtExact cn (gamma defs) | _ => pure Nothing case (definition gdef, type gdef) of - (DCon t arity, ty) => + (DCon t arity, ty) => pure (Just (!(nf defs [] ty), cn, t, arity)) _ => pure Nothing getCons defs _ = pure [] @@ -94,7 +94,7 @@ emptyRHS fc sc = sc mkAlt : FC -> CaseTree vars -> (Name, Int, Nat) -> CaseAlt vars mkAlt fc sc (cn, t, ar) - = ConCase cn t (map (MN "m") (take ar [0..])) + = ConCase cn t (map (MN "m") (take ar [0..])) (weakenNs _ (emptyRHS fc sc)) altMatch : CaseAlt vars -> CaseAlt vars -> Bool @@ -106,9 +106,9 @@ altMatch _ _ = False -- Given a type and a list of case alternatives, return the -- well-typed alternatives which were *not* in the list -getMissingAlts : FC -> Defs -> NF vars -> List (CaseAlt vars) -> +getMissingAlts : FC -> Defs -> NF vars -> List (CaseAlt vars) -> Core (List (CaseAlt vars)) --- If it's a primitive, there's too many to reasonably check, so require a +-- If it's a primitive, there's too many to reasonably check, so require a -- catch all getMissingAlts fc defs (NPrimVal _ c) alts = if any isDefault alts @@ -128,13 +128,13 @@ getMissingAlts fc defs (NType _) alts isDefault (DefaultCase _) = True isDefault _ = False getMissingAlts fc defs nfty alts - = do allCons <- getCons defs nfty - pure (filter (noneOf alts) + = do allCons <- getCons defs nfty + pure (filter (noneOf alts) (map (mkAlt fc (Unmatched "Coverage check") . snd) allCons)) where -- Return whether the alternative c matches none of the given cases in alts noneOf : List (CaseAlt vars) -> CaseAlt vars -> Bool - noneOf alts c = not $ any (altMatch c) alts + noneOf alts c = not $ any (altMatch c) alts -- Mapping of variable to constructor tag already matched for it KnownVars : List Name -> Type -> Type @@ -152,8 +152,8 @@ showK {a} xs = show (map aString xs) weakenNs : (args : List Name) -> KnownVars vars a -> KnownVars (args ++ vars) a weakenNs args [] = [] -weakenNs {vars} args ((MkVar p, t) :: xs) - = (insertVarNames _ {outer = []} {ns=args} {inner=vars} p, t) +weakenNs {vars} args ((MkVar p, t) :: xs) + = (insertVarNames _ {outer = []} {ns=args} {inner=vars} p, t) :: weakenNs args xs findTag : IsVar n idx vars -> KnownVars vars a -> Maybe a @@ -186,13 +186,13 @@ tagIsNot ts (DefaultCase _) = False -- Replace a default case with explicit branches for the constructors. -- This is easier than checking whether a default is needed when traversing -- the tree (just one constructor lookup up front). -replaceDefaults : FC -> Defs -> NF vars -> List (CaseAlt vars) -> +replaceDefaults : FC -> Defs -> NF vars -> List (CaseAlt vars) -> Core (List (CaseAlt vars)) -- Leave it alone if it's a primitive type though, since we need the catch -- all case there replaceDefaults fc defs (NPrimVal _ _) cs = pure cs replaceDefaults fc defs (NType _) cs = pure cs -replaceDefaults fc defs nfty cs +replaceDefaults fc defs nfty cs = do cs' <- traverse rep cs pure (dropRep (concat cs')) where @@ -226,50 +226,50 @@ buildArgs fc defs known not ps cs@(Case {name = var} idx el ty altsIn) -- the ones it can't possibly be (the 'not') because a previous case -- has matched. = do let fenv = freeEnv fc _ - nfty <- nf defs fenv ty + nfty <- nf defs fenv ty alts <- replaceDefaults fc defs nfty altsIn let alts' = alts ++ !(getMissingAlts fc defs nfty alts) let altsK = maybe alts' (\t => filter (tagIs t) alts') - (findTag el known) + (findTag el known) let altsN = maybe altsK (\ts => filter (tagIsNot ts) altsK) (findTag el not) buildArgsAlt not altsN where buildArgAlt : KnownVars vars (List Int) -> CaseAlt vars -> Core (List (List ClosedTerm)) - buildArgAlt not' (ConCase n t args sc) + buildArgAlt not' (ConCase n t args sc) = do let con = Ref fc (DataCon t (length args)) n - let ps' = map (substName var + let ps' = map (substName var (apply fc con (map (Ref fc Bound) args))) ps - buildArgs fc defs (weakenNs args ((MkVar el, t) :: known)) + buildArgs fc defs (weakenNs args ((MkVar el, t) :: known)) (weakenNs args not') ps' sc buildArgAlt not' (DelayCase t a sc) - = let ps' = map (substName var (TDelay fc LUnknown + = let ps' = map (substName var (TDelay fc LUnknown (Ref fc Bound t) (Ref fc Bound a))) ps in buildArgs fc defs (weakenNs [t,a] known) (weakenNs [t,a] not') ps' sc - buildArgAlt not' (ConstCase c sc) + buildArgAlt not' (ConstCase c sc) = do let ps' = map (substName var (PrimVal fc c)) ps buildArgs fc defs known not' ps' sc - buildArgAlt not' (DefaultCase sc) + buildArgAlt not' (DefaultCase sc) = buildArgs fc defs known not' ps sc buildArgsAlt : KnownVars vars (List Int) -> List (CaseAlt vars) -> Core (List (List ClosedTerm)) buildArgsAlt not' [] = pure [] buildArgsAlt not' (c@(ConCase _ t _ _) :: cs) - = pure $ !(buildArgAlt not' c) ++ + = pure $ !(buildArgAlt not' c) ++ !(buildArgsAlt (addNot el t not') cs) buildArgsAlt not' (c :: cs) = pure $ !(buildArgAlt not' c) ++ !(buildArgsAlt not' cs) -buildArgs fc defs known not ps (STerm vs) +buildArgs fc defs known not ps (STerm vs) = pure [] -- matched, so return nothing -buildArgs fc defs known not ps (Unmatched msg) +buildArgs fc defs known not ps (Unmatched msg) = pure [ps] -- unmatched, so return it -buildArgs fc defs known not ps Impossible +buildArgs fc defs known not ps Impossible = pure [] -- not a possible match, so return nothing -- Traverse a case tree and return pattern clauses which are not @@ -278,7 +278,7 @@ buildArgs fc defs known not ps Impossible -- checked export getMissing : {auto c : Ref Ctxt Defs} -> - FC -> Name -> CaseTree vars -> + FC -> Name -> CaseTree vars -> Core (List ClosedTerm) getMissing fc n ctree = do defs <- get Ctxt diff --git a/src/Core/Env.idr b/src/Core/Env.idr index 762c3b4..0f54582 100644 --- a/src/Core/Env.idr +++ b/src/Core/Env.idr @@ -10,7 +10,7 @@ data Env : (tm : List Name -> Type) -> List Name -> Type where export extend : (x : Name) -> Binder (tm vars) -> Env tm vars -> Env tm (x :: vars) -extend x = (::) {x} +extend x = (::) {x} export length : Env tm xs -> Nat @@ -24,7 +24,7 @@ data IsDefined : Name -> List Name -> Type where export defined : {vars : _} -> - (n : Name) -> Env Term vars -> + (n : Name) -> Env Term vars -> Maybe (IsDefined n vars) defined n [] = Nothing defined {vars = x :: xs} n (b :: env) @@ -36,19 +36,19 @@ defined {vars = x :: xs} n (b :: env) export bindEnv : FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm bindEnv loc [] tm = tm -bindEnv loc (b :: env) tm +bindEnv loc (b :: env) tm = bindEnv loc env (Bind loc _ b tm) revOnto : (xs, vs : _) -> reverseOnto xs vs = reverse vs ++ xs revOnto xs [] = Refl -revOnto xs (v :: vs) - = rewrite revOnto (v :: xs) vs in +revOnto xs (v :: vs) + = rewrite revOnto (v :: xs) vs in rewrite appendAssociative (reverse vs) [v] xs in rewrite revOnto [v] vs in Refl revNs : (vs, ns : List a) -> reverse ns ++ reverse vs = reverse (vs ++ ns) revNs [] ns = rewrite appendNilRightNeutral (reverse ns) in Refl -revNs (v :: vs) ns +revNs (v :: vs) ns = rewrite revOnto [v] vs in rewrite revOnto [v] (vs ++ ns) in rewrite sym (revNs vs ns) in @@ -59,22 +59,22 @@ revNs (v :: vs) ns -- in big environments -- Also reversing the names at the end saves significant time over concatenating -- when environments get fairly big. -getBinderUnder : Weaken tm => +getBinderUnder : Weaken tm => {idx : Nat} -> - (ns : List Name) -> - .(IsVar x idx vars) -> Env tm vars -> + (ns : List Name) -> + .(IsVar x idx vars) -> Env tm vars -> Binder (tm (reverse ns ++ vars)) -getBinderUnder {idx = Z} {vars = v :: vs} ns First (b :: env) +getBinderUnder {idx = Z} {vars = v :: vs} ns First (b :: env) = rewrite appendAssociative (reverse ns) [v] vs in rewrite revNs [v] ns in map (weakenNs (reverse (v :: ns))) b -getBinderUnder {idx = S k} {vars = v :: vs} ns (Later lp) (b :: env) +getBinderUnder {idx = S k} {vars = v :: vs} ns (Later lp) (b :: env) = rewrite appendAssociative (reverse ns) [v] vs in rewrite revNs [v] ns in getBinderUnder (v :: ns) lp env export -getBinder : Weaken tm => +getBinder : Weaken tm => {idx : Nat} -> .(IsVar x idx vars) -> Env tm vars -> Binder (tm vars) getBinder el env = getBinderUnder [] el env @@ -87,10 +87,10 @@ abstractEnvType : FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm abstractEnvType fc [] tm = tm abstractEnvType fc (Let c val ty :: env) tm = abstractEnvType fc env (Bind fc _ (Let c val ty) tm) -abstractEnvType fc (Pi c e ty :: env) tm +abstractEnvType fc (Pi c e ty :: env) tm = abstractEnvType fc env (Bind fc _ (Pi c e ty) tm) -abstractEnvType fc (b :: env) tm - = abstractEnvType fc env (Bind fc _ +abstractEnvType fc (b :: env) tm + = abstractEnvType fc env (Bind fc _ (Pi (multiplicity b) Explicit (binderType b)) tm) -- As above, for the corresponding term @@ -99,16 +99,16 @@ abstractEnv : FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm abstractEnv fc [] tm = tm abstractEnv fc (Let c val ty :: env) tm = abstractEnv fc env (Bind fc _ (Let c val ty) tm) -abstractEnv fc (b :: env) tm - = abstractEnv fc env (Bind fc _ +abstractEnv fc (b :: env) tm + = abstractEnv fc env (Bind fc _ (Lam (multiplicity b) Explicit (binderType b)) tm) -- As above, but abstract over all binders including lets export abstractFullEnvType : FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm abstractFullEnvType fc [] tm = tm -abstractFullEnvType fc (b :: env) tm - = abstractFullEnvType fc env (Bind fc _ +abstractFullEnvType fc (b :: env) tm + = abstractFullEnvType fc env (Bind fc _ (Pi (multiplicity b) Explicit (binderType b)) tm) export @@ -120,8 +120,8 @@ letToLam (b :: env) = b :: letToLam env mutual -- Quicker, if less safe, to store variables as a Nat, for quick comparison findUsed : Env Term vars -> List Nat -> Term vars -> List Nat - findUsed env used (Local fc r idx p) - = if elemBy eqNat idx used + findUsed env used (Local fc r idx p) + = if elemBy eqNat idx used then used else assert_total (findUsedInBinder env (idx :: used) (getBinder p env)) @@ -135,19 +135,19 @@ mutual findUsedArgs env u [] = u findUsedArgs env u (a :: as) = findUsedArgs env (findUsed env u a) as - findUsed env used (Bind fc x b tm) + findUsed env used (Bind fc x b tm) = assert_total $ dropS (findUsed (b :: env) (map S (findUsedInBinder env used b)) tm) - where + where dropS : List Nat -> List Nat dropS [] = [] dropS (Z :: xs) = dropS xs dropS (S p :: xs) = p :: dropS xs - findUsed env used (App fc fn arg) + findUsed env used (App fc fn arg) = findUsed env (findUsed env used fn) arg - findUsed env used (As fc a p) + findUsed env used (As fc a p) = findUsed env (findUsed env used a) p findUsed env used (TDelayed fc r tm) = findUsed env used tm @@ -156,10 +156,10 @@ mutual findUsed env used (TForce fc tm) = findUsed env used tm findUsed env used _ = used - + findUsedInBinder : Env Term vars -> List Nat -> Binder (Term vars) -> List Nat - findUsedInBinder env used (Let _ val ty) + findUsedInBinder env used (Let _ val ty) = findUsed env (findUsed env used val) ty findUsedInBinder env used (PLet _ val ty) = findUsed env (findUsed env used val) ty @@ -168,32 +168,32 @@ mutual toVar : (vars : List Name) -> Nat -> Maybe (Var vars) toVar (v :: vs) Z = Just (MkVar First) toVar (v :: vs) (S k) - = do MkVar prf <- toVar vs k + = do MkVar prf <- toVar vs k Just (MkVar (Later prf)) toVar _ _ = Nothing export findUsedLocs : Env Term vars -> Term vars -> List (Var vars) -findUsedLocs env tm +findUsedLocs env tm = mapMaybe (toVar _) (findUsed env [] tm) isUsed : Nat -> List (Var vars) -> Bool isUsed n [] = False isUsed n (v :: vs) = n == varIdx v || isUsed n vs -mkShrinkSub : (vars : _) -> List (Var (n :: vars)) -> +mkShrinkSub : (vars : _) -> List (Var (n :: vars)) -> (newvars ** SubVars newvars (n :: vars)) -mkShrinkSub [] els +mkShrinkSub [] els = if isUsed 0 els then (_ ** KeepCons SubRefl) else (_ ** DropCons SubRefl) -mkShrinkSub (x :: xs) els +mkShrinkSub (x :: xs) els = let (_ ** subRest) = mkShrinkSub xs (dropFirst els) in if isUsed 0 els then (_ ** KeepCons subRest) else (_ ** DropCons subRest) -mkShrink : List (Var vars) -> +mkShrink : List (Var vars) -> (newvars ** SubVars newvars vars) mkShrink {vars = []} xs = (_ ** SubRefl) mkShrink {vars = v :: vs} xs = mkShrinkSub _ xs @@ -201,7 +201,7 @@ mkShrink {vars = v :: vs} xs = mkShrinkSub _ xs -- Find the smallest subset of the environment which is needed to type check -- the given term export -findSubEnv : Env Term vars -> Term vars -> +findSubEnv : Env Term vars -> Term vars -> (vars' : List Name ** SubVars vars' vars) findSubEnv env tm = mkShrink (findUsedLocs env tm) @@ -209,7 +209,7 @@ export shrinkEnv : Env Term vars -> SubVars newvars vars -> Maybe (Env Term newvars) shrinkEnv env SubRefl = Just env shrinkEnv (b :: env) (DropCons p) = shrinkEnv env p -shrinkEnv (b :: env) (KeepCons p) +shrinkEnv (b :: env) (KeepCons p) = do env' <- shrinkEnv env p b' <- shrinkBinder b p pure (b' :: env') diff --git a/src/Core/FC.idr b/src/Core/FC.idr index e8d6547..5d85c6b 100644 --- a/src/Core/FC.idr +++ b/src/Core/FC.idr @@ -14,7 +14,7 @@ FileName = String public export data FC = MkFC FileName FilePos FilePos | EmptyFC - + export file : FC -> FileName file (MkFC fn _ _) = fn @@ -38,7 +38,7 @@ within (x, y) (MkFC _ start end) = (x, y) >= start && (x, y) <= end within _ _ = False --- Return whether a given line is on the same line as the file context (assuming +-- Return whether a given line is on the same line as the file context (assuming -- we're in the right file) export onLine : Int -> FC -> Bool @@ -58,8 +58,8 @@ toplevelFC = MkFC "(toplevel)" (0, 0) (0, 0) export Show FC where - show loc = file loc ++ ":" ++ - showPos (startPos loc) ++ "--" ++ + show loc = file loc ++ ":" ++ + showPos (startPos loc) ++ "--" ++ showPos (endPos loc) diff --git a/src/Core/GetType.idr b/src/Core/GetType.idr index 757c832..d1945e8 100644 --- a/src/Core/GetType.idr +++ b/src/Core/GetType.idr @@ -11,7 +11,7 @@ import Core.Value -- Get the type of an already typechecked thing. -- We need this (occasionally) because we don't store types in subterms (e.g. on --- applications) and we don't keep the type of suterms up to date throughout +-- applications) and we don't keep the type of suterms up to date throughout -- unification. Perhaps we should? There's a trade off here, and recalculating on -- the rare occasions it's necessary doesn't seem to cost too much, but keep an -- eye on it... @@ -19,26 +19,26 @@ import Core.Value mutual chk : {auto c : Ref Ctxt Defs} -> Env Term vars -> Term vars -> Core (Glued vars) - chk env (Local fc r idx p) + chk env (Local fc r idx p) = pure $ gnf env (binderType (getBinder p env)) chk env (Ref fc nt n) = do defs <- get Ctxt Just ty <- lookupTyExact n (gamma defs) | Nothing => throw (UndefinedName fc n) pure $ gnf env (embed ty) - chk env (Meta fc n i args) + chk env (Meta fc n i args) = do defs <- get Ctxt Just mty <- lookupTyExact (Resolved i) (gamma defs) | Nothing => throw (UndefinedName fc n) chkMeta fc env !(nf defs env (embed mty)) args - chk env (Bind fc nm b sc) + chk env (Bind fc nm b sc) = do bt <- chkBinder env b sct <- chk {vars = nm :: _} (b :: env) sc pure $ gnf env (discharge fc nm b !(getTerm bt) !(getTerm sct)) - chk env (App fc f a) + chk env (App fc f a) = do fty <- chk env f case !(getNF fty) of - NBind _ _ (Pi _ _ ty) scdone => + NBind _ _ (Pi _ _ ty) scdone => do defs <- get Ctxt aty <- chk env a sc' <- scdone defs (toClosure defaultOpts env a) @@ -47,15 +47,15 @@ mutual throw (NotFunctionType fc env fty') chk env (As fc n p) = chk env p chk env (TDelayed fc r tm) = pure (gType fc) - chk env (TDelay fc r dty tm) + chk env (TDelay fc r dty tm) = do gtm <- chk env tm tm' <- getNF gtm defs <- get Ctxt pure $ glueBack defs env (NDelayed fc r tm') - chk env (TForce fc tm) + chk env (TForce fc tm) = do tm' <- chk env tm case !(getNF tm') of - NDelayed fc r fty => + NDelayed fc r fty => do defs <- get Ctxt pure $ glueBack defs env fty chk env (PrimVal fc x) = pure $ gnf env (chkConstant fc x) @@ -65,7 +65,7 @@ mutual chkMeta : {auto c : Ref Ctxt Defs} -> FC -> Env Term vars -> NF vars -> List (Term vars) -> Core (Glued vars) - chkMeta fc env ty [] + chkMeta fc env ty [] = do defs <- get Ctxt pure $ glueBack defs env ty chkMeta fc env (NBind _ _ (Pi _ _ ty) scdone) (a :: args) @@ -88,9 +88,9 @@ mutual = Bind fc n (Pi c x ty) scopety discharge fc n (Let c val ty) bindty scopety = Bind fc n (Let c val ty) scopety - discharge fc n (Pi c x ty) bindty scopety + discharge fc n (Pi c x ty) bindty scopety = bindty - discharge fc n (PVar c p ty) bindty scopety + discharge fc n (PVar c p ty) bindty scopety = Bind fc n (PVTy c ty) scopety discharge fc n (PLet c val ty) bindty scopety = Bind fc n (PLet c val ty) scopety diff --git a/src/Core/Hash.idr b/src/Core/Hash.idr index ed6529a..51a8f18 100644 --- a/src/Core/Hash.idr +++ b/src/Core/Hash.idr @@ -15,7 +15,7 @@ public export interface Hashable a where hash : a -> Int hashWithSalt : Int -> a -> Int - + hash = hashWithSalt 5381 hashWithSalt h i = h * 33 + hash i @@ -54,9 +54,9 @@ Hashable String where hashChars : Int -> Int -> Int -> String -> Int hashChars h p len str = assert_total $ - if p == len + if p == len then h - else hashChars (h * 33 + cast (strIndex str p)) + else hashChars (h * 33 + cast (strIndex str p)) (p + 1) len str export @@ -79,7 +79,7 @@ Hashable PiInfo where export Hashable ty => Hashable (Binder ty) where - hashWithSalt h (Lam c p ty) + hashWithSalt h (Lam c p ty) = h `hashWithSalt` 0 `hashWithSalt` c `hashWithSalt` p `hashWithSalt` ty hashWithSalt h (Let c val ty) = h `hashWithSalt` 1 `hashWithSalt` c `hashWithSalt` val `hashWithSalt` ty @@ -98,72 +98,72 @@ Hashable (Var vars) where mutual export Hashable (Term vars) where - hashWithSalt h (Local fc x idx y) + hashWithSalt h (Local fc x idx y) = h `hashWithSalt` 0 `hashWithSalt` idx - hashWithSalt h (Ref fc x name) + hashWithSalt h (Ref fc x name) = h `hashWithSalt` 1 `hashWithSalt` name - hashWithSalt h (Meta fc x y xs) + hashWithSalt h (Meta fc x y xs) = h `hashWithSalt` 2 `hashWithSalt` y `hashWithSalt` xs - hashWithSalt h (Bind fc x b scope) + hashWithSalt h (Bind fc x b scope) = h `hashWithSalt` 3 `hashWithSalt` b `hashWithSalt` scope - hashWithSalt h (App fc fn arg) + hashWithSalt h (App fc fn arg) = h `hashWithSalt` 4 `hashWithSalt` fn `hashWithSalt` arg hashWithSalt h (As fc nm pat) = h `hashWithSalt` 5 `hashWithSalt` nm `hashWithSalt` pat - hashWithSalt h (TDelayed fc x y) + hashWithSalt h (TDelayed fc x y) = h `hashWithSalt` 6 `hashWithSalt` y hashWithSalt h (TDelay fc x t y) = h `hashWithSalt` 7 `hashWithSalt` t `hashWithSalt` y hashWithSalt h (TForce fc x) = h `hashWithSalt` 8 `hashWithSalt` x - hashWithSalt h (PrimVal fc c) + hashWithSalt h (PrimVal fc c) = h `hashWithSalt` 9 `hashWithSalt` (show c) - hashWithSalt h (Erased fc) + hashWithSalt h (Erased fc) = hashWithSalt h 10 hashWithSalt h (TType fc) = hashWithSalt h 11 export Hashable Pat where - hashWithSalt h (PAs fc nm pat) + hashWithSalt h (PAs fc nm pat) = h `hashWithSalt` 0 `hashWithSalt` nm `hashWithSalt` pat - hashWithSalt h (PCon fc x tag arity xs) + hashWithSalt h (PCon fc x tag arity xs) = h `hashWithSalt` 1 `hashWithSalt` x `hashWithSalt` xs - hashWithSalt h (PTyCon fc x arity xs) + hashWithSalt h (PTyCon fc x arity xs) = h `hashWithSalt` 2 `hashWithSalt` x `hashWithSalt` xs - hashWithSalt h (PConst fc c) + hashWithSalt h (PConst fc c) = h `hashWithSalt` 3 `hashWithSalt` (show c) - hashWithSalt h (PArrow fc x s t) + hashWithSalt h (PArrow fc x s t) = h `hashWithSalt` 4 `hashWithSalt` s `hashWithSalt` t hashWithSalt h (PDelay fc r t p) = h `hashWithSalt` 5 `hashWithSalt` t `hashWithSalt` p - hashWithSalt h (PLoc fc x) + hashWithSalt h (PLoc fc x) = h `hashWithSalt` 6 `hashWithSalt` x - hashWithSalt h (PUnmatchable fc x) + hashWithSalt h (PUnmatchable fc x) = h `hashWithSalt` 7 `hashWithSalt` x export Hashable (CaseTree vars) where - hashWithSalt h (Case idx x scTy xs) + hashWithSalt h (Case idx x scTy xs) = h `hashWithSalt` 0 `hashWithSalt` idx `hashWithSalt` xs - hashWithSalt h (STerm x) + hashWithSalt h (STerm x) = h `hashWithSalt` 1 `hashWithSalt` x - hashWithSalt h (Unmatched msg) + hashWithSalt h (Unmatched msg) = h `hashWithSalt` 2 hashWithSalt h Impossible = h `hashWithSalt` 3 export Hashable (CaseAlt vars) where - hashWithSalt h (ConCase x tag args y) + hashWithSalt h (ConCase x tag args y) = h `hashWithSalt` 0 `hashWithSalt` x `hashWithSalt` args `hashWithSalt` y - hashWithSalt h (DelayCase t x y) - = h `hashWithSalt` 2 `hashWithSalt` (show t) + hashWithSalt h (DelayCase t x y) + = h `hashWithSalt` 2 `hashWithSalt` (show t) `hashWithSalt` (show x) `hashWithSalt` y - hashWithSalt h (ConstCase x y) + hashWithSalt h (ConstCase x y) = h `hashWithSalt` 3 `hashWithSalt` (show x) `hashWithSalt` y - hashWithSalt h (DefaultCase x) + hashWithSalt h (DefaultCase x) = h `hashWithSalt` 4 `hashWithSalt` x diff --git a/src/Core/InitPrimitives.idr b/src/Core/InitPrimitives.idr index cdcd1a4..1864fd8 100644 --- a/src/Core/InitPrimitives.idr +++ b/src/Core/InitPrimitives.idr @@ -10,11 +10,11 @@ import Core.TT addPrim : {auto c : Ref Ctxt Defs} -> Prim -> Core () -addPrim p +addPrim p = do addBuiltin (opName (fn p)) (type p) (totality p) (fn p) -- compileDef empty (opName (fn p)) export addPrimitives : {auto c : Ref Ctxt Defs} -> Core () -addPrimitives +addPrimitives = traverse_ addPrim allPrimitives diff --git a/src/Core/LinearCheck.idr b/src/Core/LinearCheck.idr index 6f09525..29c3eba 100644 --- a/src/Core/LinearCheck.idr +++ b/src/Core/LinearCheck.idr @@ -37,7 +37,7 @@ doneScope (MkVar (Later p) :: xs) = MkVar p :: doneScope xs count : Nat -> Usage ns -> Nat count p [] = 0 -count p (v :: xs) +count p (v :: xs) = if p == varIdx v then 1 + count p xs else count p xs localPrf : {later : _} -> Var (later ++ n :: vars) @@ -50,7 +50,7 @@ mutual updateHoleUsageArgs : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> (useInHole : Bool) -> - Var vars -> List (Term vars) -> Core Bool + Var vars -> List (Term vars) -> Core Bool updateHoleUsageArgs useInHole var [] = pure False updateHoleUsageArgs useInHole var (a :: as) = do h <- updateHoleUsage useInHole var a @@ -79,10 +79,10 @@ mutual = do updateHoleUsage False var a scty <- updateHoleType useInHole var sc as pure (Bind bfc nm (Pi c e ty) scty) - updateHoleType useInHole var ty as + updateHoleType useInHole var ty as = do updateHoleUsageArgs False var as pure ty - + updateHoleUsagePats : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> (useInHole : Bool) -> @@ -111,11 +111,11 @@ mutual findLocal (Local _ _ _ p :: _) Z = Just (MkVar p) findLocal (_ :: els) (S k) = findLocal els k findLocal _ _ = Nothing - + updateHoleUsage : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> (useInHole : Bool) -> - Var vars -> Term vars -> Core Bool + Var vars -> Term vars -> Core Bool updateHoleUsage useInHole (MkVar var) (Bind _ n (Let c val ty) sc) = do h <- updateHoleUsage useInHole (MkVar var) val h' <- updateHoleUsage useInHole (MkVar (Later var)) sc @@ -133,23 +133,23 @@ mutual ty' <- updateHoleType useInHole var ty args updateTy i ty' pure True - _ => updateHoleUsageArgs useInHole var args + _ => updateHoleUsageArgs useInHole var args updateHoleUsage useInHole var (As _ a p) = do h <- updateHoleUsage useInHole var a h' <- updateHoleUsage useInHole var a pure (h || h') - updateHoleUsage useInHole var (TDelayed _ _ t) + updateHoleUsage useInHole var (TDelayed _ _ t) = updateHoleUsage useInHole var t - updateHoleUsage useInHole var (TDelay _ _ _ t) + updateHoleUsage useInHole var (TDelay _ _ _ t) = updateHoleUsage useInHole var t - updateHoleUsage useInHole var (TForce _ t) + updateHoleUsage useInHole var (TForce _ t) = updateHoleUsage useInHole var t - updateHoleUsage useInHole var tm + updateHoleUsage useInHole var tm = case getFnArgs tm of - (Ref _ _ fn, args) => + (Ref _ _ fn, args) => do aup <- updateHoleUsageArgs useInHole var args defs <- get Ctxt - Just (NS _ (CaseBlock _ _), PMDef _ _ _ _ pats) <- + Just (NS _ (CaseBlock _ _), PMDef _ _ _ _ pats) <- lookupExactBy (\d => (fullname d, definition d)) fn (gamma defs) | _ => pure aup @@ -166,10 +166,10 @@ mutual lcheck : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState } -> - RigCount -> (erase : Bool) -> Env Term vars -> Term vars -> + RigCount -> (erase : Bool) -> Env Term vars -> Term vars -> Core (Term vars, Glued vars, Usage vars) - lcheck {vars} rig erase env (Local {name} fc x idx prf) - = let b = getBinder prf env + lcheck {vars} rig erase env (Local {name} fc x idx prf) + = let b = getBinder prf env rigb = multiplicity b ty = binderType b in do when (not erase) $ rigSafe rigb rig @@ -237,8 +237,8 @@ mutual -- if there's a hole, assume it will contain the missing usage -- if there is none already let used = case rigMult (multiplicity b) rig of - Rig1 => if holeFound && used_in == 0 - then 1 + Rig1 => if holeFound && used_in == 0 + then 1 else used_in _ => used_in @@ -256,11 +256,11 @@ mutual checkUsageOK used Rig0 = pure () checkUsageOK used RigW = pure () checkUsageOK used Rig1 - = if used == 1 + = if used == 1 then pure () else throw (LinearUsed fc used nm) - lcheck rig erase env (App fc f a) + lcheck rig erase env (App fc f a) = do (f', gfty, fused) <- lcheck rig erase env f defs <- get Ctxt fty <- getNF gfty @@ -285,27 +285,27 @@ mutual when (not !(convert defs env aty ty)) $ do ty' <- quote defs env ty aty' <- quote defs env aty - throw (CantConvert fc env ty' aty') - pure (App fc f' aerased, - glueBack defs env sc', + throw (CantConvert fc env ty' aty') + pure (App fc f' aerased, + glueBack defs env sc', fused ++ aused) _ => do tfty <- getTerm gfty - throw (GenericMsg fc ("Linearity checking failed on " ++ show f' ++ + throw (GenericMsg fc ("Linearity checking failed on " ++ show f' ++ " (" ++ show tfty ++ " not a function type)")) - lcheck rig erase env (As fc as pat) + lcheck rig erase env (As fc as pat) = do (as', _, _) <- lcheck rig erase env as (pat', pty, u) <- lcheck rig erase env pat pure (As fc as' pat', pty, u) - lcheck rig erase env (TDelayed fc r ty) + lcheck rig erase env (TDelayed fc r ty) = do (ty', _, u) <- lcheck rig erase env ty pure (TDelayed fc r ty', gType fc, u) - lcheck rig erase env (TDelay fc r ty val) + lcheck rig erase env (TDelay fc r ty val) = do (ty', _, _) <- lcheck Rig0 erase env ty (val', gty, u) <- lcheck rig erase env val ty <- getTerm gty pure (TDelay fc r ty' val', gnf env (TDelayed fc r ty), u) - lcheck rig erase env (TForce fc val) + lcheck rig erase env (TForce fc val) = do (val', gty, u) <- lcheck rig erase env val tynf <- getNF gty case tynf of @@ -313,17 +313,17 @@ mutual => do defs <- get Ctxt pure (TForce fc val', glueBack defs env narg, u) _ => throw (GenericMsg fc "Not a delayed tyoe") - lcheck rig erase env (PrimVal fc c) + lcheck rig erase env (PrimVal fc c) = pure (PrimVal fc c, gErased fc, []) - lcheck rig erase env (Erased fc) + lcheck rig erase env (Erased fc) = pure (Erased fc, gErased fc, []) - lcheck rig erase env (TType fc) + lcheck rig erase env (TType fc) = pure (TType fc, gType fc, []) lcheckBinder : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - RigCount -> (erase : Bool) -> Env Term vars -> - Binder (Term vars) -> + RigCount -> (erase : Bool) -> Env Term vars -> + Binder (Term vars) -> Core (Binder (Term vars), Glued vars, Usage vars) lcheckBinder rig erase env (Lam c x ty) = do (tyv, tyt, _) <- lcheck Rig0 erase env ty @@ -352,7 +352,7 @@ mutual Core (Term vars, Glued vars, Usage vars) discharge defs env fc nm (Lam c x ty) gbindty scope gscopety used = do scty <- getTerm gscopety - pure (Bind fc nm (Lam c x ty) scope, + pure (Bind fc nm (Lam c x ty) scope, gnf env (Bind fc nm (Pi c x ty) scty), used) discharge defs env fc nm (Let c val ty) gbindty scope gscopety used = do scty <- getTerm gscopety @@ -371,7 +371,7 @@ mutual discharge defs env fc nm (PVTy c ty) gbindty scope gscopety used = pure (Bind fc nm (PVTy c ty) scope, gbindty, used) - data ArgUsage + data ArgUsage = UseAny -- RigW so we don't care | Use0 -- argument position not used | Use1 -- argument position used exactly once @@ -397,7 +397,7 @@ mutual = do us <- traverse (getPUsage ty) pats pure (map snd !(combine us)) where - getCaseUsage : Term ns -> Env Term vs -> List (Term vs) -> + getCaseUsage : Term ns -> Env Term vs -> List (Term vs) -> Usage vs -> Term vs -> Core (List (Name, ArgUsage)) getCaseUsage ty env (As _ _ p :: args) used rhs @@ -420,7 +420,7 @@ mutual Rig1 => pure ((n, UseKeep) :: rest) _ => pure ((n, UseKeep) :: rest) getCaseUsage tm env args used rhs = pure [] - + checkUsageOK : FC -> Nat -> Name -> Bool -> RigCount -> Core () checkUsageOK fc used nm isloc Rig0 = pure () checkUsageOK fc used nm isloc RigW = pure () @@ -429,7 +429,7 @@ mutual then throw (LinearUsed fc used nm) else pure () checkUsageOK fc used nm isloc Rig1 - = if used == 1 + = if used == 1 then pure () else throw (LinearUsed fc used nm) @@ -441,15 +441,15 @@ mutual = if idx == varIdx p then True else isLocArg p args - isLocArg p (As _ tm pat :: args) + isLocArg p (As _ tm pat :: args) = isLocArg p (tm :: pat :: args) isLocArg p (_ :: args) = isLocArg p args -- As checkEnvUsage in general, but it's okay for local variables to -- remain unused (since in that case, they must be used outside the -- case block) - checkEnvUsage : RigCount -> - Env Term vars -> Usage (done ++ vars) -> + checkEnvUsage : RigCount -> + Env Term vars -> Usage (done ++ vars) -> List (Term (done ++ vars)) -> Term (done ++ vars) -> Core () checkEnvUsage rig [] usage args tm = pure () @@ -461,14 +461,14 @@ mutual then updateHoleUsage (used_in == 0) pos tm else pure False let used = case rigMult (multiplicity b) rig of - Rig1 => if holeFound && used_in == 0 - then 1 + Rig1 => if holeFound && used_in == 0 + then 1 else used_in _ => used_in checkUsageOK (getLoc (binderType b)) - used nm (isLocArg pos args) + used nm (isLocArg pos args) (rigMult (multiplicity b) rig) - checkEnvUsage {done = done ++ [nm]} rig env + checkEnvUsage {done = done ++ [nm]} rig env (rewrite sym (appendAssociative done [nm] xs) in usage) (rewrite sym (appendAssociative done [nm] xs) in args) (rewrite sym (appendAssociative done [nm] xs) in tm) @@ -487,7 +487,7 @@ mutual log 10 $ "Arg usage: " ++ show ause pure ause - combineUsage : (Name, ArgUsage) -> (Name, ArgUsage) -> + combineUsage : (Name, ArgUsage) -> (Name, ArgUsage) -> Core (Name, ArgUsage) combineUsage (n, Use0) (_, Use1) = throw (GenericMsg topfc ("Inconsistent usage of " ++ show n ++ " in case branches")) @@ -510,7 +510,7 @@ mutual pure (u' :: us') combineUsages _ _ = throw (InternalError "Argument usage lists inconsistent") - combine : List (List (Name, ArgUsage)) -> + combine : List (List (Name, ArgUsage)) -> Core (List (Name, ArgUsage)) combine [] = pure [] combine [x] = pure x @@ -520,7 +520,7 @@ mutual lcheckDef : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - RigCount -> (erase : Bool) -> Env Term vars -> Name -> + RigCount -> (erase : Bool) -> Env Term vars -> Name -> Core ClosedTerm lcheckDef rig True env n = do defs <- get Ctxt @@ -533,17 +533,17 @@ mutual | Nothing => throw (InternalError ("Linearity checking failed on " ++ show n)) Just def <- lookupCtxtExact (Resolved idx) (gamma defs) | Nothing => throw (InternalError ("Linearity checking failed on " ++ show n)) - if linearChecked def + if linearChecked def then pure (type def) else do case definition def of - PMDef _ _ _ _ pats => + PMDef _ _ _ _ pats => do u <- getArgUsage (getLoc (type def)) rig (type def) pats log 10 $ "Overall arg usage " ++ show u let ty' = updateUsage u (type def) updateTy idx ty' setLinearCheck idx True - logTerm 5 ("New type of " ++ + logTerm 5 ("New type of " ++ show (fullname def)) ty' pure ty' _ => pure (type def) @@ -559,10 +559,10 @@ mutual UseAny => c in -- no constraint, so leave alone Bind bfc n (Pi c' e ty) sc' updateUsage _ ty = ty - + expandMeta : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - RigCount -> (erase : Bool) -> Env Term vars -> + 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 @@ -581,28 +581,28 @@ mutual lcheckMeta : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> RigCount -> Bool -> Env Term vars -> - FC -> Name -> Int -> + FC -> Name -> Int -> (args : List (Term vars)) -> (checked : List (Term vars)) -> NF vars -> Core (Term vars, Glued vars, Usage vars) - lcheckMeta rig erase env fc n idx + lcheckMeta rig erase env fc n idx (arg :: args) chk (NBind _ _ (Pi rigf _ ty) sc) = do let checkRig = rigMult rigf rig (arg', gargTy, aused) <- lcheck checkRig erase env arg defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts env arg') let aerased = if erase && rigf == Rig0 then Erased fc else arg' - (tm, gty, u) <- lcheckMeta rig erase env fc n idx args + (tm, gty, u) <- lcheckMeta rig erase env fc n idx args (aerased :: chk) sc' pure (tm, gty, aused ++ u) lcheckMeta rig erase env fc n idx (arg :: args) chk nty = do defs <- get Ctxt empty <- clearDefs defs ty <- quote empty env nty - throw (GenericMsg fc ("Linearity checking failed on metavar - " ++ show n ++ " (" ++ show ty ++ + throw (GenericMsg fc ("Linearity checking failed on metavar + " ++ show n ++ " (" ++ show ty ++ " not a function type)")) - lcheckMeta rig erase env fc n idx [] chk nty + lcheckMeta rig erase env fc n idx [] chk nty = do defs <- get Ctxt pure (Meta fc n idx (reverse chk), glueBack defs env nty, []) @@ -610,9 +610,9 @@ mutual checkEnvUsage : {done : _} -> {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> RigCount -> - Env Term vars -> Usage (done ++ vars) -> - Term (done ++ vars) -> + FC -> RigCount -> + Env Term vars -> Usage (done ++ vars) -> + Term (done ++ vars) -> Core () checkEnvUsage fc rig [] usage tm = pure () checkEnvUsage fc rig {done} {vars = nm :: xs} (b :: env) usage tm @@ -623,12 +623,12 @@ checkEnvUsage fc rig {done} {vars = nm :: xs} (b :: env) usage tm then updateHoleUsage (used_in == 0) pos tm else pure False let used = case rigMult (multiplicity b) rig of - Rig1 => if holeFound && used_in == 0 - then 1 + Rig1 => if holeFound && used_in == 0 + then 1 else used_in _ => used_in checkUsageOK used (rigMult (multiplicity b) rig) - checkEnvUsage {done = done ++ [nm]} fc rig env + checkEnvUsage {done = done ++ [nm]} fc rig env (rewrite sym (appendAssociative done [nm] xs) in usage) (rewrite sym (appendAssociative done [nm] xs) in tm) where @@ -636,7 +636,7 @@ checkEnvUsage fc rig {done} {vars = nm :: xs} (b :: env) usage tm checkUsageOK used Rig0 = pure () checkUsageOK used RigW = pure () checkUsageOK used Rig1 - = if used == 1 + = if used == 1 then pure () else throw (LinearUsed fc used nm) @@ -648,7 +648,7 @@ export linearCheck : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> FC -> RigCount -> (erase : Bool) -> - Env Term vars -> Term vars -> + Env Term vars -> Term vars -> Core (Term vars) linearCheck fc rig erase env tm = do logTerm 5 "Linearity check on " tm diff --git a/src/Core/Metadata.idr b/src/Core/Metadata.idr index 373cb40..4bbff42 100644 --- a/src/Core/Metadata.idr +++ b/src/Core/Metadata.idr @@ -64,8 +64,8 @@ addLHS : {auto c : Ref Ctxt Defs} -> addLHS loc outerenvlen env tm = do meta <- get MD tm' <- toFullNames (bindEnv loc (toPat env) tm) - put MD (record { - lhsApps $= ((loc, outerenvlen, tm') ::) + put MD (record { + lhsApps $= ((loc, outerenvlen, tm') ::) } meta) where toPat : Env Term vs -> Env Term vs @@ -84,7 +84,7 @@ addLHS loc outerenvlen env tm substEnv : {vars : _} -> FC -> Env Term vars -> (tm : Term vars) -> ClosedTerm substEnv loc [] tm = tm -substEnv {vars = x :: _} loc (b :: env) tm +substEnv {vars = x :: _} loc (b :: env) tm = substEnv loc env (subst (Ref loc Bound x) tm) export @@ -94,8 +94,8 @@ addNameType : {auto c : Ref Ctxt Defs} -> addNameType loc n env tm = do meta <- get MD n' <- getFullName n - put MD (record { - names $= ((loc, (n', 0, substEnv loc env tm)) ::) + put MD (record { + names $= ((loc, (n', 0, substEnv loc env tm)) ::) } meta) export @@ -105,8 +105,8 @@ addTyDecl : {auto c : Ref Ctxt Defs} -> addTyDecl loc n env tm = do meta <- get MD n' <- getFullName n - put MD (record { - tydecls $= ((loc, (n', length env, bindEnv loc env tm)) ::) + put MD (record { + tydecls $= ((loc, (n', length env, bindEnv loc env tm)) ::) } meta) export @@ -143,15 +143,15 @@ findEntryWith p ((l, x) :: xs) export findLHSAt : {auto m : Ref MD Metadata} -> - (FC -> ClosedTerm -> Bool) -> + (FC -> ClosedTerm -> Bool) -> Core (Maybe (FC, Nat, ClosedTerm)) -findLHSAt p +findLHSAt p = do meta <- get MD pure (findEntryWith (\ loc, tm => p loc (snd tm)) (lhsApps meta)) export findTypeAt : {auto m : Ref MD Metadata} -> - (FC -> (Name, Nat, ClosedTerm) -> Bool) -> + (FC -> (Name, Nat, ClosedTerm) -> Bool) -> Core (Maybe (Name, Nat, ClosedTerm)) findTypeAt p = do meta <- get MD @@ -159,7 +159,7 @@ findTypeAt p export findTyDeclAt : {auto m : Ref MD Metadata} -> - (FC -> (Name, Nat, ClosedTerm) -> Bool) -> + (FC -> (Name, Nat, ClosedTerm) -> Bool) -> Core (Maybe (FC, Name, Nat, ClosedTerm)) findTyDeclAt p = do meta <- get MD @@ -183,9 +183,9 @@ normaliseTypes ns' <- traverse (nfType defs) (names meta) put MD (record { names = ns' } meta) where - nfType : Defs -> (FC, (Name, Nat, ClosedTerm)) -> + nfType : Defs -> (FC, (Name, Nat, ClosedTerm)) -> Core (FC, (Name, Nat, ClosedTerm)) - nfType defs (loc, (n, len, ty)) + nfType defs (loc, (n, len, ty)) = pure (loc, (n, len, !(normaliseArgHoles defs [] ty))) record TTMFile where diff --git a/src/Core/Name.idr b/src/Core/Name.idr index 50cdd91..d8b4fa4 100644 --- a/src/Core/Name.idr +++ b/src/Core/Name.idr @@ -95,7 +95,7 @@ nameTag (Resolved _) = 8 export Ord Name where - compare (NS x y) (NS x' y') + compare (NS x y) (NS x' y') = case compare y y' of -- Compare base name first (more likely to differ) EQ => compare x x' -- Because of the terrible way Idris 1 compiles 'case', this @@ -103,7 +103,7 @@ Ord Name where GT => GT LT => LT compare (UN x) (UN y) = compare x y - compare (MN x y) (MN x' y') + compare (MN x y) (MN x' y') = case compare y y' of EQ => compare x x' GT => GT @@ -176,5 +176,5 @@ nameEq (WithBlock x y) (WithBlock x' y') with (decEq x x') nameEq (Resolved x) (Resolved y) with (decEq x y) nameEq (Resolved y) (Resolved y) | (Yes Refl) = Just Refl nameEq (Resolved x) (Resolved y) | (No contra) = Nothing -nameEq _ _ = Nothing +nameEq _ _ = Nothing diff --git a/src/Core/Normalise.idr b/src/Core/Normalise.idr index e4c5749..ca415c6 100644 --- a/src/Core/Normalise.idr +++ b/src/Core/Normalise.idr @@ -40,7 +40,7 @@ Stack vars = List (Closure vars) evalWithOpts : {vars : _} -> Defs -> EvalOpts -> - Env Term free -> LocalEnv free vars -> + Env Term free -> LocalEnv free vars -> Term (vars ++ free) -> Stack free -> Core (NF free) export @@ -67,11 +67,11 @@ useMeta fc n defs opts parameters (defs : Defs, topopts : EvalOpts) mutual eval : {vars : _} -> - Env Term free -> LocalEnv free vars -> + Env Term free -> LocalEnv free vars -> Term (vars ++ free) -> 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 + 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 locs False fc nt fn stk (NApp fc (NRef nt fn) stk) eval {vars} {free} env locs (Meta fc name idx args) stk = evalMeta env locs fc name idx (closeArgs args) stk @@ -88,46 +88,46 @@ parameters (defs : Defs, topopts : EvalOpts) = if holesOnly topopts || argHolesOnly topopts then do b' <- traverse (\tm => eval env locs tm []) b pure $ NBind fc x b' - (\defs', arg => evalWithOpts defs' topopts + (\defs', arg => evalWithOpts defs' topopts env (arg :: locs) scope stk) else eval env (MkClosure topopts locs env val :: locs) scope stk - eval env locs (Bind fc x b scope) stk + eval env locs (Bind fc x b scope) stk = do b' <- traverse (\tm => eval env locs tm []) b pure $ NBind fc x b' - (\defs', arg => evalWithOpts defs' topopts + (\defs', arg => evalWithOpts defs' topopts env (arg :: locs) scope stk) - eval env locs (App fc fn arg) stk + eval env locs (App fc fn arg) stk = eval env locs fn (MkClosure topopts locs env arg :: stk) - eval env locs (As fc n tm) stk + eval env locs (As fc n tm) stk = if removeAs topopts then eval env locs tm stk else do n' <- eval env locs n stk - tm' <- eval env locs tm stk + tm' <- eval env locs tm stk pure (NAs fc n' tm') - eval env locs (TDelayed fc r ty) stk + eval env locs (TDelayed fc r ty) stk = do ty' <- eval env locs ty stk pure (NDelayed fc r ty') - eval env locs (TDelay fc r ty tm) stk + eval env locs (TDelay fc r ty tm) stk = pure (NDelay fc r (MkClosure topopts locs env ty) (MkClosure topopts locs env tm)) - eval env locs (TForce fc tm) stk + eval env locs (TForce fc tm) stk = do tm' <- eval env locs tm [] case tm' of - NDelay fc r _ arg => + NDelay fc r _ arg => eval env (arg :: locs) (Local {name = UN "fvar"} fc Nothing _ First) stk _ => pure (NForce fc tm' stk) eval env locs (PrimVal fc c) stk = pure $ NPrimVal fc c eval env locs (Erased fc) stk = pure $ NErased fc eval env locs (TType fc) stk = pure $ NType fc - + evalLocal : {vars : _} -> - Env Term free -> - FC -> Maybe Bool -> + Env Term free -> + FC -> Maybe Bool -> (idx : Nat) -> .(IsVar name idx (vars ++ free)) -> Stack free -> - LocalEnv free vars -> + LocalEnv free vars -> Core (NF free) - evalLocal {vars = []} env fc mrig idx prf stk locs + evalLocal {vars = []} env fc mrig idx prf stk locs = if not (holesOnly topopts || argHolesOnly topopts) && isLet mrig idx env then case getBinder prf env of @@ -146,7 +146,7 @@ parameters (defs : Defs, topopts : EvalOpts) isLet _ n env = isLet' n env evalLocal env fc mrig Z First stk (MkClosure opts locs' env' tm' :: locs) = evalWithOpts defs opts env' locs' tm' stk - evalLocal {free} {vars = x :: xs} + evalLocal {free} {vars = x :: xs} env fc mrig Z First stk (MkNFClosure nf :: locs) = applyToStack nf stk where @@ -159,19 +159,19 @@ parameters (defs : Defs, topopts : EvalOpts) (NApp fc (NRef nt fn) args) applyToStack (NApp fc (NLocal mrig idx p) args) stk = let MkVar p' = insertVarNames {outer=[]} {ns = xs} idx p in - evalLocal env fc mrig _ p' (args ++ stk) locs - applyToStack (NDCon fc n t a args) stk + evalLocal env fc mrig _ p' (args ++ stk) locs + applyToStack (NDCon fc n t a args) stk = pure $ NDCon fc n t a (args ++ stk) - applyToStack (NTCon fc n t a args) stk + applyToStack (NTCon fc n t a args) stk = pure $ NTCon fc n t a (args ++ stk) applyToStack nf _ = pure nf evalLocal {vars = x :: xs} {free} env fc mrig (S idx) (Later p) stk (_ :: locs) - = evalLocal {vars = xs} env fc mrig idx p stk locs - + = evalLocal {vars = xs} env fc mrig idx p stk locs + evalMeta : {vars : _} -> - Env Term free -> LocalEnv free vars -> + Env Term free -> LocalEnv free vars -> FC -> Name -> Int -> List (Closure free) -> Stack free -> Core (NF free) evalMeta {vars} env locs fc nm i args stk @@ -179,7 +179,7 @@ parameters (defs : Defs, topopts : EvalOpts) (NApp fc (NMeta nm i args) stk) evalRef : {vars : _} -> - Env Term free -> LocalEnv free vars -> + Env Term free -> LocalEnv free vars -> (isMeta : Bool) -> FC -> NameType -> Name -> Stack free -> (def : Lazy (NF free)) -> Core (NF free) @@ -189,19 +189,19 @@ parameters (defs : Defs, topopts : EvalOpts) = pure $ NTCon fc fn tag arity stk evalRef env locs meta fc Bound fn stk def = pure def - evalRef env locs meta fc nt n stk def + evalRef env locs meta fc nt n stk def = do Just res <- lookupCtxtExact n (gamma defs) - | Nothing => pure def + | Nothing => pure def let redok = evalAll topopts || - reducibleInAny (currentNS defs :: nestedNS defs) - (fullname res) + reducibleInAny (currentNS defs :: nestedNS defs) + (fullname res) (visibility res) if redok then do opts' <- if noCycles res then useMeta fc n defs topopts else pure topopts - evalDef env locs opts' meta fc + evalDef env locs opts' meta fc (multiplicity res) (definition res) (flags res) stk def else pure def @@ -212,28 +212,28 @@ parameters (defs : Defs, topopts : EvalOpts) getCaseBound [] [] loc = Just loc getCaseBound [] (x :: xs) loc = Nothing -- mismatched arg length getCaseBound (arg :: args) [] loc = Nothing -- mismatched arg length - getCaseBound (arg :: args) (n :: ns) loc + getCaseBound (arg :: args) (n :: ns) loc = do loc' <- getCaseBound args ns loc pure (arg :: loc') - evalConAlt : Env Term free -> + evalConAlt : Env Term free -> LocalEnv free (more ++ vars) -> EvalOpts -> FC -> - Stack free -> - (args : List Name) -> - List (Closure free) -> + Stack free -> + (args : List Name) -> + List (Closure free) -> CaseTree (args ++ more) -> - (default : Core (NF free)) -> + (default : Core (NF free)) -> Core (NF free) evalConAlt {more} {vars} env loc opts fc stk args args' sc def - = maybe def (\bound => - let loc' : LocalEnv _ ((args ++ more) ++ vars) + = maybe def (\bound => + let loc' : LocalEnv _ ((args ++ more) ++ vars) = rewrite sym (appendAssociative args more vars) in bound in evalTree env loc' opts fc stk sc def) (getCaseBound args' args loc) tryAlt : Env Term free -> - LocalEnv free (more ++ vars) -> EvalOpts -> FC -> + LocalEnv free (more ++ vars) -> EvalOpts -> FC -> Stack free -> NF free -> CaseAlt more -> (default : Core (NF free)) -> Core (NF free) -- Ordinary constructor matching @@ -255,10 +255,10 @@ parameters (defs : Defs, topopts : EvalOpts) tryAlt env loc opts fc stk (NType _) (ConCase (UN "Type") tag [] sc) def = evalTree env loc opts fc stk sc def -- Arrow matching, in typecase - tryAlt {more} {vars} + tryAlt {more} {vars} env loc opts fc stk (NBind pfc x (Pi r e aty) scty) (ConCase (UN "->") tag [s,t] sc) def = evalConAlt {more} {vars} env loc opts fc stk [s,t] - [MkNFClosure aty, + [MkNFClosure aty, MkNFClosure (NBind pfc x (Lam r e aty) scty)] sc def -- Delay matching @@ -270,7 +270,7 @@ parameters (defs : Defs, topopts : EvalOpts) else def -- Default case matches against any *concrete* value tryAlt env loc opts fc stk val (DefaultCase sc) def - = if concrete val + = if concrete val then evalTree env loc opts fc stk sc def else def where @@ -292,24 +292,24 @@ parameters (defs : Defs, topopts : EvalOpts) = tryAlt env loc opts fc stk val x (findAlt env loc opts fc stk val xs def) evalTree : {vars : _} -> - Env Term free -> LocalEnv free (args ++ vars) -> + Env Term free -> LocalEnv free (args ++ vars) -> EvalOpts -> FC -> Stack free -> CaseTree args -> (default : Core (NF free)) -> Core (NF free) evalTree {args} {vars} {free} env loc opts fc stk (Case idx x _ alts) def - = do let x' : IsVar _ _ ((args ++ vars) ++ free) + = do let x' : IsVar _ _ ((args ++ vars) ++ free) = rewrite sym (appendAssociative args vars free) in varExtend x - xval <- evalLocal env fc Nothing idx x' [] loc + xval <- evalLocal env fc Nothing idx x' [] loc findAlt env loc opts fc stk xval alts def evalTree {args} {vars} {free} env loc opts fc stk (STerm tm) def - = do let tm' : Term ((args ++ vars) ++ free) + = do let tm' : Term ((args ++ vars) ++ free) = rewrite sym (appendAssociative args vars free) in - embed tm + embed tm case fuel opts of Nothing => evalWithOpts defs opts env loc tm' stk Just Z => def - Just (S k) => + Just (S k) => do let opts' = record { fuel = Just k } opts evalWithOpts defs opts' env loc tm' stk evalTree env loc opts fc stk _ def = def @@ -320,22 +320,22 @@ parameters (defs : Defs, topopts : EvalOpts) Maybe (Vect arity (Closure free), Stack free) takeFromStack arity stk = takeStk arity stk [] where - takeStk : (remain : Nat) -> Stack free -> - Vect got (Closure free) -> + takeStk : (remain : Nat) -> Stack free -> + Vect got (Closure free) -> Maybe (Vect (got + remain) (Closure free), Stack free) takeStk {got} Z stk acc = Just (rewrite plusZeroRightNeutral got in reverse acc, stk) takeStk (S k) [] acc = Nothing - takeStk {got} (S k) (arg :: stk) acc + takeStk {got} (S k) (arg :: stk) acc = rewrite sym (plusSuccRightSucc got k) in takeStk k stk (arg :: acc) - extendFromStack : (args : List Name) -> + extendFromStack : (args : List Name) -> LocalEnv free vars -> Stack free -> Maybe (LocalEnv free (args ++ vars), Stack free) extendFromStack [] loc stk = Just (loc, stk) extendFromStack (n :: ns) loc [] = Nothing - extendFromStack (n :: ns) loc (arg :: args) + extendFromStack (n :: ns) loc (arg :: args) = do (loc', stk') <- extendFromStack ns loc args pure (arg :: loc', stk') @@ -345,7 +345,7 @@ parameters (defs : Defs, topopts : EvalOpts) evalOp {arity} fn stk def = case takeFromStack arity stk of -- Stack must be exactly the right height - Just (args, []) => + Just (args, []) => do argsnf <- evalAll args case fn argsnf of Nothing => pure def @@ -356,11 +356,11 @@ parameters (defs : Defs, topopts : EvalOpts) evalAll : Vect n (Closure free) -> Core (Vect n (NF free)) evalAll [] = pure [] evalAll (c :: cs) = pure $ !(evalClosure defs c) :: !(evalAll cs) - + evalDef : {vars : _} -> Env Term free -> LocalEnv free vars -> EvalOpts -> (isMeta : Bool) -> FC -> - RigCount -> Def -> List DefFlag -> + RigCount -> Def -> List DefFlag -> Stack free -> (def : Lazy (NF free)) -> Core (NF free) evalDef {vars} env locs opts meta fc rigd (PMDef r args tree _ _) flags stk def @@ -373,14 +373,14 @@ parameters (defs : Defs, topopts : EvalOpts) -- + It's a metavariable and not in Rig0 -- + It's a metavariable and we're not in 'argHolesOnly' -- + It's inlinable and and we're in 'tcInline' - = if r + = if r || (not (holesOnly opts) && not (argHolesOnly opts) && not (tcInline opts)) || (meta && rigd /= Rig0) || (meta && holesOnly opts) || (tcInline opts && elem TCInline flags) then case extendFromStack args locs stk of Nothing => pure def - Just (locs', stk') => + Just (locs', stk') => evalTree env locs' opts fc stk' tree (pure def) else pure def evalDef {vars} env locs opts meta fc rigd (Builtin op) flags stk def @@ -407,17 +407,17 @@ nfOpts opts defs env tm = eval defs opts env [] tm [] export gnf : Env Term vars -> Term vars -> Glued vars -gnf env tm +gnf env tm = MkGlue True - (pure tm) + (pure tm) (\c => do defs <- get Ctxt nf defs env tm) export gnfOpts : EvalOpts -> Env Term vars -> Term vars -> Glued vars -gnfOpts opts env tm +gnfOpts opts env tm = MkGlue True - (pure tm) + (pure tm) (\c => do defs <- get Ctxt nfOpts opts defs env tm) @@ -450,7 +450,7 @@ genName n mutual quoteArgs : {bound : _} -> Ref QVar Int -> Defs -> Bounds bound -> - Env Term free -> List (Closure free) -> + Env Term free -> List (Closure free) -> Core (List (Term (bound ++ free))) quoteArgs q defs bounds env [] = pure [] quoteArgs q defs bounds env (a :: args) @@ -458,27 +458,27 @@ mutual !(quoteArgs q defs bounds env args)) quoteHead : {bound : _} -> - Ref QVar Int -> Defs -> - FC -> Bounds bound -> Env Term free -> NHead free -> + Ref QVar Int -> Defs -> + FC -> Bounds bound -> Env Term free -> NHead free -> Core (Term (bound ++ free)) - quoteHead {bound} q defs fc bounds env (NLocal mrig _ prf) + quoteHead {bound} q defs fc bounds env (NLocal mrig _ prf) = let MkVar prf' = addLater bound prf in pure $ Local fc mrig _ prf' where - addLater : (ys : List Name) -> IsVar n idx xs -> + addLater : (ys : List Name) -> IsVar n idx xs -> Var (ys ++ xs) addLater [] isv = MkVar isv - addLater (x :: xs) 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)) + quoteHead q defs fc bounds env (NRef Bound (MN n i)) = case findName bounds of Just (MkVar p) => pure $ Local fc Nothing _ (varExtend p) Nothing => pure $ Ref fc Bound (MN n i) where findName : Bounds bound' -> Maybe (Var bound') findName None = Nothing - findName (Add x (MN n' i') ns) + findName (Add x (MN n' i') ns) = if i == i' -- this uniquely identifies it, given how we -- generated the names, and is a faster test! then Just (MkVar First) @@ -494,9 +494,9 @@ mutual quoteBinder : {bound : _} -> Ref QVar Int -> Defs -> Bounds bound -> - Env Term free -> Binder (NF free) -> + Env Term free -> Binder (NF free) -> Core (Binder (Term (bound ++ free))) - quoteBinder q defs bounds env (Lam r p ty) + quoteBinder q defs bounds env (Lam r p ty) = do ty' <- quoteGenNF q defs bounds env ty pure (Lam r p ty') quoteBinder q defs bounds env (Let r val ty) @@ -519,11 +519,11 @@ mutual quoteGenNF : {bound : _} -> Ref QVar Int -> - Defs -> Bounds bound -> + Defs -> Bounds bound -> Env Term vars -> NF vars -> Core (Term (bound ++ vars)) quoteGenNF q defs bound env (NBind fc n b sc) = do var <- genName "qv" - sc' <- quoteGenNF q defs (Add n var bound) env + sc' <- quoteGenNF q defs (Add n var bound) env !(sc defs (toClosure defaultOpts env (Ref fc Bound var))) b' <- quoteBinder q defs bound env b pure (Bind fc n b' sc') @@ -531,10 +531,10 @@ mutual = do f' <- quoteHead q defs fc bound env f args' <- quoteArgs q defs bound env args pure $ apply fc f' args' - quoteGenNF q defs bound env (NDCon fc n t ar args) + quoteGenNF q defs bound env (NDCon fc n t ar args) = do args' <- quoteArgs q defs bound env args pure $ apply fc (Ref fc (DataCon t ar) n) args' - quoteGenNF q defs bound env (NTCon fc n t ar args) + quoteGenNF q defs bound env (NTCon fc n t ar args) = do args' <- quoteArgs q defs bound env args pure $ apply fc (Ref fc (TyCon t ar) n) args' quoteGenNF q defs bound env (NAs fc n pat) @@ -552,11 +552,11 @@ mutual pure (TDelay fc r tyQ argQ) where toHolesOnly : Closure vs -> Closure vs - toHolesOnly (MkClosure _ locs env tm) + toHolesOnly (MkClosure _ locs env tm) = MkClosure withHoles locs env tm toHolesOnly c = c - quoteGenNF q defs bound env (NForce fc arg args) - = do args' <- quoteArgs q defs bound env args + quoteGenNF q defs bound env (NForce fc arg args) + = do args' <- quoteArgs q defs bound env args case arg of NDelay fc _ _ arg => do argNF <- evalClosure defs arg @@ -581,10 +581,10 @@ Quote Closure where export glueBack : Defs -> Env Term vars -> NF vars -> Glued vars -glueBack defs env nf +glueBack defs env nf = MkGlue False (do empty <- clearDefs defs - quote empty env nf) + quote empty env nf) (const (pure nf)) export @@ -593,27 +593,27 @@ normalise defs env tm = quote defs env !(nf defs env tm) export normaliseOpts : EvalOpts -> Defs -> Env Term free -> Term free -> Core (Term free) -normaliseOpts opts defs env tm +normaliseOpts opts defs env tm = quote defs env !(nfOpts opts defs env tm) export normaliseHoles : Defs -> Env Term free -> Term free -> Core (Term free) -normaliseHoles defs env tm +normaliseHoles defs env tm = quote defs env !(nfOpts withHoles defs env tm) export normaliseLHS : Defs -> Env Term free -> Term free -> Core (Term free) -normaliseLHS defs env tm +normaliseLHS defs env tm = quote defs env !(nfOpts onLHS defs env tm) export normaliseArgHoles : Defs -> Env Term free -> Term free -> Core (Term free) -normaliseArgHoles defs env tm +normaliseArgHoles defs env tm = quote defs env !(nfOpts withArgHoles defs env tm) export normaliseAll : Defs -> Env Term free -> Term free -> Core (Term free) -normaliseAll defs env tm +normaliseAll defs env tm = quote defs env !(nfOpts withAll defs env tm) -- Normalise, but without normalising the types of binders. Dealing with @@ -621,19 +621,19 @@ normaliseAll defs env tm -- a big win export normaliseScope : Defs -> Env Term vars -> Term vars -> Core (Term vars) -normaliseScope defs env (Bind fc n b sc) +normaliseScope defs env (Bind fc n b sc) = pure $ Bind fc n b !(normaliseScope defs (b :: env) sc) normaliseScope defs env tm = normalise defs env tm public export interface Convert (tm : List Name -> Type) where - convert : Defs -> Env Term vars -> + convert : Defs -> Env Term vars -> tm vars -> tm vars -> Core Bool convGen : Ref QVar Int -> - Defs -> Env Term vars -> + Defs -> Env Term vars -> tm vars -> tm vars -> Core Bool - convert defs env tm tm' + convert defs env tm tm' = do q <- newRef QVar 0 convGen q defs env tm tm' @@ -646,10 +646,10 @@ mutual allConv q defs env _ _ = pure False chkConvHead : Ref QVar Int -> Defs -> Env Term vars -> - NHead vars -> NHead vars -> Core Bool + NHead vars -> NHead vars -> Core Bool chkConvHead q defs env (NLocal _ idx _) (NLocal _ idx' _) = pure $ idx == idx' chkConvHead q defs env (NRef _ n) (NRef _ n') = pure $ n == n' - chkConvHead q defs env (NMeta n i args) (NMeta n' i' args') + chkConvHead q defs env (NMeta n i args) (NMeta n' i' args') = if i == i' then allConv q defs env args args' else pure False @@ -678,7 +678,7 @@ mutual export Convert NF where - convGen q defs env (NBind fc x b sc) (NBind _ x' b' sc') + convGen q defs env (NBind fc x b sc) (NBind _ x' b' sc') = do var <- genName "conv" let c = MkClosure defaultOpts [] env (Ref fc Bound var) bok <- convBinders q defs env b b' @@ -688,16 +688,16 @@ mutual convGen q defs env bsc bsc' else pure False - convGen q defs env tmx@(NBind fc x (Lam c ix tx) scx) tmy + convGen q defs env tmx@(NBind fc x (Lam c ix tx) scx) tmy = do empty <- clearDefs defs - etay <- nf defs env + etay <- nf defs env (Bind fc x (Lam c ix !(quote empty env tx)) (App fc (weaken !(quote empty env tmy)) (Local fc Nothing _ First))) convGen q defs env tmx etay convGen q defs env tmx tmy@(NBind fc y (Lam c iy ty) scy) = do empty <- clearDefs defs - etax <- nf defs env + etax <- nf defs env (Bind fc y (Lam c iy !(quote empty env ty)) (App fc (weaken !(quote empty env tmx)) (Local fc Nothing _ First))) @@ -750,7 +750,7 @@ mutual export getValArity : Defs -> Env Term vars -> NF vars -> Core Nat -getValArity defs env (NBind fc x (Pi _ _ _) sc) +getValArity defs env (NBind fc x (Pi _ _ _) sc) = pure (S !(getValArity defs env !(sc defs (toClosure defaultOpts env (Erased fc))))) getValArity defs env val = pure 0 @@ -768,7 +768,7 @@ logNF lvl msg env tmnf then do defs <- get Ctxt tm <- quote defs env tmnf tm' <- toFullNames tm - coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg + coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg ++ ": " ++ show tm' else pure () @@ -783,7 +783,7 @@ logTermNF lvl msg env tm then do defs <- get Ctxt tmnf <- normaliseHoles defs env tm tm' <- toFullNames tmnf - coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg + coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg ++ ": " ++ show tm' else pure () @@ -796,7 +796,7 @@ logGlue lvl msg env gtm then do defs <- get Ctxt tm <- getTerm gtm tm' <- toFullNames tm - coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg + coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg ++ ": " ++ show tm' else pure () @@ -810,7 +810,7 @@ logGlueNF lvl msg env gtm tm <- getTerm gtm tmnf <- normaliseHoles defs env tm tm' <- toFullNames tmnf - coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg + coreLift $ putStrLn $ "LOG " ++ show lvl ++ ": " ++ msg ++ ": " ++ show tm' else pure () @@ -828,11 +828,11 @@ logEnv lvl msg env dumpEnv [] = pure () dumpEnv {vs = x :: _} (Let c val ty :: bs) = do logTermNF lvl (msg ++ ": let " ++ show x) bs val - logTermNF lvl (msg ++ ":" ++ show c ++ " " ++ + logTermNF lvl (msg ++ ":" ++ show c ++ " " ++ show x) bs ty dumpEnv bs dumpEnv {vs = x :: _} (b :: bs) - = do logTermNF lvl (msg ++ ":" ++ show (multiplicity b) ++ " " ++ + = do logTermNF lvl (msg ++ ":" ++ show (multiplicity b) ++ " " ++ show x) bs (binderType b) dumpEnv bs @@ -851,29 +851,29 @@ replace' {vars} tmpi defs env lhs parg tm repSub : NF vars -> Core (Term vars) repSub (NBind fc x b scfn) - = do b' <- traverse repSub b + = do b' <- traverse repSub b let x' = MN "tmp" tmpi - sc' <- replace' (tmpi + 1) defs env lhs parg + 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 []) - repSub (NApp fc hd args) + repSub (NApp fc hd args) = do args' <- traverse repArg args - pure $ apply fc + pure $ apply fc !(replace' tmpi defs env lhs parg (NApp fc hd [])) args' - repSub (NDCon fc n t a args) + repSub (NDCon fc n t a args) = do args' <- traverse repArg args empty <- clearDefs defs - pure $ apply fc + pure $ apply fc !(quote empty env (NDCon fc n t a [])) args' - repSub (NTCon fc n t a args) + repSub (NTCon fc n t a args) = do args' <- traverse repArg args empty <- clearDefs defs - pure $ apply fc + pure $ apply fc !(quote empty env (NTCon fc n t a [])) args' repSub (NAs fc a p) diff --git a/src/Core/Primitives.idr b/src/Core/Primitives.idr index 2967a96..2ccf454 100644 --- a/src/Core/Primitives.idr +++ b/src/Core/Primitives.idr @@ -65,40 +65,40 @@ strLength _ = Nothing strHead : Vect 1 (NF vars) -> Maybe (NF vars) strHead [NPrimVal fc (Str "")] = Nothing -strHead [NPrimVal fc (Str str)] +strHead [NPrimVal fc (Str str)] = Just (NPrimVal fc (Ch (assert_total (strHead str)))) strHead _ = Nothing strTail : Vect 1 (NF vars) -> Maybe (NF vars) strTail [NPrimVal fc (Str "")] = Nothing -strTail [NPrimVal fc (Str str)] +strTail [NPrimVal fc (Str str)] = Just (NPrimVal fc (Str (assert_total (strTail str)))) strTail _ = Nothing strIndex : Vect 2 (NF vars) -> Maybe (NF vars) -strIndex [NPrimVal fc (Str str), NPrimVal _ (I i)] +strIndex [NPrimVal fc (Str str), NPrimVal _ (I i)] = if i >= 0 && cast i < length str then Just (NPrimVal fc (Ch (assert_total (prim__strIndex str i)))) else Nothing strIndex _ = Nothing strCons : Vect 2 (NF vars) -> Maybe (NF vars) -strCons [NPrimVal fc (Ch x), NPrimVal _ (Str y)] +strCons [NPrimVal fc (Ch x), NPrimVal _ (Str y)] = Just (NPrimVal fc (Str (strCons x y))) strCons _ = Nothing strAppend : Vect 2 (NF vars) -> Maybe (NF vars) -strAppend [NPrimVal fc (Str x), NPrimVal _ (Str y)] +strAppend [NPrimVal fc (Str x), NPrimVal _ (Str y)] = Just (NPrimVal fc (Str (x ++ y))) strAppend _ = Nothing strReverse : Vect 1 (NF vars) -> Maybe (NF vars) -strReverse [NPrimVal fc (Str x)] +strReverse [NPrimVal fc (Str x)] = Just (NPrimVal fc (Str (reverse x))) strReverse _ = Nothing strSubstr : Vect 3 (NF vars) -> Maybe (NF vars) -strSubstr [NPrimVal fc (I start), NPrimVal _ (I len), NPrimVal _ (Str str)] +strSubstr [NPrimVal fc (I start), NPrimVal _ (I len), NPrimVal _ (Str str)] = Just (NPrimVal fc (Str (prim__strSubstr start len str))) strSubstr _ = Nothing @@ -241,14 +241,14 @@ believeMe [_, _, NType fc] = Just (NType fc) believeMe [_, _, val] = Nothing constTy : Constant -> Constant -> Constant -> ClosedTerm -constTy a b c - = PrimVal emptyFC a `linFnType` +constTy a b c + = PrimVal emptyFC a `linFnType` (PrimVal emptyFC b `linFnType` PrimVal emptyFC c) constTy3 : Constant -> Constant -> Constant -> Constant -> ClosedTerm -constTy3 a b c d - = PrimVal emptyFC a `linFnType` - (PrimVal emptyFC b `linFnType` +constTy3 a b c d + = PrimVal emptyFC a `linFnType` + (PrimVal emptyFC b `linFnType` (PrimVal emptyFC c `linFnType` PrimVal emptyFC d)) predTy : Constant -> Constant -> ClosedTerm @@ -264,7 +264,7 @@ doubleTy : ClosedTerm doubleTy = predTy DoubleType DoubleType believeMeTy : ClosedTerm -believeMeTy +believeMeTy = Bind emptyFC (UN "a") (Pi Rig0 Explicit (TType emptyFC)) $ Bind emptyFC (UN "b") (Pi Rig0 Explicit (TType emptyFC)) $ Bind emptyFC (UN "x") (Pi RigW Explicit (Local emptyFC Nothing _ (Later First))) $ @@ -279,7 +279,7 @@ castTo DoubleType = castDouble castTo _ = const Nothing export -getOp : PrimFn arity -> +getOp : PrimFn arity -> {vars : List Name} -> Vect arity (NF vars) -> Maybe (NF vars) getOp (Add ty) = binOp add getOp (Sub ty) = binOp sub @@ -373,7 +373,7 @@ allPrimitives = map (\t => MkPrim (Neg t) (predTy t t) isTotal) [IntType, IntegerType, DoubleType] ++ map (\t => MkPrim (ShiftL t) (arithTy t) notCovering) [IntType] ++ map (\t => MkPrim (ShiftR t) (arithTy t) notCovering) [IntType] ++ - + map (\t => MkPrim (LT t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType] ++ map (\t => MkPrim (LTE t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType] ++ map (\t => MkPrim (EQ t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType] ++ diff --git a/src/Core/Reflect.idr b/src/Core/Reflect.idr index 9d4dd1b..e9ad12e 100644 --- a/src/Core/Reflect.idr +++ b/src/Core/Reflect.idr @@ -49,12 +49,12 @@ reflection n = NS ["Reflection", "Language"] (UN n) export cantReify : NF vars -> String -> Core a -cantReify val ty +cantReify val ty = throw (GenericMsg (getLoc val) ("Can't reify as " ++ ty)) export cantReflect : FC -> String -> Core a -cantReflect fc ty +cantReflect fc ty = throw (GenericMsg fc ("Can't reflect as " ++ ty)) export @@ -187,14 +187,14 @@ Reify Name where export Reflect Name where - reflect fc defs env (UN x) + reflect fc defs env (UN x) = do x' <- reflect fc defs env x appCon fc defs (reflection "UN") [x'] - reflect fc defs env (MN x i) + reflect fc defs env (MN x i) = do x' <- reflect fc defs env x i' <- reflect fc defs env i appCon fc defs (reflection "MN") [x', i'] - reflect fc defs env (NS ns n) + reflect fc defs env (NS ns n) = do ns' <- reflect fc defs env ns n' <- reflect fc defs env n appCon fc defs (reflection "NS") [ns', n'] @@ -385,9 +385,9 @@ export Reflect (IsVar name idx vs) where reflect fc defs env First = appCon fc defs (reflection "First") [Erased fc, Erased fc] - reflect fc defs env (Later p) + reflect fc defs env (Later p) = do p' <- reflect fc defs env p - appCon fc defs (reflection "Later") + appCon fc defs (reflection "Later") [Erased fc, Erased fc, Erased fc, Erased fc, p'] -- Assume terms are normalised so there's not Let bindings in particular diff --git a/src/Core/TT.idr b/src/Core/TT.idr index 98c93ea..0d289e9 100644 --- a/src/Core/TT.idr +++ b/src/Core/TT.idr @@ -19,7 +19,7 @@ data NameType : Type where TyCon : (tag : Int) -> (arity : Nat) -> NameType public export -data Constant +data Constant = I Int | BI Integer | Str String @@ -260,11 +260,11 @@ data Binder : Type -> Type where -- pattern bound variables. The PiInfo gives the implicitness at the -- point it was bound (Explicit if it was explicitly named in the -- program) - PVar : RigCount -> PiInfo -> (ty : type) -> Binder type + PVar : RigCount -> PiInfo -> (ty : type) -> Binder type -- variable bound for an as pattern (Like a let, but no computational -- force, and only used on the lhs. Converted to a let on the rhs because -- we want the computational behaviour.) - PLet : RigCount -> (val : type) -> (ty : type) -> Binder type + PLet : RigCount -> (val : type) -> (ty : type) -> Binder type -- the type of pattern bound variables PVTy : RigCount -> (ty : type) -> Binder type @@ -285,7 +285,7 @@ multiplicity (Pi c x ty) = c multiplicity (PVar c p ty) = c multiplicity (PLet c val ty) = c multiplicity (PVTy c ty) = c - + export setMultiplicity : Binder tm -> RigCount -> Binder tm setMultiplicity (Lam c x ty) c' = Lam c' x ty @@ -299,7 +299,7 @@ showCount : RigCount -> String showCount Rig0 = "0 " showCount Rig1 = "1 " showCount RigW = "" - + Show ty => Show (Binder ty) where show (Lam c _ t) = "\\" ++ showCount c ++ show t show (Pi c _ t) = "Pi " ++ showCount c ++ show t @@ -374,13 +374,13 @@ data LazyReason = LInf | LLazy | LUnknown public export data Term : List Name -> Type where Local : {name : _} -> - FC -> Maybe Bool -> + FC -> Maybe Bool -> (idx : Nat) -> .(IsVar name idx vars) -> Term vars Ref : FC -> NameType -> (name : Name) -> Term vars -- Metavariables and the scope they are applied to Meta : FC -> Name -> Int -> List (Term vars) -> Term vars - Bind : FC -> (x : Name) -> - (b : Binder (Term vars)) -> + Bind : FC -> (x : Name) -> + (b : Binder (Term vars)) -> (scope : Term (x :: vars)) -> Term vars App : FC -> (fn : Term vars) -> (arg : Term vars) -> Term vars -- as patterns; since we check LHS patterns as terms before turning @@ -441,9 +441,9 @@ export Eq (Term vars) where (==) (Local _ _ idx _) (Local _ _ idx' _) = idx == idx' (==) (Ref _ _ n) (Ref _ _ n') = n == n' - (==) (Meta _ _ i args) (Meta _ _ i' args') + (==) (Meta _ _ i args) (Meta _ _ i' args') = assert_total (i == i' && args == args') - (==) (Bind _ _ b sc) (Bind _ _ b' sc') + (==) (Bind _ _ b sc) (Bind _ _ b' sc') = assert_total (b == b' && sc == believe_me sc') (==) (App _ f a) (App _ f' a') = f == f' && a == a' (==) (As _ a p) (As _ a' p') = a == a' && p == p' @@ -496,20 +496,20 @@ Ord Visibility where compare Public Export = GT public export -data PartialReason - = NotStrictlyPositive +data PartialReason + = NotStrictlyPositive | BadCall (List Name) | RecPath (List Name) export Show PartialReason where show NotStrictlyPositive = "not strictly positive" - show (BadCall [n]) + show (BadCall [n]) = "not terminating due to call to " ++ show n - show (BadCall ns) - = "not terminating due to calls to " ++ showSep ", " (map show ns) - show (RecPath ns) - = "not terminating due to recursive path " ++ showSep " -> " (map show ns) + show (BadCall ns) + = "not terminating due to calls to " ++ showSep ", " (map show ns) + show (RecPath ns) + = "not terminating due to recursive path " ++ showSep " -> " (map show ns) public export data Terminating @@ -524,7 +524,7 @@ Show Terminating where show (NotTerminating p) = show p public export -data Covering +data Covering = IsCovering | MissingCases (List (Term [])) | NonCoveringCall (List Name) @@ -533,9 +533,9 @@ export Show Covering where show IsCovering = "covering" show (MissingCases c) = "not covering all cases" - show (NonCoveringCall [f]) + show (NonCoveringCall [f]) = "not covering due to call to function " ++ show f - show (NonCoveringCall cs) + show (NonCoveringCall cs) = "not covering due to calls to functions " ++ showSep ", " (map show cs) -- Totality status of a definition. We separate termination checking from @@ -573,12 +573,12 @@ notCovering = MkTotality Unchecked (MissingCases []) export insertVar : {outer : _} -> - (idx : Nat) -> + (idx : Nat) -> .(IsVar name idx (outer ++ inner)) -> Var (outer ++ n :: inner) insertVar {outer = []} idx x = MkVar (Later x) insertVar {outer = (name :: xs)} Z First = MkVar First -insertVar {n} {outer = (x :: xs)} (S i) (Later y) +insertVar {n} {outer = (x :: xs)} (S i) (Later y) = let MkVar prf = insertVar {n} i y in MkVar (Later prf) @@ -586,30 +586,30 @@ export weakenVar : (ns : List Name) -> {idx : Nat} -> .(IsVar name idx inner) -> Var (ns ++ inner) weakenVar [] x = MkVar x -weakenVar (y :: xs) x +weakenVar (y :: xs) x = let MkVar x' = weakenVar xs x in MkVar (Later x') export insertVarNames : {outer, ns : _} -> - (idx : Nat) -> + (idx : Nat) -> .(IsVar name idx (outer ++ inner)) -> Var (outer ++ (ns ++ inner)) insertVarNames {ns} {outer = []} idx prf = weakenVar ns prf insertVarNames {outer = (y :: xs)} Z First = MkVar First -insertVarNames {ns} {outer = (y :: xs)} (S i) (Later x) +insertVarNames {ns} {outer = (y :: xs)} (S i) (Later x) = let MkVar prf = insertVarNames {ns} i x in MkVar (Later prf) export thin : {outer, inner : _} -> (n : Name) -> Term (outer ++ inner) -> Term (outer ++ n :: inner) -thin n (Local fc r idx prf) +thin n (Local fc r idx prf) = let MkVar var' = insertVar {n} idx prf in Local fc r _ var' thin n (Ref fc nt name) = Ref fc nt name thin n (Meta fc name idx args) = Meta fc name idx (map (thin n) args) -thin {outer} {inner} n (Bind fc x b scope) +thin {outer} {inner} n (Bind fc x b scope) = let sc' = thin {outer = x :: outer} {inner} n scope in Bind fc x (thinBinder n b) sc' where @@ -634,28 +634,28 @@ export insertNames : {outer, inner : _} -> (ns : List Name) -> Term (outer ++ inner) -> Term (outer ++ (ns ++ inner)) -insertNames ns (Local fc r idx prf) +insertNames ns (Local fc r idx prf) = let MkVar prf' = insertVarNames {ns} idx prf in Local fc r _ prf' insertNames ns (Ref fc nt name) = Ref fc nt name insertNames ns (Meta fc name idx args) = Meta fc name idx (map (insertNames ns) args) -insertNames {outer} {inner} ns (Bind fc x b scope) - = Bind fc x (assert_total (map (insertNames ns) b)) +insertNames {outer} {inner} ns (Bind fc x b scope) + = Bind fc x (assert_total (map (insertNames ns) b)) (insertNames {outer = x :: outer} {inner} ns scope) -insertNames ns (App fc fn arg) +insertNames ns (App fc fn arg) = App fc (insertNames ns fn) (insertNames ns arg) -insertNames ns (As fc as tm) +insertNames ns (As fc as tm) = As fc (insertNames ns as) (insertNames ns tm) insertNames ns (TDelayed fc r ty) = TDelayed fc r (insertNames ns ty) -insertNames ns (TDelay fc r ty tm) +insertNames ns (TDelay fc r ty tm) = TDelay fc r (insertNames ns ty) (insertNames ns tm) insertNames ns (TForce fc tm) = TForce fc (insertNames ns tm) insertNames ns (PrimVal fc c) = PrimVal fc c insertNames ns (Erased fc) = Erased fc insertNames ns (TType fc) = TType fc -export +export Weaken Term where weaken tm = thin {outer = []} _ tm weakenNs ns tm = insertNames {outer = []} ns tm @@ -698,7 +698,7 @@ export getFnArgs : Term vars -> (Term vars, List (Term vars)) getFnArgs tm = getFA [] tm where - getFA : List (Term vars) -> Term vars -> + getFA : List (Term vars) -> Term vars -> (Term vars, List (Term vars)) getFA args (App _ f a) = getFA (a :: args) f getFA args tm = (tm, args) @@ -718,7 +718,7 @@ data CompatibleVars : List Name -> List Name -> Type where CompatExt : CompatibleVars xs ys -> CompatibleVars (n :: xs) (m :: ys) export -areVarsCompatible : (xs : List Name) -> (ys : List Name) -> +areVarsCompatible : (xs : List Name) -> (ys : List Name) -> Maybe (CompatibleVars xs ys) areVarsCompatible [] [] = pure CompatPre areVarsCompatible (x :: xs) (y :: ys) @@ -732,15 +732,15 @@ extendCompats : (args : List Name) -> extendCompats [] prf = prf extendCompats (x :: xs) prf = CompatExt (extendCompats xs prf) -renameLocalRef : CompatibleVars xs ys -> - {idx : Nat} -> - .(IsVar name idx xs) -> +renameLocalRef : CompatibleVars xs ys -> + {idx : Nat} -> + .(IsVar name idx xs) -> Var ys renameLocalRef prf p = believe_me (MkVar p) -- renameLocalRef CompatPre First = (MkVar First) -- renameLocalRef (CompatExt x) First = (MkVar First) -- renameLocalRef CompatPre (Later p) = (MkVar (Later p)) --- renameLocalRef (CompatExt y) (Later p) +-- renameLocalRef (CompatExt y) (Later p) -- = let (MkVar p') = renameLocalRef y p in MkVar (Later p') renameVarList : CompatibleVars xs ys -> Var xs -> Var ys @@ -748,22 +748,22 @@ renameVarList prf (MkVar p) = renameLocalRef prf p -- TODO: Surely identity at run time, can we replace with 'believe_me'? export -renameVars : CompatibleVars xs ys -> Term xs -> Term ys +renameVars : CompatibleVars xs ys -> Term xs -> Term ys renameVars CompatPre tm = tm -renameVars prf (Local fc r idx vprf) +renameVars prf (Local fc r idx vprf) = let MkVar vprf' = renameLocalRef prf vprf in Local fc r _ vprf' renameVars prf (Ref fc x name) = Ref fc x name -renameVars prf (Meta fc n i args) +renameVars prf (Meta fc n i args) = Meta fc n i (map (renameVars prf) args) -renameVars prf (Bind fc x b scope) +renameVars prf (Bind fc x b scope) = Bind fc x (map (renameVars prf) b) (renameVars (CompatExt prf) scope) -renameVars prf (App fc fn arg) +renameVars prf (App fc fn arg) = App fc (renameVars prf fn) (renameVars prf arg) renameVars prf (As fc as tm) = As fc (renameVars prf as) (renameVars prf tm) renameVars prf (TDelayed fc r ty) = TDelayed fc r (renameVars prf ty) -renameVars prf (TDelay fc r ty tm) +renameVars prf (TDelay fc r ty tm) = TDelay fc r (renameVars prf ty) (renameVars prf tm) renameVars prf (TForce fc x) = TForce fc (renameVars prf x) renameVars prf (PrimVal fc c) = PrimVal fc c @@ -781,15 +781,15 @@ data SubVars : List Name -> List Name -> Type where KeepCons : SubVars xs ys -> SubVars (x :: xs) (x :: ys) export -subElem : {idx : Nat} -> .(IsVar name idx xs) -> +subElem : {idx : Nat} -> .(IsVar name idx xs) -> SubVars ys xs -> Maybe (Var ys) subElem prf SubRefl = Just (MkVar prf) subElem First (DropCons p) = Nothing -subElem (Later x) (DropCons p) +subElem (Later x) (DropCons p) = do MkVar prf' <- subElem x p Just (MkVar prf') subElem First (KeepCons p) = Just (MkVar First) -subElem (Later x) (KeepCons p) +subElem (Later x) (KeepCons p) = do MkVar prf' <- subElem x p Just (MkVar (Later prf')) @@ -806,9 +806,9 @@ subInclude ns (KeepCons p) = KeepCons (subInclude ns p) mutual export - shrinkBinder : Binder (Term vars) -> SubVars newvars vars -> + shrinkBinder : Binder (Term vars) -> SubVars newvars vars -> Maybe (Binder (Term newvars)) - shrinkBinder (Lam c p ty) prf + shrinkBinder (Lam c p ty) prf = Just (Lam c p !(shrinkTerm ty prf)) shrinkBinder (Let c val ty) prf = Just (Let c !(shrinkTerm val prf) !(shrinkTerm ty prf)) @@ -827,21 +827,21 @@ mutual export shrinkTerm : Term vars -> SubVars newvars vars -> Maybe (Term newvars) - shrinkTerm (Local fc r idx loc) prf + shrinkTerm (Local fc r idx loc) prf = case subElem loc prf of Nothing => Nothing Just (MkVar loc') => Just (Local fc r _ loc') shrinkTerm (Ref fc x name) prf = Just (Ref fc x name) - shrinkTerm (Meta fc x y xs) prf + shrinkTerm (Meta fc x y xs) prf = do xs' <- traverse (\x => shrinkTerm x prf) xs Just (Meta fc x y xs') - shrinkTerm (Bind fc x b scope) prf + shrinkTerm (Bind fc x b scope) prf = Just (Bind fc x !(shrinkBinder b prf) !(shrinkTerm scope (KeepCons prf))) - shrinkTerm (App fc fn arg) prf + shrinkTerm (App fc fn arg) prf = Just (App fc !(shrinkTerm fn prf) !(shrinkTerm arg prf)) - shrinkTerm (As fc as tm) prf + shrinkTerm (As fc as tm) prf = Just (As fc !(shrinkTerm as prf) !(shrinkTerm tm prf)) - shrinkTerm (TDelayed fc x y) prf + shrinkTerm (TDelayed fc x y) prf = Just (TDelayed fc x !(shrinkTerm y prf)) shrinkTerm (TDelay fc x t y) prf = Just (TDelay fc x !(shrinkTerm t prf) !(shrinkTerm y prf)) @@ -863,14 +863,14 @@ addVars : {later, bound : _} -> Var (later ++ (bound ++ vars)) addVars {later = []} {bound} bs p = weakenVar bound p addVars {later = (x :: xs)} bs First = MkVar First -addVars {later = (x :: xs)} bs (Later p) +addVars {later = (x :: xs)} bs (Later p) = let MkVar p' = addVars {later = xs} bs p in MkVar (Later p') -resolveRef : (done : List Name) -> Bounds bound -> FC -> Name -> +resolveRef : (done : List Name) -> Bounds bound -> FC -> Name -> Maybe (Term (later ++ (done ++ bound ++ vars))) resolveRef done None fc n = Nothing -resolveRef {later} {vars} done (Add {xs} new old bs) fc n +resolveRef {later} {vars} done (Add {xs} new old bs) fc n = if n == old then rewrite appendAssociative later done (new :: xs ++ vars) in let MkVar p = weakenVar {inner = new :: xs ++ vars} @@ -880,25 +880,25 @@ resolveRef {later} {vars} done (Add {xs} new old bs) fc n in resolveRef (done ++ [new]) bs fc n mkLocals : {later, bound : _} -> - Bounds bound -> + Bounds bound -> Term (later ++ vars) -> Term (later ++ (bound ++ vars)) -mkLocals bs (Local fc r idx p) +mkLocals bs (Local fc r idx p) = let MkVar p' = addVars bs p in Local fc r _ p' -mkLocals bs (Ref fc Bound name) +mkLocals bs (Ref fc Bound name) = maybe (Ref fc Bound name) id (resolveRef [] bs fc name) -mkLocals bs (Ref fc nt name) +mkLocals bs (Ref fc nt name) = Ref fc nt name -mkLocals bs (Meta fc name y xs) +mkLocals bs (Meta fc name y xs) = maybe (Meta fc name y (map (mkLocals bs) xs)) id (resolveRef [] bs fc name) -mkLocals {later} bs (Bind fc x b scope) - = Bind fc x (map (mkLocals bs) b) +mkLocals {later} bs (Bind fc x b scope) + = Bind fc x (map (mkLocals bs) b) (mkLocals {later = x :: later} bs scope) -mkLocals bs (App fc fn arg) +mkLocals bs (App fc fn arg) = App fc (mkLocals bs fn) (mkLocals bs arg) -mkLocals bs (As fc as tm) +mkLocals bs (As fc as tm) = As fc (mkLocals bs as) (mkLocals bs tm) -mkLocals bs (TDelayed fc x y) +mkLocals bs (TDelayed fc x y) = TDelayed fc x (mkLocals bs y) mkLocals bs (TDelay fc x t y) = TDelay fc x (mkLocals bs t) (mkLocals bs y) @@ -921,7 +921,7 @@ refToLocal x new tm = refsToLocals (Add new x None) tm export isVar : (n : Name) -> (ns : List Name) -> Maybe (Var ns) isVar n [] = Nothing -isVar n (m :: ms) +isVar n (m :: ms) = case nameEq n m of Nothing => do MkVar p <- isVar n ms pure (MkVar (Later p)) @@ -934,19 +934,19 @@ resolveNames vars (Ref fc Bound name) = case isVar name vars of Just (MkVar prf) => Local fc (Just False) _ prf _ => Ref fc Bound name -resolveNames vars (Meta fc n i xs) +resolveNames vars (Meta fc n i xs) = Meta fc n i (map (resolveNames vars) xs) -resolveNames vars (Bind fc x b scope) +resolveNames vars (Bind fc x b scope) = Bind fc x (map (resolveNames vars) b) (resolveNames (x :: vars) scope) -resolveNames vars (App fc fn arg) +resolveNames vars (App fc fn arg) = App fc (resolveNames vars fn) (resolveNames vars arg) -resolveNames vars (As fc as pat) +resolveNames vars (As fc as pat) = As fc (resolveNames vars as) (resolveNames vars pat) -resolveNames vars (TDelayed fc x y) +resolveNames vars (TDelayed fc x y) = TDelayed fc x (resolveNames vars y) resolveNames vars (TDelay fc x t y) = TDelay fc x (resolveNames vars t) (resolveNames vars y) -resolveNames vars (TForce fc x) +resolveNames vars (TForce fc x) = TForce fc (resolveNames vars x) resolveNames vars tm = tm @@ -959,15 +959,15 @@ namespace SubstEnv public export data SubstEnv : List Name -> List Name -> Type where Nil : SubstEnv [] vars - (::) : Term vars -> + (::) : Term vars -> SubstEnv ds vars -> SubstEnv (d :: ds) vars findDrop : {drop : _} -> {idx : Nat} -> - FC -> Maybe Bool -> .(IsVar name idx (drop ++ vars)) -> + FC -> Maybe Bool -> .(IsVar name idx (drop ++ vars)) -> SubstEnv drop vars -> Term vars findDrop {drop = []} fc r var env = Local fc r _ var findDrop {drop = x :: xs} fc r First (tm :: env) = tm - findDrop {drop = x :: xs} fc r (Later p) (tm :: env) + findDrop {drop = x :: xs} fc r (Later p) (tm :: env) = findDrop fc r p env find : {outer : _} -> {idx : Nat} -> @@ -979,22 +979,22 @@ namespace SubstEnv find {outer = x :: xs} fc r (Later p) env = weaken (find fc r p env) substEnv : {outer : _} -> - SubstEnv drop vars -> Term (outer ++ (drop ++ vars)) -> + SubstEnv drop vars -> Term (outer ++ (drop ++ vars)) -> Term (outer ++ vars) - substEnv env (Local fc r _ prf) + substEnv env (Local fc r _ prf) = find fc r prf env substEnv env (Ref fc x name) = Ref fc x name - substEnv env (Meta fc n i xs) + substEnv env (Meta fc n i xs) = Meta fc n i (map (substEnv env) xs) - substEnv {outer} env (Bind fc x b scope) - = Bind fc x (map (substEnv env) b) + substEnv {outer} env (Bind fc x b scope) + = Bind fc x (map (substEnv env) b) (substEnv {outer = x :: outer} env scope) - substEnv env (App fc fn arg) + substEnv env (App fc fn arg) = App fc (substEnv env fn) (substEnv env arg) - substEnv env (As fc as pat) + substEnv env (As fc as pat) = As fc (substEnv env as) (substEnv env pat) substEnv env (TDelayed fc x y) = TDelayed fc x (substEnv env y) - substEnv env (TDelay fc x t y) + substEnv env (TDelay fc x t y) = TDelay fc x (substEnv env t) (substEnv env y) substEnv env (TForce fc x) = TForce fc (substEnv env x) substEnv env (PrimVal fc c) = PrimVal fc c @@ -1016,24 +1016,24 @@ substName 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) +substName x new (Meta fc n i xs) = Meta fc n i (map (substName 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) +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) +substName x new (App fc fn arg) = App fc (substName x new fn) (substName x new arg) -substName x new (As fc as pat) +substName x new (As fc as pat) = As fc as (substName x new pat) -substName x new (TDelayed fc y z) +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 y) +substName x new (TForce fc y) = TForce fc (substName x new y) substName x new tm = tm - + export addMetas : NameMap Bool -> Term vars -> NameMap Bool addMetas ns (Local fc x idx y) = ns @@ -1043,15 +1043,15 @@ addMetas ns (Meta fc n i xs) = addMetaArgs (insert n False ns) xs addMetaArgs : NameMap Bool -> List (Term vars) -> NameMap Bool addMetaArgs ns [] = ns addMetaArgs ns (t :: ts) = addMetaArgs (addMetas ns t) ts -addMetas ns (Bind fc x (Let c val ty) scope) +addMetas ns (Bind fc x (Let c val ty) scope) = addMetas (addMetas (addMetas ns val) ty) scope -addMetas ns (Bind fc x b scope) +addMetas ns (Bind fc x b scope) = addMetas (addMetas ns (binderType b)) scope -addMetas ns (App fc fn arg) +addMetas ns (App fc fn arg) = addMetas (addMetas ns fn) arg addMetas ns (As fc as tm) = addMetas ns tm addMetas ns (TDelayed fc x y) = addMetas ns y -addMetas ns (TDelay fc x t y) +addMetas ns (TDelay fc x t y) = addMetas (addMetas ns t) y addMetas ns (TForce fc x) = addMetas ns x addMetas ns (PrimVal fc c) = ns @@ -1062,31 +1062,31 @@ addMetas ns (TType fc) = ns export getMetas : Term vars -> NameMap Bool getMetas tm = addMetas empty tm - + export -addRefs : (underAssert : Bool) -> (aTotal : Name) -> +addRefs : (underAssert : Bool) -> (aTotal : Name) -> NameMap Bool -> Term vars -> NameMap Bool addRefs ua at ns (Local fc x idx y) = ns addRefs ua at ns (Ref fc x name) = insert name ua ns -addRefs ua at ns (Meta fc n i xs) +addRefs ua at ns (Meta fc n i xs) = addRefsArgs ns xs where addRefsArgs : NameMap Bool -> List (Term vars) -> NameMap Bool addRefsArgs ns [] = ns addRefsArgs ns (t :: ts) = addRefsArgs (addRefs ua at ns t) ts -addRefs ua at ns (Bind fc x (Let c val ty) scope) +addRefs ua at ns (Bind fc x (Let c val ty) scope) = addRefs ua at (addRefs ua at (addRefs ua at ns val) ty) scope -addRefs ua at ns (Bind fc x b scope) +addRefs ua at ns (Bind fc x b scope) = addRefs ua at (addRefs ua at ns (binderType b)) scope addRefs ua at ns (App _ (App _ (Ref fc _ name) x) y) = if name == at then addRefs True at (insert name True ns) y else addRefs ua at (addRefs ua at (insert name ua ns) x) y -addRefs ua at ns (App fc fn arg) +addRefs ua at ns (App fc fn arg) = addRefs ua at (addRefs ua at ns fn) arg addRefs ua at ns (As fc as tm) = addRefs ua at ns tm addRefs ua at ns (TDelayed fc x y) = addRefs ua at ns y -addRefs ua at ns (TDelay fc x t y) +addRefs ua at ns (TDelay fc x t y) = addRefs ua at (addRefs ua at ns t) y addRefs ua at ns (TForce fc x) = addRefs ua at ns x addRefs ua at ns (PrimVal fc c) = ns @@ -1104,40 +1104,40 @@ export Show (Term vars) where show tm = let (fn, args) = getFnArgs tm in showApp fn args where showApp : Term vars -> List (Term vars) -> String - showApp (Local {name} _ c idx _) [] + showApp (Local {name} _ c idx _) [] = show name ++ "[" ++ show idx ++ "]" showApp (Ref _ _ n) [] = show n - showApp (Meta _ n i args) [] + showApp (Meta _ n i args) [] = "?" ++ show n ++ "_" ++ show args - showApp (Bind _ x (Lam c p ty) sc) [] - = "\\" ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (Lam c p ty) sc) [] + = "\\" ++ showCount c ++ show x ++ " : " ++ show ty ++ " => " ++ show sc - showApp (Bind _ x (Let c val ty) sc) [] - = "let " ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (Let c val ty) sc) [] + = "let " ++ showCount c ++ show x ++ " : " ++ show ty ++ " = " ++ show val ++ " in " ++ show sc - showApp (Bind _ x (Pi c Explicit ty) sc) [] - = "((" ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (Pi c Explicit ty) sc) [] + = "((" ++ showCount c ++ show x ++ " : " ++ show ty ++ ") -> " ++ show sc ++ ")" - showApp (Bind _ x (Pi c Implicit ty) sc) [] - = "{" ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (Pi c Implicit ty) sc) [] + = "{" ++ showCount c ++ show x ++ " : " ++ show ty ++ "} -> " ++ show sc - showApp (Bind _ x (Pi c AutoImplicit ty) sc) [] - = "{auto" ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (Pi c AutoImplicit ty) sc) [] + = "{auto" ++ showCount c ++ show x ++ " : " ++ show ty ++ "} -> " ++ show sc - showApp (Bind _ x (PVar c Explicit ty) sc) [] - = "pat " ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (PVar c Explicit ty) sc) [] + = "pat " ++ showCount c ++ show x ++ " : " ++ show ty ++ " => " ++ show sc - showApp (Bind _ x (PVar c Implicit ty) sc) [] - = "{pat " ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (PVar c Implicit ty) sc) [] + = "{pat " ++ showCount c ++ show x ++ " : " ++ show ty ++ "} => " ++ show sc - showApp (Bind _ x (PVar c AutoImplicit ty) sc) [] - = "{auto pat " ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (PVar c AutoImplicit ty) sc) [] + = "{auto pat " ++ showCount c ++ show x ++ " : " ++ show ty ++ "} => " ++ show sc - showApp (Bind _ x (PLet c val ty) sc) [] - = "plet " ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (PLet c val ty) sc) [] + = "plet " ++ showCount c ++ show x ++ " : " ++ show ty ++ " = " ++ show val ++ " in " ++ show sc - showApp (Bind _ x (PVTy c ty) sc) [] - = "pty " ++ showCount c ++ show x ++ " : " ++ show ty ++ + showApp (Bind _ x (PVTy c ty) sc) [] + = "pty " ++ showCount c ++ show x ++ " : " ++ show ty ++ " => " ++ show sc showApp (App _ _ _) [] = "[can't happen]" showApp (As _ n tm) [] = show n ++ "@" ++ show tm diff --git a/src/Core/TTC.idr b/src/Core/TTC.idr index 8feb80d..fab40f4 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -19,13 +19,13 @@ import Utils.Binary export TTC FC where - toBuf b (MkFC file startPos endPos) + toBuf b (MkFC file startPos endPos) = do tag 0; toBuf b file; toBuf b startPos; toBuf b endPos toBuf b EmptyFC = tag 1 fromBuf b = case !getTag of - 0 => do f <- fromBuf b; + 0 => do f <- fromBuf b; s <- fromBuf b; e <- fromBuf b pure (MkFC f s e) 1 => pure EmptyFC @@ -41,7 +41,7 @@ TTC Name where toBuf b (Nested x y) = do tag 5; toBuf b x; toBuf b y toBuf b (CaseBlock x y) = do tag 6; toBuf b x; toBuf b y toBuf b (WithBlock x y) = do tag 7; toBuf b x; toBuf b y - toBuf b (Resolved x) + toBuf b (Resolved x) = throw (InternalError ("Can't write resolved name " ++ show x)) fromBuf b @@ -70,8 +70,8 @@ TTC Name where y <- fromBuf b pure (WithBlock x y) _ => corrupt "Name" - -export + +export TTC RigCount where toBuf b Rig0 = tag 0 toBuf b Rig1 = tag 1 @@ -104,10 +104,10 @@ TTC Constant where toBuf b (Str x) = do tag 2; toBuf b x toBuf b (Ch x) = do tag 3; toBuf b x toBuf b (Db x) = do tag 4; toBuf b x - + toBuf b WorldVal = tag 5 toBuf b IntType = tag 6 - toBuf b IntegerType = tag 7 + toBuf b IntegerType = tag 7 toBuf b StringType = tag 8 toBuf b CharType = tag 9 toBuf b DoubleType = tag 10 @@ -198,7 +198,7 @@ mutual export TTC (Term vars) where - toBuf b (Local {name} fc c idx y) + toBuf b (Local {name} fc c idx y) = if idx < 244 then do toBuf b (prim__truncBigInt_B8 (12 + cast idx)) toBuf b c @@ -207,26 +207,26 @@ mutual toBuf b c toBuf b name toBuf b idx - toBuf b (Ref fc nt name) + toBuf b (Ref fc nt name) = do tag 1; toBuf b nt; toBuf b name - toBuf b (Meta fc n i xs) + toBuf b (Meta fc n i xs) = do tag 2; toBuf b n; toBuf b xs - toBuf b (Bind fc x bnd scope) + toBuf b (Bind fc x bnd scope) = do tag 3; - toBuf b x; + toBuf b x; toBuf b bnd; toBuf b scope - toBuf b (App fc fn arg) + toBuf b (App fc fn arg) = do tag 4; toBuf b fn; toBuf b arg -- let (fn, args) = getFnArgs (App fc fn arg) --- toBuf b fn; -- toBuf b p; +-- toBuf b fn; -- toBuf b p; -- toBuf b args toBuf b (As fc as tm) = do tag 5; toBuf b as; toBuf b tm - toBuf b (TDelayed fc r tm) + toBuf b (TDelayed fc r tm) = do tag 6; toBuf b r; toBuf b tm toBuf b (TDelay fc r ty tm) @@ -235,15 +235,15 @@ mutual toBuf b (TForce fc tm) = do tag 8; toBuf b tm - toBuf b (PrimVal fc c) + toBuf b (PrimVal fc c) = do tag 9; toBuf b c - toBuf b (Erased fc) + toBuf b (Erased fc) = tag 10 toBuf b (TType fc) = tag 11 - fromBuf b + fromBuf b = case !getTag of 0 => do c <- fromBuf b name <- fromBuf b @@ -264,7 +264,7 @@ mutual pure (As emptyFC as tm) 6 => do lr <- fromBuf b; tm <- fromBuf b pure (TDelayed emptyFC lr tm) - 7 => do lr <- fromBuf b; + 7 => do lr <- fromBuf b; ty <- fromBuf b; tm <- fromBuf b pure (TDelay emptyFC lr ty tm) 8 => do tm <- fromBuf b @@ -280,24 +280,24 @@ mutual export TTC Pat where - toBuf b (PAs fc x y) + toBuf b (PAs fc x y) = do tag 0; toBuf b fc; toBuf b x; toBuf b y - toBuf b (PCon fc x t arity xs) + toBuf b (PCon fc x t arity xs) = do tag 1; toBuf b fc; toBuf b x; toBuf b t; toBuf b arity; toBuf b xs - toBuf b (PTyCon fc x arity xs) + toBuf b (PTyCon fc x arity xs) = do tag 2; toBuf b fc; toBuf b x; toBuf b arity; toBuf b xs toBuf b (PConst fc c) = do tag 3; toBuf b fc; toBuf b c toBuf b (PArrow fc x s t) = do tag 4; toBuf b fc; toBuf b x; toBuf b s; toBuf b t - toBuf b (PDelay fc x t y) + toBuf b (PDelay fc x t y) = do tag 5; toBuf b fc; toBuf b x; toBuf b t; toBuf b y - toBuf b (PLoc fc x) + toBuf b (PLoc fc x) = do tag 6; toBuf b fc; toBuf b x - toBuf b (PUnmatchable fc x) + toBuf b (PUnmatchable fc x) = do tag 7; toBuf b fc; toBuf b x - fromBuf b + fromBuf b = case !getTag of 0 => do fc <- fromBuf b; x <- fromBuf b; y <- fromBuf b @@ -327,15 +327,15 @@ TTC Pat where mutual export TTC (CaseTree vars) where - toBuf b (Case {name} idx x scTy xs) + toBuf b (Case {name} idx x scTy xs) = do tag 0; toBuf b name; toBuf b idx; toBuf b xs - toBuf b (STerm x) + toBuf b (STerm x) = do tag 1; toBuf b x - toBuf b (Unmatched msg) + toBuf b (Unmatched msg) = do tag 2; toBuf b msg toBuf b Impossible = tag 3 - fromBuf b + fromBuf b = case !getTag of 0 => do name <- fromBuf b; idx <- fromBuf b xs <- fromBuf b @@ -349,16 +349,16 @@ mutual export TTC (CaseAlt vars) where - toBuf b (ConCase x t args y) + toBuf b (ConCase x t args y) = do tag 0; toBuf b x; toBuf b t; toBuf b args; toBuf b y - toBuf b (DelayCase ty arg y) + toBuf b (DelayCase ty arg y) = do tag 1; toBuf b ty; toBuf b arg; toBuf b y toBuf b (ConstCase x y) = do tag 2; toBuf b x; toBuf b y toBuf b (DefaultCase x) = do tag 3; toBuf b x - fromBuf b + fromBuf b = case !getTag of 0 => do x <- fromBuf b; t <- fromBuf b args <- fromBuf b; y <- fromBuf b @@ -374,7 +374,7 @@ mutual export TTC (Env Term vars) where toBuf b [] = pure () - toBuf b ((::) bnd env) + toBuf b ((::) bnd env) = do toBuf b bnd; toBuf b env -- Length has to correspond to length of 'vars' @@ -390,7 +390,7 @@ TTC Visibility where toBuf b Export = tag 1 toBuf b Public = tag 2 - fromBuf b + fromBuf b = case !getTag of 0 => pure Private 1 => pure Export @@ -403,7 +403,7 @@ TTC PartialReason where toBuf b (BadCall xs) = do tag 1; toBuf b xs toBuf b (RecPath xs) = do tag 2; toBuf b xs - fromBuf b + fromBuf b = case !getTag of 0 => pure NotStrictlyPositive 1 => do xs <- fromBuf b @@ -429,14 +429,14 @@ TTC Terminating where export TTC Covering where toBuf b IsCovering = tag 0 - toBuf b (MissingCases ms) + toBuf b (MissingCases ms) = do tag 1 toBuf b ms - toBuf b (NonCoveringCall ns) + toBuf b (NonCoveringCall ns) = do tag 2 toBuf b ns - fromBuf b + fromBuf b = case !getTag of 0 => pure IsCovering 1 => do ms <- fromBuf b @@ -544,7 +544,7 @@ TTC (PrimFn n) where 35 => do ty <- fromBuf b; pure (ShiftL ty) 36 => do ty <- fromBuf b; pure (ShiftR ty) _ => corrupt "PrimFn 2" - + fromBuf3 : Ref Bin Binary -> Core (PrimFn 3) fromBuf3 b @@ -552,7 +552,7 @@ TTC (PrimFn n) where 18 => pure StrSubstr 100 => pure BelieveMe _ => corrupt "PrimFn 3" - + mutual export TTC (CExp vars) where @@ -671,7 +671,7 @@ TTC CDef where toBuf b (MkForeign cs args ret) = do tag 2; toBuf b cs; toBuf b args; toBuf b ret toBuf b (MkError cexpr) = do tag 3; toBuf b cexpr - fromBuf b + fromBuf b = case !getTag of 0 => do args <- fromBuf b; cexpr <- fromBuf b pure (MkFun args cexpr) @@ -734,7 +734,7 @@ TTC PrimNames where export TTC Def where toBuf b None = tag 0 - toBuf b (PMDef r args ct rt pats) + toBuf b (PMDef r args ct rt pats) = do tag 1; toBuf b args; toBuf b ct; toBuf b rt; toBuf b pats toBuf b (ExternDef a) = do tag 2; toBuf b a @@ -743,22 +743,22 @@ TTC Def where toBuf b (Builtin a) = throw (InternalError "Trying to serialise a Builtin") toBuf b (DCon t arity) = do tag 4; toBuf b t; toBuf b arity - toBuf b (TCon t arity parampos detpos ms datacons) + toBuf b (TCon t arity parampos detpos ms datacons) = do tag 5; toBuf b t; toBuf b arity; toBuf b parampos toBuf b detpos; toBuf b ms; toBuf b datacons - toBuf b (Hole locs p) + toBuf b (Hole locs p) = do tag 6; toBuf b locs; toBuf b p - toBuf b (BySearch c depth def) + toBuf b (BySearch c depth def) = do tag 7; toBuf b c; toBuf b depth; toBuf b def - toBuf b (Guess guess envb constraints) + toBuf b (Guess guess envb constraints) = do tag 8; toBuf b guess; toBuf b envb; toBuf b constraints toBuf b ImpBind = tag 9 toBuf b Delayed = tag 10 - fromBuf b + fromBuf b = case !getTag of 0 => pure None - 1 => do args <- fromBuf b + 1 => do args <- fromBuf b ct <- fromBuf b rt <- fromBuf b pats <- fromBuf b @@ -771,7 +771,7 @@ TTC Def where 4 => do t <- fromBuf b; a <- fromBuf b pure (DCon t a) 5 => do t <- fromBuf b; a <- fromBuf b - ps <- fromBuf b; dets <- fromBuf b; + ps <- fromBuf b; dets <- fromBuf b; ms <- fromBuf b; cs <- fromBuf b pure (TCon t a ps dets ms cs) 6 => do l <- fromBuf b @@ -839,7 +839,7 @@ TTC SCCall where export TTC GlobalDef where - toBuf b gdef + toBuf b gdef = -- Only write full details for user specified names. The others will -- be holes where all we will ever need after loading is the definition do toBuf b (fullname gdef) @@ -859,22 +859,22 @@ TTC GlobalDef where toBuf b (noCycles gdef) toBuf b (sizeChange gdef) - fromBuf b + fromBuf b = do name <- fromBuf b def <- fromBuf b cdef <- fromBuf b - refsList <- fromBuf b; + refsList <- fromBuf b; let refs = map fromList refsList if isUserName name - then do loc <- fromBuf b; - ty <- fromBuf b; eargs <- fromBuf b; + then do loc <- fromBuf b; + ty <- fromBuf b; eargs <- fromBuf b; mul <- fromBuf b; vars <- fromBuf b vis <- fromBuf b; tot <- fromBuf b fl <- fromBuf b inv <- fromBuf b c <- fromBuf b sc <- fromBuf b - pure (MkGlobalDef loc name ty eargs mul vars vis + pure (MkGlobalDef loc name ty eargs mul vars vis tot fl refs inv c True def cdef sc) else do let fc = emptyFC pure (MkGlobalDef fc name (Erased fc) [] @@ -882,7 +882,7 @@ TTC GlobalDef where False False True def cdef []) -- decode : Context -> Int -> ContextEntry -> Core GlobalDef -Core.Context.decode gam idx (Coded bin) +Core.Context.decode gam idx (Coded bin) = do b <- newRef Bin bin def <- fromBuf b let a = getContent gam diff --git a/src/Core/Termination.idr b/src/Core/Termination.idr index 5c0e15a..e573ff9 100644 --- a/src/Core/Termination.idr +++ b/src/Core/Termination.idr @@ -41,8 +41,8 @@ totRefsIn defs ty = totRefs defs (keys (getRefs (Resolved (-1)) ty)) scEq : Term vars -> Term vars -> Bool scEq (Local _ _ idx _) (Local _ _ idx' _) = idx == idx' scEq (Ref _ _ n) (Ref _ _ n') = n == n' -scEq (Meta _ _ i args) _ = True -scEq _ (Meta _ _ i args) = True +scEq (Meta _ _ i args) _ = True +scEq _ (Meta _ _ i args) = True scEq (Bind _ _ b sc) (Bind _ _ b' sc') = False -- not checkable scEq (App _ f a) (App _ f' a') = scEq f f' && scEq a a' scEq (As _ a p) p' = scEq p p' @@ -69,8 +69,8 @@ mutual List (Nat, Term vars) -> -- LHS args and their position Term vars -> -- Right hand side Core (List SCCall) - findSC {vars} defs env g pats (Bind fc n b sc) - = pure $ + findSC {vars} defs env g pats (Bind fc n b sc) + = pure $ !(findSCbinder b) ++ !(findSC defs (b :: env) g (map (\ (p, tm) => (p, weaken tm)) pats) sc) where @@ -97,7 +97,7 @@ mutual pure (concat scs) (_, Ref fc Func fn, args) => do Just ty <- lookupTyExact fn (gamma defs) - | Nothing => + | Nothing => findSCcall defs env Unguarded pats fc fn 0 args arity <- getArity defs [] ty findSCcall defs env Unguarded pats fc fn arity args @@ -109,7 +109,7 @@ mutual -- arity (i.e. the arity of the function we're calling) to ensure that -- it's noted that we don't know the size change relationship with the -- extra arguments. - expandToArity : Nat -> List (Maybe (Nat, SizeChange)) -> + expandToArity : Nat -> List (Maybe (Nat, SizeChange)) -> List (Maybe (Nat, SizeChange)) expandToArity Z xs = xs expandToArity (S k) (x :: xs) = x :: expandToArity k xs @@ -144,29 +144,29 @@ mutual = if assertedSmaller big tm then True else case getFnArgs tm of - (Ref _ (DataCon t a) cn, args) + (Ref _ (DataCon t a) cn, args) => any (smaller True defs big s) args _ => case s of - App _ f _ => smaller inc defs big f tm + App _ f _ => smaller inc defs big f tm -- Higher order recursive argument _ => False -- if the argument is an 'assert_smaller', return the thing it's smaller than asserted : Name -> Term vars -> Maybe (Term vars) - asserted aSmaller tm + asserted aSmaller tm = case getFnArgs tm of - (Ref _ nt fn, [_, _, b, _]) + (Ref _ nt fn, [_, _, b, _]) => if fn == aSmaller then Just b else Nothing _ => Nothing -- Calculate the size change for the given argument. - -- i.e., return the size relationship of the given argument with an entry + -- i.e., return the size relationship of the given argument with an entry -- in 'pats'; the position in 'pats' and the size change. -- Nothing if there is no relation with any of them. mkChange : Defs -> Name -> - (pats : List (Nat, Term vars)) -> + (pats : List (Nat, Term vars)) -> (arg : Term vars) -> Maybe (Nat, SizeChange) mkChange defs aSmaller [] arg = Nothing @@ -184,7 +184,7 @@ mutual -- rather than treating the definitions separately. getCasePats : Defs -> Name -> List (Nat, Term vars) -> List (Term vars) -> - Core (Maybe (List (vs ** (Env Term vs, + Core (Maybe (List (vs ** (Env Term vs, List (Nat, Term vs), Term vs)))) getCasePats {vars} defs n pats args = case !(lookupDefExact n (gamma defs)) of @@ -216,11 +216,11 @@ mutual urhs (App fc f a) = App fc (updateRHS ms f) (updateRHS ms a) urhs (As fc a p) = As fc (updateRHS ms a) (updateRHS ms p) urhs (TDelayed fc r ty) = TDelayed fc r (updateRHS ms ty) - urhs (TDelay fc r ty tm) + urhs (TDelay fc r ty tm) = TDelay fc r (updateRHS ms ty) (updateRHS ms tm) urhs (TForce fc tm) = TForce fc (updateRHS ms tm) urhs (Bind fc x b sc) - = Bind fc x (map (updateRHS ms) b) + = Bind fc x (map (updateRHS ms) b) (updateRHS (map (\vt => (weaken (fst vt), weaken (snd vt))) ms) sc) urhs (PrimVal fc c) = PrimVal fc c urhs (Erased fc) = Erased fc @@ -229,7 +229,7 @@ mutual updatePat : List (Term vs, Term vs') -> (Nat, Term vs) -> (Nat, Term vs') updatePat ms (n, tm) = (n, updateRHS ms tm) - matchArgs : (vs ** (Env Term vs, Term vs, Term vs)) -> + matchArgs : (vs ** (Env Term vs, Term vs, Term vs)) -> (vs ** (Env Term vs, List (Nat, Term vs), Term vs)) matchArgs (_ ** (env', lhs, rhs)) = let patMatch = reverse (zip args (getArgs lhs)) in @@ -246,7 +246,7 @@ mutual List (Nat, Term vars) -> FC -> Name -> Nat -> List (Term vars) -> Core (List SCCall) - findSCcall defs env g pats fc fn_in arity args + findSCcall defs env g pats fc fn_in arity args -- Under 'assert_total' we assume that all calls are fine, so leave -- the size change list empty = do Just gdef <- lookupCtxtExact fn_in (gamma defs) @@ -262,16 +262,16 @@ mutual Just ps => do scs <- traverse (findInCase defs g) ps pure (concat scs))] (do scs <- traverse (findSC defs env g pats) args - pure ([MkSCCall fn - (expandToArity arity - (map (mkChange defs aSmaller pats) args))] + pure ([MkSCCall fn + (expandToArity arity + (map (mkChange defs aSmaller pats) args))] ++ concat scs)) findInCase : {auto c : Ref Ctxt Defs} -> - Defs -> Guardedness -> + Defs -> Guardedness -> (vs ** (Env Term vs, List (Nat, Term vs), Term vs)) -> Core (List SCCall) - findInCase defs g (_ ** (env, pats, tm)) + findInCase defs g (_ ** (env, pats, tm)) = do logC 10 (do ps <- traverse toFullNames (map snd pats) pure ("Looking in case args " ++ show ps)) logTermNF 10 " =" env tm @@ -281,26 +281,26 @@ mutual -- Remove all laziness annotations which are nothing to do with coinduction, -- meaning that all only Force/Delay left is to guard coinductive calls. delazy : Defs -> Term vars -> Term vars -delazy defs (TDelayed fc r tm) +delazy defs (TDelayed fc r tm) = let tm' = delazy defs tm in case r of LInf => TDelayed fc r tm' _ => tm' -delazy defs (TDelay fc r ty tm) +delazy defs (TDelay fc r ty tm) = let ty' = delazy defs ty tm' = delazy defs tm in case r of LInf => TDelay fc r ty' tm' _ => tm' delazy defs (Meta fc n i args) = Meta fc n i (map (delazy defs) args) -delazy defs (Bind fc x b sc) +delazy defs (Bind fc x b sc) = Bind fc x (map (delazy defs) b) (delazy defs sc) delazy defs (App fc f a) = App fc (delazy defs f) (delazy defs a) delazy defs (As fc a p) = As fc (delazy defs a) (delazy defs p) delazy defs tm = tm findCalls : {auto c : Ref Ctxt Defs} -> - Defs -> (vars ** (Env Term vars, Term vars, Term vars)) -> + Defs -> (vars ** (Env Term vars, Term vars, Term vars)) -> Core (List SCCall) findCalls defs (_ ** (env, lhs, rhs_in)) = do let pargs = getArgs (delazy defs lhs) @@ -310,7 +310,7 @@ findCalls defs (_ ** (env, lhs, rhs_in)) getSC : {auto c : Ref Ctxt Defs} -> Defs -> Def -> Core (List SCCall) -getSC defs (PMDef _ args _ _ pats) +getSC defs (PMDef _ args _ _ pats) = do sc <- traverse (findCalls defs) pats pure (concat sc) getSC defs _ = pure [] @@ -338,7 +338,7 @@ nextArg x = x + 1 initArgs : {auto a : Ref APos Arg} -> Nat -> Core (List (Maybe (Arg, SizeChange))) initArgs Z = pure [] -initArgs (S k) +initArgs (S k) = do arg <- get APos put APos (nextArg arg) args' <- initArgs k @@ -351,7 +351,7 @@ initArgs (S k) -- use that rather than continuing to traverse the graph! checkSC : {auto a : Ref APos Arg} -> {auto c : Ref Ctxt Defs} -> - Defs -> + Defs -> Name -> -- function we're checking List (Maybe (Arg, SizeChange)) -> -- functions arguments and change List (Name, List (Maybe Arg)) -> -- calls we've seen so far @@ -398,7 +398,7 @@ checkSC defs f args path then case term of NotTerminating (RecPath _) => -- might have lost information while assuming this - -- was mutually recursive, so start again with new + -- was mutually recursive, so start again with new -- arguments (that is, where we'd start if the -- function was the top level thing we were checking) do args' <- initArgs (length (fnArgs sc)) @@ -419,11 +419,11 @@ checkSC defs f args path calcTerminating : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core Terminating -calcTerminating loc n +calcTerminating loc n = do defs <- get Ctxt case !(lookupCtxtExact n (gamma defs)) of Nothing => throw (UndefinedName loc n) - Just def => + Just def => case !(totRefs defs (nub !(addCases defs (keys (refersTo def))))) of IsTerminating => do let ty = type def @@ -455,7 +455,7 @@ checkTerminating : {auto c : Ref Ctxt Defs} -> checkTerminating loc n = do tot <- getTotality loc n case isTerminating tot of - Unchecked => + Unchecked => do tot' <- calcTerminating loc n setTerminating loc n tot' pure tot' @@ -468,7 +468,7 @@ nameIn defs tyns (NBind fc x b sc) else do sc' <- sc defs (toClosure defaultOpts [] (Erased fc)) nameIn defs tyns sc' nameIn defs tyns (NApp _ _ args) - = anyM (nameIn defs tyns) + = anyM (nameIn defs tyns) !(traverse (evalClosure defs) args) nameIn defs tyns (NTCon _ n _ _ args) = if n `elem` tyns @@ -476,7 +476,7 @@ nameIn defs tyns (NTCon _ n _ _ args) else do args' <- traverse (evalClosure defs) args anyM (nameIn defs tyns) args' nameIn defs tyns (NDCon _ n _ _ args) - = anyM (nameIn defs tyns) + = anyM (nameIn defs tyns) !(traverse (evalClosure defs) args) nameIn defs tyns _ = pure False @@ -485,10 +485,10 @@ nameIn defs tyns _ = pure False posArg : Defs -> List Name -> NF [] -> Core Terminating -- a tyn can only appear in the parameter positions of -- tc; report positivity failure if it appears anywhere else -posArg defs tyns (NTCon _ tc _ _ args) +posArg defs tyns (NTCon _ tc _ _ args) = let testargs : List (Closure []) = case !(lookupDefExact tc (gamma defs)) of - Just (TCon _ _ params _ _ _) => + Just (TCon _ _ params _ _ _) => dropParams 0 params args _ => args in if !(anyM (nameIn defs tyns) @@ -503,7 +503,7 @@ posArg defs tyns (NTCon _ tc _ _ args) then dropParams (S i) ps xs else x :: dropParams (S i) ps xs -- a tyn can not appear as part of ty -posArg defs tyns (NBind fc x (Pi c e ty) sc) +posArg defs tyns (NBind fc x (Pi c e ty) sc) = if !(nameIn defs tyns ty) then pure (NotTerminating NotStrictlyPositive) else do sc' <- sc defs (toClosure defaultOpts [] (Erased fc)) @@ -511,20 +511,20 @@ posArg defs tyns (NBind fc x (Pi c e ty) sc) posArg defs tyn _ = pure IsTerminating checkPosArgs : Defs -> List Name -> NF [] -> Core Terminating -checkPosArgs defs tyns (NBind fc x (Pi c e ty) sc) +checkPosArgs defs tyns (NBind fc x (Pi c e ty) sc) = case !(posArg defs tyns ty) of - IsTerminating => - checkPosArgs defs tyns + IsTerminating => + checkPosArgs defs tyns !(sc defs (toClosure defaultOpts [] (Erased fc))) bad => pure bad checkPosArgs defs tyns _ = pure IsTerminating checkCon : {auto c : Ref Ctxt Defs} -> Defs -> List Name -> Name -> Core Terminating -checkCon defs tyns cn +checkCon defs tyns cn = case !(lookupTyExact cn (gamma defs)) of Nothing => pure Unchecked - Just ty => + Just ty => case !(totRefsIn defs ty) of IsTerminating => checkPosArgs defs tyns !(nf defs [] ty) bad => pure bad @@ -541,12 +541,12 @@ checkData defs tyns (c :: cs) -- return whether it's terminating, along with its data constructors calcPositive : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core (Terminating, List Name) -calcPositive loc n +calcPositive loc n = do defs <- get Ctxt case !(lookupDefTyExact n (gamma defs)) of - Just (TCon _ _ _ _ tns dcons, ty) => + Just (TCon _ _ _ _ tns dcons, ty) => case !(totRefsIn defs ty) of - IsTerminating => + IsTerminating => do t <- checkData defs (n :: tns) dcons pure (t , dcons) bad => pure (bad, dcons) @@ -570,7 +570,7 @@ checkPositive loc n_in t => pure t -- Check and record totality of the given name; positivity if it's a data --- type, termination if it's a function +-- type, termination if it's a function export checkTotal : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core Terminating diff --git a/src/Core/Unify.idr b/src/Core/Unify.idr index a7792d0..3b67df9 100644 --- a/src/Core/Unify.idr +++ b/src/Core/Unify.idr @@ -73,7 +73,7 @@ interface Unify (tm : List Name -> Type) where Ref UST UState -> UnifyMode -> FC -> Env Term vars -> - tm vars -> tm vars -> + tm vars -> tm vars -> Core UnifyResult -- As unify but at the top level can allow lazy/non-lazy to be mixed in -- order to infer annotations @@ -81,7 +81,7 @@ interface Unify (tm : List Name -> Type) where Ref UST UState -> UnifyMode -> FC -> Env Term vars -> - tm vars -> tm vars -> + tm vars -> tm vars -> Core UnifyResult unifyWithLazyD = unifyD @@ -89,22 +89,22 @@ interface Unify (tm : List Name -> Type) where -- In calls to unification, the first argument is the given type, and the second -- argument is the expected type. export -unify : Unify tm => +unify : Unify tm => {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> UnifyMode -> FC -> Env Term vars -> - tm vars -> tm vars -> + tm vars -> tm vars -> Core UnifyResult unify {c} {u} = unifyD c u export -unifyWithLazy : Unify tm => +unifyWithLazy : Unify tm => {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> UnifyMode -> FC -> Env Term vars -> - tm vars -> tm vars -> + tm vars -> tm vars -> Core UnifyResult unifyWithLazy {c} {u} = unifyWithLazyD c u @@ -114,7 +114,7 @@ search : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> FC -> RigCount -> (defaults : Bool) -> (depth : Nat) -> - (defining : Name) -> (topTy : Term vars) -> Env Term vars -> + (defining : Name) -> (topTy : Term vars) -> Env Term vars -> Core (Term vars) ufail : FC -> String -> Core a @@ -122,15 +122,15 @@ ufail loc msg = throw (GenericMsg loc msg) convertError : {auto c : Ref Ctxt Defs} -> FC -> Env Term vars -> NF vars -> NF vars -> Core a -convertError loc env x y +convertError loc env x y = do defs <- get Ctxt empty <- clearDefs defs - throw (CantConvert loc env !(quote empty env x) + throw (CantConvert loc env !(quote empty env x) !(quote empty env y)) convertErrorS : {auto c : Ref Ctxt Defs} -> Bool -> FC -> Env Term vars -> NF vars -> NF vars -> Core a -convertErrorS s loc env x y +convertErrorS s loc env x y = if s then convertError loc env y x else convertError loc env x y @@ -144,9 +144,9 @@ postpone loc logstr env x y logC 10 $ do xq <- quote defs env x yq <- quote defs env y - pure (logstr ++ ": " ++ show !(toFullNames xq) ++ + pure (logstr ++ ": " ++ show !(toFullNames xq) ++ " =?= " ++ show !(toFullNames yq)) - c <- addConstraint (MkConstraint loc env !(quote empty env x) + c <- addConstraint (MkConstraint loc env !(quote empty env x) !(quote empty env y)) pure (constrain c) @@ -173,20 +173,20 @@ unifyArgs mode loc env (cx :: cxs) (cy :: cys) pure (union res cs) _ => do cs <- unifyArgs mode loc env cxs cys -- TODO: Fix this bit! See p59 Ulf's thesis --- c <- addConstraint --- (MkSeqConstraint loc env +-- c <- addConstraint +-- (MkSeqConstraint loc env -- (map (quote gam env) (cx :: cxs)) -- (map (quote gam env) (cy :: cys))) pure (union res cs) -- [c] unifyArgs mode loc env _ _ = ufail loc "" --- Get the variables in an application argument list; fail if any arguments +-- 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 getVars : List Nat -> List (NF vars) -> Maybe (List (Var vars)) getVars got [] = Just [] -getVars got (NApp fc (NLocal r idx v) [] :: xs) +getVars got (NApp fc (NLocal r idx v) [] :: xs) = if inArgs idx got then Nothing else do xs' <- getVars (idx :: got) xs pure (MkVar v :: xs') @@ -195,9 +195,9 @@ getVars got (NApp fc (NLocal r idx v) [] :: xs) -- Nat is linear time in Idris 1! inArgs : Nat -> List Nat -> Bool inArgs n [] = False - inArgs n (n' :: ns) + inArgs n (n' :: ns) = if toIntegerNat n == toIntegerNat n' then True else inArgs n ns -getVars got (NAs _ _ p :: xs) = getVars got (p :: xs) +getVars got (NAs _ _ p :: xs) = getVars got (p :: xs) getVars _ (_ :: xs) = Nothing -- Make a sublist representing the variables used in the application. @@ -206,13 +206,13 @@ getVars _ (_ :: xs) = Nothing toSubVars : (vars : List Name) -> List (Var vars) -> (newvars ** SubVars newvars vars) toSubVars [] xs = ([] ** SubRefl) -toSubVars (n :: ns) xs +toSubVars (n :: ns) xs -- If there's a proof 'First' in 'xs', then 'n' should be kept, -- otherwise dropped -- (Remember: 'n' might be shadowed; looking for 'First' ensures we -- get the *right* proof that the name is in scope!) = let (_ ** svs) = toSubVars ns (dropFirst xs) in - if anyFirst xs + if anyFirst xs then (_ ** KeepCons svs) else (_ ** DropCons svs) where @@ -239,7 +239,7 @@ toSubVars (n :: ns) xs patternEnv : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {vars : _} -> - Env Term vars -> List (Closure vars) -> + Env Term vars -> List (Closure vars) -> Core (Maybe (newvars ** (List (Var newvars), SubVars newvars vars))) patternEnv {vars} env args @@ -248,9 +248,9 @@ patternEnv {vars} env args args' <- traverse (evalArg empty) args case getVars [] args' of Nothing => pure Nothing - Just vs => + Just vs => let (newvars ** svs) = toSubVars _ vs in - pure (Just (newvars ** + pure (Just (newvars ** (updateVars vs svs, svs))) where -- Update the variable list to point into the sub environment @@ -262,10 +262,10 @@ patternEnv {vars} env args = case subElem p svs of Nothing => updateVars ps svs Just p' => p' :: updateVars ps svs - + getVarsBelowTm : Nat -> List (Term vars) -> Maybe (List (Var vars)) getVarsBelowTm max [] = Just [] -getVarsBelowTm max (Local fc r idx v :: xs) +getVarsBelowTm max (Local fc r idx v :: xs) = if idx >= max then Nothing else do xs' <- getVarsBelowTm idx xs pure (MkVar v :: xs') @@ -275,7 +275,7 @@ export patternEnvTm : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {vars : _} -> - Env Term vars -> List (Term vars) -> + Env Term vars -> List (Term vars) -> Core (Maybe (newvars ** (List (Var newvars), SubVars newvars vars))) patternEnvTm {vars} env args @@ -283,9 +283,9 @@ patternEnvTm {vars} env args empty <- clearDefs defs case getVarsBelowTm 1000000 args of Nothing => pure Nothing - Just vs => + Just vs => let (newvars ** svs) = toSubVars _ vs in - pure (Just (newvars ** + pure (Just (newvars ** (updateVars vs svs, svs))) where -- Update the variable list to point into the sub environment @@ -305,7 +305,7 @@ patternEnvTm {vars} env args instantiate : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {newvars : _} -> - FC -> Env Term vars -> + FC -> Env Term vars -> (metavar : Name) -> (mref : Int) -> (mdef : GlobalDef) -> List (Var newvars) -> -- Variable each argument maps to Term vars -> -- original, just for error message @@ -324,14 +324,14 @@ instantiate {newvars} loc env mname mref mdef locs otm tm defs <- get Ctxt rhs <- mkDef [] newvars (snocList newvars) CompatPre (rewrite appendNilRightNeutral newvars in locs) - (rewrite appendNilRightNeutral newvars in tm) + (rewrite appendNilRightNeutral newvars in tm) ty logTerm 5 ("Instantiated: " ++ show mname) ty log 5 ("From vars: " ++ show newvars) logTerm 5 "Definition" rhs let simpleDef = isSimple rhs - let newdef = record { definition = - PMDef simpleDef [] (STerm rhs) (STerm rhs) [] + let newdef = record { definition = + PMDef simpleDef [] (STerm rhs) (STerm rhs) [] } mdef addDef (Resolved mref) newdef removeHole mref @@ -345,7 +345,7 @@ instantiate {newvars} loc env mname mref mdef locs otm tm isSimple (TType _) = True isSimple _ = False - updateLoc : {v : Nat} -> List (Var vs) -> .(IsVar name v vs') -> + updateLoc : {v : Nat} -> List (Var vs) -> .(IsVar name v vs') -> Maybe (Var vs) updateLoc [] el = Nothing updateLoc (p :: ps) First = Just p @@ -360,8 +360,8 @@ instantiate {newvars} loc env mname mref mdef locs otm tm Just (Local fc r _ p') updateLocs {vs} locs (Bind fc x b sc) = do b' <- updateLocsB b - sc' <- updateLocs - (MkVar First :: map (\ (MkVar p) => (MkVar (Later p))) locs) + sc' <- updateLocs + (MkVar First :: map (\ (MkVar p) => (MkVar (Later p))) locs) sc Just (Bind fc x b' sc') where @@ -379,15 +379,15 @@ instantiate {newvars} loc env mname mref mdef locs otm tm mkDef : (got : List Name) -> (vs : List Name) -> SnocList vs -> CompatibleVars got rest -> - List (Var (vs ++ got)) -> Term (vs ++ got) -> + List (Var (vs ++ got)) -> Term (vs ++ got) -> Term ts -> Core (Term rest) - mkDef {rest} got [] Empty cvs locs tm ty + mkDef {rest} got [] Empty cvs locs tm ty = do let Just tm' = updateLocs (reverse locs) tm | Nothing => ufail loc ("Can't make solution for " ++ show mname) pure (renameVars cvs tm') mkDef got vs rec cvs locs tm (Bind _ _ (Let _ _ _) sc) = mkDef got vs rec cvs locs tm sc - mkDef got (vs ++ [v]) (Snoc rec) cvs locs tm (Bind bfc x (Pi c _ ty) sc) + mkDef got (vs ++ [v]) (Snoc rec) cvs locs tm (Bind bfc x (Pi c _ ty) sc) = do defs <- get Ctxt sc' <- mkDef (v :: got) vs rec (CompatExt cvs) (rewrite appendAssociative vs [v] got in locs) @@ -395,8 +395,8 @@ instantiate {newvars} loc env mname mref mdef locs otm tm sc pure (Bind bfc x (Lam c Explicit (Erased bfc)) sc') mkDef got (vs ++ [v]) (Snoc rec) cvs locs tm ty - = ufail loc $ "Can't make solution for " ++ show mname - + = ufail loc $ "Can't make solution for " ++ show mname + export solveIfUndefined : {vars : _} -> {auto c : Ref Ctxt Defs} -> @@ -416,7 +416,7 @@ solveIfUndefined env (Meta fc mname idx args) soln | Nothing => throw (InternalError "Can't happen: no definition") instantiate fc env mname idx hdef locs soln stm pure True -solveIfUndefined env metavar soln +solveIfUndefined env metavar soln = pure False isDefInvertible : {auto c : Ref Ctxt Defs} -> @@ -432,17 +432,17 @@ mutual {auto u : Ref UST UState} -> {vars : _} -> (postpone : Bool) -> - FC -> Env Term vars -> NF vars -> NF vars -> + FC -> Env Term vars -> NF vars -> NF vars -> Core UnifyResult - unifyIfEq post loc env x y + unifyIfEq post loc env x y = do defs <- get Ctxt if !(convert defs env x y) then pure success - else if post + else if post then postpone loc "Postponing unifyIfEq" env x y else convertError loc env x y - getArgTypes : Defs -> (fnType : NF vars) -> List (Closure vars) -> + getArgTypes : Defs -> (fnType : NF vars) -> List (Closure vars) -> Core (Maybe (List (NF vars))) getArgTypes defs (NBind _ n (Pi _ _ ty) sc) (a :: as) = do Just scTys <- getArgTypes defs !(sc defs a) as @@ -452,18 +452,18 @@ mutual getArgTypes _ _ _ = pure Nothing headsConvert : {auto c : Ref Ctxt Defs} -> - Env Term vars -> + Env Term vars -> Maybe (List (NF vars)) -> Maybe (List (NF vars)) -> Core Bool headsConvert env (Just vs) (Just ns) = case (reverse vs, reverse ns) of - (v :: _, n :: _) => + (v :: _, n :: _) => do logNF 10 "Converting" env v logNF 10 "......with" env n defs <- get Ctxt convert defs env v n _ => pure False - headsConvert env _ _ + headsConvert env _ _ = do log 10 "Nothing to convert" pure True @@ -492,7 +492,7 @@ mutual -- If the rightmost arguments have the same type, or we don't -- know the types of the arguments, we'll get on with it. if !(headsConvert env vargTys nargTys) - then + then -- Unify the rightmost arguments, with the goal of turning the -- hole application into a pattern form case (reverse margs', reverse args') of @@ -502,7 +502,7 @@ mutual do log 10 "Unifying invertible" ures <- unify mode fc env h f log 10 $ "Constraints " ++ show (constraints ures) - uargs <- unify mode fc env + uargs <- unify mode fc env (NApp fc (NMeta mname mref margs) (reverse hargs)) (con (reverse fargs)) pure (union ures uargs) @@ -510,7 +510,7 @@ mutual do log 10 "Unifying invertible" ures <- unify mode fc env f h log 10 $ "Constraints " ++ show (constraints ures) - uargs <- unify mode fc env + uargs <- unify mode fc env (con (reverse fargs)) (NApp fc (NMeta mname mref margs) (reverse hargs)) pure (union ures uargs)) @@ -521,7 +521,7 @@ mutual (NApp fc (NMeta mname mref margs) margs') (con args') else -- TODO: Cancellable function applications - postpone fc "Postponing hole application [3]" env + postpone fc "Postponing hole application [3]" env (NApp fc (NMeta mname mref margs) margs') (con args') -- Unify a hole application - we have already checked that the hole is @@ -546,7 +546,7 @@ mutual mty <- lookupTyExact n (gamma defs) unifyInvertible swap mode loc env mname mref margs margs' mty (NTCon nfc n t a) args' unifyHoleApp swap mode loc env mname mref margs margs' (NApp nfc (NLocal r idx p) args') - = unifyInvertible swap mode loc env mname mref margs margs' Nothing + = unifyInvertible swap mode loc env mname mref margs margs' Nothing (NApp nfc (NLocal r idx p)) args' unifyHoleApp swap mode loc env mname mref margs margs' tm@(NApp nfc (NMeta n i margs2) args2') = do defs <- get Ctxt @@ -556,15 +556,15 @@ mutual if inv then unifyInvertible swap mode loc env mname mref margs margs' Nothing (NApp nfc (NMeta n i margs2)) args2' - else postponeS swap loc "Postponing hole application" env + else postponeS swap loc "Postponing hole application" env (NApp loc (NMeta mname mref margs) margs') tm where isPatName : Name -> Bool isPatName (PV _ _) = True isPatName _ = False - + unifyHoleApp swap mode loc env mname mref margs margs' tm - = postponeS swap loc "Postponing hole application" env + = postponeS swap loc "Postponing hole application" env (NApp loc (NMeta mname mref margs) margs') tm postponePatVar : {auto c : Ref Ctxt Defs} -> @@ -578,7 +578,7 @@ mutual (soln : NF vars) -> Core UnifyResult postponePatVar swap mode loc env mname mref margs margs' tm - = postponeS swap loc "Not in pattern fragment" env + = postponeS swap loc "Not in pattern fragment" env (NApp loc (NMeta mname mref margs) margs') tm solveHole : {auto c : Ref Ctxt Defs} -> @@ -599,7 +599,7 @@ mutual empty <- clearDefs defs -- if the terms are the same, this isn't a solution -- but they are already unifying, so just return - if solutionHeadSame solnf + if solutionHeadSame solnf then pure success else -- Rather than doing the occurs check here immediately, -- we'll wait until all metavariables are resolved, and in @@ -638,7 +638,7 @@ mutual pure $ "Unifying: " ++ show mname ++ " " ++ show qargs ++ " with " ++ show qtm) case !(patternEnv env args) of - Nothing => + Nothing => do Just hdef <- lookupCtxtExact (Resolved mref) (gamma defs) | _ => postponePatVar swap mode loc env mname mref margs margs' tmnf let Hole _ _ = definition hdef @@ -646,20 +646,20 @@ mutual if invertible hdef then unifyHoleApp swap mode loc env mname mref margs margs' tmnf else postponePatVar swap mode loc env mname mref margs margs' tmnf - Just (newvars ** (locs, submv)) => + Just (newvars ** (locs, submv)) => do tm <- quote empty env tmnf case shrinkTerm tm submv of - Just stm => solveHole fc env mname mref - margs margs' locs submv + Just stm => solveHole fc env mname mref + margs margs' locs submv tm stm tmnf - Nothing => + Nothing => do tm' <- normalise defs env tm case shrinkTerm tm' submv of Nothing => postponeS swap loc "Can't shrink" env (NApp loc (NMeta mname mref margs) margs') tmnf - Just stm => solveHole fc env mname mref - margs margs' locs submv + Just stm => solveHole fc env mname mref + margs margs' locs submv tm stm tmnf -- Unify an application with something else @@ -684,8 +684,8 @@ mutual 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 "Postponing var" - env (NApp xfc (NLocal rx x xp) []) + else postponeS swap loc "Postponing var" + 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 _ _ _ _) @@ -700,13 +700,13 @@ mutual = convertErrorS swap loc env (NApp xfc (NLocal rx x xp) args) y -- If they're already convertible without metavariables, we're done, -- otherwise postpone - unifyApp False mode loc env fc hd args tm + unifyApp False mode loc env fc hd args tm = do gam <- get Ctxt if !(convert gam env (NApp fc hd args) tm) then pure success else postponeS False loc "Postponing constraint" env (NApp fc hd args) tm - unifyApp True mode loc env fc hd args tm + unifyApp True mode loc env fc hd args tm = do gam <- get Ctxt if !(convert gam env tm (NApp fc hd args)) then pure success @@ -717,7 +717,7 @@ mutual {auto u : Ref UST UState} -> {vars : _} -> UnifyMode -> FC -> Env Term vars -> - FC -> NHead vars -> List (Closure vars) -> + FC -> NHead vars -> List (Closure vars) -> FC -> NHead vars -> List (Closure vars) -> Core UnifyResult unifyBothApps mode loc env xfc (NLocal xr x xp) [] yfc (NLocal yr y yp) [] @@ -763,7 +763,7 @@ mutual case !(evalClosure defs c) of NApp _ (NLocal _ _ _) _ => pure $ S !(localsIn cs) _ => localsIn cs - + unifyBothApps mode loc env xfc (NMeta xn xi xargs) xargs' yfc fy yargs' = unifyApp False mode loc env xfc (NMeta xn xi xargs) xargs' (NApp yfc fy yargs') @@ -794,15 +794,15 @@ mutual {auto u : Ref UST UState} -> {vars : _} -> UnifyMode -> FC -> Env Term vars -> - FC -> Name -> Binder (NF vars) -> + FC -> Name -> Binder (NF vars) -> (Defs -> Closure vars -> Core (NF vars)) -> - FC -> Name -> Binder (NF vars) -> + FC -> Name -> Binder (NF vars) -> (Defs -> Closure vars -> Core (NF vars)) -> Core UnifyResult unifyBothBinders mode loc env xfc x (Pi cx ix tx) scx yfc y (Pi cy iy ty) scy = do defs <- get Ctxt if ix /= iy || not (subRig cx cy) - then convertError loc env + then convertError loc env (NBind xfc x (Pi cx ix tx) scx) (NBind yfc y (Pi cy iy ty) scy) else @@ -839,7 +839,7 @@ mutual unifyBothBinders mode loc env xfc x (Lam cx ix tx) scx yfc y (Lam cy iy ty) scy = do defs <- get Ctxt if ix /= iy || not (subRig cx cy) - then convertError loc env + then convertError loc env (NBind xfc x (Lam cx ix tx) scx) (NBind yfc y (Lam cy iy ty) scy) else @@ -861,7 +861,7 @@ mutual pure (union ct cs') unifyBothBinders mode loc env xfc x bx scx yfc y by scy - = convertError loc env + = convertError loc env (NBind xfc x bx scx) (NBind yfc y by scy) @@ -876,7 +876,7 @@ mutual = do gam <- get Ctxt if tagx == tagy then unifyArgs mode loc env xs ys - else convertError loc env + else convertError loc env (NDCon xfc x tagx ax xs) (NDCon yfc y tagy ay ys) unifyNoEta mode loc env (NTCon xfc x tagx ax xs) (NTCon yfc y tagy ay ys) @@ -888,7 +888,7 @@ mutual -- what's injective... -- then postpone loc env (quote empty env (NTCon x tagx ax xs)) -- (quote empty env (NTCon y tagy ay ys)) - else convertError loc env + else convertError loc env (NTCon xfc x tagx ax xs) (NTCon yfc y tagy ay ys) unifyNoEta mode loc env (NDelayed xfc _ x) (NDelayed yfc _ y) @@ -901,14 +901,14 @@ mutual pure (union cs cs') unifyNoEta mode loc env (NApp xfc fx axs) (NApp yfc fy ays) = unifyBothApps mode loc env xfc fx axs yfc fy ays - unifyNoEta mode loc env (NApp xfc hd args) y + unifyNoEta mode loc env (NApp xfc hd args) y = unifyApp False mode loc env xfc hd args y unifyNoEta mode loc env y (NApp yfc hd args) = unifyApp True mode loc env yfc hd args y -- Only try stripping as patterns as a last resort unifyNoEta mode loc env x (NAs _ _ y) = unifyNoEta mode loc env x y unifyNoEta mode loc env (NAs _ _ x) y = unifyNoEta mode loc env x y - unifyNoEta mode loc env x y + unifyNoEta mode loc env x y = do defs <- get Ctxt empty <- clearDefs defs unifyIfEq False loc env x y @@ -940,7 +940,7 @@ mutual export Unify NF where - unifyD _ _ mode loc env (NBind xfc x bx scx) (NBind yfc y by scy) + unifyD _ _ mode loc env (NBind xfc x bx scx) (NBind yfc y by scy) = unifyBothBinders mode loc env xfc x bx scx yfc y by scy unifyD _ _ mode loc env tmx@(NBind xfc x (Lam cx ix tx) scx) tmy = do defs <- get Ctxt @@ -952,10 +952,10 @@ mutual ety <- getEtaType env !(quote empty env tmx) case ety of Just argty => - do etay <- nf defs env + do etay <- nf defs env (Bind xfc x (Lam cx ix argty) - (App xfc - (weaken !(quote empty env tmy)) + (App xfc + (weaken !(quote empty env tmy)) (Local xfc Nothing 0 First))) logNF 10 "Expand" env etay unify mode loc env tmx etay @@ -970,10 +970,10 @@ mutual ety <- getEtaType env !(quote empty env tmy) case ety of Just argty => - do etax <- nf defs env + do etax <- nf defs env (Bind yfc y (Lam cy iy argty) - (App yfc - (weaken !(quote empty env tmx)) + (App yfc + (weaken !(quote empty env tmx)) (Local yfc Nothing 0 First))) logNF 10 "Expand" env etax unify mode loc env etax tmy @@ -993,7 +993,7 @@ mutual export Unify Term where - unifyD _ _ mode loc env x y + unifyD _ _ mode loc env x y = do defs <- get Ctxt if x == y then do log 10 $ "Skipped unification (equal already): " @@ -1002,7 +1002,7 @@ mutual else do xnf <- nf defs env x ynf <- nf defs env y unify mode loc env xnf ynf - unifyWithLazyD _ _ mode loc env x y + unifyWithLazyD _ _ mode loc env x y = do defs <- get Ctxt if x == y then do log 10 $ "Skipped unification (equal already): " @@ -1014,7 +1014,7 @@ mutual export Unify Closure where - unifyD _ _ mode loc env x y + unifyD _ _ mode loc env x y = do defs <- get Ctxt unify mode loc env !(evalClosure defs x) !(evalClosure defs y) @@ -1050,20 +1050,20 @@ retry withLazy mode c Nothing => pure success Just Resolved => pure success Just (MkConstraint loc env x y) - => catch (do logTermNF 5 "Retrying" env x + => catch (do logTermNF 5 "Retrying" env x logTermNF 5 "....with" env y cs <- if withLazy - then unifyWithLazy mode loc env x y - else unify mode loc env x y + then unifyWithLazy mode loc env x y + else unify mode loc env x y case constraints cs of [] => do deleteConstraint c pure cs _ => pure cs) - (\err => throw (WhenUnifying loc env x y err)) + (\err => throw (WhenUnifying loc env x y err)) Just (MkSeqConstraint loc env xs ys) => do cs <- unifyArgs mode loc env xs ys case constraints cs of - [] => do deleteConstraint c + [] => do deleteConstraint c pure cs _ => pure cs @@ -1098,15 +1098,15 @@ retryGuess mode smode (hid, (loc, hname)) removeGuess hid pure True) (\err => case err of - DeterminingArg _ n i _ _ => + DeterminingArg _ n i _ _ => do logTerm 5 ("Failed (det " ++ show hname ++ " " ++ show n ++ ")") (type def) setInvertible loc (Resolved i) pure False -- progress made! - _ => do logTermNF 5 ("Search failed at " ++ show rig ++ " for " ++ show hname) + _ => do logTermNF 5 ("Search failed at " ++ show rig ++ " for " ++ show hname) [] (type def) case smode of - LastChance => + LastChance => throw !(normaliseErr err) _ => pure False) -- Postpone again Guess tm envb [constr] => @@ -1118,7 +1118,7 @@ retryGuess mode smode (hid, (loc, hname)) [] => do tm' <- case addLazy cs of NoLazy => pure tm AddForce => pure $ forceMeta envb tm - AddDelay r => + AddDelay r => do ty <- getType [] tm pure $ delayMeta r envb !(getTerm ty) tm let gdef = record { definition = PMDef True [] (STerm tm') (STerm tm') [] } def @@ -1129,7 +1129,7 @@ retryGuess mode smode (hid, (loc, hname)) newcs => do let gdef = record { definition = Guess tm envb newcs } def addDef (Resolved hid) gdef pure False - Guess tm envb constrs => + Guess tm envb constrs => do let umode = case smode of MatchArgs => InMatch _ => mode @@ -1156,10 +1156,10 @@ solveConstraints : {auto c : Ref Ctxt Defs} -> solveConstraints umode smode = do ust <- get UST progress <- traverse (retryGuess umode smode) (toList (guesses ust)) - when (or (map Delay progress)) $ + when (or (map Delay progress)) $ solveConstraints umode smode --- Replace any 'BySearch' with 'Hole', so that we don't keep searching +-- Replace any 'BySearch' with 'Hole', so that we don't keep searching -- fruitlessly while elaborating the rest of a source file export giveUpConstraints : {auto c : Ref Ctxt Defs} -> @@ -1205,12 +1205,12 @@ checkDots let h = case ndef of Hole _ _ => True _ => False - + when (not (isNil (constraints cs)) || holesSolved cs || h) $ throw (InternalError "Dot pattern match fail")) (\err => do defs <- get Ctxt - throw (BadDotPattern fc env reason - !(normaliseHoles defs env x) + throw (BadDotPattern fc env reason + !(normaliseHoles defs env x) !(normaliseHoles defs env y))) checkConstraint _ = pure () diff --git a/src/Core/UnifyState.idr b/src/Core/UnifyState.idr index 627cdf8..99701d1 100644 --- a/src/Core/UnifyState.idr +++ b/src/Core/UnifyState.idr @@ -21,9 +21,9 @@ data Constraint : Type where -- An unsolved constraint, noting two terms which need to be convertible -- in a particular environment MkConstraint : {vars : _} -> - FC -> + FC -> (env : Env Term vars) -> - (x : Term vars) -> (y : Term vars) -> + (x : Term vars) -> (y : Term vars) -> Constraint -- An unsolved sequence of constraints, arising from arguments in an -- application where solving later constraints relies on solving earlier @@ -39,13 +39,13 @@ data Constraint : Type where export TTC Constraint where - toBuf b (MkConstraint {vars} fc env x y) + toBuf b (MkConstraint {vars} fc env x y) = do tag 0; toBuf b vars; toBuf b fc; toBuf b env; toBuf b x; toBuf b y toBuf b (MkSeqConstraint {vars} fc env xs ys) = do tag 1; toBuf b vars; toBuf b fc; toBuf b env; toBuf b xs; toBuf b ys toBuf b Resolved = tag 2 - fromBuf b + fromBuf b = case !getTag of 0 => do vars <- fromBuf b fc <- fromBuf b; env <- fromBuf b @@ -273,18 +273,18 @@ addDot : {auto u : Ref UST UState} -> Core () addDot fc env dotarg x reason y = do ust <- get UST - put UST (record { dotConstraints $= - ((dotarg, reason, MkConstraint fc env x y) ::) + put UST (record { dotConstraints $= + ((dotarg, reason, MkConstraint fc env x y) ::) } ust) -mkConstantAppArgs : Bool -> FC -> Env Term vars -> +mkConstantAppArgs : Bool -> FC -> Env Term vars -> (wkns : List 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 if lets || not (isLet b) - then Local fc (Just (isLet b)) (length wkns) (mkVar wkns) :: + then Local fc (Just (isLet b)) (length wkns) (mkVar wkns) :: rewrite (appendAssociative wkns [x] (xs ++ done)) in rec else rewrite (appendAssociative wkns [x] (xs ++ done)) in rec where @@ -302,19 +302,19 @@ mkConstantAppArgsOthers : Bool -> FC -> Env Term vars -> (wkns : List Name) -> List (Term (wkns ++ (vars ++ done))) mkConstantAppArgsOthers lets fc [] p wkns = [] -mkConstantAppArgsOthers {done} {vars = x :: xs} +mkConstantAppArgsOthers {done} {vars = x :: xs} lets fc (b :: env) SubRefl wkns = rewrite appendAssociative wkns [x] (xs ++ done) in mkConstantAppArgsOthers lets fc env SubRefl (wkns ++ [x]) -mkConstantAppArgsOthers {done} {vars = x :: xs} +mkConstantAppArgsOthers {done} {vars = x :: xs} lets fc (b :: env) (KeepCons p) wkns = rewrite appendAssociative wkns [x] (xs ++ done) in mkConstantAppArgsOthers lets fc env p (wkns ++ [x]) -mkConstantAppArgsOthers {done} {vars = x :: xs} +mkConstantAppArgsOthers {done} {vars = x :: xs} lets fc (b :: env) (DropCons p) wkns = let rec = mkConstantAppArgsOthers {done} lets fc env p (wkns ++ [x]) in if lets || not (isLet b) - then Local fc (Just (isLet b)) (length wkns) (mkVar wkns) :: + then Local fc (Just (isLet b)) (length wkns) (mkVar wkns) :: rewrite appendAssociative wkns [x] (xs ++ done) in rec else rewrite appendAssociative wkns [x] (xs ++ done) in rec where @@ -341,7 +341,7 @@ applyToFull {vars} fc tm env apply fc tm (rewrite sym (appendNilRightNeutral vars) in args) export -applyToOthers : FC -> Term vars -> Env Term vars -> +applyToOthers : FC -> Term vars -> Env Term vars -> SubVars smaller vars -> Term vars applyToOthers {vars} fc tm env sub = let args = reverse (mkConstantAppArgsOthers {done = []} True fc env sub []) in @@ -367,7 +367,7 @@ newMetaLets {vars} fc rig env n ty def nocyc lets log 5 $ "Adding new meta " ++ show (n, fc, rig) logTerm 10 ("New meta type " ++ show n) hty defs <- get Ctxt - idx <- addDef n hole + idx <- addDef n hole addHoleName fc n idx pure (idx, Meta fc n idx envArgs) where @@ -379,7 +379,7 @@ export newMeta : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> FC -> RigCount -> - Env Term vars -> Name -> Term vars -> Def -> + Env Term vars -> Name -> Term vars -> Def -> Bool -> Core (Int, Term vars) newMeta fc r env n ty def cyc = newMetaLets fc r env n ty def cyc False @@ -388,7 +388,7 @@ mkConstant : FC -> Env Term vars -> Term vars -> ClosedTerm 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 (b :: env) tm = let ty = binderType b in mkConstant fc env (Bind fc x (Lam (multiplicity b) Explicit ty) tm) @@ -398,7 +398,7 @@ mkConstant {vars = x :: _} fc (b :: env) tm export newConstant : {auto u : Ref UST UState} -> {auto c : Ref Ctxt Defs} -> - FC -> RigCount -> Env Term vars -> + FC -> RigCount -> Env Term vars -> (tm : Term vars) -> (ty : Term vars) -> (constrs : List Int) -> Core (Term vars) @@ -406,7 +406,7 @@ newConstant {vars} fc rig env tm ty constrs = do let def = mkConstant fc env tm let defty = abstractFullEnvType fc env ty cn <- genName "postpone" - let guess = newDef fc cn rig [] defty Public + let guess = newDef fc cn rig [] defty Public (Guess def (length env) constrs) log 5 $ "Adding new constant " ++ show (cn, fc, rig) logTerm 10 ("New constant type " ++ show cn) defty @@ -430,7 +430,7 @@ newSearch {vars} fc rig depth def env n ty = do let hty = abstractEnvType fc env ty let hole = newDef fc n rig [] hty Public (BySearch rig depth def) log 10 $ "Adding new search " ++ show n - idx <- addDef n hole + idx <- addDef n hole addGuessName fc n idx pure (idx, Meta fc n idx envArgs) where @@ -441,8 +441,8 @@ newSearch {vars} fc rig depth def env n ty -- Add a hole which stands for a delayed elaborator export newDelayed : {auto u : Ref UST UState} -> - {auto c : Ref Ctxt Defs} -> - FC -> RigCount -> + {auto c : Ref Ctxt Defs} -> + FC -> RigCount -> Env Term vars -> Name -> (ty : Term vars) -> Core (Int, Term vars) newDelayed {vars} fc rig env n ty @@ -481,7 +481,7 @@ tryUnify elab1 elab2 pure ok export -handleUnify : {auto c : Ref Ctxt Defs} -> +handleUnify : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> Core a -> (Error -> Core a) -> Core a handleUnify elab1 elab2 @@ -505,7 +505,7 @@ checkDelayedHoles : {auto u : Ref UST UState} -> checkDelayedHoles = do ust <- get UST let hs = toList (delayedHoles ust) - if (not (isNil hs)) + if (not (isNil hs)) then do pure (Just (UnsolvedHoles (map snd hs))) else pure Nothing @@ -528,18 +528,18 @@ checkValidHole (idx, (fc, n)) Just ty <- lookupTyExact n (gamma defs) | Nothing => pure () throw (CantSolveGoal fc [] ty) - Guess tm envb (con :: _) => + Guess tm envb (con :: _) => do ust <- get UST let Just c = lookup con (constraints ust) | Nothing => pure () case c of MkConstraint fc env x y => - do put UST (record { guesses = empty } ust) + do put UST (record { guesses = empty } ust) xnf <- normaliseHoles defs env x ynf <- normaliseHoles defs env y throw (CantSolveEq fc env xnf ynf) MkSeqConstraint fc env (x :: _) (y :: _) => - do put UST (record { guesses = empty } ust) + do put UST (record { guesses = empty } ust) xnf <- normaliseHoles defs env x ynf <- normaliseHoles defs env y throw (CantSolveEq fc env xnf ynf) @@ -549,7 +549,7 @@ checkValidHole (idx, (fc, n)) where checkRef : Name -> Core () checkRef (PV n f) - = throw (GenericMsg fc + = throw (GenericMsg fc ("Hole cannot depend on an unbound implicit " ++ show n)) checkRef _ = pure () @@ -569,9 +569,9 @@ checkUserHoles now traverse_ checkValidHole gs hs_map <- getCurrentHoles let hs = toList hs_map - let hs' = if any isUserName (map (snd . snd) hs) + let hs' = if any isUserName (map (snd . snd) hs) then [] else hs - when (now && not (isNil hs')) $ + when (now && not (isNil hs')) $ throw (UnsolvedHoles (map snd (nubBy nameEq hs))) -- Note the hole names, to ensure they are resolved -- by the end of elaborating the current source file @@ -600,30 +600,30 @@ dumpHole lvl hole case !(lookupCtxtExact (Resolved hole) (gamma defs)) of Nothing => pure () Just gdef => case (definition gdef, type gdef) of - (Guess tm envb constraints, ty) => - do log lvl $ "!" ++ show !(getFullName (Resolved hole)) ++ " : " ++ + (Guess tm envb constraints, ty) => + do log lvl $ "!" ++ show !(getFullName (Resolved hole)) ++ " : " ++ show !(toFullNames !(normaliseHoles defs [] ty)) log lvl $ "\t = " ++ show !(normaliseHoles defs [] tm) ++ "\n\twhen" - traverse dumpConstraint constraints + traverse dumpConstraint constraints pure () (Hole _ p, ty) => - log lvl $ "?" ++ show (fullname gdef) ++ " : " ++ + log lvl $ "?" ++ show (fullname gdef) ++ " : " ++ show !(normaliseHoles defs [] ty) ++ if p then " (ImplBind)" else "" ++ if invertible gdef then " (Invertible)" else "" (BySearch _ _ _, ty) => - log lvl $ "Search " ++ show hole ++ " : " ++ + log lvl $ "Search " ++ show hole ++ " : " ++ show !(toFullNames !(normaliseHoles defs [] ty)) (PMDef _ args t _ _, ty) => - log 4 $ "Solved: " ++ show hole ++ " : " ++ + log 4 $ "Solved: " ++ show hole ++ " : " ++ show !(normalise defs [] ty) ++ " = " ++ show !(normalise defs [] (Ref emptyFC Func (Resolved hole))) (ImpBind, ty) => - log 4 $ "Bound: " ++ show hole ++ " : " ++ + log 4 $ "Bound: " ++ show hole ++ " : " ++ show !(normalise defs [] ty) (Delayed, ty) => - log 4 $ "Delayed elaborator : " ++ + log 4 $ "Delayed elaborator : " ++ show !(normalise defs [] ty) _ => pure () where @@ -643,7 +643,7 @@ dumpHole lvl hole log lvl $ "\t\t" ++ show xs ++ " =?= " ++ show ys export -dumpConstraints : {auto u : Ref UST UState} -> +dumpConstraints : {auto u : Ref UST UState} -> {auto c : Ref Ctxt Defs} -> (loglevel : Nat) -> (all : Bool) -> diff --git a/src/Core/Value.idr b/src/Core/Value.idr index f737e76..da1bf9b 100644 --- a/src/Core/Value.idr +++ b/src/Core/Value.idr @@ -51,7 +51,7 @@ mutual public export data Closure : List Name -> Type where MkClosure : (opts : EvalOpts) -> - LocalEnv free vars -> + LocalEnv free vars -> Env Term free -> Term (vars ++ free) -> Closure free MkNFClosure : NF free -> Closure free @@ -64,16 +64,16 @@ mutual NRef : NameType -> Name -> NHead vars NMeta : Name -> Int -> List (Closure vars) -> NHead vars - -- Values themselves. 'Closure' is an unevaluated thunk, which means + -- Values themselves. 'Closure' is an unevaluated thunk, which means -- we can wait until necessary to reduce constructor arguments public export data NF : List Name -> Type where NBind : FC -> (x : Name) -> Binder (NF vars) -> (Defs -> Closure vars -> Core (NF vars)) -> NF vars NApp : FC -> NHead vars -> List (Closure vars) -> NF vars - NDCon : FC -> Name -> (tag : Int) -> (arity : Nat) -> + NDCon : FC -> Name -> (tag : Int) -> (arity : Nat) -> List (Closure vars) -> NF vars - NTCon : FC -> Name -> (tag : Int) -> (arity : Nat) -> + NTCon : FC -> Name -> (tag : Int) -> (arity : Nat) -> List (Closure vars) -> NF vars NAs : FC -> NF vars -> NF vars -> NF vars NDelayed : FC -> LazyReason -> NF vars -> NF vars diff --git a/src/Data/ANameMap.idr b/src/Data/ANameMap.idr index 1e5309a..193d561 100644 --- a/src/Data/ANameMap.idr +++ b/src/Data/ANameMap.idr @@ -9,7 +9,7 @@ export record ANameMap a where constructor MkANameMap -- for looking up by exact (completely qualified) names - exactNames : NameMap a + exactNames : NameMap a -- for looking up by name root or partially qualified (so possibly -- ambiguous) names. This doesn't store machine generated names. hierarchy : StringMap (List (Name, a)) @@ -62,10 +62,10 @@ addToHier n val hier export addName : Name -> a -> ANameMap a -> ANameMap a -addName n val (MkANameMap dict hier) +addName n val (MkANameMap dict hier) = let dict' = insert n val dict hier' = addToHier n val hier in - MkANameMap dict' hier' + MkANameMap dict' hier' export toList : ANameMap a -> List (Name, a) diff --git a/src/Data/IOArray.idr b/src/Data/IOArray.idr index 271ad20..13f8e93 100644 --- a/src/Data/IOArray.idr +++ b/src/Data/IOArray.idr @@ -24,7 +24,7 @@ newRawArray size default vm size (MkRaw default) pure (MkIORawArray p) -||| Write an element at a location in an array. +||| Write an element at a location in an array. ||| There is *no* bounds checking, hence this is unsafe. Safe interfaces can ||| be implemented on top of this, either with a run time or compile time ||| check. @@ -35,7 +35,7 @@ unsafeWriteArray (MkIORawArray p) i val (Raw (ArrayData elem) -> Int -> Raw elem -> IO ()) (MkRaw p) i (MkRaw val) -||| Read the element at a location in an array. +||| Read the element at a location in an array. ||| There is *no* bounds checking, hence this is unsafe. Safe interfaces can ||| be implemented on top of this, either with a run time or compile time ||| check. @@ -114,7 +114,7 @@ fromList ns where addToArray : Int -> List (Maybe elem) -> IOArray elem -> IO () addToArray loc [] arr = pure () - addToArray loc (Nothing :: ns) arr + addToArray loc (Nothing :: ns) arr = assert_total (addToArray (loc + 1) ns arr) addToArray loc (Just el :: ns) arr = do unsafeWriteArray (content arr) loc (Just el) diff --git a/src/Data/IntMap.idr b/src/Data/IntMap.idr index da11310..c9a3cbb 100644 --- a/src/Data/IntMap.idr +++ b/src/Data/IntMap.idr @@ -11,16 +11,16 @@ Key = Int private data Tree : Nat -> Type -> Type where - Leaf : Key -> v -> Tree Z v - Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v - Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v + Leaf : Key -> v -> Tree Z v + Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v + Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v branch4 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Key -> Tree n v -> - Tree (S (S n)) v + Tree (S (S n)) v branch4 a b c d e f g = Branch2 (Branch2 a b c) d (Branch2 e f g) @@ -196,9 +196,9 @@ treeToList = treeToList' [] where treeToList' : List (Key, v) -> Tree n v -> List (Key, v) treeToList' rest (Leaf k v) = (k, v) :: rest - treeToList' rest (Branch2 t1 _ t2) + treeToList' rest (Branch2 t1 _ t2) = treeToList' (treeToList' rest t2) t1 - treeToList' rest (Branch3 t1 _ t2 _ t3) + treeToList' rest (Branch3 t1 _ t2 _ t3) = treeToList' (treeToList' (treeToList' rest t3) t2) t1 export @@ -258,7 +258,7 @@ export values : IntMap v -> List v values = map snd . toList -treeMap : (a -> b) -> Tree n a -> Tree n b +treeMap : (a -> b) -> Tree n a -> Tree n b treeMap f (Leaf k v) = Leaf k (f v) treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2) treeMap f (Branch3 t1 k1 t2 k2 t3) diff --git a/src/Data/NameMap.idr b/src/Data/NameMap.idr index e2dad4b..6f05704 100644 --- a/src/Data/NameMap.idr +++ b/src/Data/NameMap.idr @@ -13,16 +13,16 @@ Key = Name private data Tree : Nat -> Type -> Type where - Leaf : Key -> v -> Tree Z v - Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v - Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v + Leaf : Key -> v -> Tree Z v + Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v + Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v branch4 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Key -> Tree n v -> - Tree (S (S n)) v + Tree (S (S n)) v branch4 a b c d e f g = Branch2 (Branch2 a b c) d (Branch2 e f g) @@ -198,9 +198,9 @@ treeToList = treeToList' [] where treeToList' : List (Key, v) -> Tree n v -> List (Key, v) treeToList' rest (Leaf k v) = (k, v) :: rest - treeToList' rest (Branch2 t1 _ t2) + treeToList' rest (Branch2 t1 _ t2) = treeToList' (treeToList' rest t2) t1 - treeToList' rest (Branch3 t1 _ t2 _ t3) + treeToList' rest (Branch3 t1 _ t2 _ t3) = treeToList' (treeToList' (treeToList' rest t3) t2) t1 export @@ -260,7 +260,7 @@ export values : NameMap v -> List v values = map snd . toList -treeMap : (a -> b) -> Tree n a -> Tree n b +treeMap : (a -> b) -> Tree n a -> Tree n b treeMap f (Leaf k v) = Leaf k (f v) treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2) treeMap f (Branch3 t1 k1 t2 k2 t3) diff --git a/src/Idris/Desugar.idr b/src/Idris/Desugar.idr index 4a674a9..4b89baf 100644 --- a/src/Idris/Desugar.idr +++ b/src/Idris/Desugar.idr @@ -59,7 +59,7 @@ extendAs old as newsyn put Syn (record { infixes $= mergeLeft (infixes newsyn), prefixes $= mergeLeft (prefixes newsyn), ifaces $= mergeAs old as (ifaces newsyn), - bracketholes $= ((bracketholes newsyn) ++) } + bracketholes $= ((bracketholes newsyn) ++) } syn) mkPrec : Fixity -> Nat -> OpPrec @@ -74,7 +74,7 @@ toTokList (POp fc opn l r) = do syn <- get Syn let op = nameRoot opn case lookup op (infixes syn) of - Nothing => + Nothing => let ops = unpack opChars in if any (\x => x `elem` ops) (unpack op) then throw (GenericMsg fc $ "Unknown operator '" ++ op ++ "'") @@ -107,36 +107,36 @@ mutual {auto m : Ref MD Metadata} -> Side -> List Name -> PTerm -> Core RawImp desugar side ps (PRef fc x) = pure $ IVar fc x - desugar side ps (PPi fc rig p mn argTy retTy) + desugar side ps (PPi fc rig p mn argTy retTy) = let ps' = maybe ps (:: ps) mn in - pure $ IPi fc rig p mn !(desugar side ps argTy) + pure $ IPi fc rig p mn !(desugar side ps argTy) !(desugar side ps' retTy) - desugar side ps (PLam fc rig p (PRef _ n@(UN _)) argTy scope) - = pure $ ILam fc rig p (Just n) !(desugar side ps argTy) + desugar side ps (PLam fc rig p (PRef _ n@(UN _)) argTy scope) + = pure $ ILam fc rig p (Just n) !(desugar side ps argTy) !(desugar side (n :: ps) scope) - desugar side ps (PLam fc rig p (PRef _ n@(MN _ _)) argTy scope) - = pure $ ILam fc rig p (Just n) !(desugar side ps argTy) + desugar side ps (PLam fc rig p (PRef _ n@(MN _ _)) argTy scope) + = pure $ ILam fc rig p (Just n) !(desugar side ps argTy) !(desugar side (n :: ps) scope) - desugar side ps (PLam fc rig p (PImplicit _) argTy scope) - = pure $ ILam fc rig p Nothing !(desugar side ps argTy) + desugar side ps (PLam fc rig p (PImplicit _) argTy scope) + = pure $ ILam fc rig p Nothing !(desugar side ps argTy) !(desugar side ps scope) desugar side ps (PLam fc rig p pat argTy scope) = pure $ ILam fc rig p (Just (MN "lamc" 0)) !(desugar side ps argTy) $ ICase fc (IVar fc (MN "lamc" 0)) (Implicit fc False) [!(desugarClause ps True (MkPatClause fc pat scope []))] desugar side ps (PLet fc rig (PRef _ n) nTy nVal scope []) - = pure $ ILet fc rig n !(desugar side ps nTy) !(desugar side ps nVal) + = pure $ ILet fc rig n !(desugar side ps nTy) !(desugar side ps nVal) !(desugar side (n :: ps) scope) - desugar side ps (PLet fc rig pat nTy nVal scope alts) + desugar side ps (PLet fc rig pat nTy nVal scope alts) = pure $ ICase fc !(desugar side ps nVal) !(desugar side ps nTy) - !(traverse (desugarClause ps True) + !(traverse (desugarClause ps True) (MkPatClause fc pat scope [] :: alts)) - desugar side ps (PCase fc x xs) - = pure $ ICase fc !(desugar side ps x) + desugar side ps (PCase fc x xs) + = pure $ ICase fc !(desugar side ps x) (Implicit fc False) !(traverse (desugarClause ps True) xs) - desugar side ps (PLocal fc xs scope) - = pure $ ILocal fc (concat !(traverse (desugarDecl ps) xs)) + desugar side ps (PLocal fc xs scope) + = pure $ ILocal fc (concat !(traverse (desugarDecl ps) xs)) !(desugar side (definedIn xs ++ ps) scope) desugar side ps (PApp pfc (PUpdate fc fs) rec) = pure $ IUpdate pfc !(traverse (desugarUpdate side ps) fs) @@ -144,11 +144,11 @@ mutual desugar side ps (PUpdate fc fs) = desugar side ps (PLam fc RigW Explicit (PRef fc (MN "rec" 0)) (PImplicit fc) (PApp fc (PUpdate fc fs) (PRef fc (MN "rec" 0)))) - desugar side ps (PApp fc x y) + desugar side ps (PApp fc x y) = pure $ IApp fc !(desugar side ps x) !(desugar side ps y) - desugar side ps (PWithApp fc x y) + desugar side ps (PWithApp fc x y) = pure $ IWithApp fc !(desugar side ps x) !(desugar side ps y) - desugar side ps (PImplicitApp fc x argn y) + desugar side ps (PImplicitApp fc x argn y) = pure $ IImplicitApp fc !(desugar side ps x) argn !(desugar side ps y) desugar side ps (PDelayed fc r ty) = pure $ IDelayed fc r !(desugar side ps ty) @@ -163,18 +163,18 @@ mutual [apply (IVar fc (UN "===")) [l', r'], apply (IVar fc (UN "~=~")) [l', r']] desugar side ps (PBracketed fc e) = desugar side ps e - desugar side ps (POp fc op l r) + desugar side ps (POp fc op l r) = do ts <- toTokList (POp fc op l r) desugarTree side ps !(parseOps ts) - desugar side ps (PPrefixOp fc op arg) + desugar side ps (PPrefixOp fc op arg) = do ts <- toTokList (PPrefixOp fc op arg) desugarTree side ps !(parseOps ts) - desugar side ps (PSectionL fc op arg) + desugar side ps (PSectionL fc op arg) = do syn <- get Syn -- It might actually be a prefix argument rather than a section -- so check that first, otherwise desugar as a lambda case lookup (nameRoot op) (prefixes syn) of - Nothing => + Nothing => desugar side ps (PLam fc RigW Explicit (PRef fc (MN "arg" 0)) (PImplicit fc) (POp fc op (PRef fc (MN "arg" 0)) arg)) Just prec => desugar side ps (PPrefixOp fc op arg) @@ -188,36 +188,36 @@ mutual pure $ IAlternative fc (UniqueDefault (IPrimVal fc (BI x))) [IPrimVal fc (BI x), IPrimVal fc (I (fromInteger x))] - Just fi => pure $ IApp fc (IVar fc fi) + Just fi => pure $ IApp fc (IVar fc fi) (IPrimVal fc (BI x)) desugar side ps (PPrimVal fc (Str x)) = case !fromStringName of Nothing => pure $ IPrimVal fc (Str x) - Just f => pure $ IApp fc (IVar fc f) + Just f => pure $ IApp fc (IVar fc f) (IPrimVal fc (Str x)) desugar side ps (PPrimVal fc (Ch x)) = case !fromCharName of Nothing => pure $ IPrimVal fc (Ch x) - Just f => pure $ IApp fc (IVar fc f) + Just f => pure $ IApp fc (IVar fc f) (IPrimVal fc (Ch x)) desugar side ps (PPrimVal fc x) = pure $ IPrimVal fc x - desugar side ps (PQuote fc x) + desugar side ps (PQuote fc x) = throw (GenericMsg fc "Reflection not implemeted yet") -- = pure $ IQuote fc !(desugar side ps x) - desugar side ps (PUnquote fc x) + desugar side ps (PUnquote fc x) = throw (GenericMsg fc "Reflection not implemeted yet") -- = pure $ IUnquote fc !(desugar side ps x) - desugar side ps (PHole fc br holename) + desugar side ps (PHole fc br holename) = do when br $ do syn <- get Syn put Syn (record { bracketholes $= ((UN holename) ::) } syn) pure $ IHole fc holename desugar side ps (PType fc) = pure $ IType fc - desugar side ps (PAs fc vname pattern) + desugar side ps (PAs fc vname pattern) = pure $ IAs fc UseRight vname !(desugar side ps pattern) - desugar side ps (PDotted fc x) + desugar side ps (PDotted fc x) = pure $ IMustUnify fc "User dotted" !(desugar side ps x) desugar side ps (PImplicit fc) = pure $ Implicit fc True desugar side ps (PInfer fc) = pure $ Implicit fc False @@ -225,35 +225,35 @@ mutual = expandDo side ps fc block desugar side ps (PList fc args) = expandList side ps fc args - desugar side ps (PPair fc l r) + desugar side ps (PPair fc l r) = do l' <- desugar side ps l r' <- desugar side ps r let pval = apply (IVar fc (UN "MkPair")) [l', r'] pure $ IAlternative fc (UniqueDefault pval) [apply (IVar fc (UN "Pair")) [l', r'], pval] - desugar side ps (PDPair fc (PRef nfc (UN n)) (PImplicit _) r) + desugar side ps (PDPair fc (PRef nfc (UN n)) (PImplicit _) r) = do r' <- desugar side ps r let pval = apply (IVar fc (UN "MkDPair")) [IVar nfc (UN n), r'] pure $ IAlternative fc (UniqueDefault pval) - [apply (IVar fc (UN "DPair")) - [Implicit nfc False, + [apply (IVar fc (UN "DPair")) + [Implicit nfc False, ILam nfc RigW Explicit (Just (UN n)) (Implicit nfc False) r'], pval] - desugar side ps (PDPair fc (PRef nfc (UN n)) ty r) + desugar side ps (PDPair fc (PRef nfc (UN n)) ty r) = do ty' <- desugar side ps ty r' <- desugar side ps r pure $ apply (IVar fc (UN "DPair")) - [ty', + [ty', ILam nfc RigW Explicit (Just (UN n)) ty' r'] - desugar side ps (PDPair fc l (PImplicit _) r) + desugar side ps (PDPair fc l (PImplicit _) r) = do l' <- desugar side ps l r' <- desugar side ps r pure $ apply (IVar fc (UN "MkDPair")) [l', r'] - desugar side ps (PDPair fc l ty r) + desugar side ps (PDPair fc l ty r) = throw (GenericMsg fc "Invalid dependent pair type") - desugar side ps (PUnit fc) + desugar side ps (PUnit fc) = pure $ IAlternative fc (UniqueDefault (IVar fc (UN "MkUnit"))) - [IVar fc (UN "Unit"), + [IVar fc (UN "Unit"), IVar fc (UN "MkUnit")] desugar side ps (PIfThenElse fc x t e) = pure $ ICase fc !(desugar side ps x) (Implicit fc False) @@ -273,12 +273,12 @@ mutual desugar side ps (PRange fc start next end) = case next of Nothing => - desugar side ps (PApp fc + desugar side ps (PApp fc (PApp fc (PRef fc (UN "rangeFromTo")) start) end) Just n => - desugar side ps (PApp fc - (PApp fc + desugar side ps (PApp fc + (PApp fc (PApp fc (PRef fc (UN "rangeFromThenTo")) start) n) end) desugar side ps (PRangeStream fc start next) @@ -305,7 +305,7 @@ mutual Side -> List Name -> FC -> List PTerm -> Core RawImp expandList side ps fc [] = pure (IVar fc (UN "Nil")) expandList side ps fc (x :: xs) - = pure $ apply (IVar fc (UN "::")) + = pure $ apply (IVar fc (UN "::")) [!(desugar side ps x), !(expandList side ps fc xs)] expandDo : {auto s : Ref Syn SyntaxInfo} -> @@ -315,21 +315,21 @@ mutual Side -> List Name -> FC -> List PDo -> Core RawImp expandDo side ps fc [] = throw (GenericMsg fc "Do block cannot be empty") expandDo side ps _ [DoExp fc tm] = desugar side ps tm - expandDo side ps fc [e] - = throw (GenericMsg (getLoc e) - "Last statement in do block must be an expression") + expandDo side ps fc [e] + = throw (GenericMsg (getLoc e) + "Last statement in do block must be an expression") expandDo side ps topfc (DoExp fc tm :: rest) = do tm' <- desugar side ps tm rest' <- expandDo side ps topfc rest gam <- get Ctxt pure $ IApp fc (IApp fc (IVar fc (UN ">>=")) tm') - (ILam fc RigW Explicit Nothing + (ILam fc RigW Explicit Nothing (Implicit fc False) rest') expandDo side ps topfc (DoBind fc n tm :: rest) = do tm' <- desugar side ps tm rest' <- expandDo side ps topfc rest pure $ IApp fc (IApp fc (IVar fc (UN ">>=")) tm') - (ILam fc RigW Explicit (Just n) + (ILam fc RigW Explicit (Just n) (Implicit fc False) rest') expandDo side ps topfc (DoBindPat fc pat exp alts :: rest) = do pat' <- desugar LHS ps pat @@ -339,24 +339,24 @@ mutual let ps' = newps ++ ps rest' <- expandDo side ps' topfc rest pure $ IApp fc (IApp fc (IVar fc (UN ">>=")) exp') - (ILam fc RigW Explicit (Just (MN "_" 0)) + (ILam fc RigW Explicit (Just (MN "_" 0)) (Implicit fc False) (ICase fc (IVar fc (MN "_" 0)) (Implicit fc False) - (PatClause fc bpat rest' + (PatClause fc bpat rest' :: alts'))) - expandDo side ps topfc (DoLet fc n rig tm :: rest) + expandDo side ps topfc (DoLet fc n rig tm :: rest) = do tm' <- desugar side ps tm rest' <- expandDo side ps topfc rest pure $ ILet fc rig n (Implicit fc False) tm' rest' - expandDo side ps topfc (DoLetPat fc pat tm alts :: rest) + expandDo side ps topfc (DoLetPat fc pat tm alts :: rest) = do pat' <- desugar LHS ps pat (newps, bpat) <- bindNames False pat' tm' <- desugar side ps tm alts' <- traverse (desugarClause ps True) alts let ps' = newps ++ ps rest' <- expandDo side ps' topfc rest - pure $ ICase fc tm' (Implicit fc False) + pure $ ICase fc tm' (Implicit fc False) (PatClause fc bpat rest' :: alts') expandDo side ps topfc (DoLetLocal fc decls :: rest) @@ -402,7 +402,7 @@ mutual {auto u : Ref UST UState} -> {auto m : Ref MD Metadata} -> List Name -> PTypeDecl -> Core ImpTy - desugarType ps (MkPTy fc n ty) + desugarType ps (MkPTy fc n ty) = pure $ MkImpTy fc n !(bindTypeNames ps !(desugar AnyExpr ps ty)) desugarClause : {auto s : Ref Syn SyntaxInfo} -> @@ -414,7 +414,7 @@ mutual = do ws <- traverse (desugarDecl ps) wheres (bound, blhs) <- bindNames arg !(desugar LHS ps lhs) rhs' <- desugar AnyExpr (bound ++ ps) rhs - pure $ PatClause fc blhs + pure $ PatClause fc blhs (case ws of [] => rhs' _ => ILocal fc (concat ws) rhs') @@ -432,24 +432,24 @@ mutual {auto u : Ref UST UState} -> {auto m : Ref MD Metadata} -> List Name -> PDataDecl -> Core ImpData - desugarData ps (MkPData fc n tycon opts datacons) + desugarData ps (MkPData fc n tycon opts datacons) = pure $ MkImpData fc n !(bindTypeNames ps !(desugar AnyExpr ps tycon)) opts !(traverse (desugarType ps) datacons) - desugarData ps (MkPLater fc n tycon) + desugarData ps (MkPLater fc n tycon) = pure $ MkImpLater fc n !(bindTypeNames ps !(desugar AnyExpr ps tycon)) desugarField : {auto s : Ref Syn SyntaxInfo} -> {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {auto m : Ref MD Metadata} -> - List Name -> PField -> + List Name -> PField -> Core IField desugarField ps (MkField fc rig p n ty) = pure (MkIField fc rig p n !(bindTypeNames ps !(desugar AnyExpr ps ty))) -- Get the declaration to process on each pass of a mutual block - -- Essentially: types on the first pass + -- Essentially: types on the first pass -- i.e. type constructors of data declarations -- function types -- interfaces (in full, since it includes function types) @@ -479,8 +479,8 @@ mutual getDecl AsDef (PFixity _ _ _ _) = Nothing getDecl AsDef (PDirective _ _) = Nothing getDecl AsDef d = Just d - - getDecl p (PParameters fc ps pds) + + getDecl p (PParameters fc ps pds) = Just (PParameters fc ps (mapMaybe (getDecl p) pds)) getDecl Single d = Just d @@ -493,14 +493,14 @@ mutual {auto u : Ref UST UState} -> {auto m : Ref MD Metadata} -> List Name -> PDecl -> Core (List ImpDecl) - desugarDecl ps (PClaim fc rig vis opts ty) + desugarDecl ps (PClaim fc rig vis opts ty) = pure [IClaim fc rig vis opts !(desugarType ps ty)] - desugarDecl ps (PDef fc clauses) + desugarDecl ps (PDef fc clauses) -- The clauses won't necessarily all be from the same function, so split -- after desugaring, by function name, using collectDefs from RawImp = do cs <- traverse (desugarClause ps False) clauses defs <- traverse toIDef cs - pure (collectDefs defs) + pure (collectDefs defs) where getFn : RawImp -> Core Name getFn (IVar _ n) = pure n @@ -509,14 +509,14 @@ mutual getFn tm = throw (InternalError (show tm ++ " is not a function application")) toIDef : ImpClause -> Core ImpDecl - toIDef (PatClause fc lhs rhs) + toIDef (PatClause fc lhs rhs) = pure $ IDef fc !(getFn lhs) [PatClause fc lhs rhs] - toIDef (WithClause fc lhs rhs cs) + toIDef (WithClause fc lhs rhs cs) = pure $ IDef fc !(getFn lhs) [WithClause fc lhs rhs cs] - toIDef (ImpossibleClause fc lhs) + toIDef (ImpossibleClause fc lhs) = pure $ IDef fc !(getFn lhs) [ImpossibleClause fc lhs] - desugarDecl ps (PData fc vis ddecl) + desugarDecl ps (PData fc vis ddecl) = pure [IData fc vis !(desugarData ps ddecl)] desugarDecl ps (PParameters fc params pds) = do pds' <- traverse (desugarDecl (ps ++ map fst params)) pds @@ -540,19 +540,19 @@ mutual pure (fst ntm, tm')) params -- Look for bindable names in all the constraints and parameters let mnames = map dropNS (definedIn body) - let bnames = concatMap (findBindableNames True - (ps ++ mnames ++ map fst params) []) + let bnames = concatMap (findBindableNames True + (ps ++ mnames ++ map fst params) []) (map snd cons') ++ - concatMap (findBindableNames True - (ps ++ mnames ++ map fst params) []) + concatMap (findBindableNames True + (ps ++ mnames ++ map fst params) []) (map snd params') let paramsb = map (\ (n, tm) => (n, doBind bnames tm)) params' let consb = map (\ (n, tm) => (n, doBind bnames tm)) cons' body' <- traverse (desugarDecl (ps ++ mnames ++ map fst params)) body - pure [IPragma (\c, nest, env => + pure [IPragma (\c, nest, env => elabInterface fc vis env nest consb - tn paramsb det conname + tn paramsb det conname (concat body'))] where -- Turns pairs in the constraints to individual constraints. This @@ -585,15 +585,15 @@ mutual pure (Just (concat b'))) body pure [IPragma (\c, nest, env => elabImplementation fc vis pass env nest isb consb - tn paramsb impname + tn paramsb impname body')] desugarDecl ps (PRecord fc vis tn params conname fields) = do params' <- traverse (\ ntm => do tm' <- desugar AnyExpr ps (snd ntm) pure (fst ntm, tm')) params let fnames = map fname fields -- Look for bindable names in the parameters - let bnames = concatMap (findBindableNames True - (ps ++ fnames ++ map fst params) []) + let bnames = concatMap (findBindableNames True + (ps ++ fnames ++ map fst params) []) (map snd params') fields' <- traverse (desugarField (ps ++ fnames ++ map fst params)) fields @@ -607,11 +607,11 @@ mutual where fname : PField -> Name fname (MkField _ _ _ n _) = n - desugarDecl ps (PFixity fc Prefix prec (UN n)) + desugarDecl ps (PFixity fc Prefix prec (UN n)) = do syn <- get Syn put Syn (record { prefixes $= insert n prec } syn) pure [] - desugarDecl ps (PFixity fc fix prec (UN n)) + desugarDecl ps (PFixity fc fix prec (UN n)) = do syn <- get Syn put Syn (record { infixes $= insert n (fix, prec) } syn) pure [] @@ -624,7 +624,7 @@ mutual desugarDecl ps (PNamespace fc ns decls) = do ds <- traverse (desugarDecl ps) decls pure [INamespace fc False ns (concat ds)] - desugarDecl ps (PDirective fc d) + desugarDecl ps (PDirective fc d) = case d of Hide n => pure [IPragma (\c, nest, env => hide fc n)] Logging i => pure [ILog i] diff --git a/src/Idris/Elab/Implementation.idr b/src/Idris/Elab/Implementation.idr index 83b3fd4..2886fe7 100644 --- a/src/Idris/Elab/Implementation.idr +++ b/src/Idris/Elab/Implementation.idr @@ -26,12 +26,12 @@ import Data.NameMap %default covering mkImpl : FC -> Name -> List RawImp -> Name -mkImpl fc n ps +mkImpl fc n ps = DN (show n ++ " implementation at " ++ show fc) (UN ("__Impl_" ++ show n ++ "_" ++ showSep "_" (map show ps))) -bindConstraints : FC -> PiInfo -> +bindConstraints : FC -> PiInfo -> List (Maybe Name, RawImp) -> RawImp -> RawImp bindConstraints fc p [] ty = ty bindConstraints fc p ((n, ty) :: rest) sc @@ -43,7 +43,7 @@ bindImpls fc ((n, r, ty) :: rest) sc = IPi fc r Implicit (Just n) ty (bindImpls fc rest sc) addDefaults : FC -> Name -> List Name -> List (Name, List ImpClause) -> - List ImpDecl -> + List ImpDecl -> (List ImpDecl, List Name) -- Updated body, list of missing methods addDefaults fc impName allms defs body = let missing = dropGot allms body in @@ -51,25 +51,25 @@ addDefaults fc impName allms defs body where -- Given the list of missing names, if any are among the default definitions, -- add them to the body - extendBody : List Name -> List Name -> List ImpDecl -> + extendBody : List Name -> List Name -> List ImpDecl -> (List ImpDecl, List Name) extendBody ms [] body = (body, ms) extendBody ms (n :: ns) body = case lookup n defs of Nothing => extendBody (n :: ms) ns body - Just cs => + Just cs => -- If any method names appear in the clauses, they should -- be applied to the constraint name __con because they -- are going to be referring to the present implementation. -- That is, default method implementations could depend on -- other methods. -- (See test idris2/interface014 for an example!) - let mupdates + let mupdates = map (\n => (n, IImplicitApp fc (IVar fc n) (Just (UN "__con")) (IVar fc impName))) allms cs' = map (substNamesClause [] mupdates) cs in - extendBody ms ns + extendBody ms ns (IDef fc n (map (substLocClause fc) cs') :: body) -- Find which names are missing from the body @@ -119,7 +119,7 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody Just conty <- lookupTyExact (iconstructor cdata) (gamma defs) | Nothing => throw (UndefinedName fc (iconstructor cdata)) - let impsp = nub (concatMap findIBinds ps ++ + let impsp = nub (concatMap findIBinds ps ++ concatMap findIBinds (map snd cons)) logTerm 3 ("Found interface " ++ show cn) ity @@ -138,7 +138,7 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody -- Don't make it a hint if it's a named implementation let opts = maybe [Inline, Hint True] (const [Inline]) impln - let initTy = bindImpls fc is $ bindConstraints fc AutoImplicit cons + let initTy = bindImpls fc is $ bindConstraints fc AutoImplicit cons (apply (IVar fc iname) ps) let paramBinds = findBindableNames True vars [] initTy let impTy = doBind paramBinds initTy @@ -147,7 +147,7 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody log 5 $ "Implementation type: " ++ show impTy when (typePass pass) $ processDecl [] nest env impTyDecl - + -- If the body is empty, we're done for now (just declaring that -- the implementation exists and define it later) when (defPass pass) $ maybe (pure ()) @@ -160,7 +160,7 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody -- 1.5. Lookup default definitions and add them to to body let (body, missing) - = addDefaults fc impName (map (dropNS . fst) (methods cdata)) + = addDefaults fc impName (map (dropNS . fst) (methods cdata)) (defaults cdata) body_in log 5 $ "Added defaults: body is " ++ show body @@ -169,15 +169,15 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody -- 2. Elaborate top level function types for this interface defs <- get Ctxt fns <- topMethTypes [] impName methImps impsp (params cdata) - (map fst (methods cdata)) + (map fst (methods cdata)) (methods cdata) traverse (processDecl [] nest env) (map mkTopMethDecl fns) -- 3. Build the record for the implementation let mtops = map (Basics.fst . snd) fns let con = iconstructor cdata - let ilhs = impsApply (IVar fc impName) - (map (\x => (x, IBindVar fc (show x))) + let ilhs = impsApply (IVar fc impName) + (map (\x => (x, IBindVar fc (show x))) (map fst methImps)) -- RHS is the constructor applied to a search for the necessary -- parent constraints, then the method implementations @@ -230,12 +230,12 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody impsApply : RawImp -> List (Name, RawImp) -> RawImp impsApply fn [] = fn - impsApply fn ((n, arg) :: ns) + impsApply fn ((n, arg) :: ns) = impsApply (IImplicitApp fc fn (Just n) arg) ns mkLam : List (Name, RigCount, PiInfo) -> RawImp -> RawImp mkLam [] tm = tm - mkLam ((x, c, p) :: xs) tm + mkLam ((x, c, p) :: xs) tm = ILam fc c p (Just x) (Implicit fc False) (mkLam xs tm) applyTo : FC -> RawImp -> List (Name, RigCount, PiInfo) -> RawImp @@ -248,10 +248,10 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody = applyTo fc (IImplicitApp fc tm (Just x) (IVar fc x)) xs -- When applying the method in the field for the record, eta expand - -- the expected arguments based on the field type, so that implicits get + -- the expected arguments based on the field type, so that implicits get -- inserted in the right place mkMethField : List (Name, RigCount, RawImp) -> - List (Name, List (Name, RigCount, PiInfo)) -> + List (Name, List (Name, RigCount, PiInfo)) -> (Name, Name, List (String, String), RigCount, RawImp) -> RawImp mkMethField methImps fldTys (topn, n, upds, c, ty) = let argns = map applyUpdate (maybe [] id (lookup (dropNS topn) fldTys)) @@ -264,22 +264,22 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody (map (\n => (n, IVar fc (UN (show n)))) imps)) where applyUpdate : (Name, RigCount, PiInfo) -> (Name, RigCount, PiInfo) - applyUpdate (UN n, c, p) + applyUpdate (UN n, c, p) = maybe (UN n, c, p) (\n' => (UN n', c, p)) (lookup n upds) applyUpdate t = t methName : Name -> Name methName (NS _ n) = methName n - methName n + methName n = DN (show n) (UN (show n ++ "_" ++ show iname ++ "_" ++ maybe "" show impln ++ "_" ++ showSep "_" (map show ps))) - + applyCon : Name -> Name -> Core (Name, RawImp) - applyCon impl n + applyCon impl n = do mn <- inCurrentNS (methName n) pure (dropNS n, IVar fc mn) - + bindImps : List (Name, RigCount, RawImp) -> RawImp -> RawImp bindImps [] ty = ty bindImps ((n, c, t) :: ts) ty @@ -291,9 +291,9 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody topMethType : List (Name, RawImp) -> Name -> List (Name, RigCount, RawImp) -> List String -> List Name -> List Name -> - (Name, RigCount, (Bool, RawImp)) -> + (Name, RigCount, (Bool, RawImp)) -> Core ((Name, Name, List (String, String), RigCount, RawImp), - List (Name, RawImp)) + List (Name, RawImp)) topMethType methupds impName methImps impsp pnames allmeths (mn, c, (d, mty_in)) = do -- Get the specialised type by applying the method to the -- parameters @@ -319,20 +319,20 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody log 3 $ "Method " ++ show mn ++ " ==> " ++ show n ++ " : " ++ show mty log 5 $ "Updates " ++ show methupds - log 5 $ "From " ++ show mbase - log 3 $ "Name updates " ++ show upds - log 3 $ "Param names: " ++ show pnames + log 5 $ "From " ++ show mbase + log 3 $ "Name updates " ++ show upds + log 3 $ "Param names: " ++ show pnames log 10 $ "Used names " ++ show ibound let ibinds = map fst methImps let methupds' = if isNil ibinds then [] else [(n, impsApply (IVar fc n) (map (\x => (x, IBindVar fc (show x))) ibinds))] pure ((mn, n, upds, c, mty), methupds') - + topMethTypes : List (Name, RawImp) -> Name -> List (Name, RigCount, RawImp) -> List String -> List Name -> List Name -> - List (Name, RigCount, (Bool, RawImp)) -> + List (Name, RigCount, (Bool, RawImp)) -> Core (List (Name, Name, List (String, String), RigCount, RawImp)) topMethTypes upds impName methImps impsp pnames allmeths [] = pure [] topMethTypes upds impName methImps impsp pnames allmeths (m :: ms) @@ -341,7 +341,7 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody pure (m' :: ms') mkTopMethDecl : (Name, Name, List (String, String), RigCount, RawImp) -> ImpDecl - mkTopMethDecl (mn, n, upds, c, mty) + mkTopMethDecl (mn, n, upds, c, mty) = IClaim fc c vis [] (MkImpTy fc n mty) -- Given the method type (result of topMethType) return the mapping from @@ -352,8 +352,8 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody findMethName : List (Name, Name) -> FC -> Name -> Core Name findMethName ns fc n = case lookup n ns of - Nothing => throw (GenericMsg fc - (show n ++ " is not a method of " ++ + Nothing => throw (GenericMsg fc + (show n ++ " is not a method of " ++ show iname)) Just n' => pure n' @@ -370,9 +370,9 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody updateApp ns tm = throw (GenericMsg (getFC tm) "Invalid method definition") - updateClause : List (Name, Name) -> ImpClause -> + updateClause : List (Name, Name) -> ImpClause -> Core ImpClause - updateClause ns (PatClause fc lhs rhs) + updateClause ns (PatClause fc lhs rhs) = do lhs' <- updateApp ns lhs pure (PatClause fc lhs' rhs) updateClause ns (WithClause fc lhs wval cs) @@ -384,10 +384,10 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln mbody pure (ImpossibleClause fc lhs') updateBody : List (Name, Name) -> ImpDecl -> Core ImpDecl - updateBody ns (IDef fc n cs) + updateBody ns (IDef fc n cs) = do cs' <- traverse (updateClause ns) cs n' <- findMethName ns fc n pure (IDef fc n' cs') - updateBody ns _ - = throw (GenericMsg fc + updateBody ns _ + = throw (GenericMsg fc "Implementation body can only contain definitions") diff --git a/src/Idris/Elab/Interface.idr b/src/Idris/Elab/Interface.idr index 178938b..3df2955 100644 --- a/src/Idris/Elab/Interface.idr +++ b/src/Idris/Elab/Interface.idr @@ -26,25 +26,25 @@ import Data.ANameMap mkDataTy : FC -> List (Name, RawImp) -> RawImp mkDataTy fc [] = IType fc -mkDataTy fc ((n, ty) :: ps) +mkDataTy fc ((n, ty) :: ps) = IPi fc RigW Explicit (Just n) ty (mkDataTy fc ps) mkIfaceData : {auto c : Ref Ctxt Defs} -> FC -> Visibility -> Env Term vars -> List (Maybe Name, RigCount, RawImp) -> - Name -> Name -> List (Name, RawImp) -> + Name -> Name -> List (Name, RawImp) -> List Name -> List (Name, RigCount, RawImp) -> Core ImpDecl mkIfaceData {vars} fc vis env constraints n conName ps dets meths - = let opts = if isNil dets + = let opts = if isNil dets then [NoHints] - else [NoHints, SearchBy dets] + else [NoHints, SearchBy dets] retty = apply (IVar fc n) (map (IVar fc) (map fst ps)) conty = mkTy Implicit (map jname ps) $ mkTy Explicit (map bhere constraints ++ map bname meths) retty con = MkImpTy fc conName !(bindTypeNames (map fst ps ++ map fst meths ++ vars) conty) in - pure $ IData fc vis (MkImpData fc n + pure $ IData fc vis (MkImpData fc n !(bindTypeNames (map fst ps ++ map fst meths ++ vars) - (mkDataTy fc ps)) + (mkDataTy fc ps)) opts [con]) where jname : (Name, RawImp) -> (Maybe Name, RigCount, RawImp) @@ -56,7 +56,7 @@ mkIfaceData {vars} fc vis env constraints n conName ps dets meths bhere : (Maybe Name, RigCount, RawImp) -> (Maybe Name, RigCount, RawImp) bhere (n, c, t) = (n, c, IBindHere (getFC t) (PI Rig0) t) - mkTy : PiInfo -> + mkTy : PiInfo -> List (Maybe Name, RigCount, RawImp) -> RawImp -> RawImp mkTy imp [] ret = ret mkTy imp ((n, c, argty) :: args) ret @@ -68,7 +68,7 @@ getMethDecl : {auto c : Ref Ctxt Defs} -> Env Term vars -> NestedNames vars -> (params : List (Name, RawImp)) -> (mnames : List Name) -> - (FC, RigCount, List FnOpt, n, (Bool, RawImp)) -> + (FC, RigCount, List FnOpt, n, (Bool, RawImp)) -> Core (n, RigCount, RawImp) getMethDecl {vars} env nest params mnames (fc, c, opts, n, (d, ty)) = do ty_imp <- bindTypeNames (map fst params ++ mnames ++ vars) ty @@ -83,7 +83,7 @@ getMethDecl {vars} env nest params mnames (fc, c, opts, n, (d, ty)) then stripParams ps ret else IPi fc r p mn arg (stripParams ps ret) stripParams ps ty = ty - + -- bind the auto implicit for the interface - put it after all the other -- implicits bindIFace : FC -> RawImp -> RawImp -> RawImp @@ -93,42 +93,42 @@ bindIFace _ ity (IPi fc rig AutoImplicit n ty sc) = IPi fc rig AutoImplicit n ty (bindIFace fc ity sc) bindIFace fc ity sc = IPi fc RigW AutoImplicit (Just (UN "__con")) ity sc --- Get the top level function for implementing a method +-- Get the top level function for implementing a method getMethToplevel : {auto c : Ref Ctxt Defs} -> - Env Term vars -> Visibility -> + Env Term vars -> Visibility -> Name -> Name -> (constraints : List (Maybe Name)) -> (allmeths : List Name) -> (params : List Name) -> - (FC, RigCount, List FnOpt, Name, (Bool, RawImp)) -> + (FC, RigCount, List FnOpt, Name, (Bool, RawImp)) -> Core (List ImpDecl) -getMethToplevel {vars} env vis iname cname constraints allmeths params +getMethToplevel {vars} env vis iname cname constraints allmeths params (fc, c, opts, n, (d, ty)) - = do let ity = apply (IVar fc iname) (map (IVar fc) params) + = do let ity = apply (IVar fc iname) (map (IVar fc) params) -- Make the constraint application explicit for any method names -- which appear in other method types let ty_constr = substNames vars (map applyCon allmeths) ty ty_imp <- bindTypeNames vars (bindIFace fc ity ty_constr) cn <- inCurrentNS n let tydecl = IClaim fc c vis (if d then [Inline, Invertible] - else [Inline]) - (MkImpTy fc cn ty_imp) + else [Inline]) + (MkImpTy fc cn ty_imp) let conapp = apply (IVar fc cname) (map (const (Implicit fc True)) constraints ++ map (IBindVar fc) (map bindName allmeths)) let argns = getExplicitArgs 0 ty -- eta expand the RHS so that we put implicits in the right place - let fnclause = PatClause fc (IImplicitApp fc (IVar fc cn) + let fnclause = PatClause fc (IImplicitApp fc (IVar fc cn) (Just (UN "__con")) conapp) - (mkLam argns + (mkLam argns (apply (IVar fc (methName n)) (map (IVar fc) argns))) let fndef = IDef fc cn [fnclause] pure [tydecl, fndef] where applyCon : Name -> (Name, RawImp) - applyCon n = (n, IImplicitApp fc (IVar fc n) + applyCon n = (n, IImplicitApp fc (IVar fc n) (Just (UN "__con")) (IVar fc (UN "__con"))) getExplicitArgs : Int -> RawImp -> List Name @@ -139,7 +139,7 @@ getMethToplevel {vars} env vis iname cname constraints allmeths params mkLam : List Name -> RawImp -> RawImp mkLam [] tm = tm - mkLam (x :: xs) tm + mkLam (x :: xs) tm = ILam fc RigW Explicit (Just x) (Implicit fc False) (mkLam xs tm) bindName : Name -> String @@ -153,7 +153,7 @@ getMethToplevel {vars} env vis iname cname constraints allmeths params -- Get the function for chasing a constraint. This is one of the -- arguments to the record, appearing before the method arguments. getConstraintHint : {auto c : Ref Ctxt Defs} -> - FC -> Env Term vars -> Visibility -> + FC -> Env Term vars -> Visibility -> Name -> Name -> (constraints : List Name) -> (allmeths : List Name) -> @@ -162,14 +162,14 @@ getConstraintHint : {auto c : Ref Ctxt Defs} -> getConstraintHint {vars} fc env vis iname cname constraints meths params (cn, con) = do let ity = apply (IVar fc iname) (map (IVar fc) params) let fty = IPi fc RigW Explicit Nothing ity con - ty_imp <- bindTypeNames (meths ++ vars) fty + ty_imp <- bindTypeNames (meths ++ vars) fty let hintname = DN ("Constraint " ++ show con) (UN ("__" ++ show iname ++ "_" ++ show con)) - let tydecl = IClaim fc RigW vis [Inline, Hint False] + let tydecl = IClaim fc RigW vis [Inline, Hint False] (MkImpTy fc hintname ty_imp) let conapp = apply (IVar fc cname) (map (IBindVar fc) (map bindName constraints) ++ - map (const (Implicit fc True)) meths) + map (const (Implicit fc True)) meths) let fnclause = PatClause fc (IApp fc (IVar fc hintname) conapp) (IVar fc (constName cn)) let fndef = IDef fc hintname [fnclause] @@ -193,9 +193,9 @@ getDefault (IDef fc n cs) = Just (fc, [], n, cs) getDefault _ = Nothing mkCon : FC -> Name -> Name -mkCon loc (NS ns (UN n)) +mkCon loc (NS ns (UN n)) = NS ns (DN (n ++ " at " ++ show loc) (UN ("__mk" ++ n))) -mkCon loc n +mkCon loc n = DN (show n ++ " at " ++ show loc) (UN ("__mk" ++ show n)) updateIfaceSyn : {auto s : Ref Syn SyntaxInfo} -> @@ -212,7 +212,7 @@ elabInterface : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {auto s : Ref Syn SyntaxInfo} -> {auto m : Ref MD Metadata} -> - FC -> Visibility -> + FC -> Visibility -> Env Term vars -> NestedNames vars -> (constraints : List (Maybe Name, RawImp)) -> Name -> @@ -239,13 +239,13 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body ns_meths <- traverse (\mt => do n <- inCurrentNS (fst mt) pure (n, snd mt)) meth_decls ns_iname <- inCurrentNS fullIName - updateIfaceSyn ns_iname conName + updateIfaceSyn ns_iname conName (map fst params) (map snd constraints) ns_meths ds where nameCons : Int -> List (Maybe Name, RawImp) -> List (Name, RawImp) nameCons i [] = [] - nameCons i ((_, ty) :: rest) + nameCons i ((_, ty) :: rest) = (UN ("__con" ++ show i), ty) :: nameCons (i + 1) rest -- Elaborate the data declaration part of the interface @@ -257,13 +257,13 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body -- signatures and constraint hints meths <- traverse (getMethDecl env nest params meth_names) meth_sigs log 5 $ "Method declarations: " ++ show meths - - consts <- traverse (getMethDecl env nest params meth_names) + + consts <- traverse (getMethDecl env nest params meth_names) (map (\c => (fc, Rig1, [], c)) (map notData constraints)) log 5 $ "Constraints: " ++ show consts - dt <- mkIfaceData fc vis env consts iname conName params + dt <- mkIfaceData fc vis env consts iname conName params dets meths log 10 $ "Methods: " ++ show meths log 5 $ "Making interface data type " ++ show dt @@ -273,7 +273,7 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body notData : (n, t) -> (n, (Bool, t)) notData (x, y) = (x, (False, y)) - elabMethods : (conName : Name) -> List Name -> + elabMethods : (conName : Name) -> List Name -> List (FC, RigCount, List FnOpt, Name, (Bool, RawImp)) -> Core () elabMethods conName meth_names meth_sigs @@ -293,14 +293,14 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body -- we know it's okay, since we'll need to re-elaborate it for each -- instance, to specialise it elabDefault : List (Name, RigCount, (Bool, RawImp)) -> - (FC, List FnOpt, Name, List ImpClause) -> + (FC, List FnOpt, Name, List ImpClause) -> Core (Name, List ImpClause) - elabDefault tydecls (fc, opts, n, cs) + elabDefault tydecls (fc, opts, n, cs) = do -- orig <- branch let dn_in = UN ("Default implementation of " ++ show n) dn <- inCurrentNS dn_in - (rig, dty) <- + (rig, dty) <- the (Core (RigCount, RawImp)) $ case lookup n tydecls of Just (r, (_, t)) => pure (r, t) @@ -310,9 +310,9 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body -- Substitute the method names with their top level function -- name, so they don't get implicitly bound in the name - methNameMap <- traverse (\n => + methNameMap <- traverse (\n => do cn <- inCurrentNS n - pure (n, applyParams (IVar fc cn) + pure (n, applyParams (IVar fc cn) (map fst params))) (map fst tydecls) let dty = substNames vars methNameMap dty @@ -320,7 +320,7 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body dty_imp <- bindTypeNames (map fst tydecls ++ vars) (bindIFace fc ity dty) log 5 $ "Default method " ++ show dn ++ " : " ++ show dty_imp - let dtydecl = IClaim fc rig vis [] (MkImpTy fc dn dty_imp) + let dtydecl = IClaim fc rig vis [] (MkImpTy fc dn dty_imp) processDecl [] nest env dtydecl let cs' = map (changeName dn) cs @@ -348,9 +348,9 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body changeNameTerm dn tm = tm changeName : Name -> ImpClause -> ImpClause - changeName dn (PatClause fc lhs rhs) + changeName dn (PatClause fc lhs rhs) = PatClause fc (changeNameTerm dn lhs) rhs - changeName dn (ImpossibleClause fc lhs) + changeName dn (ImpossibleClause fc lhs) = ImpossibleClause fc (changeNameTerm dn lhs) elabConstraintHints : (conName : Name) -> List Name -> diff --git a/src/Idris/Error.idr b/src/Idris/Error.idr index 6d29860..2bee7c1 100644 --- a/src/Idris/Error.idr +++ b/src/Idris/Error.idr @@ -16,7 +16,7 @@ import Parser.Support pshow : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> Env Term vars -> Term vars -> Core String -pshow env tm +pshow env tm = do defs <- get Ctxt itm <- resugar env !(normaliseHoles defs env tm) pure (show itm) @@ -24,7 +24,7 @@ pshow env tm pshowNoNorm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> Env Term vars -> Term vars -> Core String -pshowNoNorm env tm +pshowNoNorm env tm = do defs <- get Ctxt itm <- resugar env tm pure (show itm) @@ -37,10 +37,10 @@ perror (Fatal err) = perror err perror (CantConvert _ env l r) = pure $ "Mismatch between:\n\t" ++ !(pshow env l) ++ "\nand\n\t" ++ !(pshow env r) perror (CantSolveEq _ env l r) - = pure $ "Can't solve constraint between:\n\t" ++ !(pshow env l) ++ + = pure $ "Can't solve constraint between:\n\t" ++ !(pshow env l) ++ "\nand\n\t" ++ !(pshow env r) perror (PatternVariableUnifies _ env n tm) - = pure $ "Pattern variable " ++ showPVar n ++ + = pure $ "Pattern variable " ++ showPVar n ++ " unifies with:\n\t" ++ !(pshow env tm) where showPVar : Name -> String @@ -72,7 +72,7 @@ perror (NotCovering fc n (MissingCases cs)) showSep "\n\t" !(traverse (pshow []) cs) perror (NotCovering fc n (NonCoveringCall ns)) = pure $ show n ++ " is not covering:\n\t" ++ - "Calls non covering function" + "Calls non covering function" ++ case ns of [fn] => " " ++ show fn _ => "s: " ++ showSep ", " (map show ns) @@ -94,11 +94,11 @@ perror (LinearMisuse fc n exp ctx) showRel Rig1 = "relevant" showRel RigW = "non-linear" perror (BorrowPartial fc env tm arg) - = pure $ !(pshow env tm) ++ - " borrows argument " ++ !(pshow env arg) ++ + = pure $ !(pshow env tm) ++ + " borrows argument " ++ !(pshow env arg) ++ " so must be fully applied" perror (BorrowPartialType fc env tm) - = pure $ !(pshow env tm) ++ + = pure $ !(pshow env tm) ++ " borrows, so must return a concrete type" perror (AmbiguousName fc ns) = pure $ "Ambiguous name " ++ show ns perror (AmbiguousElab fc env ts) @@ -137,12 +137,12 @@ perror (NotRecordField fc fld (Just ty)) perror (NotRecordType fc ty) = pure $ show ty ++ " is not a record type" perror (IncompatibleFieldUpdate fc flds) - = pure $ "Field update " ++ showSep "->" flds ++ + = pure $ "Field update " ++ showSep "->" flds ++ " not compatible with other updates" perror (InvalidImplicits _ env [Just n] tm) = pure $ show n ++ " is not a valid implicit argument in " ++ !(pshow env tm) perror (InvalidImplicits _ env ns tm) - = pure $ showSep ", " (map show ns) ++ + = pure $ showSep ", " (map show ns) ++ " are not valid implicit arguments in " ++ !(pshow env tm) perror (TryWithImplicits _ env imps) = pure $ "Need to bind implicits " @@ -159,19 +159,19 @@ perror (CantSolveGoal _ env g) where -- For display, we don't want to see the full top level type; just the -- return type - dropPis : Env Term vars -> Term vars -> + dropPis : Env Term vars -> Term vars -> (ns ** (Env Term ns, Term ns)) - dropPis env (Bind _ n b@(Pi _ _ _) sc) = dropPis (b :: env) sc + dropPis env (Bind _ n b@(Pi _ _ _) sc) = dropPis (b :: env) sc dropPis env tm = (_ ** (env, tm)) perror (DeterminingArg _ n i env g) = pure $ "Can't find an implementation for " ++ !(pshow env g) ++ "\n" ++ "since I can't infer a value for argument " ++ show n -perror (UnsolvedHoles hs) +perror (UnsolvedHoles hs) = pure $ "Unsolved holes:\n" ++ showHoles hs where showHoles [] = "" - showHoles ((fc, n) :: hs) = show n ++ " introduced at " ++ show fc ++ "\n" + showHoles ((fc, n) :: hs) = show n ++ " introduced at " ++ show fc ++ "\n" ++ showHoles hs perror (CantInferArgType _ env n h ty) = pure $ "Can't infer type for argument " ++ show n ++ "\n" ++ @@ -180,7 +180,7 @@ perror (SolvedNamedHole _ env h tm) = pure $ "Named hole " ++ show h ++ " has been solved by unification\n" ++ "Result: " ++ !(pshow env tm) perror (VisibilityError fc vx x vy y) - = pure $ show vx ++ " " ++ sugarName x ++ + = pure $ show vx ++ " " ++ sugarName x ++ " cannot refer to " ++ show vy ++ " " ++ sugarName y perror (NonLinearPattern _ n) = pure $ "Non linear pattern " ++ sugarName n perror (BadPattern _ n) = pure $ "Pattern not allowed here: " ++ show n @@ -189,7 +189,7 @@ perror (AlreadyDefined _ n) = pure $ show n ++ " is already defined" perror (NotFunctionType _ env tm) = pure $ !(pshow env tm) ++ " is not a function type" perror (RewriteNoChange _ env rule ty) - = pure $ "Rewriting by " ++ !(pshow env rule) ++ + = pure $ "Rewriting by " ++ !(pshow env rule) ++ " did not change type " ++ !(pshow env ty) perror (NotRewriteRule fc env rule) = pure $ !(pshow env rule) ++ " is not a rewrite rule type" @@ -199,24 +199,24 @@ perror (CaseCompile _ n DifferingTypes) = pure $ "Patterns for " ++ show n ++ " require matching on different types" perror (CaseCompile _ n UnknownType) = pure $ "Can't infer type to match in " ++ show n -perror (CaseCompile fc n (MatchErased (_ ** (env, tm)))) - = pure $ "Attempt to match on erased argument " ++ !(pshow env tm) ++ +perror (CaseCompile fc n (MatchErased (_ ** (env, tm)))) + = pure $ "Attempt to match on erased argument " ++ !(pshow env tm) ++ " in " ++ show n perror (BadDotPattern _ env reason x y) = pure $ "Can't match on " ++ !(pshow env x) ++ (if reason /= "" then " (" ++ reason ++ ")" else "") ++ "\n" ++ "It elaborates to: " ++ !(pshow env y) perror (MatchTooSpecific _ env tm) - = pure $ "Can't match on " ++ !(pshow env tm) ++ + = pure $ "Can't match on " ++ !(pshow env tm) ++ " as it has a polymorphic type" -perror (BadImplicit _ str) +perror (BadImplicit _ str) = pure $ "Can't infer type for unbound implicit name " ++ str ++ "\n" ++ "Try making it a bound implicit." perror (BadRunElab _ env script) = pure $ "Bad elaborator script " ++ !(pshow env script) perror (GenericMsg _ str) = pure str perror (TTCError msg) = pure $ "Error in TTC file: " ++ show msg -perror (FileErr fname err) +perror (FileErr fname err) = pure $ "File error in " ++ fname ++ ": " ++ show err perror (ParseFail _ err) = pure $ show err @@ -231,22 +231,22 @@ perror ForceNeeded = pure "Internal error when resolving implicit laziness" perror (InternalError str) = pure $ "INTERNAL ERROR: " ++ str perror (InType fc n err) - = pure $ "While processing type of " ++ sugarName !(getFullName n) ++ + = pure $ "While processing type of " ++ sugarName !(getFullName n) ++ " at " ++ show fc ++ ":\n" ++ !(perror err) perror (InCon fc n err) - = pure $ "While processing constructor " ++ sugarName !(getFullName n) ++ + = pure $ "While processing constructor " ++ sugarName !(getFullName n) ++ " at " ++ show fc ++ ":\n" ++ !(perror err) perror (InLHS fc n err) - = pure $ "While processing left hand side of " ++ sugarName !(getFullName n) ++ + = pure $ "While processing left hand side of " ++ sugarName !(getFullName n) ++ " at " ++ show fc ++ ":\n" ++ !(perror err) perror (InRHS fc n err) - = pure $ "While processing right hand side of " ++ sugarName !(getFullName n) ++ + = pure $ "While processing right hand side of " ++ sugarName !(getFullName n) ++ " at " ++ show fc ++ ":\n" ++ !(perror err) export display : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> Error -> Core String -display err +display err = pure $ maybe "" (\f => show f ++ ":") (getErrorLoc err) ++ !(perror err) diff --git a/src/Idris/IDEMode/CaseSplit.idr b/src/Idris/IDEMode/CaseSplit.idr index 44b2af7..55235bf 100644 --- a/src/Idris/IDEMode/CaseSplit.idr +++ b/src/Idris/IDEMode/CaseSplit.idr @@ -51,13 +51,13 @@ dump (Other str) = str data UPD : Type where doUpdates : {auto u : Ref UPD (List String)} -> - Defs -> List (String, String) -> List SourcePart -> + Defs -> List (String, String) -> List SourcePart -> Core (List SourcePart) doUpdates defs ups [] = pure [] doUpdates defs ups (LBrace :: xs) = case dropSpace xs of Name n :: RBrace :: rest => - pure (LBrace :: Name n :: + pure (LBrace :: Name n :: Whitespace " " :: Equal :: Whitespace " " :: !(doUpdates defs ups (Name n :: RBrace :: rest))) Name n :: Equal :: rest => @@ -80,14 +80,14 @@ doUpdates defs ups (HoleName n :: xs) n' <- uniqueName defs used n put UPD (n' :: used) pure $ HoleName n' :: !(doUpdates defs ups xs) -doUpdates defs ups (x :: xs) +doUpdates defs ups (x :: xs) = pure $ x :: !(doUpdates defs ups xs) -- State here is a list of new hole names we generated (so as not to reuse any). --- Update the token list with the string replacements for each match, and return +-- Update the token list with the string replacements for each match, and return -- the newly generated strings. updateAll : {auto u : Ref UPD (List String)} -> - Defs -> List SourcePart -> List (List (String, String)) -> + Defs -> List SourcePart -> List (List (String, String)) -> Core (List String) updateAll defs l [] = pure [] updateAll defs l (rs :: rss) @@ -104,7 +104,7 @@ getReplaces : {auto c : Ref Ctxt Defs} -> getReplaces updates = do strups <- traverse toStrUpdate updates pure (concat strups) - + showImpossible : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> {auto o : Ref ROpts REPLOpts} -> @@ -131,7 +131,7 @@ updateCase splits line col let thisline = getLine (cast line) (lines file) case thisline of Nothing => throw (InternalError "File too short!") - Just l => + Just l => do let valid = mapMaybe getValid splits let bad = mapMaybe getBad splits if isNil valid @@ -151,7 +151,7 @@ updateCase splits line col getBad _ = Nothing fnName : Bool -> Name -> String -fnName lhs (UN n) +fnName lhs (UN n) = if any (not . identChar) (unpack n) then if lhs then "(" ++ n ++ ")" else "op" @@ -171,7 +171,7 @@ getClause l n | Nothing => pure Nothing n <- getFullName nidx argns <- getEnvArgNames defs envlen !(nf defs [] ty) - pure (Just (indent loc ++ fnName True n ++ concat (map (" " ++) argns) ++ + pure (Just (indent loc ++ fnName True n ++ concat (map (" " ++) argns) ++ " = ?" ++ fnName False n ++ "_rhs")) where indent : FC -> String diff --git a/src/Idris/IDEMode/MakeClause.idr b/src/Idris/IDEMode/MakeClause.idr index c989b9f..9e79b3b 100644 --- a/src/Idris/IDEMode/MakeClause.idr +++ b/src/Idris/IDEMode/MakeClause.idr @@ -6,7 +6,7 @@ import Parser.Lexer -- Implement make-with and make-case from the IDE mode isLit : String -> (Bool, String) -isLit str +isLit str = assert_total $ if length str > 0 && strHead str == '>' then (True, strTail str) @@ -27,7 +27,7 @@ makeWith n srcline case span isSpace src of (spc, rest) => (length spc, rest) indent = fst isrc - src = snd isrc + src = snd isrc lhs = pack (readLHS 0 (unpack src)) in mkWithArg lit indent lhs ++ "\n" ++ mkWithPat lit indent lhs ++ "\n" @@ -43,15 +43,15 @@ makeWith n srcline pref : Bool -> Nat -> String pref l ind - = (if l then ">" else "") ++ + = (if l then ">" else "") ++ pack (replicate ind ' ') mkWithArg : Bool -> Nat -> String -> String - mkWithArg lit indent lhs + mkWithArg lit indent lhs = pref lit indent ++ lhs ++ "with (_)" mkWithPat : Bool -> Nat -> String -> String - mkWithPat lit indent lhs - = pref lit (indent + 2) ++ lhs ++ "| with_pat = ?" ++ + mkWithPat lit indent lhs + = pref lit (indent + 2) ++ lhs ++ "| with_pat = ?" ++ showRHSName n ++ "_rhs" diff --git a/src/Idris/IDEMode/Parser.idr b/src/Idris/IDEMode/Parser.idr index e1ea0fc..120bd7e 100644 --- a/src/Idris/IDEMode/Parser.idr +++ b/src/Idris/IDEMode/Parser.idr @@ -30,7 +30,7 @@ ident = pred startIdent <+> many (pred validIdent) validIdent x = isAlphaNum x ideTokens : TokenMap Token -ideTokens = +ideTokens = map (\x => (exact x, Symbol)) symbols ++ [(digits, \x => Literal (cast x)), (stringLit, \x => StrLit (stripQuotes x)), @@ -42,11 +42,11 @@ ideTokens = stripQuotes = assert_total (strTail . reverse . strTail . reverse) idelex : String -> Either (Int, Int, String) (List (TokenData Token)) -idelex str +idelex str = case lex ideTokens str of -- Add the EndInput token so that we'll have a line and column -- number to read when storing spans in the file - (tok, (l, c, "")) => Right (filter notComment tok ++ + (tok, (l, c, "")) => Right (filter notComment tok ++ [MkToken l c EndInput]) (_, fail) => Left fail where @@ -65,7 +65,7 @@ sexp pure (IntegerAtom i) <|> do str <- strLit pure (StringAtom str) - <|> do symbol ":"; x <- unqualifiedName + <|> do symbol ":"; x <- unqualifiedName pure (SymbolAtom x) <|> do symbol "(" xs <- many sexp @@ -73,14 +73,14 @@ sexp pure (SExpList xs) ideParser : String -> Grammar (TokenData Token) e ty -> Either ParseError ty -ideParser str p +ideParser str p = case idelex str of Left err => Left $ LexFail err - Right toks => + Right toks => case parse p toks of - Left (Error err []) => + Left (Error err []) => Left $ ParseFail err Nothing [] - Left (Error err (t :: ts)) => + Left (Error err (t :: ts)) => Left $ ParseFail err (Just (line t, col t)) (map tok (t :: ts)) Right (val, _) => Right val diff --git a/src/Idris/IDEMode/TokenLine.idr b/src/Idris/IDEMode/TokenLine.idr index 33d9cfa..ac3f3d4 100644 --- a/src/Idris/IDEMode/TokenLine.idr +++ b/src/Idris/IDEMode/TokenLine.idr @@ -30,7 +30,7 @@ holeIdent : Lexer holeIdent = is '?' <+> ident srcTokens : TokenMap SourcePart -srcTokens = +srcTokens = [(ident, Name), (holeIdent, \x => HoleName (assert_total (strTail x))), (space, Whitespace), @@ -41,10 +41,10 @@ srcTokens = export tokens : String -> List SourcePart -tokens str +tokens str = case lex srcTokens str of -- Add the EndInput token so that we'll have a line and column -- number to read when storing spans in the file - (srctoks, (l, c, rest)) => + (srctoks, (l, c, rest)) => map tok srctoks ++ (if rest == "" then [] else [Other rest]) diff --git a/src/Idris/REPL.idr b/src/Idris/REPL.idr index b557bad..3d8cc29 100644 --- a/src/Idris/REPL.idr +++ b/src/Idris/REPL.idr @@ -560,7 +560,7 @@ process (Editing cmd) processEdit cmd setPPrint ppopts pure True -process Quit +process Quit = pure False process NOP = pure True @@ -653,8 +653,8 @@ repl repeat <- interpret inp end <- coreLift $ fEOF stdin if repeat && not end - then repl - else + then repl + else do iputStrLn "Bye for now!" pure () diff --git a/src/Idris/REPLCommon.idr b/src/Idris/REPLCommon.idr index 1cd984d..334d88d 100644 --- a/src/Idris/REPLCommon.idr +++ b/src/Idris/REPLCommon.idr @@ -22,9 +22,9 @@ iputStrLn msg REPL False => coreLift $ putStrLn msg REPL _ => pure () IDEMode i _ f => - send f (SExpList [SymbolAtom "write-string", + send f (SExpList [SymbolAtom "write-string", toSExp msg, toSExp i]) - + printWithStatus : {auto o : Ref ROpts REPLOpts} -> String -> String -> Core () @@ -33,7 +33,7 @@ printWithStatus status msg case idemode opts of REPL _ => coreLift $ putStrLn msg IDEMode i _ f => - do let m = SExpList [SymbolAtom status, toSExp msg, + do let m = SExpList [SymbolAtom status, toSExp msg, -- highlighting; currently blank SExpList []] send f (SExpList [SymbolAtom "return", m, toSExp i]) @@ -58,7 +58,7 @@ emitError : {auto c : Ref Ctxt Defs} -> emitError err = do opts <- get ROpts case idemode opts of - REPL _ => + REPL _ => do msg <- display err coreLift $ putStrLn msg IDEMode i _ f => @@ -66,10 +66,10 @@ emitError err case getErrorLoc err of Nothing => iputStrLn msg Just fc => - send f (SExpList [SymbolAtom "warning", - SExpList [toSExp (file fc), - toSExp (addOne (startPos fc)), - toSExp (addOne (endPos fc)), + send f (SExpList [SymbolAtom "warning", + SExpList [toSExp (file fc), + toSExp (addOne (startPos fc)), + toSExp (addOne (endPos fc)), toSExp msg, -- highlighting; currently blank SExpList []], diff --git a/src/Idris/REPLOpts.idr b/src/Idris/REPLOpts.idr index be35ff0..3d92921 100644 --- a/src/Idris/REPLOpts.idr +++ b/src/Idris/REPLOpts.idr @@ -4,7 +4,7 @@ import Idris.Syntax import Idris.Socket public export -data OutputMode +data OutputMode = IDEMode Integer File File | REPL Bool -- quiet flag (ignore iputStrLn) @@ -53,7 +53,7 @@ setSource src export getSource : {auto o : Ref ROpts REPLOpts} -> Core String -getSource +getSource = do opts <- get ROpts pure (source opts) diff --git a/src/Idris/Resugar.idr b/src/Idris/Resugar.idr index 0ba37cc..444a143 100644 --- a/src/Idris/Resugar.idr +++ b/src/Idris/Resugar.idr @@ -131,7 +131,7 @@ mutual = pure (sugarApp (PRef fc (UN n))) toPTerm p (IVar loc (Nested _ n)) = toPTerm p (IVar loc n) - toPTerm p (IVar fc n) + toPTerm p (IVar fc n) = do ns <- fullNamespace pure (sugarApp (PRef fc (if ns then n else dropNS n))) toPTerm p (IPi fc rig Implicit n arg ret) @@ -168,7 +168,7 @@ mutual bracket p startPrec (mkIf (PCase fc sc' alts')) where mkIf : PTerm -> PTerm - mkIf tm@(PCase loc sc [MkPatClause _ (PRef _ tval) t [], + mkIf tm@(PCase loc sc [MkPatClause _ (PRef _ tval) t [], MkPatClause _ (PRef _ fval) f []]) = if dropNS tval == UN "True" && dropNS fval == UN "False" then PIfThenElse loc sc t f @@ -190,7 +190,7 @@ mutual = do arg' <- toPTerm startPrec arg fn' <- toPTerm startPrec fn bracket p appPrec (PWithApp fc fn' arg') - toPTerm p (IImplicitApp fc fn n arg) + toPTerm p (IImplicitApp fc fn n arg) = do arg' <- toPTerm startPrec arg app <- toPTermApp fn [(fc, Just n, arg')] imp <- showImplicits @@ -199,7 +199,7 @@ mutual else mkOp app toPTerm p (ISearch fc d) = pure (PSearch fc d) toPTerm p (IAlternative fc _ _) = pure (PImplicit fc) - toPTerm p (IRewrite fc rule tm) + toPTerm p (IRewrite fc rule tm) = pure (PRewrite fc !(toPTerm startPrec rule) !(toPTerm startPrec tm)) toPTerm p (ICoerced fc tm) = toPTerm p tm @@ -221,7 +221,7 @@ mutual mkApp : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> PTerm -> List (FC, Maybe (Maybe Name), PTerm) -> Core PTerm - mkApp fn [] = pure fn + mkApp fn [] = pure fn mkApp fn ((fc, Nothing, arg) :: rest) = do let ap = sugarApp (PApp fc fn arg) mkApp ap rest @@ -236,10 +236,10 @@ mutual {auto s : Ref Syn SyntaxInfo} -> RawImp -> List (FC, Maybe (Maybe Name), PTerm) -> Core PTerm - toPTermApp (IApp fc f a) args + toPTermApp (IApp fc f a) args = do a' <- toPTerm argPrec a toPTermApp f ((fc, Nothing, a') :: args) - toPTermApp (IImplicitApp fc f n a) args + toPTermApp (IImplicitApp fc f n a) args = do a' <- toPTerm startPrec a toPTermApp f ((fc, Just n, a') :: args) toPTermApp fn@(IVar fc n) args @@ -249,12 +249,12 @@ mutual mkApp fn' args Just def => do fn' <- toPTerm appPrec fn fenv <- showFullEnv - let args' - = if fenv + let args' + = if fenv then args else drop (length (vars def)) args mkApp fn' args' - toPTermApp fn args + toPTermApp fn args = do fn' <- toPTerm appPrec fn mkApp fn' args @@ -306,10 +306,10 @@ mutual toPRecord : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - ImpRecord -> + ImpRecord -> Core (Name, List (Name, PTerm), Maybe Name, List PField) toPRecord (MkImpRecord fc n ps con fs) - = do ps' <- traverse (\ (n, ty) => + = do ps' <- traverse (\ (n, ty) => do ty' <- toPTerm startPrec ty pure (n, ty')) ps fs' <- traverse toPField fs @@ -319,7 +319,7 @@ mutual toPDecl : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> ImpDecl -> Core (Maybe PDecl) - toPDecl (IClaim fc rig vis opts ty) + toPDecl (IClaim fc rig vis opts ty) = pure (Just (PClaim fc rig vis opts !(toPTypeDecl ty))) toPDecl (IData fc vis d) = pure (Just (PData fc vis !(toPData d))) @@ -327,7 +327,7 @@ mutual = pure (Just (PDef fc !(traverse toPClause cs))) toPDecl (IParameters fc ps ds) = do ds' <- traverse toPDecl ds - pure (Just (PParameters fc + pure (Just (PParameters fc !(traverse (\ntm => do tm' <- toPTerm startPrec (snd ntm) pure (fst ntm, tm')) ps) (mapMaybe id ds'))) @@ -347,7 +347,7 @@ resugar : {auto c : Ref Ctxt Defs} -> resugar env tm = do tti <- unelab env tm toPTerm startPrec tti - + export resugarNoPatvars : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> @@ -355,7 +355,7 @@ resugarNoPatvars : {auto c : Ref Ctxt Defs} -> resugarNoPatvars env tm = do tti <- unelabNoPatvars env tm toPTerm startPrec tti - + export pterm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> diff --git a/src/Parser/Lexer.idr b/src/Parser/Lexer.idr index 000b8ae..99652e3 100644 --- a/src/Parser/Lexer.idr +++ b/src/Parser/Lexer.idr @@ -44,8 +44,8 @@ comment = is '-' <+> is '-' <+> many (isNot '\n') toEndComment : (k : Nat) -> Recognise (k /= 0) toEndComment Z = empty -toEndComment (S k) - = some (pred (\c => c /= '-' && c /= '{')) +toEndComment (S k) + = some (pred (\c => c /= '-' && c /= '{')) <+> toEndComment (S k) <|> is '{' <+> is '-' <+> toEndComment (S (S k)) <|> is '-' <+> is '}' <+> toEndComment k @@ -54,7 +54,7 @@ toEndComment (S k) blockComment : Lexer blockComment = is '{' <+> is '-' <+> toEndComment 1 - + docComment : Lexer docComment = is '|' <+> is '|' <+> is '|' <+> many (isNot '\n') @@ -74,7 +74,7 @@ holeIdent : Lexer holeIdent = is '?' <+> ident doubleLit : Lexer -doubleLit +doubleLit = digits <+> is '.' <+> digits <+> opt (is 'e' <+> opt (is '-' <|> is '+') <+> digits) @@ -82,11 +82,11 @@ doubleLit -- a specific back end cgDirective : Lexer cgDirective - = exact "%cg" <+> - ((some space <+> + = exact "%cg" <+> + ((some space <+> some (pred isAlphaNum) <+> many space <+> - is '{' <+> many (isNot '}') <+> - is '}') + is '{' <+> many (isNot '}') <+> + is '}') <|> many (isNot '\n')) mkDirective : String -> Token @@ -113,10 +113,10 @@ special = ["%lam", "%pi", "%imppi", "%let"] -- don't match 'validSymbol' export symbols : List String -symbols +symbols = [".(", -- for things such as Foo.Bar.(+) "@{", - "(", ")", "{", "}", "[", "]", ",", ";", "_", + "(", ")", "{", "}", "[", "]", ",", ";", "_", "`(", "`"] export @@ -130,14 +130,14 @@ validSymbol = some (oneOf opChars) export reservedSymbols : List String reservedSymbols - = symbols ++ + = symbols ++ ["%", "\\", ":", "=", "|", "|||", "<-", "->", "=>", "?", "&", "**", ".."] symbolChar : Char -> Bool symbolChar c = c `elem` unpack opChars rawTokens : TokenMap Token -rawTokens = +rawTokens = [(comment, Comment), (blockComment, Comment), (docComment, DocComment), @@ -160,11 +160,11 @@ rawTokens = export lexTo : (TokenData Token -> Bool) -> String -> Either (Int, Int, String) (List (TokenData Token)) -lexTo pred str +lexTo pred str = case lexTo pred rawTokens str of -- Add the EndInput token so that we'll have a line and column -- number to read when storing spans in the file - (tok, (l, c, "")) => Right (filter notComment tok ++ + (tok, (l, c, "")) => Right (filter notComment tok ++ [MkToken l c EndInput]) (_, fail) => Left fail where diff --git a/src/Parser/Support.idr b/src/Parser/Support.idr index 52de797..007964e 100644 --- a/src/Parser/Support.idr +++ b/src/Parser/Support.idr @@ -26,15 +26,15 @@ export Show ParseError where show (ParseFail err loc toks) = "Parse error: " ++ err ++ " (next tokens: " - ++ show (take 10 toks) ++ ")" - show (LexFail (c, l, str)) + ++ show (take 10 toks) ++ ")" + show (LexFail (c, l, str)) = "Lex error at " ++ show (c, l) ++ " input: " ++ str show (FileFail err) = "File error: " ++ show err export eoi : EmptyRule () -eoi +eoi = do nextIs "Expected end of input" (isEOI . tok) pure () where @@ -45,14 +45,14 @@ eoi export runParserTo : (TokenData Token -> Bool) -> String -> Grammar (TokenData Token) e ty -> Either ParseError ty -runParserTo pred str p +runParserTo pred str p = case lexTo pred str of Left err => Left $ LexFail err - Right toks => + Right toks => case parse p toks of - Left (Error err []) => + Left (Error err []) => Left $ ParseFail err Nothing [] - Left (Error err (t :: ts)) => + Left (Error err (t :: ts)) => Left $ ParseFail err (Just (line t, col t)) (map tok (t :: ts)) Right (val, _) => Right val @@ -73,7 +73,7 @@ parseFile fn p export location : EmptyRule (Int, Int) -location +location = do tok <- peek pure (line tok, col tok) @@ -176,29 +176,29 @@ escape' ('\\' :: 't' :: xs) = pure $ '\t' :: !(escape' xs) escape' ('\\' :: 'v' :: xs) = pure $ '\v' :: !(escape' xs) escape' ('\\' :: '\'' :: xs) = pure $ '\'' :: !(escape' xs) escape' ('\\' :: '\"' :: xs) = pure $ '\"' :: !(escape' xs) -escape' ('\\' :: 'x' :: xs) +escape' ('\\' :: 'x' :: xs) = case span isHexDigit xs of ([], rest) => assert_total (escape' rest) - (ds, rest) => pure $ cast !(toHex 1 (reverse ds)) :: + (ds, rest) => pure $ cast !(toHex 1 (reverse ds)) :: !(assert_total (escape' rest)) - where + where toHex : Int -> List Char -> Maybe Int toHex _ [] = Just 0 - toHex m (d :: ds) + toHex m (d :: ds) = pure $ !(hex (toLower d)) * m + !(toHex (m*16) ds) -escape' ('\\' :: 'o' :: xs) +escape' ('\\' :: 'o' :: xs) = case span isOctDigit xs of ([], rest) => assert_total (escape' rest) - (ds, rest) => pure $ cast !(toOct 1 (reverse ds)) :: + (ds, rest) => pure $ cast !(toOct 1 (reverse ds)) :: !(assert_total (escape' rest)) - where + where toOct : Int -> List Char -> Maybe Int toOct _ [] = Just 0 - toOct m (d :: ds) + toOct m (d :: ds) = pure $ !(oct (toLower d)) * m + !(toOct (m*8) ds) -escape' ('\\' :: xs) +escape' ('\\' :: xs) = case span isDigit xs of - ([], (a :: b :: c :: rest)) => + ([], (a :: b :: c :: rest)) => case getEsc (pack (the (List _) [a, b, c])) of Just v => Just (v :: !(assert_total (escape' rest))) Nothing => case getEsc (pack (the (List _) [a, b])) of @@ -209,7 +209,7 @@ escape' ('\\' :: xs) Just v => Just (v :: []) Nothing => escape' xs ([], rest) => assert_total (escape' rest) - (ds, rest) => Just $ cast (cast {to=Int} (pack ds)) :: + (ds, rest) => Just $ cast (cast {to=Int} (pack ds)) :: !(assert_total (escape' rest)) escape' (x :: xs) = Just $ x :: !(escape' xs) @@ -227,7 +227,7 @@ getCharLit str export constant : Rule Constant -constant +constant = terminal "Expected constant" (\x => case tok x of Literal i => Just (BI i) @@ -247,7 +247,7 @@ constant export intLit : Rule Integer -intLit +intLit = terminal "Expected integer literal" (\x => case tok x of Literal i => Just i @@ -255,7 +255,7 @@ intLit export strLit : Rule String -strLit +strLit = terminal "Expected string literal" (\x => case tok x of StrLit s => Just s @@ -293,14 +293,14 @@ operator : Rule String operator = terminal "Expected operator" (\x => case tok x of - Symbol s => - if s `elem` reservedSymbols + Symbol s => + if s `elem` reservedSymbols then Nothing else Just s _ => Nothing) identPart : Rule String -identPart +identPart = terminal "Expected name" (\x => case tok x of Ident str => Just str @@ -308,13 +308,13 @@ identPart export namespace_ : Rule (List String) -namespace_ +namespace_ = do ns <- sepBy1 (do col <- column symbol "." col' <- column if (col' - col == 1) then pure () - else fail "No whitepace allowed after namespace separator") + else fail "No whitepace allowed after namespace separator") identPart pure (reverse ns) -- innermost first, so reverse @@ -324,7 +324,7 @@ unqualifiedName = identPart export holeName : Rule String -holeName +holeName = terminal "Expected hole name" (\x => case tok x of HoleIdent str => Just str @@ -332,8 +332,8 @@ holeName export name : Rule Name -name - = do ns <- namespace_ +name + = do ns <- namespace_ (do symbol ".(" op <- operator symbol ")" @@ -374,12 +374,12 @@ continue = continueF (fail "Unexpected end of expression") -- As 'continue' but failing is fatal (i.e. entire parse fails) export mustContinue : (indent : IndentInfo) -> Maybe String -> EmptyRule () -mustContinue indent Nothing +mustContinue indent Nothing = continueF (fatalError "Unexpected end of expression") indent -mustContinue indent (Just req) +mustContinue indent (Just req) = continueF (fatalError ("Expected '" ++ req ++ "'")) indent -data ValidIndent +data ValidIndent = AnyIndent -- In {}, entries can begin in any column | AtPos Int -- Entry must begin in a specific column | AfterPos Int -- Entry can begin in this column or later @@ -416,7 +416,7 @@ isTerminator _ = False -- Check we're at the end of a block entry, given the start column -- of the block. --- It's the end if we have a terminating token, or the next token starts +-- It's the end if we have a terminating token, or the next token starts -- in or before indent. Works by looking ahead but not consuming. export atEnd : (indent : IndentInfo) -> EmptyRule () @@ -452,8 +452,8 @@ terminator valid laststart afterDedent valid col <|> pure EndOfBlock where - -- Expected indentation for the next token can either be anything (if - -- we're inside a brace delimited block) or anywhere after the initial + -- Expected indentation for the next token can either be anything (if + -- we're inside a brace delimited block) or anywhere after the initial -- column (if we're inside an indentation delimited block) afterSemi : ValidIndent -> ValidIndent afterSemi AnyIndent = AnyIndent -- in braces, anything goes @@ -461,8 +461,8 @@ terminator valid laststart afterSemi (AfterPos c) = AfterPos c afterSemi EndOfBlock = EndOfBlock - -- Expected indentation for the next token can either be anything (if - -- we're inside a brace delimited block) or in exactly the initial column + -- Expected indentation for the next token can either be anything (if + -- we're inside a brace delimited block) or in exactly the initial column -- (if we're inside an indentation delimited block) afterDedent : ValidIndent -> Int -> EmptyRule ValidIndent afterDedent AnyIndent col @@ -480,7 +480,7 @@ terminator valid laststart afterDedent EndOfBlock col = pure EndOfBlock -- Parse an entry in a block -blockEntry : ValidIndent -> (IndentInfo -> Rule ty) -> +blockEntry : ValidIndent -> (IndentInfo -> Rule ty) -> Rule (ty, ValidIndent) blockEntry valid rule = do col <- column @@ -535,7 +535,7 @@ blockWithOptHeaderAfter {ty} mincol header item else do hidt <- optional $ blockEntry (AtPos col) header ps <- blockEntries (AtPos col) item pure (map fst hidt, ps) - where + where restOfBlock : Maybe (hd, ValidIndent) -> Rule (Maybe hd, List ty) restOfBlock (Just (h, idt)) = do ps <- blockEntries idt item symbol "}" diff --git a/src/TTImp/BindImplicits.idr b/src/TTImp/BindImplicits.idr index cb2afef..bf409ab 100644 --- a/src/TTImp/BindImplicits.idr +++ b/src/TTImp/BindImplicits.idr @@ -13,13 +13,13 @@ import Control.Monad.State -- Rename the IBindVars in a term. Anything which appears in the list 'renames' -- should be renamed, to something which is *not* in the list 'used' export -renameIBinds : (renames : List String) -> - (used : List String) -> +renameIBinds : (renames : List String) -> + (used : List String) -> RawImp -> State (List (String, String)) RawImp renameIBinds rs us (IPi fc c p (Just (UN n)) ty sc) - = if n `elem` rs + = if n `elem` rs then let n' = getUnique (rs ++ us) n - sc' = substNames (map UN (filter (/= n) us)) + sc' = substNames (map UN (filter (/= n) us)) [(UN n, IVar fc (UN n'))] sc in do scr <- renameIBinds rs (n' :: us) sc' ty' <- renameIBinds rs us ty @@ -141,6 +141,6 @@ piBindNames loc env tm where piBind : List String -> RawImp -> RawImp piBind [] ty = ty - piBind (n :: ns) ty + piBind (n :: ns) ty = IPi loc Rig0 Implicit (Just (UN n)) (Implicit loc False) (piBind ns ty) diff --git a/src/TTImp/Elab.idr b/src/TTImp/Elab.idr index 0cd0d59..6f02068 100644 --- a/src/TTImp/Elab.idr +++ b/src/TTImp/Elab.idr @@ -23,7 +23,7 @@ findPLetRenames (Bind fc n (PLet c (Local {name = x@(MN _ _)} _ _ _ p) ty) sc) findPLetRenames (Bind fc n _ sc) = findPLetRenames sc findPLetRenames tm = [] -doPLetRenames : List (Name, (RigCount, Name)) -> +doPLetRenames : List (Name, (RigCount, Name)) -> List Name -> Term vars -> Term vars doPLetRenames ns drops (Bind fc n b@(PLet _ _ _) sc) = if n `elem` drops @@ -31,7 +31,7 @@ doPLetRenames ns drops (Bind fc n b@(PLet _ _ _) sc) else Bind fc n b (doPLetRenames ns drops sc) doPLetRenames ns drops (Bind fc n b sc) = case lookup n ns of - Just (c, n') => + Just (c, n') => Bind fc n' (setMultiplicity b (max c (multiplicity b))) (doPLetRenames ns (n' :: drops) (renameTop n' sc)) Nothing => Bind fc n b (doPLetRenames ns drops sc) @@ -46,7 +46,7 @@ getRigNeeded _ = Rig1 -- away (since solved holes don't get written to .tti) export normaliseHoleTypes : {auto c : Ref Ctxt Defs} -> - {auto u : Ref UST UState} -> + {auto u : Ref UST UState} -> Core () normaliseHoleTypes = do ust <- get UST @@ -145,7 +145,7 @@ elabTermSub {vars} defining mode opts nest env env' sub tm ty -- need to check here. else pure chktm normaliseHoleTypes - -- Put the current hole state back to what it was (minus anything + -- Put the current hole state back to what it was (minus anything -- which has been solved in the meantime) when (not incase) $ do hs <- getHoles @@ -155,15 +155,15 @@ elabTermSub {vars} defining mode opts nest env env' sub tm ty -- were of the form x@_, where the _ is inferred to be a variable, -- to just x) case mode of - InLHS _ => + InLHS _ => do let vs = findPLetRenames chktm let ret = doPLetRenames vs [] chktm pure (ret, gnf env (doPLetRenames vs [] !(getTerm chkty))) _ => do dumpConstraints 2 False pure (chktm, chkty) where - addHoles : (acc : IntMap (FC, Name)) -> - (allHoles : IntMap (FC, Name)) -> + addHoles : (acc : IntMap (FC, Name)) -> + (allHoles : IntMap (FC, Name)) -> List (Int, (FC, Name)) -> IntMap (FC, Name) addHoles acc allhs [] = acc @@ -189,8 +189,8 @@ checkTermSub : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - Int -> ElabMode -> List ElabOpt -> - NestedNames vars -> Env Term vars -> + Int -> ElabMode -> List ElabOpt -> + NestedNames vars -> Env Term vars -> Env Term inner -> SubVars inner vars -> RawImp -> Glued vars -> Core (Term vars) @@ -201,9 +201,9 @@ checkTermSub defining mode opts nest env env' sub tm ty _ => get Ctxt ust <- get UST mv <- get MD - res <- + res <- catch {t = Error} - (elabTermSub defining mode opts nest + (elabTermSub defining mode opts nest env env' sub tm (Just ty)) (\err => case err of TryWithImplicits loc benv ns @@ -217,7 +217,7 @@ checkTermSub defining mode opts nest env env' sub tm ty _ => throw err) pure (fst res) where - bindImps : FC -> Env Term vs -> List (Name, Term vs) -> RawImp -> + bindImps : FC -> Env Term vs -> List (Name, Term vs) -> RawImp -> Core RawImp bindImps loc env [] ty = pure ty bindImps loc env ((n, ty) :: ntys) sc @@ -229,8 +229,8 @@ checkTerm : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - Int -> ElabMode -> List ElabOpt -> - NestedNames vars -> Env Term vars -> + Int -> ElabMode -> List ElabOpt -> + NestedNames vars -> Env Term vars -> RawImp -> Glued vars -> Core (Term vars) checkTerm defining mode opts nest env tm ty diff --git a/src/TTImp/Elab/Ambiguity.idr b/src/TTImp/Elab/Ambiguity.idr index 8398e43..5223e2c 100644 --- a/src/TTImp/Elab/Ambiguity.idr +++ b/src/TTImp/Elab/Ambiguity.idr @@ -18,8 +18,8 @@ import TTImp.TTImp export expandAmbigName : {auto c : Ref Ctxt Defs} -> {auto e : Ref EST (EState vars)} -> - ElabMode -> NestedNames vars -> Env Term vars -> RawImp -> - List (FC, Maybe (Maybe Name), RawImp) -> + ElabMode -> NestedNames vars -> Env Term vars -> RawImp -> + List (FC, Maybe (Maybe Name), RawImp) -> RawImp -> Maybe (Glued vars) -> Core RawImp expandAmbigName (InLHS _) nest env orig args (IBindVar fc n) exp = do est <- get EST @@ -32,11 +32,11 @@ expandAmbigName mode nest env orig args (IVar fc x) exp Nothing => do defs <- get Ctxt case defined x env of - Just _ => - if isNil args || notLHS mode + Just _ => + if isNil args || notLHS mode then pure $ orig else pure $ IMustUnify fc "Name applied to arguments" orig - Nothing => + Nothing => do est <- get EST fi <- fromIntegerName si <- fromStringName @@ -51,41 +51,41 @@ expandAmbigName mode nest env orig args (IVar fc x) exp where -- If there's multiple alternatives and all else fails, resort to using -- the primitive directly - uniqType : Maybe Name -> Maybe Name -> Maybe Name -> Name -> + uniqType : Maybe Name -> Maybe Name -> Maybe Name -> Name -> List (FC, Maybe (Maybe Name), RawImp) -> AltType - uniqType (Just fi) _ _ n [(_, _, IPrimVal fc (BI x))] + uniqType (Just fi) _ _ n [(_, _, IPrimVal fc (BI x))] = UniqueDefault (IPrimVal fc (BI x)) - uniqType _ (Just si) _ n [(_, _, IPrimVal fc (Str x))] + uniqType _ (Just si) _ n [(_, _, IPrimVal fc (Str x))] = UniqueDefault (IPrimVal fc (Str x)) - uniqType _ _ (Just ci) n [(_, _, IPrimVal fc (Ch x))] + uniqType _ _ (Just ci) n [(_, _, IPrimVal fc (Ch x))] = UniqueDefault (IPrimVal fc (Ch x)) uniqType _ _ _ _ _ = Unique - buildAlt : RawImp -> List (FC, Maybe (Maybe Name), RawImp) -> + buildAlt : RawImp -> List (FC, Maybe (Maybe Name), RawImp) -> RawImp buildAlt f [] = f - buildAlt f ((fc', Nothing, a) :: as) + buildAlt f ((fc', Nothing, a) :: as) = buildAlt (IApp fc' f a) as - buildAlt f ((fc', Just i, a) :: as) + buildAlt f ((fc', Just i, a) :: as) = buildAlt (IImplicitApp fc' f i a) as - + isPrimName : List Name -> Name -> Bool isPrimName [] fn = False - isPrimName (p :: ps) fn + isPrimName (p :: ps) fn = dropNS fn == p || isPrimName ps fn -- If it's not a constructor application, dot it wrapDot : Bool -> EState vars -> - ElabMode -> Name -> List RawImp -> Def -> RawImp -> RawImp + ElabMode -> Name -> List RawImp -> Def -> RawImp -> RawImp wrapDot _ _ _ _ _ (DCon _ _) tm = tm wrapDot _ _ _ _ _ (TCon _ _ _ _ _ _) tm = tm -- Leave primitive applications alone, because they'll be inlined -- before compiling the case tree - wrapDot prim est (InLHS _) n' [arg] _ tm + wrapDot prim est (InLHS _) n' [arg] _ tm = if n' == Resolved (defining est) || prim then tm else IMustUnify fc "Not a constructor application or primitive" tm - wrapDot prim est (InLHS _) n' _ _ tm + wrapDot prim est (InLHS _) n' _ _ tm = if n' == Resolved (defining est) then tm else IMustUnify fc "Not a constructor application or primitive" tm @@ -93,12 +93,12 @@ expandAmbigName mode nest env orig args (IVar fc x) exp mkTerm : Bool -> EState vars -> Name -> GlobalDef -> RawImp - mkTerm prim est n def + mkTerm prim est n def = wrapDot prim est mode n (map (snd . snd) args) (definition def) (buildAlt (IVar fc n) args) mkAlt : Bool -> EState vars -> (Name, Int, GlobalDef) -> RawImp - mkAlt prim est (fullname, i, gdef) + mkAlt prim est (fullname, i, gdef) = mkTerm prim est (Resolved i) gdef notLHS : ElabMode -> Bool @@ -106,10 +106,10 @@ expandAmbigName mode nest env orig args (IVar fc x) exp notLHS _ = True expandAmbigName mode nest env orig args (IApp fc f a) exp - = expandAmbigName mode nest env orig + = expandAmbigName mode nest env orig ((fc, Nothing, a) :: args) f exp expandAmbigName mode nest env orig args (IImplicitApp fc f n a) exp - = expandAmbigName mode nest env orig + = expandAmbigName mode nest env orig ((fc, Just n, a) :: args) f exp expandAmbigName elabmode nest env orig args tm exp = pure orig @@ -126,11 +126,11 @@ Show TypeMatch where mutual mightMatchD : Defs -> NF vars -> NF [] -> Core TypeMatch - mightMatchD defs l r + mightMatchD defs l r = mightMatch defs (stripDelay l) (stripDelay r) - mightMatchArg : Defs -> - Closure vars -> Closure [] -> + mightMatchArg : Defs -> + Closure vars -> Closure [] -> Core Bool mightMatchArg defs l r = case !(mightMatchD defs !(evalClosure defs l) !(evalClosure defs r)) of @@ -152,16 +152,16 @@ mutual mightMatch defs target (NBind fc n (Pi _ _ _) sc) = mightMatchD defs target !(sc defs (toClosure defaultOpts [] (Erased fc))) mightMatch defs (NTCon _ n t a args) (NTCon _ n' t' a' args') - = if n == n' + = if n == n' then do amatch <- mightMatchArgs defs args args' if amatch then pure Concrete else pure NoMatch else pure NoMatch mightMatch defs (NDCon _ n t a args) (NDCon _ n' t' a' args') - = if t == t' + = if t == t' then do amatch <- mightMatchArgs defs args args' if amatch then pure Concrete else pure NoMatch else pure NoMatch - mightMatch defs (NPrimVal _ x) (NPrimVal _ y) + mightMatch defs (NPrimVal _ x) (NPrimVal _ y) = if x == y then pure Concrete else pure NoMatch mightMatch defs (NType _) (NType _) = pure Concrete mightMatch defs (NApp _ _ _) _ = pure Poly @@ -187,17 +187,17 @@ couldBeFn defs ty _ = pure Poly -- Just (True, app) if it's a match on concrete return type -- Just (False, app) if it might be a match due to being polymorphic couldBe : Defs -> NF vars -> RawImp -> Core (Maybe (Bool, RawImp)) -couldBe {vars} defs ty@(NTCon _ n _ _ _) app +couldBe {vars} defs ty@(NTCon _ n _ _ _) app = case !(couldBeFn {vars} defs ty (getFn app)) of Concrete => pure $ Just (True, app) Poly => pure $ Just (False, app) NoMatch => pure Nothing -couldBe {vars} defs ty@(NPrimVal _ _) app +couldBe {vars} defs ty@(NPrimVal _ _) app = case !(couldBeFn {vars} defs ty (getFn app)) of Concrete => pure $ Just (True, app) Poly => pure $ Just (False, app) NoMatch => pure Nothing -couldBe {vars} defs ty@(NType _) app +couldBe {vars} defs ty@(NType _) app = case !(couldBeFn {vars} defs ty (getFn app)) of Concrete => pure $ Just (True, app) Poly => pure $ Just (False, app) @@ -230,7 +230,7 @@ filterCore f (x :: xs) pruneByType : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - Env Term vars -> NF vars -> List RawImp -> + Env Term vars -> NF vars -> List RawImp -> Core (List RawImp) pruneByType env target alts = do defs <- get Ctxt @@ -273,8 +273,8 @@ checkAlternative : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> AltType -> List RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkAlternative rig elabinfo nest env fc (UniqueDefault def) alts mexpected @@ -285,35 +285,35 @@ checkAlternative rig elabinfo nest env fc (UniqueDefault def) alts mexpected let solvemode = case elabMode elabinfo of InLHS c => InLHS _ => InTerm - delayOnFailure fc rig env expected ambiguous $ + delayOnFailure fc rig env expected ambiguous $ \delayed => do solveConstraints solvemode Normal defs <- get Ctxt exp <- getTerm expected - -- We can't just use the old NF on the second attempt, + -- We can't just use the old NF on the second attempt, -- because we might know more now, so recalculate it - let exp' = if delayed + let exp' = if delayed then gnf env exp else expected alts' <- pruneByType env !(getNF exp') alts - logGlueNF 5 ("Ambiguous elaboration " ++ show alts' ++ + logGlueNF 5 ("Ambiguous elaboration " ++ show alts' ++ " at " ++ show fc ++ "\nWith default. Target type ") env exp' if delayed -- use the default if there's still ambiguity - then try - (exactlyOne fc env - (map (\t => - (getName t, - checkImp rig elabinfo nest env t + then try + (exactlyOne fc env + (map (\t => + (getName t, + checkImp rig elabinfo nest env t (Just exp'))) alts')) (do log 5 "All failed, running default" checkImp rig elabinfo nest env def (Just exp')) else exactlyOne fc env - (map (\t => - (getName t, + (map (\t => + (getName t, checkImp rig elabinfo nest env t (Just exp'))) alts') checkAlternative rig elabinfo nest env fc uniq alts mexpected @@ -329,28 +329,28 @@ checkAlternative rig elabinfo nest env fc uniq alts mexpected let solvemode = case elabMode elabinfo of InLHS c => InLHS _ => InTerm - delayOnFailure fc rig env expected ambiguous $ + delayOnFailure fc rig env expected ambiguous $ \delayed => do solveConstraints solvemode Normal defs <- get Ctxt exp <- getTerm expected - -- We can't just use the old NF on the second attempt, + -- We can't just use the old NF on the second attempt, -- because we might know more now, so recalculate it - let exp' = if delayed + let exp' = if delayed then gnf env exp else expected alts' <- pruneByType env !(getNF exp') alts - logGlueNF 5 ("Ambiguous elaboration " ++ show alts' ++ + logGlueNF 5 ("Ambiguous elaboration " ++ show alts' ++ " at " ++ show fc ++ "\nTarget type ") env exp' let tryall = case uniq of FirstSuccess => anyOne fc _ => exactlyOne fc env - tryall (map (\t => - (getName t, + tryall (map (\t => + (getName t, do res <- checkImp rig elabinfo nest env t (Just exp') -- Do it twice for interface resolution; -- first pass gets the determining argument diff --git a/src/TTImp/Elab/App.idr b/src/TTImp/Elab/App.idr index aaf6237..99aef9c 100644 --- a/src/TTImp/Elab/App.idr +++ b/src/TTImp/Elab/App.idr @@ -36,17 +36,17 @@ getNameType : {vars : _} -> Core (Term vars, Glued vars) getNameType rigc env fc x = case defined x env of - Just (MkIsDefined rigb lv) => + Just (MkIsDefined rigb lv) => do rigSafe rigb rigc let binder = getBinder lv env let bty = binderType binder addNameType fc x env bty when (isLinear rigb) $ do est <- get EST - put EST + put EST (record { linearUsed $= ((MkVar lv) :: ) } est) pure (Local fc (Just (isLet binder)) _ lv, gnf env bty) - Nothing => + Nothing => do defs <- get Ctxt [(pname, i, def)] <- lookupCtxtName x (gamma defs) | [] => throw (UndefinedName fc x) @@ -102,9 +102,9 @@ getVarType rigc nest env fc x where useVars : List (Term vars) -> Term vars -> Term vars useVars [] sc = sc - useVars (a :: as) (Bind bfc n (Pi c _ ty) sc) + useVars (a :: as) (Bind bfc n (Pi c _ ty) sc) = Bind bfc n (Let c a ty) (useVars (map weaken as) sc) - useVars as (Bind bfc n (Let c v ty) sc) + useVars as (Bind bfc n (Let c v ty) sc) = Bind bfc n (Let c v ty) (useVars (map weaken as) sc) useVars _ sc = sc -- Can't happen? @@ -130,9 +130,9 @@ mutual {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> (fntm : Term vars) -> + RigCount -> RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> (fntm : Term vars) -> Name -> NF vars -> (Defs -> Closure vars -> Core (NF vars)) -> (expargs : List RawImp) -> (impargs : List (Maybe Name, RawImp)) -> @@ -158,9 +158,9 @@ mutual {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> (fntm : Term vars) -> + RigCount -> RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> (fntm : Term vars) -> Name -> NF vars -> (Defs -> Closure vars -> Core (NF vars)) -> (expargs : List RawImp) -> (impargs : List (Maybe Name, RawImp)) -> @@ -171,7 +171,7 @@ mutual -- on the LHS, just treat it as an implicit pattern variable. -- on the RHS, add a searchable hole = case elabMode elabinfo of - InLHS _ => + InLHS _ => do defs <- get Ctxt nm <- genMVName x empty <- clearDefs defs @@ -217,7 +217,7 @@ mutual needsDelayExpr True (ISearch _ _) = pure True needsDelayExpr True (IRewrite _ _ _) = pure True needsDelayExpr True _ = pure False - + -- On the LHS, for any concrete thing, we need to make sure we know -- its type before we proceed so that we can reject it if the type turns -- out to be polymorphic @@ -270,8 +270,8 @@ mutual {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> (fntm : Term vars) -> Name -> (aty : NF vars) -> (sc : Defs -> Closure vars -> Core (NF vars)) -> (arg : RawImp) -> @@ -308,7 +308,7 @@ mutual defs <- get Ctxt -- If we're on the LHS, reinstantiate it with 'argv' because it -- *may* have as patterns in it and we need to retain them. - -- (As patterns are a bit of a hack but I don't yet see a + -- (As patterns are a bit of a hack but I don't yet see a -- better way that leads to good code...) logTerm 5 ("Solving " ++ show metaval ++ " with") argv ok <- solveIfUndefined env metaval argv @@ -351,21 +351,21 @@ mutual {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> (fntm : Term vars) -> (fnty : NF vars) -> (expargs : List RawImp) -> (impargs : List (Maybe Name, RawImp)) -> (knownret : Bool) -> -- Do we know what the return type is yet? - -- if we do, we might be able to use it to work + -- if we do, we might be able to use it to work -- out the types of arguments before elaborating them (expected : Maybe (Glued vars)) -> Core (Term vars, Glued vars) -- Ordinary explicit argument checkAppWith rig elabinfo nest env fc tm (NBind tfc x (Pi rigb Explicit aty) sc) - (arg :: expargs) impargs kr expty + (arg :: expargs) impargs kr expty = do let argRig = rigMult rig rigb - checkRestApp rig argRig elabinfo nest env fc + checkRestApp rig argRig elabinfo nest env fc tm x aty sc arg expargs impargs kr expty -- Function type is delayed, so force the term and continue checkAppWith rig elabinfo nest env fc tm (NDelayed dfc r ty@(NBind _ _ (Pi _ _ _) sc)) expargs impargs kr expty @@ -396,10 +396,10 @@ mutual expargs impargs kr expty = let argRig = rigMult rig rigb in case useAutoImp [] impargs of - Nothing => makeAutoImplicit rig argRig elabinfo nest env fc tm + Nothing => makeAutoImplicit rig argRig elabinfo nest env fc tm x aty sc expargs impargs kr expty Just (arg, impargs') => - checkRestApp rig argRig elabinfo nest env fc + checkRestApp rig argRig elabinfo nest env fc tm x aty sc arg expargs impargs' kr expty where useAutoImp : List (Maybe Name, RawImp) -> List (Maybe Name, RawImp) -> @@ -418,10 +418,10 @@ mutual expargs impargs kr expty = let argRig = rigMult rig rigb in case useImp [] impargs of - Nothing => makeImplicit rig argRig elabinfo nest env fc tm + Nothing => makeImplicit rig argRig elabinfo nest env fc tm x aty sc expargs impargs kr expty Just (arg, impargs') => - checkRestApp rig argRig elabinfo nest env fc + checkRestApp rig argRig elabinfo nest env fc tm x aty sc arg expargs impargs' kr expty where useImp : List (Maybe Name, RawImp) -> List (Maybe Name, RawImp) -> @@ -434,10 +434,10 @@ mutual useImp acc (ximp :: rest) = useImp (ximp :: acc) rest - checkAppWith rig elabinfo nest env fc tm ty [] [] kr expty + checkAppWith rig elabinfo nest env fc tm ty [] [] kr expty = do defs <- get Ctxt checkExp rig elabinfo env fc tm (glueBack defs env ty) expty - checkAppWith rig elabinfo nest env fc tm ty [] impargs kr expty + checkAppWith rig elabinfo nest env fc tm ty [] impargs kr expty = case filter notInfer impargs of [] => checkAppWith rig elabinfo nest env fc tm ty [] [] kr expty is => throw (InvalidImplicits fc env (map fst is) tm) @@ -446,7 +446,7 @@ mutual notInfer (_, Implicit _ _) = False notInfer (n, IAs _ _ _ i) = notInfer (n, i) notInfer _ = True - checkAppWith {vars} rig elabinfo nest env fc tm ty (arg :: expargs) impargs kr expty + checkAppWith {vars} rig elabinfo nest env fc tm ty (arg :: expargs) impargs kr expty = -- Invent a function type, and hope that we'll know enough to solve it -- later when we unify with expty do logNF 10 "Function type" env ty @@ -456,7 +456,7 @@ mutual argTy <- metaVar fc Rig0 env argn (TType fc) let argTyG = gnf env argTy retTy <- metaVar -- {vars = argn :: vars} - fc Rig0 env -- (Pi RigW Explicit argTy :: env) + fc Rig0 env -- (Pi RigW Explicit argTy :: env) retn (TType fc) (argv, argt) <- check rig elabinfo nest env arg (Just argTyG) @@ -480,10 +480,10 @@ checkApp : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> (fn : RawImp) -> - (expargs : List RawImp) -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> (fn : RawImp) -> + (expargs : List RawImp) -> (impargs : List (Maybe Name, RawImp)) -> Maybe (Glued vars) -> Core (Term vars, Glued vars) @@ -497,7 +497,7 @@ checkApp rig elabinfo nest env fc (IVar fc' n) expargs impargs exp elabinfo <- updateElabInfo (elabMode elabinfo) n expargs elabinfo logC 10 (do defs <- get Ctxt fnty <- quote defs env nty - exptyt <- maybe (pure Nothing) + exptyt <- maybe (pure Nothing) (\t => do ety <- getTerm t etynf <- normaliseHoles defs env ety pure (Just !(toFullNames etynf))) @@ -510,15 +510,15 @@ checkApp rig elabinfo nest env fc (IVar fc' n) expargs impargs exp where isPrimName : List Name -> Name -> Bool isPrimName [] fn = False - isPrimName (p :: ps) fn + isPrimName (p :: ps) fn = dropNS fn == p || isPrimName ps fn - + updateElabInfo : ElabMode -> Name -> List RawImp -> ElabInfo -> Core ElabInfo -- If it's a primitive function applied to a constant on the LHS, treat it -- as an expression because we'll normalise the function away and match on -- the result updateElabInfo (InLHS _) n [IPrimVal fc c] elabinfo = - do let prims = mapMaybe id + do let prims = mapMaybe id [!fromIntegerName, !fromStringName, !fromCharName] if isPrimName prims !(getFullName n) then pure (record { elabMode = InExpr } elabinfo) diff --git a/src/TTImp/Elab/As.idr b/src/TTImp/Elab/As.idr index 44a4ef2..ca23427 100644 --- a/src/TTImp/Elab/As.idr +++ b/src/TTImp/Elab/As.idr @@ -23,11 +23,11 @@ checkAs : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> UseSide -> Name -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) -checkAs rig elabinfo nest env fc side n_in pat topexp +checkAs rig elabinfo nest env fc side n_in pat topexp = do let elabmode = elabMode elabinfo let InLHS _ = elabmode | _ => throw (GenericMsg fc "@-patterns only allowed in pattern clauses") @@ -40,7 +40,7 @@ checkAs rig elabinfo nest env fc side n_in pat topexp noteLHSPatVar elabmode str notePatVar n case lookup n (boundNames est) of - Nothing => + Nothing => do (pattm, patty) <- check rigPat elabinfo nest env pat topexp (tm, exp, bty) <- mkPatternHole fc rig n env (implicitMode elabinfo) @@ -56,7 +56,7 @@ checkAs rig elabinfo nest env fc side n_in pat topexp (ntm, nty) <- checkExp rig elabinfo env fc tm (gnf env exp) (Just patty) pure (As fc ntm pattm, patty) - Just bty => throw (NonLinearPattern fc n_in) + Just bty => throw (NonLinearPattern fc n_in) where -- Only one side can be usable if it's linear! Normally we'd assume this -- to be the new variable (UseRight), but in generated case blocks it's diff --git a/src/TTImp/Elab/Binders.idr b/src/TTImp/Elab/Binders.idr index e43dd63..f84f78f 100644 --- a/src/TTImp/Elab/Binders.idr +++ b/src/TTImp/Elab/Binders.idr @@ -23,8 +23,8 @@ dropName n nest = record { names $= drop } nest where drop : List (Name, a) -> List (Name, a) drop [] = [] - drop ((x, y) :: xs) - = if x == n then drop xs + drop ((x, y) :: xs) + = if x == n then drop xs else (x, y) :: drop xs export @@ -33,21 +33,21 @@ checkPi : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> - RigCount -> PiInfo -> (n : Name) -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> + RigCount -> PiInfo -> (n : Name) -> (argTy : RawImp) -> (retTy : RawImp) -> (expTy : Maybe (Glued vars)) -> Core (Term vars, Glued vars) checkPi rig elabinfo nest env fc rigf info n argTy retTy expTy = do let pirig = getRig (elabMode elabinfo) - (tyv, tyt) <- check pirig elabinfo nest env argTy + (tyv, tyt) <- check pirig elabinfo nest env argTy (Just (gType fc)) let env' : Env Term (n :: _) = Pi rigf info tyv :: env let nest' = weaken (dropName n nest) - (scopev, scopet) <- - inScope fc env' (\e' => + (scopev, scopet) <- + inScope fc env' (\e' => check {e=e'} pirig elabinfo nest' env' retTy (Just (gType fc))) checkExp rig elabinfo env fc (Bind fc n (Pi rigf info tyv) scopev) (gType fc) expTy where @@ -71,10 +71,10 @@ inferLambda : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> - RigCount -> PiInfo -> (n : Name) -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> + RigCount -> PiInfo -> (n : Name) -> (argTy : RawImp) -> (scope : RawImp) -> (expTy : Maybe (Glued vars)) -> Core (Term vars, Glued vars) @@ -85,7 +85,7 @@ inferLambda rig elabinfo nest env fc rigl info n argTy scope expTy let env' : Env Term (n :: _) = Lam rigb info tyv :: env let nest' = weaken (dropName n nest) (scopev, scopet) <- inScope fc env' (\e' => - check {e=e'} rig elabinfo + check {e=e'} rig elabinfo nest' env' scope Nothing) let lamty = gnf env (Bind fc n (Pi rigb info tyv) !(getTerm scopet)) logGlue 5 "Inferred lambda type" env lamty @@ -110,10 +110,10 @@ checkLambda : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> - RigCount -> PiInfo -> (n : Name) -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> + RigCount -> PiInfo -> (n : Name) -> (argTy : RawImp) -> (scope : RawImp) -> (expTy : Maybe (Glued vars)) -> Core (Term vars, Glued vars) @@ -127,21 +127,21 @@ checkLambda rig_in elabinfo nest env fc rigl info n argTy scope (Just expty_in) defs <- get Ctxt case exptynf of Bind bfc bn (Pi c _ pty) psc => - do (tyv, tyt) <- check Rig0 elabinfo nest env + do (tyv, tyt) <- check Rig0 elabinfo nest env argTy (Just (gType fc)) let rigb = min rigl c let env' : Env Term (n :: _) = Lam rigb info tyv :: env - convert fc elabinfo env (gnf env tyv) (gnf env pty) + convert fc elabinfo env (gnf env tyv) (gnf env pty) let nest' = weaken (dropName n nest) (scopev, scopet) <- inScope fc env' (\e' => - check {e=e'} rig elabinfo nest' env' scope + check {e=e'} rig elabinfo nest' env' scope (Just (gnf env' (renameTop n psc)))) logTermNF 10 "Lambda type" env exptynf logGlueNF 10 "Got scope type" env' scopet - checkExp rig elabinfo env fc + checkExp rig elabinfo env fc (Bind fc n (Lam rigb info tyv) scopev) - (gnf env + (gnf env (Bind fc n (Pi rigb info tyv) !(getTerm scopet))) (Just (gnf env (Bind fc bn (Pi rigb info pty) psc))) @@ -160,10 +160,10 @@ checkLet : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> - RigCount -> (n : Name) -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> + RigCount -> (n : Name) -> (nTy : RawImp) -> (nVal : RawImp) -> (scope : RawImp) -> (expTy : Maybe (Glued vars)) -> Core (Term vars, Glued vars) @@ -179,15 +179,15 @@ checkLet rigc_in elabinfo nest env fc rigl n nTy nVal scope expty pure (fst c, snd c, rigMult rigl rigc)) (\err => case err of LinearMisuse _ _ Rig1 _ - => do c <- check Rig1 elabinfo + => do c <- check Rig1 elabinfo nest env nVal (Just (gnf env tyv)) pure (fst c, snd c, Rig1) e => throw e) let env' : Env Term (n :: _) = Lam rigb Explicit tyv :: env let nest' = weaken (dropName n nest) - expScope <- weakenExp env' expty - (scopev, gscopet) <- - inScope fc env' (\e' => + expScope <- weakenExp env' expty + (scopev, gscopet) <- + inScope fc env' (\e' => check {e=e'} rigc elabinfo nest' env' scope expScope) scopet <- getTerm gscopet diff --git a/src/TTImp/Elab/Case.idr b/src/TTImp/Elab/Case.idr index da3941a..02ec1dc 100644 --- a/src/TTImp/Elab/Case.idr +++ b/src/TTImp/Elab/Case.idr @@ -26,10 +26,10 @@ changeVar (MkVar {i=x} old) (MkVar new) (Local fc r idx p) else Local fc r _ p changeVar old new (Meta fc nm i args) = Meta fc nm i (map (changeVar old new) args) -changeVar (MkVar old) (MkVar new) (Bind fc x b sc) - = Bind fc x (assert_total (map (changeVar (MkVar old) (MkVar new)) b)) +changeVar (MkVar old) (MkVar new) (Bind fc x b sc) + = Bind fc x (assert_total (map (changeVar (MkVar old) (MkVar new)) b)) (changeVar (MkVar (Later old)) (MkVar (Later new)) sc) -changeVar old new (App fc fn arg) +changeVar old new (App fc fn arg) = App fc (changeVar old new fn) (changeVar old new arg) changeVar old new (As fc nm p) = As fc (changeVar old new nm) (changeVar old new p) @@ -48,10 +48,10 @@ findLater {older} x (_ :: xs) MkVar (Later p) -- For any variable *not* in vs', re-abstract over it in the term -absOthers : FC -> Env Term vs -> SubVars vs' vs -> +absOthers : FC -> Env Term vs -> SubVars vs' vs -> Term (done ++ vs) -> Term (done ++ vs) absOthers fc _ SubRefl tm = tm -absOthers {done} {vs = x :: vars} fc (b :: env) (KeepCons sub) tm +absOthers {done} {vs = x :: vars} fc (b :: env) (KeepCons sub) tm = rewrite appendAssociative done [x] vars in absOthers {done = done ++ [x]} fc env sub (rewrite sym (appendAssociative done [x] vars) in tm) @@ -60,7 +60,7 @@ absOthers {done} {vs = x :: vars} fc (b :: env) (DropCons sub) tm = rewrite appendAssociative done [x] vars in map (weakenNs (done ++ [x])) b b' = Pi (multiplicity b) Explicit (binderType bindervs) - btm = Bind fc x b' + btm = Bind fc x b' (changeVar (findLater _ (x :: done)) (MkVar First) (weaken tm)) in rewrite appendAssociative done [x] vars in absOthers {done = done ++ [x]} fc env sub @@ -70,43 +70,43 @@ absOthers {done} {vs = x :: vars} fc (b :: env) (DropCons sub) tm -- unbound implicits at the point in the environment where they were -- created (which is after the outer environment was bound) export -abstractOver : FC -> Defs -> BindMode -> Env Term vs -> +abstractOver : FC -> Defs -> BindMode -> Env Term vs -> Maybe (SubVars outer vs) -> List (Name, ImplBinding outer) -> (tm : Term vs) -> Core ClosedTerm abstractOver fc defs bindmode [] Nothing imps tm = pure tm -abstractOver fc defs bindmode [] (Just SubRefl) imps tm - = do tm' <- if isNil imps +abstractOver fc defs bindmode [] (Just SubRefl) imps tm + = do tm' <- if isNil imps then pure tm else normaliseHoles defs [] tm (bimptm, _) <- bindImplicits fc bindmode defs [] imps tm' (TType fc) pure bimptm -abstractOver fc defs bindmode (b :: env) (Just SubRefl) imps tm +abstractOver fc defs bindmode (b :: env) (Just SubRefl) imps tm = do let c : RigCount = case multiplicity b of Rig1 => Rig0 r => r - tm' <- if isNil imps + tm' <- if isNil imps then pure tm else normaliseHoles defs (b :: env) tm (bimptm, _) <- bindImplicits fc bindmode defs (b :: env) imps tm' (TType fc) - abstractOver fc defs bindmode env Nothing imps + abstractOver fc defs bindmode env Nothing imps (Bind fc _ (Pi c Explicit (binderType b)) bimptm) -abstractOver fc defs bindmode (b :: env) (Just (DropCons p)) imps tm +abstractOver fc defs bindmode (b :: env) (Just (DropCons p)) imps tm = let c = case multiplicity b of Rig1 => Rig0 r => r in - abstractOver fc defs bindmode env (Just p) imps + abstractOver fc defs bindmode env (Just p) imps (Bind fc _ (Pi c Explicit (binderType b)) tm) -abstractOver fc defs bindmode (b :: env) _ imps tm +abstractOver fc defs bindmode (b :: env) _ imps tm = let c = case multiplicity b of Rig1 => Rig0 r => r in - abstractOver fc defs bindmode env Nothing imps + abstractOver fc defs bindmode env Nothing imps (Bind fc _ (Pi c Explicit (binderType b)) tm) toRig1 : {idx : Nat} -> .(IsVar name idx vs) -> Env Term vs -> Env Term vs -toRig1 First (b :: bs) +toRig1 First (b :: bs) = if multiplicity b == Rig0 then setMultiplicity b Rig1 :: bs else b :: bs @@ -126,7 +126,7 @@ updateMults : List (Var vs) -> Env Term vs -> Env Term vs updateMults [] env = env updateMults (MkVar p :: us) env = updateMults us (toRig0 p env) -shrinkImp : SubVars outer vars -> +shrinkImp : SubVars outer vars -> (Name, ImplBinding vars) -> Maybe (Name, ImplBinding outer) shrinkImp sub (n, NameBinding c p tm ty) = do tm' <- shrinkTerm tm sub @@ -141,11 +141,11 @@ shrinkImp sub (n, AsBinding c p tm ty pat) findImpsIn : 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 (b :: env) ((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 (b :: env) (map (\x => (fst x, weaken (snd x))) ns) sc findImpsIn fc env ns ty @@ -160,7 +160,7 @@ merge (v :: vs) xs -- Extend the list of variables we need in the environment so far, removing -- duplicates -extendNeeded : Binder (Term vs) -> +extendNeeded : Binder (Term vs) -> Env Term vs -> List (Var vs) -> List (Var vs) extendNeeded (Let c ty val) env needed = merge (findUsedLocs env ty) (merge (findUsedLocs env val) needed) @@ -183,16 +183,16 @@ isNeeded x (MkVar {i} _ :: xs) = x == i || isNeeded x xs -- starting from the 'outerEnv' which is the fragment of the environment -- used for the outer scope) shrinkEnv : Defs -> SubVars outer vs -> List (Var vs) -> - (done : List Name) -> Env Term vs -> + (done : List Name) -> Env Term vs -> Core (outer' ** SubVars outer' vs) -shrinkEnv defs SubRefl needed done env +shrinkEnv defs SubRefl needed done env = pure (_ ** SubRefl) -- keep them all -- usable name, so drop from the outer environment -shrinkEnv {vs = UN n :: _} defs (DropCons p) needed done (b :: env) +shrinkEnv {vs = UN n :: _} defs (DropCons p) needed done (b :: env) = do b' <- traverse (normaliseHoles defs env) b - (_ ** p') <- shrinkEnv defs p - (extendNeeded b' - env (dropFirst needed)) + (_ ** p') <- shrinkEnv defs p + (extendNeeded b' + env (dropFirst needed)) (UN n :: done) env -- if shadowed and not needed, keep in the outer env if (UN n `elem` done) && not (isNeeded 0 needed) @@ -200,22 +200,22 @@ shrinkEnv {vs = UN n :: _} defs (DropCons p) needed done (b :: env) else pure (_ ** DropCons p') shrinkEnv {vs = n :: _} defs (DropCons p) needed done (b :: env) = do b' <- traverse (normaliseHoles defs env) b - (_ ** p') <- shrinkEnv defs p - (extendNeeded b' - env (dropFirst needed)) + (_ ** p') <- shrinkEnv defs p + (extendNeeded b' + env (dropFirst needed)) (n :: done) env if isNeeded 0 needed || notLam b - then pure (_ ** DropCons p') + then pure (_ ** DropCons p') else pure (_ ** KeepCons p') where notLam : Binder t -> Bool notLam (Lam _ _ _) = False notLam _ = True -shrinkEnv {vs = n :: _} defs (KeepCons p) needed done (b :: env) +shrinkEnv {vs = n :: _} defs (KeepCons p) needed done (b :: env) = do b' <- traverse (normaliseHoles defs env) b - (_ ** p') <- shrinkEnv defs p + (_ ** p') <- shrinkEnv defs p (extendNeeded b' - env (dropFirst needed)) + env (dropFirst needed)) (n :: done) env pure (_ ** KeepCons p') -- still keep it @@ -237,14 +237,14 @@ findScrutinee _ _ _ = Nothing export caseBlock : {vars : _} -> - {auto c : Ref Ctxt Defs} -> + {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> - ElabInfo -> FC -> - NestedNames vars -> - Env Term vars -> + RigCount -> + ElabInfo -> FC -> + NestedNames vars -> + Env Term vars -> RawImp -> -- original scrutinee Term vars -> -- checked scrutinee Term vars -> -- its type @@ -261,7 +261,7 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected (implicitMode elabinfo) env [] let fullImps = mapMaybe (shrinkImp (subEnv est)) fullImps_in log 5 $ "Doing a case under unbound implicits " ++ show fullImps - + scrn <- genVarName "scr" casen <- genCaseName (defining est) @@ -287,15 +287,15 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected -- if the scrutinee is ones of the arguments in 'env' we should -- split on that, rather than adding it as a new argument let splitOn = findScrutinee env smaller scr - + caseretty <- the (Core (Term vars)) $ case expected of Just ty => getTerm ty _ => do nmty <- genName "caseTy" metaVar fc Rig0 env nmty (TType fc) - let envscope = absOthers {done = []} fc (allow splitOn env) smaller - (maybe (Bind fc scrn (Pi caseRig Explicit scrty) + let envscope = absOthers {done = []} fc (allow splitOn env) smaller + (maybe (Bind fc scrn (Pi caseRig Explicit scrty) (weaken caseretty)) (const caseretty) splitOn) casefnty <- abstractOver fc defs (implicitMode elabinfo) @@ -317,20 +317,20 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected let alts' = map (updateClause casen splitOn env smaller) alts log 2 $ "Generated alts: " ++ show alts' - let nest' = record { names $= ((Resolved cidx, (Nothing, - (\fc, nt => applyToFull fc caseRef pre_env))) ::) } + let nest' = record { names $= ((Resolved cidx, (Nothing, + (\fc, nt => applyToFull fc caseRef pre_env))) ::) } nest processDecl [InCase] nest' pre_env (IDef fc casen alts') let applyEnv = applyToOthers fc (applyToFull fc caseRef env) env smaller - pure (maybe (App fc applyEnv scrtm) - (const applyEnv) splitOn, + pure (maybe (App fc applyEnv scrtm) + (const applyEnv) splitOn, gnf env caseretty) where mkLocalEnv : Env Term vs -> Env Term vs mkLocalEnv [] = [] - mkLocalEnv (b :: bs) + mkLocalEnv (b :: bs) = let b' = if isLinear (multiplicity b) then setMultiplicity b Rig0 else b in @@ -341,7 +341,7 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected = if n `elem` vs then Nothing else Just n canBindName _ vs = Nothing - addEnv : Env Term vs -> SubVars vs' vs -> List Name -> + addEnv : Env Term vs -> SubVars vs' vs -> List Name -> (List (Maybe RawImp), List Name) addEnv [] sub used = ([], used) addEnv {vs = v :: vs} (b :: bs) SubRefl used @@ -359,22 +359,22 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected -- Replace a variable in the argument list; if the reference is to -- a variable kept in the outer environment (therefore not an argument -- in the list) don't consume it - replace : {idx : Nat} -> .(IsVar name idx vs) -> + replace : {idx : Nat} -> .(IsVar name idx vs) -> RawImp -> List (Maybe RawImp) -> List RawImp - replace First lhs (old :: xs) + replace First lhs (old :: xs) = let lhs' = case old of - Just (IAs loc' side n _) => IAs loc' side n lhs + Just (IAs loc' side n _) => IAs loc' side n lhs _ => lhs in lhs' :: mapMaybe id xs - replace (Later p) lhs (Nothing :: xs) + replace (Later p) lhs (Nothing :: xs) = replace p lhs xs - replace (Later p) lhs (Just x :: xs) + replace (Later p) lhs (Just x :: xs) = x :: replace p lhs xs replace _ _ xs = mapMaybe id xs - mkSplit : Maybe (Var vs) -> - RawImp -> List (Maybe RawImp) -> + mkSplit : Maybe (Var vs) -> + RawImp -> List (Maybe RawImp) -> List RawImp mkSplit Nothing lhs args = reverse (lhs :: mapMaybe id args) mkSplit (Just (MkVar prf)) lhs args @@ -414,15 +414,15 @@ checkCase : {vars : _} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> (scr : RawImp) -> (ty : RawImp) -> List ImpClause -> + NestedNames vars -> Env Term vars -> + FC -> (scr : RawImp) -> (ty : RawImp) -> List ImpClause -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkCase rig elabinfo nest env fc scr scrty_exp alts exp = delayElab fc rig env exp $ - do (scrtyv, scrtyt) <- check Rig0 elabinfo nest env scrty_exp + do (scrtyv, scrtyt) <- check Rig0 elabinfo nest env scrty_exp (Just (gType fc)) - + logTerm 10 "Expected scrutinee type" scrtyv -- Try checking at the given multiplicity; if that doesn't work, -- try checking at Rig1 (meaning that we're using a linear variable @@ -432,7 +432,7 @@ checkCase rig elabinfo nest env fc scr scrty_exp alts exp pure (fst c, snd c, RigW)) (\err => case err of LinearMisuse _ _ Rig1 _ - => do c <- check Rig1 elabinfo nest env scr + => do c <- check Rig1 elabinfo nest env scr (Just (gnf env scrtyv)) pure (fst c, snd c, Rig1) e => throw e) diff --git a/src/TTImp/Elab/Check.idr b/src/TTImp/Elab/Check.idr index 2b8d701..2ec9762 100644 --- a/src/TTImp/Elab/Check.idr +++ b/src/TTImp/Elab/Check.idr @@ -50,7 +50,7 @@ Show (ImplBinding vars) where export bindingMetas : ImplBinding vars -> NameMap Bool bindingMetas (NameBinding c p tm ty) = getMetas ty -bindingMetas (AsBinding c p tm ty pat) +bindingMetas (AsBinding c p tm ty pat) = insertAll (toList (getMetas ty)) (getMetas pat) where insertAll : List (Name, Bool) -> NameMap Bool -> NameMap Bool @@ -92,7 +92,7 @@ record EState (vars : List Name) where outerEnv : Env Term outer subEnv : SubVars outer vars boundNames : List (Name, ImplBinding vars) - -- implicit pattern/type variable bindings and the + -- implicit pattern/type variable bindings and the -- term/type they elaborated to toBind : List (Name, ImplBinding vars) -- implicit pattern/type variables which haven't been @@ -100,8 +100,8 @@ record EState (vars : List Name) where -- pattern vars need to be dealt with in with-application on -- the RHS) bindIfUnsolved : List (Name, RigCount, PiInfo, - (vars' ** (Env Term vars', Term vars', Term vars', - SubVars outer vars'))) + (vars' ** (Env Term vars', Term vars', Term vars', + SubVars outer vars'))) -- names to add as unbound implicits if they are still holes -- when unbound implicits are added lhsPatVars : List String @@ -129,20 +129,20 @@ weakenedEState : {auto e : Ref EST (EState vars)} -> Core (Ref EST (EState (n :: vars))) weakenedEState {e} = do est <- get EST - eref <- newRef EST - (MkEState (defining est) + eref <- newRef EST + (MkEState (defining est) (outerEnv est) (DropCons (subEnv est)) (map wknTms (boundNames est)) (map wknTms (toBind est)) - (bindIfUnsolved est) + (bindIfUnsolved est) (lhsPatVars est) (allPatVars est) (allowDelay est) (map weaken (linearUsed est))) pure eref where - wknTms : (Name, ImplBinding vs) -> + wknTms : (Name, ImplBinding vs) -> (Name, ImplBinding (n :: vs)) wknTms (f, NameBinding c p x y) = (f, NameBinding c p (weaken x) (weaken y)) wknTms (f, AsBinding c p x y z) @@ -158,13 +158,13 @@ strengthenedEState {n} {vars} c e fc env svs <- dropSub (subEnv est) bns <- traverse (strTms defs) (boundNames est) todo <- traverse (strTms defs) (toBind est) - - pure (MkEState (defining est) + + pure (MkEState (defining est) (outerEnv est) svs - bns + bns todo - (bindIfUnsolved est) + (bindIfUnsolved est) (lhsPatVars est) (allPatVars est) (allowDelay est) @@ -183,10 +183,10 @@ strengthenedEState {n} {vars} c e fc env -- in scope. removeArgVars : List (Term (n :: vs)) -> Maybe (List (Term vs)) removeArgVars [] = pure [] - removeArgVars (Local fc r _ (Later p) :: args) + removeArgVars (Local fc r _ (Later p) :: args) = do args' <- removeArgVars args pure (Local fc r _ p :: args') - removeArgVars (Local fc r _ First :: args) + removeArgVars (Local fc r _ First :: args) = removeArgVars args removeArgVars (a :: args) = do a' <- shrinkTerm a (DropCons SubRefl) @@ -201,12 +201,12 @@ strengthenedEState {n} {vars} c e fc env f' <- shrinkTerm f (DropCons SubRefl) pure (apply (getLoc f) f' args') - strTms : Defs -> (Name, ImplBinding (n :: vars)) -> + strTms : Defs -> (Name, ImplBinding (n :: vars)) -> Core (Name, ImplBinding vars) strTms defs (f, NameBinding c p x y) = do xnf <- normaliseHoles defs env x ynf <- normaliseHoles defs env y - case (removeArg xnf, + case (removeArg xnf, shrinkTerm ynf (DropCons SubRefl)) of (Just x', Just y') => pure (f, NameBinding c p x' y') _ => throw (BadUnboundImplicit fc env f y) @@ -214,7 +214,7 @@ strengthenedEState {n} {vars} c e fc env = do xnf <- normaliseHoles defs env x ynf <- normaliseHoles defs env y znf <- normaliseHoles defs env z - case (shrinkTerm xnf (DropCons SubRefl), + case (shrinkTerm xnf (DropCons SubRefl), shrinkTerm ynf (DropCons SubRefl), shrinkTerm znf (DropCons SubRefl)) of (Just x', Just y', Just z') => pure (f, AsBinding c p x' y' z') @@ -227,8 +227,8 @@ strengthenedEState {n} {vars} c e fc env export inScope : {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 (n :: vars) -> + (Ref EST (EState (n :: vars)) -> Core a) -> Core a inScope {c} {e} fc env elab = do e' <- weakenedEState @@ -238,7 +238,7 @@ inScope {c} {e} fc env elab pure res export -updateEnv : Env Term new -> SubVars new vars -> +updateEnv : Env Term new -> SubVars new vars -> List (Name, RigCount, PiInfo, (vars' ** (Env Term vars', Term vars', Term vars', SubVars new vars'))) -> EState vars -> EState vars updateEnv env sub bif st @@ -256,7 +256,7 @@ addBindIfUnsolved : Name -> RigCount -> PiInfo -> addBindIfUnsolved hn r p env tm ty st = MkEState (defining st) (outerEnv st) (subEnv st) - (boundNames st) (toBind st) + (boundNames st) (toBind st) ((hn, r, p, (_ ** (env, tm, ty, subEnv st))) :: bindIfUnsolved st) (lhsPatVars st) (allPatVars st) @@ -279,7 +279,7 @@ clearToBind : {auto e : Ref EST (EState vars)} -> (excepts : List Name) -> Core () clearToBind excepts = do est <- get EST - put EST (record { toBind $= filter (\x => fst x `elem` excepts) } + put EST (record { toBind $= filter (\x => fst x `elem` excepts) } (clearBindIfUnsolved est)) export @@ -403,7 +403,7 @@ successful : {vars : _} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> List (Maybe Name, Core a) -> - Core (List (Either (Maybe Name, Error) + Core (List (Either (Maybe Name, Error) (a, Defs, UState, EState vars))) successful [] = pure [] successful ((tm, elab) :: elabs) @@ -411,7 +411,7 @@ successful ((tm, elab) :: elabs) est <- get EST md <- get MD defs <- branch - catch (do -- Run the elaborator + catch (do -- Run the elaborator log 5 $ "Running " ++ show tm res <- elab -- Record post-elaborator state @@ -440,14 +440,14 @@ exactlyOne : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - FC -> Env Term vars -> + FC -> Env Term vars -> List (Maybe Name, Core (Term vars, Glued vars)) -> Core (Term vars, Glued vars) exactlyOne fc env [(tm, elab)] = elab exactlyOne {vars} fc env all = do elabs <- successful all case rights elabs of - [(res, defs, ust, est)] => + [(res, defs, ust, est)] => do put UST ust put EST est put Ctxt defs @@ -460,7 +460,7 @@ exactlyOne {vars} fc env all -- If they've all failed, collect all the errors -- If more than one succeeded, report the ambiguity - altError : List (Maybe Name, Error) -> + altError : List (Maybe Name, Error) -> List ((Term vars, Glued vars), st) -> Error altError ls [] = AllFailed ls @@ -474,7 +474,7 @@ anyOne : {vars : _} -> {auto e : Ref EST (EState vars)} -> FC -> List (Maybe Name, Core (Term vars, Glued vars)) -> Core (Term vars, Glued vars) -anyOne fc [] = throw (GenericMsg fc "No elaborators provided") +anyOne fc [] = throw (GenericMsg fc "No elaborators provided") anyOne fc [(tm, elab)] = elab anyOne fc ((tm, elab) :: es) = try elab (anyOne fc es) @@ -486,8 +486,8 @@ check : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> RawImp -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) @@ -498,7 +498,7 @@ checkImp : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> + RigCount -> ElabInfo -> NestedNames vars -> Env Term vars -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) @@ -508,9 +508,9 @@ processDecl : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - List ElabOpt -> NestedNames vars -> + List ElabOpt -> NestedNames vars -> Env Term vars -> ImpDecl -> Core () - + -- Check whether two terms are convertible. May solve metavariables (in Ctxt) -- in doing so. -- Returns a list of constraints which need to be solved for the conversion @@ -528,7 +528,7 @@ convertWithLazy withLazy fc elabinfo env x y = case elabMode elabinfo of InLHS _ => InLHS _ => InTerm in - catch + catch (do logGlueNF 5 "Unifying" env x logGlueNF 5 "....with" env y vs <- if isFromTerm x && isFromTerm y @@ -545,7 +545,7 @@ convertWithLazy withLazy fc elabinfo env x y when (holesSolved vs) $ solveConstraints umode Normal pure vs) - (\err => + (\err => do defs <- get Ctxt xtm <- getTerm x ytm <- getTerm y @@ -579,10 +579,10 @@ checkExp : {vars : _} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> RigCount -> ElabInfo -> Env Term vars -> FC -> - (term : Term vars) -> - (got : Glued vars) -> (expected : Maybe (Glued vars)) -> + (term : Term vars) -> + (got : Glued vars) -> (expected : Maybe (Glued vars)) -> Core (Term vars, Glued vars) -checkExp rig elabinfo env fc tm got (Just exp) +checkExp rig elabinfo env fc tm got (Just exp) = do vs <- convertWithLazy True fc elabinfo env got exp case (constraints vs) of [] => case addLazy vs of diff --git a/src/TTImp/Elab/Delayed.idr b/src/TTImp/Elab/Delayed.idr index 49fecc8..b0e24c8 100644 --- a/src/TTImp/Elab/Delayed.idr +++ b/src/TTImp/Elab/Delayed.idr @@ -18,15 +18,15 @@ import Data.IntMap %default covering -- We run the elaborator in the given environment, but need to end up with a --- closed term. -mkClosedElab : FC -> Env Term vars -> +-- closed term. +mkClosedElab : 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 fc env + = mkClosedElab fc env (do (sc', _) <- elab let b' = newBinder b pure (Bind fc x b' sc', gErased fc)) @@ -42,50 +42,50 @@ mkClosedElab {vars = x :: vars} fc (b :: env) elab -- predicate, make a hole and try it again later when more holes might -- have been resolved export -delayOnFailure : {auto c : Ref Ctxt Defs} -> +delayOnFailure : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - {auto e : Ref EST (EState vars)} -> + {auto e : Ref EST (EState vars)} -> FC -> RigCount -> Env Term vars -> (expected : Glued vars) -> (Error -> Bool) -> (Bool -> Core (Term vars, Glued vars)) -> Core (Term vars, Glued vars) -delayOnFailure fc rig env expected pred elab +delayOnFailure fc rig env expected pred elab = handle (elab False) - (\err => + (\err => do est <- get EST if pred err && allowDelay est - then + then do nm <- genName "delayed" (ci, dtm) <- newDelayed fc Rig1 env nm !(getTerm expected) - logGlueNF 5 ("Postponing elaborator " ++ show nm ++ + logGlueNF 5 ("Postponing elaborator " ++ show nm ++ " at " ++ show fc ++ " for") env expected log 10 ("Due to error " ++ show err) ust <- get UST - put UST (record { delayedElab $= - ((ci, mkClosedElab fc env + put UST (record { delayedElab $= + ((ci, mkClosedElab fc env (do est <- get EST put EST (record { allowDelay = False } est) tm <- elab True est <- get EST put EST (record { allowDelay = True } est) - pure tm)) :: ) } + pure tm)) :: ) } ust) pure (dtm, expected) else throw err) export -delayElab : {auto c : Ref Ctxt Defs} -> +delayElab : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - {auto e : Ref EST (EState vars)} -> + {auto e : Ref EST (EState vars)} -> FC -> RigCount -> Env Term vars -> (expected : Maybe (Glued vars)) -> Core (Term vars, Glued vars) -> Core (Term vars, Glued vars) -delayElab {vars} fc rig env exp elab +delayElab {vars} fc rig env exp elab = do est <- get EST if not (allowDelay est) then elab @@ -93,17 +93,17 @@ delayElab {vars} fc rig env exp elab nm <- genName "delayed" expected <- mkExpected exp (ci, dtm) <- newDelayed fc Rig1 env nm !(getTerm expected) - logGlueNF 5 ("Postponing elaborator " ++ show nm ++ + logGlueNF 5 ("Postponing elaborator " ++ show nm ++ " for") env expected ust <- get UST - put UST (record { delayedElab $= - ((ci, mkClosedElab fc env + put UST (record { delayedElab $= + ((ci, mkClosedElab fc env (do est <- get EST put EST (record { allowDelay = False } est) tm <- elab est <- get EST put EST (record { allowDelay = True } est) - pure tm)) :: ) } + pure tm)) :: ) } ust) pure (dtm, expected) where @@ -115,9 +115,9 @@ delayElab {vars} fc rig env exp elab pure (gnf env ty) export -retryDelayed : {auto c : Ref Ctxt Defs} -> +retryDelayed : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - {auto e : Ref EST (EState vars)} -> + {auto e : Ref EST (EState vars)} -> List (Int, Core ClosedTerm) -> Core () retryDelayed [] = pure () @@ -127,7 +127,7 @@ retryDelayed ((i, elab) :: ds) | _ => retryDelayed ds log 5 ("Retrying delayed hole " ++ show !(getFullName (Resolved i))) tm <- elab - updateDef (Resolved i) (const (Just + updateDef (Resolved i) (const (Just (PMDef True [] (STerm tm) (STerm tm) []))) logTerm 5 ("Resolved delayed hole " ++ show i) tm logTermNF 5 ("Resolved delayed hole NF " ++ show i) [] tm diff --git a/src/TTImp/Elab/Dot.idr b/src/TTImp/Elab/Dot.idr index f900a2a..12e743f 100644 --- a/src/TTImp/Elab/Dot.idr +++ b/src/TTImp/Elab/Dot.idr @@ -23,26 +23,26 @@ checkDot : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> String -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkDot rig elabinfo nest env fc reason tm Nothing - = throw (GenericMsg fc ("Dot pattern not valid here (unknown type) " + = throw (GenericMsg fc ("Dot pattern not valid here (unknown type) " ++ show tm)) checkDot rig elabinfo nest env fc reason tm (Just gexpty) = case elabMode elabinfo of InLHS _ => - do (wantedTm, wantedTy) <- checkImp rig + do (wantedTm, wantedTy) <- checkImp rig (record { elabMode = InExpr } elabinfo) - nest env + nest env tm (Just gexpty) nm <- genName "dotTm" expty <- getTerm gexpty metaval <- metaVar fc rig env nm expty addDot fc env nm wantedTm reason metaval checkExp rig elabinfo env fc metaval wantedTy (Just gexpty) - _ => throw (GenericMsg fc ("Dot pattern not valid here (Not LHS) " + _ => throw (GenericMsg fc ("Dot pattern not valid here (Not LHS) " ++ show tm)) diff --git a/src/TTImp/Elab/Hole.idr b/src/TTImp/Elab/Hole.idr index 8cc11c3..9a4a322 100644 --- a/src/TTImp/Elab/Hole.idr +++ b/src/TTImp/Elab/Hole.idr @@ -21,7 +21,7 @@ checkHole : {vars : _} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + NestedNames vars -> Env Term vars -> FC -> String -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkHole rig elabinfo nest env fc n_in (Just gexpty) diff --git a/src/TTImp/Elab/ImplicitBind.idr b/src/TTImp/Elab/ImplicitBind.idr index 8128aba..5d9cf3a 100644 --- a/src/TTImp/Elab/ImplicitBind.idr +++ b/src/TTImp/Elab/ImplicitBind.idr @@ -19,11 +19,11 @@ import Data.NameMap %default covering -varEmbedSub : SubVars small vars -> - {idx : Nat} -> .(IsVar n idx small) -> +varEmbedSub : SubVars small vars -> + {idx : Nat} -> .(IsVar n idx small) -> Var vars varEmbedSub SubRefl y = MkVar y -varEmbedSub (DropCons prf) y +varEmbedSub (DropCons prf) y = let MkVar y' = varEmbedSub prf y in MkVar (Later y') varEmbedSub (KeepCons prf) First = MkVar First @@ -33,19 +33,19 @@ varEmbedSub (KeepCons prf) (Later p) mutual embedSub : SubVars small vars -> Term small -> Term vars - embedSub sub (Local fc x idx y) + embedSub sub (Local fc x idx y) = let MkVar y' = varEmbedSub sub y in Local fc x _ y' embedSub sub (Ref fc x name) = Ref fc x name - embedSub sub (Meta fc x y xs) + embedSub sub (Meta fc x y xs) = Meta fc x y (map (embedSub sub) xs) - embedSub sub (Bind fc x b scope) + embedSub sub (Bind fc x b scope) = Bind fc x (map (embedSub sub) b) (embedSub (KeepCons sub) scope) - embedSub sub (App fc fn arg) + embedSub sub (App fc fn arg) = App fc (embedSub sub fn) (embedSub sub arg) - embedSub sub (As fc nm pat) + embedSub sub (As fc nm pat) = As fc (embedSub sub nm) (embedSub sub pat) embedSub sub (TDelayed fc x y) = TDelayed fc x (embedSub sub y) - embedSub sub (TDelay fc x t y) + embedSub sub (TDelay fc x t y) = TDelay fc x (embedSub sub t) (embedSub sub y) embedSub sub (TForce fc x) = TForce fc (embedSub sub x) embedSub sub (PrimVal fc c) = PrimVal fc c @@ -67,7 +67,7 @@ mkOuterHole loc rig n topenv (Just expty_in) case shrinkTerm expected sub of -- Can't shrink so rely on unification with expected type later Nothing => mkOuterHole loc rig n topenv Nothing - Just exp' => + Just exp' => do let env = outerEnv est tm <- implBindVar loc rig env n exp' pure (embedSub sub tm, embedSub sub exp') @@ -106,7 +106,7 @@ 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 (embedSub sub tm) (mkArgs sub), + pure (apply loc (embedSub sub tm) (mkArgs sub), expected, embedSub sub exp') where @@ -118,7 +118,7 @@ mkPatternHole {vars} loc rig n topenv imode (Just expty_in) -- This is for the specific situation where we're pattern matching on -- function types, which is realistically the only time we'll legitimately -- encounter a type variable under a binder - bindInner : Env Term vs -> Term vs -> SubVars newvars vs -> + bindInner : Env Term vs -> Term vs -> SubVars newvars vs -> Maybe (Term newvars) bindInner env ty SubRefl = Just ty bindInner {vs = x :: _} (b :: env) ty (DropCons p) @@ -136,7 +136,7 @@ bindUnsolved : {auto c : Ref Ctxt Defs} -> {auto e : Ref EST (EState vars)} -> {auto u : Ref UST UState} -> FC -> ElabMode -> BindMode -> Core () bindUnsolved fc elabmode NONE = pure () -bindUnsolved {vars} fc elabmode _ +bindUnsolved {vars} fc elabmode _ = do est <- get EST defs <- get Ctxt let bifs = bindIfUnsolved est @@ -150,7 +150,7 @@ bindUnsolved {vars} fc elabmode _ = case shrinkTerm expected sub of Nothing => do tmn <- toFullNames expected throw (GenericMsg fc ("Can't bind implicit " ++ show n ++ " of type " ++ show tmn)) - Just exp' => + Just exp' => do impn <- genVarName (nameRoot n) tm <- metaVar fc rig env impn exp' est <- get EST @@ -160,8 +160,8 @@ bindUnsolved {vars} fc elabmode _ pure (embedSub sub tm) mkImplicit : Defs -> Env Term outer -> SubVars outer vars -> - (Name, RigCount, PiInfo, (vars' ** - (Env Term vars', Term vars', Term vars', SubVars outer vars'))) -> + (Name, RigCount, PiInfo, (vars' ** + (Env Term vars', Term vars', Term vars', SubVars outer vars'))) -> Core () mkImplicit defs outerEnv subEnv (n, rig, p, (vs ** (env, tm, exp, sub))) = do Just (Hole _ _) <- lookupDefExact n (gamma defs) @@ -176,27 +176,27 @@ bindUnsolved {vars} fc elabmode _ fc env tm bindtm pure () -swapIsVarH : {idx : Nat} -> .(IsVar name idx (x :: y :: xs)) -> +swapIsVarH : {idx : Nat} -> .(IsVar name idx (x :: y :: xs)) -> Var (y :: x :: xs) swapIsVarH First = MkVar (Later First) swapIsVarH (Later First) = MkVar First swapIsVarH (Later (Later x)) = MkVar (Later (Later x)) swapIsVar : (vs : List Name) -> - {idx : Nat} -> .(IsVar name idx (vs ++ x :: y :: xs)) -> + {idx : Nat} -> .(IsVar name idx (vs ++ x :: y :: xs)) -> Var (vs ++ y :: x :: xs) swapIsVar [] prf = swapIsVarH prf swapIsVar (x :: xs) First = MkVar First -swapIsVar (x :: xs) (Later p) +swapIsVar (x :: xs) (Later p) = let MkVar p' = swapIsVar xs p in MkVar (Later p') swapVars : {vs : List Name} -> Term (vs ++ x :: y :: ys) -> Term (vs ++ y :: x :: ys) -swapVars (Local fc x idx p) +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) +swapVars {vs} (Bind fc x b scope) = Bind fc x (map swapVars b) (swapVars {vs = x :: vs} scope) swapVars (App fc fn arg) = App fc (swapVars fn) (swapVars arg) swapVars (As fc nm pat) = As fc (swapVars nm) (swapVars pat) @@ -215,7 +215,7 @@ push ofc n b tm@(Bind fc (PV x i) (Pi c Implicit ty) sc) -- only push past 'PV's = case shrinkTerm ty (DropCons SubRefl) of Nothing => -- needs explicit pi, do nothing Bind ofc n b tm - Just ty' => Bind fc (PV x i) (Pi c Implicit ty') + Just ty' => Bind fc (PV x i) (Pi c Implicit ty') (push ofc n (map weaken b) (swapVars {vs = []} sc)) push ofc n b tm = Bind ofc n b tm @@ -227,7 +227,7 @@ liftImps : BindMode -> (Term vars, Term vars) -> (Term vars, Term vars) liftImps (PI _) (tm, TType) = (liftImps' tm, TType) where liftImps' : Term vars -> Term vars - liftImps' (Bind fc (PV n i) (Pi c Implicit ty) sc) + liftImps' (Bind fc (PV n i) (Pi c Implicit ty) sc) = Bind fc (PV n i) (Pi c Implicit ty) (liftImps' sc) liftImps' (Bind fc n (Pi c p ty) sc) = push fc n (Pi c p ty) (liftImps' sc) @@ -241,7 +241,7 @@ bindImplVars : FC -> BindMode -> List (Name, ImplBinding vars) -> Term vars -> Term vars -> (Term vars, Term vars) bindImplVars fc NONE gam env imps_in scope scty = (scope, scty) -bindImplVars {vars} fc mode gam env imps_in scope scty +bindImplVars {vars} fc mode gam env imps_in scope scty = let imps = map (\ (x, bind) => (tidyName x, x, bind)) imps_in in getBinds imps None scope scty where @@ -253,31 +253,31 @@ bindImplVars {vars} fc mode gam env imps_in scope scty tidyName (Nested n inner) = tidyName inner tidyName n = n - getBinds : (imps : List (Name, Name, ImplBinding vs)) -> + getBinds : (imps : List (Name, Name, ImplBinding vs)) -> Bounds new -> (tm : Term vs) -> (ty : Term vs) -> (Term (new ++ vs), Term (new ++ vs)) getBinds [] bs tm ty = (refsToLocals bs tm, refsToLocals bs ty) getBinds ((n, metan, NameBinding c p _ bty) :: imps) bs tm ty - = let (tm', ty') = getBinds imps (Add n metan bs) tm ty + = let (tm', ty') = getBinds imps (Add n metan bs) tm ty bty' = refsToLocals bs bty in case mode of PI c => - (Bind fc _ (Pi c Implicit bty') tm', + (Bind fc _ (Pi c Implicit bty') tm', TType fc) _ => - (Bind fc _ (PVar c p bty') tm', + (Bind fc _ (PVar c p bty') tm', Bind fc _ (PVTy c bty') ty') getBinds ((n, metan, AsBinding c _ _ bty bpat) :: imps) bs tm ty - = let (tm', ty') = getBinds imps (Add n metan bs) tm ty + = let (tm', ty') = getBinds imps (Add n metan bs) tm ty bty' = refsToLocals bs bty bpat' = refsToLocals bs bpat in - (Bind fc _ (PLet c bpat' bty') tm', + (Bind fc _ (PLet c bpat' bty') tm', Bind fc _ (PLet c bpat' bty') ty') normaliseHolesScope : Defs -> Env Term vars -> Term vars -> Core (Term vars) -normaliseHolesScope defs env (Bind fc n b sc) - = pure $ Bind fc n b - !(normaliseHolesScope defs +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 (multiplicity b) Explicit (binderType b) :: env) sc) normaliseHolesScope defs env tm = normaliseHoles defs env tm @@ -288,7 +288,7 @@ bindImplicits : FC -> BindMode -> List (Name, ImplBinding vars) -> Term vars -> Term vars -> Core (Term vars, Term vars) bindImplicits fc NONE defs env hs tm ty = pure (tm, ty) -bindImplicits {vars} fc mode defs env hs tm ty +bindImplicits {vars} fc mode defs env hs tm ty = do hs' <- traverse nHoles hs pure $ liftImps mode $ bindImplVars fc mode defs env hs' tm ty where @@ -302,7 +302,7 @@ export implicitBind : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> Name -> Core () -implicitBind n +implicitBind n = do defs <- get Ctxt Just (Hole _ _) <- lookupDefExact n (gamma defs) | _ => pure () @@ -320,9 +320,9 @@ getToBind : {auto c : Ref Ctxt Defs} -> {auto e : Ref EST (EState vars)} -> FC -> ElabMode -> BindMode -> Env Term vars -> (excepts : List Name) -> Core (List (Name, ImplBinding vars)) -getToBind fc elabmode NONE env excepts +getToBind fc elabmode NONE env excepts = pure [] -- We should probably never get here, but for completeness... -getToBind {vars} fc elabmode impmode env excepts +getToBind {vars} fc elabmode impmode env excepts = do solveConstraints (case elabmode of InLHS _ => InLHS _ => InTerm) Normal @@ -337,7 +337,7 @@ getToBind {vars} fc elabmode impmode env excepts -- Make sure all the hole names are normalised in the implicitly -- bound types, because otherwise we'll bind them too res <- normImps defs [] tob - let hnames = map fst res + let hnames = map fst res -- Return then in dependency order let res' = depSort hnames res log 10 $ "Bound names: " ++ show res @@ -348,14 +348,14 @@ getToBind {vars} fc elabmode impmode env excepts normBindingTy defs (NameBinding c p tm ty) = pure $ NameBinding c p tm !(normaliseHoles defs env ty) normBindingTy defs (AsBinding c p tm ty pat) - = pure $ AsBinding c p tm !(normaliseHoles defs env ty) + = pure $ AsBinding c p tm !(normaliseHoles defs env ty) !(normaliseHoles defs env pat) - normImps : Defs -> List Name -> List (Name, ImplBinding vars) -> + normImps : Defs -> List Name -> List (Name, ImplBinding vars) -> Core (List (Name, ImplBinding vars)) normImps defs ns [] = pure [] - normImps defs ns ((PV n i, bty) :: ts) - = do logTermNF 10 ("Implicit pattern var " ++ show (PV n i)) env + normImps defs ns ((PV n i, bty) :: ts) + = do logTermNF 10 ("Implicit pattern var " ++ show (PV n i)) env (bindingType bty) if PV n i `elem` ns then normImps defs ns ts @@ -379,8 +379,8 @@ getToBind {vars} fc elabmode impmode env excepts -- Insert the hole/binding pair into the list before the first thing -- which refers to it - insert : (Name, ImplBinding vars) -> List Name -> List Name -> - List (Name, ImplBinding vars) -> + insert : (Name, ImplBinding vars) -> List Name -> List Name -> + List (Name, ImplBinding vars) -> List (Name, ImplBinding vars) insert h ns sofar [] = [h] insert (hn, bty) ns sofar ((hn', bty') :: rest) @@ -389,14 +389,14 @@ getToBind {vars} fc elabmode impmode env excepts -- introduced in *this* expression (there may be others unresolved -- from elsewhere, for type inference purposes) if hn `elem` used - then (hn, bty) :: + then (hn, bty) :: (hn', bty') :: rest - else (hn', bty') :: + else (hn', bty') :: insert (hn, bty) ns (hn' :: sofar) rest - + -- Sort the list of implicits so that each binding is inserted *after* -- all the things it depends on (assumes no cycles) - depSort : List Name -> List (Name, ImplBinding vars) -> + depSort : List Name -> List (Name, ImplBinding vars) -> List (Name, ImplBinding vars) depSort hnames [] = [] depSort hnames (h :: hs) = insert h hnames [] (depSort hnames hs) @@ -407,9 +407,9 @@ checkBindVar : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> - FC -> String -> -- string is base of the pattern name + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> String -> -- string is base of the pattern name Maybe (Glued vars) -> Core (Term vars, Glued vars) checkBindVar rig elabinfo nest env fc str topexp @@ -426,7 +426,7 @@ checkBindVar rig elabinfo nest env fc str topexp notePatVar n est <- get EST case lookup n (boundNames est) of - Nothing => + Nothing => do (tm, exp, bty) <- mkPatternHole fc rig n env (implicitMode elabinfo) topexp @@ -451,7 +451,7 @@ checkBindVar rig elabinfo nest env fc str topexp addNameType fc (UN str) env ty checkExp rig elabinfo env fc tm (gnf env ty) topexp where - updateRig : Name -> RigCount -> List (Name, ImplBinding vars) -> + updateRig : Name -> RigCount -> List (Name, ImplBinding vars) -> List (Name, ImplBinding vars) updateRig n c [] = [] updateRig n c ((bn, r) :: bs) @@ -467,7 +467,7 @@ checkBindVar rig elabinfo nest env fc str topexp combine n RigW Rig1 = throw (LinearUsed fc 2 n) combine n RigW RigW = pure () combine n Rig0 c = pure () - combine n c Rig0 + combine n c Rig0 -- It was 0, make it c = do est <- get EST put EST (record { boundNames $= updateRig n c, @@ -479,8 +479,8 @@ checkBindHere : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> BindMode -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) @@ -518,12 +518,12 @@ checkBindHere rig elabinfo nest env fc bindmode tm exp bindmode env dontbind clearToBind dontbind est <- get EST - put EST (updateEnv oldenv oldsub oldbif + put EST (updateEnv oldenv oldsub oldbif (record { boundNames = [] } est)) ty <- getTerm tmt defs <- get Ctxt (bv, bt) <- bindImplicits fc bindmode - defs env argImps + defs env argImps !(normaliseHoles defs env tmv) !(normaliseHoles defs env ty) traverse_ implicitBind (map fst argImps) diff --git a/src/TTImp/Elab/Lazy.idr b/src/TTImp/Elab/Lazy.idr index 1467bb6..dde13b3 100644 --- a/src/TTImp/Elab/Lazy.idr +++ b/src/TTImp/Elab/Lazy.idr @@ -22,7 +22,7 @@ checkDelayed : {vars : _} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + NestedNames vars -> Env Term vars -> FC -> LazyReason -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkDelayed rig elabinfo nest env fc r tm exp @@ -36,7 +36,7 @@ checkDelay : {vars : _} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + NestedNames vars -> Env Term vars -> FC -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkDelay rig elabinfo nest env fc tm mexpected @@ -59,7 +59,7 @@ checkDelay rig elabinfo nest env fc tm mexpected (Just (glueBack defs env expnf)) tynf <- getNF gty ty <- getTerm gty - pure (TDelay fc r ty tm', + pure (TDelay fc r ty tm', glueBack defs env (NDelayed fc r tynf)) _ => throw (GenericMsg fc ("Can't infer delay type"))) where @@ -74,14 +74,14 @@ checkForce : {vars : _} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + NestedNames vars -> Env Term vars -> FC -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkForce rig elabinfo nest env fc tm exp = do defs <- get Ctxt expf <- maybe (pure Nothing) (\gty => do tynf <- getNF gty - pure (Just (glueBack defs env + pure (Just (glueBack defs env (NDelayed fc LUnknown tynf)))) exp (tm', gty) <- check rig elabinfo nest env tm expf diff --git a/src/TTImp/Elab/Local.idr b/src/TTImp/Elab/Local.idr index fe84b99..82517d7 100644 --- a/src/TTImp/Elab/Local.idr +++ b/src/TTImp/Elab/Local.idr @@ -20,16 +20,16 @@ checkLocal : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> List ImpDecl -> (scope : RawImp) -> (expTy : Maybe (Glued vars)) -> Core (Term vars, Glued vars) checkLocal {vars} rig elabinfo nest env fc nestdecls scope expty = do let defNames = definedInBlock [] nestdecls - est <- get EST - let f = defining est - names' <- traverse (applyEnv f) + est <- get EST + let f = defining est + names' <- traverse (applyEnv f) (nub defNames) -- binding names must be unique -- fixes bug #115 let nest' = record { names $= (names' ++) } nest @@ -43,31 +43,31 @@ checkLocal {vars} rig elabinfo nest env fc nestdecls scope expty -- ensuring the nested definition is used exactly once dropLinear : Env Term vs -> Env Term vs dropLinear [] = [] - dropLinear (b :: bs) + dropLinear (b :: bs) = if isLinear (multiplicity b) then setMultiplicity b Rig0 :: dropLinear bs else b :: dropLinear bs - applyEnv : {auto c : Ref Ctxt Defs} -> Int -> Name -> + applyEnv : {auto c : Ref Ctxt Defs} -> Int -> Name -> Core (Name, (Maybe Name, FC -> NameType -> Term vars)) - applyEnv outer inner + applyEnv outer inner = do let nestedName = Nested outer inner n' <- addName nestedName - pure (inner, (Just nestedName, - \fc, nt => applyTo fc + pure (inner, (Just nestedName, + \fc, nt => applyTo fc (Ref fc nt (Resolved n')) env)) -- Update the names in the declarations to the new 'nested' names. -- When we encounter the names in elaboration, we'll update to an -- application of the nested name. newName : NestedNames vars -> Name -> Name - newName nest n + newName nest n = case lookup n (names nest) of Just (Just n', _) => n' _ => n updateTyName : NestedNames vars -> ImpTy -> ImpTy - updateTyName nest (MkImpTy loc' n ty) + updateTyName nest (MkImpTy loc' n ty) = MkImpTy loc' (newName nest n) ty updateDataName : NestedNames vars -> ImpData -> ImpData @@ -78,11 +78,11 @@ checkLocal {vars} rig elabinfo nest env fc nestdecls scope expty = MkImpLater loc' (newName nest n) tycons updateName : NestedNames vars -> ImpDecl -> ImpDecl - updateName nest (IClaim loc' r vis fnopts ty) + updateName nest (IClaim loc' r vis fnopts ty) = IClaim loc' r vis fnopts (updateTyName nest ty) - updateName nest (IDef loc' n cs) + updateName nest (IDef loc' n cs) = IDef loc' (newName nest n) cs - updateName nest (IData loc' vis d) + updateName nest (IData loc' vis d) = IData loc' vis (updateDataName nest d) updateName nest i = i diff --git a/src/TTImp/Elab/Record.idr b/src/TTImp/Elab/Record.idr index fd99fb8..d4c44a2 100644 --- a/src/TTImp/Elab/Record.idr +++ b/src/TTImp/Elab/Record.idr @@ -63,25 +63,25 @@ genFieldName root -- There's probably a generic version of this in the prelude isn't -- there? -replace : String -> Rec -> +replace : String -> Rec -> List (String, Rec) -> List (String, Rec) replace k v [] = [] replace k v ((k', v') :: vs) - = if k == k' + = if k == k' then ((k, v) :: vs) else ((k', v') :: replace k v vs) findPath : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> List String -> List String -> Maybe Name -> + FC -> List String -> List String -> Maybe Name -> (String -> RawImp) -> Rec -> Core Rec findPath loc [] full tyn val (Field lhs _) = pure (Field lhs (val lhs)) -findPath loc [] full tyn val rec +findPath loc [] full tyn val rec = throw (IncompatibleFieldUpdate loc full) -findPath loc (p :: ps) full Nothing val (Field n v) +findPath loc (p :: ps) full Nothing val (Field n v) = throw (NotRecordField loc p Nothing) -findPath loc (p :: ps) full (Just tyn) val (Field n v) +findPath loc (p :: ps) full (Just tyn) val (Field n v) = do defs <- get Ctxt Just con <- findConName defs tyn | Nothing => throw (NotRecordType loc tyn) @@ -91,7 +91,7 @@ findPath loc (p :: ps) full (Just tyn) val (Field n v) let rec' = Constr con args findPath loc (p :: ps) full (Just tyn) val rec' where - mkArgs : List (String, Maybe Name) -> + mkArgs : List (String, Maybe Name) -> Core (List (String, Rec)) mkArgs [] = pure [] mkArgs ((p, _) :: ps) @@ -99,7 +99,7 @@ findPath loc (p :: ps) full (Just tyn) val (Field n v) args' <- mkArgs ps pure ((p, Field fldn (IVar loc (UN fldn))) :: args') -findPath loc (p :: ps) full tyn val (Constr con args) +findPath loc (p :: ps) full tyn val (Constr con args) = do let Just prec = lookup p args | Nothing => throw (NotRecordField loc p tyn) defs <- get Ctxt @@ -112,13 +112,13 @@ findPath loc (p :: ps) full tyn val (Constr con args) getSides : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> IFieldUpdate -> Name -> RawImp -> Rec -> + FC -> IFieldUpdate -> Name -> RawImp -> Rec -> Core Rec -getSides loc (ISetField path val) tyn orig rec +getSides loc (ISetField path val) tyn orig rec -- update 'rec' so that 'path' is accessible on the lhs and rhs, -- then set the path on the rhs to 'val' = findPath loc path path (Just tyn) (const val) rec -getSides loc (ISetFieldApp path val) tyn orig rec +getSides loc (ISetFieldApp path val) tyn orig rec = findPath loc path path (Just tyn) (\n => apply val [IVar loc (UN n)]) rec where get : List String -> RawImp -> RawImp @@ -127,23 +127,23 @@ getSides loc (ISetFieldApp path val) tyn orig rec getAllSides : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> List IFieldUpdate -> Name -> - RawImp -> Rec -> + FC -> List IFieldUpdate -> Name -> + RawImp -> Rec -> Core Rec getAllSides loc [] tyn orig rec = pure rec -getAllSides loc (u :: upds) tyn orig rec +getAllSides loc (u :: upds) tyn orig rec = getAllSides loc upds tyn orig !(getSides loc u tyn orig rec) -- Convert the collection of high level field accesses into a case expression -- which does the updates all in one go export recUpdate : {vars : _} -> - {auto c : Ref Ctxt Defs} -> + {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> FC -> - NestedNames vars -> Env Term vars -> - List IFieldUpdate -> + RigCount -> ElabInfo -> FC -> + NestedNames vars -> Env Term vars -> + List IFieldUpdate -> (rec : RawImp) -> (grecty : Glued vars) -> Core RawImp recUpdate rigc elabinfo loc nest env flds rec grecty @@ -164,14 +164,14 @@ checkUpdate : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> List IFieldUpdate -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkUpdate rig elabinfo nest env fc upds rec expected = do recty <- case expected of Just ret => pure ret - _ => do (_, ty) <- checkImp rig elabinfo + _ => do (_, ty) <- checkImp rig elabinfo nest env rec Nothing pure ty rcase <- recUpdate rig elabinfo fc nest env upds rec recty diff --git a/src/TTImp/Elab/Rewrite.idr b/src/TTImp/Elab/Rewrite.idr index ea2877c..e134907 100644 --- a/src/TTImp/Elab/Rewrite.idr +++ b/src/TTImp/Elab/Rewrite.idr @@ -18,7 +18,7 @@ import TTImp.TTImp -- TODO: Later, we'll get the name of the lemma from the type, if it's one -- that's generated for a dependent type. For now, always return the default -findRewriteLemma : {auto c : Ref Ctxt Defs} -> +findRewriteLemma : {auto c : Ref Ctxt Defs} -> FC -> (rulety : Term vars) -> Core Name findRewriteLemma loc rulety @@ -33,7 +33,7 @@ getRewriteTerms loc defs (NTCon nfc eq t a args) err = if !(isEqualTy eq) then case reverse args of (rhs :: lhs :: rhsty :: lhsty :: _) => - pure (!(evalClosure defs lhs), + pure (!(evalClosure defs lhs), !(evalClosure defs rhs), !(evalClosure defs lhsty)) _ => throw err @@ -56,9 +56,9 @@ rewriteErr _ = False export elabRewrite : {vars : _} -> {auto c : Ref Ctxt Defs} -> - {auto u : Ref UST UState} -> + {auto u : Ref UST UState} -> FC -> Env Term vars -> - (expected : Term vars) -> + (expected : Term vars) -> (rulety : Term vars) -> Core (Name, Term vars, Term vars) elabRewrite loc env expected rulety @@ -72,13 +72,13 @@ elabRewrite loc env expected rulety -- the metavariables might have been updated expnf <- nf defs env expected - logNF 5 "Rewriting" env lt + logNF 5 "Rewriting" env lt logNF 5 "Rewriting in" env expnf rwexp_sc <- replace defs env lt (Ref loc Bound parg) expnf logTerm 5 "Rewritten to" rwexp_sc empty <- clearDefs defs - let pred = Bind loc parg (Lam RigW Explicit + let pred = Bind loc parg (Lam RigW Explicit !(quote empty env lty)) (refsToLocals (Add parg parg None) rwexp_sc) gpredty <- getType env pred @@ -97,8 +97,8 @@ checkRewrite : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> {auto e : Ref EST (EState vars)} -> - RigCount -> ElabInfo -> - NestedNames vars -> Env Term vars -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> FC -> RawImp -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkRewrite rigc elabinfo nest env fc rule tm Nothing @@ -129,12 +129,12 @@ checkRewrite {vars} rigc elabinfo nest env fc rule tm (Just expected) (\e'' => check {e = e''} {vars = rname :: pname :: vars} rigc elabinfo (weaken (weaken nest)) env' (apply (IVar fc lemma) [IVar fc pname, - IVar fc rname, - tm]) + IVar fc rname, + tm]) (Just (gnf env' (weakenNs [rname, pname] expTy))) )) rwty <- getTerm grwty - pure (Bind fc pname pbind (Bind fc rname rbind rwtm), + pure (Bind fc pname pbind (Bind fc rname rbind rwtm), gnf env (Bind fc pname pbind (Bind fc rname rbind rwty)))) diff --git a/src/TTImp/Elab/Term.idr b/src/TTImp/Elab/Term.idr index cc004a6..87179b2 100644 --- a/src/TTImp/Elab/Term.idr +++ b/src/TTImp/Elab/Term.idr @@ -28,7 +28,7 @@ import TTImp.TTImp %default covering -- If the expected type has an implicit pi, elaborate with leading --- implicit lambdas if they aren't there already. +-- implicit lambdas if they aren't there already. insertImpLam : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> Env Term vars -> @@ -84,22 +84,22 @@ checkTerm : {vars : _} -> RigCount -> ElabInfo -> NestedNames vars -> Env Term vars -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) -checkTerm rig elabinfo nest env (IVar fc n) exp +checkTerm rig elabinfo nest env (IVar fc n) exp = -- It may actually turn out to be an application, if the expected -- type is expecting an implicit argument, so check it as an -- application with no arguments checkApp rig elabinfo nest env fc (IVar fc n) [] [] exp -checkTerm rig elabinfo nest env (IPi fc r p (Just n) argTy retTy) exp +checkTerm rig elabinfo nest env (IPi fc r p (Just n) argTy retTy) exp = checkPi rig elabinfo nest env fc r p n argTy retTy exp -checkTerm rig elabinfo nest env (IPi fc r p Nothing argTy retTy) exp +checkTerm rig elabinfo nest env (IPi fc r p Nothing argTy retTy) exp = do n <- case p of Explicit => genVarName "arg" Implicit => genVarName "impArg" AutoImplicit => genVarName "conArg" checkPi rig elabinfo nest env fc r p n argTy retTy exp -checkTerm rig elabinfo nest env (ILam fc r p (Just n) argTy scope) exp +checkTerm rig elabinfo nest env (ILam fc r p (Just n) argTy scope) exp = checkLambda rig elabinfo nest env fc r p n argTy scope exp -checkTerm rig elabinfo nest env (ILam fc r p Nothing argTy scope) exp +checkTerm rig elabinfo nest env (ILam fc r p Nothing argTy scope) exp = do n <- genVarName "_" checkLambda rig elabinfo nest env fc r p n argTy scope exp checkTerm rig elabinfo nest env (ILet fc r n nTy nVal scope) exp @@ -110,9 +110,9 @@ checkTerm rig elabinfo nest env (ILocal fc nested scope) exp = checkLocal rig elabinfo nest env fc nested scope exp checkTerm rig elabinfo nest env (IUpdate fc upds rec) exp = checkUpdate rig elabinfo nest env fc upds rec exp -checkTerm rig elabinfo nest env (IApp fc fn arg) exp +checkTerm rig elabinfo nest env (IApp fc fn arg) exp = checkApp rig elabinfo nest env fc fn [arg] [] exp -checkTerm rig elabinfo nest env (IWithApp fc fn arg) exp +checkTerm rig elabinfo nest env (IWithApp fc fn arg) exp = throw (GenericMsg fc "with application not implemented yet") checkTerm rig elabinfo nest env (IImplicitApp fc fn nm arg) exp = checkApp rig elabinfo nest env fc fn [] [(nm, arg)] exp @@ -149,10 +149,10 @@ checkTerm rig elabinfo nest env (IDelay fc tm) exp = checkDelay rig elabinfo nest env fc tm exp checkTerm rig elabinfo nest env (IForce fc tm) exp = checkForce rig elabinfo nest env fc tm exp -checkTerm {vars} rig elabinfo nest env (IPrimVal fc c) exp +checkTerm {vars} rig elabinfo nest env (IPrimVal fc c) exp = do let (cval, cty) = checkPrim {vars} fc c checkExp rig elabinfo env fc cval (gnf env cty) exp -checkTerm rig elabinfo nest env (IType fc) exp +checkTerm rig elabinfo nest env (IType fc) exp = checkExp rig elabinfo env fc (TType fc) (gType fc) exp checkTerm rig elabinfo nest env (IHole fc str) exp @@ -185,7 +185,7 @@ checkTerm rig elabinfo nest env (Implicit fc b) Nothing -- {auto m : Ref MD Metadata} -> -- {auto u : Ref UST UState} -> -- {auto e : Ref EST (EState vars)} -> --- RigCount -> ElabInfo -> Env Term vars -> RawImp -> +-- RigCount -> ElabInfo -> Env Term vars -> RawImp -> -- Maybe (Glued vars) -> -- Core (Term vars, Glued vars) -- If we've just inserted an implicit coercion (in practice, that's either @@ -199,7 +199,7 @@ TTImp.Elab.Check.check rigc elabinfo nest env tm@(ILocal fc ds sc) exp = checkImp rigc elabinfo nest env tm exp TTImp.Elab.Check.check rigc elabinfo nest env tm@(IUpdate fc fs rec) exp = checkImp rigc elabinfo nest env tm exp -TTImp.Elab.Check.check rigc elabinfo nest env tm_in exp +TTImp.Elab.Check.check rigc elabinfo nest env tm_in exp = do defs <- get Ctxt est <- get EST tm <- expandAmbigName (elabMode elabinfo) nest env tm_in [] tm_in exp diff --git a/src/TTImp/Elab/Utils.idr b/src/TTImp/Elab/Utils.idr index 95beab4..8a8a4a1 100644 --- a/src/TTImp/Elab/Utils.idr +++ b/src/TTImp/Elab/Utils.idr @@ -23,7 +23,7 @@ findErasedFrom defs pos tm = pure [] export findErased : {auto c : Ref Ctxt Defs} -> ClosedTerm -> Core (List Nat) -findErased tm +findErased tm = do defs <- get Ctxt tmnf <- nf defs [] tm findErasedFrom defs 0 tmnf diff --git a/src/TTImp/Interactive/CaseSplit.idr b/src/TTImp/Interactive/CaseSplit.idr index 29faee3..45aaac0 100644 --- a/src/TTImp/Interactive/CaseSplit.idr +++ b/src/TTImp/Interactive/CaseSplit.idr @@ -36,7 +36,7 @@ Show ClauseUpdate where show (Impossible lhs) = "Impossible: " ++ show lhs show Invalid = "Invalid" -public export +public export data SplitError : Type where NoValidSplit : SplitError -- None of the splits either type check, or fail -- in a way which is valid as an 'impossible' case @@ -60,7 +60,7 @@ Show a => Show (SplitResult a) where show (OK res) = "OK: " ++ show res findTyName : {auto c : Ref Ctxt Defs} -> - Defs -> Env Term vars -> Name -> Term vars -> + Defs -> Env Term vars -> Name -> Term vars -> Core (Maybe Name) findTyName defs env n (Bind _ x (PVar c p ty) sc) -- Take the first one, which is the most recently bound @@ -84,19 +84,19 @@ findCons : {auto c : Ref Ctxt Defs} -> Name -> Term [] -> Core (SplitResult (Name, Name, List Name)) findCons n lhs = case getDefining lhs of - Nothing => pure (SplitFail + Nothing => pure (SplitFail (CantSplitThis n "Can't find function name on LHS")) Just fn => do defs <- get Ctxt case !(findTyName defs [] n lhs) of - Nothing => pure (SplitFail (CantSplitThis n + Nothing => pure (SplitFail (CantSplitThis n ("Can't find type of " ++ show n ++ " in LHS"))) Just tyn => do Just (TCon _ _ _ _ _ cons) <- lookupDefExact tyn (gamma defs) - | res => pure (SplitFail - (CantSplitThis n - ("Not a type constructor " ++ + | res => pure (SplitFail + (CantSplitThis n + ("Not a type constructor " ++ show res))) pure (OK (fn, tyn, cons)) @@ -123,7 +123,7 @@ defaultNames = ["x", "y", "z", "w", "v", "s", "t", "u"] export getArgName : {auto c : Ref Ctxt Defs} -> Defs -> Name -> List Name -> NF vars -> Core String -getArgName defs x allvars ty +getArgName defs x allvars ty = do defnames <- findNames ty pure $ getName x defnames allvars where @@ -148,9 +148,9 @@ getArgName defs x allvars ty export getArgNames : {auto c : Ref Ctxt Defs} -> - Defs -> List Name -> Env Term vars -> NF vars -> + Defs -> List Name -> Env Term vars -> NF vars -> Core (List String) -getArgNames defs allvars env (NBind fc x (Pi _ p ty) sc) +getArgNames defs allvars env (NBind fc x (Pi _ p ty) sc) = do ns <- case p of Explicit => pure [!(getArgName defs x allvars ty)] _ => pure [] @@ -172,14 +172,14 @@ expandCon fc usedvars con = do defs <- get Ctxt Just ty <- lookupTyExact con (gamma defs) | Nothing => throw (UndefinedName fc con) - pure (apply (IVar fc con) + pure (apply (IVar fc con) (map (IBindVar fc) - !(getArgNames defs usedvars [] + !(getArgNames defs usedvars [] !(nf defs [] ty)))) updateArg : {auto c : Ref Ctxt Defs} -> List Name -> -- all the variable names - (var : Name) -> (con : Name) -> + (var : Name) -> (con : Name) -> RawImp -> Core RawImp updateArg allvars var con (IVar fc n) = if n `elem` allvars @@ -188,22 +188,22 @@ updateArg allvars var con (IVar fc n) else pure $ Implicit fc True else pure $ IVar fc n updateArg allvars var con (IApp fc f a) - = pure $ IApp fc !(updateArg allvars var con f) + = pure $ IApp fc !(updateArg allvars var con f) !(updateArg allvars var con a) updateArg allvars var con (IImplicitApp fc f n a) - = pure $ IImplicitApp fc !(updateArg allvars var con f) n + = pure $ IImplicitApp fc !(updateArg allvars var con f) n !(updateArg allvars var con a) updateArg allvars var con (IAs fc s n p) = updateArg allvars var con p updateArg allvars var con tm = pure $ Implicit (getFC tm) True -data ArgType +data ArgType = Explicit FC RawImp | Implicit FC (Maybe Name) RawImp update : {auto c : Ref Ctxt Defs} -> List Name -> -- all the variable names - (var : Name) -> (con : Name) -> + (var : Name) -> (con : Name) -> ArgType -> Core ArgType update allvars var con (Explicit fc arg) = pure $ Explicit fc !(updateArg allvars var con arg) @@ -226,14 +226,14 @@ apply f [] = f -- Also replace any variables with '_' to allow elaboration to -- expand them newLHS : {auto c : Ref Ctxt Defs} -> - FC -> + FC -> Nat -> -- previous environment length; leave these alone List Name -> -- all the variable names - (var : Name) -> (con : Name) -> + (var : Name) -> (con : Name) -> RawImp -> Core RawImp newLHS fc envlen allvars var con tm = do let (f, args) = getFnArgs tm [] - let keep = map (const (Explicit fc (Implicit fc True))) + let keep = map (const (Explicit fc (Implicit fc True))) (take envlen args) let ups = drop envlen args ups' <- traverse (update allvars var con) ups @@ -305,7 +305,7 @@ mkCase {c} {u} fn orig lhs_raw (\err => case err of WhenUnifying _ env l r err => do defs <- get Ctxt - if !(impossibleOK defs !(nf defs env l) + if !(impossibleOK defs !(nf defs env l) !(nf defs env r)) then pure (Impossible lhs_raw) else pure Invalid @@ -328,7 +328,7 @@ export getSplitsLHS : {auto m : Ref MD Metadata} -> {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> Nat -> ClosedTerm -> Name -> + FC -> Nat -> ClosedTerm -> Name -> Core (SplitResult (List ClauseUpdate)) getSplitsLHS fc envlen lhs_in n = do let lhs = substLets lhs_in @@ -337,7 +337,7 @@ getSplitsLHS fc envlen lhs_in n defs <- get Ctxt OK (fn, tyn, cons) <- findCons n lhs | SplitFail err => pure (SplitFail err) - + rawlhs <- unelabNoSugar [] lhs trycases <- traverse (\c => newLHS fc envlen usedns n c rawlhs) cons @@ -351,7 +351,7 @@ export getSplits : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - (FC -> ClosedTerm -> Bool) -> Name -> + (FC -> ClosedTerm -> Bool) -> Name -> Core (SplitResult (List ClauseUpdate)) getSplits p n = do Just (loc, envlen, lhs_in) <- findLHSAt p diff --git a/src/TTImp/Interactive/ExprSearch.idr b/src/TTImp/Interactive/ExprSearch.idr index 7bd24e3..685cb7f 100644 --- a/src/TTImp/Interactive/ExprSearch.idr +++ b/src/TTImp/Interactive/ExprSearch.idr @@ -43,30 +43,30 @@ search : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> FC -> RigCount -> - SearchOpts -> Maybe RecData -> + SearchOpts -> Maybe RecData -> ClosedTerm -> Name -> Core (List ClosedTerm) -getAllEnv : FC -> (done : List Name) -> - Env Term vars -> +getAllEnv : FC -> (done : List Name) -> + Env Term vars -> List (Term (done ++ vars), Term (done ++ vars)) getAllEnv fc done [] = [] -getAllEnv {vars = v :: vs} fc done (b :: env) - = let rest = getAllEnv fc (done ++ [v]) env +getAllEnv {vars = v :: vs} fc done (b :: env) + = let rest = getAllEnv fc (done ++ [v]) env MkVar p = weakenVar done {inner = v :: vs} First in (Local fc Nothing _ p, - rewrite appendAssociative done [v] vs in - weakenNs (done ++ [v]) (binderType b)) :: + rewrite appendAssociative done [v] vs in + weakenNs (done ++ [v]) (binderType b)) :: rewrite appendAssociative done [v] vs in rest -- Search recursively, but only if the given name wasn't solved by unification searchIfHole : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> SearchOpts -> Maybe RecData -> ClosedTerm -> - Env Term vars -> ArgInfo vars -> + FC -> SearchOpts -> Maybe RecData -> ClosedTerm -> + Env Term vars -> ArgInfo vars -> Core (List (Term vars)) -searchIfHole fc opts defining topty env arg +searchIfHole fc opts defining topty env arg = case depth opts of Z => pure [] S k => @@ -86,7 +86,7 @@ searchIfHole fc opts defining topty env arg traverse (\tm => pure !(normaliseHoles defs env (applyTo fc (embed tm) env))) tms -mkCandidates : FC -> Term vars -> List (List (Term vars)) -> +mkCandidates : FC -> Term vars -> List (List (Term vars)) -> List (Term vars) mkCandidates fc f [] = pure f mkCandidates fc f (args :: argss) @@ -102,12 +102,12 @@ explicit ai = plicit ai == Explicit searchName : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> RigCount -> SearchOpts -> + FC -> RigCount -> SearchOpts -> Env Term vars -> NF vars -> ClosedTerm -> Maybe RecData -> (Name, GlobalDef) -> Core (List (Term vars)) searchName fc rigc opts env target topty defining (n, ndef) = do defs <- get Ctxt - let True = visibleInAny (!getNS :: !getNestedNS) + let True = visibleInAny (!getNS :: !getNestedNS) (fullname ndef) (visibility ndef) | _ => pure [] let ty = type ndef @@ -149,7 +149,7 @@ successful (elab :: elabs) = catch (do res <- elab rest <- successful elabs pure (Right res :: rest)) - (\err => + (\err => do rest <- successful elabs pure (Left err :: rest)) @@ -171,7 +171,7 @@ getSuccessful {vars} fc rig opts mkHole env ty topty defining all (\r => nameRoot (recname r) ++ "_rhs") defining hn <- uniqueName defs (map nameRoot vars) base - (idx, tm) <- newMeta fc rig env (UN hn) ty + (idx, tm) <- newMeta fc rig env (UN hn) ty (Hole (length env) False) False pure [tm] @@ -197,7 +197,7 @@ searchNames fc rig opts env ty topty defining (n :: ns) getSuccessful fc rig opts False env ty topty defining (map (searchName fc rig opts env nfty topty defining) visns) where - visible : Context -> List (List String) -> Name -> + visible : Context -> List (List String) -> Name -> Core (Maybe (Name, GlobalDef)) visible gam nspace n = do Just def <- lookupCtxtExact n gam @@ -209,16 +209,16 @@ searchNames fc rig opts env ty topty defining (n :: ns) tryRecursive : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> RigCount -> SearchOpts -> + FC -> RigCount -> SearchOpts -> Env Term vars -> Term vars -> ClosedTerm -> Maybe RecData -> Core (List (Term vars)) tryRecursive fc rig opts env ty topty Nothing = pure [] -tryRecursive fc rig opts env ty topty (Just rdata) +tryRecursive fc rig opts env ty topty (Just rdata) = do defs <- get Ctxt case !(lookupCtxtExact (recname rdata) (gamma defs)) of Nothing => pure [] Just def => - do tms <- searchName fc rig opts env !(nf defs env ty) + do tms <- searchName fc rig opts env !(nf defs env ty) topty Nothing (recname rdata, def) defs <- get Ctxt @@ -235,7 +235,7 @@ tryRecursive fc rig opts env ty topty (Just rdata) argDiff (Ref _ _ fn) (Ref _ _ fn') = fn /= fn' argDiff (Bind _ _ _ _) _ = False argDiff _ (Bind _ _ _ _) = False - argDiff (App _ f a) (App _ f' a') + argDiff (App _ f a) (App _ f' a') = structDiff f f' || structDiff a a' argDiff (PrimVal _ c) (PrimVal _ c') = c /= c' argDiff (Erased _) _ = False @@ -244,7 +244,7 @@ tryRecursive fc rig opts env ty topty (Just rdata) argDiff (As _ _ x) y = argDiff x y argDiff x (As _ _ y) = argDiff x y argDiff _ _ = True - + appsDiff : Term vs -> Term vs' -> List (Term vs) -> List (Term vs') -> Bool appsDiff (Ref _ (DataCon _ _) f) (Ref _ (DataCon _ _) f') args args' @@ -277,9 +277,9 @@ usableLocal loc _ _ = True searchLocalWith : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> RigCount -> SearchOpts -> Env Term vars -> + FC -> RigCount -> SearchOpts -> Env Term vars -> List (Term vars, Term vars) -> - Term vars -> ClosedTerm -> Maybe RecData -> + Term vars -> ClosedTerm -> Maybe RecData -> Core (List (Term vars)) searchLocalWith fc rig opts env [] ty topty defining = pure [] @@ -291,7 +291,7 @@ searchLocalWith {vars} fc rig opts env ((p, pty) :: rest) ty topty defining searchLocalWith fc rig opts env rest ty topty defining] where - findDirect : Defs -> Term vars -> + findDirect : Defs -> Term vars -> (Term vars -> Term vars) -> NF vars -> -- local variable's type NF vars -> -- type we're looking for @@ -301,7 +301,7 @@ searchLocalWith {vars} fc rig opts env ((p, pty) :: rest) ty topty defining -- We can only use a local variable if it's not an unsolved -- hole if usableLocal fc env nty - then + then tryUnify -- try with no arguments first (do ures <- unify InTerm fc env ty nty let [] = constraints ures @@ -310,12 +310,12 @@ searchLocalWith {vars} fc rig opts env ((p, pty) :: rest) ty topty defining (do ures <- unify InTerm fc env ty appTy let [] = constraints ures | _ => pure [] - args' <- traverse (searchIfHole fc opts defining topty env) + args' <- traverse (searchIfHole fc opts defining topty env) args pure (mkCandidates fc (f prf) args')) else pure [] - findPos : Defs -> Term vars -> + findPos : Defs -> Term vars -> (Term vars -> Term vars) -> NF vars -> NF vars -> Core (List (Term vars)) findPos defs prf f x@(NTCon pfc pn _ _ [xty, yty]) target @@ -340,7 +340,7 @@ searchLocalWith {vars} fc rig opts env ((p, pty) :: rest) ty topty defining f arg]) xtynf target), (do ytynf <- evalClosure defs yty - findPos defs prf + findPos defs prf (\arg => apply fc (Ref fc Func sname) [xtytm, ytytm, @@ -352,12 +352,12 @@ searchLocalWith {vars} fc rig opts env ((p, pty) :: rest) ty topty defining searchLocal : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> RigCount -> SearchOpts -> + FC -> RigCount -> SearchOpts -> Env Term vars -> Term vars -> ClosedTerm -> Maybe RecData -> Core (List (Term vars)) -searchLocal fc rig opts env ty topty defining +searchLocal fc rig opts env ty topty defining = do defs <- get Ctxt - searchLocalWith fc rig opts env (getAllEnv fc [] env) + searchLocalWith fc rig opts env (getAllEnv fc [] env) ty topty defining searchType : {auto c : Ref Ctxt Defs} -> @@ -399,12 +399,12 @@ searchType fc rig opts env defining topty _ ty ([searchLocal fc rig opts env ty topty defining, searchNames fc rig opts env ty topty defining allHints] - ++ if recOK opts + ++ if recOK opts then [tryRecursive fc rig opts env ty topty defining] else []) else pure [] _ => do logTerm 10 "Searching locals only at" ty - getSuccessful fc rig opts True env ty topty defining + getSuccessful fc rig opts True env ty topty defining ([searchLocal fc rig opts env ty topty defining] ++ if recOK opts then [tryRecursive fc rig opts env ty topty defining] @@ -413,7 +413,7 @@ searchType fc rig opts env defining topty _ ty searchHole : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> RigCount -> SearchOpts -> Maybe RecData -> Name -> + FC -> RigCount -> SearchOpts -> Maybe RecData -> Name -> Nat -> ClosedTerm -> Defs -> GlobalDef -> Core (List ClosedTerm) searchHole fc rig opts defining n locs topty defs glob @@ -430,15 +430,15 @@ search fc rig opts defining topty n_in -- if it's arising from an auto implicit case definition gdef of Hole locs _ => searchHole fc rig opts defining n locs topty defs gdef - BySearch _ _ _ => searchHole fc rig opts defining n - !(getArity defs [] (type gdef)) + BySearch _ _ _ => searchHole fc rig opts defining n + !(getArity defs [] (type gdef)) topty defs gdef _ => do log 10 $ show n_in ++ " not a hole" throw (InternalError $ "Not a hole: " ++ show n ++ " in " ++ show (map recname defining)) _ => do log 10 $ show n_in ++ " not found" throw (UndefinedName fc n_in) where - lookupHoleName : Name -> Context -> + lookupHoleName : Name -> Context -> Core (Maybe (Name, Int, GlobalDef)) lookupHoleName n defs = case !(lookupCtxtExactI n defs) of @@ -454,7 +454,7 @@ getLHSData defs (Just tm) = pure $ getLHS !(normaliseHoles defs [] tm) getLHS : Term vars -> Maybe RecData getLHS (Bind _ _ (PVar _ _ _) sc) = getLHS sc getLHS (Bind _ _ (PLet _ _ _) sc) = getLHS sc - getLHS sc + getLHS sc = case getFn sc of Ref _ _ n => Just (MkRecData n sc) _ => Nothing @@ -465,7 +465,7 @@ dropLinearErrors : {auto c : Ref Ctxt Defs} -> Core (List ClosedTerm) dropLinearErrors fc [] = pure [] dropLinearErrors fc (t :: ts) - = tryUnify + = tryUnify (do linearCheck fc Rig1 False [] t ts' <- dropLinearErrors fc ts pure (t :: ts')) diff --git a/src/TTImp/Interactive/GenerateDef.idr b/src/TTImp/Interactive/GenerateDef.idr index 7ac5228..d871b7e 100644 --- a/src/TTImp/Interactive/GenerateDef.idr +++ b/src/TTImp/Interactive/GenerateDef.idr @@ -23,7 +23,7 @@ import TTImp.Utils %default covering fnName : Bool -> Name -> String -fnName lhs (UN n) +fnName lhs (UN n) = if any (not . identChar) (unpack n) then if lhs then "(" ++ n ++ ")" else "op" @@ -49,10 +49,10 @@ uniqueRHS c = pure c expandClause : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> Int -> ImpClause -> + FC -> Int -> ImpClause -> Core (List ImpClause) expandClause loc n c - = do log 10 $ "Trying clause " ++ show c + = do log 10 $ "Trying clause " ++ show c c <- uniqueRHS c Just clause <- checkClause Rig1 False n [] (MkNested []) [] c | Nothing => pure [] -- TODO: impossible clause, do something @@ -71,8 +71,8 @@ expandClause loc n c rhsnf <- normaliseHoles defs [] rhs' let (_ ** (env', rhsenv)) = dropLams locs [] rhsnf - rhsraw <- unelab env' rhsenv - logTermNF 5 "Got clause" env lhs + rhsraw <- unelab env' rhsenv + logTermNF 5 "Got clause" env lhs logTermNF 5 " = " env' rhsenv pure [updateRHS c rhsraw] where @@ -82,10 +82,10 @@ expandClause loc n c updateRHS (WithClause fc lhs wval cs) rhs = WithClause fc lhs wval cs updateRHS (ImpossibleClause fc lhs) _ = ImpossibleClause fc lhs - dropLams : Nat -> Env Term vars -> Term vars -> + dropLams : Nat -> Env Term vars -> Term vars -> (vars' ** (Env Term vars', Term vars')) dropLams Z env tm = (_ ** (env, tm)) - dropLams (S k) env (Bind _ _ b sc) = dropLams k (b :: env) sc + dropLams (S k) env (Bind _ _ b sc) = dropLams k (b :: env) sc dropLams _ env tm = (_ ** (env, tm)) splittableNames : RawImp -> List Name @@ -129,19 +129,19 @@ trySplit loc lhsraw lhs rhs n Nothing => IBindVar loc' n Just tm => fixNames tm updateLHS ups (IApp loc' f a) = IApp loc' (updateLHS ups f) (updateLHS ups a) - updateLHS ups (IImplicitApp loc' f t a) + updateLHS ups (IImplicitApp loc' f t a) = IImplicitApp loc' (updateLHS ups f) t (updateLHS ups a) updateLHS ups tm = tm generateSplits : {auto m : Ref MD Metadata} -> {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> Int -> ImpClause -> + FC -> Int -> ImpClause -> Core (List (Name, List ImpClause)) generateSplits loc fn (ImpossibleClause fc lhs) = pure [] generateSplits loc fn (WithClause fc lhs wval cs) = pure [] -generateSplits {c} {m} {u} loc fn (PatClause fc lhs rhs) - = do (lhstm, _) <- +generateSplits {c} {m} {u} loc fn (PatClause fc lhs rhs) + = do (lhstm, _) <- elabTerm fn (InLHS Rig1) [] (MkNested []) [] (IBindHere loc PATTERN lhs) Nothing traverse (trySplit fc lhs lhstm rhs) (splittableNames lhs) @@ -151,10 +151,10 @@ mutual {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> FC -> Int -> Error -> - List (Name, List ImpClause) -> + List (Name, List ImpClause) -> Core (List ImpClause) tryAllSplits loc n err [] = throw err - tryAllSplits loc n err ((x, []) :: rest) + tryAllSplits loc n err ((x, []) :: rest) = tryAllSplits loc n err rest tryAllSplits loc n err ((x, cs) :: rest) = do log 5 $ "Splitting on " ++ show x @@ -165,7 +165,7 @@ mutual mkSplits : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - FC -> Int -> ImpClause -> + FC -> Int -> ImpClause -> Core (List ImpClause) -- If the clause works, use it. Otherwise, split on one of the splittable -- variables and try all of the resulting clauses @@ -180,9 +180,9 @@ export makeDef : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - (FC -> (Name, Nat, ClosedTerm) -> Bool) -> + (FC -> (Name, Nat, ClosedTerm) -> Bool) -> Name -> Core (Maybe (FC, List ImpClause)) -makeDef p n +makeDef p n = do Just (loc, nidx, envlen, ty) <- findTyDeclAt p | Nothing => pure Nothing n <- getFullName nidx @@ -193,10 +193,10 @@ makeDef p n argns <- getEnvArgNames defs envlen !(nf defs [] ty) -- Need to add implicit patterns for the outer environment. -- We won't try splitting on these - let pre_env = replicate envlen (Implicit loc True) + let pre_env = replicate envlen (Implicit loc True) rhshole <- uniqueName defs [] (fnName False n ++ "_rhs") - let initcs = PatClause loc + let initcs = PatClause loc (apply (IVar loc n) (pre_env ++ (map (IBindVar loc) argns))) (IHole loc rhshole) let Just nidx = getNameID n (gamma defs) diff --git a/src/TTImp/Interactive/MakeLemma.idr b/src/TTImp/Interactive/MakeLemma.idr index 7a74c71..d82f49e 100644 --- a/src/TTImp/Interactive/MakeLemma.idr +++ b/src/TTImp/Interactive/MakeLemma.idr @@ -38,7 +38,7 @@ bindableArg p (Bind _ _ (Pi _ _ ty) sc) bindableArg p _ = False getArgs : {auto c : Ref Ctxt Defs} -> - Env Term vars -> Nat -> Term vars -> + Env Term vars -> Nat -> Term vars -> Core (List (Name, Maybe Name, PiInfo, RigCount, RawImp), RawImp) getArgs {vars} env (S k) (Bind _ x (Pi c p ty) sc) = do ty' <- unelab env ty @@ -59,8 +59,8 @@ getArgs env k ty = do ty' <- unelab env ty pure ([], ty') -mkType : FC -> List (Name, Maybe Name, PiInfo, RigCount, RawImp) -> - RawImp -> RawImp +mkType : FC -> List (Name, Maybe Name, PiInfo, RigCount, RawImp) -> + RawImp -> RawImp mkType loc [] ret = ret mkType loc ((_, n, p, c, ty) :: rest) ret = IPi loc c p n ty (mkType loc rest ret) @@ -70,7 +70,7 @@ mkApp : FC -> Name -> mkApp loc n args = apply (IVar loc n) (mapMaybe getArg args) where - getArg : (Name, Maybe Name, PiInfo, RigCount, RawImp) -> + getArg : (Name, Maybe Name, PiInfo, RigCount, RawImp) -> Maybe RawImp getArg (x, _, Explicit, _, _) = Just (IVar loc x) getArg _ = Nothing @@ -80,7 +80,7 @@ mkApp loc n args export makeLemma : {auto m : Ref MD Metadata} -> {auto c : Ref Ctxt Defs} -> - FC -> Name -> Nat -> ClosedTerm -> + FC -> Name -> Nat -> ClosedTerm -> Core (RawImp, RawImp) makeLemma loc n nlocs ty = do (args, ret) <- getArgs [] nlocs ty diff --git a/src/TTImp/Parser.idr b/src/TTImp/Parser.idr index dad831e..fdeaa34 100644 --- a/src/TTImp/Parser.idr +++ b/src/TTImp/Parser.idr @@ -99,7 +99,7 @@ visOpt opt <- fnDirectOpt pure (Right opt) -getVisibility : Maybe Visibility -> List (Either Visibility FnOpt) -> +getVisibility : Maybe Visibility -> List (Either Visibility FnOpt) -> EmptyRule Visibility getVisibility Nothing [] = pure Private getVisibility (Just vis) [] = pure vis @@ -136,10 +136,10 @@ mutual applyExpImp start end f [] = f applyExpImp start end f (Left exp :: args) = applyExpImp start end (IApp (MkFC fname start end) f exp) args - applyExpImp start end f (Right (n, imp) :: args) + applyExpImp start end f (Right (n, imp) :: args) = applyExpImp start end (IImplicitApp (MkFC fname start end) f n imp) args - argExpr : FileName -> IndentInfo -> + argExpr : FileName -> IndentInfo -> Rule (Either RawImp (Maybe Name, RawImp)) argExpr fname indents = do continue indents @@ -201,20 +201,20 @@ mutual getMult Nothing = pure RigW getMult _ = fatalError "Invalid multiplicity (must be 0 or 1)" - pibindAll : FC -> PiInfo -> List (RigCount, Maybe Name, RawImp) -> + pibindAll : FC -> PiInfo -> List (RigCount, Maybe Name, RawImp) -> RawImp -> RawImp pibindAll fc p [] scope = scope pibindAll fc p ((rig, n, ty) :: rest) scope = IPi fc rig p n ty (pibindAll fc p rest scope) - bindList : FileName -> FilePos -> IndentInfo -> + bindList : FileName -> FilePos -> IndentInfo -> Rule (List (RigCount, Name, RawImp)) bindList fname start indents = sepBy1 (symbol ",") (do rigc <- multiplicity n <- unqualifiedName end <- location - ty <- option + ty <- option (Implicit (MkFC fname start end) False) (do symbol ":" appExpr fname indents) @@ -222,7 +222,7 @@ mutual pure (rig, UN n, ty)) - pibindList : FileName -> FilePos -> IndentInfo -> + pibindList : FileName -> FilePos -> IndentInfo -> Rule (List (RigCount, Maybe Name, RawImp)) pibindList fname start indents = do rigc <- multiplicity @@ -239,7 +239,7 @@ mutual ty <- expr fname indents rig <- getMult rigc pure (rig, Just n, ty)) - + autoImplicitPi : FileName -> IndentInfo -> Rule RawImp autoImplicitPi fname indents = do start <- location @@ -347,8 +347,8 @@ mutual = do start <- location lhs <- appExpr fname indents caseRHS fname indents start lhs - - caseRHS : FileName -> IndentInfo -> (Int, Int) -> RawImp -> + + caseRHS : FileName -> IndentInfo -> (Int, Int) -> RawImp -> Rule ImpClause caseRHS fname indents start lhs = do symbol "=>" @@ -392,7 +392,7 @@ mutual tm <- expr fname indents end <- location pure (IRewrite (MkFC fname start end) rule tm) - + lazy : FileName -> IndentInfo -> Rule RawImp lazy fname indents = do start <- location @@ -440,8 +440,8 @@ mutual where mkPi : FilePos -> FilePos -> RawImp -> List (PiInfo, RawImp) -> RawImp mkPi start end arg [] = arg - mkPi start end arg ((exp, a) :: as) - = IPi (MkFC fname start end) RigW exp Nothing arg + mkPi start end arg ((exp, a) :: as) + = IPi (MkFC fname start end) RigW exp Nothing arg (mkPi start end a as) export @@ -490,7 +490,7 @@ mutual getFn (IVar _ n) = pure n getFn (IApp _ f a) = getFn f getFn (IImplicitApp _ f _ a) = getFn f - getFn _ = fail "Not a function application" + getFn _ = fail "Not a function application" clause : Nat -> FileName -> IndentInfo -> Rule (Name, ImpClause) clause withArgs fname indents @@ -506,13 +506,13 @@ mutual applyArgs f ((fc, a) :: args) = applyArgs (IApp fc f a) args parseWithArg : Rule (FC, RawImp) - parseWithArg + parseWithArg = do symbol "|" start <- location tm <- expr fname indents end <- location pure (MkFC fname start end, tm) - + definition : FileName -> IndentInfo -> Rule ImpDecl definition fname indents = do start <- location @@ -666,7 +666,7 @@ collectDefs (IDef loc fn cs :: ds) (ys, zs) => (y ++ ys, zs) isClause : Name -> ImpDecl -> Maybe (List ImpClause) - isClause n (IDef _ n' cs) + isClause n (IDef _ n' cs) = if n == n' then Just cs else Nothing isClause n _ = Nothing collectDefs (INamespace loc nest ns nds :: ds) diff --git a/src/TTImp/ProcessData.idr b/src/TTImp/ProcessData.idr index 8038060..77a1522 100644 --- a/src/TTImp/ProcessData.idr +++ b/src/TTImp/ProcessData.idr @@ -19,13 +19,13 @@ import Data.NameMap processDataOpt : {auto c : Ref Ctxt Defs} -> FC -> Name -> DataOpt -> Core () -processDataOpt fc n NoHints +processDataOpt fc n NoHints = pure () -processDataOpt fc ndef (SearchBy dets) +processDataOpt fc ndef (SearchBy dets) = setDetermining fc ndef dets checkRetType : {auto c : Ref Ctxt Defs} -> - Env Term vars -> NF vars -> + Env Term vars -> NF vars -> (NF vars -> Core ()) -> Core () checkRetType env (NBind fc x (Pi _ _ ty) sc) chk = do defs <- get Ctxt @@ -35,18 +35,18 @@ checkRetType env nf chk = chk nf checkIsType : {auto c : Ref Ctxt Defs} -> FC -> Name -> Env Term vars -> NF vars -> Core () checkIsType loc n env nf - = checkRetType env nf - (\nf => case nf of + = checkRetType env nf + (\nf => case nf of NType _ => pure () _ => throw (BadTypeConType loc n)) checkFamily : {auto c : Ref Ctxt Defs} -> FC -> Name -> Name -> Env Term vars -> NF vars -> Core () checkFamily loc cn tn env nf - = checkRetType env nf - (\nf => case nf of + = checkRetType env nf + (\nf => case nf of NType _ => throw (BadDataConType loc cn tn) - NTCon _ n' _ _ _ => + NTCon _ n' _ _ _ => if tn == n' then pure () else throw (BadDataConType loc cn tn) @@ -56,7 +56,7 @@ checkCon : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - List ElabOpt -> NestedNames vars -> + List ElabOpt -> NestedNames vars -> Env Term vars -> Visibility -> Name -> ImpTy -> Core Constructor checkCon {vars} opts nest env vis tn (MkImpTy fc cn_in ty_raw) @@ -67,9 +67,9 @@ checkCon {vars} opts nest env vis tn (MkImpTy fc cn_in ty_raw) -- Check 'cn' is undefined Nothing <- lookupCtxtExact cn (gamma defs) | Just gdef => throw (AlreadyDefined fc cn) - ty <- + ty <- wrapError (InCon fc cn) $ - checkTerm !(resolveName cn) InType opts nest env + checkTerm !(resolveName cn) InType opts nest env (IBindHere fc (PI Rig0) ty_raw) (gType fc) @@ -96,10 +96,10 @@ processData : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - List ElabOpt -> NestedNames vars -> + List ElabOpt -> NestedNames vars -> Env Term vars -> FC -> Visibility -> ImpData -> Core () -processData {vars} eopts nest env fc vis (MkImpLater dfc n_in ty_raw) +processData {vars} eopts nest env fc vis (MkImpLater dfc n_in ty_raw) = do n <- inCurrentNS n_in ty_raw <- bindTypeNames vars ty_raw @@ -107,10 +107,10 @@ processData {vars} eopts nest env fc vis (MkImpLater dfc n_in ty_raw) -- Check 'n' is undefined Nothing <- lookupCtxtExact n (gamma defs) | Just gdef => throw (AlreadyDefined fc n) - - (ty, _) <- + + (ty, _) <- wrapError (InCon fc n) $ - elabTerm !(resolveName n) InType eopts nest env + elabTerm !(resolveName n) InType eopts nest env (IBindHere fc (PI Rig0) ty_raw) (Just (gType dfc)) let fullty = abstractEnvType dfc env ty @@ -144,7 +144,7 @@ processData {vars} eopts nest env fc vis (MkImpData dfc n_in ty_raw opts cons_ra defs <- get Ctxt (ty, _) <- wrapError (InCon fc n) $ - elabTerm !(resolveName n) InType eopts nest env + elabTerm !(resolveName n) InType eopts nest env (IBindHere fc (PI Rig0) ty_raw) (Just (gType dfc)) let fullty = abstractEnvType dfc env ty diff --git a/src/TTImp/ProcessDecls.idr b/src/TTImp/ProcessDecls.idr index 005d93d..01ec861 100644 --- a/src/TTImp/ProcessDecls.idr +++ b/src/TTImp/ProcessDecls.idr @@ -24,11 +24,11 @@ process : {vars : _} -> {auto u : Ref UST UState} -> List ElabOpt -> NestedNames vars -> Env Term vars -> ImpDecl -> Core () -process eopts nest env (IClaim fc rig vis opts ty) +process eopts nest env (IClaim fc rig vis opts ty) = processType eopts nest env fc rig vis opts ty -process eopts nest env (IData fc vis ddef) +process eopts nest env (IData fc vis ddef) = processData eopts nest env fc vis ddef -process eopts nest env (IDef fc fname def) +process eopts nest env (IDef fc fname def) = processDef eopts nest env fc fname def process eopts nest env (IParameters fc ps decls) = processParams nest env fc ps decls @@ -42,7 +42,7 @@ process eopts nest env (INamespace fc nested ns decls) newns <- getNS traverse_ (processDecl eopts nest env) decls defs <- get Ctxt - put Ctxt (record { currentNS = cns, + put Ctxt (record { currentNS = cns, nestedNS = if nested then newns :: nns else nns } defs) diff --git a/src/TTImp/ProcessDef.idr b/src/TTImp/ProcessDef.idr index 14acca4..9b49c7c 100644 --- a/src/TTImp/ProcessDef.idr +++ b/src/TTImp/ProcessDef.idr @@ -26,22 +26,22 @@ import Data.NameMap mutual mismatchNF : Defs -> NF vars -> NF vars -> Core Bool - mismatchNF defs (NTCon _ xn xt _ xargs) (NTCon _ yn yt _ yargs) + mismatchNF defs (NTCon _ xn xt _ xargs) (NTCon _ yn yt _ yargs) = if xn /= yn then pure True - else anyM (mismatch defs) (zip xargs yargs) - mismatchNF defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) + else anyM (mismatch defs) (zip xargs yargs) + mismatchNF defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) = if xt /= yt then pure True - else anyM (mismatch defs) (zip xargs yargs) + else anyM (mismatch defs) (zip xargs yargs) mismatchNF defs (NPrimVal _ xc) (NPrimVal _ yc) = pure (xc /= yc) mismatchNF defs (NDelayed _ _ x) (NDelayed _ _ y) = mismatchNF defs x y - mismatchNF defs (NDelay _ _ _ x) (NDelay _ _ _ y) + mismatchNF defs (NDelay _ _ _ x) (NDelay _ _ _ y) = mismatchNF defs !(evalClosure defs x) !(evalClosure defs y) mismatchNF _ _ _ = pure False mismatch : Defs -> (Closure vars, Closure vars) -> Core Bool - mismatch defs (x, y) + mismatch defs (x, y) = mismatchNF defs !(evalClosure defs x) !(evalClosure defs y) -- If the terms have the same type constructor at the head, and one of @@ -62,7 +62,7 @@ impossibleOK defs (NPrimVal _ x) (NPrimVal _ y) = pure (x /= y) impossibleOK defs (NDCon _ _ _ _ _) (NPrimVal _ _) = pure True impossibleOK defs (NPrimVal _ _) (NDCon _ _ _ _ _) = pure True impossibleOK defs x y = pure False - + export impossibleErrOK : {auto c : Ref Ctxt Defs} -> Defs -> Error -> Core Bool @@ -91,10 +91,10 @@ impossibleErrOK defs _ = pure False -- so all the outer things are marked as 'DropCons' extendEnv : Env Term vars -> SubVars inner vars -> NestedNames vars -> - Term vars -> Term vars -> - Core (vars' ** + Term vars -> Term vars -> + Core (vars' ** (SubVars inner vars', - Env Term vars', NestedNames vars', + Env Term vars', NestedNames vars', Term vars', Term vars')) extendEnv env p nest (Bind _ n (PVar c pi tmty) sc) (Bind _ n' (PVTy _ _) tysc) with (nameEq n n') extendEnv env p nest (Bind _ n (PVar c pi tmty) sc) (Bind _ n' (PVTy _ _) tysc) | Nothing @@ -107,7 +107,7 @@ extendEnv env p nest (Bind _ n (PLet c tmval tmty) sc) (Bind _ n' (PLet _ _ _) t -- PLet on the left becomes Let on the right, to give it computational force extendEnv env p nest (Bind _ n (PLet c tmval tmty) sc) (Bind _ n (PLet _ _ _) tysc) | (Just Refl) = extendEnv (Let c tmval tmty :: env) (DropCons p) (weaken nest) sc tysc -extendEnv env p nest tm ty +extendEnv env p nest tm ty = pure (_ ** (p, env, nest, tm, ty)) -- Find names which are applied to a function in a Rig1/Rig0 position, @@ -117,9 +117,9 @@ extendEnv env p nest tm ty -- only ones we're checking linearity of (we may be shadowing names if this -- is a local definition, so we need to leave the earlier ones alone) findLinear : {auto c : Ref Ctxt Defs} -> - Bool -> Nat -> RigCount -> Term vars -> + Bool -> Nat -> RigCount -> Term vars -> Core (List (Name, RigCount)) -findLinear top bound rig (Bind fc n b sc) +findLinear top bound rig (Bind fc n b sc) = findLinear top (S bound) rig sc findLinear top bound rig (As fc _ p) = findLinear top bound rig p @@ -137,22 +137,22 @@ findLinear top bound rig tm accessible Func r = if top then r else Rig0 accessible _ r = r - findLinArg : RigCount -> NF [] -> List (Term vars) -> + findLinArg : RigCount -> NF [] -> List (Term vars) -> Core (List (Name, RigCount)) findLinArg rig ty (As fc _ p :: as) = findLinArg rig ty (p :: as) - findLinArg rig (NBind _ x (Pi c _ _) sc) (Local {name=a} fc _ idx prf :: as) + findLinArg rig (NBind _ x (Pi c _ _) sc) (Local {name=a} fc _ idx prf :: as) = do defs <- get Ctxt if idx < bound then do sc' <- sc defs (toClosure defaultOpts [] (Ref fc Bound x)) - pure $ (a, rigMult c rig) :: + pure $ (a, rigMult c rig) :: !(findLinArg rig sc' as) else do sc' <- sc defs (toClosure defaultOpts [] (Ref fc Bound x)) findLinArg rig sc' as - findLinArg rig (NBind fc x (Pi c _ _) sc) (a :: as) + findLinArg rig (NBind fc x (Pi c _ _) sc) (a :: as) = do defs <- get Ctxt pure $ !(findLinear False bound (rigMult c rig) a) ++ !(findLinArg rig !(sc defs (toClosure defaultOpts [] (Ref fc Bound x))) as) - findLinArg rig ty (a :: as) + findLinArg rig ty (a :: as) = pure $ !(findLinear False bound rig a) ++ !(findLinArg rig ty as) findLinArg _ _ [] = pure [] @@ -178,7 +178,7 @@ combineLinear loc ((n, count) :: cs) = case lookupAll n cs of [] => pure $ (n, count) :: !(combineLinear loc cs) counts => do count' <- combineAll count counts - pure $ (n, count') :: + pure $ (n, count') :: !(combineLinear loc (filter notN cs)) where notN : (Name, RigCount) -> Bool @@ -186,7 +186,7 @@ combineLinear loc ((n, count) :: cs) lookupAll : Name -> List (Name, RigCount) -> List RigCount lookupAll n [] = [] - lookupAll n ((n', c) :: cs) + lookupAll n ((n', c) :: cs) = if n == n' then c :: lookupAll n cs else lookupAll n cs combine : RigCount -> RigCount -> Core RigCount @@ -209,14 +209,14 @@ checkLHS : {vars : _} -> {auto u : Ref UST UState} -> (mult : RigCount) -> (hashit : Bool) -> Int -> List ElabOpt -> NestedNames vars -> Env Term vars -> - FC -> RawImp -> + FC -> RawImp -> Core (RawImp, -- checked LHS with implicits added (vars' ** (SubVars vars vars', - Env Term vars', NestedNames vars', + Env Term vars', NestedNames vars', Term vars', Term vars'))) checkLHS {vars} mult hashit n opts nest env fc lhs_in = do defs <- get Ctxt - lhs_raw <- lhsInCurrentNS nest lhs_in + lhs_raw <- lhsInCurrentNS nest lhs_in autoimp <- isAutoImplicits autoImplicits True (_, lhs_bound) <- bindNames False lhs_raw @@ -226,9 +226,9 @@ checkLHS {vars} mult hashit n opts nest env fc lhs_in log 5 $ "Checking LHS of " ++ show !(getFullName (Resolved n)) ++ " " ++ show lhs logEnv 5 "In env" env - (lhstm, lhstyg) <- + (lhstm, lhstyg) <- wrapError (InLHS fc !(getFullName (Resolved n))) $ - elabTerm n (InLHS mult) opts nest env + elabTerm n (InLHS mult) opts nest env (IBindHere fc PATTERN lhs) Nothing logTerm 10 "Checked LHS term" lhstm lhsty <- getTerm lhstyg @@ -240,7 +240,7 @@ checkLHS {vars} mult hashit n opts nest env fc lhs_in lhsty <- normaliseHoles defs env lhsty linvars_in <- findLinear True 0 Rig1 lhstm logTerm 10 "Checked LHS term after normalise" lhstm - log 5 $ "Linearity of names in " ++ show n ++ ": " ++ + log 5 $ "Linearity of names in " ++ show n ++ ": " ++ show linvars_in linvars <- combineLinear fc linvars_in @@ -260,59 +260,59 @@ plicit (PVar _ p _) = p plicit _ = Explicit bindNotReq : {vs : _} -> - FC -> Int -> Env Term vs -> (sub : SubVars pre vs) -> + FC -> Int -> Env Term vs -> (sub : SubVars pre vs) -> List (PiInfo, Name) -> Term vs -> (List (PiInfo, Name), Term pre) bindNotReq fc i [] SubRefl ns tm = (ns, embed tm) -bindNotReq fc i (b :: env) SubRefl ns tm - = let tmptm = subst (Ref fc Bound (MN "arg" i)) tm +bindNotReq fc i (b :: env) SubRefl ns tm + = let tmptm = subst (Ref fc Bound (MN "arg" i)) tm (ns', btm) = bindNotReq fc (1 + i) env SubRefl ns tmptm in (ns', refToLocal (MN "arg" i) _ btm) -bindNotReq fc i (b :: env) (KeepCons p) ns tm - = let tmptm = subst (Ref fc Bound (MN "arg" i)) tm +bindNotReq fc i (b :: env) (KeepCons 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) (DropCons p) ns tm +bindNotReq {vs = n :: _} fc i (b :: env) (DropCons p) ns tm = bindNotReq fc i env p ((plicit b, n) :: ns) (Bind fc _ (Pi (multiplicity b) Explicit (binderType b)) tm) bindReq : {vs : _} -> - FC -> Env Term vs -> (sub : SubVars pre vs) -> + FC -> Env Term vs -> (sub : SubVars pre vs) -> List (PiInfo, Name) -> Term pre -> Maybe (List (PiInfo, Name), List Name, ClosedTerm) -bindReq {vs} fc env SubRefl ns tm +bindReq {vs} fc env SubRefl ns tm = pure (ns, notLets [] _ env, abstractEnvType fc env tm) where notLets : List Name -> (vars : List Name) -> Env Term vars -> List Name notLets acc [] _ = acc notLets acc (v :: vs) (Let _ _ _ :: env) = notLets acc vs env notLets acc (v :: vs) (_ :: env) = notLets (v :: acc) vs env -bindReq {vs = n :: _} fc (b :: env) (KeepCons p) ns tm +bindReq {vs = n :: _} fc (b :: env) (KeepCons p) ns tm = do b' <- shrinkBinder b p bindReq fc env p ((plicit b, n) :: ns) (Bind fc _ (Pi (multiplicity b) Explicit (binderType b')) tm) -bindReq fc (b :: env) (DropCons p) ns tm +bindReq fc (b :: env) (DropCons p) ns tm = bindReq fc env p ns tm -- Return whether any of the pattern variables are in a trivially empty -- type, where trivally empty means one of: -- * No constructors --- * Every constructor of the family has a return type which conflicts with +-- * Every constructor of the family has a return type which conflicts with -- the given constructor's type hasEmptyPat : Defs -> Env Term vars -> Term vars -> Core Bool hasEmptyPat defs env (Bind fc x (PVar c p ty) sc) - = pure $ !(isEmpty defs !(nf defs env ty)) + = pure $ !(isEmpty defs !(nf defs env ty)) || !(hasEmptyPat defs (PVar c p ty :: env) sc) hasEmptyPat defs env _ = pure False - + -- For checking with blocks as nested names applyEnv : {auto c : Ref Ctxt Defs} -> - Env Term vars -> Name -> + Env Term vars -> Name -> Core (Name, (Maybe Name, FC -> NameType -> Term vars)) applyEnv env withname = do n' <- resolveName withname - pure (withname, (Just withname, - \fc, nt => applyTo fc + pure (withname, (Just withname, + \fc, nt => applyTo fc (Ref fc nt (Resolved n')) env)) -- Check a pattern clause, returning the component of the 'Case' expression it @@ -335,15 +335,15 @@ checkClause mult hashit n opts nest env (ImpossibleClause fc lhs) log 5 $ "Checking " ++ show lhs logEnv 5 "In env" env - (lhstm, lhstyg) <- - elabTerm n (InLHS mult) opts nest env + (lhstm, lhstyg) <- + elabTerm n (InLHS mult) opts nest env (IBindHere fc PATTERN lhs) Nothing defs <- get Ctxt lhs <- normaliseHoles defs env lhstm if !(hasEmptyPat defs env lhs) then pure Nothing else throw (ValidCase fc env (Left lhs))) - (\err => + (\err => case err of ValidCase _ _ _ => throw err _ => do defs <- get Ctxt @@ -351,7 +351,7 @@ checkClause mult hashit n opts nest env (ImpossibleClause fc lhs) then pure Nothing else throw (ValidCase fc env (Right err))) checkClause {vars} mult hashit n opts nest env (PatClause fc lhs_in rhs) - = do (_, (vars' ** (sub', env', nest', lhstm', lhsty'))) <- + = do (_, (vars' ** (sub', env', nest', lhstm', lhsty'))) <- checkLHS mult hashit n opts nest env fc lhs_in let rhsMode = case mult of Rig0 => InType @@ -362,21 +362,21 @@ checkClause {vars} mult hashit n opts nest env (PatClause fc lhs_in rhs) clearHoleLHS logTerm 5 "RHS term" rhstm - when hashit $ + when hashit $ do addHash lhstm' addHash rhstm - -- If the rhs is a hole, record the lhs in the metadata because we + -- If the rhs is a hole, record the lhs in the metadata because we -- might want to split it interactively case rhstm of - Meta _ _ _ _ => + Meta _ _ _ _ => addLHS (getFC lhs_in) (length env) env' lhstm' _ => pure () pure (Just (MkClause env' lhstm' rhstm)) -- TODO: (to decide) With is complicated. Move this into its own module? checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs) - = do (lhs, (vars' ** (sub', env', nest', lhspat, reqty))) <- + = do (lhs, (vars' ** (sub', env', nest', lhspat, reqty))) <- checkLHS mult hashit n opts nest env fc lhs_in let wmode = case mult of @@ -386,7 +386,7 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs (wval, gwvalTy) <- wrapError (InRHS fc !(getFullName (Resolved n))) $ elabTermSub n wmode opts nest' env' env sub' wval_raw Nothing clearHoleLHS - + logTerm 5 "With value" wval logTerm 3 "Required type" reqty wvalTy <- getTerm gwvalTy @@ -418,7 +418,7 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs wtyScope <- replace defs scenv !(nf defs scenv (weaken wval)) (Local fc (Just False) _ First) - !(nf defs scenv + !(nf defs scenv (weaken {n=wargn} notreqty)) let bNotReq = Bind fc wargn (Pi RigW Explicit wvalTy) wtyScope @@ -428,11 +428,11 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs -- list of argument names - 'Just' means we need to match the name -- in the with clauses to find out what the pattern should be. -- 'Nothing' means it's the with pattern (so wargn) - let wargNames - = map Just reqns ++ + let wargNames + = map Just reqns ++ Nothing :: map Just notreqns - logTerm 3 "With function type" wtype + logTerm 3 "With function type" wtype log 5 $ "Argument names " ++ show wargNames wname <- genWithName n @@ -443,7 +443,7 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs log 3 $ "Applying to with argument " ++ show rhs_in rhs <- wrapError (InRHS fc !(getFullName (Resolved n))) $ - checkTermSub n wmode opts nest' env' env sub' rhs_in + checkTermSub n wmode opts nest' env' env sub' rhs_in (gnf env' reqty) -- Generate new clauses by rewriting the matched arguments @@ -478,12 +478,12 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs keepOldEnv (KeepCons p) (KeepCons p') = let (_ ** rest) = keepOldEnv p p' in (_ ** KeepCons rest) - + -- Rewrite the clauses in the block to use an updated LHS. -- 'drop' is the number of additional with arguments we expect (i.e. -- the things to drop from the end before matching LHSs) mkClauseWith : (drop : Nat) -> Name -> List (Maybe (PiInfo, Name)) -> - RawImp -> ImpClause -> + RawImp -> ImpClause -> Core ImpClause mkClauseWith drop wname wargnames lhs (PatClause ploc patlhs rhs) = do newlhs <- getNewLHS ploc drop nest wname wargnames lhs patlhs @@ -519,17 +519,17 @@ mkRunTime n let PMDef r cargs tree_ct _ pats = definition gdef | _ => pure () -- not a function definition let ty = type gdef - (rargs ** tree_rt) <- getPMDef (location gdef) RunTime n ty + (rargs ** tree_rt) <- getPMDef (location gdef) RunTime n ty !(traverse (toClause (location gdef)) pats) let Just Refl = nameListEq cargs rargs | Nothing => throw (InternalError "WAT") - addDef n (record { definition = PMDef r cargs tree_ct tree_rt pats + addDef n (record { definition = PMDef r cargs tree_ct tree_rt pats } gdef) pure () where toClause : FC -> (vars ** (Env Term vars, Term vars, Term vars)) -> Core Clause - toClause fc (_ ** (env, lhs, rhs)) + toClause fc (_ ** (env, lhs, rhs)) = do rhs_erased <- linearCheck fc Rig1 True env rhs pure $ MkClause env lhs rhs_erased @@ -565,7 +565,7 @@ calcRefs at fn traverse_ (calcRefs at) (keys refs) toPats : Clause -> (vs ** (Env Term vs, Term vs, Term vs)) -toPats (MkClause {vars} env lhs rhs) +toPats (MkClause {vars} env lhs rhs) = (_ ** (env, lhs, rhs)) export @@ -590,9 +590,9 @@ processDef opts nest env fc n_in cs_in cs <- traverse (checkClause mult hashit nidx opts nest env) cs_in let pats = map toPats (mapMaybe id cs) - (cargs ** tree_ct) <- getPMDef fc CompileTime n ty + (cargs ** tree_ct) <- getPMDef fc CompileTime n ty (mapMaybe id cs) - + logC 5 (do t <- toFullNames tree_ct pure ("Case tree for " ++ show n ++ ": " ++ show t)) @@ -645,10 +645,10 @@ processDef opts nest env fc n_in cs_in catchAll Nothing = False catchAll (Just (MkClause env lhs _)) = all simplePat (getArgs lhs) - + -- Return 'Nothing' if the clause is impossible, otherwise return the -- original - checkImpossible : Int -> RigCount -> ClosedTerm -> + checkImpossible : Int -> RigCount -> ClosedTerm -> Core (Maybe ClosedTerm) checkImpossible n mult tm = do itm <- unelabNoPatvars [] tm @@ -662,7 +662,7 @@ processDef opts nest env fc n_in cs_in (\err => case err of WhenUnifying _ env l r err => do defs <- get Ctxt - if !(impossibleOK defs !(nf defs env l) + if !(impossibleOK defs !(nf defs env l) !(nf defs env r)) then pure Nothing else pure (Just tm) @@ -676,8 +676,8 @@ processDef opts nest env fc n_in cs_in pure [] else getMissing fc (Resolved n) ctree logC 3 (do mc <- traverse toFullNames missCase - pure ("Initially missing in " ++ - show !(getFullName (Resolved n)) ++ ":\n" ++ + pure ("Initially missing in " ++ + show !(getFullName (Resolved n)) ++ ":\n" ++ showSep "\n" (map show mc))) missImp <- traverse (checkImpossible n mult) missCase let miss = mapMaybe id missImp diff --git a/src/TTImp/ProcessParams.idr b/src/TTImp/ProcessParams.idr index 31834d5..7c1413e 100644 --- a/src/TTImp/ProcessParams.idr +++ b/src/TTImp/ProcessParams.idr @@ -13,7 +13,7 @@ import TTImp.Elab.Check import TTImp.TTImp %default covering - + extend : Env Term extvs -> SubVars vs extvs -> NestedNames extvs -> Term extvs -> @@ -28,7 +28,7 @@ processParams : {vars : _} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> NestedNames vars -> - Env Term vars -> + Env Term vars -> FC -> List (Name, RawImp) -> List ImpDecl -> Core () processParams {vars} {c} {m} {u} nest env fc ps ds @@ -38,7 +38,7 @@ processParams {vars} {c} {m} {u} nest env fc ps ds let pty_raw = mkParamTy ps pty_imp <- bindTypeNames vars (IBindHere fc (PI Rig0) pty_raw) log 10 $ "Checking " ++ show pty_imp - pty <- checkTerm (-1) InType [] + pty <- checkTerm (-1) InType [] nest env pty_imp (gType fc) let (vs ** (prf, env', nest')) = extend env SubRefl nest pty @@ -53,13 +53,13 @@ processParams {vars} {c} {m} {u} nest env fc ps ds where mkParamTy : List (Name, RawImp) -> RawImp mkParamTy [] = IType fc - mkParamTy ((n, ty) :: ps) + mkParamTy ((n, ty) :: ps) = IPi fc RigW Explicit (Just n) ty (mkParamTy ps) - applyEnv : Env Term vs -> Name -> + applyEnv : Env Term vs -> Name -> Core (Name, (Maybe Name, FC -> NameType -> Term vs)) applyEnv env n = do n' <- resolveName n -- it'll be Resolved by expandAmbigName - pure (Resolved n', (Nothing, - \fc, nt => applyTo fc + pure (Resolved n', (Nothing, + \fc, nt => applyTo fc (Ref fc nt (Resolved n')) env)) diff --git a/src/TTImp/ProcessRecord.idr b/src/TTImp/ProcessRecord.idr index c54d5de..8c6ceeb 100644 --- a/src/TTImp/ProcessRecord.idr +++ b/src/TTImp/ProcessRecord.idr @@ -17,7 +17,7 @@ import TTImp.Utils mkDataTy : FC -> List (Name, RawImp) -> RawImp mkDataTy fc [] = IType fc -mkDataTy fc ((n, ty) :: ps) +mkDataTy fc ((n, ty) :: ps) = IPi fc RigW Explicit (Just n) ty (mkDataTy fc ps) mkCon : Name -> Name @@ -27,14 +27,14 @@ mkCon n = DN (show n) (MN ("__mk" ++ show n) 0) elabRecord : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - List ElabOpt -> FC -> Env Term vars -> + List ElabOpt -> FC -> Env Term vars -> NestedNames vars -> Visibility -> Name -> (params : List (Name, RawImp)) -> (conName : Maybe Name) -> List IField -> Core () -elabRecord {vars} eopts fc env nest vis tn params rcon fields +elabRecord {vars} eopts fc env nest vis tn params rcon fields = do let conName_in = maybe (mkCon tn) id rcon conName <- inCurrentNS conName_in elabAsData conName @@ -50,18 +50,18 @@ elabRecord {vars} eopts fc env nest vis tn params rcon fields fname : IField -> Name fname (MkIField fc c p n ty) = n - farg : IField -> + farg : IField -> (Maybe Name, RigCount, PiInfo, RawImp) farg (MkIField fc c p n ty) = (Just n, c, p, ty) - - mkTy : List (Maybe Name, RigCount, PiInfo, RawImp) -> + + mkTy : List (Maybe Name, RigCount, PiInfo, RawImp) -> RawImp -> RawImp mkTy [] ret = ret mkTy ((n, c, imp, argty) :: args) ret = IPi fc c imp n argty (mkTy args ret) elabAsData : Name -> Core () - elabAsData cname + elabAsData cname = do let retty = apply (IVar fc tn) (map (IVar fc) (map fst params)) let conty = mkTy (map jname params) $ mkTy (map farg fields) retty @@ -79,7 +79,7 @@ elabRecord {vars} eopts fc env nest vis tn params rcon fields countExp _ = 0 -- Generate getters from the elaborated record constructor type - elabGetters : Name -> RawImp -> + elabGetters : Name -> RawImp -> (done : Nat) -> -- number of explicit fields processed List (Name, RawImp) -> -- names to update in types -- (for dependent records, where a field's type may depend @@ -89,26 +89,26 @@ elabRecord {vars} eopts fc env nest vis tn params rcon fields elabGetters con recTy done upds tyenv (Bind bfc n b@(Pi rc imp ty_chk) sc) = if n `elem` map fst params then elabGetters con recTy - (if imp == Explicit + (if imp == Explicit then S done else done) upds (b :: tyenv) sc - else + else do let fldName = n gname <- inCurrentNS fldName ty <- unelab tyenv ty_chk let ty' = substNames vars upds ty let rname = MN "rec" 0 - gty <- bindTypeNames + gty <- bindTypeNames (map fst params ++ map fname fields ++ vars) $ mkTy (map jname params) $ IPi fc RigW Explicit (Just rname) recTy ty' log 5 $ "Projection " ++ show gname ++ " : " ++ show gty - let lhs_exp + let lhs_exp = apply (IVar fc con) (replicate done (Implicit fc True) ++ (if imp == Explicit then [IBindVar fc (nameRoot fldName)] - else []) ++ + else []) ++ (replicate (countExp sc) (Implicit fc True))) let lhs = IApp fc (IVar fc gname) (if imp == Explicit @@ -123,7 +123,7 @@ elabRecord {vars} eopts fc env nest vis tn params rcon fields (IDef fc gname [PatClause fc lhs (IVar fc fldName)]) let upds' = (n, IApp fc (IVar fc gname) (IVar fc rname)) :: upds elabGetters con recTy - (if imp == Explicit + (if imp == Explicit then S done else done) upds' (b :: tyenv) sc elabGetters con recTy done upds _ _ = pure () @@ -133,7 +133,7 @@ export processRecord : {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - List ElabOpt -> NestedNames vars -> + List ElabOpt -> NestedNames vars -> Env Term vars -> Visibility -> ImpRecord -> Core () processRecord eopts nest env vis (MkImpRecord fc n ps cons fs) diff --git a/src/TTImp/ProcessType.idr b/src/TTImp/ProcessType.idr index ab3e4ea..6efeb5a 100644 --- a/src/TTImp/ProcessType.idr +++ b/src/TTImp/ProcessType.idr @@ -25,12 +25,12 @@ getRetTy defs (NBind fc _ (Pi _ _ _) sc) = getRetTy defs !(sc defs (toClosure defaultOpts [] (Erased fc))) getRetTy defs (NTCon _ n _ _ _) = pure n getRetTy defs ty - = throw (GenericMsg (getLoc ty) + = throw (GenericMsg (getLoc ty) "Can only add hints for concrete return types") processFnOpt : {auto c : Ref Ctxt Defs} -> FC -> Name -> FnOpt -> Core () -processFnOpt fc ndef Inline +processFnOpt fc ndef Inline = setFlag fc ndef Inline processFnOpt fc ndef (Hint d) = do defs <- get Ctxt @@ -59,7 +59,7 @@ processFnOpt fc ndef PartialOK -- Similarly set foreign definitions. Possibly combine these? initDef : {auto c : Ref Ctxt Defs} -> Name -> Env Term vars -> Term vars -> List FnOpt -> Core Def -initDef n env ty [] +initDef n env ty [] = do addUserHole n pure None initDef n env ty (ExternFn :: opts) @@ -77,7 +77,7 @@ processType : {vars : _} -> {auto c : Ref Ctxt Defs} -> {auto m : Ref MD Metadata} -> {auto u : Ref UST UState} -> - List ElabOpt -> NestedNames vars -> Env Term vars -> + List ElabOpt -> NestedNames vars -> Env Term vars -> FC -> RigCount -> Visibility -> List FnOpt -> ImpTy -> Core () processType {vars} eopts nest env fc rig vis opts (MkImpTy tfc n_in ty_raw) @@ -86,17 +86,17 @@ processType {vars} eopts nest env fc rig vis opts (MkImpTy tfc n_in ty_raw) log 1 $ "Processing " ++ show n log 5 $ "Checking type decl " ++ show n ++ " : " ++ show ty_raw - idx <- resolveName n + idx <- resolveName n -- Check 'n' is undefined defs <- get Ctxt Nothing <- lookupCtxtExact (Resolved idx) (gamma defs) | Just _ => throw (AlreadyDefined fc n) - - ty <- + + ty <- wrapError (InType fc n) $ - checkTerm idx InType (HolesOkay :: eopts) nest env - (IBindHere fc (PI Rig0) ty_raw) + checkTerm idx InType (HolesOkay :: eopts) nest env + (IBindHere fc (PI Rig0) ty_raw) (gType fc) logTermNF 5 ("Type of " ++ show n) [] (abstractEnvType tfc env ty) -- TODO: Check name visibility @@ -105,10 +105,10 @@ processType {vars} eopts nest env fc rig vis opts (MkImpTy tfc n_in ty_raw) let fullty = abstractEnvType tfc env ty erased <- findErased fullty - addDef (Resolved idx) + addDef (Resolved idx) (record { eraseArgs = erased } (newDef fc n rig vars fullty vis def)) - -- Flag it as checked, because we're going to check the clauses + -- Flag it as checked, because we're going to check the clauses -- from the top level. -- But, if it's a case block, it'll be checked as part of the top -- level check so don't set the flag. diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index c4f0f06..ccea103 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -31,7 +31,7 @@ Weaken NestedNames where -- Unchecked terms, with implicit arguments -- This is the raw, elaboratable form. -- Higher level expressions (e.g. case, pattern matching let, where blocks, --- do notation, etc, should elaborate via this, perhaps in some local +-- do notation, etc, should elaborate via this, perhaps in some local -- context). mutual public export @@ -49,9 +49,9 @@ mutual (argTy : RawImp) -> (retTy : RawImp) -> RawImp ILam : FC -> RigCount -> PiInfo -> Maybe Name -> (argTy : RawImp) -> (lamTy : RawImp) -> RawImp - ILet : FC -> RigCount -> Name -> - (nTy : RawImp) -> (nVal : RawImp) -> - (scope : RawImp) -> RawImp + ILet : FC -> RigCount -> Name -> + (nTy : RawImp) -> (nVal : RawImp) -> + (scope : RawImp) -> RawImp ICase : FC -> RawImp -> (ty : RawImp) -> List ImpClause -> RawImp ILocal : FC -> List ImpDecl -> RawImp -> RawImp @@ -64,7 +64,7 @@ mutual ISearch : FC -> (depth : Nat) -> RawImp IAlternative : FC -> AltType -> List RawImp -> RawImp IRewrite : FC -> RawImp -> RawImp -> RawImp - ICoerced : FC -> RawImp -> RawImp + ICoerced : FC -> RawImp -> RawImp -- Any implicit bindings in the scope should be bound here, using -- the given binder @@ -81,14 +81,14 @@ mutual IDelayed : FC -> LazyReason -> RawImp -> RawImp -- the type IDelay : FC -> RawImp -> RawImp -- delay constructor IForce : FC -> RawImp -> RawImp - + IPrimVal : FC -> (c : Constant) -> RawImp IType : FC -> RawImp IHole : FC -> String -> RawImp -- An implicit value, solved by unification, but which will also be -- bound (either as a pattern variable or a type variable) if unsolved - -- at the end of elaborator + -- at the end of elaborator Implicit : FC -> (bindIfUnsolved : Bool) -> RawImp public export @@ -112,7 +112,7 @@ mutual = "(%lam " ++ show c ++ " " ++ show p ++ " " ++ show n ++ " " ++ show arg ++ " " ++ show sc ++ ")" show (ILet fc c n ty val sc) - = "(%let " ++ show c ++ " " ++ " " ++ show n ++ " " ++ show ty ++ + = "(%let " ++ show c ++ " " ++ " " ++ show n ++ " " ++ show ty ++ " " ++ show val ++ " " ++ show sc ++ ")" show (ICase _ scr scrty alts) = "(%case (" ++ show scr ++ ") " ++ show alts ++ ")" @@ -164,7 +164,7 @@ mutual GlobalHint : Bool -> FnOpt ExternFn : FnOpt -- Defined externally, list calling conventions - ForeignFn : List String -> FnOpt + ForeignFn : List String -> FnOpt -- assume safe to cancel arguments in unification Invertible : FnOpt Total : FnOpt @@ -218,7 +218,7 @@ mutual public export data ImpData : Type where MkImpData : FC -> (n : Name) -> (tycon : RawImp) -> - (opts : List DataOpt) -> + (opts : List DataOpt) -> (datacons : List ImpTy) -> ImpData MkImpLater : FC -> (n : Name) -> (tycon : RawImp) -> ImpData @@ -251,17 +251,17 @@ mutual export Show ImpRecord where show (MkImpRecord _ n params con fields) - = "record " ++ show n ++ " " ++ show params ++ - " " ++ show con ++ "\n\t" ++ + = "record " ++ show n ++ " " ++ show params ++ + " " ++ show con ++ "\n\t" ++ showSep "\n\t" (map show fields) ++ "\n" public export data ImpClause : Type where - PatClause : FC -> (lhs : RawImp) -> (rhs : RawImp) -> ImpClause + PatClause : FC -> (lhs : RawImp) -> (rhs : RawImp) -> ImpClause WithClause : FC -> (lhs : RawImp) -> (wval : RawImp) -> List ImpClause -> ImpClause ImpossibleClause : FC -> (lhs : RawImp) -> ImpClause - + export Show ImpClause where show (PatClause fc lhs rhs) @@ -278,15 +278,15 @@ mutual IData : FC -> Visibility -> ImpData -> ImpDecl IDef : FC -> Name -> List ImpClause -> ImpDecl IParameters : FC -> List (Name, RawImp) -> - List ImpDecl -> ImpDecl + List ImpDecl -> ImpDecl IRecord : FC -> Visibility -> ImpRecord -> ImpDecl - INamespace : FC -> - (nested : Bool) -> - -- ^ if True, parent namespaces in the same file can also + INamespace : FC -> + (nested : Bool) -> + -- ^ if True, parent namespaces in the same file can also -- look inside and see private/export names in full - List String -> List ImpDecl -> ImpDecl - IPragma : ({vars : _} -> Ref Ctxt Defs -> - NestedNames vars -> Env Term vars -> Core ()) -> + List String -> List ImpDecl -> ImpDecl + IPragma : ({vars : _} -> Ref Ctxt Defs -> + NestedNames vars -> Env Term vars -> Core ()) -> ImpDecl ILog : Nat -> ImpDecl @@ -295,12 +295,12 @@ mutual show (IClaim _ _ _ _ ty) = show ty show (IData _ _ d) = show d show (IDef _ n cs) = "(%def " ++ show n ++ " " ++ show cs ++ ")" - show (IParameters _ ps ds) + show (IParameters _ ps ds) = "parameters " ++ show ps ++ "\n\t" ++ showSep "\n\t" (assert_total $ map show ds) show (IRecord _ _ d) = show d - show (INamespace _ nest ns decls) - = "namespace " ++ if nest then "[nested] " else "" ++ show ns ++ + show (INamespace _ nest ns decls) + = "namespace " ++ if nest then "[nested] " else "" ++ show ns ++ showSep "\n" (assert_total $ map show decls) show (IPragma _) = "[externally defined pragma]" show (ILog lvl) = "%logging " ++ show lvl @@ -394,7 +394,7 @@ findImplicits (IDelay fc tm) = findImplicits tm findImplicits (IForce fc tm) = findImplicits tm findImplicits (IBindVar _ n) = [n] findImplicits tm = [] - + -- Update the lhs of a clause so that any implicits named in the type are -- bound as @-patterns (unless they're already explicitly bound or appear as -- IBindVar anywhere else in the pattern) so that they will be available on the @@ -432,15 +432,15 @@ implicitsAs defs ns tm = setAs (map Just (ns ++ map UN (findIBinds tm))) tm updateNs n [] = Nothing findImps : List (Maybe Name) -> NF [] -> Core (List (Name, PiInfo)) - findImps ns (NBind fc x (Pi _ Explicit _) sc) + findImps ns (NBind fc x (Pi _ Explicit _) sc) = findImps ns !(sc defs (toClosure defaultOpts [] (Erased fc))) -- if the implicit was given, skip it - findImps ns (NBind fc x (Pi _ AutoImplicit _) sc) + findImps ns (NBind fc x (Pi _ AutoImplicit _) sc) = case updateNs x ns of Nothing => -- didn't find explicit call pure $ (x, AutoImplicit) :: !(findImps ns !(sc defs (toClosure defaultOpts [] (Erased fc)))) Just ns' => findImps ns' !(sc defs (toClosure defaultOpts [] (Erased fc))) - findImps ns (NBind fc x (Pi _ p _) sc) + findImps ns (NBind fc x (Pi _ p _) sc) = if Just x `elem` ns then findImps ns !(sc defs (toClosure defaultOpts [] (Erased fc))) else pure $ (x, p) :: !(findImps ns !(sc defs (toClosure defaultOpts [] (Erased fc)))) @@ -448,12 +448,12 @@ implicitsAs defs ns tm = setAs (map Just (ns ++ map UN (findIBinds tm))) tm impAs : FC -> List (Name, PiInfo) -> RawImp -> RawImp impAs loc' [] tm = tm - impAs loc' ((UN n, AutoImplicit) :: ns) tm + impAs loc' ((UN n, AutoImplicit) :: ns) tm = impAs loc' ns $ IImplicitApp loc' tm (Just (UN n)) (IBindVar loc' n) - impAs loc' ((n, Implicit) :: ns) tm + impAs loc' ((n, Implicit) :: ns) tm = impAs loc' ns $ - IImplicitApp loc' tm (Just n) + IImplicitApp loc' tm (Just n) (IAs loc' UseLeft n (Implicit loc' True)) impAs loc' (_ :: ns) tm = impAs loc' ns tm setAs is tm = pure tm @@ -529,34 +529,34 @@ mutual export TTC RawImp where toBuf b (IVar fc n) = do tag 0; toBuf b fc; toBuf b n - toBuf b (IPi fc r p n argTy retTy) + toBuf b (IPi fc r p n argTy retTy) = do tag 1; toBuf b fc; toBuf b r; toBuf b p; toBuf b n toBuf b argTy; toBuf b retTy - toBuf b (ILam fc r p n argTy scope) + toBuf b (ILam fc r p n argTy scope) = do tag 2; toBuf b fc; toBuf b r; toBuf b p; toBuf b n; toBuf b argTy; toBuf b scope - toBuf b (ILet fc r n nTy nVal scope) - = do tag 3; toBuf b fc; toBuf b r; toBuf b n; + toBuf b (ILet fc r n nTy nVal scope) + = do tag 3; toBuf b fc; toBuf b r; toBuf b n; toBuf b nTy; toBuf b nVal; toBuf b scope - toBuf b (ICase fc y ty xs) + toBuf b (ICase fc y ty xs) = do tag 4; toBuf b fc; toBuf b y; toBuf b ty; toBuf b xs - toBuf b (ILocal fc xs sc) + toBuf b (ILocal fc xs sc) = do tag 5; toBuf b fc; toBuf b xs; toBuf b sc - toBuf b (IUpdate fc fs rec) + toBuf b (IUpdate fc fs rec) = do tag 6; toBuf b fc; toBuf b fs; toBuf b rec - toBuf b (IApp fc fn arg) + toBuf b (IApp fc fn arg) = do tag 7; toBuf b fc; toBuf b fn; toBuf b arg - toBuf b (IImplicitApp fc fn y arg) + toBuf b (IImplicitApp fc fn y arg) = do tag 8; toBuf b fc; toBuf b fn; toBuf b y; toBuf b arg - toBuf b (IWithApp fc fn arg) + toBuf b (IWithApp fc fn arg) = do tag 9; toBuf b fc; toBuf b fn; toBuf b arg - toBuf b (ISearch fc depth) + toBuf b (ISearch fc depth) = do tag 10; toBuf b fc; toBuf b depth - toBuf b (IAlternative fc y xs) + toBuf b (IAlternative fc y xs) = do tag 11; toBuf b fc; toBuf b y; toBuf b xs - toBuf b (IRewrite fc x y) + toBuf b (IRewrite fc x y) = do tag 12; toBuf b fc; toBuf b x; toBuf b y - toBuf b (ICoerced fc y) + toBuf b (ICoerced fc y) = do tag 13; toBuf b fc; toBuf b y toBuf b (IBindHere fc m y) @@ -591,7 +591,7 @@ mutual 0 => do fc <- fromBuf b; n <- fromBuf b; pure (IVar fc n) 1 => do fc <- fromBuf b; - r <- fromBuf b; p <- fromBuf b; + r <- fromBuf b; p <- fromBuf b; n <- fromBuf b argTy <- fromBuf b; retTy <- fromBuf b pure (IPi fc r p n argTy retTy) @@ -661,7 +661,7 @@ mutual i <- fromBuf b pure (Implicit fc i) _ => corrupt "RawImp" - + export TTC IFieldUpdate where toBuf b (ISetField p val) @@ -715,10 +715,10 @@ mutual 2 => do x <- fromBuf b pure (UniqueDefault x) _ => corrupt "AltType" - + export TTC ImpTy where - toBuf b (MkImpTy fc n ty) + toBuf b (MkImpTy fc n ty) = do toBuf b fc; toBuf b n; toBuf b ty fromBuf b = do fc <- fromBuf b; n <- fromBuf b; ty <- fromBuf b @@ -726,28 +726,28 @@ mutual export TTC ImpClause where - toBuf b (PatClause fc lhs rhs) + toBuf b (PatClause fc lhs rhs) = do tag 0; toBuf b fc; toBuf b lhs; toBuf b rhs - toBuf b (ImpossibleClause fc lhs) + toBuf b (ImpossibleClause fc lhs) = do tag 1; toBuf b fc; toBuf b lhs - toBuf b (WithClause fc lhs wval cs) + toBuf b (WithClause fc lhs wval cs) = do tag 2; toBuf b fc; toBuf b lhs; toBuf b wval; toBuf b cs fromBuf b = case !getTag of - 0 => do fc <- fromBuf b; lhs <- fromBuf b; + 0 => do fc <- fromBuf b; lhs <- fromBuf b; rhs <- fromBuf b pure (PatClause fc lhs rhs) - 1 => do fc <- fromBuf b; lhs <- fromBuf b; + 1 => do fc <- fromBuf b; lhs <- fromBuf b; pure (ImpossibleClause fc lhs) - 2 => do fc <- fromBuf b; lhs <- fromBuf b; + 2 => do fc <- fromBuf b; lhs <- fromBuf b; wval <- fromBuf b; cs <- fromBuf b pure (WithClause fc lhs wval cs) _ => corrupt "ImpClause" export TTC DataOpt where - toBuf b (SearchBy ns) + toBuf b (SearchBy ns) = do tag 0; toBuf b ns toBuf b NoHints = tag 1 @@ -760,10 +760,10 @@ mutual export TTC ImpData where - toBuf b (MkImpData fc n tycon opts cons) + toBuf b (MkImpData fc n tycon opts cons) = do tag 0; toBuf b fc; toBuf b n; toBuf b tycon; toBuf b opts toBuf b cons - toBuf b (MkImpLater fc n tycon) + toBuf b (MkImpLater fc n tycon) = do tag 1; toBuf b fc; toBuf b n; toBuf b tycon fromBuf b @@ -824,20 +824,20 @@ mutual export TTC ImpDecl where - toBuf b (IClaim fc c vis xs d) + toBuf b (IClaim fc c vis xs d) = do tag 0; toBuf b fc; toBuf b c; toBuf b vis; toBuf b xs; toBuf b d - toBuf b (IData fc vis d) + toBuf b (IData fc vis d) = do tag 1; toBuf b fc; toBuf b vis; toBuf b d - toBuf b (IDef fc n xs) + toBuf b (IDef fc n xs) = do tag 2; toBuf b fc; toBuf b n; toBuf b xs - toBuf b (IParameters fc vis d) + toBuf b (IParameters fc vis d) = do tag 3; toBuf b fc; toBuf b vis; toBuf b d - toBuf b (IRecord fc vis r) + toBuf b (IRecord fc vis r) = do tag 4; toBuf b fc; toBuf b vis; toBuf b r - toBuf b (INamespace fc n xs ds) + toBuf b (INamespace fc n xs ds) = do tag 5; toBuf b fc; toBuf b n; toBuf b xs; toBuf b ds toBuf b (IPragma f) = throw (InternalError "Can't write Pragma") - toBuf b (ILog n) + toBuf b (ILog n) = do tag 6; toBuf b n fromBuf b diff --git a/src/TTImp/Unelab.idr b/src/TTImp/Unelab.idr index 134dfdb..5a1a93a 100644 --- a/src/TTImp/Unelab.idr +++ b/src/TTImp/Unelab.idr @@ -70,7 +70,7 @@ mutual = case getFnArgs tm of (f, as) => idxOrDefault n f as - nthArg : FC -> Nat -> Term vars -> Term vars + nthArg : FC -> Nat -> Term vars -> Term vars nthArg fc drop (App afc f a) = getNth drop (App afc f a) nthArg fc drop tm = Erased fc @@ -97,7 +97,7 @@ mutual Core (RawImp, Glued vars) unelabSugar NoSugar res = pure res unelabSugar ImplicitHoles res = pure res - unelabSugar _ (tm, ty) + unelabSugar _ (tm, ty) = let (f, args) = getFnArgs tm [] in case f of IVar fc (NS ns (CaseBlock n i)) @@ -110,22 +110,22 @@ mutual getFnArgs tm args = (tm, args) -- Turn a term back into an unannotated TTImp. Returns the type of the - -- unelaborated term so that we can work out where to put the implicit + -- unelaborated term so that we can work out where to put the implicit -- applications -- NOTE: There is *no guarantee* that this will elaborate back successfully! -- It's only intended for display unelabTy : {auto c : Ref Ctxt Defs} -> (umode : UnelabMode) -> - Env Term vars -> Term vars -> + Env Term vars -> Term vars -> Core (RawImp, Glued vars) - unelabTy umode env tm + unelabTy umode env tm = unelabSugar umode !(unelabTy' umode env tm) unelabTy' : {auto c : Ref Ctxt Defs} -> (umode : UnelabMode) -> - Env Term vars -> Term vars -> + Env Term vars -> Term vars -> Core (RawImp, Glued vars) - unelabTy' umode env (Local {name} fc _ idx p) + unelabTy' umode env (Local {name} fc _ idx p) = pure (IVar fc name, gnf env (binderType (getBinder p env))) unelabTy' umode env (Ref fc nt n) = do defs <- get Ctxt @@ -152,7 +152,7 @@ mutual case fnty of NBind _ x (Pi rig Explicit ty) sc => do sc' <- sc defs (toClosure defaultOpts env arg) - pure (IApp fc fn' arg', + pure (IApp fc fn' arg', glueBack defs env sc') NBind _ x (Pi rig p ty) sc => do sc' <- sc defs (toClosure defaultOpts env arg) @@ -160,10 +160,10 @@ mutual glueBack defs env sc') _ => pure (IApp fc fn' arg', gErased fc) unelabTy' umode env (As fc p tm) - = do (p', _) <- unelabTy' umode env p + = do (p', _) <- unelabTy' umode env p (tm', ty) <- unelabTy' umode env tm case p' of - IVar _ n => + IVar _ n => case umode of NoSugar => pure (IAs fc UseRight n tm', ty) _ => pure (tm', ty) @@ -183,26 +183,26 @@ mutual unelabTy' umode env (PrimVal fc c) = pure (IPrimVal fc c, gErased fc) unelabTy' umode env (Erased fc) = pure (Implicit fc False, gErased fc) unelabTy' umode env (TType fc) = pure (IType fc, gType fc) - unelabTy' umode _ tm - = let fc = getLoc tm in + unelabTy' umode _ tm + = let fc = getLoc tm in pure (Implicit fc False, gErased fc) unelabBinder : {auto c : Ref Ctxt Defs} -> (umode : UnelabMode) -> FC -> Env Term vars -> (x : Name) -> Binder (Term vars) -> Term (x :: vars) -> - RawImp -> Term (x :: vars) -> + RawImp -> Term (x :: vars) -> Core (RawImp, Glued vars) unelabBinder umode fc env x (Lam rig p ty) sctm sc scty = do (ty', _) <- unelabTy umode env ty - pure (ILam fc rig p (Just x) ty' sc, + pure (ILam fc rig p (Just x) ty' sc, gnf env (Bind fc x (Pi rig p ty) scty)) unelabBinder umode fc env x (Let rig val ty) sctm sc scty = do (val', vty) <- unelabTy umode env val (ty', _) <- unelabTy umode env ty - pure (ILet fc rig x ty' val' sc, + pure (ILet fc rig x ty' val' sc, gnf env (Bind fc x (Let rig val ty) scty)) - unelabBinder umode fc env x (Pi rig p ty) sctm sc scty + unelabBinder umode fc env x (Pi rig p ty) sctm sc scty = do (ty', _) <- unelabTy umode env ty let nm = if used 0 sctm || rig /= RigW then Just x else Nothing @@ -213,7 +213,7 @@ mutual unelabBinder umode fc env x (PLet rig val ty) sctm sc scty = do (val', vty) <- unelabTy umode env val (ty', _) <- unelabTy umode env ty - pure (ILet fc rig x ty' val' sc, + pure (ILet fc rig x ty' val' sc, gnf env (Bind fc x (PLet rig val ty) scty)) unelabBinder umode fc env x (PVTy rig ty) sctm sc scty = do (ty', _) <- unelabTy umode env ty diff --git a/src/TTImp/Utils.idr b/src/TTImp/Utils.idr index 05e9c55..44b6792 100644 --- a/src/TTImp/Utils.idr +++ b/src/TTImp/Utils.idr @@ -61,43 +61,43 @@ findBindableNames arg env used tm = [] mutual export - substNames : List Name -> List (Name, RawImp) -> + substNames : List Name -> List (Name, RawImp) -> RawImp -> RawImp - substNames bound ps (IVar fc n) + substNames bound ps (IVar fc n) = if not (n `elem` bound) then case lookup n ps of Just t => t _ => IVar fc n else IVar fc n - substNames bound ps (IPi fc r p mn argTy retTy) + substNames bound ps (IPi fc r p mn argTy retTy) = let bound' = maybe bound (\n => n :: bound) mn in - IPi fc r p mn (substNames bound ps argTy) + IPi fc r p mn (substNames bound ps argTy) (substNames bound' ps retTy) substNames bound ps (ILam fc r p mn argTy scope) = let bound' = maybe bound (\n => n :: bound) mn in - ILam fc r p mn (substNames bound ps argTy) + ILam fc r p mn (substNames bound ps argTy) (substNames bound' ps scope) substNames bound ps (ILet fc r n nTy nVal scope) = let bound' = n :: bound in - ILet fc r n (substNames bound ps nTy) + ILet fc r n (substNames bound ps nTy) (substNames bound ps nVal) (substNames bound' ps scope) - substNames bound ps (ICase fc y ty xs) + substNames bound ps (ICase fc y ty xs) = ICase fc (substNames bound ps y) (substNames bound ps ty) (map (substNamesClause bound ps) xs) - substNames bound ps (ILocal fc xs y) + substNames bound ps (ILocal fc xs y) = let bound' = definedInBlock [] xs ++ bound in - ILocal fc (map (substNamesDecl bound ps) xs) + ILocal fc (map (substNamesDecl bound ps) xs) (substNames bound' ps y) - substNames bound ps (IApp fc fn arg) + substNames bound ps (IApp fc fn arg) = IApp fc (substNames bound ps fn) (substNames bound ps arg) substNames bound ps (IImplicitApp fc fn y arg) = IImplicitApp fc (substNames bound ps fn) y (substNames bound ps arg) - substNames bound ps (IWithApp fc fn arg) + substNames bound ps (IWithApp fc fn arg) = IWithApp fc (substNames bound ps fn) (substNames bound ps arg) - substNames bound ps (IAlternative fc y xs) + substNames bound ps (IAlternative fc y xs) = IAlternative fc y (map (substNames bound ps) xs) - substNames bound ps (ICoerced fc y) + substNames bound ps (ICoerced fc y) = ICoerced fc (substNames bound ps y) substNames bound ps (IAs fc s y pattern) = IAs fc s y (substNames bound ps pattern) @@ -112,43 +112,43 @@ mutual substNames bound ps tm = tm export - substNamesClause : List Name -> List (Name, RawImp) -> - ImpClause -> ImpClause + substNamesClause : List Name -> List (Name, RawImp) -> + ImpClause -> ImpClause substNamesClause bound ps (PatClause fc lhs rhs) = let bound' = map UN (map snd (findBindableNames True bound [] lhs)) ++ bound in - PatClause fc (substNames [] [] lhs) + PatClause fc (substNames [] [] lhs) (substNames bound' ps rhs) substNamesClause bound ps (WithClause fc lhs wval cs) = let bound' = map UN (map snd (findBindableNames True bound [] lhs)) ++ bound in - WithClause fc (substNames [] [] lhs) + WithClause fc (substNames [] [] lhs) (substNames bound' ps wval) cs substNamesClause bound ps (ImpossibleClause fc lhs) = ImpossibleClause fc (substNames bound [] lhs) substNamesTy : List Name -> List (Name, RawImp) -> ImpTy -> ImpTy - substNamesTy bound ps (MkImpTy fc n ty) + substNamesTy bound ps (MkImpTy fc n ty) = MkImpTy fc n (substNames bound ps ty) - + substNamesData : List Name -> List (Name, RawImp) -> ImpData -> ImpData - substNamesData bound ps (MkImpData fc n con opts dcons) + substNamesData bound ps (MkImpData fc n con opts dcons) = MkImpData fc n (substNames bound ps con) opts (map (substNamesTy bound ps) dcons) - substNamesData bound ps (MkImpLater fc n con) + substNamesData bound ps (MkImpLater fc n con) = MkImpLater fc n (substNames bound ps con) substNamesDecl : List Name -> List (Name, RawImp ) -> - ImpDecl -> ImpDecl - substNamesDecl bound ps (IClaim fc r vis opts td) + ImpDecl -> ImpDecl + substNamesDecl bound ps (IClaim fc r vis opts td) = IClaim fc r vis opts (substNamesTy bound ps td) - substNamesDecl bound ps (IDef fc n cs) + substNamesDecl bound ps (IDef fc n cs) = IDef fc n (map (substNamesClause bound ps) cs) - substNamesDecl bound ps (IData fc vis d) + substNamesDecl bound ps (IData fc vis d) = IData fc vis (substNamesData bound ps d) - substNamesDecl bound ps (INamespace fc nest ns ds) + substNamesDecl bound ps (INamespace fc nest ns ds) = INamespace fc nest ns (map (substNamesDecl bound ps) ds) substNamesDecl bound ps d = d @@ -156,31 +156,31 @@ mutual export substLoc : FC -> RawImp -> RawImp substLoc fc' (IVar fc n) = IVar fc' n - substLoc fc' (IPi fc r p mn argTy retTy) - = IPi fc' r p mn (substLoc fc' argTy) + substLoc fc' (IPi fc r p mn argTy retTy) + = IPi fc' r p mn (substLoc fc' argTy) (substLoc fc' retTy) substLoc fc' (ILam fc r p mn argTy scope) - = ILam fc' r p mn (substLoc fc' argTy) + = ILam fc' r p mn (substLoc fc' argTy) (substLoc fc' scope) substLoc fc' (ILet fc r n nTy nVal scope) - = ILet fc' r n (substLoc fc' nTy) + = ILet fc' r n (substLoc fc' nTy) (substLoc fc' nVal) (substLoc fc' scope) - substLoc fc' (ICase fc y ty xs) + substLoc fc' (ICase fc y ty xs) = ICase fc' (substLoc fc' y) (substLoc fc' ty) (map (substLocClause fc') xs) - substLoc fc' (ILocal fc xs y) - = ILocal fc' (map (substLocDecl fc') xs) + substLoc fc' (ILocal fc xs y) + = ILocal fc' (map (substLocDecl fc') xs) (substLoc fc' y) - substLoc fc' (IApp fc fn arg) + substLoc fc' (IApp fc fn arg) = IApp fc' (substLoc fc' fn) (substLoc fc' arg) substLoc fc' (IImplicitApp fc fn y arg) = IImplicitApp fc' (substLoc fc' fn) y (substLoc fc' arg) - substLoc fc' (IWithApp fc fn arg) + substLoc fc' (IWithApp fc fn arg) = IWithApp fc' (substLoc fc' fn) (substLoc fc' arg) - substLoc fc' (IAlternative fc y xs) + substLoc fc' (IAlternative fc y xs) = IAlternative fc' y (map (substLoc fc') xs) - substLoc fc' (ICoerced fc y) + substLoc fc' (ICoerced fc y) = ICoerced fc' (substLoc fc' y) substLoc fc' (IAs fc s y pattern) = IAs fc' s y (substLoc fc' pattern) @@ -197,7 +197,7 @@ mutual export substLocClause : FC -> ImpClause -> ImpClause substLocClause fc' (PatClause fc lhs rhs) - = PatClause fc' (substLoc fc' lhs) + = PatClause fc' (substLoc fc' lhs) (substLoc fc' rhs) substLocClause fc' (WithClause fc lhs wval cs) = WithClause fc' (substLoc fc' lhs) @@ -207,24 +207,24 @@ mutual = ImpossibleClause fc' (substLoc fc' lhs) substLocTy : FC -> ImpTy -> ImpTy - substLocTy fc' (MkImpTy fc n ty) + substLocTy fc' (MkImpTy fc n ty) = MkImpTy fc' n (substLoc fc' ty) - + substLocData : FC -> ImpData -> ImpData - substLocData fc' (MkImpData fc n con opts dcons) + substLocData fc' (MkImpData fc n con opts dcons) = MkImpData fc' n (substLoc fc' con) opts (map (substLocTy fc') dcons) - substLocData fc' (MkImpLater fc n con) + substLocData fc' (MkImpLater fc n con) = MkImpLater fc' n (substLoc fc' con) substLocDecl : FC -> ImpDecl -> ImpDecl - substLocDecl fc' (IClaim fc r vis opts td) + substLocDecl fc' (IClaim fc r vis opts td) = IClaim fc' r vis opts (substLocTy fc' td) - substLocDecl fc' (IDef fc n cs) + substLocDecl fc' (IDef fc n cs) = IDef fc' n (map (substLocClause fc') cs) - substLocDecl fc' (IData fc vis d) + substLocDecl fc' (IData fc vis d) = IData fc' vis (substLocData fc' d) - substLocDecl fc' (INamespace fc nest ns ds) + substLocDecl fc' (INamespace fc nest ns ds) = INamespace fc' nest ns (map (substLocDecl fc') ds) substLocDecl fc' d = d @@ -240,17 +240,17 @@ nameNum str export uniqueName : Defs -> List String -> String -> Core String uniqueName defs used n - = if !usedName + = if !usedName then uniqueName defs used (next n) else pure n where usedName : Core Bool - usedName + usedName = case !(lookupTyName (UN n) (gamma defs)) of [] => pure $ n `elem` used _ => pure True next : String -> String - next str + next str = let (n, i) = nameNum str in n ++ "_" ++ show (i + 1) diff --git a/src/Text/Lexer.idr b/src/Text/Lexer.idr index f2f0b0f..3c337c0 100644 --- a/src/Text/Lexer.idr +++ b/src/Text/Lexer.idr @@ -145,7 +145,7 @@ count (Qty (S min) (Just (S max))) l = l <+> count (between min max) l digit : Lexer digit = pred isDigit -||| Recognise one or more digits +||| Recognise one or more digits ||| /[0-9]+/ digits : Lexer digits = some digit diff --git a/src/Text/Lexer/Core.idr b/src/Text/Lexer/Core.idr index e2e81d5..4616252 100644 --- a/src/Text/Lexer/Core.idr +++ b/src/Text/Lexer/Core.idr @@ -191,13 +191,13 @@ tokenise pred line col acc tmap str ||| string where there are no recognised tokens. export lex : TokenMap a -> String -> (List (TokenData a), (Int, Int, String)) -lex tmap str +lex tmap str = let (ts, (l, c, str')) = tokenise (const False) 0 0 [] tmap (mkStr str) in (ts, (l, c, getString str')) export lexTo : (TokenData a -> Bool) -> TokenMap a -> String -> (List (TokenData a), (Int, Int, String)) -lexTo pred tmap str +lexTo pred tmap str = let (ts, (l, c, str')) = tokenise pred 0 0 [] tmap (mkStr str) in (ts, (l, c, getString str')) diff --git a/src/Text/Parser/Core.idr b/src/Text/Parser/Core.idr index 266a87f..bebb77c 100644 --- a/src/Text/Parser/Core.idr +++ b/src/Text/Parser/Core.idr @@ -212,20 +212,20 @@ doParse com xs (MustWork g) = Failure com' _ msg ts => Failure com' True msg ts res => res doParse com [] (Terminal err f) = Failure com False "End of input" [] -doParse com (x :: xs) (Terminal err f) +doParse com (x :: xs) (Terminal err f) = maybe (Failure com False err (x :: xs)) (\a => NonEmptyRes com {xs=[]} a xs) (f x) doParse com [] EOF = EmptyRes com () [] -doParse com (x :: xs) EOF +doParse com (x :: xs) EOF = Failure com False "Expected end of input" (x :: xs) doParse com [] (NextIs err f) = Failure com False "End of input" [] -doParse com (x :: xs) (NextIs err f) +doParse com (x :: xs) (NextIs err f) = if f x then EmptyRes com x (x :: xs) else Failure com False err (x :: xs) -doParse com xs (Alt x y) +doParse com xs (Alt x y) = let p' = doParse False xs x in case p' of Failure com' fatal msg ts diff --git a/src/Utils/Binary.idr b/src/Utils/Binary.idr index 3366470..eac5fac 100644 --- a/src/Utils/Binary.idr +++ b/src/Utils/Binary.idr @@ -16,7 +16,7 @@ import Data.Vect %default covering -- A label for binary states -export +export data Bin : Type where -- A label for storing resolved name ids @@ -41,7 +41,7 @@ avail : Binary -> Int avail c = (size c - loc c) - 1 toRead : Binary -> Int -toRead c = used c - loc c +toRead c = used c - loc c appended : Int -> Binary -> Binary appended i (MkBin b loc s used) = MkBin b (loc+i) s (used + i) @@ -114,7 +114,7 @@ initBinaryS s extendBinary : Int -> Binary -> Core Binary extendBinary need (MkBin buf l s u) = do let newsize = s * 2 - let s' = if newsize < need + let s' = if newsize < need then newsize + need else newsize Just buf' <- coreLift $ resizeBuffer buf s' @@ -130,7 +130,7 @@ corrupt ty = throw (TTCError (Corrupt ty)) export TTC Bits8 where - toBuf b val + toBuf b val = do chunk <- get Bin if avail chunk >= 1 then @@ -164,14 +164,14 @@ TTC Int where toBuf b val = do chunk <- get Bin if avail chunk >= 4 - then + then do coreLift $ setInt (buf chunk) (loc chunk) val put Bin (appended 4 chunk) else do chunk' <- extendBinary 4 chunk coreLift $ setInt (buf chunk') (loc chunk') val put Bin (appended 4 chunk') - fromBuf b + fromBuf b = do chunk <- get Bin if toRead chunk >= 4 then @@ -199,7 +199,7 @@ TTC String where coreLift $ setString (buf chunk') (loc chunk') val put Bin (appended req chunk') - fromBuf b + fromBuf b = do len <- fromBuf {a = Int} b chunk <- get Bin if toRead chunk >= len @@ -207,7 +207,7 @@ TTC String where do val <- coreLift $ getString (buf chunk) (loc chunk) len put Bin (incLoc len chunk) pure val - else throw (TTCError (EndOfBuffer ("String length " ++ show len ++ + else throw (TTCError (EndOfBuffer ("String length " ++ show len ++ " at " ++ show (loc chunk)))) export @@ -261,14 +261,14 @@ TTC Double where toBuf b val = do chunk <- get Bin if avail chunk >= 8 - then + then do coreLift $ setDouble (buf chunk) (loc chunk) val put Bin (appended 8 chunk) else do chunk' <- extendBinary 8 chunk coreLift $ setDouble (buf chunk') (loc chunk') val put Bin (appended 8 chunk') - fromBuf b + fromBuf b = do chunk <- get Bin if toRead chunk >= 8 then @@ -340,7 +340,7 @@ TTC a => TTC (List a) where toBuf b xs = do toBuf b (cast {to=Int} (length xs)) traverse_ (toBuf b) xs - fromBuf b + fromBuf b = do len <- fromBuf b {a = Int} readElems [] (cast len) where @@ -361,7 +361,7 @@ TTC a => TTC (Vect n a) where fromBuf {n} b = rewrite sym (plusZeroRightNeutral n) in readElems [] n where readElems : Vect done a -> (todo : Nat) -> Core (Vect (todo + done) a) - readElems {done} xs Z + readElems {done} xs Z = pure (reverse xs) readElems {done} xs (S k) = do val <- fromBuf b @@ -374,7 +374,7 @@ count (There p) = 1 + count p toLimbs : Integer -> List Int toLimbs x - = if x == 0 + = if x == 0 then [] else if x == -1 then [-1] else fromInteger (prim__andBigInt x 0xffffffff) :: @@ -392,7 +392,7 @@ TTC Integer where toBuf b (toLimbs (-val)) else do toBuf b (the Bits8 1) toBuf b (toLimbs val) - fromBuf b + fromBuf b = do val <- fromBuf b {a = Bits8} case val of 0 => do val <- fromBuf b @@ -404,6 +404,6 @@ TTC Integer where export TTC Nat where toBuf b val = toBuf b (cast {to=Integer} val) - fromBuf b + fromBuf b = do val <- fromBuf b pure (fromInteger val) diff --git a/src/Utils/Shunting.idr b/src/Utils/Shunting.idr index 8d9d827..78cd784 100644 --- a/src/Utils/Shunting.idr +++ b/src/Utils/Shunting.idr @@ -12,13 +12,13 @@ import Core.FC -- Precedences/associativities public export -data OpPrec +data OpPrec = AssocL Nat | AssocR Nat | NonAssoc Nat | Prefix Nat --- Tokens are either operators or already parsed expressions in some +-- Tokens are either operators or already parsed expressions in some -- higher level language public export data Tok op a = Op FC op OpPrec @@ -58,7 +58,7 @@ export -- Label for the output queue state data Out : Type where -output : List (Tree op a) -> Tok op a -> +output : List (Tree op a) -> Tok op a -> Core (List (Tree op a)) output [] (Op _ _ _) = throw (InternalError "Invalid input to shunting") output (x :: stk) (Op loc str (Prefix _)) = pure $ Pre loc str x :: stk @@ -66,7 +66,7 @@ output (x :: y :: stk) (Op loc str _) = pure $ Inf loc str y x :: stk output stk (Expr a) = pure $ Leaf a :: stk output _ _ = throw (InternalError "Invalid input to shunting") -emit : {auto o : Ref Out (List (Tree op a))} -> +emit : {auto o : Ref Out (List (Tree op a))} -> Tok op a -> Core () emit t = do out <- get Out @@ -83,20 +83,20 @@ isLAssoc (AssocL _) = True isLAssoc _ = False -- Return whether the first operator should be applied before the second, --- assuming +-- assuming higher : Show op => FC -> op -> OpPrec -> op -> OpPrec -> Core Bool higher loc opx op opy (Prefix p) = pure False higher loc opx (NonAssoc x) opy oy = if x == getPrec oy - then throw (GenericMsg loc ("Operator '" ++ show opx ++ + then throw (GenericMsg loc ("Operator '" ++ show opx ++ "' is non-associative")) else pure (x > getPrec oy) higher loc opx ox opy (NonAssoc y) = if getPrec ox == y - then throw (GenericMsg loc ("Operator '" ++ show opy ++ + then throw (GenericMsg loc ("Operator '" ++ show opy ++ "' is non-associative")) else pure (getPrec ox > y) -higher loc opl l opr r +higher loc opl l opr r = pure $ (getPrec l > getPrec r) || ((getPrec l == getPrec r) && isLAssoc l) @@ -104,22 +104,22 @@ processStack : Show op => {auto o : Ref Out (List (Tree op a))} -> List (FC, op, OpPrec) -> op -> OpPrec -> Core (List (FC, op, OpPrec)) processStack [] op prec = pure [] -processStack ((loc, opx, sprec) :: xs) opy prec +processStack ((loc, opx, sprec) :: xs) opy prec = if !(higher loc opx sprec opy prec) then do emit (Op loc opx sprec) processStack xs opy prec else pure ((loc, opx, sprec) :: xs) shunt : Show op => {auto o : Ref Out (List (Tree op a))} -> - (opstk : List (FC, op, OpPrec)) -> + (opstk : List (FC, op, OpPrec)) -> List (Tok op a) -> Core (Tree op a) shunt stk (Expr x :: rest) = do emit (Expr x) shunt stk rest -shunt stk (Op loc op prec :: rest) +shunt stk (Op loc op prec :: rest) = do stk' <- processStack stk op prec shunt ((loc, op, prec) :: stk') rest -shunt stk [] +shunt stk [] = do traverse (\s => emit (Op (sloc s) (sop s) (sprec s))) stk [out] <- get Out | out => throw (InternalError "Invalid input to shunting") @@ -131,9 +131,9 @@ shunt stk [] sop (x, y, z) = y sprec : (annot, b, c) -> c sprec (x, y, z) = z - + export parseOps : Show op => List (Tok op a) -> Core (Tree op a) -parseOps toks +parseOps toks = do o <- newRef {t = List (Tree op a)} Out [] shunt [] toks diff --git a/src/Yaffle/REPL.idr b/src/Yaffle/REPL.idr index 157745f..fe252a4 100644 --- a/src/Yaffle/REPL.idr +++ b/src/Yaffle/REPL.idr @@ -28,8 +28,8 @@ import Control.Catchable %default covering showInfo : (Name, Int, GlobalDef) -> Core () -showInfo (n, _, d) - = coreLift $ putStrLn (show n ++ " ==>\n" ++ +showInfo (n, _, d) + = coreLift $ putStrLn (show n ++ " ==>\n" ++ "\t" ++ show (definition d) ++ "\n" ++ "\t" ++ show (sizeChange d) ++ "\n") @@ -51,10 +51,10 @@ process (Check (IVar _ n)) pure True where printName : (Name, Int, ClosedTerm) -> Core () - printName (n, _, tyh) + printName (n, _, tyh) = do defs <- get Ctxt ty <- normaliseHoles defs [] tyh - coreLift $ putStrLn $ show n ++ " : " ++ + coreLift $ putStrLn $ show n ++ " : " ++ show !(unelab [] ty) process (Check ttimp) = do (tm, gty) <- elabTerm 0 InExpr [] (MkNested []) [] ttimp Nothing @@ -90,8 +90,8 @@ process (GenerateDef line name) pure True case !(lookupDefExact n' (gamma defs)) of Just None => - catch - (do Just (fc, cs) <- logTime "Generation" $ + catch + (do Just (fc, cs) <- logTime "Generation" $ makeDef (\p, n => onLine line p) n' | Nothing => coreLift (putStrLn "Failed") coreLift $ putStrLn (show cs)) @@ -99,23 +99,23 @@ process (GenerateDef line name) Just _ => coreLift $ putStrLn "Already defined" Nothing => coreLift $ putStrLn $ "Can't find declaration for " ++ show name pure True -process (Missing n_in) +process (Missing n_in) = do defs <- get Ctxt case !(lookupCtxtName n_in (gamma defs)) of [] => throw (UndefinedName emptyFC n_in) - ts => do traverse_ (\fn => + ts => do traverse_ (\fn => do tot <- getTotality emptyFC fn the (Core ()) $ case isCovering tot of - MissingCases cs => + MissingCases cs => coreLift (putStrLn (show fn ++ ":\n" ++ showSep "\n" (map show cs))) NonCoveringCall ns => - coreLift (putStrLn - (show fn ++ ": Calls non covering function" + coreLift (putStrLn + (show fn ++ ": Calls non covering function" ++ case ns of [fn] => " " ++ show fn _ => "s: " ++ showSep ", " (map show ns))) - _ => coreLift $ putStrLn (show fn ++ ": All cases covered")) + _ => coreLift $ putStrLn (show fn ++ ": All cases covered")) (map fst ts) pure True process (CheckTotal n) @@ -132,7 +132,7 @@ process (DebugInfo n) = do defs <- get Ctxt traverse showInfo !(lookupCtxtName n (gamma defs)) pure True -process Quit +process Quit = do coreLift $ putStrLn "Bye for now!" pure False @@ -141,7 +141,7 @@ processCatch : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> ImpREPL -> Core Bool processCatch cmd - = catch (process cmd) + = catch (process cmd) (\err => do coreLift (putStrLn (show err)) pure True) diff --git a/tests/chez/chez010/CB.idr b/tests/chez/chez010/CB.idr index 3544c03..8857c5a 100644 --- a/tests/chez/chez010/CB.idr +++ b/tests/chez/chez010/CB.idr @@ -24,7 +24,7 @@ cb x y pure (x + y) main : IO () -main +main = do printLn (add 4 5) res <- applyIntFn (add 4 5) 6 (\x, y => do putStrLn "In callback" pure (x * 2 + y)) diff --git a/tests/idris2/basic002/Do.idr b/tests/idris2/basic002/Do.idr index 156f27c..b40056a 100644 --- a/tests/idris2/basic002/Do.idr +++ b/tests/idris2/basic002/Do.idr @@ -1,4 +1,4 @@ -data Maybe a = Nothing +data Maybe a = Nothing | Just a infixl 1 >>= diff --git a/tests/idris2/basic004/Stuff.idr b/tests/idris2/basic004/Stuff.idr index 93867cb..73c10a4 100644 --- a/tests/idris2/basic004/Stuff.idr +++ b/tests/idris2/basic004/Stuff.idr @@ -28,7 +28,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/basic004/Wheres.idr b/tests/idris2/basic004/Wheres.idr index e47c427..35bf7d3 100644 --- a/tests/idris2/basic004/Wheres.idr +++ b/tests/idris2/basic004/Wheres.idr @@ -3,7 +3,7 @@ module Wheres import Stuff reverse : List a -> List a -reverse xs = rev' Nil xs +reverse xs = rev' Nil xs where rev' : List a -> List a -> List a rev' acc Nil = acc diff --git a/tests/idris2/basic006/PMLet.idr b/tests/idris2/basic006/PMLet.idr index 5e47dcc..bfebf44 100644 --- a/tests/idris2/basic006/PMLet.idr +++ b/tests/idris2/basic006/PMLet.idr @@ -6,7 +6,7 @@ foo x = Just (prim__mul_Int x 2) testLet : Int -> Int testLet x = let y = prim__mul_Int x 2 - Just ans = foo y + Just ans = foo y | Nothing => 99 z = prim__mul_Int ans 2 in z diff --git a/tests/idris2/basic006/Stuff.idr b/tests/idris2/basic006/Stuff.idr index 3d11d19..c129ba5 100644 --- a/tests/idris2/basic006/Stuff.idr +++ b/tests/idris2/basic006/Stuff.idr @@ -28,7 +28,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/basic007/Stuff.idr b/tests/idris2/basic007/Stuff.idr index 3d11d19..c129ba5 100644 --- a/tests/idris2/basic007/Stuff.idr +++ b/tests/idris2/basic007/Stuff.idr @@ -28,7 +28,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/basic008/If.idr b/tests/idris2/basic008/If.idr index 736cb04..bc30f44 100644 --- a/tests/idris2/basic008/If.idr +++ b/tests/idris2/basic008/If.idr @@ -14,5 +14,5 @@ isOdd Z = False isOdd (S k) = not (isOdd k) testZ : Nat -> String -testZ x = if isZero x then "Zero" else +testZ x = if isZero x then "Zero" else if isOdd x then "Odd" else "Even" diff --git a/tests/idris2/basic008/Stuff.idr b/tests/idris2/basic008/Stuff.idr index 3d11d19..c129ba5 100644 --- a/tests/idris2/basic008/Stuff.idr +++ b/tests/idris2/basic008/Stuff.idr @@ -28,7 +28,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/basic009/Stuff.idr b/tests/idris2/basic009/Stuff.idr index d16af9f..d8c2ced 100644 --- a/tests/idris2/basic009/Stuff.idr +++ b/tests/idris2/basic009/Stuff.idr @@ -35,7 +35,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/basic013/Implicits.idr b/tests/idris2/basic013/Implicits.idr index c2ed382..ec95ac2 100644 --- a/tests/idris2/basic013/Implicits.idr +++ b/tests/idris2/basic013/Implicits.idr @@ -13,4 +13,4 @@ foom = ?thurlingdrome public export Monad m => Do (m a) where Next x = {b : Type} -> (a -> m b) -> m b - bind = ?oops -- (>>=) + bind = ?oops -- (>>=) diff --git a/tests/idris2/basic014/Rewrite.idr b/tests/idris2/basic014/Rewrite.idr index 873c344..e097958 100644 --- a/tests/idris2/basic014/Rewrite.idr +++ b/tests/idris2/basic014/Rewrite.idr @@ -1,6 +1,6 @@ plusnZ : (n : Nat) -> n + 0 = n plusnZ 0 = Refl -plusnZ (S k) = rewrite plusnZ k in Refl +plusnZ (S k) = rewrite plusnZ k in Refl plusnSm : (n, m : Nat) -> n + (S m) = S (n + m) plusnSm Z m = Refl diff --git a/tests/idris2/basic018/Fin.idr b/tests/idris2/basic018/Fin.idr index 1ed7ad4..479f146 100644 --- a/tests/idris2/basic018/Fin.idr +++ b/tests/idris2/basic018/Fin.idr @@ -4,7 +4,7 @@ data Fin : Nat -> Type where natToFin : Nat -> (n : Nat) -> Maybe (Fin n) natToFin Z (S j) = Just FZ -natToFin (S k) (S j) +natToFin (S k) (S j) = case natToFin k j of Just k' => Just (FS k') Nothing => Nothing @@ -19,7 +19,7 @@ data IsJust : Maybe a -> Type where -- Testing that %allow_overloads lets this one through! fromInteger : {k : Nat} -> - (n : Integer) -> + (n : Integer) -> {auto prf : IsJust (integerToFin n k)} -> Fin k fromInteger {k} n {prf} diff --git a/tests/idris2/basic020/Mut.idr b/tests/idris2/basic020/Mut.idr index 0588b97..ad74f72 100644 --- a/tests/idris2/basic020/Mut.idr +++ b/tests/idris2/basic020/Mut.idr @@ -26,12 +26,12 @@ data Box : Type -> Type where mutual Functor Box where - map f b + map f b = do b' <- b pure (f b') Applicative Box where - (<*>) f a + (<*>) f a = do f' <- f a' <- a pure (f' a') diff --git a/tests/idris2/basic021/CaseDep.idr b/tests/idris2/basic021/CaseDep.idr index d5316a2..6cf51cc 100644 --- a/tests/idris2/basic021/CaseDep.idr +++ b/tests/idris2/basic021/CaseDep.idr @@ -3,7 +3,7 @@ IntOrChar True = Int IntOrChar False = Char foo : Nat -> (x : Bool) -> IntOrChar x -> String -foo num x i +foo num x i = case x of True => show num False => show i diff --git a/tests/idris2/basic023/Params.idr b/tests/idris2/basic023/Params.idr index ce275a8..37deaf0 100644 --- a/tests/idris2/basic023/Params.idr +++ b/tests/idris2/basic023/Params.idr @@ -1,7 +1,7 @@ parameters (eq : a -> a -> Bool) lookup : a -> List (a, b) -> Maybe b lookup x [] = Nothing - lookup x ((k, v) :: ys) + lookup x ((k, v) :: ys) = if eq x k then Just v else lookup x ys diff --git a/tests/idris2/basic028/Do.idr b/tests/idris2/basic028/Do.idr index 156f27c..b40056a 100644 --- a/tests/idris2/basic028/Do.idr +++ b/tests/idris2/basic028/Do.idr @@ -1,4 +1,4 @@ -data Maybe a = Nothing +data Maybe a = Nothing | Just a infixl 1 >>= diff --git a/tests/idris2/error001/Error.idr b/tests/idris2/error001/Error.idr index bae0697..fe48b0e 100644 --- a/tests/idris2/error001/Error.idr +++ b/tests/idris2/error001/Error.idr @@ -3,4 +3,4 @@ data Vect : Nat -> Type -> Type where (::) : a -> Vect k a -> Vect (S k) a wrong : a -> Vect (S n) a -> Vect (S n) a -wrong x xs = x :: x +wrong x xs = x :: x diff --git a/tests/idris2/interactive003/IEdit.idr b/tests/idris2/interactive003/IEdit.idr index 31547d2..8e79c60 100644 --- a/tests/idris2/interactive003/IEdit.idr +++ b/tests/idris2/interactive003/IEdit.idr @@ -5,7 +5,7 @@ data Vect : Nat -> Type -> Type where %name Vect xs, ys, zs append : Vect n a -> Vect m a -> Vect (n + m) a -append xs ys +append xs ys = case xs of foo => ?bar diff --git a/tests/idris2/interactive011/IEdit.idr b/tests/idris2/interactive011/IEdit.idr index 8ad7c55..25beb5f 100644 --- a/tests/idris2/interactive011/IEdit.idr +++ b/tests/idris2/interactive011/IEdit.idr @@ -6,7 +6,7 @@ natElim2 : (p : Nat -> Type) -> p Z -> ((k : Nat) -> p k -> p (S k)) -> natElim2 p x f Z = x natElim2 p x f (S k) = ?foo -listElim : (p : List a -> Type) -> +listElim : (p : List a -> Type) -> (mnil : p []) -> (mcons : (x : _) -> (xs : List a) -> p xs -> p (x :: xs)) -> (xs : List a) -> p xs diff --git a/tests/idris2/interface001/IFace.idr b/tests/idris2/interface001/IFace.idr index 58ef295..4c1acb2 100644 --- a/tests/idris2/interface001/IFace.idr +++ b/tests/idris2/interface001/IFace.idr @@ -26,7 +26,7 @@ Eq a => Eq (List a) where (==) [] [] = True (==) (x :: xs) (y :: ys) = x == y && xs == ys (==) _ _ = False - + (/=) x y = not (x == y) (Eq a, Eq b) => Eq (a, b) where @@ -36,7 +36,7 @@ Eq a => Eq (List a) where (==) [] [] = False (==) (x :: xs) (y :: ys) = x == y && xs == ys (==) _ _ = True - + (/=) x y = not (x == y) test : ((Eq b, Eq b, Eq a), Eq b) => a -> a -> Bool @@ -73,7 +73,7 @@ v2 : DPair Nat (\n => Vect n Nat) v2 = MkDPair _ [Z, Z] (DecEq a, {t : a} -> Eq (p t)) => Eq (DPair a p) where - (==) (MkDPair l r) (MkDPair l' r') + (==) (MkDPair l r) (MkDPair l' r') = case decEq l l' of Yes Refl => r == r' No _ => False diff --git a/tests/idris2/interface001/IFace1.idr b/tests/idris2/interface001/IFace1.idr index 73d09fb..3a07466 100644 --- a/tests/idris2/interface001/IFace1.idr +++ b/tests/idris2/interface001/IFace1.idr @@ -26,7 +26,7 @@ Eq a => Eq (List a) where (==) [] [] = True (==) (x :: xs) (y :: ys) = x == y && xs == ys (==) _ _ = False - + (/=) x y = not (x == y) (Eq a, Eq b) => Eq (a, b) where @@ -36,7 +36,7 @@ Eq a => Eq (List a) where (==) [] [] = False (==) (x :: xs) (y :: ys) = x == y && xs == ys (==) _ _ = True - + (/=) x y = not (x == y) test : ((Eq b, Eq b, Eq a), Eq b) => a -> a -> Bool @@ -73,7 +73,7 @@ v2 : DPair Nat (\n => Vect n Nat) v2 = MkDPair _ [Z, Z] (DecEq a, {t : a} -> Eq (p t)) => Eq (DPair a p) where - (==) (MkDPair l r) (MkDPair l' r') + (==) (MkDPair l r) (MkDPair l' r') = case decEq l l' of Yes Refl => ?foo No _ => False diff --git a/tests/idris2/interface001/Stuff.idr b/tests/idris2/interface001/Stuff.idr index b5bd434..03b3c0b 100644 --- a/tests/idris2/interface001/Stuff.idr +++ b/tests/idris2/interface001/Stuff.idr @@ -35,7 +35,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/interface002/Stuff.idr b/tests/idris2/interface002/Stuff.idr index e1423b8..8bcc331 100644 --- a/tests/idris2/interface002/Stuff.idr +++ b/tests/idris2/interface002/Stuff.idr @@ -28,7 +28,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/interface004/Do.idr b/tests/idris2/interface004/Do.idr index 1686785..04a9dce 100644 --- a/tests/idris2/interface004/Do.idr +++ b/tests/idris2/interface004/Do.idr @@ -10,6 +10,6 @@ Monad m => Do (m a) where foo : Maybe Int -> Maybe Int -> Maybe Int foo x y - = bind x (\x' => + = bind x (\x' => bind y (\y' => Just (x' + y'))) diff --git a/tests/idris2/interface009/Odd.idr b/tests/idris2/interface009/Odd.idr index af0e7f5..a6776c0 100644 --- a/tests/idris2/interface009/Odd.idr +++ b/tests/idris2/interface009/Odd.idr @@ -1,6 +1,6 @@ interface Foo m where bar : k -> v -> m k v -> m k v - + -- This is kind of meaningless, except it exposes a potential error where -- (\s, t => List (s, t)) is substituted in as 'm' in 'm k v' and the ks -- clash, so one has to be renamed. diff --git a/tests/idris2/interface012/Defmeth.idr b/tests/idris2/interface012/Defmeth.idr index c152536..1311404 100644 --- a/tests/idris2/interface012/Defmeth.idr +++ b/tests/idris2/interface012/Defmeth.idr @@ -18,7 +18,7 @@ record Iso a b where interface Finite t where card : Nat - iso : Iso t (Fin card) + iso : Iso t (Fin card) -- default methods diff --git a/tests/idris2/linear001/Stuff.idr b/tests/idris2/linear001/Stuff.idr index 52da737..d0081e4 100644 --- a/tests/idris2/linear001/Stuff.idr +++ b/tests/idris2/linear001/Stuff.idr @@ -35,7 +35,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/linear002/Stuff.idr b/tests/idris2/linear002/Stuff.idr index 52da737..d0081e4 100644 --- a/tests/idris2/linear002/Stuff.idr +++ b/tests/idris2/linear002/Stuff.idr @@ -35,7 +35,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/linear003/Linear.idr b/tests/idris2/linear003/Linear.idr index 514ed6a..5403711 100644 --- a/tests/idris2/linear003/Linear.idr +++ b/tests/idris2/linear003/Linear.idr @@ -31,7 +31,7 @@ fst : (1 p : Pair a b) -> a fst (MkPair x y) = x wibble : (1 p : Pair a b) -> a -wibble {a=a} (MkPair x y) +wibble {a=a} (MkPair x y) = let test : (1 y : a) -> a test y = y in test x diff --git a/tests/idris2/linear004/Stuff.idr b/tests/idris2/linear004/Stuff.idr index 52da737..d0081e4 100644 --- a/tests/idris2/linear004/Stuff.idr +++ b/tests/idris2/linear004/Stuff.idr @@ -35,7 +35,7 @@ data Nat = Z | S Nat public export fromInteger : Integer -> Nat -fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) +fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0)) Z (S (fromInteger (prim__sub_Integer x 1))) public export diff --git a/tests/idris2/linear006/ZFun.idr b/tests/idris2/linear006/ZFun.idr index f026ae0..2d45f6b 100644 --- a/tests/idris2/linear006/ZFun.idr +++ b/tests/idris2/linear006/ZFun.idr @@ -2,10 +2,10 @@ import Data.Fin foo : Fin 10 foo = 5 - + 0 test : Fin k -> Nat test i = k - + 0 baz : Nat baz = test foo -- fine! diff --git a/tests/idris2/perf001/Big.idr b/tests/idris2/perf001/Big.idr index 9706bed..a20dd1a 100644 --- a/tests/idris2/perf001/Big.idr +++ b/tests/idris2/perf001/Big.idr @@ -2,8 +2,8 @@ import Data.Vect test : Vect 33 Int -> IO Int test bytes_list = do - let int1 = (index 0 bytes_list * 8) + - (index 1 bytes_list * 4) + + let int1 = (index 0 bytes_list * 8) + + (index 1 bytes_list * 4) + (index 2 bytes_list * 2) + (index 3 bytes_list) let int2 = (index 4 bytes_list * 8) + (index 5 bytes_list * 4) + (index 6 bytes_list * 2) + (index 7 bytes_list) let int3 = (index 8 bytes_list * 8) + (index 9 bytes_list * 4) + (index 10 bytes_list * 2) + (index 11 bytes_list) diff --git a/tests/idris2/record002/Record.idr b/tests/idris2/record002/Record.idr index e404c12..09b2e83 100644 --- a/tests/idris2/record002/Record.idr +++ b/tests/idris2/record002/Record.idr @@ -9,12 +9,12 @@ record MyDPair a p where cons : t -> MyDPair Nat (\n => Vect n t) -> MyDPair Nat (\n => Vect n t) cons val xs - = record { dfst = S (dfst xs), + = record { dfst = S (dfst xs), dsnd = val :: dsnd xs } xs cons' : t -> MyDPair Nat (\n => Vect n t) -> MyDPair Nat (\n => Vect n t) cons' val - = record { dfst $= S, + = record { dfst $= S, dsnd $= (val ::) } record Stats where @@ -35,4 +35,4 @@ testPerson : Person testPerson = MkPerson "Fred" 1337 10 (MkStats 10 10) grow : Person -> Person -grow = record { more->height $= (+1) } +grow = record { more->height $= (+1) } diff --git a/tests/idris2/reg001/D.idr b/tests/idris2/reg001/D.idr index 2530444..486acfc 100644 --- a/tests/idris2/reg001/D.idr +++ b/tests/idris2/reg001/D.idr @@ -7,7 +7,7 @@ func1 fn g (ma, mb) = MkPair <$> fn ma <*> ?gmb -- %logging 10 mfunc : (a -> Maybe c) -> (b -> Maybe d) -> (a, b) -> Maybe (c, d) -mfunc fn g (ma, mb) +mfunc fn g (ma, mb) = let pairapp = MkPair <$> fn ma in pairapp <*> g mb %logging 0 diff --git a/tests/idris2/total004/Total.idr b/tests/idris2/total004/Total.idr index 7972c16..3c82ff9 100644 --- a/tests/idris2/total004/Total.idr +++ b/tests/idris2/total004/Total.idr @@ -92,13 +92,13 @@ size (MkGTree xs) = sizeAll xs qsortBad : Ord a => List a -> List a qsortBad [] = [] -qsortBad (x :: xs) +qsortBad (x :: xs) = qsortBad (filter (< x) xs) ++ x :: qsortBad (filter (> x) xs) qsort : Ord a => List a -> List a qsort [] = [] -qsort (x :: xs) - = qsort (assert_smaller (x :: xs) (filter (< x) xs)) ++ +qsort (x :: xs) + = qsort (assert_smaller (x :: xs) (filter (< x) xs)) ++ x :: qsort (assert_smaller (x :: xs) (filter (> x) xs)) qsort' : Ord a => List a -> List a diff --git a/tests/typedd-book/chapter04/BSTree.idr b/tests/typedd-book/chapter04/BSTree.idr index 455e3b0..e5b0cf0 100644 --- a/tests/typedd-book/chapter04/BSTree.idr +++ b/tests/typedd-book/chapter04/BSTree.idr @@ -2,7 +2,7 @@ data BSTree : Type -> Type where Empty : Ord elem => BSTree elem Node : Ord elem => (left : BSTree elem) -> (val : elem) -> (right : BSTree elem) -> BSTree elem - + insert : elem -> BSTree elem -> BSTree elem insert x Empty = Node Empty x Empty insert x orig@(Node left val right) diff --git a/tests/typedd-book/chapter04/DataStore.idr b/tests/typedd-book/chapter04/DataStore.idr index 19493a3..0f2d040 100644 --- a/tests/typedd-book/chapter04/DataStore.idr +++ b/tests/typedd-book/chapter04/DataStore.idr @@ -33,7 +33,7 @@ parseCommand "quit" "" = Just Quit parseCommand _ _ = Nothing parse : (input : String) -> Maybe Command -parse input +parse input = case span (/= ' ') input of (cmd, args) => parseCommand cmd (ltrim args) diff --git a/tests/typedd-book/chapter04/Shape.idr b/tests/typedd-book/chapter04/Shape.idr index 7d41d0d..5495fe8 100644 --- a/tests/typedd-book/chapter04/Shape.idr +++ b/tests/typedd-book/chapter04/Shape.idr @@ -4,7 +4,7 @@ data Shape = ||| A triangle, with its base length and height Rectangle Double Double | ||| A circle, with its radius Circle Double - + area : Shape -> Double area (Triangle base height) = 0.5 * base * height area (Rectangle length height) = length * height diff --git a/tests/typedd-book/chapter04/SumInputs.idr b/tests/typedd-book/chapter04/SumInputs.idr index ed53776..59f9598 100644 --- a/tests/typedd-book/chapter04/SumInputs.idr +++ b/tests/typedd-book/chapter04/SumInputs.idr @@ -3,10 +3,10 @@ import System.REPL sumInputs : Integer -> String -> Maybe (String, Integer) sumInputs tot inp = let val = cast inp in - if val < 0 + if val < 0 then Nothing else let newVal = tot + val in Just ("Subtotal: " ++ show newVal ++ "\n", newVal) - + main : IO () main = replWith 0 "Value: " sumInputs diff --git a/tests/typedd-book/chapter05/PrintLength.idr b/tests/typedd-book/chapter05/PrintLength.idr index 58aa343..22b4b50 100644 --- a/tests/typedd-book/chapter05/PrintLength.idr +++ b/tests/typedd-book/chapter05/PrintLength.idr @@ -3,4 +3,4 @@ printLength = putStr "Input string: " >>= \_ => getLine >>= \input => let len = length input in putStrLn (show len) - + diff --git a/tests/typedd-book/chapter07/Expr.idr b/tests/typedd-book/chapter07/Expr.idr index df1511a..36032a1 100644 --- a/tests/typedd-book/chapter07/Expr.idr +++ b/tests/typedd-book/chapter07/Expr.idr @@ -17,7 +17,7 @@ Num ty => Num (Expr ty) where (+) = Add (*) = Mul fromInteger = Val . fromInteger - + Neg ty => Neg (Expr ty) where negate x = 0 - x (-) = Sub diff --git a/tests/typedd-book/chapter08/ExactLength.idr b/tests/typedd-book/chapter08/ExactLength.idr index a6c2044..1668b61 100644 --- a/tests/typedd-book/chapter08/ExactLength.idr +++ b/tests/typedd-book/chapter08/ExactLength.idr @@ -18,7 +18,7 @@ checkEqNat (S k) (S j) = case checkEqNat k j of Nothing => Nothing Just eq => Just (sameS _ _ eq) -exactLength : {m : _} -> +exactLength : {m : _} -> (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a) exactLength {m} len input = case checkEqNat m len of Nothing => Nothing diff --git a/tests/typedd-book/chapter10/DataStore.idr b/tests/typedd-book/chapter10/DataStore.idr index 3a1e225..ea10754 100644 --- a/tests/typedd-book/chapter10/DataStore.idr +++ b/tests/typedd-book/chapter10/DataStore.idr @@ -26,23 +26,23 @@ empty = MkData 0 [] export addToStore : (entry : SchemaType schema) -> (store : DataStore schema) -> - DataStore schema + DataStore schema addToStore entry (MkData _ items) = MkData _ (entry :: items) public export data StoreView : (schema : _) -> DataStore schema -> Type where SNil : StoreView schema DataStore.empty - SAdd : (entry, store : _) -> (rec : StoreView schema store) -> + SAdd : (entry, store : _) -> (rec : StoreView schema store) -> StoreView schema (addToStore entry store) storeViewHelp : {size : _} -> - (items : Vect size (SchemaType schema)) -> + (items : Vect size (SchemaType schema)) -> StoreView schema (MkData size items) storeViewHelp [] = SNil storeViewHelp (entry :: xs) = SAdd _ _ (storeViewHelp xs) export storeView : (store : DataStore schema) -> StoreView schema store -storeView (MkData size items) +storeView (MkData size items) = storeViewHelp items diff --git a/tests/typedd-book/chapter10/IsSuffix.idr b/tests/typedd-book/chapter10/IsSuffix.idr index b2ca51f..be02b40 100644 --- a/tests/typedd-book/chapter10/IsSuffix.idr +++ b/tests/typedd-book/chapter10/IsSuffix.idr @@ -6,6 +6,6 @@ isSuffix input1 input2 with (MkPair (snocList input1) (snocList input2)) isSuffix [] input2 | (Empty, s) = True isSuffix input1 [] | (s, Empty) = False isSuffix (xs ++ [x]) (ys ++ [y]) | (MkPair (Snoc x xs xsrec) (Snoc y ys ysrec)) - = if x == y + = if x == y then isSuffix xs ys | (MkPair xsrec ysrec) else False diff --git a/tests/typedd-book/chapter10/SnocList.idr b/tests/typedd-book/chapter10/SnocList.idr index 0685098..e67b713 100644 --- a/tests/typedd-book/chapter10/SnocList.idr +++ b/tests/typedd-book/chapter10/SnocList.idr @@ -8,7 +8,7 @@ snocListHelp : {input : _} -> (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest) snocListHelp snoc [] = rewrite appendNilRightNeutral input in snoc snocListHelp snoc (x :: xs) - = rewrite appendAssociative input [x] xs in + = rewrite appendAssociative input [x] xs in snocListHelp (Snoc x input snoc) xs snocList : (xs : List a) -> SnocList xs diff --git a/tests/typedd-book/chapter10/TestStore.idr b/tests/typedd-book/chapter10/TestStore.idr index 81b6eaf..8ab3102 100644 --- a/tests/typedd-book/chapter10/TestStore.idr +++ b/tests/typedd-book/chapter10/TestStore.idr @@ -10,15 +10,15 @@ testStore = addToStore ("Mercury", "Mariner 10", 1974) $ listItems : DataStore schema -> List (SchemaType schema) listItems input with (storeView input) listItems DataStore.empty | SNil = [] - listItems (addToStore entry store) | (SAdd entry store rec) + listItems (addToStore entry store) | (SAdd entry store rec) = entry :: listItems store | rec filterKeys : (test : SchemaType val_schema -> Bool) -> DataStore (SString .+. val_schema) -> List String filterKeys test input with (storeView input) filterKeys test DataStore.empty | SNil = [] - filterKeys test (addToStore (key, value) store) | (SAdd (key, value) store rec) - = if test value + filterKeys test (addToStore (key, value) store) | (SAdd (key, value) store rec) + = if test value then key :: filterKeys test store | rec else filterKeys test store | rec diff --git a/tests/typedd-book/chapter11/Arith.idr b/tests/typedd-book/chapter11/Arith.idr index dce03a2..32a94b7 100644 --- a/tests/typedd-book/chapter11/Arith.idr +++ b/tests/typedd-book/chapter11/Arith.idr @@ -15,7 +15,7 @@ quiz (num1 :: num2 :: nums) score randoms : Int -> Stream Int randoms seed = let seed' = 1664525 * seed + 1013904223 in (seed' `shiftR` 2) :: randoms seed' - + arithInputs : Int -> Stream Int arithInputs seed = map bound (randoms seed) where diff --git a/tests/typedd-book/chapter11/ArithCmdDo.idr b/tests/typedd-book/chapter11/ArithCmdDo.idr index 36d0ecf..db71f5b 100644 --- a/tests/typedd-book/chapter11/ArithCmdDo.idr +++ b/tests/typedd-book/chapter11/ArithCmdDo.idr @@ -66,11 +66,11 @@ mutual | QuitCmd readInput : (prompt : String) -> Command Input - readInput prompt + readInput prompt = do PutStr prompt answer <- GetLine - if toLower answer == "quit" - then Pure QuitCmd + if toLower answer == "quit" + then Pure QuitCmd else Pure (Answer (cast answer)) quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat @@ -78,7 +78,7 @@ mutual = do PutStr ("Score so far: " ++ show score ++ "\n") input <- readInput (show num1 ++ " * " ++ show num2 ++ "? ") case input of - Answer answer => if answer == num1 * num2 + Answer answer => if answer == num1 * num2 then correct nums score else wrong nums (num1 * num2) score QuitCmd => Quit score diff --git a/tests/typedd-book/chapter12/Traverse.idr b/tests/typedd-book/chapter12/Traverse.idr index aa5278b..91cf041 100644 --- a/tests/typedd-book/chapter12/Traverse.idr +++ b/tests/typedd-book/chapter12/Traverse.idr @@ -4,7 +4,7 @@ crew = ["Lister", "Rimmer", "Kryten", "Cat"] main : IO () main = do putStr "Display Crew? " x <- getLine - when (x == "yes") $ + when (x == "yes") $ do traverse putStrLn crew pure () putStrLn "Done" diff --git a/tests/typedd-book/chapter12/TreeLabel.idr b/tests/typedd-book/chapter12/TreeLabel.idr index 75f38cf..8741875 100644 --- a/tests/typedd-book/chapter12/TreeLabel.idr +++ b/tests/typedd-book/chapter12/TreeLabel.idr @@ -2,7 +2,7 @@ data Tree a = Empty | Node (Tree a) a (Tree a) testTree : Tree String -testTree = Node (Node (Node Empty "Jim" Empty) "Fred" +testTree = Node (Node (Node Empty "Jim" Empty) "Fred" (Node Empty "Sheila" Empty)) "Alice" (Node Empty "Bob" (Node Empty "Eve" Empty)) @@ -10,10 +10,10 @@ flatten : Tree a -> List a flatten Empty = [] flatten (Node left val right) = flatten left ++ val :: flatten right -treeLabelWith : Stream labelType -> Tree a -> +treeLabelWith : Stream labelType -> Tree a -> (Stream labelType, Tree (labelType, a)) treeLabelWith lbls Empty = (lbls, Empty) -treeLabelWith lbls (Node left val right) +treeLabelWith lbls (Node left val right) = let (this :: lblsLeft, left_labelled) = treeLabelWith lbls left (lblsRight, right_labelled) = treeLabelWith lblsLeft right in diff --git a/tests/typedd-book/chapter12/TreeLabelState.idr b/tests/typedd-book/chapter12/TreeLabelState.idr index 1de20c8..55116ce 100644 --- a/tests/typedd-book/chapter12/TreeLabelState.idr +++ b/tests/typedd-book/chapter12/TreeLabelState.idr @@ -4,7 +4,7 @@ data Tree a = Empty | Node (Tree a) a (Tree a) testTree : Tree String -testTree = Node (Node (Node Empty "Jim" Empty) "Fred" +testTree = Node (Node (Node Empty "Jim" Empty) "Fred" (Node Empty "Sheila" Empty)) "Alice" (Node Empty "Bob" (Node Empty "Eve" Empty)) @@ -14,7 +14,7 @@ flatten (Node left val right) = flatten left ++ val :: flatten right treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a)) treeLabelWith Empty = pure Empty -treeLabelWith (Node left val right) +treeLabelWith (Node left val right) = do left_labelled <- treeLabelWith left (this :: rest) <- get put rest diff --git a/tests/typedd-book/chapter12/TreeLabelType.idr b/tests/typedd-book/chapter12/TreeLabelType.idr index 97111df..3217b8c 100644 --- a/tests/typedd-book/chapter12/TreeLabelType.idr +++ b/tests/typedd-book/chapter12/TreeLabelType.idr @@ -2,7 +2,7 @@ data Tree a = Empty | Node (Tree a) a (Tree a) testTree : Tree String -testTree = Node (Node (Node Empty "Jim" Empty) "Fred" +testTree = Node (Node (Node Empty "Jim" Empty) "Fred" (Node Empty "Sheila" Empty)) "Alice" (Node Empty "Bob" (Node Empty "Eve" Empty)) @@ -15,11 +15,11 @@ data State : (stateType : Type) -> Type -> Type where Put : stateType -> State stateType () Pure : ty -> State stateType ty - Bind : State stateType a -> (a -> State stateType b) -> + Bind : State stateType a -> (a -> State stateType b) -> State stateType b {- -(>>=) : State stateType a -> (a -> State stateType b) -> +(>>=) : State stateType a -> (a -> State stateType b) -> State stateType b (>>=) = Bind -} @@ -48,7 +48,7 @@ runState (Bind cmd prog) st = let (val, nextState) = runState cmd st in treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a)) treeLabelWith Empty = Pure Empty -treeLabelWith (Node left val right) +treeLabelWith (Node left val right) = do left_labelled <- treeLabelWith left (this :: rest) <- Get Put rest From fa299418195620e7000cba91079c366d78cfeb6f Mon Sep 17 00:00:00 2001 From: Ohad Kammar Date: Sun, 27 Oct 2019 04:05:31 +0200 Subject: [PATCH 02/18] Add DIY syntax for: 1. with-proof construct 2. equational reasoning temporarily, until Idris2 supports those features --- libs/base/Syntax/PreorderReasoning.idr | 42 ++++++++++++++++++++++++++ libs/base/Syntax/WithProof.idr | 8 +++++ 2 files changed, 50 insertions(+) create mode 100644 libs/base/Syntax/PreorderReasoning.idr create mode 100644 libs/base/Syntax/WithProof.idr diff --git a/libs/base/Syntax/PreorderReasoning.idr b/libs/base/Syntax/PreorderReasoning.idr new file mode 100644 index 0000000..a2cba20 --- /dev/null +++ b/libs/base/Syntax/PreorderReasoning.idr @@ -0,0 +1,42 @@ +||| Until Idris2 starts supporting the 'syntax' keyword, here's a +||| poor-man's equational reasoning +module Syntax.PreorderReasoning + +||| Deep embedding of equation derivation sequences. +||| Using the Nil, (::) constructors lets us use list syntax. +public export +data Derivation : (x : a) -> (y : b) -> Type where + Nil : Derivation x x + (::) : (x = y) -> Derivation y z -> Derivation x z + +infix 1 ==| + +||| Explicate the term under consideration and the justification for +||| the next step. +export +(==|) : (x : a) -> (x = y) -> x = y +(==|) x pf = pf + +||| Finishg the derivation. +||| A bit klunky, but this /is/ a poor-man's version. +export +QED : {x : a} -> x = x +QED = Refl + +export +Calculate : Derivation x y -> x = y +Calculate [] = Refl +Calculate (Refl :: der) = Calculate der + +{-- +||| Requires Data.Nata +example : (x : Nat) -> (x + 1) + 0 = 1 + x +example x = Calculate [ + (x + 1) + 0 + ==| plusZeroRightNeutral (x + 1) , + x + 1 + ==| plusCommutative x 1 , + 1 + x + ==| QED + ] +--} diff --git a/libs/base/Syntax/WithProof.idr b/libs/base/Syntax/WithProof.idr new file mode 100644 index 0000000..aa933cb --- /dev/null +++ b/libs/base/Syntax/WithProof.idr @@ -0,0 +1,8 @@ +module Syntax.WithProof + +||| Until Idris2 supports the 'with (...) proof p' construct, here's a +||| poor-man's replacement. +prefix 10 @@ +public export +(@@) : (t : a ) -> (u : a ** t = u) +(@@) x = ( x ** Refl) From fd980bc92fbc0e92cab0ca59d9a3b32d4777ea51 Mon Sep 17 00:00:00 2001 From: Ohad Kammar Date: Sun, 27 Oct 2019 04:07:01 +0200 Subject: [PATCH 03/18] Add tail-recursive versions for most of the Data.List functions Also include proof the tail-recursive versions are extensionally equivalent to the non-tail-recursive one I'm a bit worried that some of those proofs came through, as visibility modifiers should get in the way. If they cause problems at some future point, just delete/comment them out. --- libs/base/Data/List.idr | 22 +- libs/base/Data/List/TailRec.idr | 394 ++++++++++++++++++++++++++++++++ 2 files changed, 409 insertions(+), 7 deletions(-) create mode 100644 libs/base/Data/List/TailRec.idr diff --git a/libs/base/Data/List.idr b/libs/base/Data/List.idr index 6c63b6d..4cacd3f 100644 --- a/libs/base/Data/List.idr +++ b/libs/base/Data/List.idr @@ -85,7 +85,7 @@ span p (x::xs) = public export break : (a -> Bool) -> List a -> (List a, List a) -break p = span (not . p) +break p xs = span (not . p) xs public export split : (a -> Bool) -> List a -> List (List a) @@ -159,6 +159,18 @@ export toList : Foldable t => t a -> List a toList = foldr (::) [] +||| Prefix every element in the list with the given element +||| +||| ```idris example +||| with List (mergeReplicate '>' ['a', 'b', 'c', 'd', 'e']) +||| ``` +||| +export +mergeReplicate : a -> List a -> List a +mergeReplicate sep [] = [] +mergeReplicate sep (y::ys) = sep :: y :: mergeReplicate sep ys + + ||| Insert some separator between the elements of a list. ||| ||| ````idris example @@ -168,11 +180,7 @@ toList = foldr (::) [] export intersperse : a -> List a -> List a intersperse sep [] = [] -intersperse sep (x::xs) = x :: intersperse' sep xs - where - intersperse' : a -> List a -> List a - intersperse' sep [] = [] - intersperse' sep (y::ys) = sep :: y :: intersperse' sep ys +intersperse sep (x::xs) = x :: mergeReplicate sep xs ||| Apply a partial function to the elements of a list, keeping the ones at which ||| it is defined. @@ -212,7 +220,7 @@ mergeBy order (x::xs) (y::ys) = ||| Merge two sorted lists using the default ordering for the type of their elements. export merge : Ord a => List a -> List a -> List a -merge = mergeBy compare +merge left right = mergeBy compare left right ||| Sort a list using some arbitrary comparison predicate. ||| diff --git a/libs/base/Data/List/TailRec.idr b/libs/base/Data/List/TailRec.idr new file mode 100644 index 0000000..9e73f3b --- /dev/null +++ b/libs/base/Data/List/TailRec.idr @@ -0,0 +1,394 @@ +||| Contains: +||| +||| 1. Tail recursive versions of the list processing functions from +||| Data.List. +||| +||| 2. Extensional equality proofs that these variants are +||| (extensionally) equivalent to their non-tail-recursive +||| counterparts. +||| +||| Note: +||| +||| 1. Written in one sitting, feel free to refactor +||| +||| 2. The proofs below also work on non-publicly exported +||| definitions. This could be due to a bug, and will need to be +||| moved elsewhere if it's fixed. +module Data.List.TailRec + +import Syntax.PreorderReasoning +import Syntax.WithProof + +import Data.List +import Data.Vect +import Data.Nat + +length_aux : List a -> Nat -> Nat +length_aux [] len = len +length_aux (_::xs) len = length_aux xs (S len) + +export +length : List a -> Nat +length xs = length_aux xs Z + +export +length_ext : (xs : List a) -> Data.List.length xs = Data.List.TailRec.length xs +length_ext xs = Calculate [ + Data.List.length xs + ==| sym (plusZeroRightNeutral (Data.List.length xs)), + Data.List.length xs + 0 + ==| lemma 0 xs, + Data.List.TailRec.length_aux xs 0 + ==| Refl, + Data.List.TailRec.length xs + ==| QED + ] + where + lemma : (n : Nat) -> (xs : List a) -> + Data.List.length xs + n = length_aux xs n + lemma n [] = Refl + lemma n (_ :: xs) = + let length_xs : Nat + length_xs = Data.List.length xs in + Calculate [ + 1 + (length_xs + n) + -- Hopefully we could Frex these two steps one day + ==| plusAssociative 1 length_xs n , + (1 + length_xs) + n + ==| cong (+n) (plusCommutative 1 length_xs) , + (length_xs + 1) + n + ==| sym (plusAssociative length_xs 1 n), + (length_xs) + (1 + n) + ==| lemma (1 + n) xs, + length_aux xs (1 + n) + ==| QED + ] + +take_aux : Nat -> List a -> List a -> List a +take_aux Z xs acc = reverseOnto [] acc +take_aux (S n) [] acc = reverseOnto [] acc +take_aux (S n) (x :: xs) acc = take_aux n xs (x :: acc) + +export +take : Nat -> List a -> List a +take n xs = take_aux n xs [] + +export +take_ext : + (n : Nat) -> (xs : List a) -> + Data.List.take n xs = Data.List.TailRec.take n xs +take_ext n xs = Calculate [ + Data.List.take n xs + ==| Refl , + reverse [] ++ (Data.List.take n xs) + ==| sym (revOnto (Data.List.take n xs) []) , + reverseOnto (Data.List.take n xs) [] + ==| sym (lemma n xs []) , + take_aux n xs [] + ==| QED + ] + where + lemma : (n : Nat) -> (xs, acc : List a) -> + take_aux n xs acc = reverseOnto (Data.List.take n xs) acc + lemma Z xs acc = Refl + lemma (S n) [] acc = Refl + lemma (S n) (x::xs) acc = lemma n xs (x :: acc) + + +span_aux : (a -> Bool) -> List a -> List a -> (List a, List a) +span_aux p [] acc = (reverseOnto [] acc, []) +span_aux p (x::xs) acc = + if p x then + Data.List.TailRec.span_aux p xs (x :: acc) + else + (reverseOnto [] acc, x::xs) + +export +span : (a -> Bool) -> List a -> (List a, List a) +span p xs = span_aux p xs [] + +coe : (f : (i : a) -> Type) -> i = i' -> f i -> f i' +coe f Refl x = x + +span_aux_ext : (p : a -> Bool) -> (xs, acc : List a) -> + (reverseOnto (fst $ Data.List.span p xs) acc, snd $ Data.List.span p xs) + = + span_aux p xs acc +span_aux_ext p [] acc = Refl +-- This is disgusting. Please teach me a better way. +span_aux_ext p (x::xs) acc with (@@(p x), @@(Data.List.span p xs)) + span_aux_ext p (x::xs) acc | ((True ** px_tru), ((pre, rest)**dl_pf)) = + rewrite px_tru in + rewrite dl_pf in + let u = span_aux_ext p xs (x::acc) in + coe (\u => (reverseOnto (x :: fst u) acc, snd u) = + Data.List.TailRec.span_aux p xs (x :: acc)) dl_pf u + span_aux_ext p (x::xs) acc | ((False**px_fls), ((pre,rest)**dl_pf)) = + rewrite px_fls in + Refl + +export +span_ext : (p : a -> Bool) -> (xs : List a) -> + Data.List.span p xs = Data.List.TailRec.span p xs +span_ext p xs with (@@(Data.List.span p xs)) + span_ext p xs | ((pre, rest) ** pf) = + rewrite pf in + let u = span_aux_ext p xs [] in + coe (\u => (fst u, snd u) = span_aux p xs []) pf u + +export +break : (a -> Bool) -> List a -> (List a, List a) +break p xs = Data.List.TailRec.span (not . p) xs + +export +break_ext : (p : a -> Bool) -> (xs : List a) -> + Data.List.break p xs = Data.List.TailRec.break p xs +break_ext p xs = span_ext (not . p) xs + +splitOnto : List (List a) -> (a -> Bool) -> List a -> List (List a) +splitOnto acc p xs = + case Data.List.break p xs of + (chunk, [] ) => reverseOnto [chunk] acc + (chunk, (c::rest)) => splitOnto (chunk::acc) p rest + +export +split : (a -> Bool) -> List a -> List (List a) +split p xs = splitOnto [] p xs + +splitOnto_ext : (acc : List (List a)) -> (p : a -> Bool) -> (xs : List a) -> + reverseOnto (Data.List.split p xs) acc + = Data.List.TailRec.splitOnto acc p xs +splitOnto_ext acc p xs with (@@(Data.List.break p xs)) + splitOnto_ext acc p xs | ((chunk, [] )**pf) = + rewrite pf in + Refl + splitOnto_ext acc p xs | ((chunk, c::rest)**pf) = + rewrite pf in + rewrite splitOnto_ext (chunk::acc) p rest in + Refl + +export +split_ext : (p : a -> Bool) -> (xs : List a) -> + Data.List.split p xs = Data.List.TailRec.split p xs +split_ext p xs = splitOnto_ext [] p xs + + +splitAtOnto : List a -> (n : Nat) -> (xs : List a) -> (List a, List a) +splitAtOnto acc Z xs = (reverseOnto [] acc, xs) +splitAtOnto acc (S n) [] = (reverseOnto [] acc, []) +splitAtOnto acc (S n) (x::xs) = splitAtOnto (x::acc) n xs + +export +splitAt : (n : Nat) -> (xs : List a) -> (List a, List a) +splitAt n xs = splitAtOnto [] n xs + +splitAtOnto_ext : (acc : List a) -> (n : Nat) -> (xs : List a) -> + (reverseOnto (fst $ Data.List.splitAt n xs) acc, snd $ Data.List.splitAt n xs) + = splitAtOnto acc n xs +splitAtOnto_ext acc Z xs = Refl +splitAtOnto_ext acc (S n) [] = Refl +splitAtOnto_ext acc (S n) (x::xs) with (@@(Data.List.splitAt n xs)) + splitAtOnto_ext acc (S n) (x::xs) | ((tk, dr)**pf) = + rewrite pf in + let u = splitAtOnto_ext (x::acc) n xs in + coe (\u => (reverseOnto (x :: fst u) acc, snd u) = + splitAtOnto (x :: acc) n xs) pf u + +export +splitAt_ext : (n : Nat) -> (xs : List a) -> + Data.List.splitAt n xs = + Data.List.TailRec.splitAt n xs +splitAt_ext n xs with (@@(Data.List.splitAt n xs)) + splitAt_ext n xs | ((tk, dr)**pf) = + rewrite pf in + rewrite sym $ splitAtOnto_ext [] n xs in + rewrite pf in + Refl + +partitionOnto : List a -> List a -> (a -> Bool) -> List a -> (List a, List a) +partitionOnto lfts rgts p [] = (reverseOnto [] lfts, reverseOnto [] rgts) +partitionOnto lfts rgts p (x::xs) = + if p x then + partitionOnto (x :: lfts) rgts p xs + else + partitionOnto lfts (x::rgts) p xs + +export +partition : (a -> Bool) -> List a -> (List a, List a) +partition p xs = partitionOnto [] [] p xs + +partitionOnto_ext : (lfts, rgts : List a) -> (p : a -> Bool) -> (xs : List a) -> + (reverseOnto (fst $ Data.List.partition p xs) lfts + ,reverseOnto (snd $ Data.List.partition p xs) rgts) + = Data.List.TailRec.partitionOnto lfts rgts p xs +partitionOnto_ext lfts rgts p [] = Refl +partitionOnto_ext lfts rgts p (x::xs) with (@@(p x), @@(Data.List.partition p xs)) + partitionOnto_ext lfts rgts p (x::xs) | ((True **px_tru), ((dl_l, dl_r)**dl_pf)) + = rewrite px_tru in + rewrite dl_pf in + rewrite px_tru in + let u = partitionOnto_ext (x :: lfts) rgts p xs in + coe (\u => (reverseOnto (x :: fst u) lfts + ,reverseOnto ( snd u) rgts) + = partitionOnto (x :: lfts) rgts p xs) dl_pf u + + partitionOnto_ext lfts rgts p (x::xs) | ((False**px_fls), ((dl_l, dl_r)**dl_pf)) + = rewrite px_fls in + rewrite dl_pf in + rewrite px_fls in + let u = partitionOnto_ext lfts (x :: rgts) p xs in + coe (\u => (reverseOnto ( fst u) lfts + ,reverseOnto (x :: snd u) rgts) + = partitionOnto lfts (x::rgts) p xs) dl_pf u + +mergeReplicate_aux : a -> List a -> List a -> List a +mergeReplicate_aux sep [] acc = reverseOnto [] acc +mergeReplicate_aux sep (x::xs) acc = mergeReplicate_aux sep xs (x :: sep :: acc) + +mergeReplicate_ext : (sep : a) -> (xs : List a) -> (acc : List a) -> + mergeReplicate_aux sep xs acc = + reverseOnto (mergeReplicate sep xs) acc +mergeReplicate_ext sep [] acc = Refl +mergeReplicate_ext sep (x::xs) acc = Calculate [ + mergeReplicate_aux sep xs (x :: sep :: acc) + ==| mergeReplicate_ext sep xs (x :: sep :: acc) , + reverseOnto (sep :: x :: mergeReplicate sep xs) acc + ==| QED + ] + +export +intersperse : a -> List a -> List a +intersperse sep [] = [] +intersperse sep (y::ys) = y :: mergeReplicate_aux sep ys [] + +export +intersperse_ext : (sep : a) -> (xs : List a) -> + Data.List.intersperse sep xs = + Data.List.TailRec.intersperse sep xs +intersperse_ext sep [] = Refl +intersperse_ext sep (y::ys) = cong (y::) (sym $ mergeReplicate_ext sep ys []) + +mapMaybeOnto : List b -> (a -> Maybe b) -> List a -> List b +mapMaybeOnto acc f [] = reverseOnto [] acc +mapMaybeOnto acc f (x::xs) = + case f x of + Nothing => mapMaybeOnto acc f xs + Just y => mapMaybeOnto (y :: acc) f xs + +export +mapMaybe : (a -> Maybe b) -> List a -> List b +mapMaybe f xs = mapMaybeOnto [] f xs + +mapMaybeOnto_ext : (acc : List b) -> (f : a -> Maybe b) -> (xs : List a) -> + reverseOnto (Data.List.mapMaybe f xs) acc + = + mapMaybeOnto acc f xs +mapMaybeOnto_ext acc f [] = Refl +mapMaybeOnto_ext acc f (x::xs) with (f x) + mapMaybeOnto_ext acc f (x::xs) | Nothing = mapMaybeOnto_ext acc f xs + mapMaybeOnto_ext acc f (x::xs) | Just y = mapMaybeOnto_ext (y :: acc) f xs + +export +mapMaybe_ext : (f : a -> Maybe b) -> (xs : List a) -> + Data.List.mapMaybe f xs = Data.List.TailRec.mapMaybe f xs +mapMaybe_ext f xs = mapMaybeOnto_ext [] f xs + +export +sorted : Ord a => List a -> Bool +sorted [ ] = True +sorted [x] = True +sorted (x :: xs@(y :: ys)) = case (x <= y) of + False => False + True => Data.List.TailRec.sorted xs + +export +sorted_ext : Ord a => (xs : List a) -> + Data.List.sorted xs = Data.List.TailRec.sorted xs +sorted_ext [] = Refl +sorted_ext [x] = Refl +sorted_ext (x :: y :: ys) with (x <= y) + sorted_ext (x :: y :: ys) | False = Refl + sorted_ext (x :: y :: ys) | True = sorted_ext (y::ys) + +mergeByOnto : List a -> (a -> a -> Ordering) -> List a -> List a -> List a +mergeByOnto acc order [] right = reverseOnto right acc +mergeByOnto acc order left [] = reverseOnto left acc +mergeByOnto acc order left@(x::xs) right@(y::ys) = + case order x y of + LT => mergeByOnto (x :: acc) order xs right + _ => mergeByOnto (y :: acc) order left ys + +mergeByOnto_ext : (acc : List a) + -> (order : a -> a -> Ordering) + -> (left, right : List a) + -> reverseOnto (mergeBy order left right) acc + = mergeByOnto acc order left right +mergeByOnto_ext acc order [] right = Refl +mergeByOnto_ext acc order left [] = ?bug139 +mergeByOnto_ext acc order left@(x::xs) right@(y::ys) with (order x y) + mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | LT = + mergeByOnto_ext (x :: acc) order xs (y::ys) + -- We need to exhaust the two other cases explicitly to convince the + -- typecheker. See #140 + mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | EQ = + mergeByOnto_ext (y :: acc) order (x::xs) ys + mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | GT = + mergeByOnto_ext (y :: acc) order (x::xs) ys + +export +mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a +mergeBy order left right = mergeByOnto [] order left right + +export +mergeBy_ext : (order : a -> a -> Ordering) -> (left, right : List a) -> + Data.List.mergeBy order left right = + Data.List.TailRec.mergeBy order left right +mergeBy_ext order left right = mergeByOnto_ext [] order left right + +export +merge : Ord a => List a -> List a -> List a +merge = Data.List.TailRec.mergeBy compare + +export +merge_ext : Ord a => (left, right : List a) -> + Data.List.merge left right = Data.List.TailRec.merge left right +merge_ext left right = mergeBy_ext compare left right + + +-- Not quite finished due to a bug. + +sortBy_splitRec : List a -> List a -> (List a -> List a) -> (List a, List a) +sortBy_splitRec (_::_::xs) (y::ys) zs = sortBy_splitRec xs ys (zs . ((::) y)) +sortBy_splitRec _ ys zs = (zs [], ys) + +sortBy_split : List a -> (List a, List a) +sortBy_split xs = sortBy_splitRec xs xs id + +export +sortBy : (cmp : a -> a -> Ordering) -> (xs : List a) -> List a +sortBy cmp [] = [] +sortBy cmp [x] = [x] +sortBy cmp xs = let (x, y) = sortBy_split xs in + Data.List.TailRec.mergeBy cmp + (Data.List.TailRec.sortBy cmp (assert_smaller xs x)) + (Data.List.TailRec.sortBy cmp (assert_smaller xs y)) + + +{-- -- This code seems to make Idris2 loop +export +sortBy_ext : (cmp : a -> a -> Ordering) -> (xs : List a) -> + Data.List.sortBy cmp xs = Data.List.TailRec.sortBy cmp xs +sortBy_ext cmp [] = Refl +sortBy_ext cmp [x] = Refl +sortBy_ext cmp xs@(y::ys) = let (x, y) = split xs in + Calculate [ + Data.List.mergeBy cmp + (Data.List.sortBy cmp (assert_smaller xs x)) + (Data.List.sortBy cmp (assert_smaller xs y)) + ==| ?help1 , + Data.List.TailRec.mergeBy cmp + (Data.List.TailRec.sortBy cmp (assert_smaller xs x)) + (Data.List.TailRec.sortBy cmp (assert_smaller xs y)) + ==| QED + ] +--} From 7e8642e8f84d24bd4afddf84380ca970f0cef1c0 Mon Sep 17 00:00:00 2001 From: Ohad Kammar Date: Sun, 27 Oct 2019 08:26:06 +0200 Subject: [PATCH 04/18] Fix a stack overflow with a tail recursive list integer length function Relates to #133 and #135. --- src/Utils/Binary.idr | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/Utils/Binary.idr b/src/Utils/Binary.idr index 3366470..3497142 100644 --- a/src/Utils/Binary.idr +++ b/src/Utils/Binary.idr @@ -338,8 +338,19 @@ export export TTC a => TTC (List a) where toBuf b xs - = do toBuf b (cast {to=Int} (length xs)) + = do toBuf b (TailRec_length xs) traverse_ (toBuf b) xs + where + ||| Tail-recursive length as buffer sizes can get large + ||| + ||| Once we port to Idris2, can use Data.List.TailRec.length instead + length_aux : List a -> Int -> Int + length_aux [] len = len + length_aux (_::xs) len = length_aux xs (1 + len) + + TailRec_length : List a -> Int + TailRec_length xs = length_aux xs 0 + fromBuf b = do len <- fromBuf b {a = Int} readElems [] (cast len) From 0fb873949f70e0d5c5caeda2353a0b9792c28670 Mon Sep 17 00:00:00 2001 From: Molly Miller Date: Mon, 28 Oct 2019 20:23:11 +0000 Subject: [PATCH 05/18] Implement Debug.Trace, from Idris 1's base package --- libs/base/Debug/Trace.idr | 8 ++++++++ libs/base/base.ipkg | 2 ++ 2 files changed, 10 insertions(+) create mode 100644 libs/base/Debug/Trace.idr diff --git a/libs/base/Debug/Trace.idr b/libs/base/Debug/Trace.idr new file mode 100644 index 0000000..887a9a5 --- /dev/null +++ b/libs/base/Debug/Trace.idr @@ -0,0 +1,8 @@ +module Debug.Trace + +import Prelude +import PrimIO + +export +trace : (msg : String) -> (result : a) -> a +trace x val = unsafePerformIO (do putStrLn x; pure val) diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg index 1365db5..73e8971 100644 --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -22,6 +22,8 @@ modules = Control.Monad.Identity, Data.Strings, Data.Vect, + Debug.Trace, + Decidable.Equality, Language.Reflection, From 76ff99d3701e226a7f7f36dab3d4f08e02e48110 Mon Sep 17 00:00:00 2001 From: lodi Date: Fri, 6 Sep 2019 14:44:33 -0400 Subject: [PATCH 06/18] allow overriding racket/chicken paths through environment variables This is to help Idris2 codegen the correct scripts on NixOS where Racket and Chicken aren't installed in the standard locations, and the /usr/bin/env trampoline is disabled at package build time. This now matches the existing Chez behavior. Also, fixed the test runner to restore the correct working directory after a failed test, and fixed the top-level Makefile to allow the IDRIS2_VERSION variable to be queried without building the project. --- Makefile | 2 +- src/Compiler/Scheme/Chicken.idr | 8 +++++-- src/Compiler/Scheme/Racket.idr | 8 +++++-- tests/Main.idr | 42 +++++++++++++++++++-------------- 4 files changed, 37 insertions(+), 23 deletions(-) diff --git a/Makefile b/Makefile index 709166e..1ad5877 100644 --- a/Makefile +++ b/Makefile @@ -14,7 +14,7 @@ ifeq ($(shell git status >/dev/null 2>&1; echo $$?), 0) endif endif -IDRIS2_VERSION=${MAJOR}.${MINOR}.${PATCH}${VER_TAG} +IDRIS2_VERSION:=${MAJOR}.${MINOR}.${PATCH}${VER_TAG} PREFIX ?= ${HOME}/.idris2 export IDRIS2_PATH = ${CURDIR}/libs/prelude/build/ttc:${CURDIR}/libs/base/build/ttc diff --git a/src/Compiler/Scheme/Chicken.idr b/src/Compiler/Scheme/Chicken.idr index 8300379..1fb7c97 100644 --- a/src/Compiler/Scheme/Chicken.idr +++ b/src/Compiler/Scheme/Chicken.idr @@ -21,10 +21,14 @@ import System.Info %default covering findCSI : IO String -findCSI = pure "/usr/bin/env csi" +findCSI = + do env <- getEnv "CHICKEN_CSI" + pure $ fromMaybe "/usr/bin/env -S csi" env findCSC : IO String -findCSC = pure "/usr/bin/env csc" +findCSC = + do env <- getEnv "CHICKEN_CSC" + pure $ fromMaybe "/usr/bin/env -S csc" env schHeader : List String -> String schHeader ds diff --git a/src/Compiler/Scheme/Racket.idr b/src/Compiler/Scheme/Racket.idr index 8bf78e1..c37d5bd 100644 --- a/src/Compiler/Scheme/Racket.idr +++ b/src/Compiler/Scheme/Racket.idr @@ -20,10 +20,14 @@ import System.Info %default covering findRacket : IO String -findRacket = pure "/usr/bin/env racket" +findRacket = + do env <- getEnv "RACKET" + pure $ fromMaybe "/usr/bin/env -S racket" env findRacoExe : IO String -findRacoExe = pure "raco exe" +findRacoExe = + do env <- getEnv "RACKET_RACO" + pure $ (fromMaybe "/usr/bin/env -S raco" env) ++ " exe" schHeader : String -> String schHeader libs diff --git a/tests/Main.idr b/tests/Main.idr index 09060dc..5c415be 100644 --- a/tests/Main.idr +++ b/tests/Main.idr @@ -82,25 +82,31 @@ fail err runTest : String -> String -> IO Bool runTest prog testPath = do chdir testPath - putStr $ testPath ++ ": " - system $ "sh ./run " ++ prog ++ " | tr -d '\\r' > output" - Right out <- readFile "output" - | Left err => do print err - pure False - Right exp <- readFile "expected" - | Left err => do print err - pure False - - if (out == exp) - then putStrLn "success" - else do - putStrLn "FAILURE" - putStrLn "Expected:" - printLn exp - putStrLn "Given:" - printLn out + isSuccess <- runTest' chdir "../.." - pure (out == exp) + pure isSuccess + where + runTest' : IO Bool + runTest' + = do putStr $ testPath ++ ": " + system $ "sh ./run " ++ prog ++ " | tr -d '\\r' > output" + Right out <- readFile "output" + | Left err => do print err + pure False + Right exp <- readFile "expected" + | Left err => do print err + pure False + + if (out == exp) + then putStrLn "success" + else do + putStrLn "FAILURE" + putStrLn "Expected:" + printLn exp + putStrLn "Given:" + printLn out + + pure (out == exp) exists : String -> IO Bool exists f From 2a014d1e19e706d250f085743a1bffc67318183e Mon Sep 17 00:00:00 2001 From: Michael Morgan Date: Tue, 29 Oct 2019 15:51:15 -0700 Subject: [PATCH 07/18] Add zip functions to base/Data.List. This includes the following functions: zipWith, zip, zipWith3, zip3 --- libs/base/Data/List.idr | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/libs/base/Data/List.idr b/libs/base/Data/List.idr index 6c63b6d..acd7c4b 100644 --- a/libs/base/Data/List.idr +++ b/libs/base/Data/List.idr @@ -132,6 +132,39 @@ export intersect : Eq a => List a -> List a -> List a intersect = intersectBy (==) +||| Combine two lists elementwise using some function. +||| +||| If the lists are different lengths, the result is truncated to the +||| length of the shortest list. +export +zipWith : (a -> b -> c) -> List a -> List b -> List c +zipWith _ [] _ = [] +zipWith _ _ [] = [] +zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys + +||| Combine two lists elementwise into pairs. +||| +||| If the lists are different lengths, the result is truncated to the +||| length of the shortest list. +export +zip : List a -> List b -> List (a, b) +zip = zipWith \x, y => (x, y) + +export +zipWith3 : (a -> b -> c -> d) -> List a -> List b -> List c -> List d +zipWith3 _ [] _ _ = [] +zipWith3 _ _ [] _ = [] +zipWith3 _ _ _ [] = [] +zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs + +||| Combine three lists elementwise into tuples. +||| +||| If the lists are different lengths, the result is truncated to the +||| length of the shortest list. +export +zip3 : List a -> List b -> List c -> List (a, b, c) +zip3 = zipWith3 \x, y, z => (x, y, z) + public export data NonEmpty : (xs : List a) -> Type where IsNonEmpty : NonEmpty (x :: xs) From 9190ccf8833e179e67db5500911376abcf8ad581 Mon Sep 17 00:00:00 2001 From: Michael Morgan Date: Tue, 29 Oct 2019 16:06:48 -0700 Subject: [PATCH 08/18] Add replicate to base/Data.List. --- libs/base/Data/List.idr | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/libs/base/Data/List.idr b/libs/base/Data/List.idr index 6c63b6d..8a0e5d2 100644 --- a/libs/base/Data/List.idr +++ b/libs/base/Data/List.idr @@ -121,6 +121,13 @@ public export reverse : List a -> List a reverse = reverseOnto [] +||| Construct a list with `n` copies of `x`. +||| @ n how many copies +||| @ x the element to replicate +public export +replicate : (n : Nat) -> (x : a) -> List a +replicate Z _ = [] +replicate (S n) x = x :: replicate n x ||| Compute the intersect of two lists by user-supplied equality predicate. export From fe4fb532cdd5a8040c6f81217372990d823cce74 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 11 Nov 2019 08:37:59 +0100 Subject: [PATCH 09/18] export Network.Socket functions fix #152 --- libs/network/Network/Socket.idr | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/libs/network/Network/Socket.idr b/libs/network/Network/Socket.idr index f058c09..2d201c0 100644 --- a/libs/network/Network/Socket.idr +++ b/libs/network/Network/Socket.idr @@ -12,6 +12,7 @@ import Data.List ||| Creates a UNIX socket with the given family, socket type and protocol ||| number. Returns either a socket or an error. +export socket : (fam : SocketFamily) -> (ty : SocketType) -> (pnum : ProtocolNumber) @@ -24,11 +25,13 @@ socket sf st pn = do else pure $ Right (MkSocket socket_res sf st pn) ||| Close a socket +export close : Socket -> IO () close sock = cCall () "close" [descriptor sock] ||| Binds a socket to the given socket address and port. ||| Returns 0 on success, an error code otherwise. +export bind : (sock : Socket) -> (addr : Maybe SocketAddress) -> (port : Port) @@ -48,6 +51,7 @@ bind sock addr port = do ||| Connects to a given address and port. ||| Returns 0 on success, and an error number on error. +export connect : (sock : Socket) -> (addr : SocketAddress) -> (port : Port) @@ -63,6 +67,7 @@ connect sock addr port = do ||| Listens on a bound socket. ||| ||| @sock The socket to listen on. +export listen : (sock : Socket) -> IO Int listen sock = do listen_res <- cCall Int "listen" [ descriptor sock, BACKLOG ] @@ -78,6 +83,7 @@ listen sock = do ||| + `SocketAddress` :: The ||| ||| @sock The socket used to establish connection. +export accept : (sock : Socket) -> IO (Either SocketError (Socket, SocketAddress)) accept sock = do @@ -103,6 +109,7 @@ accept sock = do ||| ||| @sock The socket on which to send the message. ||| @msg The data to send. +export send : (sock : Socket) -> (msg : String) -> IO (Either SocketError ResultCode) @@ -122,6 +129,7 @@ send sock dat = do ||| ||| @sock The socket on which to receive the message. ||| @len How much of the data to receive. +export recv : (sock : Socket) -> (len : ByteLength) -> IO (Either SocketError (String, ResultCode)) @@ -152,7 +160,7 @@ recv sock len = do ||| Returns on success the payload `String` ||| ||| @sock The socket on which to receive the message. -partial +export recvAll : (sock : Socket) -> IO (Either SocketError String) recvAll sock = recvRec sock [] 64 where @@ -174,6 +182,7 @@ recvAll sock = recvRec sock [] 64 ||| @addr Address of the recipient. ||| @port The port on which to send the message. ||| @msg The message to send. +export sendTo : (sock : Socket) -> (addr : SocketAddress) -> (port : Port) @@ -198,6 +207,7 @@ sendTo sock addr p dat = do ||| @sock The channel on which to receive. ||| @len Size of the expected message. ||| +export recvFrom : (sock : Socket) -> (len : ByteLength) -> IO (Either SocketError (UDPAddrInfo, String, ResultCode)) From ca3ea38cdece96b3eff89ae6ef11a4e62682dcc0 Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Mon, 11 Nov 2019 19:35:23 +0000 Subject: [PATCH 10/18] Make sure Force is erased for termination checker But only for 'Lazy', not for 'Inf'. This is necessary to build the size change graphs correctly. --- libs/prelude/PrimIO.idr | 23 ++++++++++++++---- src/Compiler/CompileExpr.idr | 2 +- src/Core/Binary.idr | 2 +- src/Core/Context.idr | 8 +++---- src/Core/Env.idr | 2 +- src/Core/GetType.idr | 4 ++-- src/Core/Hash.idr | 2 +- src/Core/LinearCheck.idr | 6 ++--- src/Core/Normalise.idr | 20 ++++++++-------- src/Core/TT.idr | 36 ++++++++++++++--------------- src/Core/TTC.idr | 8 +++---- src/Core/Termination.idr | 12 ++++++---- src/Core/Unify.idr | 18 +++++++-------- src/Core/Value.idr | 4 ++-- src/TTImp/Elab/App.idr | 2 +- src/TTImp/Elab/Case.idr | 4 ++-- src/TTImp/Elab/Check.idr | 10 ++++---- src/TTImp/Elab/ImplicitBind.idr | 4 ++-- src/TTImp/Elab/Lazy.idr | 4 ++-- src/TTImp/Elab/Term.idr | 2 +- src/TTImp/Interactive/MakeLemma.idr | 2 +- src/TTImp/Unelab.idr | 4 ++-- 22 files changed, 99 insertions(+), 80 deletions(-) diff --git a/libs/prelude/PrimIO.idr b/libs/prelude/PrimIO.idr index 57db609..3b6e80c 100644 --- a/libs/prelude/PrimIO.idr +++ b/libs/prelude/PrimIO.idr @@ -10,10 +10,23 @@ export data IO : Type -> Type where MkIO : (1 fn : (1 x : %World) -> IORes a) -> IO a +public export +PrimIO : Type -> Type +PrimIO a = (1 x : %World) -> IORes a + +export +prim_io_pure : a -> PrimIO a +prim_io_pure x = \w => MkIORes x w + export io_pure : a -> IO a io_pure x = MkIO (\w => MkIORes x w) +export +prim_io_bind : (1 act : PrimIO a) -> (1 k : a -> PrimIO b) -> PrimIO b +prim_io_bind fn k w + = let MkIORes x' w' = fn w in k x' w' + export io_bind : (1 act : IO a) -> (1 k : a -> IO b) -> IO b io_bind (MkIO fn) @@ -21,10 +34,6 @@ io_bind (MkIO fn) MkIO res = k x' in res w') -public export -PrimIO : Type -> Type -PrimIO a = (1 x : %World) -> IORes a - %extern prim__putStr : String -> (1 x : %World) -> IORes () %extern prim__getStr : (1 x : %World) -> IORes String @@ -56,7 +65,7 @@ primIO : (1 fn : (1 x : %World) -> IORes a) -> IO a primIO op = MkIO op export %inline -toPrim : IO a -> PrimIO a +toPrim : (1 act : IO a) -> PrimIO a toPrim (MkIO fn) = fn export %inline @@ -83,6 +92,10 @@ export fork : (1 prog : IO ()) -> IO ThreadID fork (MkIO act) = schemeCall ThreadID "blodwen-thread" [act] +export +prim_fork : (1 prog : PrimIO ()) -> PrimIO ThreadID +prim_fork act w = prim__schemeCall ThreadID "blodwen-thread" [act] w + unsafeCreateWorld : (1 f : (1 x : %World) -> a) -> a unsafeCreateWorld f = f %MkWorld diff --git a/src/Compiler/CompileExpr.idr b/src/Compiler/CompileExpr.idr index 41b117e..9196b86 100644 --- a/src/Compiler/CompileExpr.idr +++ b/src/Compiler/CompileExpr.idr @@ -175,7 +175,7 @@ mutual toCExpTm tags n (TDelayed fc _ _) = pure $ CErased fc toCExpTm tags n (TDelay fc _ _ arg) = pure (CDelay fc !(toCExp tags n arg)) - toCExpTm tags n (TForce fc arg) + toCExpTm tags n (TForce fc _ arg) = pure (CForce fc !(toCExp tags n arg)) toCExpTm tags n (PrimVal fc c) = let t = constTag c in diff --git a/src/Core/Binary.idr b/src/Core/Binary.idr index 202bf18..622cd87 100644 --- a/src/Core/Binary.idr +++ b/src/Core/Binary.idr @@ -27,7 +27,7 @@ import Data.Buffer -- TTC files can only be compatible if the version number is the same export ttcVersion : Int -ttcVersion = 9 +ttcVersion = 10 export checkTTCVersion : Int -> Int -> Core () diff --git a/src/Core/Context.idr b/src/Core/Context.idr index 78bfa81..493d99d 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -469,8 +469,8 @@ HasNames (Term vars) where = pure (TDelayed fc x !(full gam y)) full gam (TDelay fc x t y) = pure (TDelay fc x !(full gam t) !(full gam y)) - full gam (TForce fc y) - = pure (TForce fc !(full gam y)) + full gam (TForce fc r y) + = pure (TForce fc r !(full gam y)) full gam tm = pure tm resolved gam (Ref fc x n) @@ -492,8 +492,8 @@ HasNames (Term vars) where = pure (TDelayed fc x !(resolved gam y)) resolved gam (TDelay fc x t y) = pure (TDelay fc x !(resolved gam t) !(resolved gam y)) - resolved gam (TForce fc y) - = pure (TForce fc !(resolved gam y)) + resolved gam (TForce fc r y) + = pure (TForce fc r !(resolved gam y)) resolved gam tm = pure tm mutual diff --git a/src/Core/Env.idr b/src/Core/Env.idr index 762c3b4..e471185 100644 --- a/src/Core/Env.idr +++ b/src/Core/Env.idr @@ -153,7 +153,7 @@ mutual = findUsed env used tm findUsed env used (TDelay fc r ty tm) = findUsed env (findUsed env used ty) tm - findUsed env used (TForce fc tm) + findUsed env used (TForce fc r tm) = findUsed env used tm findUsed env used _ = used diff --git a/src/Core/GetType.idr b/src/Core/GetType.idr index 757c832..7133053 100644 --- a/src/Core/GetType.idr +++ b/src/Core/GetType.idr @@ -52,10 +52,10 @@ mutual tm' <- getNF gtm defs <- get Ctxt pure $ glueBack defs env (NDelayed fc r tm') - chk env (TForce fc tm) + chk env (TForce fc r tm) = do tm' <- chk env tm case !(getNF tm') of - NDelayed fc r fty => + NDelayed fc _ fty => do defs <- get Ctxt pure $ glueBack defs env fty chk env (PrimVal fc x) = pure $ gnf env (chkConstant fc x) diff --git a/src/Core/Hash.idr b/src/Core/Hash.idr index ed6529a..625c525 100644 --- a/src/Core/Hash.idr +++ b/src/Core/Hash.idr @@ -114,7 +114,7 @@ mutual = h `hashWithSalt` 6 `hashWithSalt` y hashWithSalt h (TDelay fc x t y) = h `hashWithSalt` 7 `hashWithSalt` t `hashWithSalt` y - hashWithSalt h (TForce fc x) + hashWithSalt h (TForce fc r x) = h `hashWithSalt` 8 `hashWithSalt` x hashWithSalt h (PrimVal fc c) = h `hashWithSalt` 9 `hashWithSalt` (show c) diff --git a/src/Core/LinearCheck.idr b/src/Core/LinearCheck.idr index 6f09525..d6fedae 100644 --- a/src/Core/LinearCheck.idr +++ b/src/Core/LinearCheck.idr @@ -142,7 +142,7 @@ mutual = updateHoleUsage useInHole var t updateHoleUsage useInHole var (TDelay _ _ _ t) = updateHoleUsage useInHole var t - updateHoleUsage useInHole var (TForce _ t) + updateHoleUsage useInHole var (TForce _ _ t) = updateHoleUsage useInHole var t updateHoleUsage useInHole var tm = case getFnArgs tm of @@ -305,13 +305,13 @@ mutual (val', gty, u) <- lcheck rig erase env val ty <- getTerm gty pure (TDelay fc r ty' val', gnf env (TDelayed fc r ty), u) - lcheck rig erase env (TForce fc val) + lcheck rig erase env (TForce fc r val) = do (val', gty, u) <- lcheck rig erase env val tynf <- getNF gty case tynf of NDelayed _ r narg => do defs <- get Ctxt - pure (TForce fc val', glueBack defs env narg, u) + pure (TForce fc r val', glueBack defs env narg, u) _ => throw (GenericMsg fc "Not a delayed tyoe") lcheck rig erase env (PrimVal fc c) = pure (PrimVal fc c, gErased fc, []) diff --git a/src/Core/Normalise.idr b/src/Core/Normalise.idr index e4c5749..2da5f17 100644 --- a/src/Core/Normalise.idr +++ b/src/Core/Normalise.idr @@ -110,12 +110,12 @@ parameters (defs : Defs, topopts : EvalOpts) eval env locs (TDelay fc r ty tm) stk = pure (NDelay fc r (MkClosure topopts locs env ty) (MkClosure topopts locs env tm)) - eval env locs (TForce fc tm) stk + eval env locs (TForce fc r tm) stk = do tm' <- eval env locs tm [] case tm' of NDelay fc r _ arg => eval env (arg :: locs) (Local {name = UN "fvar"} fc Nothing _ First) stk - _ => pure (NForce fc tm' stk) + _ => pure (NForce fc r tm' stk) eval env locs (PrimVal fc c) stk = pure $ NPrimVal fc c eval env locs (Erased fc) stk = pure $ NErased fc eval env locs (TType fc) stk = pure $ NType fc @@ -555,14 +555,14 @@ mutual toHolesOnly (MkClosure _ locs env tm) = MkClosure withHoles locs env tm toHolesOnly c = c - quoteGenNF q defs bound env (NForce fc arg args) + quoteGenNF q defs bound env (NForce fc r arg args) = do args' <- quoteArgs q defs bound env args case arg of NDelay fc _ _ arg => do argNF <- evalClosure defs arg pure $ apply fc !(quoteGenNF q defs bound env argNF) args' t => do arg' <- quoteGenNF q defs bound env arg - pure $ apply fc (TForce fc arg') args' + pure $ apply fc (TForce fc r arg') args' quoteGenNF q defs bound env (NPrimVal fc c) = pure $ PrimVal fc c quoteGenNF q defs bound env (NErased fc) = pure $ Erased fc quoteGenNF q defs bound env (NType fc) = pure $ TType fc @@ -727,9 +727,11 @@ mutual = if compatible r r' then convGen q defs env arg arg' else pure False - convGen q defs env (NForce _ arg args) (NForce _ arg' args') - = if !(convGen q defs env arg arg') - then allConv q defs env args args' + convGen q defs env (NForce _ r arg args) (NForce _ r' arg' args') + = if compatible r r' + then if !(convGen q defs env arg arg') + then allConv q defs env args args' + else pure False else pure False convGen q defs env (NPrimVal _ c) (NPrimVal _ c') = pure (c == c') @@ -887,10 +889,10 @@ replace' {vars} tmpi defs env lhs parg tm = do ty' <- replace' tmpi defs env lhs parg !(evalClosure defs ty) tm' <- replace' tmpi defs env lhs parg !(evalClosure defs tm) pure (TDelay fc r ty' tm') - repSub (NForce fc tm args) + repSub (NForce fc r tm args) = do args' <- traverse repArg args tm' <- repSub tm - pure $ apply fc (TForce fc tm') args' + pure $ apply fc (TForce fc r tm') args' repSub tm = do empty <- clearDefs defs quote empty env tm diff --git a/src/Core/TT.idr b/src/Core/TT.idr index 98c93ea..b419b92 100644 --- a/src/Core/TT.idr +++ b/src/Core/TT.idr @@ -394,7 +394,7 @@ data Term : List Name -> Type where -- Typed laziness annotations TDelayed : FC -> LazyReason -> Term vars -> Term vars TDelay : FC -> LazyReason -> (ty : Term vars) -> (arg : Term vars) -> Term vars - TForce : FC -> Term vars -> Term vars + TForce : FC -> LazyReason -> Term vars -> Term vars PrimVal : FC -> (c : Constant) -> Term vars Erased : FC -> Term vars TType : FC -> Term vars @@ -409,7 +409,7 @@ getLoc (App fc _ _) = fc getLoc (As fc _ _) = fc getLoc (TDelayed fc _ _) = fc getLoc (TDelay fc _ _ _) = fc -getLoc (TForce fc _) = fc +getLoc (TForce fc _ _) = fc getLoc (PrimVal fc _) = fc getLoc (Erased fc) = fc getLoc (TType fc) = fc @@ -449,7 +449,7 @@ Eq (Term vars) where (==) (As _ a p) (As _ a' p') = a == a' && p == p' (==) (TDelayed _ _ t) (TDelayed _ _ t') = t == t' (==) (TDelay _ _ t x) (TDelay _ _ t' x') = t == t' && x == x' - (==) (TForce _ t) (TForce _ t') = t == t' + (==) (TForce _ _ t) (TForce _ _ t') = t == t' (==) (PrimVal _ c) (PrimVal _ c') = c == c' (==) (Erased _) (Erased _) = True (==) (TType _) (TType _) = True @@ -625,7 +625,7 @@ thin n (App fc fn arg) = App fc (thin n fn) (thin n arg) thin n (As fc nm tm) = As fc (thin n nm) (thin n tm) thin n (TDelayed fc r ty) = TDelayed fc r (thin n ty) thin n (TDelay fc r ty tm) = TDelay fc r (thin n ty) (thin n tm) -thin n (TForce fc tm) = TForce fc (thin n tm) +thin n (TForce fc r tm) = TForce fc r (thin n tm) thin n (PrimVal fc c) = PrimVal fc c thin n (Erased fc) = Erased fc thin n (TType fc) = TType fc @@ -650,7 +650,7 @@ insertNames ns (As fc as tm) insertNames ns (TDelayed fc r ty) = TDelayed fc r (insertNames ns ty) insertNames ns (TDelay fc r ty tm) = TDelay fc r (insertNames ns ty) (insertNames ns tm) -insertNames ns (TForce fc tm) = TForce fc (insertNames ns tm) +insertNames ns (TForce fc r tm) = TForce fc r (insertNames ns tm) insertNames ns (PrimVal fc c) = PrimVal fc c insertNames ns (Erased fc) = Erased fc insertNames ns (TType fc) = TType fc @@ -765,7 +765,7 @@ renameVars prf (As fc as tm) renameVars prf (TDelayed fc r ty) = TDelayed fc r (renameVars prf ty) renameVars prf (TDelay fc r ty tm) = TDelay fc r (renameVars prf ty) (renameVars prf tm) -renameVars prf (TForce fc x) = TForce fc (renameVars prf x) +renameVars prf (TForce fc r x) = TForce fc r (renameVars prf x) renameVars prf (PrimVal fc c) = PrimVal fc c renameVars prf (Erased fc) = Erased fc renameVars prf (TType fc) = TType fc @@ -845,8 +845,8 @@ mutual = Just (TDelayed fc x !(shrinkTerm y prf)) shrinkTerm (TDelay fc x t y) prf = Just (TDelay fc x !(shrinkTerm t prf) !(shrinkTerm y prf)) - shrinkTerm (TForce fc x) prf - = Just (TForce fc !(shrinkTerm x prf)) + shrinkTerm (TForce fc r x) prf + = Just (TForce fc r !(shrinkTerm x prf)) shrinkTerm (PrimVal fc c) prf = Just (PrimVal fc c) shrinkTerm (Erased fc) prf = Just (Erased fc) shrinkTerm (TType fc) prf = Just (TType fc) @@ -902,8 +902,8 @@ mkLocals bs (TDelayed fc x y) = TDelayed fc x (mkLocals bs y) mkLocals bs (TDelay fc x t y) = TDelay fc x (mkLocals bs t) (mkLocals bs y) -mkLocals bs (TForce fc x) - = TForce fc (mkLocals bs x) +mkLocals bs (TForce fc r x) + = TForce fc r (mkLocals bs x) mkLocals bs (PrimVal fc c) = PrimVal fc c mkLocals bs (Erased fc) = Erased fc mkLocals bs (TType fc) = TType fc @@ -946,8 +946,8 @@ resolveNames vars (TDelayed fc x y) = TDelayed fc x (resolveNames vars y) resolveNames vars (TDelay fc x t y) = TDelay fc x (resolveNames vars t) (resolveNames vars y) -resolveNames vars (TForce fc x) - = TForce fc (resolveNames vars x) +resolveNames vars (TForce fc r x) + = TForce fc r (resolveNames vars x) resolveNames vars tm = tm @@ -996,7 +996,7 @@ namespace SubstEnv substEnv env (TDelayed fc x y) = TDelayed fc x (substEnv env y) substEnv env (TDelay fc x t y) = TDelay fc x (substEnv env t) (substEnv env y) - substEnv env (TForce fc x) = TForce fc (substEnv env x) + substEnv env (TForce fc r x) = TForce fc r (substEnv env x) substEnv env (PrimVal fc c) = PrimVal fc c substEnv env (Erased fc) = Erased fc substEnv env (TType fc) = TType fc @@ -1030,8 +1030,8 @@ 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 y) - = TForce fc (substName x new y) +substName x new (TForce fc r y) + = TForce fc r (substName x new y) substName x new tm = tm export @@ -1053,7 +1053,7 @@ addMetas ns (As fc as tm) = addMetas ns tm addMetas ns (TDelayed fc x y) = addMetas ns y addMetas ns (TDelay fc x t y) = addMetas (addMetas ns t) y -addMetas ns (TForce fc x) = addMetas ns x +addMetas ns (TForce fc r x) = addMetas ns x addMetas ns (PrimVal fc c) = ns addMetas ns (Erased fc) = ns addMetas ns (TType fc) = ns @@ -1088,7 +1088,7 @@ addRefs ua at ns (As fc as tm) = addRefs ua at ns tm addRefs ua at ns (TDelayed fc x y) = addRefs ua at ns y addRefs ua at ns (TDelay fc x t y) = addRefs ua at (addRefs ua at ns t) y -addRefs ua at ns (TForce fc x) = addRefs ua at ns x +addRefs ua at ns (TForce fc r x) = addRefs ua at ns x addRefs ua at ns (PrimVal fc c) = ns addRefs ua at ns (Erased fc) = ns addRefs ua at ns (TType fc) = ns @@ -1143,7 +1143,7 @@ export Show (Term vars) where showApp (As _ n tm) [] = show n ++ "@" ++ show tm showApp (TDelayed _ _ tm) [] = "%Delayed " ++ show tm showApp (TDelay _ _ _ tm) [] = "%Delay " ++ show tm - showApp (TForce _ tm) [] = "%Force " ++ show tm + showApp (TForce _ _ tm) [] = "%Force " ++ show tm showApp (PrimVal _ c) [] = show c showApp (Erased _) [] = "[__]" showApp (TType _) [] = "Type" diff --git a/src/Core/TTC.idr b/src/Core/TTC.idr index 8feb80d..cd78626 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -232,9 +232,9 @@ mutual toBuf b (TDelay fc r ty tm) = do tag 7; toBuf b r; toBuf b ty; toBuf b tm - toBuf b (TForce fc tm) + toBuf b (TForce fc r tm) = do tag 8; - toBuf b tm + toBuf b r; toBuf b tm toBuf b (PrimVal fc c) = do tag 9; toBuf b c @@ -267,8 +267,8 @@ mutual 7 => do lr <- fromBuf b; ty <- fromBuf b; tm <- fromBuf b pure (TDelay emptyFC lr ty tm) - 8 => do tm <- fromBuf b - pure (TForce emptyFC tm) + 8 => do lr <- fromBuf b; tm <- fromBuf b + pure (TForce emptyFC lr tm) 9 => do c <- fromBuf b pure (PrimVal emptyFC c) 10 => pure (Erased emptyFC) diff --git a/src/Core/Termination.idr b/src/Core/Termination.idr index 5c0e15a..7964ec9 100644 --- a/src/Core/Termination.idr +++ b/src/Core/Termination.idr @@ -49,7 +49,7 @@ scEq (As _ a p) p' = scEq p p' scEq p (As _ a p') = scEq p p' scEq (TDelayed _ _ t) (TDelayed _ _ t') = scEq t t' scEq (TDelay _ _ t x) (TDelay _ _ t' x') = scEq t t' && scEq x x' -scEq (TForce _ t) (TForce _ t') = scEq t t' +scEq (TForce _ _ t) (TForce _ _ t') = scEq t t' scEq (PrimVal _ c) (PrimVal _ c') = c == c' scEq (Erased _) (Erased _) = True scEq (TType _) (TType _) = True @@ -218,7 +218,7 @@ mutual urhs (TDelayed fc r ty) = TDelayed fc r (updateRHS ms ty) urhs (TDelay fc r ty tm) = TDelay fc r (updateRHS ms ty) (updateRHS ms tm) - urhs (TForce fc tm) = TForce fc (updateRHS ms tm) + urhs (TForce fc r tm) = TForce fc r (updateRHS ms tm) urhs (Bind fc x b sc) = Bind fc x (map (updateRHS ms) b) (updateRHS (map (\vt => (weaken (fst vt), weaken (snd vt))) ms) sc) @@ -278,8 +278,8 @@ mutual rhs <- normaliseOpts tcOnly defs env tm findSC defs env g pats rhs --- Remove all laziness annotations which are nothing to do with coinduction, --- meaning that all only Force/Delay left is to guard coinductive calls. +-- Remove all force and delay annotations which are nothing to do with +-- coinduction meaning that all Delays left guard coinductive calls. delazy : Defs -> Term vars -> Term vars delazy defs (TDelayed fc r tm) = let tm' = delazy defs tm in @@ -292,6 +292,10 @@ delazy defs (TDelay fc r ty tm) case r of LInf => TDelay fc r ty' tm' _ => tm' +delazy defs (TForce fc r t) + = case r of + LInf => TForce fc r (delazy defs t) + _ => delazy defs t delazy defs (Meta fc n i args) = Meta fc n i (map (delazy defs) args) delazy defs (Bind fc x b sc) = Bind fc x (map (delazy defs) b) (delazy defs sc) diff --git a/src/Core/Unify.idr b/src/Core/Unify.idr index a7792d0..2b74e20 100644 --- a/src/Core/Unify.idr +++ b/src/Core/Unify.idr @@ -32,12 +32,12 @@ Eq UnifyMode where -- explicit force or delay to the first argument to unification. This says -- which to add, if any. Can only added at the very top level. public export -data AddLazy = NoLazy | AddForce | AddDelay LazyReason +data AddLazy = NoLazy | AddForce LazyReason | AddDelay LazyReason export Show AddLazy where show NoLazy = "NoLazy" - show AddForce = "AddForce" + show (AddForce _) = "AddForce" show (AddDelay _) = "AddDelay" public export @@ -895,7 +895,7 @@ mutual = unify mode loc env x y unifyNoEta mode loc env (NDelay xfc _ xty x) (NDelay yfc _ yty y) = unifyArgs mode loc env [xty, x] [yty, y] - unifyNoEta mode loc env (NForce xfc x axs) (NForce yfc y ays) + unifyNoEta mode loc env (NForce xfc _ x axs) (NForce yfc _ y ays) = do cs <- unify mode loc env x y cs' <- unifyArgs mode loc env axs ays pure (union cs cs') @@ -984,7 +984,7 @@ mutual = unify mode loc env tmx tmy unifyWithLazyD _ _ mode loc env (NDelayed _ r tmx) tmy = do vs <- unify mode loc env tmx tmy - pure (record { addLazy = AddForce } vs) + pure (record { addLazy = AddForce r } vs) unifyWithLazyD _ _ mode loc env tmx (NDelayed _ r tmy) = do vs <- unify mode loc env tmx tmy pure (record { addLazy = AddDelay r } vs) @@ -1072,10 +1072,10 @@ delayMeta r (S k) ty (Bind fc n b sc) = Bind fc n b (delayMeta r k (weaken ty) sc) delayMeta r envb ty tm = TDelay (getLoc tm) r ty tm -forceMeta : Nat -> Term vars -> Term vars -forceMeta (S k) (Bind fc n b sc) - = Bind fc n b (forceMeta k sc) -forceMeta envb tm = TForce (getLoc tm) tm +forceMeta : LazyReason -> Nat -> Term vars -> Term vars +forceMeta r (S k) (Bind fc n b sc) + = Bind fc n b (forceMeta r k sc) +forceMeta r envb tm = TForce (getLoc tm) r tm -- Retry the given constraint, return True if progress was made retryGuess : {auto c : Ref Ctxt Defs} -> @@ -1117,7 +1117,7 @@ retryGuess mode smode (hid, (loc, hname)) case constraints cs of [] => do tm' <- case addLazy cs of NoLazy => pure tm - AddForce => pure $ forceMeta envb tm + AddForce r => pure $ forceMeta r envb tm AddDelay r => do ty <- getType [] tm pure $ delayMeta r envb !(getTerm ty) tm diff --git a/src/Core/Value.idr b/src/Core/Value.idr index f737e76..2f123f2 100644 --- a/src/Core/Value.idr +++ b/src/Core/Value.idr @@ -78,7 +78,7 @@ mutual NAs : FC -> NF vars -> NF vars -> NF vars NDelayed : FC -> LazyReason -> NF vars -> NF vars NDelay : FC -> LazyReason -> Closure vars -> Closure vars -> NF vars - NForce : FC -> NF vars -> List (Closure vars) -> NF vars + NForce : FC -> LazyReason -> NF vars -> List (Closure vars) -> NF vars NPrimVal : FC -> Constant -> NF vars NErased : FC -> NF vars NType : FC -> NF vars @@ -92,7 +92,7 @@ getLoc (NTCon fc _ _ _ _) = fc getLoc (NAs fc _ _) = fc getLoc (NDelayed fc _ _) = fc getLoc (NDelay fc _ _ _) = fc -getLoc (NForce fc _ _) = fc +getLoc (NForce fc _ _ _) = fc getLoc (NPrimVal fc _) = fc getLoc (NErased fc) = fc getLoc (NType fc) = fc diff --git a/src/TTImp/Elab/App.idr b/src/TTImp/Elab/App.idr index aaf6237..1a55e91 100644 --- a/src/TTImp/Elab/App.idr +++ b/src/TTImp/Elab/App.idr @@ -369,7 +369,7 @@ mutual tm x aty sc arg expargs impargs kr expty -- Function type is delayed, so force the term and continue checkAppWith rig elabinfo nest env fc tm (NDelayed dfc r ty@(NBind _ _ (Pi _ _ _) sc)) expargs impargs kr expty - = checkAppWith rig elabinfo nest env fc (TForce dfc tm) ty expargs impargs kr expty + = checkAppWith rig elabinfo nest env fc (TForce dfc r tm) ty expargs impargs kr expty -- If there's no more arguments given, and the plicities of the type and -- the expected type line up, stop checkAppWith rig elabinfo nest env fc tm ty@(NBind tfc x (Pi rigb Implicit aty) sc) diff --git a/src/TTImp/Elab/Case.idr b/src/TTImp/Elab/Case.idr index da3941a..4ea1886 100644 --- a/src/TTImp/Elab/Case.idr +++ b/src/TTImp/Elab/Case.idr @@ -37,8 +37,8 @@ changeVar old new (TDelayed fc r p) = TDelayed fc r (changeVar old new p) changeVar old new (TDelay fc r t p) = TDelay fc r (changeVar old new t) (changeVar old new p) -changeVar old new (TForce fc p) - = TForce fc (changeVar old new p) +changeVar old new (TForce fc r p) + = TForce fc r (changeVar old new p) changeVar old new tm = tm findLater : (x : Name) -> (newer : List Name) -> Var (newer ++ x :: older) diff --git a/src/TTImp/Elab/Check.idr b/src/TTImp/Elab/Check.idr index 2b8d701..1af484f 100644 --- a/src/TTImp/Elab/Check.idr +++ b/src/TTImp/Elab/Check.idr @@ -588,10 +588,10 @@ checkExp rig elabinfo env fc tm got (Just exp) [] => case addLazy vs of NoLazy => do logTerm 5 "Solved" tm pure (tm, got) - AddForce => do logTerm 5 "Force" tm - logGlue 5 "Got" env got - logGlue 5 "Exp" env exp - pure (TForce fc tm, exp) + AddForce r => do logTerm 5 "Force" tm + logGlue 5 "Got" env got + logGlue 5 "Exp" env exp + pure (TForce fc r tm, exp) AddDelay r => do ty <- getTerm got logTerm 5 "Delay" tm pure (TDelay fc r ty tm, exp) @@ -603,7 +603,7 @@ checkExp rig elabinfo env fc tm got (Just exp) dumpConstraints 5 False case addLazy vs of NoLazy => pure (ctm, got) - AddForce => pure (TForce fc tm, got) + AddForce r => pure (TForce fc r tm, got) AddDelay r => do ty <- getTerm got pure (TDelay fc r ty tm, got) checkExp rig elabinfo env fc tm got Nothing = pure (tm, got) diff --git a/src/TTImp/Elab/ImplicitBind.idr b/src/TTImp/Elab/ImplicitBind.idr index 8128aba..73a92da 100644 --- a/src/TTImp/Elab/ImplicitBind.idr +++ b/src/TTImp/Elab/ImplicitBind.idr @@ -47,7 +47,7 @@ mutual embedSub sub (TDelayed fc x y) = TDelayed fc x (embedSub sub y) embedSub sub (TDelay fc x t y) = TDelay fc x (embedSub sub t) (embedSub sub y) - embedSub sub (TForce fc x) = TForce fc (embedSub sub x) + embedSub sub (TForce fc r x) = TForce fc r (embedSub sub x) embedSub sub (PrimVal fc c) = PrimVal fc c embedSub sub (Erased fc) = Erased fc embedSub sub (TType fc) = TType fc @@ -202,7 +202,7 @@ swapVars (App fc fn arg) = App fc (swapVars fn) (swapVars arg) swapVars (As fc nm pat) = As fc (swapVars nm) (swapVars pat) swapVars (TDelayed fc x tm) = TDelayed fc x (swapVars tm) swapVars (TDelay fc x ty tm) = TDelay fc x (swapVars ty) (swapVars tm) -swapVars (TForce fc tm) = TForce fc (swapVars tm) +swapVars (TForce fc r tm) = TForce fc r (swapVars tm) swapVars (PrimVal fc c) = PrimVal fc c swapVars (Erased fc) = Erased fc swapVars (TType fc) = TType fc diff --git a/src/TTImp/Elab/Lazy.idr b/src/TTImp/Elab/Lazy.idr index 1467bb6..56bddf3 100644 --- a/src/TTImp/Elab/Lazy.idr +++ b/src/TTImp/Elab/Lazy.idr @@ -87,6 +87,6 @@ checkForce rig elabinfo nest env fc tm exp (tm', gty) <- check rig elabinfo nest env tm expf tynf <- getNF gty case tynf of - NDelayed _ _ expnf => - pure (TForce fc tm', glueBack defs env expnf) + NDelayed _ r expnf => + pure (TForce fc r tm', glueBack defs env expnf) _ => throw (GenericMsg fc "Forcing a non-delayed type") diff --git a/src/TTImp/Elab/Term.idr b/src/TTImp/Elab/Term.idr index cc004a6..f2901fd 100644 --- a/src/TTImp/Elab/Term.idr +++ b/src/TTImp/Elab/Term.idr @@ -49,7 +49,7 @@ insertImpLam {vars} env tm (Just ty) = bindLam tm ty bindLamTm tm exp = case getFn exp of Ref _ Func _ => pure Nothing -- might still be implicit - TForce _ _ => pure Nothing + TForce _ _ _ => pure Nothing Bind _ _ (Lam _ _ _) _ => pure Nothing _ => pure $ Just tm diff --git a/src/TTImp/Interactive/MakeLemma.idr b/src/TTImp/Interactive/MakeLemma.idr index 7a74c71..8ccbd2d 100644 --- a/src/TTImp/Interactive/MakeLemma.idr +++ b/src/TTImp/Interactive/MakeLemma.idr @@ -28,7 +28,7 @@ bindable p tm (Ref _ (DataCon _ _) _, args) => any (bindable p) args (TDelayed _ _ t, args) => any (bindable p) (t :: args) (TDelay _ _ _ t, args) => any (bindable p) (t :: args) - (TForce _ t, args) => any (bindable p) (t :: args) + (TForce _ _ t, args) => any (bindable p) (t :: args) (Local _ _ p' _, []) => p == p' _ => False diff --git a/src/TTImp/Unelab.idr b/src/TTImp/Unelab.idr index 134dfdb..86084c4 100644 --- a/src/TTImp/Unelab.idr +++ b/src/TTImp/Unelab.idr @@ -23,7 +23,7 @@ used idx (App _ f a) = used idx f || used idx a used idx (As _ _ pat) = used idx pat used idx (TDelayed _ _ tm) = used idx tm used idx (TDelay _ _ _ tm) = used idx tm -used idx (TForce _ tm) = used idx tm +used idx (TForce _ _ tm) = used idx tm used idx _ = False data IArg @@ -176,7 +176,7 @@ mutual = do (tm', ty) <- unelabTy' umode env tm defs <- get Ctxt pure (IDelay fc tm', gErased fc) - unelabTy' umode env (TForce fc tm) + unelabTy' umode env (TForce fc r tm) = do (tm', ty) <- unelabTy' umode env tm defs <- get Ctxt pure (IForce fc tm', gErased fc) From a3dc1ff2287d76afa7c2b0202bcc9f49075578ea Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Wed, 13 Nov 2019 17:57:39 +0100 Subject: [PATCH 11/18] Add ITransform to TTImp This is for rewrite rules/transformations which arise from partial evaluation. Details not yet implemented. --- src/Core/Context.idr | 47 +++++++++++++++++++++++++++++++++++--- src/Core/TTC.idr | 14 ++++++++++++ src/Core/Transform.idr | 10 ++++++++ src/Idris/Desugar.idr | 4 ++++ src/Idris/Resugar.idr | 3 +++ src/Idris/Syntax.idr | 1 + src/TTImp/Elab.idr | 1 + src/TTImp/ProcessDecls.idr | 2 ++ src/TTImp/TTImp.idr | 11 +++++++-- 9 files changed, 88 insertions(+), 5 deletions(-) create mode 100644 src/Core/Transform.idr diff --git a/src/Core/Context.idr b/src/Core/Context.idr index 493d99d..4985eba 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -429,6 +429,23 @@ newDef fc n rig vars ty vis def = MkGlobalDef fc n ty [] rig vars vis unchecked [] empty False False False def Nothing [] +-- Rewrite rules, applied after type checking, for runtime code only +-- LHS and RHS must have the same type, but we don't (currently) require that +-- the result still type checks (which might happen e.g. if transforming to a +-- faster implementation with different behaviour) +-- (Q: Do we need the 'Env' here? Usually we end up needing an 'Env' with a +-- 'NF but we're working with terms rather than values...) +public export +data Transform : Type where + MkTransform : Env Term vars -> Term vars -> Term vars -> Transform + +export +getFnName : Transform -> Maybe Name +getFnName (MkTransform _ app _) + = case getFn app of + Ref _ _ fn => Just fn + _ => Nothing + public export interface HasNames a where full : Context -> a -> Core a @@ -673,6 +690,15 @@ HasNames GlobalDef where sizeChange = !(traverse (resolved gam) (sizeChange def)) } def +export +HasNames Transform where + full gam (MkTransform env lhs rhs) + = pure $ MkTransform !(full gam env) !(full gam lhs) !(full gam rhs) + + resolved gam (MkTransform env lhs rhs) + = pure $ MkTransform !(resolved gam env) + !(resolved gam lhs) !(resolved gam rhs) + public export record Defs where constructor MkDefs @@ -701,6 +727,10 @@ record Defs where -- We don't look up anything in here, it's merely for saving out to TTC. -- We save the hints in the 'GlobalDef' itself for faster lookup. saveAutoHints : List (Name, Bool) + transforms : NameMap Transform + -- ^ A mapping from names to transformation rules which update applications + -- of that name + saveTransforms : List (Name, Transform) namedirectives : List (Name, List String) ifaceHash : Int importHashes : List (List String, Int) @@ -737,9 +767,9 @@ initDefs : Core Defs initDefs = do gam <- initCtxt pure (MkDefs gam [] ["Main"] [] defaults empty 100 - empty empty empty [] [] [] 5381 [] [] [] [] [] empty - empty) - + empty empty empty [] [] empty [] + [] 5381 [] [] [] [] [] empty empty) + -- Reset the context, except for the options export clearCtxt : {auto c : Ref Ctxt Defs} -> @@ -1298,6 +1328,17 @@ setOpenHints hs = do d <- get Ctxt put Ctxt (record { openHints = hs } d) +export +addTransform : {auto c : Ref Ctxt Defs} -> + FC -> Transform -> Core () +addTransform fc t + = do defs <- get Ctxt + let Just fn = getFnName t + | Nothing => + throw (GenericMsg fc "LHS of a transformation must be a function application") + put Ctxt (record { transforms $= insert fn t, + saveTransforms $= ((fn, t) ::) } defs) + export clearSavedHints : {auto c : Ref Ctxt Defs} -> Core () clearSavedHints diff --git a/src/Core/TTC.idr b/src/Core/TTC.idr index cd78626..f35a274 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -881,6 +881,20 @@ TTC GlobalDef where RigW [] Public unchecked [] refs False False True def cdef []) +TTC Transform where + toBuf b (MkTransform {vars} env lhs rhs) + = do toBuf b vars + toBuf b env + toBuf b lhs + toBuf b rhs + + fromBuf b + = do vars <- fromBuf b + env <- fromBuf b + lhs <- fromBuf b + rhs <- fromBuf b + pure (MkTransform {vars} env lhs rhs) + -- decode : Context -> Int -> ContextEntry -> Core GlobalDef Core.Context.decode gam idx (Coded bin) = do b <- newRef Bin bin diff --git a/src/Core/Transform.idr b/src/Core/Transform.idr new file mode 100644 index 0000000..8a5ad2c --- /dev/null +++ b/src/Core/Transform.idr @@ -0,0 +1,10 @@ +module Core.Transform + +import Core.Context +import Core.Env +import Core.TT + +export +applyTransforms : {auto c : Ref Ctxt Defs} -> + Term vars -> Core (Term vars) +applyTransforms t = pure t -- TODO! diff --git a/src/Idris/Desugar.idr b/src/Idris/Desugar.idr index 4a674a9..c465b0a 100644 --- a/src/Idris/Desugar.idr +++ b/src/Idris/Desugar.idr @@ -624,6 +624,10 @@ mutual desugarDecl ps (PNamespace fc ns decls) = do ds <- traverse (desugarDecl ps) decls pure [INamespace fc False ns (concat ds)] + desugarDecl ps (PTransform fc lhs rhs) + = do (bound, blhs) <- bindNames False !(desugar LHS ps lhs) + rhs' <- desugar AnyExpr (bound ++ ps) rhs + pure [ITransform fc blhs rhs'] desugarDecl ps (PDirective fc d) = case d of Hide n => pure [IPragma (\c, nest, env => hide fc n)] diff --git a/src/Idris/Resugar.idr b/src/Idris/Resugar.idr index 0ba37cc..7aaf3f7 100644 --- a/src/Idris/Resugar.idr +++ b/src/Idris/Resugar.idr @@ -337,6 +337,9 @@ mutual toPDecl (INamespace fc _ ns ds) = do ds' <- traverse toPDecl ds pure (Just (PNamespace fc ns (mapMaybe id ds'))) + toPDecl (ITransform fc lhs rhs) + = pure (Just (PTransform fc !(toPTerm startPrec lhs) + !(toPTerm startPrec rhs))) toPDecl (IPragma _) = pure Nothing toPDecl (ILog _) = pure Nothing diff --git a/src/Idris/Syntax.idr b/src/Idris/Syntax.idr index 9546a83..d56b4ab 100644 --- a/src/Idris/Syntax.idr +++ b/src/Idris/Syntax.idr @@ -217,6 +217,7 @@ mutual PMutual : FC -> List PDecl -> PDecl PFixity : FC -> Fixity -> Nat -> OpStr -> PDecl PNamespace : FC -> List String -> List PDecl -> PDecl + PTransform : FC -> PTerm -> PTerm -> PDecl PDirective : FC -> Directive -> PDecl definedInData : PDataDecl -> List Name diff --git a/src/TTImp/Elab.idr b/src/TTImp/Elab.idr index 0cd0d59..ebd13e6 100644 --- a/src/TTImp/Elab.idr +++ b/src/TTImp/Elab.idr @@ -6,6 +6,7 @@ import Core.Env import Core.LinearCheck import Core.Metadata import Core.Normalise +import Core.Transform import Core.UnifyState import Core.Unify diff --git a/src/TTImp/ProcessDecls.idr b/src/TTImp/ProcessDecls.idr index 005d93d..be148f9 100644 --- a/src/TTImp/ProcessDecls.idr +++ b/src/TTImp/ProcessDecls.idr @@ -46,6 +46,8 @@ process eopts nest env (INamespace fc nested ns decls) nestedNS = if nested then newns :: nns else nns } defs) +process eopts nest env (ITransform fc lhs rhs) + = throw (GenericMsg fc "%transform not yet implemented") process {c} eopts nest env (IPragma act) = act c nest env process eopts nest env (ILog n) diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index c4f0f06..ce9ae15 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -285,6 +285,7 @@ mutual -- ^ if True, parent namespaces in the same file can also -- look inside and see private/export names in full List String -> List ImpDecl -> ImpDecl + ITransform : FC -> RawImp -> RawImp -> ImpDecl IPragma : ({vars : _} -> Ref Ctxt Defs -> NestedNames vars -> Env Term vars -> Core ()) -> ImpDecl @@ -302,6 +303,8 @@ mutual show (INamespace _ nest ns decls) = "namespace " ++ if nest then "[nested] " else "" ++ show ns ++ showSep "\n" (assert_total $ map show decls) + show (ITransform _ lhs rhs) + = "%transform " ++ show lhs ++ " ==> " ++ show rhs show (IPragma _) = "[externally defined pragma]" show (ILog lvl) = "%logging " ++ show lvl @@ -836,9 +839,11 @@ mutual = do tag 4; toBuf b fc; toBuf b vis; toBuf b r toBuf b (INamespace fc n xs ds) = do tag 5; toBuf b fc; toBuf b n; toBuf b xs; toBuf b ds + toBuf b (ITransform fc lhs rhs) + = do tag 6; toBuf b fc; toBuf b lhs; toBuf b rhs toBuf b (IPragma f) = throw (InternalError "Can't write Pragma") toBuf b (ILog n) - = do tag 6; toBuf b n + = do tag 7; toBuf b n fromBuf b = case !getTag of @@ -861,7 +866,9 @@ mutual 5 => do fc <- fromBuf b; n <- fromBuf b; xs <- fromBuf b ds <- fromBuf b pure (INamespace fc n xs ds) - 6 => do n <- fromBuf b + 6 => do fc <- fromBuf b; lhs <- fromBuf b; rhs <- fromBuf b + pure (ITransform fc lhs rhs) + 7 => do n <- fromBuf b pure (ILog n) _ => corrupt "ImpDecl" From f0da43156a5d387b55afe9bd0b9bb141016c4c83 Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Sat, 23 Nov 2019 14:44:31 +0000 Subject: [PATCH 12/18] Use latest bound name in building case function We were using the least recently bound, leading to the wrong type being shown in some cases with shadowing --- src/TTImp/Elab/Case.idr | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/TTImp/Elab/Case.idr b/src/TTImp/Elab/Case.idr index a60340e..2a20e33 100644 --- a/src/TTImp/Elab/Case.idr +++ b/src/TTImp/Elab/Case.idr @@ -342,19 +342,20 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected canBindName _ vs = Nothing addEnv : Env Term vs -> SubVars vs' vs -> List Name -> - (List (Maybe RawImp), List Name) - addEnv [] sub used = ([], used) + List (Maybe RawImp) + addEnv [] sub used = [] addEnv {vs = v :: vs} (b :: bs) SubRefl used - = let (rest, used') = addEnv bs SubRefl used in - (Nothing :: rest, used') + = let rest = addEnv bs SubRefl used in + Nothing :: rest addEnv (b :: bs) (KeepCons p) used - = let (rest, used') = addEnv bs p used in - (Nothing :: rest, used') + = let rest = addEnv bs p used in + Nothing :: rest addEnv {vs = v :: vs} (b :: bs) (DropCons p) used - = let (rest, used') = addEnv bs p used in - case canBindName v used' of - Just n => (Just (IAs fc UseLeft n (Implicit fc True)) :: rest, n :: used') - _ => (Just (Implicit fc True) :: rest, used') + = case canBindName v used of + Just n => let rest = addEnv bs p (n :: used) in + Just (IAs fc UseLeft n (Implicit fc True)) :: rest + _ => let rest = addEnv bs p used in + Just (Implicit fc True) :: rest -- Replace a variable in the argument list; if the reference is to -- a variable kept in the outer environment (therefore not an argument @@ -393,16 +394,16 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected Env Term vars -> SubVars vs' vars -> ImpClause -> ImpClause updateClause casen splitOn env sub (PatClause loc' lhs rhs) - = let args = fst (addEnv env sub (usedIn lhs)) + = let args = addEnv env sub (usedIn lhs) args' = mkSplit splitOn lhs args in PatClause loc' (apply (IVar loc' casen) args') rhs -- With isn't allowed in a case block but include for completeness updateClause casen splitOn env sub (WithClause loc' lhs wval cs) - = let args = fst (addEnv env sub (usedIn lhs)) + = let args = addEnv env sub (usedIn lhs) args' = mkSplit splitOn lhs args in WithClause loc' (apply (IVar loc' casen) args') wval cs updateClause casen splitOn env sub (ImpossibleClause loc' lhs) - = let args = fst (addEnv env sub (usedIn lhs)) + = let args = addEnv env sub (usedIn lhs) args' = mkSplit splitOn lhs args in ImpossibleClause loc' (apply (IVar loc' casen) args') From 1c006b647a974c199ab84c9d4886f8896eb43030 Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Sun, 24 Nov 2019 21:17:16 +0000 Subject: [PATCH 13/18] Reflect/reify for TTImp This is further progress towards a metaprogramming system in a form similar to Elaborator Reflection or Template Haskell, but trying to avoid leaking too many implementation details of the elaborator itself. --- idris2.ipkg | 1 + libs/base/Language/Reflection.idr | 140 +++++++ src/Core/Context.idr | 4 +- src/Core/Reflect.idr | 24 +- src/Core/Termination.idr | 4 +- src/Idris/REPL.idr | 4 +- src/TTImp/Elab/Term.idr | 2 + src/TTImp/Reflect.idr | 623 ++++++++++++++++++++++++++++++ 8 files changed, 794 insertions(+), 8 deletions(-) create mode 100644 src/TTImp/Reflect.idr diff --git a/idris2.ipkg b/idris2.ipkg index 6963bdc..6e26d15 100644 --- a/idris2.ipkg +++ b/idris2.ipkg @@ -110,6 +110,7 @@ modules = TTImp.ProcessParams, TTImp.ProcessRecord, TTImp.ProcessType, + TTImp.Reflect, TTImp.TTImp, TTImp.Unelab, TTImp.Utils, diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr index 0b71e53..231625f 100644 --- a/libs/base/Language/Reflection.idr +++ b/libs/base/Language/Reflection.idr @@ -75,3 +75,143 @@ data TT : List Name -> Type where Erased : FC -> TT vars TType : FC -> TT vars +public export +data Visibility = Private | Export | Public + +-- Unchecked terms and declarations in the intermediate language +mutual + public export + data BindMode = PI Count | PATTERN | NONE + + -- For as patterns matching linear arguments, select which side is + -- consumed + public export + data UseSide = UseLeft | UseRight + + data TTImp : Type where + IVar : FC -> Name -> TTImp + IPi : FC -> Count -> PiInfo -> Maybe Name -> + (argTy : TTImp) -> (retTy : TTImp) -> TTImp + ILam : FC -> Count -> PiInfo -> Maybe Name -> + (argTy : TTImp) -> (lamTy : TTImp) -> TTImp + ILet : FC -> Count -> Name -> + (nTy : TTImp) -> (nVal : TTImp) -> + (scope : TTImp) -> TTImp + ICase : FC -> TTImp -> (ty : TTImp) -> + List Clause -> TTImp + ILocal : FC -> List Decl -> TTImp -> TTImp + IUpdate : FC -> List IFieldUpdate -> TTImp -> TTImp + + IApp : FC -> TTImp -> TTImp -> TTImp + IImplicitApp : FC -> TTImp -> Maybe Name -> TTImp -> TTImp + IWithApp : FC -> TTImp -> TTImp -> TTImp + + ISearch : FC -> (depth : Nat) -> TTImp + IAlternative : FC -> AltType -> List TTImp -> TTImp + IRewrite : FC -> TTImp -> TTImp -> TTImp + + -- Any implicit bindings in the scope should be bound here, using + -- the given binder + IBindHere : FC -> BindMode -> TTImp -> TTImp + -- A name which should be implicitly bound + IBindVar : FC -> String -> TTImp + -- An 'as' pattern, valid on the LHS of a clause only + IAs : FC -> UseSide -> Name -> TTImp -> TTImp + -- A 'dot' pattern, i.e. one which must also have the given value + -- by unification + IMustUnify : FC -> (reason : String) -> TTImp -> TTImp + + -- Laziness annotations + IDelayed : FC -> LazyReason -> TTImp -> TTImp -- the type + IDelay : FC -> TTImp -> TTImp -- delay constructor + IForce : FC -> TTImp -> TTImp + + IPrimVal : FC -> (c : Constant) -> TTImp + IType : FC -> TTImp + IHole : FC -> String -> TTImp + + -- An implicit value, solved by unification, but which will also be + -- bound (either as a pattern variable or a type variable) if unsolved + -- at the end of elaborator + Implicit : FC -> (bindIfUnsolved : Bool) -> TTImp + + public export + data IFieldUpdate : Type where + ISetField : (path : List String) -> TTImp -> IFieldUpdate + ISetFieldApp : (path : List String) -> TTImp -> IFieldUpdate + + public export + data AltType : Type where + FirstSuccess : AltType + Unique : AltType + UniqueDefault : TTImp -> AltType + + public export + data FnOpt : Type where + Inline : FnOpt + -- Flag means the hint is a direct hint, not a function which might + -- find the result (e.g. chasing parent interface dictionaries) + Hint : Bool -> FnOpt + -- Flag means to use as a default if all else fails + GlobalHint : Bool -> FnOpt + ExternFn : FnOpt + -- Defined externally, list calling conventions + ForeignFn : List String -> FnOpt + -- assume safe to cancel arguments in unification + Invertible : FnOpt + Total : FnOpt + Covering : FnOpt + PartialOK : FnOpt + + public export + data ITy : Type where + MkTy : FC -> (n : Name) -> (ty : TTImp) -> ITy + + public export + data DataOpt : Type where + SearchBy : List Name -> DataOpt -- determining arguments + NoHints : DataOpt -- Don't generate search hints for constructors + + public export + data Data : Type where + MkData : FC -> (n : Name) -> (tycon : TTImp) -> + (opts : List DataOpt) -> + (datacons : List ITy) -> Data + MkLater : FC -> (n : Name) -> (tycon : TTImp) -> Data + + public export + data IField : Type where + MkIField : FC -> Count -> PiInfo -> Name -> TTImp -> + IField + + public export + data Record : Type where + MkRecord : FC -> (n : Name) -> + (params : List (Name, TTImp)) -> + (conName : Maybe Name) -> + (fields : List IField) -> + Record + + public export + data Clause : Type where + PatClause : FC -> (lhs : TTImp) -> (rhs : TTImp) -> Clause + WithClause : FC -> (lhs : TTImp) -> (wval : TTImp) -> + List Clause -> Clause + ImpossibleClause : FC -> (lhs : TTImp) -> Clause + + public export + data Decl : Type where + IClaim : FC -> Count -> Visibility -> List FnOpt -> + ITy -> Decl + IData : FC -> Visibility -> Data -> Decl + IDef : FC -> Name -> List Clause -> Decl + IParameters : FC -> List (Name, TTImp) -> + List Decl -> Decl + IRecord : FC -> Visibility -> Record -> Decl + INamespace : FC -> + (nested : Bool) -> + -- ^ if True, parent namespaces in the same file can also + -- look inside and see private/export names in full + List String -> List Decl -> Decl + ITransform : FC -> TTImp -> TTImp -> Decl + ILog : Nat -> Decl diff --git a/src/Core/Context.idr b/src/Core/Context.idr index 982a39d..33dcfa6 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -696,7 +696,7 @@ HasNames Transform where = pure $ MkTransform !(full gam env) !(full gam lhs) !(full gam rhs) resolved gam (MkTransform env lhs rhs) - = pure $ MkTransform !(resolved gam env) + = pure $ MkTransform !(resolved gam env) !(resolved gam lhs) !(resolved gam rhs) public export @@ -1334,7 +1334,7 @@ addTransform : {auto c : Ref Ctxt Defs} -> addTransform fc t = do defs <- get Ctxt let Just fn = getFnName t - | Nothing => + | Nothing => throw (GenericMsg fc "LHS of a transformation must be a function application") put Ctxt (record { transforms $= insert fn t, saveTransforms $= ((fn, t) ::) } defs) diff --git a/src/Core/Reflect.idr b/src/Core/Reflect.idr index e9ad12e..925779a 100644 --- a/src/Core/Reflect.idr +++ b/src/Core/Reflect.idr @@ -3,8 +3,8 @@ module Core.Reflect import Core.Context import Core.Env import Core.Normalise -import Core.Value import Core.TT +import Core.Value %default covering @@ -155,6 +155,23 @@ Reflect a => Reflect (List a) where xs' <- reflect fc defs env xs appCon fc defs (prelude "::") [Erased fc, x', xs'] +export +Reify a => Reify (Maybe a) where + reify defs (NDCon _ (NS _ (UN "Nothing")) _ _ _) + = pure Nothing + reify defs (NDCon _ (NS _ (UN "Just")) _ _ [_, x]) + = do x' <- reify defs !(evalClosure defs x) + pure (Just x') + reify defs val = cantReify val "Maybe" + +export +Reflect a => Reflect (Maybe a) where + reflect fc defs env Nothing = appCon fc defs (prelude "Nothing") [Erased fc] + reflect fc defs env (Just x) + = do x' <- reflect fc defs env x + appCon fc defs (prelude "Just") [Erased fc, x'] + + export (Reify a, Reify b) => Reify (a, b) where reify defs (NDCon _ (NS _ (UN "MkPair")) _ _ [_, _, x, y]) @@ -443,11 +460,12 @@ Reflect (Term vs) where tm' <- reflect fc defs env tm appCon fc defs (reflection "TDelay") [Erased fc, dfc', r', ty', tm'] - reflect fc defs env (TForce dfc tm) + reflect fc defs env (TForce dfc r tm) = do dfc' <- reflect fc defs env dfc + r' <- reflect fc defs env r tm' <- reflect fc defs env tm appCon fc defs (reflection "TForce") - [Erased fc, dfc', tm'] + [Erased fc, r', dfc', tm'] reflect fc defs env (PrimVal pfc c) = do pfc' <- reflect fc defs env pfc c' <- reflect fc defs env c diff --git a/src/Core/Termination.idr b/src/Core/Termination.idr index bb06918..d0a12df 100644 --- a/src/Core/Termination.idr +++ b/src/Core/Termination.idr @@ -278,7 +278,7 @@ mutual rhs <- normaliseOpts tcOnly defs env tm findSC defs env g pats rhs --- Remove all force and delay annotations which are nothing to do with +-- Remove all force and delay annotations which are nothing to do with -- coinduction meaning that all Delays left guard coinductive calls. delazy : Defs -> Term vars -> Term vars delazy defs (TDelayed fc r tm) @@ -292,7 +292,7 @@ delazy defs (TDelay fc r ty tm) case r of LInf => TDelay fc r ty' tm' _ => tm' -delazy defs (TForce fc r t) +delazy defs (TForce fc r t) = case r of LInf => TForce fc r (delazy defs t) _ => delazy defs t diff --git a/src/Idris/REPL.idr b/src/Idris/REPL.idr index 3d8cc29..05c343d 100644 --- a/src/Idris/REPL.idr +++ b/src/Idris/REPL.idr @@ -420,7 +420,9 @@ process (Eval itm) defs <- get Ctxt opts <- get ROpts let norm = nfun (evalMode opts) - itm <- resugar [] !(norm defs [] tm) + ntm <- norm defs [] tm + itm <- resugar [] ntm + logTermNF 5 "Normalised" [] ntm if showTypes opts then do ty <- getTerm gty ity <- resugar [] !(norm defs [] ty) diff --git a/src/TTImp/Elab/Term.idr b/src/TTImp/Elab/Term.idr index e034f04..aa57c8a 100644 --- a/src/TTImp/Elab/Term.idr +++ b/src/TTImp/Elab/Term.idr @@ -5,6 +5,7 @@ import Core.Core import Core.Env import Core.Metadata import Core.Normalise +import Core.Reflect import Core.Unify import Core.TT import Core.Value @@ -23,6 +24,7 @@ import TTImp.Elab.Local import TTImp.Elab.Prim import TTImp.Elab.Record import TTImp.Elab.Rewrite +import TTImp.Reflect import TTImp.TTImp %default covering diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr new file mode 100644 index 0000000..b0ab533 --- /dev/null +++ b/src/TTImp/Reflect.idr @@ -0,0 +1,623 @@ +module TTImp.Reflect + +import Core.Context +import Core.Env +import Core.Normalise +import Core.Reflect +import Core.TT +import Core.Value + +import TTImp.TTImp + +%default covering + +export +Reify BindMode where + reify defs (NDCon _ (NS _ (UN "PI")) _ _ [c]) + = do c' <- reify defs !(evalClosure defs c) + pure (PI c') + reify defs (NDCon _ (NS _ (UN "PATTERN")) _ _ _) + = pure PATTERN + reify defs (NDCon _ (NS _ (UN "NONE")) _ _ _) + = pure NONE + reify deva val = cantReify val "BindMode" + +export +Reflect BindMode where + reflect fc defs env (PI c) + = do c' <- reflect fc defs env c + appCon fc defs (reflection "PI") [c'] + reflect fc defs env PATTERN + = getCon fc defs (reflection "PATTERN") + reflect fc defs env NONE + = getCon fc defs (reflection "NONE") + +export +Reify UseSide where + reify defs (NDCon _ (NS _ (UN "UseLeft")) _ _ _) + = pure UseLeft + reify defs (NDCon _ (NS _ (UN "UseRight")) _ _ _) + = pure UseRight + reify deva val = cantReify val "UseSide" + +export +Reflect UseSide where + reflect fc defs env UseLeft + = getCon fc defs (reflection "UseLeft") + reflect fc defs env UseRight + = getCon fc defs (reflection "UseRight") + +mutual + export + Reify RawImp where + reify defs (NDCon _ (NS _ (UN "IVar")) _ _ [fc, n]) + = do fc' <- reify defs !(evalClosure defs fc) + n' <- reify defs !(evalClosure defs n) + pure (IVar fc' n') + reify defs (NDCon _ (NS _ (UN "IPi")) _ _ [fc, c, p, mn, aty, rty]) + = do fc' <- reify defs !(evalClosure defs fc) + c' <- reify defs !(evalClosure defs c) + p' <- reify defs !(evalClosure defs p) + mn' <- reify defs !(evalClosure defs mn) + aty' <- reify defs !(evalClosure defs aty) + rty' <- reify defs !(evalClosure defs rty) + pure (IPi fc' c' p' mn' aty' rty') + reify defs (NDCon _ (NS _ (UN "ILam")) _ _ [fc, c, p, mn, aty, lty]) + = do fc' <- reify defs !(evalClosure defs fc) + c' <- reify defs !(evalClosure defs c) + p' <- reify defs !(evalClosure defs p) + mn' <- reify defs !(evalClosure defs mn) + aty' <- reify defs !(evalClosure defs aty) + lty' <- reify defs !(evalClosure defs lty) + pure (ILam fc' c' p' mn' aty' lty') + reify defs (NDCon _ (NS _ (UN "ILet")) _ _ [fc, c, n, ty, val, sc]) + = do fc' <- reify defs !(evalClosure defs fc) + c' <- reify defs !(evalClosure defs c) + n' <- reify defs !(evalClosure defs n) + ty' <- reify defs !(evalClosure defs ty) + val' <- reify defs !(evalClosure defs val) + sc' <- reify defs !(evalClosure defs sc) + pure (ILet fc' c' n' ty' val' sc') + reify defs (NDCon _ (NS _ (UN "ICase")) _ _ [fc, sc, ty, cs]) + = do fc' <- reify defs !(evalClosure defs fc) + sc' <- reify defs !(evalClosure defs sc) + ty' <- reify defs !(evalClosure defs ty) + cs' <- reify defs !(evalClosure defs cs) + pure (ICase fc' sc' ty' cs') + reify defs (NDCon _ (NS _ (UN "ILocal")) _ _ [fc, ds, sc]) + = do fc' <- reify defs !(evalClosure defs fc) + ds' <- reify defs !(evalClosure defs ds) + sc' <- reify defs !(evalClosure defs sc) + pure (ILocal fc' ds' sc') + reify defs (NDCon _ (NS _ (UN "IUpdate")) _ _ [fc, ds, sc]) + = do fc' <- reify defs !(evalClosure defs fc) + ds' <- reify defs !(evalClosure defs ds) + sc' <- reify defs !(evalClosure defs sc) + pure (IUpdate fc' ds' sc') + reify defs (NDCon _ (NS _ (UN "IApp")) _ _ [fc, f, a]) + = do fc' <- reify defs !(evalClosure defs fc) + f' <- reify defs !(evalClosure defs f) + a' <- reify defs !(evalClosure defs a) + pure (IApp fc' f' a') + reify defs (NDCon _ (NS _ (UN "IImplicitApp")) _ _ [fc, f, m, a]) + = 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 (IImplicitApp fc' f' m' a') + reify defs (NDCon _ (NS _ (UN "IWithApp")) _ _ [fc, f, a]) + = do fc' <- reify defs !(evalClosure defs fc) + f' <- reify defs !(evalClosure defs f) + a' <- reify defs !(evalClosure defs a) + pure (IWithApp fc' f' a') + reify defs (NDCon _ (NS _ (UN "ISearch")) _ _ [fc, d]) + = do fc' <- reify defs !(evalClosure defs fc) + d' <- reify defs !(evalClosure defs d) + pure (ISearch fc' d') + reify defs (NDCon _ (NS _ (UN "IAlternative")) _ _ [fc, t, as]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + as' <- reify defs !(evalClosure defs as) + pure (IAlternative fc' t' as') + reify defs (NDCon _ (NS _ (UN "IRewrite")) _ _ [fc, t, sc]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + sc' <- reify defs !(evalClosure defs sc) + pure (IRewrite fc' t' sc') + reify defs (NDCon _ (NS _ (UN "IBindHere")) _ _ [fc, t, sc]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + sc' <- reify defs !(evalClosure defs sc) + pure (IBindHere fc' t' sc') + reify defs (NDCon _ (NS _ (UN "IBindVar")) _ _ [fc, n]) + = do fc' <- reify defs !(evalClosure defs fc) + n' <- reify defs !(evalClosure defs n) + pure (IBindVar fc' n') + reify defs (NDCon _ (NS _ (UN "IAs")) _ _ [fc, s, n, t]) + = do fc' <- reify defs !(evalClosure defs fc) + s' <- reify defs !(evalClosure defs s) + n' <- reify defs !(evalClosure defs n) + t' <- reify defs !(evalClosure defs t) + pure (IAs fc' s' n' t') + reify defs (NDCon _ (NS _ (UN "IMustUnify")) _ _ [fc, r, t]) + = do fc' <- reify defs !(evalClosure defs fc) + r' <- reify defs !(evalClosure defs r) + t' <- reify defs !(evalClosure defs t) + pure (IMustUnify fc' r' t') + reify defs (NDCon _ (NS _ (UN "IDelayed")) _ _ [fc, r, t]) + = do fc' <- reify defs !(evalClosure defs fc) + r' <- reify defs !(evalClosure defs r) + t' <- reify defs !(evalClosure defs t) + pure (IDelayed fc' r' t') + reify defs (NDCon _ (NS _ (UN "IDelay")) _ _ [fc, t]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + pure (IDelay fc' t') + reify defs (NDCon _ (NS _ (UN "IForce")) _ _ [fc, t]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + pure (IForce fc' t') + reify defs (NDCon _ (NS _ (UN "IPrimVal")) _ _ [fc, t]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + pure (IPrimVal fc' t') + reify defs (NDCon _ (NS _ (UN "IType")) _ _ [fc]) + = do fc' <- reify defs !(evalClosure defs fc) + pure (IType fc') + reify defs (NDCon _ (NS _ (UN "IHole")) _ _ [fc, n]) + = do fc' <- reify defs !(evalClosure defs fc) + n' <- reify defs !(evalClosure defs n) + pure (IHole fc' n') + reify defs (NDCon _ (NS _ (UN "Implicit")) _ _ [fc, n]) + = do fc' <- reify defs !(evalClosure defs fc) + n' <- reify defs !(evalClosure defs n) + pure (Implicit fc' n') + reify defs val = cantReify val "TTImp" + + export + Reify IFieldUpdate where + reify defs (NDCon _ (NS _ (UN "ISetField")) _ _ [x, y]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + pure (ISetField x' y') + reify defs (NDCon _ (NS _ (UN "ISetFieldApp")) _ _ [x, y]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + pure (ISetFieldApp x' y') + reify defs val = cantReify val "IFieldUpdate" + + export + Reify AltType where + reify defs (NDCon _ (NS _ (UN "FirstSuccess")) _ _ _) + = pure FirstSuccess + reify defs (NDCon _ (NS _ (UN "Unique")) _ _ _) + = pure Unique + reify defs (NDCon _ (NS _ (UN "UniqueDefault")) _ _ [x]) + = do x' <- reify defs !(evalClosure defs x) + pure (UniqueDefault x') + reify defs val = cantReify val "AltType" + + export + Reify FnOpt where + reify defs (NDCon _ (NS _ (UN "Inline")) _ _ _) + = pure Inline + reify defs (NDCon _ (NS _ (UN "Hint")) _ _ [x]) + = do x' <- reify defs !(evalClosure defs x) + pure (Hint x') + reify defs (NDCon _ (NS _ (UN "GlobalHint")) _ _ [x]) + = do x' <- reify defs !(evalClosure defs x) + pure (GlobalHint x') + reify defs (NDCon _ (NS _ (UN "ExternFn")) _ _ _) + = pure ExternFn + reify defs (NDCon _ (NS _ (UN "ForeignFn")) _ _ [x]) + = do x' <- reify defs !(evalClosure defs x) + pure (ForeignFn x') + reify defs (NDCon _ (NS _ (UN "Invertible")) _ _ _) + = pure Invertible + reify defs (NDCon _ (NS _ (UN "Total")) _ _ _) + = pure Total + reify defs (NDCon _ (NS _ (UN "Covering")) _ _ _) + = pure Covering + reify defs (NDCon _ (NS _ (UN "PartialOK")) _ _ _) + = pure PartialOK + reify defs val = cantReify val "FnOpt" + + export + Reify ImpTy where + reify defs (NDCon _ (NS _ (UN "MkTy")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (MkImpTy x' y' z') + reify defs val = cantReify val "ITy" + + export + Reify DataOpt where + reify defs (NDCon _ (NS _ (UN "SearchBy")) _ _ [x]) + = do x' <- reify defs !(evalClosure defs x) + pure (SearchBy x') + reify defs (NDCon _ (NS _ (UN "NoHints")) _ _ _) + = pure NoHints + reify defs val = cantReify val "DataOpt" + + export + Reify ImpData where + reify defs (NDCon _ (NS _ (UN "MkData")) _ _ [v,w,x,y,z]) + = 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') + reify defs (NDCon _ (NS _ (UN "MkLater")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (MkImpLater x' y' z') + reify defs val = cantReify val "Data" + + export + Reify IField where + reify defs (NDCon _ (NS _ (UN "MkIField")) _ _ [v,w,x,y,z]) + = 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 (MkIField v' w' x' y' z') + reify defs val = cantReify val "IField" + + export + Reify ImpRecord where + reify defs (NDCon _ (NS _ (UN "MkRecord")) _ _ [v,w,x,y,z]) + = 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 (MkImpRecord v' w' x' y' z') + reify defs val = cantReify val "Record" + + export + Reify ImpClause where + reify defs (NDCon _ (NS _ (UN "PatClause")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (PatClause x' y' z') + reify defs (NDCon _ (NS _ (UN "WithClause")) _ _ [w,x,y,z]) + = 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 (WithClause w' x' y' z') + reify defs (NDCon _ (NS _ (UN "WithClause")) _ _ [x,y]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + pure (ImpossibleClause x' y') + reify defs val = cantReify val "Clause" + + export + Reify ImpDecl where + reify defs (NDCon _ (NS _ (UN "IClaim")) _ _ [v,w,x,y,z]) + = 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 (IClaim v' w' x' y' z') + reify defs (NDCon _ (NS _ (UN "IData")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (IData x' y' z') + reify defs (NDCon _ (NS _ (UN "IDef")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (IDef x' y' z') + reify defs (NDCon _ (NS _ (UN "IParameters")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (IParameters x' y' z') + reify defs (NDCon _ (NS _ (UN "IRecord")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (IRecord x' y' z') + reify defs (NDCon _ (NS _ (UN "INamespace")) _ _ [w,x,y,z]) + = 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 (INamespace w' x' y' z') + reify defs (NDCon _ (NS _ (UN "ITransform")) _ _ [x,y,z]) + = do x' <- reify defs !(evalClosure defs x) + y' <- reify defs !(evalClosure defs y) + z' <- reify defs !(evalClosure defs z) + pure (ITransform x' y' z') + reify defs (NDCon _ (NS _ (UN "ILog")) _ _ [x]) + = do x' <- reify defs !(evalClosure defs x) + pure (ILog x') + reify defs val = cantReify val "Decl" + +mutual + export + Reflect RawImp where + reflect fc defs env (IVar tfc n) + = do fc' <- reflect fc defs env tfc + n' <- reflect fc defs env n + appCon fc defs (reflection "IVar") [fc', n'] + reflect fc defs env (IPi tfc c p mn aty rty) + = do fc' <- reflect fc defs env tfc + c' <- reflect fc defs env c + p' <- reflect fc defs env p + mn' <- reflect fc defs env mn + aty' <- reflect fc defs env aty + rty' <- reflect fc defs env rty + appCon fc defs (reflection "IPi") [fc', c', p', mn', aty', rty'] + reflect fc defs env (ILam tfc c p mn aty rty) + = do fc' <- reflect fc defs env tfc + c' <- reflect fc defs env c + p' <- reflect fc defs env p + mn' <- reflect fc defs env mn + aty' <- reflect fc defs env aty + rty' <- reflect fc defs env rty + appCon fc defs (reflection "ILam") [fc', c', p', mn', aty', rty'] + reflect fc defs env (ILet tfc c n aty aval sc) + = do fc' <- reflect fc defs env tfc + c' <- reflect fc defs env c + n' <- reflect fc defs env n + aty' <- reflect fc defs env aty + aval' <- reflect fc defs env aval + sc' <- reflect fc defs env sc + appCon fc defs (reflection "ILet") [fc', c', n', aty', aval', sc'] + reflect fc defs env (ICase tfc sc ty cs) + = do fc' <- reflect fc defs env tfc + sc' <- reflect fc defs env sc + ty' <- reflect fc defs env ty + cs' <- reflect fc defs env cs + appCon fc defs (reflection "ICase") [fc', sc', ty', cs'] + reflect fc defs env (ILocal tfc ds sc) + = do fc' <- reflect fc defs env tfc + ds' <- reflect fc defs env ds + sc' <- reflect fc defs env sc + appCon fc defs (reflection "ILocal") [fc', ds', sc'] + reflect fc defs env (IUpdate tfc ds sc) + = do fc' <- reflect fc defs env tfc + ds' <- reflect fc defs env ds + sc' <- reflect fc defs env sc + appCon fc defs (reflection "IUpdate") [fc', ds', sc'] + reflect fc defs env (IApp tfc f a) + = do fc' <- reflect fc defs env tfc + f' <- reflect fc defs env f + a' <- reflect fc defs env a + appCon fc defs (reflection "IApp") [fc', f', a'] + reflect fc defs env (IImplicitApp tfc f m a) + = do fc' <- reflect fc defs env tfc + f' <- reflect fc defs env f + m' <- reflect fc defs env m + a' <- reflect fc defs env a + appCon fc defs (reflection "IImplicitApp") [fc', f', m', a'] + reflect fc defs env (IWithApp tfc f a) + = do fc' <- reflect fc defs env tfc + f' <- reflect fc defs env f + a' <- reflect fc defs env a + appCon fc defs (reflection "IWithApp") [fc', f', a'] + reflect fc defs env (ISearch tfc d) + = do fc' <- reflect fc defs env tfc + d' <- reflect fc defs env d + appCon fc defs (reflection "ISearch") [fc', d'] + reflect fc defs env (IAlternative tfc t as) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + as' <- reflect fc defs env as + appCon fc defs (reflection "IAlternative") [fc', t', as'] + reflect fc defs env (IRewrite tfc t sc) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + sc' <- reflect fc defs env sc + appCon fc defs (reflection "IRewrite") [fc', t', sc'] + reflect fc defs env (ICoerced tfc d) = reflect fc defs env d + reflect fc defs env (IBindHere tfc n sc) + = do fc' <- reflect fc defs env tfc + n' <- reflect fc defs env n + sc' <- reflect fc defs env sc + appCon fc defs (reflection "IBindHere") [fc', n', sc'] + reflect fc defs env (IBindVar tfc n) + = do fc' <- reflect fc defs env tfc + n' <- reflect fc defs env n + appCon fc defs (reflection "IBindVar") [fc', n'] + reflect fc defs env (IAs tfc s n t) + = do fc' <- reflect fc defs env tfc + s' <- reflect fc defs env s + n' <- reflect fc defs env n + t' <- reflect fc defs env t + appCon fc defs (reflection "IAs") [fc', s', n', t'] + reflect fc defs env (IMustUnify tfc r t) + = do fc' <- reflect fc defs env tfc + r' <- reflect fc defs env r + t' <- reflect fc defs env t + appCon fc defs (reflection "IMustUnify") [fc', r', t'] + reflect fc defs env (IDelayed tfc r t) + = do fc' <- reflect fc defs env tfc + r' <- reflect fc defs env r + t' <- reflect fc defs env t + appCon fc defs (reflection "IDelayed") [fc', r', t'] + reflect fc defs env (IDelay tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflection "IDelay") [fc', t'] + reflect fc defs env (IForce tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflection "IForce") [fc', t'] + reflect fc defs env (IPrimVal tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflection "IPrimVal") [fc', t'] + reflect fc defs env (IType tfc) + = do fc' <- reflect fc defs env tfc + appCon fc defs (reflection "IType") [fc'] + reflect fc defs env (IHole tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflection "IHole") [fc', t'] + reflect fc defs env (Implicit tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflection "Implicit") [fc', t'] + + export + Reflect IFieldUpdate where + reflect fc defs env (ISetField p t) + = do p' <- reflect fc defs env p + t' <- reflect fc defs env t + appCon fc defs (reflection "ISetField") [p', t'] + reflect fc defs env (ISetFieldApp p t) + = do p' <- reflect fc defs env p + t' <- reflect fc defs env t + appCon fc defs (reflection "ISetFieldApp") [p', t'] + + export + Reflect AltType where + reflect fc defs env FirstSuccess = getCon fc defs (reflection "FirstSuccess") + reflect fc defs env Unique = getCon fc defs (reflection "Unique") + reflect fc defs env (UniqueDefault x) + = do x' <- reflect fc defs env x + appCon fc defs (reflection "UniqueDefault") [x'] + + export + Reflect FnOpt where + reflect fc defs env Inline = getCon fc defs (reflection "FirstSuccess") + reflect fc defs env (Hint x) + = do x' <- reflect fc defs env x + appCon fc defs (reflection "Hint") [x'] + reflect fc defs env (GlobalHint x) + = do x' <- reflect fc defs env x + appCon fc defs (reflection "GlobalHint") [x'] + reflect fc defs env ExternFn = getCon fc defs (reflection "ExternFn") + reflect fc defs env (ForeignFn x) + = do x' <- reflect fc defs env x + appCon fc defs (reflection "ForeignFn") [x'] + reflect fc defs env Invertible = getCon fc defs (reflection "Invertible") + reflect fc defs env Total = getCon fc defs (reflection "Total") + reflect fc defs env Covering = getCon fc defs (reflection "Covering") + reflect fc defs env PartialOK = getCon fc defs (reflection "PartialOK") + + export + Reflect ImpTy where + reflect fc defs env (MkImpTy x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "MkTy") [x', y', z'] + + export + Reflect DataOpt where + reflect fc defs env (SearchBy x) + = do x' <- reflect fc defs env x + appCon fc defs (reflection "SearchBy") [x'] + reflect fc defs env NoHints = getCon fc defs (reflection "NoHints") + + export + Reflect ImpData where + reflect fc defs env (MkImpData v w x y z) + = do v' <- reflect fc defs env v + w' <- reflect fc defs env w + x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "MkData") [v', w', x', y', z'] + reflect fc defs env (MkImpLater x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "MkLater") [x', y', z'] + + export + Reflect IField where + reflect fc defs env (MkIField v w x y z) + = do v' <- reflect fc defs env v + w' <- reflect fc defs env w + x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "MkIField") [v', w', x', y', z'] + + export + Reflect ImpRecord where + reflect fc defs env (MkImpRecord v w x y z) + = do v' <- reflect fc defs env v + w' <- reflect fc defs env w + x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "MkRecord") [v', w', x', y', z'] + + export + Reflect ImpClause where + reflect fc defs env (PatClause x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "PatClause") [x', y', z'] + reflect fc defs env (WithClause w x y z) + = do w' <- reflect fc defs env x + x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "WithClause") [w', x', y', z'] + reflect fc defs env (ImpossibleClause x y) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + appCon fc defs (reflection "ImpossibleClause") [x', y'] + + export + Reflect ImpDecl where + reflect fc defs env (IClaim v w x y z) + = do v' <- reflect fc defs env v + w' <- reflect fc defs env w + x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "IClaim") [v', w', x', y', z'] + reflect fc defs env (IData x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "IData") [x', y', z'] + reflect fc defs env (IDef x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "IDef") [x', y', z'] + reflect fc defs env (IParameters x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "IParameters") [x', y', z'] + reflect fc defs env (IRecord x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "IRecord") [x', y', z'] + reflect fc defs env (INamespace w x y z) + = do w' <- reflect fc defs env w + x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "INamespace") [w', x', y', z'] + reflect fc defs env (ITransform x y z) + = do x' <- reflect fc defs env x + y' <- reflect fc defs env y + z' <- reflect fc defs env z + appCon fc defs (reflection "ITransform") [x', y', z'] + reflect fc defs env (IPragma x) + = throw (GenericMsg fc "Can't reflect a pragma") + reflect fc defs env (ILog x) + = do x' <- reflect fc defs env x + appCon fc defs (reflection "ILog") [x'] + + From aae3d0f7187f0b3a9b164b4ae7bf77655a99e7cd Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Sat, 30 Nov 2019 13:23:03 +0000 Subject: [PATCH 14/18] Reorganise Language.Reflection modules --- libs/base/Language/Reflection.idr | 217 +----------------------- libs/base/Language/Reflection/TT.idr | 80 +++++++++ libs/base/Language/Reflection/TTImp.idr | 143 ++++++++++++++++ libs/base/base.ipkg | 2 + src/Core/Context.idr | 2 + src/Core/Reflect.idr | 100 ++++++----- src/Core/TTC.idr | 2 + src/Idris/Parser.idr | 2 + src/TTImp/ProcessType.idr | 2 + src/TTImp/Reflect.idr | 125 +++++++------- src/TTImp/TTImp.idr | 5 + 11 files changed, 361 insertions(+), 319 deletions(-) create mode 100644 libs/base/Language/Reflection/TT.idr create mode 100644 libs/base/Language/Reflection/TTImp.idr diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr index 231625f..d2d5550 100644 --- a/libs/base/Language/Reflection.idr +++ b/libs/base/Language/Reflection.idr @@ -1,217 +1,10 @@ module Language.Reflection -public export -FilePos : Type -FilePos = (Int, Int) +import public Language.Reflection.TT +import public Language.Reflection.TTImp public export -data FC : Type where - MkFC : String -> FilePos -> FilePos -> FC - EmptyFC : FC +data TC : Type -> Type where + Check : TTImp -> TC a + Bind : TC a -> (a -> TC b) -> TC b -public export -emptyFC : FC -emptyFC = MkFC "(empty)" (0, 0) (0, 0) - -public export -data NameType : Type where - Bound : NameType - Func : NameType - DataCon : (tag : Int) -> (arity : Nat) -> NameType - TyCon : (tag : Int) -> (arity : Nat) -> NameType - -public export -data Constant - = I Int - | BI Integer - | Str String - | Ch Char - | Db Double - | WorldVal - - | IntType - | IntegerType - | StringType - | CharType - | DoubleType - | WorldType - -public export -data Name = UN String - | MN String Int - | NS (List String) Name - -public export -data Count = M0 | M1 | MW - -public export -data PiInfo = ImplicitArg | ExplicitArg | AutoImplicit - -public export -data IsVar : Name -> Nat -> List Name -> Type where - First : IsVar n Z (n :: ns) - Later : IsVar n i ns -> IsVar n (S i) (m :: ns) - -public export -data LazyReason = LInf | LLazy | LUnknown - --- Type checked terms in the core TT -public export -data TT : List Name -> Type where - Local : FC -> (idx : Nat) -> (n : Name) -> - (0 prf : IsVar name idx vars) -> TT vars - Ref : FC -> NameType -> Name -> TT vars - Pi : FC -> Count -> PiInfo -> - (x : Name) -> (argTy : TT vars) -> (retTy : TT (x :: vars)) -> - TT vars - Lam : FC -> Count -> PiInfo -> - (x : Name) -> (argTy : TT vars) -> (scope : TT (x :: vars)) -> - TT vars - App : FC -> TT vars -> TT vars -> TT vars - TDelayed : FC -> LazyReason -> TT vars -> TT vars - TDelay : FC -> LazyReason -> (ty : TT vars) -> (arg : TT vars) -> TT vars - TForce : FC -> TT vars -> TT vars - PrimVal : FC -> Constant -> TT vars - Erased : FC -> TT vars - TType : FC -> TT vars - -public export -data Visibility = Private | Export | Public - --- Unchecked terms and declarations in the intermediate language -mutual - public export - data BindMode = PI Count | PATTERN | NONE - - -- For as patterns matching linear arguments, select which side is - -- consumed - public export - data UseSide = UseLeft | UseRight - - data TTImp : Type where - IVar : FC -> Name -> TTImp - IPi : FC -> Count -> PiInfo -> Maybe Name -> - (argTy : TTImp) -> (retTy : TTImp) -> TTImp - ILam : FC -> Count -> PiInfo -> Maybe Name -> - (argTy : TTImp) -> (lamTy : TTImp) -> TTImp - ILet : FC -> Count -> Name -> - (nTy : TTImp) -> (nVal : TTImp) -> - (scope : TTImp) -> TTImp - ICase : FC -> TTImp -> (ty : TTImp) -> - List Clause -> TTImp - ILocal : FC -> List Decl -> TTImp -> TTImp - IUpdate : FC -> List IFieldUpdate -> TTImp -> TTImp - - IApp : FC -> TTImp -> TTImp -> TTImp - IImplicitApp : FC -> TTImp -> Maybe Name -> TTImp -> TTImp - IWithApp : FC -> TTImp -> TTImp -> TTImp - - ISearch : FC -> (depth : Nat) -> TTImp - IAlternative : FC -> AltType -> List TTImp -> TTImp - IRewrite : FC -> TTImp -> TTImp -> TTImp - - -- Any implicit bindings in the scope should be bound here, using - -- the given binder - IBindHere : FC -> BindMode -> TTImp -> TTImp - -- A name which should be implicitly bound - IBindVar : FC -> String -> TTImp - -- An 'as' pattern, valid on the LHS of a clause only - IAs : FC -> UseSide -> Name -> TTImp -> TTImp - -- A 'dot' pattern, i.e. one which must also have the given value - -- by unification - IMustUnify : FC -> (reason : String) -> TTImp -> TTImp - - -- Laziness annotations - IDelayed : FC -> LazyReason -> TTImp -> TTImp -- the type - IDelay : FC -> TTImp -> TTImp -- delay constructor - IForce : FC -> TTImp -> TTImp - - IPrimVal : FC -> (c : Constant) -> TTImp - IType : FC -> TTImp - IHole : FC -> String -> TTImp - - -- An implicit value, solved by unification, but which will also be - -- bound (either as a pattern variable or a type variable) if unsolved - -- at the end of elaborator - Implicit : FC -> (bindIfUnsolved : Bool) -> TTImp - - public export - data IFieldUpdate : Type where - ISetField : (path : List String) -> TTImp -> IFieldUpdate - ISetFieldApp : (path : List String) -> TTImp -> IFieldUpdate - - public export - data AltType : Type where - FirstSuccess : AltType - Unique : AltType - UniqueDefault : TTImp -> AltType - - public export - data FnOpt : Type where - Inline : FnOpt - -- Flag means the hint is a direct hint, not a function which might - -- find the result (e.g. chasing parent interface dictionaries) - Hint : Bool -> FnOpt - -- Flag means to use as a default if all else fails - GlobalHint : Bool -> FnOpt - ExternFn : FnOpt - -- Defined externally, list calling conventions - ForeignFn : List String -> FnOpt - -- assume safe to cancel arguments in unification - Invertible : FnOpt - Total : FnOpt - Covering : FnOpt - PartialOK : FnOpt - - public export - data ITy : Type where - MkTy : FC -> (n : Name) -> (ty : TTImp) -> ITy - - public export - data DataOpt : Type where - SearchBy : List Name -> DataOpt -- determining arguments - NoHints : DataOpt -- Don't generate search hints for constructors - - public export - data Data : Type where - MkData : FC -> (n : Name) -> (tycon : TTImp) -> - (opts : List DataOpt) -> - (datacons : List ITy) -> Data - MkLater : FC -> (n : Name) -> (tycon : TTImp) -> Data - - public export - data IField : Type where - MkIField : FC -> Count -> PiInfo -> Name -> TTImp -> - IField - - public export - data Record : Type where - MkRecord : FC -> (n : Name) -> - (params : List (Name, TTImp)) -> - (conName : Maybe Name) -> - (fields : List IField) -> - Record - - public export - data Clause : Type where - PatClause : FC -> (lhs : TTImp) -> (rhs : TTImp) -> Clause - WithClause : FC -> (lhs : TTImp) -> (wval : TTImp) -> - List Clause -> Clause - ImpossibleClause : FC -> (lhs : TTImp) -> Clause - - public export - data Decl : Type where - IClaim : FC -> Count -> Visibility -> List FnOpt -> - ITy -> Decl - IData : FC -> Visibility -> Data -> Decl - IDef : FC -> Name -> List Clause -> Decl - IParameters : FC -> List (Name, TTImp) -> - List Decl -> Decl - IRecord : FC -> Visibility -> Record -> Decl - INamespace : FC -> - (nested : Bool) -> - -- ^ if True, parent namespaces in the same file can also - -- look inside and see private/export names in full - List String -> List Decl -> Decl - ITransform : FC -> TTImp -> TTImp -> Decl - ILog : Nat -> Decl diff --git a/libs/base/Language/Reflection/TT.idr b/libs/base/Language/Reflection/TT.idr new file mode 100644 index 0000000..755ed91 --- /dev/null +++ b/libs/base/Language/Reflection/TT.idr @@ -0,0 +1,80 @@ +module Language.Reflection.TT + +public export +FilePos : Type +FilePos = (Int, Int) + +public export +data FC : Type where + MkFC : String -> FilePos -> FilePos -> FC + EmptyFC : FC + +public export +emptyFC : FC +emptyFC = EmptyFC + +public export +data NameType : Type where + Bound : NameType + Func : NameType + DataCon : (tag : Int) -> (arity : Nat) -> NameType + TyCon : (tag : Int) -> (arity : Nat) -> NameType + +public export +data Constant + = I Int + | BI Integer + | Str String + | Ch Char + | Db Double + | WorldVal + + | IntType + | IntegerType + | StringType + | CharType + | DoubleType + | WorldType + +public export +data Name = UN String + | MN String Int + | NS (List String) Name + +public export +data Count = M0 | M1 | MW + +public export +data PiInfo = ImplicitArg | ExplicitArg | AutoImplicit + +public export +data IsVar : Name -> Nat -> List Name -> Type where + First : IsVar n Z (n :: ns) + Later : IsVar n i ns -> IsVar n (S i) (m :: ns) + +public export +data LazyReason = LInf | LLazy | LUnknown + +-- Type checked terms in the core TT +public export +data TT : List Name -> Type where + Local : FC -> (idx : Nat) -> (n : Name) -> + (0 prf : IsVar name idx vars) -> TT vars + Ref : FC -> NameType -> Name -> TT vars + Pi : FC -> Count -> PiInfo -> + (x : Name) -> (argTy : TT vars) -> (retTy : TT (x :: vars)) -> + TT vars + Lam : FC -> Count -> PiInfo -> + (x : Name) -> (argTy : TT vars) -> (scope : TT (x :: vars)) -> + TT vars + App : FC -> TT vars -> TT vars -> TT vars + TDelayed : FC -> LazyReason -> TT vars -> TT vars + TDelay : FC -> LazyReason -> (ty : TT vars) -> (arg : TT vars) -> TT vars + TForce : FC -> TT vars -> TT vars + PrimVal : FC -> Constant -> TT vars + Erased : FC -> TT vars + TType : FC -> TT vars + +public export +data Visibility = Private | Export | Public + diff --git a/libs/base/Language/Reflection/TTImp.idr b/libs/base/Language/Reflection/TTImp.idr new file mode 100644 index 0000000..4b6f17e --- /dev/null +++ b/libs/base/Language/Reflection/TTImp.idr @@ -0,0 +1,143 @@ +module Language.Reflection.TTImp + +import Language.Reflection.TT + +-- Unchecked terms and declarations in the intermediate language +mutual + public export + data BindMode = PI Count | PATTERN | NONE + + -- For as patterns matching linear arguments, select which side is + -- consumed + public export + data UseSide = UseLeft | UseRight + + public export + data TTImp : Type where + IVar : FC -> Name -> TTImp + IPi : FC -> Count -> PiInfo -> Maybe Name -> + (argTy : TTImp) -> (retTy : TTImp) -> TTImp + ILam : FC -> Count -> PiInfo -> Maybe Name -> + (argTy : TTImp) -> (lamTy : TTImp) -> TTImp + ILet : FC -> Count -> Name -> + (nTy : TTImp) -> (nVal : TTImp) -> + (scope : TTImp) -> TTImp + ICase : FC -> TTImp -> (ty : TTImp) -> + List Clause -> TTImp + ILocal : FC -> List Decl -> TTImp -> TTImp + IUpdate : FC -> List IFieldUpdate -> TTImp -> TTImp + + IApp : FC -> TTImp -> TTImp -> TTImp + IImplicitApp : FC -> TTImp -> Maybe Name -> TTImp -> TTImp + IWithApp : FC -> TTImp -> TTImp -> TTImp + + ISearch : FC -> (depth : Nat) -> TTImp + IAlternative : FC -> AltType -> List TTImp -> TTImp + IRewrite : FC -> TTImp -> TTImp -> TTImp + + -- Any implicit bindings in the scope should be bound here, using + -- the given binder + IBindHere : FC -> BindMode -> TTImp -> TTImp + -- A name which should be implicitly bound + IBindVar : FC -> String -> TTImp + -- An 'as' pattern, valid on the LHS of a clause only + IAs : FC -> UseSide -> Name -> TTImp -> TTImp + -- A 'dot' pattern, i.e. one which must also have the given value + -- by unification + IMustUnify : FC -> (reason : String) -> TTImp -> TTImp + + -- Laziness annotations + IDelayed : FC -> LazyReason -> TTImp -> TTImp -- the type + IDelay : FC -> TTImp -> TTImp -- delay constructor + IForce : FC -> TTImp -> TTImp + + IPrimVal : FC -> (c : Constant) -> TTImp + IType : FC -> TTImp + IHole : FC -> String -> TTImp + + -- An implicit value, solved by unification, but which will also be + -- bound (either as a pattern variable or a type variable) if unsolved + -- at the end of elaborator + Implicit : FC -> (bindIfUnsolved : Bool) -> TTImp + + public export + data IFieldUpdate : Type where + ISetField : (path : List String) -> TTImp -> IFieldUpdate + ISetFieldApp : (path : List String) -> TTImp -> IFieldUpdate + + public export + data AltType : Type where + FirstSuccess : AltType + Unique : AltType + UniqueDefault : TTImp -> AltType + + public export + data FnOpt : Type where + Inline : FnOpt + -- Flag means the hint is a direct hint, not a function which might + -- find the result (e.g. chasing parent interface dictionaries) + Hint : Bool -> FnOpt + -- Flag means to use as a default if all else fails + GlobalHint : Bool -> FnOpt + ExternFn : FnOpt + -- Defined externally, list calling conventions + ForeignFn : List String -> FnOpt + -- assume safe to cancel arguments in unification + Invertible : FnOpt + Total : FnOpt + Covering : FnOpt + PartialOK : FnOpt + Macro : FnOpt + + public export + data ITy : Type where + MkTy : FC -> (n : Name) -> (ty : TTImp) -> ITy + + public export + data DataOpt : Type where + SearchBy : List Name -> DataOpt -- determining arguments + NoHints : DataOpt -- Don't generate search hints for constructors + + public export + data Data : Type where + MkData : FC -> (n : Name) -> (tycon : TTImp) -> + (opts : List DataOpt) -> + (datacons : List ITy) -> Data + MkLater : FC -> (n : Name) -> (tycon : TTImp) -> Data + + public export + data IField : Type where + MkIField : FC -> Count -> PiInfo -> Name -> TTImp -> + IField + + public export + data Record : Type where + MkRecord : FC -> (n : Name) -> + (params : List (Name, TTImp)) -> + (conName : Maybe Name) -> + (fields : List IField) -> + Record + + public export + data Clause : Type where + PatClause : FC -> (lhs : TTImp) -> (rhs : TTImp) -> Clause + WithClause : FC -> (lhs : TTImp) -> (wval : TTImp) -> + List Clause -> Clause + ImpossibleClause : FC -> (lhs : TTImp) -> Clause + + public export + data Decl : Type where + IClaim : FC -> Count -> Visibility -> List FnOpt -> + ITy -> Decl + IData : FC -> Visibility -> Data -> Decl + IDef : FC -> Name -> List Clause -> Decl + IParameters : FC -> List (Name, TTImp) -> + List Decl -> Decl + IRecord : FC -> Visibility -> Record -> Decl + INamespace : FC -> + (nested : Bool) -> + -- ^ if True, parent namespaces in the same file can also + -- look inside and see private/export names in full + List String -> List Decl -> Decl + ITransform : FC -> TTImp -> TTImp -> Decl + ILog : Nat -> Decl diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg index 1365db5..065cb5a 100644 --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -25,6 +25,8 @@ modules = Control.Monad.Identity, Decidable.Equality, Language.Reflection, + Language.Reflection.TT, + Language.Reflection.TTImp, System, System.Concurrency.Raw, diff --git a/src/Core/Context.idr b/src/Core/Context.idr index 33dcfa6..0d76623 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -118,6 +118,7 @@ data DefFlag -- care! | SetTotal TotalReq | BlockedHint -- a hint, but blocked for the moment (so don't use) + | Macro export Eq TotalReq where @@ -134,6 +135,7 @@ Eq DefFlag where (==) TCInline TCInline = True (==) (SetTotal x) (SetTotal y) = x == y (==) BlockedHint BlockedHint = True + (==) Macro Macro = True (==) _ _ = False public export diff --git a/src/Core/Reflect.idr b/src/Core/Reflect.idr index 925779a..cd6f59e 100644 --- a/src/Core/Reflect.idr +++ b/src/Core/Reflect.idr @@ -47,6 +47,14 @@ export reflection : String -> Name reflection n = NS ["Reflection", "Language"] (UN n) +export +reflectiontt : String -> Name +reflectiontt n = NS ["TT", "Reflection", "Language"] (UN n) + +export +reflectionttimp : String -> Name +reflectionttimp n = NS ["TTImp", "Reflection", "Language"] (UN n) + export cantReify : NF vars -> String -> Core a cantReify val ty @@ -206,15 +214,15 @@ export Reflect Name where reflect fc defs env (UN x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "UN") [x'] + appCon fc defs (reflectiontt "UN") [x'] reflect fc defs env (MN x i) = do x' <- reflect fc defs env x i' <- reflect fc defs env i - appCon fc defs (reflection "MN") [x', i'] + appCon fc defs (reflectiontt "MN") [x', i'] reflect fc defs env (NS ns n) = do ns' <- reflect fc defs env ns n' <- reflect fc defs env n - appCon fc defs (reflection "NS") [ns', n'] + appCon fc defs (reflectiontt "NS") [ns', n'] reflect fc defs env val = cantReflect fc "Name" export @@ -235,16 +243,16 @@ Reify NameType where export Reflect NameType where - reflect fc defs env Bound = getCon fc defs (reflection "Bound") - reflect fc defs env Func = getCon fc defs (reflection "Func") + reflect fc defs env Bound = getCon fc defs (reflectiontt "Bound") + reflect fc defs env Func = getCon fc defs (reflectiontt "Func") reflect fc defs env (DataCon t i) = do t' <- reflect fc defs env t i' <- reflect fc defs env i - appCon fc defs (reflection "DataCon") [t', i'] + appCon fc defs (reflectiontt "DataCon") [t', i'] reflect fc defs env (TyCon t i) = do t' <- reflect fc defs env t i' <- reflect fc defs env i - appCon fc defs (reflection "TyCon") [t', i'] + appCon fc defs (reflectiontt "TyCon") [t', i'] export Reify Constant where @@ -283,33 +291,33 @@ export Reflect Constant where reflect fc defs env (I x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "I") [x'] + appCon fc defs (reflectiontt "I") [x'] reflect fc defs env (BI x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "BI") [x'] + appCon fc defs (reflectiontt "BI") [x'] reflect fc defs env (Str x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "Str") [x'] + appCon fc defs (reflectiontt "Str") [x'] reflect fc defs env (Ch x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "Ch") [x'] + appCon fc defs (reflectiontt "Ch") [x'] reflect fc defs env (Db x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "Db") [x'] + appCon fc defs (reflectiontt "Db") [x'] reflect fc defs env WorldVal - = getCon fc defs (reflection "WorldVal") + = getCon fc defs (reflectiontt "WorldVal") reflect fc defs env IntType - = getCon fc defs (reflection "IntTyoe") + = getCon fc defs (reflectiontt "IntTyoe") reflect fc defs env IntegerType - = getCon fc defs (reflection "IntegerType") + = getCon fc defs (reflectiontt "IntegerType") reflect fc defs env StringType - = getCon fc defs (reflection "StringType") + = getCon fc defs (reflectiontt "StringType") reflect fc defs env CharType - = getCon fc defs (reflection "CharType") + = getCon fc defs (reflectiontt "CharType") reflect fc defs env DoubleType - = getCon fc defs (reflection "DoubleTyoe") + = getCon fc defs (reflectiontt "DoubleTyoe") reflect fc defs env WorldType - = getCon fc defs (reflection "WorldType") + = getCon fc defs (reflectiontt "WorldType") export Reify Visibility where @@ -323,9 +331,9 @@ Reify Visibility where export Reflect Visibility where - reflect fc defs env Private = getCon fc defs (reflection "Private") - reflect fc defs env Export = getCon fc defs (reflection "Export") - reflect fc defs env Public = getCon fc defs (reflection "Public") + reflect fc defs env Private = getCon fc defs (reflectiontt "Private") + reflect fc defs env Export = getCon fc defs (reflectiontt "Export") + reflect fc defs env Public = getCon fc defs (reflectiontt "Public") export Reify RigCount where @@ -339,9 +347,9 @@ Reify RigCount where export Reflect RigCount where - reflect fc defs env Rig0 = getCon fc defs (reflection "M0") - reflect fc defs env Rig1 = getCon fc defs (reflection "M1") - reflect fc defs env RigW = getCon fc defs (reflection "MW") + reflect fc defs env Rig0 = getCon fc defs (reflectiontt "M0") + reflect fc defs env Rig1 = getCon fc defs (reflectiontt "M1") + reflect fc defs env RigW = getCon fc defs (reflectiontt "MW") export Reify PiInfo where @@ -355,9 +363,9 @@ Reify PiInfo where export Reflect PiInfo where - reflect fc defs env Implicit = getCon fc defs (reflection "ImplicitArg") - reflect fc defs env Explicit = getCon fc defs (reflection "ExplicitArg") - reflect fc defs env AutoImplicit = getCon fc defs (reflection "AutoImplicit") + reflect fc defs env Implicit = getCon fc defs (reflectiontt "ImplicitArg") + reflect fc defs env Explicit = getCon fc defs (reflectiontt "ExplicitArg") + reflect fc defs env AutoImplicit = getCon fc defs (reflectiontt "AutoImplicit") export Reify LazyReason where @@ -371,9 +379,9 @@ Reify LazyReason where export Reflect LazyReason where - reflect fc defs env LInf = getCon fc defs (reflection "LInf") - reflect fc defs env LLazy = getCon fc defs (reflection "LLazy") - reflect fc defs env LUnknown = getCon fc defs (reflection "LUnknown") + reflect fc defs env LInf = getCon fc defs (reflectiontt "LInf") + reflect fc defs env LLazy = getCon fc defs (reflectiontt "LLazy") + reflect fc defs env LUnknown = getCon fc defs (reflectiontt "LUnknown") export Reify FC where @@ -392,8 +400,8 @@ Reflect FC where = do fn' <- reflect fc defs env fn start' <- reflect fc defs env start end' <- reflect fc defs env end - appCon fc defs (reflection "MkFC") [fn', start', end'] - reflect fc defs env EmptyFC = getCon fc defs (reflection "EmptyFC") + appCon fc defs (reflectiontt "MkFC") [fn', start', end'] + reflect fc defs env EmptyFC = getCon fc defs (reflectiontt "EmptyFC") -- Reflection of well typed terms: We don't reify terms because that involves -- type checking, but we can reflect them @@ -401,10 +409,10 @@ Reflect FC where export Reflect (IsVar name idx vs) where reflect fc defs env First - = appCon fc defs (reflection "First") [Erased fc, Erased fc] + = appCon fc defs (reflectiontt "First") [Erased fc, Erased fc] reflect fc defs env (Later p) = do p' <- reflect fc defs env p - appCon fc defs (reflection "Later") + appCon fc defs (reflectiontt "Later") [Erased fc, Erased fc, Erased fc, Erased fc, p'] -- Assume terms are normalised so there's not Let bindings in particular @@ -415,13 +423,13 @@ Reflect (Term vs) where lfc' <- reflect fc defs env lfc idx' <- reflect fc defs env idx prf' <- reflect fc defs env prf - appCon fc defs (reflection "Local") + appCon fc defs (reflectiontt "Local") [Erased fc, Erased fc, lfc', idx', prf'] reflect fc defs env (Ref rfc nt n) = do rfc' <- reflect fc defs env rfc nt' <- reflect fc defs env nt n' <- reflect fc defs env n - appCon fc defs (reflection "Ref") + appCon fc defs (reflectiontt "Ref") [Erased fc, rfc', nt', n'] reflect fc defs env (Bind bfc x (Pi c p ty) sc) = do bfc' <- reflect fc defs env bfc @@ -430,7 +438,7 @@ Reflect (Term vs) where p' <- reflect fc defs env p ty' <- reflect fc defs env ty sc' <- reflect fc defs env sc - appCon fc defs (reflection "Pi") + appCon fc defs (reflectiontt "Pi") [Erased fc, bfc', c', p', x', ty', sc'] reflect fc defs env (Bind bfc x (Lam c p ty) sc) = do bfc' <- reflect fc defs env bfc @@ -439,45 +447,45 @@ Reflect (Term vs) where p' <- reflect fc defs env p ty' <- reflect fc defs env ty sc' <- reflect fc defs env sc - appCon fc defs (reflection "Lam") + appCon fc defs (reflectiontt "Lam") [Erased fc, bfc', c', p', x', ty', sc'] reflect fc defs env (App afc fn arg) = do afc' <- reflect fc defs env afc fn' <- reflect fc defs env fn arg' <- reflect fc defs env arg - appCon fc defs (reflection "App") + appCon fc defs (reflectiontt "App") [Erased fc, afc', fn', arg'] reflect fc defs env (TDelayed dfc r tm) = do dfc' <- reflect fc defs env dfc r' <- reflect fc defs env r tm' <- reflect fc defs env tm - appCon fc defs (reflection "TDelayed") + appCon fc defs (reflectiontt "TDelayed") [Erased fc, dfc', r', tm'] reflect fc defs env (TDelay dfc r ty tm) = do dfc' <- reflect fc defs env dfc r' <- reflect fc defs env r ty' <- reflect fc defs env ty tm' <- reflect fc defs env tm - appCon fc defs (reflection "TDelay") + appCon fc defs (reflectiontt "TDelay") [Erased fc, dfc', r', ty', tm'] reflect fc defs env (TForce dfc r tm) = do dfc' <- reflect fc defs env dfc r' <- reflect fc defs env r tm' <- reflect fc defs env tm - appCon fc defs (reflection "TForce") + appCon fc defs (reflectiontt "TForce") [Erased fc, r', dfc', tm'] reflect fc defs env (PrimVal pfc c) = do pfc' <- reflect fc defs env pfc c' <- reflect fc defs env c - appCon fc defs (reflection "PrimVal") + appCon fc defs (reflectiontt "PrimVal") [Erased fc, pfc', c'] reflect fc defs env (Erased efc) = do efc' <- reflect fc defs env efc - appCon fc defs (reflection "Erased") + appCon fc defs (reflectiontt "Erased") [Erased fc, efc'] reflect fc defs env (TType tfc) = do tfc' <- reflect fc defs env tfc - appCon fc defs (reflection "TType") + appCon fc defs (reflectiontt "TType") [Erased fc, tfc'] reflect fc defs env val = cantReflect fc "Term" diff --git a/src/Core/TTC.idr b/src/Core/TTC.idr index bc43086..234cb90 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -805,6 +805,7 @@ TTC DefFlag where toBuf b TCInline = tag 5 toBuf b (SetTotal x) = do tag 6; toBuf b x toBuf b BlockedHint = tag 7 + toBuf b Macro = tag 8 fromBuf b = case !getTag of @@ -814,6 +815,7 @@ TTC DefFlag where 5 => pure TCInline 6 => do x <- fromBuf b; pure (SetTotal x) 7 => pure BlockedHint + 8 => pure Macro _ => corrupt "DefFlag" export diff --git a/src/Idris/Parser.idr b/src/Idris/Parser.idr index 7e7887b..28afb59 100644 --- a/src/Idris/Parser.idr +++ b/src/Idris/Parser.idr @@ -1025,6 +1025,8 @@ fnDirectOpt pure Inline <|> do exactIdent "extern" pure ExternFn + <|> do exactIdent "macro" + pure Macro <|> do exactIdent "foreign" cs <- many strLit pure (ForeignFn cs) diff --git a/src/TTImp/ProcessType.idr b/src/TTImp/ProcessType.idr index 6efeb5a..15422f4 100644 --- a/src/TTImp/ProcessType.idr +++ b/src/TTImp/ProcessType.idr @@ -52,6 +52,8 @@ processFnOpt fc ndef Covering = setFlag fc ndef (SetTotal CoveringOnly) processFnOpt fc ndef PartialOK = setFlag fc ndef (SetTotal PartialOK) +processFnOpt fc ndef Macro + = setFlag fc ndef Macro -- If it's declared as externally defined, set the definition to -- ExternFn , where the arity is assumed to be fixed (i.e. diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr index b0ab533..a76375c 100644 --- a/src/TTImp/Reflect.idr +++ b/src/TTImp/Reflect.idr @@ -26,11 +26,11 @@ export Reflect BindMode where reflect fc defs env (PI c) = do c' <- reflect fc defs env c - appCon fc defs (reflection "PI") [c'] + appCon fc defs (reflectionttimp "PI") [c'] reflect fc defs env PATTERN - = getCon fc defs (reflection "PATTERN") + = getCon fc defs (reflectionttimp "PATTERN") reflect fc defs env NONE - = getCon fc defs (reflection "NONE") + = getCon fc defs (reflectionttimp "NONE") export Reify UseSide where @@ -43,9 +43,9 @@ Reify UseSide where export Reflect UseSide where reflect fc defs env UseLeft - = getCon fc defs (reflection "UseLeft") + = getCon fc defs (reflectionttimp "UseLeft") reflect fc defs env UseRight - = getCon fc defs (reflection "UseRight") + = getCon fc defs (reflectionttimp "UseRight") mutual export @@ -220,6 +220,8 @@ mutual = pure Covering reify defs (NDCon _ (NS _ (UN "PartialOK")) _ _ _) = pure PartialOK + reify defs (NDCon _ (NS _ (UN "Macro")) _ _ _) + = pure Macro reify defs val = cantReify val "FnOpt" export @@ -348,7 +350,7 @@ mutual reflect fc defs env (IVar tfc n) = do fc' <- reflect fc defs env tfc n' <- reflect fc defs env n - appCon fc defs (reflection "IVar") [fc', n'] + appCon fc defs (reflectionttimp "IVar") [fc', n'] reflect fc defs env (IPi tfc c p mn aty rty) = do fc' <- reflect fc defs env tfc c' <- reflect fc defs env c @@ -356,7 +358,7 @@ mutual mn' <- reflect fc defs env mn aty' <- reflect fc defs env aty rty' <- reflect fc defs env rty - appCon fc defs (reflection "IPi") [fc', c', p', mn', aty', rty'] + appCon fc defs (reflectionttimp "IPi") [fc', c', p', mn', aty', rty'] reflect fc defs env (ILam tfc c p mn aty rty) = do fc' <- reflect fc defs env tfc c' <- reflect fc defs env c @@ -364,7 +366,7 @@ mutual mn' <- reflect fc defs env mn aty' <- reflect fc defs env aty rty' <- reflect fc defs env rty - appCon fc defs (reflection "ILam") [fc', c', p', mn', aty', rty'] + appCon fc defs (reflectionttimp "ILam") [fc', c', p', mn', aty', rty'] reflect fc defs env (ILet tfc c n aty aval sc) = do fc' <- reflect fc defs env tfc c' <- reflect fc defs env c @@ -372,139 +374,140 @@ mutual aty' <- reflect fc defs env aty aval' <- reflect fc defs env aval sc' <- reflect fc defs env sc - appCon fc defs (reflection "ILet") [fc', c', n', aty', aval', sc'] + appCon fc defs (reflectionttimp "ILet") [fc', c', n', aty', aval', sc'] reflect fc defs env (ICase tfc sc ty cs) = do fc' <- reflect fc defs env tfc sc' <- reflect fc defs env sc ty' <- reflect fc defs env ty cs' <- reflect fc defs env cs - appCon fc defs (reflection "ICase") [fc', sc', ty', cs'] + appCon fc defs (reflectionttimp "ICase") [fc', sc', ty', cs'] reflect fc defs env (ILocal tfc ds sc) = do fc' <- reflect fc defs env tfc ds' <- reflect fc defs env ds sc' <- reflect fc defs env sc - appCon fc defs (reflection "ILocal") [fc', ds', sc'] + appCon fc defs (reflectionttimp "ILocal") [fc', ds', sc'] reflect fc defs env (IUpdate tfc ds sc) = do fc' <- reflect fc defs env tfc ds' <- reflect fc defs env ds sc' <- reflect fc defs env sc - appCon fc defs (reflection "IUpdate") [fc', ds', sc'] + appCon fc defs (reflectionttimp "IUpdate") [fc', ds', sc'] reflect fc defs env (IApp tfc f a) = do fc' <- reflect fc defs env tfc f' <- reflect fc defs env f a' <- reflect fc defs env a - appCon fc defs (reflection "IApp") [fc', f', a'] + appCon fc defs (reflectionttimp "IApp") [fc', f', a'] reflect fc defs env (IImplicitApp tfc f m a) = do fc' <- reflect fc defs env tfc f' <- reflect fc defs env f m' <- reflect fc defs env m a' <- reflect fc defs env a - appCon fc defs (reflection "IImplicitApp") [fc', f', m', a'] + appCon fc defs (reflectionttimp "IImplicitApp") [fc', f', m', a'] reflect fc defs env (IWithApp tfc f a) = do fc' <- reflect fc defs env tfc f' <- reflect fc defs env f a' <- reflect fc defs env a - appCon fc defs (reflection "IWithApp") [fc', f', a'] + appCon fc defs (reflectionttimp "IWithApp") [fc', f', a'] reflect fc defs env (ISearch tfc d) = do fc' <- reflect fc defs env tfc d' <- reflect fc defs env d - appCon fc defs (reflection "ISearch") [fc', d'] + appCon fc defs (reflectionttimp "ISearch") [fc', d'] reflect fc defs env (IAlternative tfc t as) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t as' <- reflect fc defs env as - appCon fc defs (reflection "IAlternative") [fc', t', as'] + appCon fc defs (reflectionttimp "IAlternative") [fc', t', as'] reflect fc defs env (IRewrite tfc t sc) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t sc' <- reflect fc defs env sc - appCon fc defs (reflection "IRewrite") [fc', t', sc'] + appCon fc defs (reflectionttimp "IRewrite") [fc', t', sc'] reflect fc defs env (ICoerced tfc d) = reflect fc defs env d reflect fc defs env (IBindHere tfc n sc) = do fc' <- reflect fc defs env tfc n' <- reflect fc defs env n sc' <- reflect fc defs env sc - appCon fc defs (reflection "IBindHere") [fc', n', sc'] + appCon fc defs (reflectionttimp "IBindHere") [fc', n', sc'] reflect fc defs env (IBindVar tfc n) = do fc' <- reflect fc defs env tfc n' <- reflect fc defs env n - appCon fc defs (reflection "IBindVar") [fc', n'] + appCon fc defs (reflectionttimp "IBindVar") [fc', n'] reflect fc defs env (IAs tfc s n t) = do fc' <- reflect fc defs env tfc s' <- reflect fc defs env s n' <- reflect fc defs env n t' <- reflect fc defs env t - appCon fc defs (reflection "IAs") [fc', s', n', t'] + appCon fc defs (reflectionttimp "IAs") [fc', s', n', t'] reflect fc defs env (IMustUnify tfc r t) = do fc' <- reflect fc defs env tfc r' <- reflect fc defs env r t' <- reflect fc defs env t - appCon fc defs (reflection "IMustUnify") [fc', r', t'] + appCon fc defs (reflectionttimp "IMustUnify") [fc', r', t'] reflect fc defs env (IDelayed tfc r t) = do fc' <- reflect fc defs env tfc r' <- reflect fc defs env r t' <- reflect fc defs env t - appCon fc defs (reflection "IDelayed") [fc', r', t'] + appCon fc defs (reflectionttimp "IDelayed") [fc', r', t'] reflect fc defs env (IDelay tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t - appCon fc defs (reflection "IDelay") [fc', t'] + appCon fc defs (reflectionttimp "IDelay") [fc', t'] reflect fc defs env (IForce tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t - appCon fc defs (reflection "IForce") [fc', t'] + appCon fc defs (reflectionttimp "IForce") [fc', t'] reflect fc defs env (IPrimVal tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t - appCon fc defs (reflection "IPrimVal") [fc', t'] + appCon fc defs (reflectionttimp "IPrimVal") [fc', t'] reflect fc defs env (IType tfc) = do fc' <- reflect fc defs env tfc - appCon fc defs (reflection "IType") [fc'] + appCon fc defs (reflectionttimp "IType") [fc'] reflect fc defs env (IHole tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t - appCon fc defs (reflection "IHole") [fc', t'] + appCon fc defs (reflectionttimp "IHole") [fc', t'] reflect fc defs env (Implicit tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t - appCon fc defs (reflection "Implicit") [fc', t'] + appCon fc defs (reflectionttimp "Implicit") [fc', t'] export Reflect IFieldUpdate where reflect fc defs env (ISetField p t) = do p' <- reflect fc defs env p t' <- reflect fc defs env t - appCon fc defs (reflection "ISetField") [p', t'] + appCon fc defs (reflectionttimp "ISetField") [p', t'] reflect fc defs env (ISetFieldApp p t) = do p' <- reflect fc defs env p t' <- reflect fc defs env t - appCon fc defs (reflection "ISetFieldApp") [p', t'] + appCon fc defs (reflectionttimp "ISetFieldApp") [p', t'] export Reflect AltType where - reflect fc defs env FirstSuccess = getCon fc defs (reflection "FirstSuccess") - reflect fc defs env Unique = getCon fc defs (reflection "Unique") + reflect fc defs env FirstSuccess = getCon fc defs (reflectionttimp "FirstSuccess") + reflect fc defs env Unique = getCon fc defs (reflectionttimp "Unique") reflect fc defs env (UniqueDefault x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "UniqueDefault") [x'] + appCon fc defs (reflectionttimp "UniqueDefault") [x'] export Reflect FnOpt where - reflect fc defs env Inline = getCon fc defs (reflection "FirstSuccess") + reflect fc defs env Inline = getCon fc defs (reflectionttimp "FirstSuccess") reflect fc defs env (Hint x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "Hint") [x'] + appCon fc defs (reflectionttimp "Hint") [x'] reflect fc defs env (GlobalHint x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "GlobalHint") [x'] - reflect fc defs env ExternFn = getCon fc defs (reflection "ExternFn") + appCon fc defs (reflectionttimp "GlobalHint") [x'] + reflect fc defs env ExternFn = getCon fc defs (reflectionttimp "ExternFn") reflect fc defs env (ForeignFn x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "ForeignFn") [x'] - reflect fc defs env Invertible = getCon fc defs (reflection "Invertible") - reflect fc defs env Total = getCon fc defs (reflection "Total") - reflect fc defs env Covering = getCon fc defs (reflection "Covering") - reflect fc defs env PartialOK = getCon fc defs (reflection "PartialOK") + appCon fc defs (reflectionttimp "ForeignFn") [x'] + reflect fc defs env Invertible = getCon fc defs (reflectionttimp "Invertible") + reflect fc defs env Total = getCon fc defs (reflectionttimp "Total") + reflect fc defs env Covering = getCon fc defs (reflectionttimp "Covering") + reflect fc defs env PartialOK = getCon fc defs (reflectionttimp "PartialOK") + reflect fc defs env Macro = getCon fc defs (reflectionttimp "Macro") export Reflect ImpTy where @@ -512,14 +515,14 @@ mutual = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "MkTy") [x', y', z'] + appCon fc defs (reflectionttimp "MkTy") [x', y', z'] export Reflect DataOpt where reflect fc defs env (SearchBy x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "SearchBy") [x'] - reflect fc defs env NoHints = getCon fc defs (reflection "NoHints") + appCon fc defs (reflectionttimp "SearchBy") [x'] + reflect fc defs env NoHints = getCon fc defs (reflectionttimp "NoHints") export Reflect ImpData where @@ -529,12 +532,12 @@ mutual x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "MkData") [v', w', x', y', z'] + appCon fc defs (reflectionttimp "MkData") [v', w', x', y', z'] reflect fc defs env (MkImpLater x y z) = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "MkLater") [x', y', z'] + appCon fc defs (reflectionttimp "MkLater") [x', y', z'] export Reflect IField where @@ -544,7 +547,7 @@ mutual x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "MkIField") [v', w', x', y', z'] + appCon fc defs (reflectionttimp "MkIField") [v', w', x', y', z'] export Reflect ImpRecord where @@ -554,7 +557,7 @@ mutual x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "MkRecord") [v', w', x', y', z'] + appCon fc defs (reflectionttimp "MkRecord") [v', w', x', y', z'] export Reflect ImpClause where @@ -562,17 +565,17 @@ mutual = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "PatClause") [x', y', z'] + appCon fc defs (reflectionttimp "PatClause") [x', y', z'] reflect fc defs env (WithClause w x y z) = do w' <- reflect fc defs env x x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "WithClause") [w', x', y', z'] + appCon fc defs (reflectionttimp "WithClause") [w', x', y', z'] reflect fc defs env (ImpossibleClause x y) = do x' <- reflect fc defs env x y' <- reflect fc defs env y - appCon fc defs (reflection "ImpossibleClause") [x', y'] + appCon fc defs (reflectionttimp "ImpossibleClause") [x', y'] export Reflect ImpDecl where @@ -582,42 +585,42 @@ mutual x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "IClaim") [v', w', x', y', z'] + appCon fc defs (reflectionttimp "IClaim") [v', w', x', y', z'] reflect fc defs env (IData x y z) = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "IData") [x', y', z'] + appCon fc defs (reflectionttimp "IData") [x', y', z'] reflect fc defs env (IDef x y z) = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "IDef") [x', y', z'] + appCon fc defs (reflectionttimp "IDef") [x', y', z'] reflect fc defs env (IParameters x y z) = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "IParameters") [x', y', z'] + appCon fc defs (reflectionttimp "IParameters") [x', y', z'] reflect fc defs env (IRecord x y z) = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "IRecord") [x', y', z'] + appCon fc defs (reflectionttimp "IRecord") [x', y', z'] reflect fc defs env (INamespace w x y z) = do w' <- reflect fc defs env w x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "INamespace") [w', x', y', z'] + appCon fc defs (reflectionttimp "INamespace") [w', x', y', z'] reflect fc defs env (ITransform x y z) = do x' <- reflect fc defs env x y' <- reflect fc defs env y z' <- reflect fc defs env z - appCon fc defs (reflection "ITransform") [x', y', z'] + appCon fc defs (reflectionttimp "ITransform") [x', y', z'] reflect fc defs env (IPragma x) = throw (GenericMsg fc "Can't reflect a pragma") reflect fc defs env (ILog x) = do x' <- reflect fc defs env x - appCon fc defs (reflection "ILog") [x'] + appCon fc defs (reflectionttimp "ILog") [x'] diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index 4914000..7c7d134 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -170,6 +170,7 @@ mutual Total : FnOpt Covering : FnOpt PartialOK : FnOpt + Macro : FnOpt export Show FnOpt where @@ -182,6 +183,7 @@ mutual show Total = "total" show Covering = "covering" show PartialOK = "partial" + show Macro = "%macro" export Eq FnOpt where @@ -194,6 +196,7 @@ mutual Total == Total = True Covering == Covering = True PartialOK == PartialOK = True + Macro == Macro = True _ == _ = False public export @@ -811,6 +814,7 @@ mutual toBuf b Total = tag 6 toBuf b Covering = tag 7 toBuf b PartialOK = tag 8 + toBuf b Macro = tag 9 fromBuf b = case !getTag of @@ -823,6 +827,7 @@ mutual 6 => pure Total 7 => pure Covering 8 => pure PartialOK + 9 => pure Macro _ => corrupt "FnOpt" export From 07509f6103c081b40039f97124b441938807be5d Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Sat, 30 Nov 2019 15:26:17 +0000 Subject: [PATCH 15/18] Begin elaboration of quoting terms --- idris2.ipkg | 1 + libs/base/Language/Reflection/TTImp.idr | 5 +++ src/Core/Binary.idr | 2 +- src/Idris/Desugar.idr | 14 ++++---- src/Idris/Resugar.idr | 7 ++++ src/Idris/Syntax.idr | 2 ++ src/TTImp/Elab/Quote.idr | 33 ++++++++++++++++++ src/TTImp/Elab/Term.idr | 7 ++++ src/TTImp/Reflect.idr | 24 +++++++++++++ src/TTImp/TTImp.idr | 45 ++++++++++++++++++++----- 10 files changed, 125 insertions(+), 15 deletions(-) create mode 100644 src/TTImp/Elab/Quote.idr diff --git a/idris2.ipkg b/idris2.ipkg index 6e26d15..12b93d2 100644 --- a/idris2.ipkg +++ b/idris2.ipkg @@ -95,6 +95,7 @@ modules = TTImp.Elab.Lazy, TTImp.Elab.Local, TTImp.Elab.Prim, + TTImp.Elab.Quote, TTImp.Elab.Record, TTImp.Elab.Rewrite, TTImp.Elab.Term, diff --git a/libs/base/Language/Reflection/TTImp.idr b/libs/base/Language/Reflection/TTImp.idr index 4b6f17e..0256515 100644 --- a/libs/base/Language/Reflection/TTImp.idr +++ b/libs/base/Language/Reflection/TTImp.idr @@ -51,6 +51,11 @@ mutual IDelay : FC -> TTImp -> TTImp -- delay constructor IForce : FC -> TTImp -> TTImp + -- Quasiquotation + IQuote : FC -> TTImp -> TTImp + IQuoteDecl : FC -> TTImp -> TTImp + IUnquote : FC -> TTImp -> TTImp + IPrimVal : FC -> (c : Constant) -> TTImp IType : FC -> TTImp IHole : FC -> String -> TTImp diff --git a/src/Core/Binary.idr b/src/Core/Binary.idr index fa6d888..900b8ea 100644 --- a/src/Core/Binary.idr +++ b/src/Core/Binary.idr @@ -27,7 +27,7 @@ import Data.Buffer -- TTC files can only be compatible if the version number is the same export ttcVersion : Int -ttcVersion = 10 +ttcVersion = 11 export checkTTCVersion : Int -> Int -> Core () diff --git a/src/Idris/Desugar.idr b/src/Idris/Desugar.idr index 0b3ecb2..40e9ce2 100644 --- a/src/Idris/Desugar.idr +++ b/src/Idris/Desugar.idr @@ -203,12 +203,14 @@ mutual Just f => pure $ IApp fc (IVar fc f) (IPrimVal fc (Ch x)) desugar side ps (PPrimVal fc x) = pure $ IPrimVal fc x - desugar side ps (PQuote fc x) - = throw (GenericMsg fc "Reflection not implemeted yet") --- = pure $ IQuote fc !(desugar side ps x) - desugar side ps (PUnquote fc x) - = throw (GenericMsg fc "Reflection not implemeted yet") --- = pure $ IUnquote fc !(desugar side ps x) + desugar side ps (PQuote fc tm) + = pure $ IQuote fc !(desugar side ps tm) + desugar side ps (PQuoteDecl fc x) + = do [x'] <- desugarDecl ps x + | _ => throw (GenericMsg fc "Can't quote this declaration") + pure $ IQuoteDecl fc x' + desugar side ps (PUnquote fc tm) + = pure $ IUnquote fc !(desugar side ps tm) desugar side ps (PHole fc br holename) = do when br $ do syn <- get Syn diff --git a/src/Idris/Resugar.idr b/src/Idris/Resugar.idr index 2ab69cc..2235190 100644 --- a/src/Idris/Resugar.idr +++ b/src/Idris/Resugar.idr @@ -214,6 +214,13 @@ mutual toPTerm p (IDelayed fc r ty) = pure (PDelayed fc r !(toPTerm argPrec ty)) toPTerm p (IDelay fc tm) = pure (PDelay fc !(toPTerm argPrec tm)) toPTerm p (IForce fc tm) = pure (PForce fc !(toPTerm argPrec tm)) + toPTerm p (IQuote fc tm) = pure (PQuote fc !(toPTerm argPrec tm)) + toPTerm p (IQuoteDecl fc d) + = do md <- toPDecl d + case md of + Nothing => throw (InternalError "Can't resugar log or pragma") + Just d' => pure (PQuoteDecl fc d') + toPTerm p (IUnquote fc tm) = pure (PUnquote fc !(toPTerm argPrec tm)) toPTerm p (Implicit fc True) = pure (PImplicit fc) toPTerm p (Implicit fc False) = pure (PInfer fc) diff --git a/src/Idris/Syntax.idr b/src/Idris/Syntax.idr index d56b4ab..a5a248f 100644 --- a/src/Idris/Syntax.idr +++ b/src/Idris/Syntax.idr @@ -55,6 +55,7 @@ mutual PSearch : FC -> (depth : Nat) -> PTerm PPrimVal : FC -> Constant -> PTerm PQuote : FC -> PTerm -> PTerm + PQuoteDecl : FC -> PDecl -> PTerm PUnquote : FC -> PTerm -> PTerm PHole : FC -> (bracket : Bool) -> (holename : String) -> PTerm PType : FC -> PTerm @@ -394,6 +395,7 @@ mutual = showPrec d f ++ " {" ++ showPrec d n ++ " = " ++ showPrec d a ++ "}" showPrec _ (PSearch _ _) = "%search" showPrec d (PQuote _ tm) = "`(" ++ showPrec d tm ++ ")" + showPrec d (PQuoteDecl _ tm) = "`( <> )" showPrec d (PUnquote _ tm) = "~(" ++ showPrec d tm ++ ")" showPrec d (PPrimVal _ c) = showPrec d c showPrec _ (PHole _ _ n) = "?" ++ n diff --git a/src/TTImp/Elab/Quote.idr b/src/TTImp/Elab/Quote.idr new file mode 100644 index 0000000..5ecbfd1 --- /dev/null +++ b/src/TTImp/Elab/Quote.idr @@ -0,0 +1,33 @@ +module TTImp.Elab.Quote + +import Core.Context +import Core.Core +import Core.Env +import Core.Metadata +import Core.Normalise +import Core.Reflect +import Core.Unify +import Core.TT +import Core.Value + +import TTImp.Elab.Check +import TTImp.Reflect +import TTImp.TTImp + +%default covering + +export +checkQuote : {vars : _} -> + {auto c : Ref Ctxt Defs} -> + {auto m : Ref MD Metadata} -> + {auto u : Ref UST UState} -> + {auto e : Ref EST (EState vars)} -> + RigCount -> ElabInfo -> + NestedNames vars -> Env Term vars -> + FC -> RawImp -> Maybe (Glued vars) -> + Core (Term vars, Glued vars) +checkQuote rig elabinfo nest env fc tm exp + = do defs <- get Ctxt + tm <- reflect fc defs env tm + ty <- getCon fc defs (reflectionttimp "TTImp") + checkExp rig elabinfo env fc tm (gnf env ty) exp diff --git a/src/TTImp/Elab/Term.idr b/src/TTImp/Elab/Term.idr index aa57c8a..c608b03 100644 --- a/src/TTImp/Elab/Term.idr +++ b/src/TTImp/Elab/Term.idr @@ -22,6 +22,7 @@ import TTImp.Elab.ImplicitBind import TTImp.Elab.Lazy import TTImp.Elab.Local import TTImp.Elab.Prim +import TTImp.Elab.Quote import TTImp.Elab.Record import TTImp.Elab.Rewrite import TTImp.Reflect @@ -151,6 +152,12 @@ checkTerm rig elabinfo nest env (IDelay fc tm) exp = checkDelay rig elabinfo nest env fc tm exp checkTerm rig elabinfo nest env (IForce fc tm) exp = checkForce rig elabinfo nest env fc tm exp +checkTerm rig elabinfo nest env (IQuote fc tm) exp + = checkQuote rig elabinfo nest env fc tm exp +checkTerm rig elabinfo nest env (IQuoteDecl fc tm) exp + = throw (GenericMsg fc "Reflection not implemented yet") +checkTerm rig elabinfo nest env (IUnquote fc tm) exp + = throw (InternalError "Unquote should have been resolved") checkTerm {vars} rig elabinfo nest env (IPrimVal fc c) exp = do let (cval, cty) = checkPrim {vars} fc c checkExp rig elabinfo env fc cval (gnf env cty) exp diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr index a76375c..3eecc1a 100644 --- a/src/TTImp/Reflect.idr +++ b/src/TTImp/Reflect.idr @@ -157,6 +157,18 @@ mutual = do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) pure (IForce fc' t') + reify defs (NDCon _ (NS _ (UN "IQuote")) _ _ [fc, t]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + pure (IQuote fc' t') + reify defs (NDCon _ (NS _ (UN "IQuoteDecl")) _ _ [fc, t]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + pure (IQuoteDecl fc' t') + reify defs (NDCon _ (NS _ (UN "IUnquote")) _ _ [fc, t]) + = do fc' <- reify defs !(evalClosure defs fc) + t' <- reify defs !(evalClosure defs t) + pure (IUnquote fc' t') reify defs (NDCon _ (NS _ (UN "IPrimVal")) _ _ [fc, t]) = do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) @@ -455,6 +467,18 @@ mutual = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t appCon fc defs (reflectionttimp "IForce") [fc', t'] + reflect fc defs env (IQuote tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflectionttimp "IQuote") [fc', t'] + reflect fc defs env (IQuoteDecl tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflectionttimp "IQuoteDecl") [fc', t'] + reflect fc defs env (IUnquote tfc t) + = do fc' <- reflect fc defs env tfc + t' <- reflect fc defs env t + appCon fc defs (reflectionttimp "IUnquote") [fc', t'] reflect fc defs env (IPrimVal tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index 7c7d134..49eb027 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -82,6 +82,11 @@ mutual IDelay : FC -> RawImp -> RawImp -- delay constructor IForce : FC -> RawImp -> RawImp + -- Quasiquoting + IQuote : FC -> RawImp -> RawImp + IQuoteDecl : FC -> ImpDecl -> RawImp + IUnquote : FC -> RawImp -> RawImp + IPrimVal : FC -> (c : Constant) -> RawImp IType : FC -> RawImp IHole : FC -> String -> RawImp @@ -143,6 +148,9 @@ mutual show (IDelayed fc r tm) = "(%delayed " ++ show tm ++ ")" show (IDelay fc tm) = "(%delay " ++ show tm ++ ")" show (IForce fc tm) = "(%force " ++ show tm ++ ")" + show (IQuote fc tm) = "(%quote " ++ show tm ++ ")" + show (IQuoteDecl fc tm) = "(%quotedecl " ++ show tm ++ ")" + show (IUnquote fc tm) = "(%unquote " ++ show tm ++ ")" show (IPrimVal fc c) = show c show (IHole _ x) = "?" ++ x show (IType fc) = "%type" @@ -369,6 +377,8 @@ findIBinds (IAlternative fc u alts) findIBinds (IDelayed fc _ ty) = findIBinds ty findIBinds (IDelay fc tm) = findIBinds tm findIBinds (IForce fc tm) = findIBinds tm +findIBinds (IQuote fc tm) = findIBinds tm +findIBinds (IUnquote fc tm) = findIBinds tm findIBinds (IBindHere _ _ tm) = findIBinds tm findIBinds (IBindVar _ n) = [n] -- We've skipped lambda, case, let and local - rather than guess where the @@ -398,6 +408,8 @@ findImplicits (IAlternative fc u alts) findImplicits (IDelayed fc _ ty) = findImplicits ty findImplicits (IDelay fc tm) = findImplicits tm findImplicits (IForce fc tm) = findImplicits tm +findImplicits (IQuote fc tm) = findImplicits tm +findImplicits (IUnquote fc tm) = findImplicits tm findImplicits (IBindVar _ n) = [n] findImplicits tm = [] @@ -514,6 +526,9 @@ getFC (IMustUnify x _ _) = x getFC (IDelayed x _ _) = x getFC (IDelay x _) = x getFC (IForce x _) = x +getFC (IQuote x _) = x +getFC (IQuoteDecl x _) = x +getFC (IUnquote x _) = x getFC (IAs x _ _ _) = x getFC (Implicit x _) = x @@ -582,15 +597,22 @@ mutual toBuf b (IForce fc t) = do tag 20; toBuf b fc; toBuf b t + toBuf b (IQuote fc t) + = do tag 21; toBuf b fc; toBuf b t + toBuf b (IQuoteDecl fc t) + = do tag 22; toBuf b fc; toBuf b t + toBuf b (IUnquote fc t) + = do tag 23; toBuf b fc; toBuf b t + toBuf b (IPrimVal fc y) - = do tag 21; toBuf b fc; toBuf b y + = do tag 24; toBuf b fc; toBuf b y toBuf b (IType fc) - = do tag 22; toBuf b fc + = do tag 25; toBuf b fc toBuf b (IHole fc y) - = do tag 23; toBuf b fc; toBuf b y + = do tag 26; toBuf b fc; toBuf b y toBuf b (Implicit fc i) - = do tag 24; toBuf b fc; toBuf b i + = do tag 27; toBuf b fc; toBuf b i fromBuf b = case !getTag of @@ -658,12 +680,19 @@ mutual pure (IForce fc y) 21 => do fc <- fromBuf b; y <- fromBuf b - pure (IPrimVal fc y) - 22 => do fc <- fromBuf b - pure (IType fc) + pure (IQuote fc y) + 22 => do fc <- fromBuf b; y <- fromBuf b + pure (IQuoteDecl fc y) 23 => do fc <- fromBuf b; y <- fromBuf b + pure (IUnquote fc y) + + 24 => do fc <- fromBuf b; y <- fromBuf b + pure (IPrimVal fc y) + 25 => do fc <- fromBuf b + pure (IType fc) + 26 => do fc <- fromBuf b; y <- fromBuf b pure (IHole fc y) - 24 => do fc <- fromBuf b + 27 => do fc <- fromBuf b i <- fromBuf b pure (Implicit fc i) _ => corrupt "RawImp" From d5cde3f4f9716690d156c3de44cc2feb411282ec Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Sat, 30 Nov 2019 19:42:39 +0000 Subject: [PATCH 16/18] Add unquoting/escaping --- src/TTImp/Elab/Quote.idr | 167 ++++++++++++++++++++++++++++++++++++++- src/TTImp/Elab/Term.idr | 4 +- src/TTImp/Reflect.idr | 6 +- 3 files changed, 169 insertions(+), 8 deletions(-) diff --git a/src/TTImp/Elab/Quote.idr b/src/TTImp/Elab/Quote.idr index 5ecbfd1..46d1b42 100644 --- a/src/TTImp/Elab/Quote.idr +++ b/src/TTImp/Elab/Quote.idr @@ -16,6 +16,162 @@ import TTImp.TTImp %default covering +-- Collecting names and terms to let bind for unquoting +data Unq : Type where + +-- Collect the escaped subterms in a term we're about to quote, and let bind +-- them first +mutual + getUnquote : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + RawImp -> + Core RawImp + getUnquote (IPi fc c p n arg ret) + = pure $ IPi fc c p n !(getUnquote arg) !(getUnquote ret) + getUnquote (ILam fc c p n arg sc) + = pure $ ILam fc c p n !(getUnquote arg) !(getUnquote sc) + getUnquote (ILet fc c n ty val sc) + = pure $ ILet fc c n !(getUnquote ty) !(getUnquote val) !(getUnquote sc) + getUnquote (ICase fc sc ty cs) + = pure $ ICase fc !(getUnquote sc) !(getUnquote ty) + !(traverse getUnquoteClause cs) + getUnquote (ILocal fc ds sc) + = pure $ ILocal fc !(traverse getUnquoteDecl ds) !(getUnquote sc) + getUnquote (IUpdate fc ds sc) + = pure $ IUpdate fc !(traverse getUnquoteUpdate ds) !(getUnquote sc) + getUnquote (IApp fc f a) + = pure $ IApp fc !(getUnquote f) !(getUnquote a) + getUnquote (IImplicitApp fc f n a) + = pure $ IImplicitApp fc !(getUnquote f) n !(getUnquote a) + getUnquote (IWithApp fc f a) + = pure $ IWithApp fc !(getUnquote f) !(getUnquote a) + getUnquote (IAlternative fc at as) + = pure $ IAlternative fc at !(traverse getUnquote as) + getUnquote (IRewrite fc f a) + = pure $ IRewrite fc !(getUnquote f) !(getUnquote a) + getUnquote (ICoerced fc t) + = pure $ ICoerced fc !(getUnquote t) + getUnquote (IBindHere fc m t) + = pure $ IBindHere fc m !(getUnquote t) + getUnquote (IAs fc u nm t) + = pure $ IAs fc u nm !(getUnquote t) + getUnquote (IMustUnify fc r t) + = pure $ IMustUnify fc r !(getUnquote t) + getUnquote (IDelayed fc r t) + = pure $ IDelayed fc r !(getUnquote t) + getUnquote (IDelay fc t) + = pure $ IDelay fc !(getUnquote t) + getUnquote (IForce fc t) + = pure $ IForce fc !(getUnquote t) + getUnquote (IQuote fc t) + = pure $ IQuote fc !(getUnquote t) + getUnquote (IUnquote fc tm) + = do qv <- genVarName "q" + unqs <- get Unq + put Unq ((qv, fc, tm) :: unqs) + pure (IUnquote fc (IVar fc qv)) -- turned into just qv when reflecting + getUnquote tm = pure tm + + getUnquoteClause : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + ImpClause -> + Core ImpClause + getUnquoteClause (PatClause fc l r) + = pure $ PatClause fc !(getUnquote l) !(getUnquote r) + getUnquoteClause (WithClause fc l w cs) + = pure $ WithClause fc !(getUnquote l) !(getUnquote w) + !(traverse getUnquoteClause cs) + getUnquoteClause (ImpossibleClause fc l) + = pure $ ImpossibleClause fc !(getUnquote l) + + getUnquoteUpdate : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + IFieldUpdate -> + Core IFieldUpdate + getUnquoteUpdate (ISetField p t) = pure $ ISetField p !(getUnquote t) + getUnquoteUpdate (ISetFieldApp p t) = pure $ ISetFieldApp p !(getUnquote t) + + getUnquoteTy : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + ImpTy -> + Core ImpTy + getUnquoteTy (MkImpTy fc n t) = pure $ MkImpTy fc n !(getUnquote t) + + getUnquoteField : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + IField -> + Core IField + getUnquoteField (MkIField fc c p n ty) + = pure $ MkIField fc c p n !(getUnquote ty) + + getUnquoteRecord : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + ImpRecord -> + Core ImpRecord + getUnquoteRecord (MkImpRecord fc n ps cn fs) + = pure $ MkImpRecord fc n !(traverse unqPair ps) cn + !(traverse getUnquoteField fs) + where + unqPair : (Name, RawImp) -> Core (Name, RawImp) + unqPair (n, t) = pure (n, !(getUnquote t)) + + getUnquoteData : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + ImpData -> + Core ImpData + getUnquoteData (MkImpData fc n tc opts cs) + = pure $ MkImpData fc n !(getUnquote tc) opts + !(traverse getUnquoteTy cs) + getUnquoteData (MkImpLater fc n tc) + = pure $ MkImpLater fc n !(getUnquote tc) + + getUnquoteDecl : {auto c : Ref Ctxt Defs} -> + {auto q : Ref Unq (List (Name, FC, RawImp))} -> + {auto u : Ref UST UState} -> + ImpDecl -> + Core ImpDecl + getUnquoteDecl (IClaim fc c v opts ty) + = pure $ IClaim fc c v opts !(getUnquoteTy ty) + getUnquoteDecl (IData fc v d) + = pure $ IData fc v !(getUnquoteData d) + getUnquoteDecl (IDef fc v d) + = pure $ IDef fc v !(traverse getUnquoteClause d) + getUnquoteDecl (IParameters fc ps ds) + = pure $ IParameters fc !(traverse unqPair ps) + !(traverse getUnquoteDecl ds) + where + unqPair : (Name, RawImp) -> Core (Name, RawImp) + unqPair (n, t) = pure (n, !(getUnquote t)) + getUnquoteDecl (IRecord fc v d) + = pure $ IRecord fc v !(getUnquoteRecord d) + getUnquoteDecl (INamespace fc nest ns ds) + = pure $ INamespace fc nest ns !(traverse getUnquoteDecl ds) + getUnquoteDecl (ITransform fc l r) + = pure $ ITransform fc !(getUnquote l) !(getUnquote r) + getUnquoteDecl d = pure d + +bindUnqs : {auto c : Ref Ctxt Defs} -> + {auto m : Ref MD Metadata} -> + {auto u : Ref UST UState} -> + {auto e : Ref EST (EState vars)} -> + List (Name, FC, RawImp) -> + RigCount -> ElabInfo -> NestedNames vars -> Env Term vars -> + Term vars -> + Core (Term vars) +bindUnqs [] _ _ _ _ tm = pure tm +bindUnqs ((qvar, fc, esctm) :: qs) rig elabinfo nest env tm + = do (escv, escty) <- check rig elabinfo nest env esctm Nothing + sc <- bindUnqs qs rig elabinfo nest env tm + pure (Bind fc qvar (Let (rigMult RigW rig) escv !(getTerm escty)) + (refToLocal qvar qvar sc)) + export checkQuote : {vars : _} -> {auto c : Ref Ctxt Defs} -> @@ -28,6 +184,11 @@ checkQuote : {vars : _} -> Core (Term vars, Glued vars) checkQuote rig elabinfo nest env fc tm exp = do defs <- get Ctxt - tm <- reflect fc defs env tm - ty <- getCon fc defs (reflectionttimp "TTImp") - checkExp rig elabinfo env fc tm (gnf env ty) exp + q <- newRef Unq (the (List (Name, FC, RawImp)) []) + tm' <- getUnquote tm + qtm <- reflect fc defs env tm' + unqs <- get Unq + qty <- getCon fc defs (reflectionttimp "TTImp") + checkExp rig elabinfo env fc + !(bindUnqs unqs rig elabinfo nest env qtm) + (gnf env qty) exp diff --git a/src/TTImp/Elab/Term.idr b/src/TTImp/Elab/Term.idr index c608b03..5acbefe 100644 --- a/src/TTImp/Elab/Term.idr +++ b/src/TTImp/Elab/Term.idr @@ -155,9 +155,9 @@ checkTerm rig elabinfo nest env (IForce fc tm) exp checkTerm rig elabinfo nest env (IQuote fc tm) exp = checkQuote rig elabinfo nest env fc tm exp checkTerm rig elabinfo nest env (IQuoteDecl fc tm) exp - = throw (GenericMsg fc "Reflection not implemented yet") + = throw (GenericMsg fc "Declaration reflection not implemented yet") checkTerm rig elabinfo nest env (IUnquote fc tm) exp - = throw (InternalError "Unquote should have been resolved") + = throw (GenericMsg fc "Can't escape outside a quoted term") checkTerm {vars} rig elabinfo nest env (IPrimVal fc c) exp = do let (cval, cty) = checkPrim {vars} fc c checkExp rig elabinfo env fc cval (gnf env cty) exp diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr index 3eecc1a..b8344ee 100644 --- a/src/TTImp/Reflect.idr +++ b/src/TTImp/Reflect.idr @@ -475,10 +475,10 @@ mutual = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t appCon fc defs (reflectionttimp "IQuoteDecl") [fc', t'] + reflect fc defs env (IUnquote tfc (IVar _ t)) + = pure (Ref tfc Bound t) reflect fc defs env (IUnquote tfc t) - = do fc' <- reflect fc defs env tfc - t' <- reflect fc defs env t - appCon fc defs (reflectionttimp "IUnquote") [fc', t'] + = throw (InternalError "Can't reflect an unquote: escapes should be lifted out") reflect fc defs env (IPrimVal tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t From 0a51a7280661d842909833a5edbca0dbeed4e7b2 Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Thu, 5 Dec 2019 18:58:53 +0000 Subject: [PATCH 17/18] Add runElab to syntax tree Nothing done yet in the elaborator, but it's ready to be filled in later --- libs/base/Language/Reflection.idr | 24 +++++++++++++++++++++--- src/Core/Binary.idr | 2 +- src/Idris/Desugar.idr | 2 ++ src/Idris/Resugar.idr | 1 + src/Idris/Syntax.idr | 2 ++ src/TTImp/Elab/Term.idr | 2 ++ src/TTImp/Reflect.idr | 2 ++ src/TTImp/TTImp.idr | 25 +++++++++++++++++-------- 8 files changed, 48 insertions(+), 12 deletions(-) diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr index d2d5550..3a0685b 100644 --- a/libs/base/Language/Reflection.idr +++ b/libs/base/Language/Reflection.idr @@ -4,7 +4,25 @@ import public Language.Reflection.TT import public Language.Reflection.TTImp public export -data TC : Type -> Type where - Check : TTImp -> TC a - Bind : TC a -> (a -> TC b) -> TC b +data Elab : Type -> Type where + Pure : a -> Elab a + Bind : Elab a -> (a -> Elab b) -> Elab b + Check : TTImp -> Elab a + +mutual + export + Functor Elab where + map f e = do e' <- e + pure (f e') + + export + Applicative Elab where + pure = Pure + f <*> a = do f' <- f + a' <- a + pure (f' a') + + export + Monad Elab where + (>>=) = Bind diff --git a/src/Core/Binary.idr b/src/Core/Binary.idr index 900b8ea..08b18b5 100644 --- a/src/Core/Binary.idr +++ b/src/Core/Binary.idr @@ -27,7 +27,7 @@ import Data.Buffer -- TTC files can only be compatible if the version number is the same export ttcVersion : Int -ttcVersion = 11 +ttcVersion = 12 export checkTTCVersion : Int -> Int -> Core () diff --git a/src/Idris/Desugar.idr b/src/Idris/Desugar.idr index 40e9ce2..e7fd327 100644 --- a/src/Idris/Desugar.idr +++ b/src/Idris/Desugar.idr @@ -211,6 +211,8 @@ mutual pure $ IQuoteDecl fc x' desugar side ps (PUnquote fc tm) = pure $ IUnquote fc !(desugar side ps tm) + desugar side ps (PRunElab fc tm) + = pure $ IRunElab fc !(desugar side ps tm) desugar side ps (PHole fc br holename) = do when br $ do syn <- get Syn diff --git a/src/Idris/Resugar.idr b/src/Idris/Resugar.idr index 2235190..c24b851 100644 --- a/src/Idris/Resugar.idr +++ b/src/Idris/Resugar.idr @@ -221,6 +221,7 @@ mutual Nothing => throw (InternalError "Can't resugar log or pragma") Just d' => pure (PQuoteDecl fc d') toPTerm p (IUnquote fc tm) = pure (PUnquote fc !(toPTerm argPrec tm)) + toPTerm p (IRunElab fc tm) = pure (PRunElab fc !(toPTerm argPrec tm)) toPTerm p (Implicit fc True) = pure (PImplicit fc) toPTerm p (Implicit fc False) = pure (PInfer fc) diff --git a/src/Idris/Syntax.idr b/src/Idris/Syntax.idr index a5a248f..ce22a33 100644 --- a/src/Idris/Syntax.idr +++ b/src/Idris/Syntax.idr @@ -57,6 +57,7 @@ mutual PQuote : FC -> PTerm -> PTerm PQuoteDecl : FC -> PDecl -> PTerm PUnquote : FC -> PTerm -> PTerm + PRunElab : FC -> PTerm -> PTerm PHole : FC -> (bracket : Bool) -> (holename : String) -> PTerm PType : FC -> PTerm PAs : FC -> Name -> (pattern : PTerm) -> PTerm @@ -397,6 +398,7 @@ mutual showPrec d (PQuote _ tm) = "`(" ++ showPrec d tm ++ ")" showPrec d (PQuoteDecl _ tm) = "`( <> )" showPrec d (PUnquote _ tm) = "~(" ++ showPrec d tm ++ ")" + showPrec d (PRunElab _ tm) = "%runElab " ++ showPrec d tm showPrec d (PPrimVal _ c) = showPrec d c showPrec _ (PHole _ _ n) = "?" ++ n showPrec _ (PType _) = "Type" diff --git a/src/TTImp/Elab/Term.idr b/src/TTImp/Elab/Term.idr index 5acbefe..991e2d2 100644 --- a/src/TTImp/Elab/Term.idr +++ b/src/TTImp/Elab/Term.idr @@ -158,6 +158,8 @@ checkTerm rig elabinfo nest env (IQuoteDecl fc tm) exp = throw (GenericMsg fc "Declaration reflection not implemented yet") checkTerm rig elabinfo nest env (IUnquote fc tm) exp = throw (GenericMsg fc "Can't escape outside a quoted term") +checkTerm rig elabinfo nest env (IRunElab fc tm) exp + = throw (GenericMsg fc "RunElab not implemented yet") checkTerm {vars} rig elabinfo nest env (IPrimVal fc c) exp = do let (cval, cty) = checkPrim {vars} fc c checkExp rig elabinfo env fc cval (gnf env cty) exp diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr index b8344ee..0c5fd4c 100644 --- a/src/TTImp/Reflect.idr +++ b/src/TTImp/Reflect.idr @@ -479,6 +479,8 @@ mutual = pure (Ref tfc Bound t) reflect fc defs env (IUnquote tfc t) = throw (InternalError "Can't reflect an unquote: escapes should be lifted out") + reflect fc defs env (IRunElab tfc t) + = throw (InternalError "Can't reflect a %runelab") reflect fc defs env (IPrimVal tfc t) = do fc' <- reflect fc defs env tfc t' <- reflect fc defs env t diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index 49eb027..67a9e05 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -86,6 +86,7 @@ mutual IQuote : FC -> RawImp -> RawImp IQuoteDecl : FC -> ImpDecl -> RawImp IUnquote : FC -> RawImp -> RawImp + IRunElab : FC -> RawImp -> RawImp IPrimVal : FC -> (c : Constant) -> RawImp IType : FC -> RawImp @@ -151,6 +152,7 @@ mutual show (IQuote fc tm) = "(%quote " ++ show tm ++ ")" show (IQuoteDecl fc tm) = "(%quotedecl " ++ show tm ++ ")" show (IUnquote fc tm) = "(%unquote " ++ show tm ++ ")" + show (IRunElab fc tm) = "(%runelab " ++ show tm ++ ")" show (IPrimVal fc c) = show c show (IHole _ x) = "?" ++ x show (IType fc) = "%type" @@ -379,6 +381,7 @@ findIBinds (IDelay fc tm) = findIBinds tm findIBinds (IForce fc tm) = findIBinds tm findIBinds (IQuote fc tm) = findIBinds tm findIBinds (IUnquote fc tm) = findIBinds tm +findIBinds (IRunElab fc tm) = findIBinds tm findIBinds (IBindHere _ _ tm) = findIBinds tm findIBinds (IBindVar _ n) = [n] -- We've skipped lambda, case, let and local - rather than guess where the @@ -410,6 +413,7 @@ findImplicits (IDelay fc tm) = findImplicits tm findImplicits (IForce fc tm) = findImplicits tm findImplicits (IQuote fc tm) = findImplicits tm findImplicits (IUnquote fc tm) = findImplicits tm +findImplicits (IRunElab fc tm) = findImplicits tm findImplicits (IBindVar _ n) = [n] findImplicits tm = [] @@ -529,6 +533,7 @@ getFC (IForce x _) = x getFC (IQuote x _) = x getFC (IQuoteDecl x _) = x getFC (IUnquote x _) = x +getFC (IRunElab x _) = x getFC (IAs x _ _ _) = x getFC (Implicit x _) = x @@ -603,16 +608,18 @@ mutual = do tag 22; toBuf b fc; toBuf b t toBuf b (IUnquote fc t) = do tag 23; toBuf b fc; toBuf b t + toBuf b (IRunElab fc t) + = do tag 24; toBuf b fc; toBuf b t toBuf b (IPrimVal fc y) - = do tag 24; toBuf b fc; toBuf b y + = do tag 25; toBuf b fc; toBuf b y toBuf b (IType fc) - = do tag 25; toBuf b fc + = do tag 26; toBuf b fc toBuf b (IHole fc y) - = do tag 26; toBuf b fc; toBuf b y + = do tag 27; toBuf b fc; toBuf b y toBuf b (Implicit fc i) - = do tag 27; toBuf b fc; toBuf b i + = do tag 28; toBuf b fc; toBuf b i fromBuf b = case !getTag of @@ -685,14 +692,16 @@ mutual pure (IQuoteDecl fc y) 23 => do fc <- fromBuf b; y <- fromBuf b pure (IUnquote fc y) - 24 => do fc <- fromBuf b; y <- fromBuf b + pure (IRunElab fc y) + + 25 => do fc <- fromBuf b; y <- fromBuf b pure (IPrimVal fc y) - 25 => do fc <- fromBuf b + 26 => do fc <- fromBuf b pure (IType fc) - 26 => do fc <- fromBuf b; y <- fromBuf b + 27 => do fc <- fromBuf b; y <- fromBuf b pure (IHole fc y) - 27 => do fc <- fromBuf b + 28 => do fc <- fromBuf b i <- fromBuf b pure (Implicit fc i) _ => corrupt "RawImp" From 6c165cab52bdb070544fdcaa21cdcdfa8c70481f Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Fri, 6 Dec 2019 11:17:07 +0000 Subject: [PATCH 18/18] Change default precedence of `op` For consistency with Idris 1, they should be lowest precedence (other than $) rather than highest. Fixes #112 --- src/Core/.Context.idr.swp | Bin 90112 -> 0 bytes src/Core/.Normalise.idr.swp | Bin 53248 -> 0 bytes src/Idris/.Desugar.idr.swp | Bin 45056 -> 0 bytes src/Idris/Desugar.idr | 2 +- 4 files changed, 1 insertion(+), 1 deletion(-) delete mode 100644 src/Core/.Context.idr.swp delete mode 100644 src/Core/.Normalise.idr.swp delete mode 100644 src/Idris/.Desugar.idr.swp diff --git a/src/Core/.Context.idr.swp b/src/Core/.Context.idr.swp deleted file mode 100644 index 88863e3f3f61602a2ecc2a07cda6e593d5027a3d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 90112 zcmeI52bf$}dG{yuW|~b21h`flG;2$1nf8H<4AM%rWhC2ZWgA;=quJTrLAx{SnORAT zZE6UCPz(V=htMH(0>KH*gqA>n&|64>5C{$g2*rf*{r>MM_uM;oSF^Gq$@6IJzjo%{ zQ{PkHa^ACd!@1jcW)B?SP~&s^TJ7iG|I9^qxb0JK^rf}6T5IY+yQAla_$)Q1r{`LS z2*m40TY@L-N8S9r2qRV|2Mq9qyN3f|J~?cg!f1L z=MDe&Ii>f_*zm%r^5pMd9rKLkB+Hn=f( zKaA%~ze*L+ydMjTt}Py z6Hwc{Q|*&~GJSULo0w}X_FLJ;tlsME=g&6&-QDWVXZsty{#dsDl-g8d(8yx2-AfCt z?7(cR*QzZn?wxBlv(~|dZf`(a7Cu{vwY4?vp6=YIpUPyg)a-Wnf}uu#&|7Q{x;h{_tzA z+vLZo6MR((e6d8EZl~63HM_m3v^dMvzCYVNkZokzEevM)ciNKjkK1WH-o=QgcjsDUykLR#!;)`LXA9ZD<+i6izc6>vnyfWPZ&{NU zd&^>bZa})18-=gTF0mvYyw^WI(54i6HJg;!HHPYPiV|A(vnGkt>{DSE-l$nW6?>od zOou*}H3G#RJnbH;-dW6gDM_Y5DrD)B*miKx>bVruJzU8#AL3zSZiO_gFO`bFCYxUz zED}xGZcK8VSM#{fnzVoQ(?Hhqtz-&G+wWeY^ChVaT+`>Ru8Qz}q0wv17m`{Kp=zOu zyOqoU3h{WVpUwBJ2xIa6R{!4WuHkj4Y>BDQCP%_XZ${Z=Yfete+SCwp6h3>W+UF8_ z0O6X0tT&*M|T!)9p@cYE5m@4I|pmCYf}034?1R!_3Vr>(^(Co%VFQ zF=$iI{-80?fX*_WZ>9m=Sme*%ZqI^@XS-)x^kMg)+hf4Zw&we-x&5s^g=~=oJ!mSU zL-WFt3d7biRl+lK-MzH4%^`!&d2UI$cc$8%nT$@DH9DCFOuN}0@M>=y@0O%W zs879V(@mq@8N_*SduL!1VyK}DS@|zzInc^xG;dI3%A3)1HQD7KP3n6!>DbI?2@~tg z#reIhUe=u^5(V!2>ShFP_qv_=R%c+7j3wn}A*OE2h=lTa)s_ckMw)3=9QCquXqlx+ zwMka*w_41hz1DdCP@TY{(&d)t@o13EHx?+r zr4T2*joGgD%mkz!*ordWIOrz9yzX`DWojcg`Bzc8MEJUz(UWjXw>uYTxV1~MAYb3L z`{<3XN*6y+uRh=HtD{iM+1A`bHr4Jg(0Lt+Y;vXnI*aoxRq83MVxb&)Tk@_kXKmSU zc3A-%gG}XCZ5O%_u$JUnu4H-j)yf!K*T<_f!P%VZSLn(xQ?0>5H+JTvoV=iOwmT{g zv%#V|Sw1t8Mct;d>d5v=3Ah+GscAFOP(y|hQ+LZsq>k0s=C?xz)qJ8(EHb2Xv?UQ% zxQ%{|bM(JbeeCRBd;Zjpt#3>ET_UR^T;)UeD*j8}t?`*`&BVrq9!)j9ZmzwzxvoE$ z;_vwEnswQlev^r+wb6GBo{W!=Tk&EV`eIwB$pLB1s5~UwUtG}kj0u9?F{kH@)cp{j z3A4Y>Qb<-(C{;zpe4!i;FjQ$z%d>iPy+&^-n_lcRZF-*46yMfY%U0zL9}3F5sjT0A zR4Z%FHaasl=xstH6^jl5n)|3gEkp``iLA*lnZ3rdb2KGtBK8E!78ZN-tyX^>Q?q-c zfwoL?-Clc!Z09Hnd6E)~mUadGtiI#)$rE>-J~`&L7s^))free7T=eFAPOtCpXU89( z)$_eI#n^3|?EK5vSb4zF!F#RNuHAIFiAKM*n;*82R)?DyA)GD4D-2&pQPFd0p{@Qx z>p{bIhmOX=#B5&>SKKqZgKVia(2h)d1kVdFWLM$?evi> z0?t#5^&p#E>a%XgpW5||Gl}eMEQApD$PJ_NQ_XtiXWP%(-0L-#Vv6Ss+H?JJHv4q{ z_|S7pwg~Rt9ddFMcT3}03yzw;m}vy%S{3E=Mt`>IIXx{rPLomQ;dz?#M0b9nJ=fZH zaG_WE+V{R%ZN59TNH?%bux!iLz9#?|umM~L z@BV%83GhzvY%l{J2F?I?2fu=s|1@|rI0)8*Pr=W>5xfDs3Ooj!1Ga%N@H1bQpQ=1Z zK1V2UgaSt>aD)O!C~$-VM<{TF0!JutgaS7Z1w0EO4a&^!_I&F+sS4`u2Mkv~>no;)P%y48&7rZarR&&sja~z!b=GRdVj4e8CQL=v(RYnL$)c2b-g}- z0@~vfQNUl!xJi|Ew5JEzaY!i!RCPy(uP#-Ws3qhQ zm9TwWYJgfHkp?p0-r$l!cYxI5I0=5vYpsP+9av{#w@nPVcPZOYj5Y^Xt#oM@Urq`e zgIHq?l`gCAYb}}39}R|+P^zrz06V%f_I6#Sau2^lI^bGzouqaW@|qaaTCzUoREUwj z>NcB@yg*{UTA|{*JqOn&I+@E^@Zf zQ;&0HC#q9TWZ{GG8WBUkb%`}vB*dU=;y85-8x05~`eTkLMp^y#!@zoLEs$}S=^U+y zAq)E(=u`|xe_vJ4M-tXT1d|9~>2+?n)V;Rzac;JM%&@L=$LboH+Te*`WBd%(%ye&8P9cfj4jG2qAO@&66H z6}$z!4m=zD5$J&jfM21{{}A{f_!Dpym<7AR8DInWIrMxt&^d!Y2h#Dk!6iVnJ_h^* zo&FoZE5UO?IP>6!Qr^qdee75GJJk2+^AaXy2WtxJK6+r1zDBm`lq{cg8LEvb1<5mT zv$^ZWB(>tps(e-*Vfli&daQC#DF4zY41rB?Fc{IU%#M{5d#m;R7^PwevG_^G4w1q) z#djk2YQi<=(B5m^s>O8q5=MP|JKBI}36PtNfm53~SsfzRgG~$rOsXr{wJ%xOcq3%L z=c4TX_kG|=8GqCNQF>xbVgI`6EQHVhCP7?4pMZP5=b~B+YSU323lYtRGmUu*xMpXg z-C1L~LNtkS`#u?#DT`|qRB(Ep+QY~e8m1P$Kq@1j5-;olSXeX-<`W)C%{SJcVxsQW zSsf(bo3h=##a5i=jQmzeO4P6AKTS;Ck2{h=R^E6af&0l9L!>_ui6ee!Y!Eh6Rwe zXlPpdZHf7%(l9+q!^zxDX`{TQij3)8ob6210j5fKDfN+m&t9(B>{@V(s`rx@8n zuYoE^qW{5cW3X0Bkg`^)POWLO^^Ex?)5j_<(RZH}x80o0IxQ)>yV+ipL{4OFKYNR) z>$Ur0^+ySgo1`o4A$mxdBv7=qdJ8@Dic=XI7?H&WOMju&#HOH09#iPo zTb&lh1E@iIt;-hMapAPWO%y{+@tO)^Ot8+ESo-W~DQ?iC%%jeteWiaI%r1&Jl(IRK zM+yb4Pn@>Sw_i>PsbeT8o4Ur-sWkoW-4koA{nk;DNZC9*x?1!vi=9qO&5F*3E?qZ; zH9G4?(w|7zs_kt74z$+pPup0pokoJ(Y0Q>7NB>0om(7`~`p8ALUo=Z&f44nFmu%Q> zv)@HqB>MttNg~@#`9d1LHR4V%(OKrDzc|m+=^Turq^CCOQhGBwLz&li`Ztw?d}2XE zCQ0J!Ock{*)sYtRQ*W3i8Fk!Qx*Xj-Cg;l#bI=lIUDoaJ3c0YeRl04ZWlNo@sCgoi zRW!D`?n8l8lArSP1L8?UD)^{FTdsmhLq(&R(z~~ZkC~hw48Lp?z|(F=*N!L zCGAwJJ(N0Oj4dvp1!wdx$a=+I+h7V2(s3HgL5?c$X85nu8CB)-nhKCGd??jh1RF=J#*JF~cNYQ1x3k?`RO3f&Z#b8yz9l49e*YHJ2kBWHEM#)SHe2m!M zHigVEzvu)zA*_@y#tu9v0b?erY8diyfLa88{%9EKMO&_~?<>DGUoF^}k@rs5SJGQtdk5)so(3s}l*b{6ra7T(`( zP%Rc+m`k%m%^+xl;0xItO9AT_Y3JPyE(rTB*&;F2ut$**5&_(l!Q`ZFfi;%vlD=jX zm-PsHBxqlpR#iLM=4iRFjQUz1)8B&fL&Gfp93we*ZSk0eK8D>nYHn7Fq+KLpYY$LOd#17N?U*0;ltSef% zaq4ceOa_(m?XV{94u(AZ9&{%)JLGL@eLifVH)dyfExBScF-)B~8CR5K8b+?L-giJ3 zEMF#==(JPlxQWB;HvGuVlX9HC(y*#)b#Z$%Z+=GK*A`Rzdy0%6!-rHiF**|9NBb1>XYi1o9@qy?0e1%0ru<#;!xXRsyBt_oSxaSYtfuzWtP`dGYtz{`#QV6~Qr@(gW%oBV)RoMC22A{qg%$S`1H=A4lfWhiZnt!Uz8 z-6lu8?6!ljO3KmA3%vJ3vs!cj89ledxdJOpEhTpm=;FC0C5KN?H{g!~Ys0 zpgp$^L3^)NcR^cH(fN4mmmj*H1+DIREA>0$m8Xf!*_%8$>%VMqQi5dJZ=we~%5Jq` zreYOJ;FeU53F$q(cV}Y>2A&@U{Xw3@DqE+zA$%+4e*!u8TvQ(7c^Lm~&vw~Nwl4Bg zt5eyQw=(yyNtNoss<`VnUpB1srrx zXH&8I*epPjVLIV!Vf5bsEo6$=j#_3F4YSqe0pjFU4b6}bjIfOPmQb8kHbA6fPCFZ< zd9E?U5Ro;GE5a2>Jsjpx1dsU*&$)%fY`zFf#fV#ncHb%iRgs!m(fyNLgdK=%lSAaD z*<{(~$?dUBtm35y4J4;tBupSu4joBcCZj`bqCJ*zj}qG=7+{#f#ajPn9|y-esZ%dl zCadnGV%_|J$#!PN3feZ#f)jJGgQ!X@98yZ843dT}*|tgV79=+c$!yobK$T9yiO7K= z9MYLH2{Mgmw;~gl=jg#DV36EMiIkMQ#DLr1nbi|2j%BkhJCz)<0ld8QJ$+f3OG_>z zfhgY=*;iEmVh$0;dy=Xp?Ug{r;HrtnYH8rr_WFuJofi|0F9+ukiZiKRsTN&v-&vfc zT&Hp+cK;Uo6Wh&V_*IV9LzUZWs#y%iMkqSHGmzVlhP>eAVy9uRf1z{H@Fu5UJ2ag& ztRzgXN|#yal`&i2r{)m;u|s z$>4XvPvG~z4n7Ay3;qy182m2y68!$B!5hJgz;nQrKsE$hz)4^O_!s#7=Yl!V0uKcz zf#bm)!FS;IzW_cDJ_-H|ya-4(@Mv%zI2RlRZU(*v?=Rm0?*cCalVBIPKNtr;K@RX` z@Ymq^pbyRk=YTW8UBQ1M2lz60CwL5aG&lgZfV+abfZKylAscutcny&6z7~+YU^CbV z{tKDFXTYby$G{(eQ^7XyOJo6`0#5^%fO~>((4OxEF96R6&jP1`TLHDTd<+yn``e~I z+}_#TVN1p=-9gH#2@%nJR=-fX@Kf|eI>zlCLbw293R{cM6&XXJPT!<%6^a}?C>0sn zbCq7(?@pZn*h$fm5G7ezVjb;~Osy-qf!{w%n7Pf=Nlw^jGE;w2$)_-!QXN^L%0H$v zfcvE|!BD0@xi~%DK6n;O9yCuEMh=p2B4HLk|9~FZ4Scw#{SI zB_n4AU6e+Kb#zRj(S{fWESOQxv;dxVT3Jo)n5TkY0g`X`@}e-}Oue(UHNAVui9R-Y zVTk?OqW)v@lLE7f9$CH~W>{8-;yVGd+pQy~NAViAi*?66ikDoMo@O4476LA@-AiXm zk`xM}ACyBm`rLeg6>>@?-t1BjkzIAg3mLi~E9B_vma}i=N>S;mS~02nom);x3%5d6 zLzN?KS|W_T*do={s>*T1+9{uyjb9KQ3y6=@CJsJv3bzIb4cxD3RB}_y9YI9L zKBsFxio0j4H9;Hmo)W&@iSC{zD{wH*8KOiZ_DCO_!C&B88iir+c}TI>fqI2%**?E+ z6)+N~MHuE2yqKcq?XwOcV9YCO)Tf76*VJz}T>ol>0T<$|wth?-lflfwb(DBc82_@d z^22tCPCJyFB_3;>ae=ectX$XuT1(U4iq@9w>2|x+(rv3Xf1D{~=oUhawC|%{tR=zk z0}O@q+)Th>3YUfG;v9+~rvyi5D4Xd6QYL%NbR!!da0)i3fy|WlqJD4AZZ)4SsdPh< zfa=jR&NF>{>7uLXYytFRZ9U|Hr%bd$BAO!}@tgALBSv%D(Mf7vp*@FA5Te{xSp z+q^`5H8w_2API+UxmF`sJC-lD^m_kQ+;tQ0(KX0qfnydy9Z z3Lj#{?LaYaM(eSfdz0fI1bzjd>(%NrC<*10T+NtFb1xJSN}Tr8z5hS7lU;` z=L_xzjt1X`XTKV}0z4U<1MUg_3BLW4;1l2@;00g`JPe!!egV(^VemvS0DUkAwt%~W zn*p`schr^@AN8T?UcmeiwM25Lm+q+)3;h+ls>0M2!b_GJzK^yt)s&)r+_v9!PkZ18 z5mQuD)epS(3hVCvZgWD!N+4}K>(#&w{v-iQr7(mBvppT~Iw$xjvr1SUlW40H#a9!N z$t5kI<)K2>tWfDcMRKN*lD%swxfQ3ZGUKuQ{InctC%m7P|DAM=rCW}uMT*AYMRLZ+ zzeZaA@1$QGprg?*1~1YtKK?b(Prjoj%ykqL>^J|n4eZIhc#ed9=jv$rQEgI%$q8dU zieyaEIxIp?&t;dQbJ~EGf1ChD7<&2BAquPiRpUXCGTn*h}BqSL03;X8zz3rLB?qc5-cDi0&V#H~a zmIU!SWy z{~zwB`#8M*bHG7x04#v5;ArqG`22qbZv~G6d%y)?5=i&|LwNhIf)9YFgGYelz|r82 z;Dhk^&jNo0X2HY2X0R6g0N(x@@B|>ggcpKyz!>;%c>8aGPkGZ91KIe?Z@?ddCxHin@4&~u7)VcF1Jcuf8+;4AAIPTvX+XUFM)2D}cjoC1 zfX9Ld0`cU~7csV!^+zosMUj0Qt{s8U)z6f9bY%m4x2W|>J4ZZ&syb3%M82!}{ zngQB<)^2lu$zHhQPO0V3Xlac{cOud>QQp+6Wb>5IC53NwS)#2&0>yD#E(y5ETQwEJ zlz!CBtWNq`j+m^gmEI2h48e8AYlQH7LU^5-TQ&7Kb}q}*!H8OsznwrF&$~`Bx;g&WM%QSZMi1HN2NqrS)s?Sk1^E^TEl5;a@X!X< zMT#s>f^s7u-RDdQ)v%1xYWQ9dM@e3MbQ**E?FP*@ z)N4bJrAqk#iTha9dzX3CY)n%?QEPnQaw)Qw0=7aMCkk?W5i`vcN>Ap>FUn7TrqrqjOp z@qDfN-u1wlWU2|DZoOHTbwr;T*iFf>8wF~~dq1}dIDMe{1zOyAjyhdo!->^=R3GBp zsx1%4X;U7o`smq4y)1tIXJk`MEs1%aIQ>$w%F+`vaLA)*ZpweHR?&d~Ac?Hp`<-BW zSSrUAblBgRe4~$X)g{+YwlUkr%}PqoBAXrTL@d~-Gdkp2$JiiY>@ zn@UeCIcLDSNogOh;93++wrn?)Af(jmRKik!EBE^(Mv%`s8C3FOq;|~n@v}lA;y;{O z!Q}2YG>Nq1D2ev-a%b*S)u9vVzMbYs5;;8LpeJ;P^nSyn5&wU8*v|LCgG&FuS3D@6 zufga49grO0L*PYV4x9%zfm?wu!Rx;YJP7<0zWyiRKfy=9>%oh`6TnWe1IXV0?%)^j z`QHPw^?x4t6L1x1f)l|pK=%NA7(5&71wVkV|6A~6@Hp`QfP4jh6#o9D;19qya4+yv z`1`MdXMo)x*zG@z@A4UVE&Trbz^lOH!2^K!|Ca;V=I;j&1$PHOhR6RG@KLY?b_3bt z|2usCOTnYS5|D2|+2j8%xEZ(>zW*BVexUmRH-ZO&`+%Rq|9>6m?EXu@Mc_hk4!9e* z3HW!~Lv8Y2wafA!-$gUqNpvKmE=vcsap+v)nc3>C{#38KaF+L1;}TN%!qXKyb~qu!~d36D|ox#Sgjs4SOB$-7SAsEZz++2QdQXl(jaM z)FUszXuZ}I6INyy`#AU(XQ--!E@t5BeS*OSH@K~DFu={7e3{e<$klatVB_3rdmoO( z(q2Gn#!kXIAr9oo6B0mDh}s<8S>(-?jcyiN#m%J#6pK_YmQyt2vte)X3)MQ9u{||4 zi}m`9Gd)Eo9t+w#F%I^#qP6h&r^%ONyScM(76$b-=X4~5(b@E2_Ewi_S~+53h$*GGvAt+n$Y;aX zhpeB3kL0#=N|>QkSHognmJkuP` z^yVGro(kVmjvj3lsg4_iDJpU>tDoJLpiiQ{e$(}9A5e#W?7Wn1QbY5~$}Hn5v$(1E zZ_Nzd`Z23^IQl>*QdiZ;^;XuL@Wvfqr)vT*CpM$&@74jXwiAru>X02QqONu3C`<9f zRe@dzVpl>+L^PP?GB|c6k<}APr#L;tAPpoKCb{5V)X;UTtJw<% zk|)Oo6$8qtG8{H5HEB`eTIyofF>~h)Gjak?r)A#JWP!UmC7B9O_Q1Jr&Aa18Yf>q` z6qD=S}-S1jR>#R5c1>SSb^DcUNyb6G~r(QJZ?mGBdbQL#ik z$X%RE3Oz1NAf@C+n?$T7^-oyGlBGI$Y-6Dg${);iI5(88t$W3#jDXk(IPHm18OL}9pDOBFlm z4Ka+UxX!PyJcO)NejHt|K{VnRf6GLQXww1E>68NE^cnx89<{exw+ z#^V2Bqif&v{QrXIH9r7>O7LRP2d9Atf_s8%DfD;1 zUjq36d z!N-vgd<=XLya4E~fl2TnaCdMwa5RwZz!!Bs%AgyVtE1L!P3dY=Eb{Qg(u1fKM`g5Lx80BXyBEyxYj>jvGh zz2E3PaMj(Opn(;DwgvuRb^frHuFc+4UVVoyDpsfNu?gYIdGr3jIHg~mHpv@33 z&-EbFh6xqy<>g#N%H=M8U9U)#;CW~n?P0l>KM0NmhRSR;v1KS66wm8pN7*!gAz8+B zCSx0+3)r<@>nt0JryxRJSis6a&V6+X&8d_)cxb}td{e__2Qjs2__W#ahw+C6$iYWy ziKDGp*g{A#vL~E0%6i5g=S;a^Wg~(cRvN7Iv9)YFr>}|u523%XbcnH)Q~vdX7(t>P z(s4F6r%g^?Y|0L<)&8*KoG0>BFSCXkkG484-;23 zXFPSwJAypPwIqJ=D}7!rZKXW+td#A|+1|>-aJ#vP+gm!l zbDdmDCd?(&lVlDwdPrT;gPu}x!w7iRSK|Ysi_LBwWZ2}1nbiah#@lAFhp28luJt(@o9-#-F>D^Z;)AjTox7+D6QVKSi~Rc8mp)fJLZSm5W*gMRPW; z)ziBNl!E9Ik@plWxObS*%dESzV*_Meiah#vC zO&t?$xE(@u1F)3mPVFW2&XaT5Io3K46GfiRAxxm?$}Kglr>Y=tuEg9V=aE-t-tyQL z+)IC*PY(t~&_ZJO)t4)R{P&8}fT>q^+WjHvC>!cQE0&MW;~hgfjSEFJ1)KQ)W8wL) z_Wb`Pp8x*>{QVojpMcAN?Ej_r{|Ws47r-;XUhoibTkuWzdinR4Z~rd1KM=3~DR}vh z0-f(a8%Vc*9sK)G!C!!L>>mKq|34jU26qPEhey8}JOw-%TnM&iN>+1gBVb99u<^o^xU7dS3e^?=c^-YaC|BlJObzm!j7)l-Io?5)Q zR4)<-CT2gV-Y{a`Iw4z3j(OrnN@;3mjkPUL`vZ3u3vqePt#ArysY+BXNkNkY5TLCX zk4c*#%m%h;3Za$L@P`Zv&f)y;nnG5U3wBgRvpbz~NkLL{2AJF4Gz&F9NO7F!>*Dim z&hy}=U~y&{7lUlf5(+XC<-c4;?6J@oaJ6c-Pb~JH4ddhc+y#67%>{Z|cv4pIXacO_ zqgUgtyTV;Jq+e^EqN*sl!R|kys&?&PbS{NPeaOkTbw#Nk221LTLlRUq*76^^g9(zf zw~KkEYL#W9);$63{)j|JvU~&+2br>NSGWXWKy~Q!Ixk|{9vPOa)`uv8v&pwnqT4HK zF;5LVM~67>rnH7Z9`g+EhaOoJZS|Ct(`l9EJ#MWjD>{6eWtJWTmn-(BP#SVmqb%e7 z*bF%vg(w5Lj^#9Vh99=avo*QUd9@NDSJEG)sQH7hw#AjWDP+Im!WNg&-97cvoWm+Bk`D0Koqqia}*gKPuy;s$AD@@QkW?Xt{Ha$4yeZ{XYr+JgqG zN~j)JIa+@hXc8QBjR3r);`y7j!ZD)t()^zTt;W8VP9fsmt2t&#dW|+tG3kbSOb(@_ zb)DF7S%&q_gC(bUj=4vvva8{+WY#9!(37H6R^2AHn2nQ1vawX9+njUrSFc!0s3F3; zpiPJH8d~8oQEWHKod#+A4vBlscAM_4~8Eb_dfOqtswt zlyZ-(LlCjP75xF@yq`@j?j^@LS2`arC!zml1@JE;F)gjSbpp+Qj+{dslBlIsle*YU zqkmkQ>f>hzhSv=nJ)qRCcKK+tZ*j;aBhHVfWcV&Wm?(gKd|8(rNuIW`!pjC!KdKsX zZtubEiZd-*%vyC*m{)7Q5LA+$z>K#kleK*i_YY}+hGhRS*=p?$%c;}%$b4l90~X6L zMv9e+Q-qC%_)AqI$)qEL!dTaK`#N=XOGtAMBd-RHhVPFL=)Ja{pkb#247WFN=Tz4sl zBREnvQdrb!GsZRd8F3&Zzg)B&!6h7Pq=qX8acP>|z}9DJ-{N7U>cGCX%sR9V`TO#4 zGOWc#sB}%XH{qe~23$KN5pbEt{DuhP-iI`-q7wNI+4s1!b4Fi8AGJbfi~V*v>KZk2 z6{ee?+#+RDRqUC5QOi}QZYSU`^rWo$z})W@aiK%lSRA;JY5a#4hN1=@F)v{g8}$D_ z5YLJIKVnk*1l#||dA|P+{QU}i{%64(!5@LgfEHK-js^1h_fjC6|0}>QAf5lcz)iuI z;r-tYUJkAR7lW2Jmm-?|{w%{2_P<1@<+k!8_|NlLB36Kwfhl8_$^!t(vd=kjt-^;;yU@geNkKq0P0elL` zhyOFc)4`L#h2Ru$BDfRyDl&nufMAD$z@SxgM_RnCh_#TE{#toL0d0wO)flZ*P9I^!(xn8*_v||x5S={Zgsr=9ROto- zUv0CTm?PO}xk|}=*jU~XeS}7awVmwdY?Gw~stf{)uA5-?=Nn!oC|WE_w^;TxeoayG zPuOu7LG`0h>Cwm;Q>zebT4C3pVip(9Wv`fNu3fb2#8Lr6LH=J|C+u`-5nZlp(Q7f| z_$BnyQpnNd$8-ypO|2#ibGnEY!*8#6;V`0(hQ;v| z^}Kj#qq-hm-I|Q9Sio}etXz^#q=80mMc8HYk!^}){XnV`w=z7T3s*%uf;HK#!g8l(PN}Qu4lD%DMYRAzwLf#g``D8PNi#ge3j!;YVDgR zFw%(A^i*g@u1{;takYxw5>7A38`$h3ys3b*1h9VYyv*CZJmMFXn!CFuiP?{xsW{sq zSY-=Oj~{8W%9~B9P)8qn*C=*!OhqfuHBZcmqRNC#4nQ*oN1|)3-I;K+F}-a0WnNvd z+&{c6@-qD+P4=Pnt!IjNPdcvai`O^Voxh%B#cgll9QVFoOQ9zaLai=!@21U0@}bG? zLg&NYM&+4OON70weiRyhq^`mcw5tmbaCip6tS(K|1=(}>HqdUs43!vIJPS@}?64V} zFk5*$v6Bo^f2ktl7qg|dyAUd_L@FyhG$|bj_n0sxA!N_jCBK7+V|V3&nRi_?PQc3o zF2z_BnC?$FVU%&n+Suw$X^0ef@?=Jj#IuRb97l@~&GXw#0Tz zwKWT;#RXB^*D8;vFl)~4wdNM5TH`9)xO5(C6xMwB#9HiGV=pdp)@PB3Ix$p;zeeqB z*J>(_%`_F3$CxYm*)@;ow~oUl(tcri11EJ&uY!>%HR@$e`*}i!X>rr*?Zp4XR@ZI^ z&nW)?QJzoyD*XP3!F#|fz@^|4@CZ-`8MqnHJ%IlVz6@Rho(=|}4&)0^_X7MYy#MFH zyTN5(0kpx1;8<{T@E-Vo$p+p5mOvZmK7iYRTZ5Yb`2~D4(EWdBgR{Wt;8x(L@c&-} z?*`8SXMr=pY2YaED`Wuw3M3nN8F)U}19pJ>fd4`c@I!Dd_%L`j&{=?|f(FfpBE zACL>Y30w{~gNFj01-L!#|x5(mPNYq<6rARL`fZ!@F9# z1jc;Ev@Xkh=$NRp-Kq1&DeX-5Tkjn}+cw`wpCwF2NO7cDAuoRgR}=&Y%x0AI><0Gl z16VI^b4PZ3Wx^g?d3lCP*6!9#NR&)u#H$F9I7Cw76(PLBcv%u!!AxtM;i@dJQIx1e za{BXm^#!V;LjoxU>o`efcW(LtM`k=HrVnJJWLd46u;Sh1x&Vt`TcF?r#2rQZZGHz* z+n(5K)2l1o?#q=zOe(2vsHXJ=zxyqOrFJ7&lIAJ8-P2s-QA?YfcHhwTD)x?;PM(7+ za$4X#)apw+WYg)Xy8e_Rx!0dkYz;2;EOh5;!WZK-%9V&G#=}r7hF>-5N3TrMK%>

k zpE8B`(*C^!PiI_Wt43t)8mY+aYZZg=Hs8BnD;L-C$HkqwoGh-)EX29VmDc-~yhH`X zf}mVp>s9tt3uJ!o$!~?XQe4;Z_&0rRcZl%TDx?t0w$*vgxn&4Tb0trH0|e-I7kkZ? zum60x{>v77(xR!(N_;JxF94c(oj<$9#R_grMZ=lRmFqwy4XtT=8OC5gx28!J}h-Cb*%gvP8 zYb4~3zi)t&YdN(}P+UF^p--SNeW?uecjYab+kad5RZZXhR$q(V`crg(a|S~j=EIrM zW^bLF%n!Jx2V2K9HSl0Xx|#m}Xc)i~#0SFvKgKhI?}fJ)@4pB-U^5WUe>?Cac=~sM zKL@e}cpPYehlBqIQeS`{hPQt$cma?!L7kx!RP-acsqC^Xn==<{|9~!Z~x!mzraVp zE5UQX-D0mRKE%*<3{C@%;22Tf11AhQ61P=ixfx7_t2>1;6ICvR&ELZ^Nf;)iQ zgIj_x!SlZZ{3&=6I0bA14**AjAJWF(0-pe{0j~xx1v-ClF4zXt4~_>FpA{F=N!NvO z`HYc3O+n))yb4lMCruAeSMHt_!$^bJ5129+SyP_X3n$~(=V*Zx&_1@^3UBg2hZr># z#afdT)b#~-&hO1IhjU@c9sR}!gThCE}xzXB#0=XDYo0>O+_q!Fg@H9aTy6TeC&5z5b zd);|%#p@ZrR>#m~9#I_bp+{f8(iF=5#+B3U3YEiHEe*Z;ArOn~c5K(L(0Ll=VtYd! zZ;+iAJdbfbijH{zEAaIsc#_C);k}TqO!g$sYKw0j&}@C+q~v$P8sbhFVHlv~r z2y1=$CEQ(Y;eG6+}X>Mm89)ZWQo*YXf@k7d~*Fu>qB-{uw*on z>7NQsio(Nc1y?$z9@ce=QVo|)HY^?P0;$l1xXM*;>EOjxS=cR?i#uvsR3wKYI<-=u z%`)ocp#(=GSIDD^3|{8t#fhi-1B?60HHUIep>Vuu)| zg6A%zOGWqLe;tMQE9+{A9-|BuKc1#3l|RH7sR9hJtzF$FWWsT?{mZX?nZ-BR$ugr_ z@-A5Hm;)A}U3pv3HQn;(+rS!dByp?ndSL;QURR3S(Eoz|KluNj_Ke?O!{>hh8~{4| ze+IY{xDog!Jih$?y%3xQ?f_Dr{}b@_^8f!5@OaPw@&)iKc==y~p8)awZwBJ~fxiQ< z2hRcvU;?ZK_XhIw_ak_B-3jnI@DgwtI0M`QTnn%MK5zv%AKVkjAHWNM`1E@M>Fa+0 z4=$eo9|3O$PXm{Ntw8$vU&4cb5&S)nKfgzTDew@Gfp5Zhe;T|I^uT#w6SxKVIyU?j z_W=~Ah5VO0UT3bEe5#Tuq*reVjk*5GIO1p8BXl}B|UQ^kNi zffbE+aAk79tR;nOo$`oQyTi&-F|A;mvXeH1k0orY(@G_pGlsXdi)!|!GLf=Srp$f( z3>bF5jkt(6YQ+RbonpN0kWpXeLb+vTvjLOS?JddpNN*Zb>u0-7-ED>CIIF%c&9bs8 zipAF#3T@YoajID7u&`M&6Eimp@%@5UuZz=cya95kLB`U2H3G$Vdk(H!k|)PC8=Pyp z1|DP%%BM2i#2|C0o7 zMfb7n!o#7zYx*wVp%>vnEKq&1V+5%?hte8It?W{~gk5S~YAm~Ss=fcx(68{W8*GF_ zN<)8LLM|PPtFGzXQ;&H|2kzd!bNiX6;n$jmQ0wt$4erw`Qz^LmJT9aE zoF}ty^M_42+Edyy;{86EP(n#;=vB`Ig&>DFBZMSY8iyfF{983cgqMduQ=}R0v9v~-O=>D}?9R&k|Hcp> zVIZ$OiesH`;32&F@jKe!UAz3~rK{0!#%1x>T2!sd=P(8}Qz_;nHvgOgPuG%TpW|wl zn*Lc~tlO)@8{;F5?W!?-_+wcytHt6kh%@0HFb;yp9c9Q&izE7|_UGVzh+$Q89+_&pZIg$z8iagY<3b!lg=i+t#=x{oi zIV@1eRB}Vts6orTjnaZ|ze$BaZ%mpXdMI z2cIt+fVY6hfJXz#0h-`ka5Rt{K>Gh_aCh)Y&+p%tzu$(J{{na)kbnOJU;*gN{}ymp z@L%xqDX*{l{$2|n4|L}L0YJ9>{{nBX^Zp+P?*)Gho(290EP@NbHgG%`19t~E2mb;8 z{}J#4a3;7Bco&s@1$a4lA$T&F1iQdiupS%@ZVWyL?|%(=6u1 z{=#g#IWB&4q1(nY02dU&?A!g-1mwypgkJ85*8Boq9y#NTLJhL=dZ&ckW3}+JOjSv- zcjB+cv=q5XMRHGUIPg0$!GT%`k4Loy0;lChz~Rj^5)cqnHm8}G-iv% zPJ3FULmWktp?mF&y`rA>EH%$Gjjpnr;)njBPQc@M=`MrQ-@nUKJ7!Fa$Yp8ju9G+N z(&ST77MfUFo&D`zw<8Bhwk)f_R(^FP6>olVZqRmJKnddIaiY7369Udy^*DdHSw5#? zns#5i^D-1#Gdf2yw?r04(`Sz~oVat~&h<>pajDvrwjd-O-G>C%hjiIqdj|5(K|Oe+ z?i>!Rt-yp1Q!(W@b%Ni;6(G*73}p6lQ_0j=HJcINxLf%abZqW)N5eP62Vr^3Sf6$d zh43SEPpy^f3}V5Pzn*fXi=1M zF;0%JV{5y#Jbirs2v^#$D_xi6S561Lv!`?3;jE z#TA*)xi(Zp{LgOMG^XR_M9WQ9?4g|vcV64G^!q0BU10RKaP`U7z@`Ja_soCb?-D1# z<_#|oyL)0gSBtX0h+oR7iCGT{yR7h|9CCX;H6~w&Ls@=4TmKg4qJCDZ7(2^T1Q!(p zl>28rEX%)@^PA{W0Tza{I{2$8{3wTXG;{yv<+9(qIL}#ZnbF9d@7few@3ZMJ-RWW5`|zZmpSQQA$}YE9 z=yK*rTD zrdUp;G~pFWmIZo*+^ni0lPgsy*xr_wVE;xdNm2+3rCl~pAf+Y%sbB~KQ>Y?y^KCm( zWvJdZLuE6)#=@+lXU9cV0t5}6U+U%>r*1*G0_VnYqoSbw zK0Xi~otVtwFPdzQ^ErKJQzAQLH%8q?J8U{iGnUPDq1O_{zA`Wh1MP}@cvj7Lu|M*q zKF2i#iBCy?e7fS{#GEcAu1Wt7OI!Px=l>t+`TuL-@81rd3v}<_?}6{a<6i@M-~@0C z_$9pld%=sq3&BO;7$BejSA*w*onQyp25t*d|Nk$8zkfcs1Y8Vc*MADw1nvXYfMdbk zz|Y|6zYC=Me=U&ie+FC%P6vVizYX87f!BW%cqTXq_5$4xaBCp@{!f69faicGf+pAo z#Q)z0{53?8FTe#LyMFQfUj$zO@&VWd_XF#}PvQ4J1azMN$)E?$2FHUjAbG%b@cEwt zF9&}Lb_1Q`KMLFoeDucd4F6U9y#U+~=$?Qtz~jFIJO+$|_2Ay%8?=|&>~C}4A6&Zuc$Cy4H|nf@i&!NqIICP9aRn;zP6XbRrm5bmuwMg4l&{>MyR- zhCRGz%FQpjc&+VQsj&zFoxM>C8mPd@Y=#%-ox4EFg|6=kTn;Ua!xI+*wLtseY-j#wjSVvctH(n)}o;YnEOI?5(X0^ zFElgm=fs=gh7JoL>pG`Nv_UEhVcdJxE%l@41(>cwxfIv2(diygwnR>Z;t9F^*P*#* zI0z;nU5?}-YPSQU^m=9?=YfxF-snA5QR1_tQ|5D^#aow0Oj;z)oVmM0rU0&Mz*A2W zBc|^RZkdTx^9r2{y-qJo|CXD4&{K)hSeocAV9Pb%IH*8maT;VB)Azh=wvp3xB?X-i zS_lkVJ-t<;sk2TSH041Qf3LP@=2ggvWrM84_7yufzaDkC*0kP1wq)1W z@@|X^<*VW*13izr$3?wpIF22P2$K_Dt=U~Wp9;P-t|&UBk!F@;;!EM@0rqEh5M@^v zc?ROKY0dI!M;tDJQ-(^Y>aLhDN!U8w)PYe^w1ujEUr0TtJaLJMMUne1G zdmvUlf4h-g12c!8N{44p*YBfVA=|)zPIB!2Wi6SGkMIL&OnkCYu=n&m`p7Oq(xqeH zwNB={X0qOgj*q9Dyx{3~uO#sfiOVI|_@K+in%ZxR;%K7k^WKaCEdzVt19%y}h!Qtg zj-cU*TRnpEKQ7vVa7>u64#7p6NISlJ_k`wAImBs+Cx%;+sH>;Dh~YSq_e=f3tSkn` zL{Bh^HWy1O=yZp+tXi39-MDelLJ}SpiX13i-+mSZXZrTlvBDR(hmILEX+bXFH72vy z8Z7oSb2CY!!jZ~T^ZZ)J!|gK04_`}8G#lNR;u|hVzY?>3*CC*S_X%m^NsCJpU5@xc z_G56`@V@gHo$4nwH})6epbM2+WG#<8UnjqHOI9#A>X4T4yjF6@b|cqaG}DY08?Qx^ zJ{u2i@>kOYP%$`K*h3n-*L8Lc6iV9{bD&DCQG=oBWq|mCv*Fc6q^74b%?;`TyF_%% ztzls^ZT(5(Hl=)0QX{D)?zV3;sM%NwSqY}N{M1-`ra-r;L`DIbTAtNSH<}vtZVyAT z*Qy%yFPvYY3Uo|7k8LMNP1xL#hO$r@xkK1*3DR4D$y{y|IG=%#!EFOWnYY;fR)w6> z9+xtz%?f^XgKDGO8)rtK_;DkOyi^Lr11+~``GV3>4$)CFK2(8FPVMK*BvU$0!iD|2 z$}-hDNae6(WVBk5^9{j9Z(6s^Eb8;nTN`xfQmwKUPXYNzD7iDj7V zBHU!G6hmpKM9d(LYSl*aX^QGNCP=F6j68mCnr|`O3?=?wEaa2*5BmQ-p8x+E{Qhgf zq)C0QvsEHTW((|9ilzz$?Lv!TI2RKO^TB<=(Lg@_Uk9!P4+VDw zUx9c3Ab1vdB+xnivw`mYyAik+{{55SY2X4d4t^WxT>d-2Bf*2fH{j7<2d2TP;1qBN zAfNs6*MB-V4crcV1^)bf;3^lpoy086+J%MK`jq;neT>~^w%;kWJzcO@x&85$&~@~!8wuhia3Kx#En{qX z<9CA<$r&@t1Zvq}!ctT8BxiRd)92u(_4IAn99aP*flprgLMKnmZ?uuk-)hx2C?Xv;Rd)eqGw` zI|oo_O<$_lg~<6PFs-_~0?U;4LpJrwTAzf53;hZf#f2*W>pHycl5LNza|n1!TW)t= zjvjws;f9XyJGJcj1cN>Onv)#e`W+;ZC9?1%4=B-!%KUf#~Vw2vg!( z{5${0WtTLXyRfntDE)P)!iI4V(-xYh-gf<=qJ6e|*-%YcEXzIRjjA14h*El*_j$k5 z65EtEkK!6fRhR_Ae%(r-Qux{1Xoo#OfuOt{u7BEFjgzscs(aO0Ay5Rja?dg z&XDk2lP!Z17%(Vng-qg)mB|=`>5J>dZg@9?SOfuLW6H5KVjRh=+)%{yEG2VVh4|MG zspZAL9C?ND&_=gv67WSl%vMR$KIEKteOiWEj@CAj%9SEbHD*1qG_E@!)hPGh3K8Z| zm=%Vpn?EBbU1U#<-lYt;r_+0o71w;rB!5=!Y*EBzBye&rmk~3~u%LRV49ksL8*axj z2E;utKctSWmq!f^R?(TQJ}cKGsj?q7zU}|_44cCyinLF)q=MF1QluPyf35C5L+yLW z9_xhddB3gbxc>gniplrvo$4C4SJd{?wxFlDInU{xVsG%vBfllm(uq#BF2gYIVU~<~ zFmIB_CW?#mcevt^aBeY4LI%lCydyZ)N~@{g;K0kKOK646-dfoeKXO4~_Q)mcDkx$K zHpN$ZB~WbN|5>e~6)Np)u3RfFCj?nmh;GpX({+Ps6XBELKi>u~D*nIW`TwuL>wgTq z0Xz$A2loR14X^(;a3$CbZUJiGt?>A>;O^i$`1((RKLdXVo&@CE?`&{4@H2S)*MO&h zCxflv$ME&y^<~d58~*RY&;JwnAh-ft4hG87KtnI2+srd>A=^^!pcsE#N5d zU1R{S2hRW(fGt2a{XawwAf5i7fdM!lYyfu!cLD#6EZ{TXmEa0+A&`vV=HRomh1%n- zYLlUl>qPdi8y`Ed*Ol*+gISw9kIPJY)mF2fM_C$*5*dWHWmMfrL#^AE@%69c=aN@kLfSZ@ooT@ zsY}P#rC7W)4a#m}HL9Z9jJ+%-9t{ezncb&$ap9{n_wcP1V=P&r;lEz?c#T1iBoSd&t69J}CGf8!*WR^|{IFt@*by7&;bG2>qi~F0Eb6!yw9(&jM za)~xCAPy}gHH}NMBrR;I%89us({|%)IX%u@#M^C7-9TmrI`Y zo~q~*8YbJYXN4>fHhVL@2kh;o)j%~NvO_igl2&b&6})bQDq>?;#WVG+(<=#CX9hxk!1 z)pnVAh5*J7OuIhdcgpbnr!ogI8?i~YA6BjU&V9ReQWKNYd7|q*7qR86k0H zpU_z|ugloPY0R9DVlhR#x5UeggFWtO5;|p0_ZUUUoHx#-!trhCzvAmKi`eQWXtXjR z1rk&udLIW!ey~U#@?2dK>P|=TODXUt7AvHxgG72^BZa@=)RUf>8sEPtj)jmV$Nc88 zE0J1xN==S+Wn!LWt5Ss#C!N&_U5H(Ge3ICHQ(}==ZtPSD3Ax0Xh1K7!GldXA8)S^D zmkv7%2vw`fG{Qa4yuSr{9lf#Bl8J(JI9@&L)OYHb)0}iu4>a|&Mkt39%_zWKs4448 zt04)U*UI*FFicT!ip>VnIxz?CbW>NW(_NgA(SNHcD{q~kJD?Ghn;Ae=>{fL8z@5to zr04HswofymTX-VhooXL95n_nfPEsg;EylfI<+!DM1HZq?b>?b&xO9V4XtMgCYu&9V zbj*7|xuh%0dKH=lc4Y=#1iU~5q?Kg<5S0Gj?!{~Z*7{nl4F(80#NpbpmK4d7F?vW= zYH$3Slv32hPwcdy9C@g#Z5sc>QOB9=JdFZSarq z`R@hK03C25xIOqfJpV_)hr#>6JHd0nBG>@r`|k(v{a*%O0=naG7VH3Pz|Fu-!OxKc zd=*>`bS9t;Hh}Ap2Yep93Ooty0h_=b!0o}ekp+ARyb#FFe;nK#d>WqrE#R@>VlWP5 z-!GqkHwWK?=l?Qz8F(pp0+5YB9jpZzI0}3V-v3QNKKw5OCxP$5`^)BEJ^(KQCxaV< zkHP!D5j+maR$voY3+@em0pI^uKxh2r`%ixP{}X=y1K^LrnV=4?r7hGRZ?53~lipGB zHDy!cHp|#?9Q0WKiR{gB99h#Trwl_WCj36U80)0hTNdNaTio;+TlZpQ_6>Os6$K;p zLVS*?aHz8Mu*XAVs6qmMEbvd{!@o=jiQNm=8kgT37mKV;$t95N2IQZm15G zx~Drk|i;$Oe_zCYQT_9=pyA(o%SJ_kYWc4&c2%%6hMb?$R zOHb0mLgWy>@DS6PJVFRjNYO-`RzkQNX2;Qz9g3Bvt@Pan`8XNmTH>k9TFa`Y;eK=2 z_NgGQahu(cge}KDUYM6GE2k84ie*TJkU<08jzl@3n+s)}5qU~3Um#MySyPC@GZD@T zp5!`~v!Ss;(iThR_CSu80Zcf1!?&ij;$KLm?t+GQ zs!;4!*7e%i{_NYf; zmTCkwRw0Mw(>tU(tB{VVv#`G0=eNA~}30?z=l|34j^2G)V!0Y8TCzZSe6JO#{x`-1y`djj1D zpfdq)08a&v1SbK>1IB>P1biBv{~17XfQNyjzz5*>4}krk3wDFs1D*Ys9N>*0_5auB z_rrkv|Nj)8|BK+I;3c339uDpTeh9z+PVf%!Ch%Nv2KWK|{rADYgU^DegNK5LfCmEk z`}-dJzWo0`A2h(FK=%OXE;Gay#iINh+2$N4r5m@MOBAee9C zY$R?Z{VisMOym24)}xSNTx)VoMAa5LD}Amk3Y$xBC8Xp6G(0V_axA|r)RS;iaEhhP zQ<7*ex~5Zlg;B$=)NNf9EhMr1*XUqmIF0zqiV>s}!%6Tum|qPilDsS=6B{#1Wlgm( zoPa%!Q46)?X>GVT{>jRXL7;@r$~Bi5g$}|wgCvX>~g2(DV0GQDjySZaPlEe^u^ElumK8r ztG?|ziGfL->D*QoMSG)SHdA5+maR`IFh|D2dV%FlQk1C)c#<|e_ zoS`}X7-CMwLniX~-UbLYun>okQESqu+VX4Mn%cK}9ghlr$$p+dPEpqmyJgF6m z*_YS5a>wv~+0-=(f$@GfA?*MRkUXLolNO72sFY&B;Z$N33hvzUy?(I}EDXV45{iSQ zVUic6f)8)*jMvYLltf)2%^2R&i@!)K)*u$GOm+3hNa-`-WWAd*BWOA?rIj7y#MAJu zs2tmcDP-UcWwcXYNl@;1lQc(+-kgn%i&_z2dp{IC)F*#3w1}6BnpQN>FH|!8=HOR} zJgcc-NM$T@We>kAD;8hoRj8;`Y}{D!a^n^#SYX`>Z>ZQnyr}omma&shxNur=5sMq(c%h-P-2+qf3o+u%5 zA?^Hd3hqRK&Vifplv8v|Fo*$)dHZmJeLb;2ZddH8<4TiO!P$xgg?VSbK~F9*!Fm|x zBqfkW&nXa^Bm2K!`&bpLdF&r{8rG52_l`293Nwl$mERQvC0Sw6B5??cvcmJ#Da#5` Nwd*XGszPb@{{e{lcR~OF diff --git a/src/Core/.Normalise.idr.swp b/src/Core/.Normalise.idr.swp deleted file mode 100644 index 8668cfc82f7c957886084c76a7e9f70e6ad3ae75..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 53248 zcmeI536vdIdFN{|#$hwtIp6^UB_Z6^w%oSxutZokQcE%dsU=&o43>>}{kppQp|`Z& zB6UX=&JZAG&oJNwaPWi}21D39Bu+3pHZUO}>}DI=I0FIBzyOm05|+&G`|eV=>eYMw z8mvPmr(d6czj{@7`R;euZ@IUo&)vUcSNxQTb0a}KRQm=K=iP}ti z`Q%nZta4zL1EX@F*PT84DG!X!d%_0o>W^EyCVtpMFC8`ZYPeMnta4zL1FIZZ<-jTj zRynZBfmIHya^T+p2f7RQkFKU1_p)V~w%`A*@O^LldyoCD7M`D6cz$!?`F-r~Df@kj z&A{bzioJiO{l2vD{I~4==h*L?3eWFr?;o(=54Htz>EF-ZzubN=6rSJT-mlp2zb-s~ zfW7bdbJj`bhD+c6jMmw3uP8jXw^zSbIk3usRSv9jV3h-_99ZSRDhF0Mu*!i|4y@&K4pe5M=&|JdF%e|3|2z5iyAO(@?|?6W4}*7s>%q%F7o=b>xCC4XCcxR?QQ(o_ zGp9z;i@;`Z9yk@;`apaDz1(0!!dY;E7-Y{1bxyPr(nthrxB=4d69k3OpK|4(>)_@L}*r;1cjia1!_eiiS6W z4rqgI;C%2n@I#aoH-Q&|y5)KI#+FqfOgh^cTOUibO&7%JkxKotT6cc;Lbns^qqy5zXz?qbz(TK`#_Qs#Ew$!M zJX?(ySgBIg++JX`EcqZMY0#Ayf#Axp&~o@pxLJO5WL{BuLtn zgW_}#`AlN@q;-<^@seGKChM(^kY1oH8U`mWM`#89tYzfhb*aFd#};+akH=?UV4qIfW~%pn zDrcV^S2QVU!4*1IwNkIwnsf2yJ$rUOdm;?iquqDsYaJq-S#NdE)Zn#l+@ZVCt>)9X z-D}3(S|g2HbinzvG84CE<3{BW>4gbBJMFBGYu&L<{Jb7?R|vAOKA!H8)IwUViO-f$ zK+@Ao@w^bl?`j$!O>HVi=hL>kmZl_iwkz#cvYyQF(5yg6ZDuh}GEUL9WQ4L^TC4h) z@auSdOxSWfOCZto!esJsV?HM1OVZga+V+Z!4ic>!&o(8eIGNhKupqaRDG90%lm;_C z7TTKxanUnMv)p#Js36UcP>psCHc`Zd_N?Y5Jwtg^NY%tD#Kq~@HoMF(CBr0 zm3p*LX;XJy#_%|iQH&5<`C9KsiH-3#YFy@v@krB?G-KMQtF#2Cz*hZ8IuqB%bxMi* zr<3@qc&bHvrlm0nb?4iyqj7R+lMHLkbY@Cgk5q)IC7oXC3^LD<7F(n0=hCi(*|9Zl z#>rfz(Wq!f<555cQcmnm!iVd5^W6-Uo8p&Wc?&GBjz|-c*=pAIT@b% zd}wzEB_A4@d$_SQEsd8?t=8GzZZ&cV&US@%NpQ9s1<#9VZfUjZzC8wv=hBR;S$0w! zx?oV={sQXko^c?`r&#)n`Ti&qwam>jV|QiA&|$?~o1164WuU*%q+&U>F-~S(VK>G? zzUE0PtOI0%?$zqdbOiCqJvFXPq!X+on$b*!IoZ%x(gI>LjW6`38T?{fSES7F-;Iyf z>h-uKOT+0juC|)c*sFG_Y9ck`W}42VGprfXYJ~yGEGBAAW#U9c8cI>c6fZeatHfh- z&Dk-AxHij;raFelvwX2!(ucI7Efk&*vJ4TG){v1Y-U^#0_NP^vPHc=U>7pk}vzufF*~j!A zMUB=>ubvu?dr$jF@g zSPvcwK8HO2YA^?Ofd_z3A-Df$&;WaZ$npONS^bZ}^TEa7Ja7v54s?6~Tn{?nG9a{F z3RXX>99ZSRDhF0Mu*!i|4y`53IbfFBY~|e6ZpSIu6srb=OBGk_&vo&R<|R+x zt9qMwO;U_C9_8*NL0}ScN)oI2-qGB-l9YVlvXmxU&CzM{fy+`7$$9jove5l$ZLZh1 zS88=6sx?VqFH!2!=GUsXq>yD~uu75|!h!C9jWO^0I{Mm@0gw52W8b2ufdIe@Q7ko3|alM+;Gs zE@c?08dgj{T?`Q%y~T3PZv~Yg^cT`Cqo3x54#KIb^jE$e4^?-0-BCMTs8=wFY(kZz zS7Y(HQC7_&t6O`J(OqSal9m_^HpWg#rh2AkdX!rQ~RdB9#laB#=!l+7qHd84m7}pKzR8n@D}h!@CV>kV3d!mcQsYHAO5?nPjBwhG`uqAIb#jm6fa_qltNS9%)pm7 z@44t$(t?1=UNHv3)14Lcy77V<_~PWCH+4r6PxxENPy$G<#t533)G7-L^`(6+!&p@E z*sRRjpgF5aNpkY>%de?@e)S@D-Tumz(79BTLX>_hYd(XmE6*Swr91;N$@miT^kBR& zmM@1k#z?3#pG~pY1$Q0VUxDRg@WR;N_$lU&PJB$wQkxE334fa%o(redXiLb*rBYyu zHyN9n%G$xWHvc};txJaQa(lBD+vg_1vu;{!c-q?vmh6$L(o-E6x(D*R&=3eWCXKv6 zBkMkW!n&_hHA_H#`#=S@ZLzLF2c-{)w+0pt^#?HnjkI$=&Ik{3(RH$OoqB}9#F#H6 z8To9=Cq{267AD_WFORp^+N`h%CHAkW?QYy5rgIvKB;l-GS|0^pUAEh5C<$q5)Enz` zz3eQlW7=%TFnDEL&QcCre1R}WmL?=EV@$>zlTeOMp`g|gM;wfJIxf)_)eX zscIw6r%Z3w=gG9NkD`dx&c-|>zl*^ySNcj*x}0XF<&`pIsmUB#OohfZxCE4%Prg0r zE%i0C;zQ;}QXCW7m`wW{n#^lFGSASX4cD+T$U!fv5s}|j6 zLi)@anq{&s1oEU4PFc835)^M2xBd+ikn7wq5*42&G7V_UP^;=hvZEujNK<@I!F+G@5k5s_v5B&+jjd1| zHH&flgR)p+z}!!>qMG_5hR^y683#=r4}ex1>4-$yZp0fTN&153y;u{|MUH7*Y>F?P zir3Ck$!m{GqRtWLpc%sl^}eaCX}z*!s5mIo7=1BMxAqhnl7qgXu10c?DbEw9EM?%c z{(t%V$-Z212ayx|&oHOeZeu)Sm96L`EXmNwOD1lSzJL*3oIM*QBpRKQ$w-@xRNc~8 zNDFHL?v(Il$&W&%8E46rGz#Ixk4UF>X zif2Q<0MvMxst%Ivw1EQwbcRmS`DlqPMIWcl3L)#HxF`;*PHD1CYmiV{t#&#g5ds?4 ziv9mg1k)Fbe2V?w$^V~5*8f}Z9&i;n0PYXIkF0+a_D`kw)>01dDfd>T3b4d7C+7OVj$fm@OHUkUbsbHFE&_1_7e2lj%; zgZCrf-vFKqc7R8N&miOf1-Kf_gA2e9;h*^GUk`+rF9M@~q*-;_OPg^vIo3cGgybO; z)NyTZ;?jZ=>L^~f-Kw}h;){#hE(5uYMjAxovnrBCCC(nMy{IptbPpPYU5#sSo0ZJ2 zj8nN#h<7qW;2M=6xJ`=xVIpIx++8~!cPn$UQ0p+%vs%@}AWx&yrW=yqhMepc8U)8?`C#1Gug_I_eL|4EIRWU5bi^YMQ*xjC~H7o6< z%+W32hSDPR=tmr))r)MS^%!&uR9!(1TeIetqN4tFqOSBxX+1Jh^er)U8RVC_iH2cw zfea^_<2J?!yvx-4QrDu9kZDUk$^S zNwbbHNr}gh2|V9XWq93-aDQC(c4%smCuS2}M}%eC1{;42`F5!(ys>>EHx-n2YGt|M zesQdDc@1k}5@u-oj9e=ITPj_rm_iv#B%Kk}vyh<02pmpJ1*c_1v#bKNn~d7<19mUp z_|1|NYGsin^&T`*v*AG6g0Xn!dq<2SkqFAqT-R|zjIe-VxG5<&xf&rb^Dv>96r6O! zOx&n-bWmmmEo9cy=3IBaKUbnA2(qF?)~tTjL_7(q8*()J#$qmvtZU@6Y+%wlcReHE zV-|Vmz}+ZW7`+gAGHEB;(xO6oW_hBO-M>c3g-sgx2iF#GhnBgtok|rF zrPjoy7Z(C^W42ylM%QauhYd(l8sb)l1G^+Jn^4B$hU}7>H4P`1b^b@DcM64!e3;xX zoqyfd5D}n^s&+_h8KSjutKLU;z@RIqR8cNnerVD&t^9o=wbPkaURzv@8UDu4yHlI4 z)g5E=$%P>c*U4B-h;LrM|YMqlb1Ph?Wt=Z2FO{6WbOm)oyXml9X9mjOgus zi?MA*cC4A5Y++NgngMrfU}Q6++pTaev}70PkeHujvL=u$!OTL^iM<08PWCNHJRf7+ z?YAq>#2JBBn2EUNFQ1K+$L-*7>#<1h`G1+gQKcKzXrtxhJHIZI{w~vh<#%X9F0GOY zEU9&@WzlWQC}db%c@-u!SwXnPp5t+;BG8vWF9PF|X73HMD*lhF{U5PEnh|-GizzF# zUWcqN{{H8KpCRMl4gLlk2N!}fz}?9Be+pg*o(UcXeu{km5g>B^8^JMfF&G08_%d?- zUw}7&MQ{{63!DZ-{ujUhCO9Ab19JYiz<&oX0rOxZ_$6}wyTKB85_kx>9XbC^;7V`? zxC8nAW^gUo117)&z{ipEUjQxzBKJQGd<{AOtzZ_M2gbnvMb7^uxEh=Xeu0cHd-QJv z9WV*DfQN&x!@Ji4;bB$ySolaqurGt9=63eonC4?=PMHuknLUaL)93n3b(60~`8C2k zx;|)}g#pW_S30c*@q8mIP|VIEowJMUw8*C%UUVym(!CT8y#xRKDyN#44hrk>g?g{E zw^yxRBAc7!BA&y*fNdyPhP#B1@raFR#xx{r9R_T&!rWTTW=j{?TbOv5t#!&N4@<#y zJ2ht$5VKG_E^$N2RPa%R9U9BmSuMl+f*t3 zS&-1E)S4os2U{D*m#b?{K@!MEbJZ(3x)M;eCXc|jksIYALtkd_l9*Xz_A>yyb!lez zf-UeS8S_6Zs0o}Ww7-1$Otn4A>L9bn^wZ3e_>#2SYqR`jSt4uVUV}-Vt;w<}Ol~pX zc4e=aTz6#Sw3bzrS`;yhU^b}vK*W~?J$`|FbGMzcIX-Q+dUNv=#=a?I^gvzQL6!WN z^!xN8A&1Nq-)|mPgRZXqL*sBhru~I7TUIJ&?IyjgYW5$`_R_i=cn;Z3$6D}WDyAuG zFDu$YY)}nxxmYa+mBz^@1QD+E7sxGPoav`XNmbO4O0wz+0^3WGT=P3^Od|lXRkZAJ zVayqz1JLQ#NC>%ZYQ#KPDy+92c$vI!lmkcuKXJHldqmYnQDCqX&=(Fq`FEL@A)-TAMC0i5H z-m|~{vR7NpYMawF2vl^C@sBdI&89f#%@TxAUn`rD_|Oarmsv=3gZ!Xi>N)7?9+se0 zwlAA?&Yw$n-kYk=mK|ABSkA04aOy4UN!6y}xkU4hB$H)2NwU=_^>tV&SV`<7_R}-u z7-byxoH53Bb)LXIHT9m%=*t^7*PeZWGv7+uo@ZkJUyr={evw;| z|K0ifpGEHf6CnHkp9bWNzmtKS>-S!8EvN%I+wURZo5=nj1b+Z3U@PEtW6=Y_UnBRw z1608@*bYtxcOdh>1Bedba&RB;A>{to1KIEYcyJf;{(Hd-fY|>}0Y63FzaA`t-QYBE z7c&2!gKNO~U=8>(^8R~44Ll2o-9HAmBlEu;><6L;7y~DP+mZXf1pW@Z7F57MQeyb1gvcoArV?clNCG2jv4%jgAe1vh~=fKX@fRDQ1ocf#{K!0kZze+yX2 zXU;lixs!c@gGKy7DyqDq3Cp29@?1y#I5CzC?<7XQVo+jyvJZ?C0G?pD7R_lAL-NR) zf9|R|s|y_M_DpK-_@IJXBDn(E5FJW(i{(-?gs~>p9+fLi#7QApR?<`CkQjS!z&S)# zo0jdMVF?u+C*!y6r#;PQLIi=@kRQxcZOemyuUjT*AxkXdT6YC1DDkhAtCZ1cOSJR_k8N45Xdkc}BTBi# zw1sf5K73{Ax%8Eb8deG+O*E3=Ud%PFJORgTX2tt*c8$>(aZV2%SglI+C3Daow`N+H z21H!N8%9JO5uCk-SJ0T`Jhn!X+9mo6J?D}`YBVjc&EQlW@$;==zY$H_#Kc5A zCbc#ux8#tqxYOd)p|N^B(`8T{PE0qpsbI}2Dn7XEc*>>rQi$*h6L&-GBzjVhu8+{e z$Z0?lib(1v0sXynJ-*eo>b#Issms|%II6I_+O+`WLFETt8(!ce8QB&FF2 zFSbIKWwg|eR+CnkGnT-CnK;=Z$0ET$Ny6CcY?(Bn*nKiHo6EyJDSk`d;Tja)YPJl; zq|EY7+_cP~MpA`AF-y#-UxaFoUzLb7+=5GL7T5{&&Vjs-MqM-Ny0oZ{RxwqXBjqkC zSUBV}=~j0%IcJh{mSi1=BX?R)8}YtLdsmrOD27B+HWNB?5|{Wx0&0DnvnfVfdTvRu zX5Qmm6BBCmKBdt8uzEsi{!xznoWrbGCL_y4T5OEMb%z{vS(D;cun(%LP}GI=2pn#t zm$}r8-w|=bh!r*3(w}NRwuvb;O6-u#QB$ySg)2E?4dEPXS`nJVj>LISsb`?2?=mfc zqr=w;Z7WZd9J@8Jko)MZW0m^R%F-obLQTiC$Dl$+Pv40FwE(@x202g8$$9r*E(ie-e$ zY?h7lIK`(Ea})6liy%&?s~7=oIwiQ~wSv)N&n_8O7=_Umn4XM?GIZb=t~|;sCq}g> z(iSFhe9~<;LJun#Rc3I#9hU>A6f!MD{`Z?8&5@8={4AKC=GBo#QY~}D2z4HsfaBjl z-ID~6;XmPEz>Tq-Jnc=&YZ7_rCRD~Pj%FK|Q09TeBD|;5rNpwuCK1>e+{2BrT0n4^ zcIi5Y4_g`Tu{YZK^l460xURcnsX2Gfq($eIRSxr|4O*s|5H*e6!9ziOnsMJp$96II zyWm_82|ksbecInqgtF+$j=ZCLnpTo>gMm>;tn* z`)$Zct2ni#;;nsZFyd@5f)Y4jJO8_AncQ= z(wzncQ>$?n%j%;zTj$)wGUFco%pTI0T*tHh?kkVDMvP|2x4Q;CApnAie@q;L+em=m0(m zt_IHlJHUEyAMi1B0j~pBfU|+@5%?MUfLp;0-~}KBPXrGIUqdf&3+RFi!4p9Q?nXE8 z0U*8t{{cJ@h^|1+@xK-v2G0cd1-GLccoTR&I1Ziz&Hz6|H}HP&DsUyZ5Ih)s9i712 zz)QfD;4E+|xC{CJo#0jAAdq(j{uA>4?cnWT30wgVfKA{r;3x23>fl|==m7HVtzRsp zbvg;r^bEBnCC0_n*$c9f)F#K2p%R`t|8!y#y5DLc-bNSiNBl7R?`hSCd#!GIQQ9P1 z#(fjd9S@x~`q&;&vuFQ4yyVd3dB;iZ4t9@Fkk(-%EopjIaj@ia6E!x%OMj5WC!Z^y z>63e8SEL>|&)Pf7U&}vo{t{X#W@u7ZxS=EyXat%)U655qx3HTnnIX~lFw=YnW!Z~X z@dRe>k}t{HGv;4cg?X~d>&xhgPaMax^m8oJc5FJl?H~5#0;Wqki*z9PXbk@Kt@d1e zH_!F2BV#?*IT#4Mu4aok;^)Q>?IAYF8=xS*tcCg0#M} zqSve)#z$odqdopQwb>f$}sPE*ZO+_9d`wTo=(Jwdg!?F4?SlaxJ*lIpXJT2@;;ABG0%{nVB)i z*(_3Hog-*GB9oYZkog4gy!epSsl*Zuzpy+DVG_~*@*r8#Q;68WP)va(JkJVliq^LT z{)@MZ_oVHwMO`ig+}D!|I8>%Rn+-*E))Kbkayu-ua$gTn&|+s5VAe**2MtClVw=;0 zG%r^uSLo8UoJu^!kj8IWD>WO4`$zdH9q6otZ#n2PD=hQe=uW7tJVVEFO=wM`p@)pp zem3&MX<{Rp6=nYtuS8E!;atOwqAePhTT&5$OlAgQ*RYVKDg`Z%)fyOok;1Cl)I_l= z`li;A&Z`>0{oKH0=H#p#eYIg<%tB%9$EPU zcP=!|+~lvwQs44$n4T7rtS@=k+m-Y3W%SgBD^UxgveHg9yAC1B`M_aMNjNMdaMGPm z-l#q`su2)uEG?!_F;9;W;lvwXA&jFc?_k_8cAL8}HYL)lkthAMB^^@nokP}yhN^^fTu1>0`$ z$oT*N0#W%z$e<$sAK*(qpFzf#z5hqS8Q{mr^PdMdfDVv70FMISLXN))90gmzso;yq z?{5W5Ky3YIfPX}O{|LAa)W8$KFOb_m30@1t=YIw~8QdS-iR}If@M`cJa1mGwzK{I= z$KXmJXZ?K{x&8IvAb1YA3_Kk?2%HK|0Y65D|2+5{_!N+R0Ugi=hrk9PX93<9+=X0! z3%Cxv0lWrW3{C@&03!E)02%*{pa~j4_6CPnp#QFwNax>_rtYWv*4t(n%=!_BavC%GQQm*S zsI8V1u|w*+cvcW)X2o$<9KpPH&|1iY6Ky@&szSD-gFo-qKP~Cdb|%anyJJUu9qV<3 z_eSmE+-T`Z!~qEbg>vk0@FY7*R34mQx};)Ftp*eXwDmp9s56gFFnwxSEGKQZ7#)kx zGxGFt-qmAk(P?32HS8NrSX&IWg~>-cO&B8J<~>uJ($e&k8^n3%QgN|CAVXW)Sio6M z+CHHo6WRVxQ2U$5OswqRthAL&!g3Ah-D=F?X>(ZOe>x}9QJNc>6GNO<^ldoN7vdl2iwPTMQ*AYkI?7~z< zNju1x6nQo%y)2rM5hR}V+LaTx{1VvtWKkjgIfhZQX*`SU?=2hKIej8uhPj8gwMoP! zA1fk>M}{7jl{?OgMK*#r|2s}z%2Mcxcxy~gnHqQpjEL-LE%8ew1ceGIRoj-__J+4nbXSg6ueut*mfT5ck_+%6aJQx7 zw7Ne?e+qYVNZ)p4%O(PK`LIpc)Ki#7aMaX6<2qx4x?v>@%kd_5ciItMT4%qMIi_2f zEcCw-NcI_LU0R`-1umA-TFLS8v?Mk&K+qy)L-D#TD?&np|l{j8f)2FGDqCy(>oL$c57&ytkpWJoks8?Z|zM)UP?QV2h9BRV+_~4j1OxHYm zf6bk+YX;DGs?Py(CO-gx4Fs<~Q@$&6C-zC1I#a z`6!b~$93*9#k(?DTqu^Qd-J+p-uG8Zw}0_;Q{Fe;$(`B~+gFfl2G&dws-2Vq^X74- zI{$A?Vzv^C_5gY3pR@6Q2HF35@H;?k{7(Sl|1akN-UU7mL@)4r-~~X=1`z$gy};Md2iydn z2eyJqa6j+`bOFBywt#zsAE5)d4ZI!vNASBqbOUlO;3v=rTn(NNwt-<${ohB{zYV+vEP^Y+Bf-B1r-287pCjvk2#7A=G9dc|*$s@{Cg1FesU(~2ORtZnI1V@QywZkbDt4-Jt|ATBSE?&R=1iSGtJ^(y-z9ZC z&A1D4^N$Oz-||q(C||mg50}Cwq*^yw{YzRJvNRy3$?4*$Mcj}WLYJ8`{7fg^WSS`@ z$`K>xBC`X>EsDcA0*ix0>z^ikBBg`9{-PP@V|(YI?DWoN!AbjG9agb! zf$ns1K6i4^nkuP=WLkZ3R6RXSHRpck`+MUKwc*;PTac5Gwv;9>A;K)G5;a=mea?han8Q z9rDi6v;w~M*{IDZUs(8}x8naXQ(X)vCseG@ktzSZjmJuozkB ztwsBRZ80S1Dz2}rJj*^o4#8!ZnWK5ICOyh*$dk5!E3+bdGsfO(3mbCC9r|9Y-Kf+V zW5fGe2H#4z1ma@w*1jOM;I%9wPx>^2AiBH>Qz{8Kma2_}rd>a}6M(}d*9IzSu4EbKp0C*c{gI(ZUa1Qu3vi{BB#b7rW z180CogWm$*L*9QUcn7!vyc`?`2^a%0_$KoIpMwM7x4~1u1|aVT{44O6pbk>78T<>3 z_%`?(@OJQGAm;|i*@1T>_ul|s23`s_gK@AH{4;X@P2hDv-WzxYcru8<7tjG*1D*jk zfOEk(I0?KTUBC_C8ZZasJi*h!kI)Ug1-u!UPd2J#S5#clp*@y7o^6s zxk4yiejrn63pU}*n_qo~thVZ{xt;Vj7F%M}y#N=&Bj(T*9o_Y&iMluKbm*ZG5!Am$ z3PTB0T*~KcU)7|CaAv+o+gJlBnQpSrjFH|oDH-?4JC7!|r>RGi9KNcqL*mlp#+e-Z zvUM2A_#!TQ5mbm)QZ~Qkqn_{@ZkBIP>o!mgPz7$BO#2-JLPAeirAysSZI|ZZtG&?P zMy&T-BQP_FR=dq$q>5(}kd5fNrMIa)WL91WCzHd@7At<*YGn>DEynP;f{$~%v7QKW z#4w}(d`k{X)*}bom1d`IHmOdFZ5=6QzSpQU&E(+t`u}^&id;d$Z!>lnwPG;G6ED4$scSmhPB~68GLUP~%yG_d*MtQTt53{>j-{28&lJzmS_p{A5 z|D@kb#m6pLIJgq__Zqn5$HCH!D2tQtjIX9$NG5yHOqRwN&4l9p8ss(R97$7F$WZ4c z>JAaWkQrsI8HOKH;9~8D#dYl%qk6yCR^p?ACaC1DRS1#Q2ncVCnzvSaS;pm5yZX*_6eZ!ZrL)opkIm&sfppMwGPE^7ir7@t+ql#MzHzO9z4Y%uDH#k5GSdRft9nku{P3r>(>(vj2_Xtw8($mcY5-;Xrf%UjcFs;48sp;4C110Dl6m0lyD^7u3L3 z@DT7zWd6H>ydU5O@G>C20J8Ug0}wxeTao==0uF+UfV>~@E6DqQ3SI_Y3J!wPz|WEK zKLcOviK0YndQEjSEzfro)xkok{-E5MV%{lNE-^*;*U3@!)f zgGYfMAm@Jyyc4v5>T1EGt zoWmz0Qr>;aMzcBvpI_vX(|j59jeC_pWrcv7tv{m%wGrLKgB>3i!G>weJ}pgC$xHIC zg!ED9%7@D+sK?UW$QL~?x19+#vNUd{s&nhHdR zg>yc6xuO|*8fxygiCQT+pG6kAGza5ASHYvN$hL(rX)(2#kEzD+StXJuK3AJ!?6<1Q z)BHzUL6pCj{pxo?Vf8p^-aVt9YH}h?Sz$7NzkJ%uHTIRZ%seqtm;yCfS+w1nNhi4J zFUyLWbISWo7d21JuUAxB$k1Nn-&r$1vw~u;wDPRK6M2-BrZ{*ONb=1}Gac5fvfg0a zt4xu6d~E=xi*K=}7Cahw<$W9T)4rCPJMk_w`~Pv>kSzxy(~cF}y>ChOLgZ?WOw!S9 zWaq?1k}b4g>qq0O4D%C%rfe1MA35`-60a91#_ych#}aF;j<-IHa*mRsXAGwRnVXEi zrRQA07)n0dG!)v$dS4wlu&3X!_iDq_I%a?B|1^s*I)QzCagyC0W)HFxr0BcPWJ~CmGgzVn&~wbB*?V$ z7xv`jE>wSxs$-f?G95T0Wvy7-85RU-6;=b7h!H`R@R^|`|0cg_eQD=fHJU_{p(E!Q zn;XPUh27)_dHc|`Tuc{7eHVCi+VieSv6x7fp|`39$Osf7hZa@e1Cy24@Qh|1NlZs^ zp?GrEO;sfbwj=~4b-^=F0&D+p4^W4~s9>|R?h4PU-0Tp+fE8;*r)?5a%qJ6~3YHb^ z5H1@uB$10Dhls$o6X G^8Wxl8iWM^ diff --git a/src/Idris/.Desugar.idr.swp b/src/Idris/.Desugar.idr.swp deleted file mode 100644 index a46da998e6728132d64e793a41f3bbe90f994efc..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 45056 zcmeI53y@@2dEXoH5QIo3U|T8@!`Ve*deCYl5DBo(f>t}bV(>nO-B}4d63d+b4?&--2h^xA{{yW|Gp7WjWeCKh`_c-USTz$jBG4tHHt809oP^>}Ttt+2?^;7Qe-G%%A#9cq){{GLx{YSa$*SWt3 zT!nr4k95~PA3s~T?`}{3OeHXtz*GWL2}~t0mB3U2QwdBZFqObm0#gZ0CGd|@0#UP8 zyB5wb6MYx|zt{gC`hi;QFTrQQec<=NUEtqC3Ahm)1pB}h;1ck|;O{Q3)jkLQ z9DE$y2Yw6uGWcnbfOT*qxB>hq*bn~4MYY;J;H}_Ja0a{#oCc2qfAmj@Q2;{_ftQ09 zgXe%JgU5hJgKs__THrx&Klmj07`Ox62(ATn@Kp>4cY&M14}t%Uq2V9E7r;lsyTI+B z3leY;TnxU6q2Tl2BjC;872r5{BKQc#j@NZxD@;~28&OCJHaaWSKu+=i?riAKodxtJ`J4j$C#!K z%rJv?Gd8_}sV^Rl)=jHn`t4QI8Kj%2a_}Cjun0HA^v`(Ho+^aJm(U;FJjQ%IBM-?ZMC-kJk0a;!@mSm#c@m z)bV7rxv<^~a=kLz76PF$L7tkco;RKVRRe0DpGE^l&4QEnbW6+(J&s7u;CIO z8g32EeB2tibiRiBjV*fM(w*8)3>ZdR3rVZ%631J;Zhu%?-xzL09Y$w&se4xIH}uk2 zKD^cIo8ip?t0w)Z#Ofz{BCc*PL7x4%)!s6_e%zQfG**AuJv;DCnr4$P&91#^{`Hk6 zE134G1EPU#u&k{_jkCjc<17h~fjQny4h{z0 zh9M$EL=fEGZ%*_i9d|a@;(n|tBvtsa&8AJ;kygq|t*_g1&Z`mowXisC!a5}PxsFlY zl4P2^F?ViATdEc7KBl*zMMDPtuhDV|r97@*3$3_Af2r=^McMeGsd}7@tpDlcY|`CK z(q3!A-d*a%mTJ3YqGa3DZ`z{nX3M-h?!@aahX^xheIx17vG`FO07fTX64BYxM2FU* z{=m+;DaU-7WU#aoTK?f3D_MW-n10BAI3w3}HmftO(Z^2>`$lii&gMqm1QTV=4GP+%}F*yA?Goh4r|<8Xp{(Zl`G? zmKN@gqqJ`vk)FKC(=rE^??*4szxjX z=etR4Yd>$-&XTItN5E_C)iox@b8!cW6ZI^Qa=L&BU}=d}9|fN4cFx5Eo82!jSo=U$ zQ|x1H>%2WX2irD&#lhcnhBLd-Gr7O<}+GWnsK8Ov6`W#vdEw3 zr)64i&)Lp8t0Jk@+Uv6B6Jo=Dw=;LFn?%hyU1_HGPSXgKK_yA6z_~oC|&n z`N9P%xit)~A+4ytjk?`!ZggVX>E>Lotcm{r@gGw*Io$7e`)2Ru10kb+7LYfEx3QxP+vj3&^hn-fWe#0`&{};OtEP$hYckRqS(~j$ zb+O-G7c2P0(m#UP$Y!V_E&>nYTfYbN!3_8&KJ>f6tH86t zH!wWB3%nFO4_pX7i0}Mf@J7%9KMMAMFXKD^6u1k#4$OmRf{VcK<3Im3umCOv-^N$| zDeyLM3pfb=4}S9d!P~)Y;4G+v8u$?Y@&F=v? zz6%8DtCNIde%Bd_lZ5nyl#gQ1IvH>F+rwCfiHUDD{mn@_KQoWZCnHL;73qp?*A7-3 z5-l^)aD}X76Ph+tk?7Ir727AU%}&B&hqN-P8TC<#PIpyJ((N3fqg_nGg*o(v;=!M2 zz^zG2nO)MN4jAsX zC>O*#>|OZI5n$>o-HoIver$2vk*a1pkvcZ)&3#I8R&tAh-8R*cNZgQFn1#3(;Fhw5 z!BQOp4jqG4HBsXD4pl<73^6-5x(OzF)6Ax0v}8uaI^}IBAKMuI|0g=O>j-E&A&c0YUr=y$6Tvt%Pc{TkW{1AqE3={g#C1 z$WY`N`R7YD^06H<=y_xPYwZL}K2LR%_u${Ap$}&--`^}CKH ztpvmAu!>Q4&B<(J*=G6XV1$bFoLG1)>a>51l9?WorpQcm6zzxFfAWmerH&Fsr8Aj4 zr>r(3eTZ)3`xQU&`1z?>d6W_zd$zgkNGl6^OfBs#on7kE&644|wD(Nfu8vWCYB>pp z9qlH`Bi)19j*N1%_^6h}fV2P!MP#LUIUCqA*wevX7~6rgcdU{mSm`#mnGq;*cb}Al z6@$hmU41->7>_LTQ_krsk2R@FFB%L~m6i1>(RMmt4Oa5x+)8Ma2AoeivKF@eY-pET zajejUvnqix6zVsvxRzVlVO0>Yta6oxwh^dxE#3t^&DQeeNf(77>b;8zMKT1_iBJ*Q z1vL7>yu`1Hsi|G2WBYJQE6B9-T(;x5mZc;UgP&}QvY32=@PyLoOQkYfn6k%D9TAZ$ z@>r6rtTo%oa6ssrn+Z$PN#*D+4`pAseAUeOPv!I?Oyy~4{myS{5&eG;3hgn`YtjGb zopSq8^!`_Z=Yemd^M3$r0g2K7d-VPL!EN9<;J=~o-vcBT|7qYM^!>X*8$2C63Varw z|Gl6C4ueO6KSb~UMQ{{68GH+!|DE78_?O^s(e*zCUJqUdo&X*~$Nv!c6|e@b2bY5X zg|7b@@P6=WAo~Bs;4|p^9{@iOmccdP0`O<(`uBie0@nkHo&OVb{ttj9a1pp4ncM|L zHb+H1JAG`EGVhNHmp|EFy%BSsjaRxO=EI#UII;^=AO9#+c6?aW7t`c6;-At()`dzXnTJ^-;n;E0DARH< zIC7!Zb$KAUAZi4hF8T?V3Zt%dvC8tau@)23s*BWCyD!F7g1O`VW?RB>UF#C87@1DA zzS4~HTZR$wr;sN$#bo(Ih zbQw_Y2}h+TbbF;{bi6M0<2cQ4s&XxtVOJfod)k0W63>vFM(`3$PT^f zeA!6*or}^fGq7`t>ulsI>Mo)}11}HLQA-wy`6GsI!R_V{b#Cvg4!jC;v{~-V5REqz zYEUNqELUYcaNs~bYY^e8(>^;~4t6Bikzh1yoIWCb@YF_wklEk?&=1y*zBznkxb~q= zWs(lvtSrRCw~B0Xk-I`LaJ^Ota&{dm|Mig0~xMj0f6n!J1 zt>cO<^D?5u9HA{!QP9Iuh$E6KARPt4m-?bhSzkQeBW78Re=XTZpqt3(5&B5MprB8~ z^l?%iuIVPUaZgoGXOgFCz)vmUI{Zx({Z(KQYbi=~++0Y^mRbeG032-3%h*2JZA66qQX=b1vBd7FmzY;urqI|L zXbY7`R!W8Pf`ZD-R?t7xi8grD@`w`4krq=cXS7%9enbh+YDO+M#UWV?Xgd@+-IBz` zi}gjHVM}T_vS?udL)&6BbPQ7jf$FxxC^fPrD(di*9Zh2A%Dd9D2J*ZW+8ALaH$)0J1NW6JSz4Ow~Z6NNvAYi1(fx%l`oc6Po&D@I#*U;)to7e7HRr=!N}MOq`OdO zi}fg&ooF=oSx!Y5cDS*PiWj=(38a4)e4}K`1X;65yXU*e z_|82uFRQu=ALZbDDsa+oilz<4ck=&ZHAMe^0ebD5MZZP=KkjtgPoVd|4n*KuPzPT? z_y0{0gJ*)jL-&_hfO~=L2e<`r#CYxRu>nXtzz4zGzy>%39t-{iTfqCktw8qRKLvaV zTfn{G)u0PbfD6EX#wPGS@N?h@xEy>1yTE(Et>DMNERa}%2eA#@2i^{D1J{Dbf%~xy z+zwX3zW`ssCh%{;?cmwqpM$Sr5BMl}E9in3gU5rTlt zMHPzVv9p>nuMy@&`7mpEIVQsiwy^m%Xvzhd+7nv3u+X*-DEc6dSL)1>4Ph8UKxCN& zzG3yo7@2s9>{1ZILe7XX~hDR<&j6n5Pp^>dEea{Kw3^ym~74}W`mA~9t{ObWEC zRgqgD8ebfLm(yiKn!YM&rJ5qE-IM1$X{6YGG^q^ahSnyrx< zBu4k>UA55!-M3OGGD`D_`bWCJj+4Bdx45j6b=&2G+ zdV{s-u*SoNSc7aO_cN?DfB=&WNZtL0^q?`At`6D3l` zPCm9Hx{&Hg+awihxyzo?*W}4$jTSOo%a7f{t+2<4RC2yr9`FU@I#;}LUG)Eh=%aUv z-irRe=yX$w|Nj}VA6yMC0S}<_e+2wKcpHeo^T1!D^WO)48^}2V>)>hNuh92D1MUSs z1?Irtpzq5$eD{L4fER&lz@MY+zDO^UILy09sxd!?tc&H00ZRgy$8U%K?8^_;0M5eLGS-Kcr7>%o&^3Y zdjChjFMt!^$>2eB{@(;Y4Hm&H`0vQ@0U)ycb&==!e$wu32(TOsRlBi^xNQA3!@(iq z9*_k2ZlEi6J@bwuX)vK`(04w8754#p=M^{?X3k~E7VGV*U1x-rtOhi2* zS6!7n(pIU$;mJwqY-2r#^@ZYtQ2odpKqK0Sgb(IrH?q0Qt*xRfL=pP6`EY$l$%)vA znB-u=3B+aOvs;HBDpxJ1@DdVySQu6LOwmp6>TXq=)H!NOZhB_a2Q1 zZDfzzP|uu^kX4q-svsF3qfbl-JsGBD<6n9#Ta~#=_7>o6vo^TWFoBunSRSCIJ7>)D zd^hFyW?7XN;+Cqrk5H7<)k|t-CR-8WxD!q-B=RL*?+v%pD!8UTRdovHkwfVbS&IW~YqsK?tKOV~A+{j+1EE$wiMDP$%;$TUqn zNz-}4;~P%}GIk_KoLATR&kT^ic1ODN!7Q%%ZvgNDImesby^QZIrT+aL(5# zW%s0TkG21DBGjdB#RQX5$ba$FYWa)u zeUym9grl3NNH6>C>OFC#J&QR-E9^y;m7R?L|K|=MeJpGGd<&+J6gG|NK3_>%wx9Jm zFRs$DnBS9~7ih!qJFs(J?}3@-&jcP|D4IIRAWMb>KHm ztZqcI^Gud6uHEewGy_)-geE9fbA{zvLKJJ)B2uVyk^C0C@}db(U}p5ztq7J3!BlqB z=du$9XNljOe{AFgd8oV2(vLx+r#{d&q?IiR*|tyNBm1EKWC2LwgItvwsaCmpW0n}A z|I6nkqOYR=pU_|E=;-^e0XKrDfQQiY-w$2`7Qq$ZJLvd-0DcDC1g-#&0e^&^|6cG4 za6PyL$ew@?fLDVP;77pM(eFP5-T-3I1lNEI!GA)>zXz-WId5O|{eKVM1Z01}rQi?I z>wgv83KqdExBz?}{r(+b8N2{I5qu5Z{JfK4Rri> zg1bN$90X4Ue}SGa=j-1Bo(sN(-0lN!1Fr%qM`W0_P3fB~xt_0^wyRUs8xpLxDF>A1 z6F9vnXlmL1olmpdjo-@Kn2q0JI?DP@xb0i=s_qG=s9Ys0LK-5d!zJfp%FGLDnJR?O zx&7jHkX44>=^9SWYb;%^>vlV$CoDRu>1t-ZXRqYNqt*3GlZjLZ&GFq>$~bl>U&^FY zw(jdCPLEkZBIsoIqquuSAZ(r+C zM$E|$?6pgeUe+U`xeUWo6tfF z?6MK#d(M?M)@3x7@Fq=_ZvZF%nalK@7XA(nTTY{cVj7r>;wUKY84{{fm|Szy+>YzX@tW zftN~4xaa$5adU(mu)-M{W&Z7r@k=93^RU*1fc}(4rCwQ^oS5@pu@$OUXv7E>uVP-& z5XVlr-d<8Z(o|d%6)po;Yb}0c3w|G*TjM+_sjR+Nt}R*}OWHGa z8C$#?{GOzb1{vIs3Srf%(%EbE5gR_vsAGL>#w=zn+y@dCHrCUqTja_``A*<1nqys# zv=fUY(f?6fYi;=t{r{BH|38k-{|4~m;K|_2==*X8z-xi{{htb+0{#kp|D)iSK?__3 zzJtCmKL6Xn5%5&-DfE4b{l63Rz;)nB;30JV2Y~qfm%u6T1n^aK{@(+4fRmsO{tTV} z9`Li^2zV@z*#EDf^S>9o2fPv-1Q&x(qxZiPY=9SnE5I|rKcM^n2k?vFW#C!hLhudr z{)fOP!0W;7AOY*(GVmAZ|DOZD1%3iZEWjS{HS7Q%20saI0{;xi*#U0=Dp!$du65aq z7ply|?gFvwrr~vY9b=6!jX&=!)1KXcZs=Ay$;$dJY7tQAbqUtvc;C?!{mV-dbi{pT zgLU^R)})SvzELi5hS<4Hy2yYG_F3cTn$4~(&XZX79!LE)JE7%_4BUE}i`BjvNZ6Gx zgk?RCSk5ny3BxHh^P)A1zR4R!)bj0U`{#_)ZI>6QTswWQpd1F%?J?h_76`AmqN|E? ztVF#!`_7uJ^5?Z$`=%#mPPyti%v$gJz35V2Cs=f;!&lzPr~P7ct=(ATq_nQIqG@xU zfgEbGVK?B)J7j$O^3q0eOXpr5GiNDW&sKCfrXcsSnI;0_>?=8mf++8JxWVgrI1xc! zYskBG^j$8rQJRJ~wHP_eKx=S{K8S@_%(iNuZ~779eslDI9IK@#uITfR-cvp;4^_K| zO;lRR6PCA8ma(J;YGu zS0xo4rpiN6hOVje<)(?tQXH4MT8`s#jFn`X(eO#TpvsV?lRHn(iLuF*At!STw;Msv zb5e1l&t+3Gxm?l^RXIgu6%F8cL;mtfnNx$GKRr{<&8!?A6{Dk=(T$COxGWsA_aVsu z)T6n?iX(>(v9@G7=eW1byR_T8lYcHr`_1lDBv9 z$mAt)+>sk{8dy8l8s=!S^`6rXg-F74uhS7z)_R+{u%kxQTuRQ5vcoq_EOsxpp<(~( zZ15CIAD;B7Ua2(yWVJV~6sVn6K+?Ojsx}(DgjC;Z)|8_qYv4-ms&8o+|eW9K$A2NkcXx_F23-8j^9J_nu?=tdXBAd45ZGxwM%~mmV z7TDRJF}xdp0mDh>D8I;(KIL2nIeN^2q;sX(vdjNh9C4ttz8n)EeN|?ZooL8H&=nI_ z&d<>gQ{6IhS~a@>9nECeg(S0|xa8GrMpltrbBt$_*H3)?%4MNp z53zOSNl8L8FHOgkoN$w|qlaQ|va4?fl`60)+Kah8qTWRoo{TNY@}-=whZHUN)BNaMUuiLc>;N4UCe$vBd+F!)FS9lblGI&iLcn||5u`(Mo#}f;`IM7qVxYL zkoN$-3COzu4uWr>^Ghti$G}^`8SotNx9I(U3|G|LI`}d=|GU90 z;Mw3W(e>XC-ULp99|506*Z*}e4;}&j03ClFTn;{mUjG~5EHFUM1N>dk0?z^x*MApy z2UrA`g9p*w?*c7w6Zk>!N%Z!+ft>&U0`PQjIrsv)`@6wwz>9&z_Fn*g2l5 zoU}jgRnJYG^;(?N(jPsl?~JZHMPZ+8BH{!-cHu5{56Mz8eQmTg9LhCf30OFpEYFxU zx;jSxRFCblJGVoA`taEj+5Jo_dMLZhRr}nFoMq9elX=BGU#T3^@>=`l^kw$B8=`!& znml7&L_Dgpigt7lM)uo#rE*Df5l+gC#yinM@?llkSc}wl<5z^T81J(f9d^7MopE3-9T*KAj`?cogTc4x-fmi64qMw`mAwQXw9mDhviQs0nZtnO`f5H_%F^B8e?LXpgNV~s+##2}op#C<`m|O_G?d!d zym}C^U!{9RN8Y5P#}7-Tf^&Rzn1(On$iG)3UsihLZ*^#lKVV!~tURdOo|Z6nVbmnsAgL7_sU>rwE2j6Qs4mLu%+{9Rj0=!zfH7&}R%czk$3ifVFJ*@VZ3 z2RXAJDdQ@$;=#dLy3)7ZaxP6U`MJimTzQgn-F6weAVdd>%VlM=w3ur1Udwd5J{%kzSnQT-w~x@wq9}JW({mJHmTWP=EDEpppvC9Y6G(H&OiARmt*? zhSZc&T~Jx)L}^6jES5AX-7bm>0!u`@rKDmpRcU+?uG0I(N12IMV&K{=HFR61FWwTZFHn{aD)GRd;r(V} z>8H2Y+diDzCr%TMP9jH6pJCIH?{WSGL6*dRW1Y5XpxAN0+$}A;?WoK