on master help sign in
Merge pull request #1884 from david-christiansen/color-issue

Make isTConName and friends exact

commitc6771d240df296fc01ea271dbcd3b1a596365503 authorDavid Christiansen <david@davidchristiansen.dk> dateWed 11 Feb 2015, 21:24 (12 years ago) parent38e3a400657c46
8 files changed+76−51
src/Idris/AbsSyntax.hs+5−1 src/Idris/Core/Elaborate.hs+14−13 src/Idris/Core/Evaluate.hs+29−24 src/Idris/Coverage.hs+10−11 src/Idris/Delaborate.hs+2−2 test/totality006/expected+1 test/totality006/run+1 test/totality006/totality006b.idr+14
src/Idris/AbsSyntax.hs+5−1
@@ -1734,7 +1734,11 @@ stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where
17341734 | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i)
17351735 = Placeholder
17361736 su (PApp fc f@(PRef _ fn) args)
1737− | isDConName fn ctxt
1737+ -- here we use canBeDConName because the impossible pattern
1738+ -- check will not necessarily fully resolve constructor names,
1739+ -- and these bare names will otherwise get in the way of
1740+ -- impossbility checking.
1741+ | canBeDConName fn ctxt
17381742 = PApp fc f (fmap (fmap su) args)
17391743 su (PApp fc f args)
17401744 = PHidden (PApp fc f args)
src/Idris/Core/Elaborate.hs+14−13
@@ -173,30 +173,30 @@ elaborating_app = do ES (ps, _) _ _ <- get
173173
174174-- Some handy gadgets for pulling out bits of state
175175
176−-- get the global context
176+-- | Get the global context
177177get_context :: Elab' aux Context
178178get_context = do ES p _ _ <- get
179179 return $! (context (fst p))
180180
181−-- update the context
181+-- | Update the context.
182182-- (should only be used for adding temporary definitions or all sorts of
183183-- stuff could go wrong)
184184set_context :: Context -> Elab' aux ()
185185set_context ctxt = do ES (p, a) logs prev <- get
186186 put (ES (p { context = ctxt }, a) logs prev)
187187
188−-- get the proof term
188+-- | get the proof term
189189get_term :: Elab' aux Term
190190get_term = do ES p _ _ <- get
191191 return $! (getProofTerm (pterm (fst p)))
192192
193−-- get the proof term
193+-- | get the proof term
194194update_term :: (Term -> Term) -> Elab' aux ()
195195update_term f = do ES (p,a) logs prev <- get
196196 let p' = p { pterm = mkProofTerm (f (getProofTerm (pterm p))) }
197197 put (ES (p', a) logs prev)
198198
199−-- get the local context at the currently in focus hole
199+-- | get the local context at the currently in focus hole
200200get_env :: Elab' aux Env
201201get_env = do ES p _ _ <- get
202202 lift $ envAtFocus (fst p)
@@ -213,14 +213,14 @@ get_probs :: Elab' aux Fails
213213get_probs = do ES p _ _ <- get
214214 return $! (problems (fst p))
215215
216−-- Return recently solved names (that is, the names solved since the
216+-- | Return recently solved names (that is, the names solved since the
217217-- last call to get_recents)
218218get_recents :: Elab' aux [Name]
219219get_recents = do ES (p, a) l prev <- get
220220 put (ES (p { recents = [] }, a) l prev)
221221 return (recents p)
222222
223−-- get the current goal type
223+-- | get the current goal type
224224goal :: Elab' aux Type
225225goal = do ES p _ _ <- get
226226 b <- lift $ goalAtFocus (fst p)
@@ -233,7 +233,7 @@ is_guess = do ES p _ _ <- get
233233 Guess _ _ -> return True
234234 _ -> return False
235235
236−-- Get the guess at the current hole, if there is one
236+-- | Get the guess at the current hole, if there is one
237237get_guess :: Elab' aux Type
238238get_guess = do ES p _ _ <- get
239239 b <- lift $ goalAtFocus (fst p)
@@ -241,7 +241,7 @@ get_guess = do ES p _ _ <- get
241241 Guess t v -> return $! v
242242 _ -> fail "Not a guess"
243243
244−-- typecheck locally
244+-- | Typecheck locally
245245get_type :: Raw -> Elab' aux Type
246246get_type tm = do ctxt <- get_context
247247 env <- get_env
@@ -254,7 +254,7 @@ get_type_val tm = do ctxt <- get_context
254254 (val, ty) <- lift $ check ctxt env tm
255255 return $! (finalise val, finalise ty)
256256
257−-- get holes we've deferred for later definition
257+-- | get holes we've deferred for later definition
258258get_deferred :: Elab' aux [Name]
259259get_deferred = do ES p _ _ <- get
260260 return $! (deferred (fst p))
@@ -271,17 +271,18 @@ checkInjective (tm, l, r) = do ctxt <- get_context
271271 isInj ctxt (Bind _ (Pi _ _ _) sc) = True
272272 isInj ctxt _ = False
273273
274−-- get instance argument names
274+-- | get instance argument names
275275get_instances :: Elab' aux [Name]
276276get_instances = do ES p _ _ <- get
277277 return $! (instances (fst p))
278278
279−-- get auto argument names
279+-- | get auto argument names
280280get_autos :: Elab' aux [(Name, [Name])]
281281get_autos = do ES p _ _ <- get
282282 return $! (autos (fst p))
283283
284−-- given a desired hole name, return a unique hole name
284+-- | given a desired hole name, return a unique hole name
285+unique_hole :: Name -> Elab' aux Name
285286unique_hole = unique_hole' False
286287
287288unique_hole' :: Bool -> Name -> Elab' aux Name
src/Idris/Core/Evaluate.hs+29−24
@@ -11,7 +11,7 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,
1111 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,
1212 lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,
1313 mapDefCtxt,
14− lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, isTConName, isConName, isFnName,
14+ lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,
1515 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,
1616 isUniverse) where
1717
@@ -971,47 +971,52 @@ isConName n ctxt = isTConName n ctxt || isDConName n ctxt
971971
972972isTConName :: Name -> Context -> Bool
973973isTConName n ctxt
974− = or $ do def <- lookupCtxt n (definitions ctxt)
975− case tfst def of
976− (TyDecl (TCon _ _) _) -> return True
977− _ -> return False
974+ = case lookupDefExact n ctxt of
975+ Just (TyDecl (TCon _ _) _) -> True
976+ _ -> False
978977
978+-- | Check whether a resolved name is certainly a data constructor
979979isDConName :: Name -> Context -> Bool
980980isDConName n ctxt
981+ = case lookupDefExact n ctxt of
982+ Just (TyDecl (DCon _ _ _) _) -> True
983+ _ -> False
984+
985+-- | Check whether any overloading of a name is a data constructor
986+canBeDConName :: Name -> Context -> Bool
987+canBeDConName n ctxt
981988 = or $ do def <- lookupCtxt n (definitions ctxt)
982989 case tfst def of
983− (TyDecl (DCon _ _ _) _) -> return True
984− _ -> return False
990+ (TyDecl (DCon _ _ _) _) -> return True
991+ _ -> return False
985992
986993isFnName :: Name -> Context -> Bool
987994isFnName n ctxt
988− = let def = lookupCtxtExact n (definitions ctxt) in
989− case def of
990− Just (Function _ _, _, _, _) -> True
991− Just (Operator _ _ _, _, _, _) -> True
992− Just (CaseOp _ _ _ _ _ _, _, _, _) -> True
993− _ -> False
995+ = case lookupDefExact n ctxt of
996+ Just (Function _ _) -> True
997+ Just (Operator _ _ _) -> True
998+ Just (CaseOp _ _ _ _ _ _) -> True
999+ _ -> False
9941000
9951001isTCDict :: Name -> Context -> Bool
9961002isTCDict n ctxt
997− = let def = lookupCtxtExact n (definitions ctxt) in
998− case def of
999− Just (Function _ _, _, _, _) -> False
1000− Just (Operator _ _ _, _, _, _) -> False
1001− Just (CaseOp ci _ _ _ _ _, _, _, _) -> tc_dictionary ci
1002− _ -> False
1003+ = case lookupDefExact n ctxt of
1004+ Just (Function _ _) -> False
1005+ Just (Operator _ _ _) -> False
1006+ Just (CaseOp ci _ _ _ _ _) -> tc_dictionary ci
1007+ _ -> False
10031008
10041009lookupP :: Name -> Context -> [Term]
10051010lookupP n ctxt
10061011 = do def <- lookupCtxt n (definitions ctxt)
10071012 p <- case def of
1008− (Function ty tm, a, _, _) -> return (P Ref n ty, a)
1009− (TyDecl nt ty, a, _, _) -> return (P nt n ty, a)
1013+ (Function ty tm, a, _, _) -> return (P Ref n ty, a)
1014+ (TyDecl nt ty, a, _, _) -> return (P nt n ty, a)
10101015 (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n ty, a)
1011− (Operator ty _ _, a, _, _) -> return (P Ref n ty, a)
1016+ (Operator ty _ _, a, _, _) -> return (P Ref n ty, a)
10121017 case snd p of
1013− Hidden -> []
1014− _ -> return (fst p)
1018+ Hidden -> []
1019+ _ -> return (fst p)
10151020
10161021lookupDefExact :: Name -> Context -> Maybe Def
10171022lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)
src/Idris/Coverage.hs+10−11
@@ -18,18 +18,18 @@ import Debug.Trace
1818
1919import Control.Monad.State.Strict
2020
21−-- Generate a pattern from an 'impossible' LHS. (Need this to eliminate the
22−-- pattern clauses which have been provided explicitly from new clause
23−-- generation.)
24−
21+-- | Generate a pattern from an 'impossible' LHS.
22+--
23+-- We need this to eliminate the pattern clauses which have been
24+-- provided explicitly from new clause generation.
2525mkPatTm :: PTerm -> Idris Term
2626mkPatTm t = do i <- getIState
2727 let timp = addImpl' True [] [] i t
2828 evalStateT (toTT (mapPT deNS timp)) 0
2929 where
3030 toTT (PRef _ n) = do i <- lift getIState
31− case lookupDef n (tt_ctxt i) of
32− [TyDecl nt _] -> return $ P nt n Erased
31+ case lookupNameDef n (tt_ctxt i) of
32+ [(n', TyDecl nt _)] -> return $ P nt n' Erased
3333 _ -> return $ P Ref n Erased
3434 toTT (PApp _ t args) = do t' <- toTT t
3535 args' <- mapM (toTT . getTm) args
@@ -44,13 +44,12 @@ mkPatTm t = do i <- getIState
4444 deNS (PRef f (NS n _)) = PRef f n
4545 deNS t = t
4646
47−-- Given a list of LHSs, generate a extra clauses which cover the remaining
48−-- cases. The ones which haven't been provided are marked 'absurd' so that the
49−-- checker will make sure they can't happen.
50−
47+-- | Given a list of LHSs, generate a extra clauses which cover the remaining
48+-- cases. The ones which haven't been provided are marked 'absurd' so
49+-- that the checker will make sure they can't happen.
50+--
5151-- This will only work after the given clauses have been typechecked and the
5252-- names are fully explicit!
53−
5453genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]
5554genClauses fc n xs given
5655 = do i <- getIState
src/Idris/Delaborate.hs+2−2
@@ -308,7 +308,7 @@ pprintErr' i (ElaboratingArg f x _ e)
308308 where whatIsName = let ctxt = tt_ctxt i
309309 in if isTConName f ctxt
310310 then text "type constructor" <> space
311− else if isConName f ctxt
311+ else if isDConName f ctxt
312312 then text "constructor" <> space
313313 else if isFnName f ctxt
314314 then text "function" <> space
@@ -488,7 +488,7 @@ fancifyAnnots ist annot@(AnnName n _ _ _) =
488488 _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty
489489 _ | isMetavarName n ist -> AnnName n (Just MetavarOutput) docs ty
490490 _ | isPostulateName n ist -> AnnName n (Just PostulateOutput) docs ty
491− _ | otherwise -> annot
491+ _ | otherwise -> annot
492492 where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs
493493 docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist)
494494 let o = overview (fst docs)
test/totality006/expected+1
@@ -1,2 +1,3 @@
11totality006.idr:8:1:Main.prf is not total as there are missing cases
22totality006a.idr:11:6:prf' (S _) (S _) Oh is a valid case
3+totality006b.idr:10:1:totality006b.blargh is not total as there are missing cases
test/totality006/run+1
@@ -1,4 +1,5 @@
11#!/usr/bin/env bash
22idris $@ totality006.idr --check
33idris $@ totality006a.idr --check
4+idris $@ totality006b.idr --check
45rm -f *.ibc
test/totality006/totality006b.idrnew file+14
@@ -0,0 +1,14 @@
1+module totality006b
2+
3+import Data.So
4+
5+
6+-- There are approaches to impossibility checking that break on this
7+-- case but not on test006.idr, due to the extra computation.
8+total
9+blargh : (xs, ys : List a) -> So (length xs > length ys) -> GT (length xs) (length ys)
10+blargh [] [] Oh impossible
11+blargh [] (y :: xs) so = absurd so
12+blargh (y :: xs) [] Oh = LTESucc LTEZero
13+
14+-- Missing: blargh (y :: xs) (z :: ys) x = ?blargh_rhs_3