@@ -1522,7 +1522,7 @@ elab ist info emode opts fn tm
15221522 (arg, x : rest)
15231523
15241524 insertScopedImps :: FC -> Name -> [Name] -> Type -> [PArg] -> ElabD [PArg]
1525− insertScopedImps fc f knowns ty xs =
1525+ insertScopedImps fc f knowns ty xs =
15261526 do mapM_ (checkKnownImplicit (map fst (getArgTys ty) ++ knowns)) xs
15271527 doInsert ty xs
15281528 where
@@ -1538,7 +1538,7 @@ elab ist info emode opts fn tm
15381538 = liftM (x :) (doInsert sc xs)
15391539 doInsert ty xs = return xs
15401540
1541− -- Any implicit in the application needs to have the name of a
1541+ -- Any implicit in the application needs to have the name of a
15421542 -- scoped implicit or a top level implicit, otherwise report an error
15431543 checkKnownImplicit ns imp@(PImp{})
15441544 | pname imp `elem` ns = return ()
@@ -1698,167 +1698,6 @@ pruneAlt xs = map prune xs
16981698 headIs f (PApp _ f' _) = headIs f f'
16991699 headIs f _ = True -- keep if it's not an application
17001700
1701−-- Rule out alternatives that don't return the same type as the head of the goal
1702−-- (If there are none left as a result, do nothing)
1703−pruneByType :: Bool -> Env -> Term -> -- head of the goal
1704− Type -> -- goal
1705− IState -> [PTerm] -> [PTerm]
1706−-- if an alternative has a locally bound name at the head, take it
1707−pruneByType imp env t goalty c as
1708− | Just a <- locallyBound as = [a]
1709− where
1710− locallyBound [] = Nothing
1711− locallyBound (t:ts)
1712− | Just n <- getName t,
1713− n `elem` map fstEnv env = Just t
1714− | otherwise = locallyBound ts
1715− getName (PRef _ _ n) = Just n
1716− getName (PApp _ (PRef _ _ (UN l)) [_, _, arg]) -- ignore Delays
1717− | l == txt "Delay" = getName (getTm arg)
1718− getName (PApp _ f _) = getName f
1719− getName (PHidden t) = getName t
1720− getName _ = Nothing
1721−
1722−-- 'n' is the name at the head of the goal type
1723−pruneByType imp env (P _ n _) goalty ist as
1724−-- if the goal type is polymorphic, keep everything
1725− | Nothing <- lookupTyExact n ctxt = as
1726−-- if the goal type is a ?metavariable, keep everything
1727− | Just _ <- lookup n (idris_metavars ist) = as
1728− | otherwise
1729− = let asV = filter (headIs True n) as
1730− as' = filter (headIs False n) as in
1731− case as' of
1732− [] -> asV
1733− _ -> as'
1734− where
1735− ctxt = tt_ctxt ist
1736−
1737− -- Get the function at the head of the alternative and see if it's
1738− -- a plausible match against the goal type. Keep if so. Also keep if
1739− -- there is a possible coercion to the goal type.
1740− headIs var f (PRef _ _ f') = typeHead var f f'
1741− headIs var f (PApp _ (PRef _ _ (UN l)) [_, _, arg])
1742− | l == txt "Delay" = headIs var f (getTm arg)
1743− headIs var f (PApp _ (PRef _ _ f') _) = typeHead var f f'
1744− headIs var f (PApp _ f' _) = headIs var f f'
1745− headIs var f (PPi _ _ _ _ sc) = headIs var f sc
1746− headIs var f (PHidden t) = headIs var f t
1747− headIs var f t = True -- keep if it's not an application
1748−
1749− typeHead var f f'
1750− = -- trace ("Trying " ++ show f' ++ " for " ++ show n) $
1751− case lookupTyExact f' ctxt of
1752− Just ty -> case unApply (getRetTy ty) of
1753− (P _ ctyn _, _) | isTConName ctyn ctxt && not (ctyn == f)
1754− -> False
1755− _ -> let ty' = normalise ctxt [] ty in
1756−-- trace ("Trying " ++ show f' ++ " : " ++ show (getRetTy ty') ++ " for " ++ show goalty
1757−-- ++ "\nMATCH: " ++ show (pat, matching (getRetTy ty') goalty)) $
1758− case unApply (getRetTy ty') of
1759− (V _, _) ->
1760− isPlausible ist var env n ty
1761− _ -> matchingTypes imp (getRetTy ty') goalty
1762− || isCoercion (getRetTy ty') goalty
1763−-- May be useful to keep for debugging purposes for a bit:
1764−-- let res = matching (getRetTy ty') goalty in
1765−-- traceWhen (not res)
1766−-- ("Rejecting " ++ show (getRetTy ty', goalty)) res
1767− _ -> False
1768−
1769− matchingTypes True = matchingHead
1770− matchingTypes False = matching
1771−
1772− -- If the goal is a constructor, it must match the suggested function type
1773− matching (P _ ctyn _) (P _ n' _)
1774− | isTConName n' ctxt && isTConName ctyn ctxt = ctyn == n'
1775− | otherwise = True
1776− -- Variables match anything
1777− matching (V _) _ = True
1778− matching _ (V _) = True
1779− matching _ (P _ n _) = not (isTConName n ctxt)
1780− matching (P _ n _) _ = not (isTConName n ctxt)
1781− -- Binders are a plausible match, so keep them
1782− matching (Bind n _ sc) _ = True
1783− matching _ (Bind n _ sc) = True
1784− -- If we hit a function name, it's a plausible match
1785− matching apl@(App _ _ _) apr@(App _ _ _)
1786− | (P _ fl _, argsl) <- unApply apl,
1787− (P _ fr _, argsr) <- unApply apr
1788− = fl == fr && and (zipWith matching argsl argsr)
1789− || (not (isConName fl ctxt && isConName fr ctxt))
1790− -- If the application structures aren't easily comparable, it's a
1791− -- plausible match
1792− matching (App _ f a) (App _ f' a') = True
1793− matching (TType _) (TType _) = True
1794− matching (UType _) (UType _) = True
1795− matching l r = l == r
1796−
1797− -- In impossible-case mode, only look at the heads (this is to account for
1798− -- the non type-directed case with 'impossible' - we'd be ruling out
1799− -- too much and wouldn't find the mismatch we're looking for)
1800− matchingHead apl@(App _ _ _) apr@(App _ _ _)
1801− | (P _ fl _, argsl) <- unApply apl,
1802− (P _ fr _, argsr) <- unApply apr,
1803− isConName fl ctxt && isConName fr ctxt
1804− = fl == fr
1805− matchingHead _ _ = True
1806−
1807− -- Return whether there is a possible coercion between the return type
1808− -- of an alternative and the goal type
1809− isCoercion rty gty | (P _ r _, _) <- unApply rty
1810− = not (null (getCoercionsBetween r gty))
1811− isCoercion _ _ = False
1812−
1813− getCoercionsBetween :: Name -> Type -> [Name]
1814− getCoercionsBetween r goal
1815− = let cs = getCoercionsTo ist goal in
1816− findCoercions r cs
1817− where findCoercions t [] = []
1818− findCoercions t (n : ns) =
1819− let ps = case lookupTy n (tt_ctxt ist) of
1820− [ty'] -> let as = map snd (getArgTys (normalise (tt_ctxt ist) [] ty')) in
1821− [n | any useR as]
1822− _ -> [] in
1823− ps ++ findCoercions t ns
1824−
1825− useR ty =
1826− case unApply (getRetTy ty) of
1827− (P _ t _, _) -> t == r
1828− _ -> False
1829−
1830−
1831−pruneByType _ _ t _ _ as = as
1832−
1833−-- Could the name feasibly be the return type?
1834−-- If there is an interface constraint on the return type, and no implementation
1835−-- in the environment or globally for that name, then no
1836−-- Otherwise, yes
1837−-- (FIXME: This isn't complete, but I'm leaving it here and coming back
1838−-- to it later - just returns 'var' for now. EB)
1839−isPlausible :: IState -> Bool -> Env -> Name -> Type -> Bool
1840−isPlausible ist var env n ty
1841− = let (hvar, interfaces) = collectConstraints [] [] ty in
1842− case hvar of
1843− Nothing -> True
1844− Just rth -> var -- trace (show (rth, interfaces)) var
1845− where
1846− collectConstraints :: [Name] -> [(Term, [Name])] -> Type ->
1847− (Maybe Name, [(Term, [Name])])
1848− collectConstraints env tcs (Bind n (Pi _ _ ty _) sc)
1849− = let tcs' = case unApply ty of
1850− (P _ c _, _) ->
1851− case lookupCtxtExact c (idris_interfaces ist) of
1852− Just tc -> ((ty, map fst (interface_implementations tc))
1853− : tcs)
1854− Nothing -> tcs
1855− _ -> tcs
1856− in
1857− collectConstraints (n : env) tcs' sc
1858− collectConstraints env tcs t
1859− | (V i, _) <- unApply t = (Just (env !! i), tcs)
1860− | otherwise = (Nothing, tcs)
1861−
18621701-- | Use the local elab context to work out the highlighting for a name
18631702findHighlight :: Name -> ElabD OutputAnnotation
18641703findHighlight n = do ctxt <- get_context