summaryrefslogtreecommitdiff
path: root/src/full/Agda/TypeChecking
diff options
context:
space:
mode:
Diffstat (limited to 'src/full/Agda/TypeChecking')
-rw-r--r--src/full/Agda/TypeChecking/Abstract.hs11
-rw-r--r--src/full/Agda/TypeChecking/CheckInternal.hs17
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause.hs26
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause/Compile.hs127
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause/Match.hs50
-rw-r--r--src/full/Agda/TypeChecking/Constraints.hs50
-rw-r--r--src/full/Agda/TypeChecking/Conversion.hs160
-rw-r--r--src/full/Agda/TypeChecking/Coverage.hs327
-rw-r--r--src/full/Agda/TypeChecking/Coverage/Match.hs302
-rw-r--r--src/full/Agda/TypeChecking/Coverage/SplitTree.hs22
-rw-r--r--src/full/Agda/TypeChecking/Datatypes.hs20
-rw-r--r--src/full/Agda/TypeChecking/DisplayForm.hs55
-rw-r--r--src/full/Agda/TypeChecking/DropArgs.hs19
-rw-r--r--src/full/Agda/TypeChecking/Empty.hs2
-rw-r--r--src/full/Agda/TypeChecking/Errors.hs306
-rw-r--r--src/full/Agda/TypeChecking/EtaContract.hs14
-rw-r--r--src/full/Agda/TypeChecking/Forcing.hs5
-rw-r--r--src/full/Agda/TypeChecking/Free.hs224
-rw-r--r--src/full/Agda/TypeChecking/Free/Lazy.hs57
-rw-r--r--src/full/Agda/TypeChecking/Free/Old.hs29
-rw-r--r--src/full/Agda/TypeChecking/Free/Tests.hs118
-rw-r--r--src/full/Agda/TypeChecking/Implicit.hs60
-rw-r--r--src/full/Agda/TypeChecking/Injectivity.hs36
-rw-r--r--src/full/Agda/TypeChecking/InstanceArguments.hs145
-rw-r--r--src/full/Agda/TypeChecking/Irrelevance.hs32
-rw-r--r--src/full/Agda/TypeChecking/Level.hs93
-rw-r--r--src/full/Agda/TypeChecking/LevelConstraints.hs61
-rw-r--r--src/full/Agda/TypeChecking/MetaVars.hs268
-rw-r--r--src/full/Agda/TypeChecking/MetaVars.hs-boot8
-rw-r--r--src/full/Agda/TypeChecking/MetaVars/Mention.hs3
-rw-r--r--src/full/Agda/TypeChecking/MetaVars/Occurs.hs52
-rw-r--r--src/full/Agda/TypeChecking/Monad.hs2
-rw-r--r--src/full/Agda/TypeChecking/Monad/Base.hs759
-rw-r--r--src/full/Agda/TypeChecking/Monad/Benchmark.hs2
-rw-r--r--src/full/Agda/TypeChecking/Monad/Builtin.hs52
-rw-r--r--src/full/Agda/TypeChecking/Monad/Caching.hs1
-rw-r--r--src/full/Agda/TypeChecking/Monad/Closure.hs12
-rw-r--r--src/full/Agda/TypeChecking/Monad/Constraints.hs32
-rw-r--r--src/full/Agda/TypeChecking/Monad/Context.hs160
-rw-r--r--src/full/Agda/TypeChecking/Monad/Env.hs7
-rw-r--r--src/full/Agda/TypeChecking/Monad/Exception.hs3
-rw-r--r--src/full/Agda/TypeChecking/Monad/Local.hs40
-rw-r--r--src/full/Agda/TypeChecking/Monad/MetaVars.hs122
-rw-r--r--src/full/Agda/TypeChecking/Monad/Mutual.hs67
-rw-r--r--src/full/Agda/TypeChecking/Monad/Open.hs1
-rw-r--r--src/full/Agda/TypeChecking/Monad/Options.hs69
-rw-r--r--src/full/Agda/TypeChecking/Monad/Sharing.hs1
-rw-r--r--src/full/Agda/TypeChecking/Monad/Signature.hs387
-rw-r--r--src/full/Agda/TypeChecking/Monad/Signature.hs-boot9
-rw-r--r--src/full/Agda/TypeChecking/Monad/SizedTypes.hs9
-rw-r--r--src/full/Agda/TypeChecking/Monad/State.hs47
-rw-r--r--src/full/Agda/TypeChecking/Monad/Trace.hs16
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Abstract.hs8
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Match.hs109
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Match.hs-boot14
-rw-r--r--src/full/Agda/TypeChecking/Polarity.hs17
-rw-r--r--src/full/Agda/TypeChecking/Positivity.hs232
-rw-r--r--src/full/Agda/TypeChecking/Positivity/Occurrence.hs170
-rw-r--r--src/full/Agda/TypeChecking/Positivity/Tests.hs27
-rw-r--r--src/full/Agda/TypeChecking/Pretty.hs174
-rw-r--r--src/full/Agda/TypeChecking/Pretty.hs-boot1
-rw-r--r--src/full/Agda/TypeChecking/Primitive.hs143
-rw-r--r--src/full/Agda/TypeChecking/ProjectionLike.hs63
-rw-r--r--src/full/Agda/TypeChecking/Quote.hs79
-rw-r--r--src/full/Agda/TypeChecking/ReconstructParameters.hs8
-rw-r--r--src/full/Agda/TypeChecking/RecordPatterns.hs56
-rw-r--r--src/full/Agda/TypeChecking/Records.hs217
-rw-r--r--src/full/Agda/TypeChecking/Records.hs-boot4
-rw-r--r--src/full/Agda/TypeChecking/Reduce.hs318
-rw-r--r--src/full/Agda/TypeChecking/Reduce/Fast.hs534
-rw-r--r--src/full/Agda/TypeChecking/Reduce/Fast.hs-boot8
-rw-r--r--src/full/Agda/TypeChecking/Reduce/Monad.hs17
-rw-r--r--src/full/Agda/TypeChecking/Rewriting.hs252
-rw-r--r--src/full/Agda/TypeChecking/Rewriting.hs-boot2
-rw-r--r--src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs387
-rw-r--r--src/full/Agda/TypeChecking/Rules/Builtin.hs52
-rw-r--r--src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs35
-rw-r--r--src/full/Agda/TypeChecking/Rules/Data.hs59
-rw-r--r--src/full/Agda/TypeChecking/Rules/Decl.hs254
-rw-r--r--src/full/Agda/TypeChecking/Rules/Decl.hs-boot6
-rw-r--r--src/full/Agda/TypeChecking/Rules/Def.hs336
-rw-r--r--src/full/Agda/TypeChecking/Rules/Def.hs-boot4
-rw-r--r--src/full/Agda/TypeChecking/Rules/Display.hs16
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS.hs389
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/AsPatterns.hs117
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs15
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs9
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Problem.hs88
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs34
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Split.hs142
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Unify.hs584
-rw-r--r--src/full/Agda/TypeChecking/Rules/Record.hs191
-rw-r--r--src/full/Agda/TypeChecking/Rules/Term.hs727
-rw-r--r--src/full/Agda/TypeChecking/Serialise.hs5
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Base.hs1
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs12
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Common.hs60
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Compilers.hs2
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs2
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs139
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes.hs3
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Solve.hs411
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Syntax.hs23
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Tests.hs145
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Utils.hs1
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs53
-rw-r--r--src/full/Agda/TypeChecking/Substitute.hs643
-rw-r--r--src/full/Agda/TypeChecking/Substitute/Class.hs256
-rw-r--r--src/full/Agda/TypeChecking/Substitute/DeBruijn.hs54
-rw-r--r--src/full/Agda/TypeChecking/Substitute/Pattern.hs43
-rw-r--r--src/full/Agda/TypeChecking/SyntacticEquality.hs14
-rw-r--r--src/full/Agda/TypeChecking/Telescope.hs73
-rw-r--r--src/full/Agda/TypeChecking/Telescope.hs-boot2
-rw-r--r--src/full/Agda/TypeChecking/Test/Generators.hs558
-rw-r--r--src/full/Agda/TypeChecking/Tests.hs98
-rw-r--r--src/full/Agda/TypeChecking/Unquote.hs131
-rw-r--r--src/full/Agda/TypeChecking/With.hs270
117 files changed, 7912 insertions, 5482 deletions
diff --git a/src/full/Agda/TypeChecking/Abstract.hs b/src/full/Agda/TypeChecking/Abstract.hs
index 84fda32..a1b8aab 100644
--- a/src/full/Agda/TypeChecking/Abstract.hs
+++ b/src/full/Agda/TypeChecking/Abstract.hs
@@ -1,7 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Functions for abstracting terms over other terms.
@@ -36,9 +33,9 @@ import Agda.Utils.Impossible
typeOf :: Type -> Type
typeOf = sort . getSort
--- Doesn't abstract in the sort.
+-- | @abstractType a v b[v] = b@ where @a : v@.
abstractType :: Type -> Term -> Type -> TCM Type
-abstractType a v (El s b) = El (raise 1 s) <$> abstractTerm a v (sort s) b
+abstractType a v (El s b) = El (absTerm v s) <$> abstractTerm a v (sort s) b
-- | @piAbstractTerm v a b[v] = (w : a) -> b[w]@
piAbstractTerm :: Term -> Type -> Type -> TCM Type
@@ -91,7 +88,7 @@ instance IsPrefixOf Term where
case (ignoreSharing u, ignoreSharing v) of
(Var i us, Var j vs) | i == j -> us `isPrefixOf` vs
(Def f us, Def g vs) | f == g -> us `isPrefixOf` vs
- (Con c us, Con d vs) | c == d -> us `isPrefixOf` vs
+ (Con c _ us, Con d _ vs) | c == d -> us `isPrefixOf` vs
(MetaV x us, MetaV y vs) | x == y -> us `isPrefixOf` vs
(u, v) -> guard (u == v) >> return []
@@ -152,7 +149,7 @@ instance AbsTerm Term where
Var i vs -> Var (i + 1) $ absT vs
Lam h b -> Lam h $ absT b
Def c vs -> Def c $ absT vs
- Con c vs -> Con c $ absT vs
+ Con c ci vs -> Con c ci $ absT vs
Pi a b -> uncurry Pi $ absT (a, b)
Lit l -> Lit l
Level l -> Level $ absT l
diff --git a/src/full/Agda/TypeChecking/CheckInternal.hs b/src/full/Agda/TypeChecking/CheckInternal.hs
index 9064cf7..ae93954 100644
--- a/src/full/Agda/TypeChecking/CheckInternal.hs
+++ b/src/full/Agda/TypeChecking/CheckInternal.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-- Initially authored by Andreas, 2013-10-22.
@@ -126,17 +125,17 @@ checkInternal' action v t = do
MetaV x es -> do -- we assume meta instantiations to be well-typed
a <- metaType x
checkSpine action a (MetaV x []) es t
- Con c vs -> do
+ Con c ci vs -> do
-- we need to fully apply the constructor to make getConType work
TelV tel t <- telView t
- addCtxTel tel $ do
+ addContext tel $ do
let failure = typeError $ DoesNotConstructAnElementOf (conName c) t
vs' = raise (size tel) vs ++ teleArgs tel
a <- maybe failure return =<< getConType c t
- Con c vs2 <- checkArgs action a (Con c []) vs' t
+ Con c ci vs2 <- checkArgs action a (Con c ci []) vs' t
-- Strip away the extra arguments
return $ applySubst (strengthenS __IMPOSSIBLE__ (size tel))
- $ Con c (take (length vs) vs2)
+ $ Con c ci (take (length vs) vs2)
Lit l -> Lit l <$ ((`subtype` t) =<< litType l)
Lam ai vb -> do
(a, b) <- shouldBePi t
@@ -227,7 +226,7 @@ inferDef' f a es = do
Just Projection{ projIndex = n } | n > 0 -> do
let self = unArg a
b <- infer self
- snd <$> inferSpine b self (Proj f : es)
+ snd <$> inferSpine b self (Proj ProjSystem f : es)
_ -> inferDef f (Apply a : es)
@@ -257,10 +256,10 @@ inferSpine' action t self self' (e : es) = do
v' <- checkInternal' action v $ unDom a
inferSpine' action (b `absApp` v) (self `applyE` [e]) (self' `applyE` [Apply (Arg ai v')]) es
-- case: projection or projection-like
- Proj f -> do
+ Proj o f -> do
(a, b) <- shouldBePi =<< shouldBeProjectible t f
- u <- f `applyDef` (argFromDom a $> self)
- u' <- f `applyDef` (argFromDom a $> self')
+ u <- applyDef o f (argFromDom a $> self)
+ u' <- applyDef o f (argFromDom a $> self')
inferSpine' action (b `absApp` self) u u' es
-- | Type should either be a record type of a type eligible for
diff --git a/src/full/Agda/TypeChecking/CompiledClause.hs b/src/full/Agda/TypeChecking/CompiledClause.hs
index bc5766b..dc0eb95 100644
--- a/src/full/Agda/TypeChecking/CompiledClause.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-- | Case trees.
--
@@ -16,7 +13,7 @@ import Prelude hiding (null)
import qualified Data.Map as Map
import Data.Map (Map)
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, Any(..))
import Data.Typeable (Typeable)
import Data.Foldable (Foldable, foldMap)
import Data.Traversable (Traversable)
@@ -27,7 +24,7 @@ import Agda.Syntax.Literal
import Agda.Syntax.Position
import Agda.Utils.Null
-import Agda.Utils.Pretty
+import Agda.Utils.Pretty hiding ((<>))
#include "undefined.h"
import Agda.Utils.Impossible
@@ -89,21 +86,26 @@ hasCatchAll = getAny . loop
Done{} -> mempty
Case _ br -> maybe (foldMap loop br) (const $ Any True) $ catchAllBranch br
-instance Monoid c => Monoid (WithArity c) where
- mempty = WithArity __IMPOSSIBLE__ mempty
- mappend (WithArity n1 c1) (WithArity n2 c2)
+instance Monoid c => Semigroup (WithArity c) where
+ WithArity n1 c1 <> WithArity n2 c2
| n1 == n2 = WithArity n1 $ mappend c1 c2
| otherwise = __IMPOSSIBLE__ -- arity must match!
-instance Monoid m => Monoid (Case m) where
- mempty = empty
- mappend (Branches cop cs ls m)
- (Branches cop' cs' ls' m') =
+instance Monoid c => Monoid (WithArity c) where
+ mempty = WithArity __IMPOSSIBLE__ mempty
+ mappend = (<>)
+
+instance Monoid m => Semigroup (Case m) where
+ Branches cop cs ls m <> Branches cop' cs' ls' m' =
Branches (cop || cop') -- for @projCase <> mempty@
(Map.unionWith mappend cs cs')
(Map.unionWith mappend ls ls')
(mappend m m')
+instance Monoid m => Monoid (Case m) where
+ mempty = empty
+ mappend = (<>)
+
instance Null (Case m) where
empty = Branches False Map.empty Map.empty Nothing
null (Branches _cop cs ls mcatch) = null cs && null ls && null mcatch
diff --git a/src/full/Agda/TypeChecking/CompiledClause/Compile.hs b/src/full/Agda/TypeChecking/CompiledClause/Compile.hs
index 19adc97..1a57b0d 100644
--- a/src/full/Agda/TypeChecking/CompiledClause/Compile.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause/Compile.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.CompiledClause.Compile where
@@ -8,7 +7,7 @@ import Prelude hiding (null)
import Data.Maybe
import Data.Monoid
import qualified Data.Map as Map
-import Data.List (genericReplicate, nubBy, findIndex)
+import Data.List (nubBy)
import Data.Function
import Debug.Trace
@@ -45,13 +44,21 @@ compileClauses ::
Maybe (QName, Type) -- ^ Translate record patterns and coverage check with given type?
-> [Clause] -> TCM CompiledClauses
compileClauses mt cs = do
- let cls = [ Cl (unnumberPatVars $ clausePats c) (clauseBody c) | c <- cs ]
+ -- Construct clauses with pattern variables bound in left-to-right order.
+ -- Discard de Bruijn indices in patterns.
+ cs <- normaliseProjP cs
+ let unBruijn cs = [ Cl (map (fmap (fmap dbPatVarName . namedThing)) $ namedClausePats c)
+ (compiledClauseBody c) | c <- cs ]
shared <- sharedFun
case mt of
- Nothing -> return $ compile shared cls
+ Nothing -> return $ compile shared $ unBruijn cs
Just (q, t) -> do
splitTree <- coverageCheck q t cs
+ -- The coverage checker might have added some clauses (#2288)!
+ cs <- normaliseProjP =<< defClauses <$> getConstInfo q
+ let cls = unBruijn cs
+
reportSDoc "tc.cc" 30 $ sep $ do
(text "clauses patterns before compilation") : do
map (prettyTCM . map unArg . clPats) cls
@@ -71,11 +78,12 @@ compileClauses mt cs = do
-- used in clause compiler.
data Cl = Cl
{ clPats :: [Arg Pattern]
- , clBody :: ClauseBody
+ -- ^ Pattern variables are considered in left-to-right order.
+ , clBody :: Maybe Term
} deriving (Show)
instance Pretty Cl where
- pretty (Cl ps b) = P.prettyList ps P.<+> P.text "->" P.<+> pretty b
+ pretty (Cl ps b) = P.prettyList ps P.<+> P.text "->" P.<+> maybe (P.text "_|_") pretty b
type Cls = [Cl]
@@ -108,13 +116,14 @@ compileWithSplitTree shared t cs = case t of
compile :: (Term -> Term) -> Cls -> CompiledClauses
compile shared cs = case nextSplit cs of
Just (isRecP, n)-> Case n $ fmap (compile shared) $ splitOn isRecP (unArg n) cs
- Nothing -> case map (getBody . clBody) cs of
+ Nothing -> case clBody c of
-- It's possible to get more than one clause here due to
-- catch-all expansion.
- Just t : _ -> Done (map (fmap name) $ clPats $ head cs) (shared t)
- Nothing : _ -> Fail
- [] -> __IMPOSSIBLE__
+ Just t -> Done (map (fmap name) $ clPats c) (shared t)
+ Nothing -> Fail
where
+ -- If there are more than one clauses, take the first one.
+ c = headWithDefault __IMPOSSIBLE__ cs
name (VarP x) = x
name (DotP _) = underscore
name ConP{} = __IMPOSSIBLE__
@@ -130,7 +139,7 @@ nextSplit (Cl ps _ : _) = headMaybe $ catMaybes $
-- | Is is not a variable pattern?
-- And if yes, is it a record pattern?
-properSplit :: Pattern -> Maybe Bool
+properSplit :: Pattern' a -> Maybe Bool
properSplit (ConP _ cpi _) = Just $ isJust $ conPRecord cpi
properSplit LitP{} = Just False
properSplit ProjP{} = Just False
@@ -140,7 +149,7 @@ properSplit DotP{} = Nothing
-- | Is this a variable pattern?
--
-- Maintain invariant: @isVar = isNothing . properSplit@!
-isVar :: Pattern -> Bool
+isVar :: Pattern' a -> Bool
isVar VarP{} = True
isVar DotP{} = True
isVar ConP{} = False
@@ -155,15 +164,18 @@ splitOn single n cs = mconcat $ map (fmap (:[]) . splitC n) $
expandCatchAlls single n cs
splitC :: Int -> Cl -> Case Cl
-splitC n (Cl ps b) = case unArg p of
- ProjP d -> projCase d $ Cl (ps0 ++ ps1) b
+splitC n (Cl ps b) = caseMaybe mp fallback $ \case
+ ProjP _ d -> projCase d $ Cl (ps0 ++ ps1) b
ConP c _ qs -> conCase (conName c) $ WithArity (length qs) $
Cl (ps0 ++ map (fmap namedThing) qs ++ ps1) b
LitP l -> litCase l $ Cl (ps0 ++ ps1) b
- VarP{} -> catchAll $ Cl ps b
- DotP{} -> catchAll $ Cl ps b
+ VarP{} -> fallback
+ DotP{} -> fallback
where
- (ps0, p, ps1) = extractNthElement' n ps
+ (ps0, rest) = splitAt n ps
+ mp = unArg <$> headMaybe rest
+ ps1 = drop 1 rest
+ fallback = catchAll $ Cl ps b
-- | Expand catch-alls that appear before actual matches.
--
@@ -202,6 +214,21 @@ splitC n (Cl ps b) = case unArg p of
-- _ -> case 3 of true -> a; false -> b
-- _ -> case 3 of true -> a; false -> b
-- @
+--
+-- Example from issue #2168:
+-- @
+-- f x false = a
+-- f false = \ _ -> b
+-- f x true = c
+-- @
+-- case tree:
+-- @
+-- f x y = case y of
+-- true -> case x of
+-- true -> c
+-- false -> b
+-- false -> a
+-- @
expandCatchAlls :: Bool -> Int -> Cls -> Cls
expandCatchAlls single n cs =
-- Andreas, 2013-03-22
@@ -209,23 +236,24 @@ expandCatchAlls single n cs =
-- we force expansion
if single then doExpand =<< cs else
case cs of
- _ | all (isCatchAllNth . clPats) cs -> cs
- Cl ps b : cs | not (isCatchAllNth ps) -> Cl ps b : expandCatchAlls False n cs
- | otherwise -> map (expand ps b) expansions ++ Cl ps b : expandCatchAlls False n cs
+ _ | all (isCatchAllNth . clPats) cs -> cs
+ c@(Cl ps b) : cs | not (isCatchAllNth ps) -> c : expandCatchAlls False n cs
+ | otherwise -> map (expand c) expansions ++ c : expandCatchAlls False n cs
_ -> __IMPOSSIBLE__
where
-- In case there is only one branch in the split tree, we expand all
-- catch-alls for this position
-- The @expansions@ are collected from all the clauses @cs@ then.
-- Note: @expansions@ could be empty, so we keep the orignal clause.
- doExpand c@(Cl ps b)
- | isVar $ unArg $ nth ps = map (expand ps b) expansions ++ [c]
- | otherwise = [c]
+ doExpand c@(Cl ps _)
+ | exCatchAllNth ps = map (expand c) expansions ++ [c]
+ | otherwise = [c]
-- True if nth pattern is variable or there are less than n patterns.
isCatchAllNth ps = all (isVar . unArg) $ take 1 $ drop n ps
- nth qs = headWithDefault __IMPOSSIBLE__ $ drop n qs
+ -- True if nth pattern exists and is variable.
+ exCatchAllNth ps = any (isVar . unArg) $ take 1 $ drop n ps
classify (LitP l) = Left l
classify (ConP c _ _) = Right c
@@ -233,38 +261,53 @@ expandCatchAlls single n cs =
-- All non-catch-all patterns following this one (at position n).
-- These are the cases the wildcard needs to be expanded into.
- expansions = nubBy ((==) `on` (classify . unArg))
- . filter (not . isVar . unArg)
- . map (nth . clPats)
+ expansions = nubBy ((==) `on` (classify . unArg . snd))
+ . mapMaybe (notVarNth . clPats)
$ cs
+ notVarNth ps = caseMaybe (headMaybe ps2) Nothing $ \ p ->
+ if isVar (unArg p) then Nothing else Just (ps1, p)
+ where (ps1, ps2) = splitAt n ps
- expand ps b q =
+ expand cl (qs, q) =
case unArg q of
ConP c mt qs' -> Cl (ps0 ++ [q $> ConP c mt conPArgs] ++ ps1)
- (substBody n' m (Con c conArgs) b)
+ (substBody n' m (Con c ci conArgs) b)
where
+ ci = fromConPatternInfo mt
m = length qs'
-- replace all direct subpatterns of q by _
- conPArgs = map (fmap ($> VarP underscore)) qs'
- conArgs = zipWith (\ q n -> q $> var n) qs' $ downFrom m
+ conPArgs = map (fmap ($> VarP "_")) qs'
+ conArgs = zipWith (\ q' i -> q' $> var i) qs' $ downFrom m
LitP l -> Cl (ps0 ++ [q $> LitP l] ++ ps1) (substBody n' 0 (Lit l) b)
_ -> __IMPOSSIBLE__
where
- (ps0, rest) = splitAt n ps
- ps1 = maybe __IMPOSSIBLE__ snd $ uncons rest
+ -- Andreas, 2016-09-19 issue #2168
+ -- Due to varying function arity, some clauses might be eta-contracted.
+ -- Thus, we eta-expand them.
+ Cl ps b = ensureNPatterns (n + 1) (map getArgInfo $ qs ++ [q]) cl
+ -- The following pattern match cannot fail (by construction of @ps@).
+ (ps0, _:ps1) = splitAt n ps
- n' = countVars ps0
+ n' = countVars ps1
countVars = sum . map (count . unArg)
count VarP{} = 1
count (ConP _ _ ps) = countVars $ map (fmap namedThing) ps
count DotP{} = 1 -- dot patterns are treated as variables in the clauses
count _ = 0
-substBody :: Int -> Int -> Term -> ClauseBody -> ClauseBody
-substBody _ _ _ NoBody = NoBody
-substBody 0 m v b = case b of
- Bind b -> foldr (.) id (replicate m (Bind . Abs underscore)) $ subst 0 v (absBody $ raise m b)
- _ -> __IMPOSSIBLE__
-substBody n m v b = case b of
- Bind b -> Bind $ fmap (substBody (n - 1) m v) b
- _ -> __IMPOSSIBLE__
+-- | Make sure (by eta-expansion) that clause has arity at least @n@
+-- where @n@ is also the length of the provided list.
+ensureNPatterns :: Int -> [ArgInfo] -> Cl -> Cl
+ensureNPatterns n ais0 cl@(Cl ps b)
+ | m <= 0 = cl
+ | otherwise = Cl (ps ++ ps') (raise m b `apply` args)
+ where
+ k = length ps
+ ais = drop k ais0
+ -- m = Number of arguments to add
+ m = n - k
+ ps' = for ais $ \ ai -> Arg ai $ VarP "_"
+ args = zipWith (\ i ai -> Arg ai $ var i) (downFrom m) ais
+
+substBody :: (Subst t a) => Int -> Int -> t -> a -> a
+substBody n m v = applySubst $ liftS n $ v :# raiseS m
diff --git a/src/full/Agda/TypeChecking/CompiledClause/Match.hs b/src/full/Agda/TypeChecking/CompiledClause/Match.hs
index d8e8e82..c638e14 100644
--- a/src/full/Agda/TypeChecking/CompiledClause/Match.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause/Match.hs
@@ -1,10 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-
module Agda.TypeChecking.CompiledClause.Match where
import Control.Applicative
@@ -33,9 +29,7 @@ matchCompiled c args = do
r <- matchCompiledE c $ map (fmap Apply) args
case r of
YesReduction simpl v -> return $ YesReduction simpl v
- NoReduction bes -> return $ NoReduction $ fmap (map fromElim) bes
- where fromElim (Apply v) = v
- fromElim (Proj f ) = __IMPOSSIBLE__
+ NoReduction bes -> return $ NoReduction $ fmap (map argFromElim) bes
-- | @matchCompiledE c es@ takes a function given by case tree @c@ and
-- and a spine @es@ and tries to apply the function to @es@.
@@ -71,18 +65,10 @@ type Stack = [Frame]
match' :: Stack -> ReduceM (Reduced (Blocked Elims) Term)
match' ((c, es, patch) : stack) = do
- let debug = do
- traceSDoc "reduce.compiled" 95 $ vcat $
- [ text "reducing case" <+> do
- caseMaybeM (asks envAppDef) __IMPOSSIBLE__ $ \ f -> do
- sep $ prettyTCM f : map prettyTCM es
- , text $ "trying clause " ++ show c
- ]
let no blocking es = return $ NoReduction $ blocking $ patch $ map ignoreReduced es
yes t = flip YesReduction t <$> asks envSimplification
- -- traceSLn "reduce.compiled" 95 "CompiledClause.Match.match'" $ do
- debug $ do
+ do
shared <- sharedFun
@@ -123,7 +109,7 @@ match' ((c, es, patch) : stack) = do
NotReduced -> unfoldCorecursionE e0
let e = ignoreBlocking eb
-- replace the @n@th argument by its reduced form
- es' = es0 ++ [MaybeRed red e] ++ es1
+ es' = es0 ++ [MaybeRed (Reduced $ () <$ eb) e] ++ es1
-- if a catch-all clause exists, put it on the stack
catchAllFrame stack = maybe stack (\c -> (c, es', patch) : stack) (catchAllBranch bs)
-- If our argument is @Lit l@, we push @litFrame l@ onto the stack.
@@ -131,14 +117,14 @@ match' ((c, es, patch) : stack) = do
case Map.lookup l (litBranches bs) of
Nothing -> stack
Just cc -> (cc, es0 ++ es1, patchLit) : stack
- -- If our argument (or its constructor form) is @Con c vs@
+ -- If our argument (or its constructor form) is @Con c ci vs@
-- we push @conFrame c vs@ onto the stack.
- conFrame c vs stack =
+ conFrame c ci vs stack =
case Map.lookup (conName c) (conBranches bs) of
Nothing -> stack
Just cc -> ( content cc
- , es0 ++ map (MaybeRed red . Apply) vs ++ es1
- , patchCon c (length vs)
+ , es0 ++ map (MaybeRed NotReduced . Apply) vs ++ es1
+ , patchCon c ci (length vs)
) : stack
-- If our argument is @Proj p@, we push @projFrame p@ onto the stack.
projFrame p stack =
@@ -150,14 +136,14 @@ match' ((c, es, patch) : stack) = do
patchLit es = patch (es0 ++ [e] ++ es1)
where (es0, es1) = splitAt n es
-- In case we matched constructor @c@ with @m@ arguments,
- -- contract these @m@ arguments @vs@ to @Con c vs@.
- patchCon c m es = patch (es0 ++ [Con c vs <$ e] ++ es2)
+ -- contract these @m@ arguments @vs@ to @Con c ci vs@.
+ patchCon c ci m es = patch (es0 ++ [Con c ci vs <$ e] ++ es2)
where (es0, rest) = splitAt n es
(es1, es2) = splitAt m rest
vs = map argFromElim es1
-- Now do the matching on the @n@ths argument:
- traceSLn "reduce.compiled" 100 ("caseing on raw " ++ show eb) $
+ id $
case fmap ignoreSharing <$> eb of
Blocked x _ -> no (Blocked x) es'
NotBlocked _ (Apply (Arg info (MetaV x _))) -> no (Blocked x) es'
@@ -166,18 +152,18 @@ match' ((c, es, patch) : stack) = do
NotBlocked _ (Apply (Arg info v@(Lit l))) -> performedSimplification $ do
cv <- constructorForm v
let cFrame stack = case ignoreSharing cv of
- Con c vs -> conFrame c vs stack
+ Con c ci vs -> conFrame c ci vs stack
_ -> stack
- traceSLn "reduce.compiled" 100 ("constructorForm = " ++ show cv) $
- match' $ litFrame l $ cFrame $ catchAllFrame stack
+ match' $ litFrame l $ cFrame $ catchAllFrame stack
-- In case of a constructor, push the conFrame
- NotBlocked _ (Apply (Arg info (Con c vs))) -> performedSimplification $
- match' $ conFrame c vs $ catchAllFrame $ stack
+ NotBlocked _ (Apply (Arg info (Con c ci vs))) -> performedSimplification $
+ match' $ conFrame c ci vs $ catchAllFrame $ stack
- -- In case of a projection, push the litFrame
- NotBlocked _ (Proj p) -> performedSimplification $
- match' $ projFrame p $ stack
+ -- In case of a projection, push the projFrame
+ NotBlocked _ (Proj _ p) -> performedSimplification $
+ match' $ projFrame p $ stack -- catchAllFrame $ stack
+ -- Issue #1986: no catch-all for copattern matching!
-- Otherwise, we are stuck. If we were stuck before,
-- we keep the old reason, otherwise we give reason StuckOn here.
diff --git a/src/full/Agda/TypeChecking/Constraints.hs b/src/full/Agda/TypeChecking/Constraints.hs
index 2271202..9ff4854 100644
--- a/src/full/Agda/TypeChecking/Constraints.hs
+++ b/src/full/Agda/TypeChecking/Constraints.hs
@@ -1,13 +1,22 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Constraints where
-import Control.Monad.State
+import Prelude hiding (null)
+
+import Control.Applicative hiding (empty)
+
+import Control.Monad
import Control.Monad.Reader
-import Control.Applicative
-import Data.List as List
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
+import Data.List as List hiding (null)
import Agda.Syntax.Internal
+
+import Agda.TypeChecking.Free
import Agda.TypeChecking.Monad
import Agda.TypeChecking.InstanceArguments
import Agda.TypeChecking.Pretty
@@ -22,10 +31,14 @@ import {-# SOURCE #-} Agda.TypeChecking.MetaVars
import {-# SOURCE #-} Agda.TypeChecking.Empty
import Agda.Utils.Except ( MonadError(throwError) )
+import Agda.Utils.Functor
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Lens
+import Agda.Utils.Size
+import qualified Agda.Utils.VarSet as VarSet
#include "undefined.h"
import Agda.Utils.Impossible
@@ -71,22 +84,31 @@ addConstraint c = do
isIFSConstraint FindInScope{} = True
isIFSConstraint _ = False
+ isLvl LevelCmp{} = True
+ isLvl _ = False
+
+ -- Try to simplify a level constraint
simpl :: Constraint -> TCM Constraint
- simpl c = do
+ simpl c = if not $ isLvl c then return c else do
n <- genericLength <$> getContext
- let isLvl LevelCmp{} = True
- isLvl _ = False
- cs <- getAllConstraints
- lvls <- instantiateFull $ List.filter (isLvl . clValue . theConstraint) cs
- when (not $ List.null lvls) $ reportSDoc "tc.constr.add" 40 $ text " simplifying using" <+> prettyTCM lvls
- return $ simplifyLevelConstraint n c lvls
+ cs <- map theConstraint <$> getAllConstraints
+ lvls <- instantiateFull $ List.filter (isLvl . clValue) cs
+ when (not $ null lvls) $ do
+ reportSDoc "tc.constr.lvl" 40 $ text "simplifying level constraint" <+> prettyTCM c
+ $$ nest 2 (hang (text "using") 2 (prettyTCM lvls))
+ let c' = simplifyLevelConstraint c $ map clValue lvls
+ reportSDoc "tc.constr.lvl" 40 $
+ if c' /= c then text "simplified to" <+> prettyTCM c'
+ else text "no simplification"
+ return c'
-- | Don't allow the argument to produce any constraints.
noConstraints :: TCM a -> TCM a
noConstraints problem = liftTCM $ do
(pid, x) <- newProblem problem
cs <- getConstraintsForProblem pid
- unless (List.null cs) $ typeError $ UnsolvedConstraints cs
+ w <- warning_ (UnsolvedConstraints cs)
+ unless (null cs) $ typeError $ NonFatalErrors [ w ]
return x
-- | Create a fresh problem for the given action.
@@ -144,7 +166,9 @@ solveAwakeConstraints' force = do
verboseS "profile.constraints" 10 $ liftTCM $ tickMax "max-open-constraints" . genericLength =<< getAllConstraints
whenM ((force ||) . not <$> isSolvingConstraints) $ nowSolvingConstraints $ do
-- solveSizeConstraints -- Andreas, 2012-09-27 attacks size constrs too early
- solve
+ -- Ulf, 2016-12-06: Don't inherit problems here! Stored constraints
+ -- already contain all their dependencies.
+ locally eActiveProblems (const []) solve
where
solve = do
reportSDoc "tc.constr.solve" 10 $ hsep [ text "Solving awake constraints."
@@ -194,7 +218,6 @@ solveConstraint_ (UnBlock m) =
-- already solved metavariables: should only happen for size
-- metas (not sure why it does, Andreas?)
InstV{} -> return ()
- InstS{} -> return ()
-- Open (whatever that means)
Open -> __IMPOSSIBLE__
OpenIFS -> __IMPOSSIBLE__
@@ -215,4 +238,3 @@ debugConstraints = verboseS "tc.constr" 50 $ do
[ text "Current constraints"
, nest 2 $ vcat [ text "awake " <+> vcat (map prettyTCM awake)
, text "asleep" <+> vcat (map prettyTCM sleeping) ] ]
-
diff --git a/src/full/Agda/TypeChecking/Conversion.hs b/src/full/Agda/TypeChecking/Conversion.hs
index 0c5cf3c..40441a5 100644
--- a/src/full/Agda/TypeChecking/Conversion.hs
+++ b/src/full/Agda/TypeChecking/Conversion.hs
@@ -1,10 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
module Agda.TypeChecking.Conversion where
@@ -23,7 +17,7 @@ import Agda.Syntax.Internal
import Agda.Syntax.Translation.InternalToAbstract (reify)
import Agda.TypeChecking.Monad
-import Agda.TypeChecking.Monad.Builtin (constructorForm)
+import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.CompiledClause (CompiledClauses(Fail))
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.MetaVars.Occurs (killArgs,PruneResult(..))
@@ -59,11 +53,6 @@ import Agda.Utils.Lens
#include "undefined.h"
import Agda.Utils.Impossible
-{- MOVED to TypeChecking.Level
-mlevel :: TCM (Maybe Term)
-mlevel = liftTCM $ (Just <$> primLevel) `catchError` \_ -> return Nothing
--}
-
-- | Try whether a computation runs without errors or new constraints
-- (may create new metas, though).
-- Restores state upon failure.
@@ -75,8 +64,7 @@ tryConversion = isJust <.> tryConversion'
-- Return 'Just' the result upon success.
-- Return 'Nothing' and restore state upon failure.
tryConversion' :: TCM a -> TCM (Maybe a)
-tryConversion' m = (Just <$> do disableDestructiveUpdate $ noConstraints m)
- `catchError` \ _ -> return Nothing
+tryConversion' m = tryMaybe $ disableDestructiveUpdate $ noConstraints m
-- | Check if to lists of arguments are the same (and all variables).
-- Precondition: the lists have the same length.
@@ -247,7 +235,7 @@ compareTerm' cmp a m n =
proofIrr <- proofIrrelevance
isSize <- isJust <$> isSizeType a'
s <- reduce $ getSort a'
- mlvl <- mlevel
+ mlvl <- tryMaybe primLevel
reportSDoc "tc.conv.level" 60 $ nest 2 $ sep
[ text $ "a' = " ++ show a'
, text $ "mlvl = " ++ show mlvl
@@ -309,7 +297,7 @@ compareTerm' cmp a m n =
-- No subtyping on record terms
c <- getRecordConstructor r
-- Record constructors are covariant (see test/succeed/CovariantConstructors).
- compareArgs (repeat $ polFromCmp cmp) (telePi_ tel $ sort Prop) (Con c []) m' n'
+ compareArgs (repeat $ polFromCmp cmp) (telePi_ tel $ sort Prop) (Con c ConOSystem []) m' n'
else compareAtom cmp a' m n
_ -> compareAtom cmp a' m n
@@ -335,35 +323,24 @@ compareTel t1 t2 cmp tel1 tel2 =
(EmptyTel, EmptyTel) -> return ()
(EmptyTel, _) -> bad
(_, EmptyTel) -> bad
- (ExtendTel dom1@(Dom i1 a1) tel1, ExtendTel dom2@(Dom i2 a2) tel2)
- | getHiding i1 /= getHiding i2 -> bad
- -- Andreas, 2011-09-11 do not test r1 == r2 because they could differ
- -- e.g. one could be Forced and the other Relevant (see fail/UncurryMeta)
- | otherwise -> do
- name <- freshName_ (suggest (absName tel1) (absName tel2))
- let r = max (getRelevance i1) (getRelevance i2) -- take "most irrelevant"
- dependent = (r /= Irrelevant) && isBinderUsed tel2
--- NEW
- pid <- newProblem_ $ compareType cmp a1 a2
- dom <- if dependent
- then Dom i1 <$> blockTypeOnProblem a1 pid
- else return dom1
- addContext (name, dom) $ compareTel t1 t2 cmp (absBody tel1) (absBody tel2)
- stealConstraints pid
+ (ExtendTel dom1@(Dom i1 a1) tel1, ExtendTel dom2@(Dom i2 a2) tel2) -> do
+ compareDom cmp dom1 dom2 tel1 tel2 bad bad $
+ compareTel t1 t2 cmp (absBody tel1) (absBody tel2)
{- OLD, before 2013-05-15
let checkDom = escapeContext 1 $ compareType cmp a1 a2
c = TelCmp t1 t2 cmp (absBody tel1) (absBody tel2)
- addCtx name dom1 $
+ addContext (name, dom1) $
if dependent
then guardConstraint c checkDom
else checkDom >> solveConstraint_ c
-}
where
-- Andreas, 2011-05-10 better report message about types
- bad = typeError $ UnequalTypes cmp t2 t1 -- switch t2 and t1 because of contravariance!
--- bad = typeError $ UnequalTelescopes cmp tel1 tel2
+ bad = typeError $ UnequalTypes cmp t2 t1
+ -- switch t2 and t1 because of contravariance!
+
-- | Raise 'UnequalTerms' if there is no hope that by
@@ -542,13 +519,13 @@ compareAtom cmp t m n =
(Def f es, Def f' es') ->
unlessM (bothAbsurd f f') $ do
trySizeUniv cmp t m n f es f' es'
- (Con x xArgs, Con y yArgs)
+ (Con x ci xArgs, Con y _ yArgs)
| x == y -> do
-- Get the type of the constructor instantiated to the datatype parameters.
a' <- conType x t
-- Constructors are covariant in their arguments
-- (see test/succeed/CovariantConstructors).
- compareArgs (repeat $ polFromCmp cmp) a' (Con x []) xArgs yArgs
+ compareArgs (repeat $ polFromCmp cmp) a' (Con x ci []) xArgs yArgs
_ -> etaInequal cmp t m n -- fixes issue 856 (unsound conversion error)
where
-- Andreas, 2013-05-15 due to new postponement strategy, type can now be blocked
@@ -566,44 +543,64 @@ compareAtom cmp t m n =
patternViolation
maybe impossible return =<< getConType c t
equalFun t1 t2 = case (ignoreSharing t1, ignoreSharing t2) of
- (Pi dom1@(Dom i1 a1@(El a1s a1t)) b1, Pi (Dom i2 a2) b2)
- | argInfoHiding i1 /= argInfoHiding i2 -> typeError $ UnequalHiding t1 t2
- -- Andreas 2010-09-21 compare r1 and r2, but ignore forcing annotations!
- | not (compareRelevance cmp (ignoreForced $ argInfoRelevance i2)
- (ignoreForced $ argInfoRelevance i1))
- -> typeError $ UnequalRelevance cmp t1 t2
- | otherwise -> verboseBracket "tc.conv.fun" 15 "compare function types" $ do
- reportSDoc "tc.conv.fun" 20 $ nest 2 $ vcat
- [ text "t1 =" <+> prettyTCM t1
- , text "t2 =" <+> prettyTCM t2 ]
-
- -- We only need to require a1 == a2 if t2 is a dependent function type.
- -- If it's non-dependent it doesn't matter what we add to the context.
- pid <- newProblem_ $ compareType cmp a2 a1
- dom <- if isBinderUsed b2
- then Dom i1 <$> blockTypeOnProblem a1 pid
- -- then Dom i1 . El a1s <$> blockTermOnProblem (El Inf $ Sort a1s) a1t pid
- else return dom1
- name <- freshName_ (suggest b1 b2)
- addContext (name, dom) $ compareType cmp (absBody b1) (absBody b2)
- stealConstraints pid
- -- Andreas, 2013-05-15 Now, comparison of codomains is not
- -- blocked any more by getting stuck on domains.
- -- Only the domain type in context will be blocked.
+ (Pi dom1 b1, Pi dom2 b2) -> do
+ verboseBracket "tc.conv.fun" 15 "compare function types" $ do
+ reportSDoc "tc.conv.fun" 20 $ nest 2 $ vcat
+ [ text "t1 =" <+> prettyTCM t1
+ , text "t2 =" <+> prettyTCM t2 ]
+ compareDom cmp dom2 dom1 b1 b2 errH errR $
+ compareType cmp (absBody b1) (absBody b2)
+ where
+ errH = typeError $ UnequalHiding t1 t2
+ errR = typeError $ UnequalRelevance cmp t1 t2
-{- OLD
+{- OLD, before 2013-05-15
let checkDom = escapeContext 1 $ compareType cmp a2 a1
conCoDom = TypeCmp cmp (absBody b1) (absBody b2)
-- We only need to require a1 == a2 if t2 is a dependent function type.
-- If it's non-dependent it doesn't matter what we add to the context.
name <- freshName_ (suggest b1 b2)
- addCtx name dom1 $
+ addContext (name, dom1) $
if isBinderUsed b2 -- dependent function type?
then guardConstraint conCoDom checkDom
else checkDom >> solveConstraint_ conCoDom
-}
_ -> __IMPOSSIBLE__
+-- | Check whether @a1 `cmp` a2@ and continue in context extended by @a1@.
+compareDom :: Free c
+ => Comparison -- ^ @cmp@ The comparison direction
+ -> Dom Type -- ^ @a1@ The smaller domain.
+ -> Dom Type -- ^ @a2@ The other domain.
+ -> Abs b -- ^ @b1@ The smaller codomain.
+ -> Abs c -- ^ @b2@ The bigger codomain.
+ -> TCM () -- ^ Continuation if mismatch in 'Hiding'.
+ -> TCM () -- ^ Continuation if mismatch in 'Relevance'.
+ -> TCM () -- ^ Continuation if comparison is successful.
+ -> TCM ()
+compareDom cmp dom1@(Dom i1 a1) dom2@(Dom i2 a2) b1 b2 errH errR cont
+ | getHiding dom1 /= getHiding dom2 = errH
+ -- Andreas 2010-09-21 compare r1 and r2, but ignore forcing annotations!
+ | not $ compareRelevance cmp (ignoreForced $ getRelevance dom1)
+ (ignoreForced $ getRelevance dom2) = errR
+ | otherwise = do
+ let r = max (getRelevance dom1) (getRelevance dom2)
+ -- take "most irrelevant"
+ dependent = (r /= Irrelevant) && isBinderUsed b2
+ pid <- newProblem_ $ compareType cmp a1 a2
+ dom <- if dependent
+ then Dom i1 <$> blockTypeOnProblem a1 pid
+ else return dom1
+ -- We only need to require a1 == a2 if b2 is dependent
+ -- If it's non-dependent it doesn't matter what we add to the context.
+ name <- freshName_ $ suggest b1 b2
+ addContext (name, dom) $ cont
+ stealConstraints pid
+ -- Andreas, 2013-05-15 Now, comparison of codomains is not
+ -- blocked any more by getting stuck on domains.
+ -- Only the domain type in context will be blocked.
+ -- But see issue #1258.
+
compareRelevance :: Comparison -> Relevance -> Relevance -> Bool
compareRelevance CmpEq = (==)
compareRelevance CmpLeq = (<=)
@@ -652,7 +649,7 @@ compareElims pols0 a v els01 els02 = catchConstraint (ElimCmp pols0 a v els01 el
ifBlockedType a (\ m t -> patternViolation) $ \ a -> do
case ignoreSharing . unEl $ a of
(Pi (Dom info b) codom) -> do
- mlvl <- mlevel
+ mlvl <- tryMaybe primLevel
let freeInCoDom (Abs _ c) = 0 `freeInIgnoringSorts` c
freeInCoDom _ = False
dependent = (Just (unEl b) /= mlvl) && freeInCoDom codom
@@ -719,12 +716,12 @@ compareElims pols0 a v els01 els02 = catchConstraint (ElimCmp pols0 a v els01 el
-- __IMPOSSIBLE__
-- case: f == f' are projections
- (Proj f : els1, Proj f' : els2)
+ (Proj o f : els1, Proj _ f' : els2)
| f /= f' -> typeError . GenericError . show =<< prettyTCM f <+> text "/=" <+> prettyTCM f'
| otherwise -> ifBlockedType a (\ m t -> patternViolation) $ \ a -> do
- res <- projectTyped v a f -- fails only if f is proj.like but parameters cannot be retrieved
+ res <- projectTyped v a o f -- fails only if f is proj.like but parameters cannot be retrieved
case res of
- Just (u, t) -> do
+ Just (_, u, t) -> do
-- Andreas, 2015-07-01:
-- The arguments following the principal argument of a projection
-- are invariant. (At least as long as we have no explicit polarity
@@ -766,7 +763,6 @@ compareIrrelevant t v w = do
let rel = getMetaRelevance mv
inst = case mvInstantiation mv of
InstV{} -> True
- InstS{} -> True
_ -> False
reportSDoc "tc.conv.irr" 20 $ vcat
[ nest 2 $ text $ "rel = " ++ show rel
@@ -774,7 +770,10 @@ compareIrrelevant t v w = do
]
if not (irrelevantOrUnused rel) || inst
then fallback
- else assignE DirEq x es w $ compareIrrelevant t
+ -- Andreas, 2016-08-08, issue #2131:
+ -- Mining for solutions for irrelevant metas is not definite.
+ -- Thus, in case of error, leave meta unsolved.
+ else (assignE DirEq x es w $ compareIrrelevant t) `catchError` \ _ -> fallback
-- the value of irrelevant or unused meta does not matter
try v w fallback = fallback
@@ -979,9 +978,11 @@ leqLevel a b = liftTCM $ do
-- See case for `same term` below.
a <- normalise a
b <- normalise b
- catchConstraint (LevelCmp CmpLeq a b) $ leqView a b
+ leqView a b
where
- leqView a@(Max as) b@(Max bs) = do
+ -- Andreas, 2016-09-28
+ -- If we have to postpone a constraint, then its simplified form!
+ leqView a@(Max as) b@(Max bs) = catchConstraint (LevelCmp CmpLeq a b) $ do
reportSDoc "tc.conv.nat" 30 $
text "compareLevelView" <+>
sep [ text (show a) <+> text "=<"
@@ -995,7 +996,11 @@ leqLevel a b = liftTCM $ do
([], _) -> ok
-- as ≤ 0
- (as, []) -> sequence_ [ equalLevel' (Max [a]) (Max []) | a <- as ]
+ (as, []) -> sequence_ [ equalLevel' (Max [a]) (Max []) | a <- as ]
+ (as, [ClosedLevel 0]) -> sequence_ [ equalLevel' (Max [a]) (Max []) | a <- as ]
+ -- Andreas, 2016-09-28, @[ClosedLevel 0]@ is possible if we come from case
+ -- "reduce constants" where we run @subtr@ on both sides.
+ -- See test/Succeed/LevelMetaLeqZero.agda.
-- as ≤ [b]
(as@(_:_:_), [b]) -> sequence_ [ leqView (Max [a]) (Max [b]) | a <- as ]
@@ -1041,11 +1046,14 @@ leqLevel a b = liftTCM $ do
[n] -> n
_ -> __IMPOSSIBLE__
- -- [a] ≤ [neutral]
- ([a@(Plus n _)], [b@(Plus m NeutralLevel{})])
- | m == n -> equalLevel' (Max [a]) (Max [b])
- -- Andreas, 2014-04-07: This call to equalLevel is ok even if we removed
- -- subsumed terms from the lhs.
+ -- Andreas, 2016-09-28: This simplification loses the solution lzero.
+ -- Thus, it is invalid.
+ -- See test/Succeed/LevelMetaLeqNeutralLevel.agda.
+ -- -- [a] ≤ [neutral]
+ -- ([a@(Plus n _)], [b@(Plus m NeutralLevel{})])
+ -- | m == n -> equalLevel' (Max [a]) (Max [b])
+ -- -- Andreas, 2014-04-07: This call to equalLevel is ok even if we removed
+ -- -- subsumed terms from the lhs.
-- anything else
_ -> postpone
diff --git a/src/full/Agda/TypeChecking/Coverage.hs b/src/full/Agda/TypeChecking/Coverage.hs
index 62707f3..72d94cc 100644
--- a/src/full/Agda/TypeChecking/Coverage.hs
+++ b/src/full/Agda/TypeChecking/Coverage.hs
@@ -1,9 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-
-{-# OPTIONS_GHC -fwarn-unused-imports #-}
+{-# LANGUAGE NondecreasingIndentation #-}
{-| Coverage checking, case splitting, and splitting for refine tactics.
@@ -13,9 +9,11 @@ module Agda.TypeChecking.Coverage
( SplitClause(..), clauseToSplitClause, fixTarget
, Covering(..), splitClauses
, coverageCheck
+ , isCovered
, splitClauseWithAbsurd
, splitLast
, splitResult
+ , normaliseProjP
) where
import Prelude hiding (null)
@@ -28,18 +26,23 @@ import Control.Applicative hiding (empty)
#endif
import Data.List hiding (null)
+import Data.Monoid (Any(..))
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Traversable as Trav
import Agda.Syntax.Common
+import Agda.Syntax.Position
+import Agda.Syntax.Literal
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Exception
-import Agda.TypeChecking.Rules.LHS.Problem (flexibleVarFromHiding)
+import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars)
import Agda.TypeChecking.Rules.LHS.Unify
import Agda.TypeChecking.Coverage.Match
@@ -48,10 +51,10 @@ import Agda.TypeChecking.Coverage.SplitTree
import Agda.TypeChecking.Datatypes (getConForm)
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Substitute
-import Agda.TypeChecking.Substitute.Pattern
import Agda.TypeChecking.Reduce
-import Agda.TypeChecking.Records (isRecordType)
+import Agda.TypeChecking.Records
import Agda.TypeChecking.Telescope
+import Agda.TypeChecking.MetaVars
import Agda.Interaction.Options
@@ -64,6 +67,7 @@ import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Tuple
+import Agda.Utils.Lens
#include "undefined.h"
import Agda.Utils.Impossible
@@ -87,6 +91,9 @@ data SplitClause = SClause
-- 'splitResult', which does not split on a variable,
-- should reset it to the identity 'idS', lest it be
-- applied to 'scTarget' again, leading to Issue 1294.
+ , scModuleParameterSub :: ModuleParamDict
+ -- ^ We need to keep track of the module parameter substitutions for the
+ -- clause for the purpose of inferring missing instance clauses.
, scTarget :: Maybe (Arg Type)
-- ^ The type of the rhs, living in context 'scTel'.
-- This invariant is broken before calls to 'fixTarget';
@@ -107,12 +114,13 @@ data Covering = Covering
splitClauses :: Covering -> [SplitClause]
splitClauses (Covering _ qcs) = map snd qcs
--- | Create a split clause from a clause in internal syntax.
+-- | Create a split clause from a clause in internal syntax. Used by make-case.
clauseToSplitClause :: Clause -> SplitClause
clauseToSplitClause cl = SClause
{ scTel = clauseTel cl
, scPats = namedClausePats cl
, scSubst = idS -- Andreas, 2014-07-15 TODO: Is this ok?
+ , scModuleParameterSub = Map.empty
, scTarget = clauseType cl
}
@@ -125,13 +133,22 @@ coverageCheck f t cs = do
let -- n = arity
-- xs = variable patterns fitting lgamma
n = size gamma
- xs = teleNamedArgs gamma
+ xs = map (setOrigin Inserted) $ teleNamedArgs gamma
+ -- The initial module parameter substitutions need to be weakened by the
+ -- number of arguments that aren't module parameters.
+ fv <- getDefFreeVars f
+ moduleParams <- raise (n - fv) <$> use stModuleParameters
-- construct the initial split clause
- sc = SClause gamma xs idS $ Just $ defaultArg a
- reportSDoc "tc.cover.top" 10 $ vcat
- [ text $ "Coverage checking " ++ show f
- , nest 2 $ vcat $ map (text . show . clausePats) cs
- ]
+ let sc = SClause gamma xs idS moduleParams $ Just $ defaultArg a
+
+ reportSDoc "tc.cover.top" 10 $ do
+ let prCl cl = addContext (clauseTel cl) $
+ prettyTCMPatternList $ namedClausePats cl
+ vcat
+ [ text $ "Coverage checking " ++ show f ++ " with patterns:"
+ , nest 2 $ vcat $ map prCl cs
+ ]
+
-- used = actually used clauses for cover
-- pss = uncovered cases
(splitTree, used, pss) <- cover f cs sc
@@ -142,39 +159,49 @@ coverageCheck f t cs = do
-- report an error if there are uncovered cases
unless (null pss) $
setCurrentRange cs $
- typeError $ CoverageFailure f (map (map (fmap namedThing)) pss)
+ typeError $ CoverageFailure f pss
-- is = indices of unreachable clauses
let is = Set.toList $ Set.difference (Set.fromList [0..genericLength cs - 1]) used
-- report an error if there are unreachable clauses
unless (null is) $ do
let unreached = map (cs !!) is
setCurrentRange unreached $
- typeError $ UnreachableClauses f (map clausePats unreached)
+ typeError $ UnreachableClauses f $ map namedClausePats unreached
return splitTree
+-- | Top-level function for eliminating redundant clauses in the interactive
+-- case splitter
+isCovered :: QName -> [Clause] -> SplitClause -> TCM Bool
+isCovered f cs sc = do
+ (_, _, missing) <- cover f cs sc
+ return $ null missing
-- | @cover f cs (SClause _ _ ps _) = return (splitTree, used, pss)@.
-- checks that the list of clauses @cs@ covers the given split clause.
-- Returns the @splitTree@, the @used@ clauses, and missing cases @pss@.
cover :: QName -> [Clause] -> SplitClause ->
TCM (SplitTree, Set Nat, [[NamedArg DeBruijnPattern]])
-cover f cs sc@(SClause tel ps _ target) = do
+cover f cs sc@(SClause tel ps _ _ target) = do
reportSDoc "tc.cover.cover" 10 $ vcat
[ text "checking coverage of pattern:"
, nest 2 $ text "tel =" <+> prettyTCM tel
- , nest 2 $ text "ps =" <+> text (show ps)
+ , nest 2 $ text "ps =" <+> do addContext tel $ prettyTCMPatternList ps
]
- let ups = map (fmap namedThing) ps
exactSplitEnabled <- optExactSplit <$> pragmaOptions
- case match cs ups of
- Yes (i,mps)
- | not exactSplitEnabled || (clauseCatchall (cs !! i) || all isTrivialMPattern mps)
+ cs' <- normaliseProjP cs
+ case match cs' ps of
+ Yes (i,(mps,ls0))
+ | not exactSplitEnabled || (clauseCatchall (cs !! i) || all isTrivialPattern mps)
-> do
reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++ show i
-- Check if any earlier clauses could match with appropriate literals
- let is = [ j | (j, c) <- zip [0..i-1] cs, matchLits c ups ]
- reportSLn "tc.cover.cover" 10 $ "literal matches: " ++ show is
- return (SplittingDone (size tel), Set.fromList (i : is), [])
+ let lsis = mapMaybe (\(j,c) -> (,j) <$> matchLits c ps) $ zip [0..i-1] cs
+ reportSLn "tc.cover.cover" 10 $ "literal matches: " ++ show lsis
+ -- Andreas, 2016-10-08, issue #2243 (#708)
+ -- If we have several literal matches with the same literals
+ -- only take the first matching clause of these.
+ let is = Map.elems $ Map.fromListWith min $ (ls0,i) : lsis
+ return (SplittingDone (size tel), Set.fromList is, [])
| otherwise -> do
reportSDoc "tc.cover.cover" 10 $ vcat
@@ -186,25 +213,24 @@ cover f cs sc@(SClause tel ps _ target) = do
No -> do
reportSLn "tc.cover" 20 $ "pattern is not covered"
- return (SplittingDone (size tel), Set.empty, [ps])
+ case fmap getHiding target of
+ Just h | h == Instance -> do
+ -- Ulf, 2016-10-31: For now we only infer instance clauses. It would
+ -- make sense to do it also for hidden, but since the value of a
+ -- hidden clause is expected to be forced by later clauses, it's too
+ -- late to add it now. If it was inferrable we would have gotten a
+ -- type error before getting to this point.
+ inferMissingClause f sc
+ return (SplittingDone (size tel), Set.empty, [])
+ _ -> return (SplittingDone (size tel), Set.empty, [ps])
- -- case: split into projection patterns
- BlockP -> do
- reportSLn "tc.cover" 20 $ "blocked by projection pattern"
- -- if we want to split projections, but have no target type, we give up
+ -- We need to split!
+ -- If all clauses have an unsplit copattern, we try that first.
+ Block res bs -> tryIf (getAny res) splitRes $ do
let done = return (SplittingDone (size tel), Set.empty, [ps])
- caseMaybeM (splitResult f sc) done $ \ (Covering n scs) -> do
- (projs, (trees, useds, psss)) <- mapSnd unzip3 . unzip <$> do
- mapM (traverseF $ cover f cs <=< (snd <.> fixTarget)) scs
- -- OR:
- -- forM scs $ \ (proj, sc') -> (proj,) <$> do
- -- cover f cs =<< do
- -- snd <$> fixTarget sc'
- let tree = SplitAt n $ zip projs trees
- return (tree, Set.unions useds, concat psss)
-
- -- case: split on variable
- Block bs -> do
+ if null bs then done else do
+ -- Otherwise, if there are variables to split, we try them
+ -- in the order determined by a split strategy.
reportSLn "tc.cover.strategy" 20 $ "blocking vars = " ++ show bs
-- xs is a non-empty lists of blocking variables
-- try splitting on one of them
@@ -234,53 +260,88 @@ cover f cs sc@(SClause tel ps _ target) = do
, nest 2 $ vcat
[ text "n = " <+> text (show n)
, text "scs = " <+> prettyTCM scs
- , text "ups = " <+> text (show ups)
+ , text "ps = " <+> text (show ps)
]
]
- let trees' = zipWith (etaRecordSplits (unArg n) ups) scs trees
+ let trees' = zipWith (etaRecordSplits (unArg n) ps) scs trees
tree = SplitAt n trees'
return (tree, Set.unions useds, concat psss)
where
+ tryIf :: Monad m => Bool -> m (Maybe a) -> m a -> m a
+ tryIf True me m = fromMaybeM m me
+ tryIf False me m = m
+
+ -- Try to split result
+ splitRes :: TCM (Maybe (SplitTree, Set Nat, [[NamedArg DeBruijnPattern]]))
+ splitRes = do
+ reportSLn "tc.cover" 20 $ "blocked by projection pattern"
+ -- forM is a monadic map over a Maybe here
+ mcov <- splitResult f sc
+ Trav.forM mcov $ \ (Covering n scs) -> do
+ -- If result splitting was successful, continue coverage checking.
+ (projs, (trees, useds, psss)) <- mapSnd unzip3 . unzip <$> do
+ mapM (traverseF $ cover f cs <=< (snd <.> fixTarget)) scs
+ -- OR:
+ -- forM scs $ \ (proj, sc') -> (proj,) <$> do
+ -- cover f cs =<< do
+ -- snd <$> fixTarget sc'
+ let tree = SplitAt n $ zip projs trees
+ return (tree, Set.unions useds, concat psss)
+
gatherEtaSplits :: Int -> SplitClause
- -> [Arg DeBruijnPattern] -> [Arg DeBruijnPattern]
+ -> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
gatherEtaSplits n sc []
| n >= 0 = __IMPOSSIBLE__ -- we should have encountered the main
-- split by now already
| otherwise = []
- gatherEtaSplits n sc (p:ps) = case unArg p of
- VarP (i,_)
- | n == 0 -> case lookupS (scSubst sc) i of -- this is the main split
+ gatherEtaSplits n sc (p:ps) = case namedArg p of
+ VarP x
+ | n == 0 -> case p' of -- this is the main split
VarP _ -> __IMPOSSIBLE__
DotP _ -> __IMPOSSIBLE__
- ConP _ _ qs ->
- map (fmap namedThing) qs ++ gatherEtaSplits (-1) sc ps
+ ConP _ _ qs -> qs ++ gatherEtaSplits (-1) sc ps
LitP _ -> __IMPOSSIBLE__
- ProjP _ -> __IMPOSSIBLE__
+ ProjP{} -> __IMPOSSIBLE__
| otherwise ->
- (p $> lookupS (scSubst sc) i) : gatherEtaSplits (n-1) sc ps
+ updateNamedArg (\ _ -> p') p : gatherEtaSplits (n-1) sc ps
+ where p' = lookupS (scSubst sc) $ dbPatVarIndex x
DotP _ -> p : gatherEtaSplits (n-1) sc ps -- count dot patterns
- ConP _ _ qs -> gatherEtaSplits n sc (map (fmap namedThing) qs ++ ps)
+ ConP _ _ qs -> gatherEtaSplits n sc (qs ++ ps)
LitP _ -> gatherEtaSplits n sc ps
- ProjP _ -> gatherEtaSplits n sc ps
+ ProjP{} -> gatherEtaSplits n sc ps
- addEtaSplits :: Int -> [Arg DeBruijnPattern] -> SplitTree -> SplitTree
+ addEtaSplits :: Int -> [NamedArg DeBruijnPattern] -> SplitTree -> SplitTree
addEtaSplits k [] t = t
- addEtaSplits k (p:ps) t = case unArg p of
+ addEtaSplits k (p:ps) t = case namedArg p of
VarP _ -> addEtaSplits (k+1) ps t
DotP _ -> addEtaSplits (k+1) ps t
- ConP c cpi nqs ->
- let qs = map (fmap namedThing) nqs
- t' = [(conName c , addEtaSplits k (qs ++ ps) t)]
- in SplitAt (p $> k) t'
+ ConP c cpi qs -> SplitAt (p $> k) [(conName c , addEtaSplits k (qs ++ ps) t)]
LitP _ -> __IMPOSSIBLE__
- ProjP _ -> __IMPOSSIBLE__
+ ProjP{} -> __IMPOSSIBLE__
- etaRecordSplits :: Int -> [Arg DeBruijnPattern] -> (QName,SplitClause)
+ etaRecordSplits :: Int -> [NamedArg DeBruijnPattern] -> (QName,SplitClause)
-> SplitTree -> (QName,SplitTree)
etaRecordSplits n ps (q , sc) t =
(q , addEtaSplits 0 (gatherEtaSplits n sc ps) t)
+inferMissingClause :: QName -> SplitClause -> TCM ()
+inferMissingClause f (SClause tel ps _ mpsub (Just t)) = setCurrentRange f $ do
+ reportSDoc "tc.cover.infer" 20 $ addContext tel $ text "Trying to infer right-hand side of type" <+> prettyTCM t
+ cl <- addContext tel $ withModuleParameters mpsub $ do
+ (x, rhs) <- case getHiding t of
+ Instance -> newIFSMeta "" (unArg t)
+ Hidden -> __IMPOSSIBLE__
+ NotHidden -> __IMPOSSIBLE__
+ return $ Clause { clauseRange = noRange
+ , clauseTel = tel
+ , namedClausePats = ps
+ , clauseBody = Just rhs
+ , clauseType = Just t
+ , clauseCatchall = False }
+ addClauses f [cl]
+inferMissingClause _ (SClause _ _ _ _ Nothing) = __IMPOSSIBLE__
+
splitStrategy :: BlockingVars -> Telescope -> TCM BlockingVars
splitStrategy bs tel = return $ updateLast clearBlockingVarCons xs
-- Make sure we do not insists on precomputed coverage when
@@ -335,26 +396,31 @@ isDatatype ind at = do
-- if target becomes a function type.
-- Returns the domains of the function type (if any).
fixTarget :: SplitClause -> TCM (Telescope, SplitClause)
-fixTarget sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scTarget = target } =
+fixTarget sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scModuleParameterSub = mpsub, scTarget = target } =
caseMaybe target (return (empty, sc)) $ \ a -> do
reportSDoc "tc.cover.target" 20 $ sep
[ text "split clause telescope: " <+> prettyTCM sctel
- , text "old patterns : " <+> sep (map (prettyTCM . namedArg) ps)
- , text "substitution : " <+> text (show sigma)
+ , text "old patterns : " <+> do
+ addContext sctel $ prettyTCMPatternList ps
+ ]
+ reportSDoc "tc.cover.target" 60 $ sep
+ [ text "substitution : " <+> text (show sigma)
]
reportSDoc "tc.cover.target" 30 $ sep
[ text "target type before substitution (variables may be wrong): " <+> do
addContext sctel $ prettyTCM a
]
TelV tel b <- telView $ applyPatSubst sigma $ unArg a
- reportSDoc "tc.cover.target" 10 $ sep
+ reportSDoc "tc.cover.target" 15 $ sep
[ text "target type telescope (after substitution): " <+> do
addContext sctel $ prettyTCM tel
, text "target type core (after substitution): " <+> do
addContext sctel $ addContext tel $ prettyTCM b
]
let n = size tel
- xs = teleNamedArgs tel
+ -- Andreas, 2016-10-04 issue #2236
+ -- Need to set origin to "Inserted" to avoid printing of hidden patterns.
+ xs = map (setOrigin Inserted) $ teleNamedArgs tel
-- Compute new split clause
sctel' = telFromList $ telToList (raise n sctel) ++ telToList tel
-- Dot patterns in @ps@ need to be raised! (Issue 1298)
@@ -365,6 +431,7 @@ fixTarget sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scTarget = ta
, scPats = ps'
, scSubst = wkS n $ sigma -- Should be wkS instead of liftS since
-- variables are only added to new tel.
+ , scModuleParameterSub = applySubst (raiseS n) mpsub
, scTarget = newTarget
}
-- Separate debug printing to find cause of crash (Issue 1374)
@@ -372,9 +439,10 @@ fixTarget sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scTarget = ta
[ text "new split clause telescope : " <+> prettyTCM sctel'
]
reportSDoc "tc.cover.target" 30 $ sep
- [ text "new split clause patterns : " <+> sep (map (prettyTCM . namedArg) ps')
+ [ text "new split clause patterns : " <+> do
+ addContext sctel' $ prettyTCMPatternList ps'
]
- reportSDoc "tc.cover.target" 30 $ sep
+ reportSDoc "tc.cover.target" 60 $ sep
[ text "new split clause substitution: " <+> text (show $ scSubst sc')
]
reportSDoc "tc.cover.target" 30 $ sep
@@ -387,7 +455,7 @@ fixTarget sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scTarget = ta
]
return $ if n == 0 then (empty, sc { scTarget = newTarget }) else (tel, sc')
--- | @computeNeighbourhood delta1 delta2 d pars ixs hix hps con@
+-- | @computeNeighbourhood delta1 delta2 d pars ixs hix tel ps mpsub con@
--
-- @
-- delta1 Telescope before split point
@@ -397,7 +465,9 @@ fixTarget sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scTarget = ta
-- pars Data type parameters
-- ixs Data type indices
-- hix Index of split variable
+-- tel Telescope for patterns ps
-- ps Patterns before doing the split
+-- mpsub Current module parameter substitutions
-- con Constructor to fit into hole
-- @
-- @dtype == d pars ixs@
@@ -409,10 +479,12 @@ computeNeighbourhood
-> Args -- ^ Data type parameters.
-> Args -- ^ Data type indices.
-> Nat -- ^ Index of split variable.
- -> [NamedArg DeBruijnPattern] -- ^ Patterns before doing the split.
+ -> Telescope -- ^ Telescope for the patterns.
+ -> [NamedArg DeBruijnPattern] -- ^ Patterns before doing the split.
+ -> ModuleParamDict -- ^ Current module parameter substitution.
-> QName -- ^ Constructor to fit into hole.
-> CoverM (Maybe SplitClause) -- ^ New split clause if successful.
-computeNeighbourhood delta1 n delta2 d pars ixs hix ps c = do
+computeNeighbourhood delta1 n delta2 d pars ixs hix tel ps mpsub c = do
-- Get the type of the datatype
dtype <- liftTCM $ (`piApply` pars) . defType <$> getConstInfo d
@@ -423,7 +495,7 @@ computeNeighbourhood delta1 n delta2 d pars ixs hix ps c = do
-- Andreas, 2013-11-29 changes nothing!
{-
con <- conSrcCon . theDef <$> getConstInfo con
- Con con [] <- liftTCM $ ignoreSharing <$> (constructorForm =<< normalise (Con con []))
+ Con con ci [] <- liftTCM $ ignoreSharing <$> (constructorForm =<< normalise (Con con ci []))
-}
-- Get the type of the constructor
@@ -444,21 +516,19 @@ computeNeighbourhood delta1 n delta2 d pars ixs hix ps c = do
preserve p = p
gammal = map (fmap preserve) . telToList $ gamma0
gamma = telFromList gammal
+ delta1Gamma = delta1 `abstract` gamma
- debugInit con ctype d pars ixs cixs delta1 delta2 gamma ps hix
+ debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix
-- All variables are flexible
- -- let flex = [0..size delta1 + size gamma - 1]
- let gammaDelta1 = gammal ++ telToList delta1
- makeFlex i d = flexibleVarFromHiding (getHiding d) i
- flex = zipWith makeFlex [0..] gammaDelta1
+ let flex = allFlexVars delta1Gamma
-- Unify constructor target and given type (in Δ₁Γ)
let conIxs = drop (size pars) cixs
givenIxs = raise (size gamma) ixs
r <- unifyIndices
- (delta1 `abstract` gamma)
+ delta1Gamma
flex
(raise (size gamma) dtype)
conIxs
@@ -470,7 +540,7 @@ computeNeighbourhood delta1 n delta2 d pars ixs hix ps c = do
DontKnow{} -> do
debugCantSplit
throwException $ CantSplit (conName con) (delta1 `abstract` gamma) conIxs givenIxs
- Unifies (delta1',rho0) -> do
+ Unifies (delta1',rho0,_) -> do
debugSubst "rho0" rho0
-- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ
@@ -479,7 +549,9 @@ computeNeighbourhood delta1 n delta2 d pars ixs hix ps c = do
-- Andreas, 2015-05-01 I guess it is fine to use @noConPatternInfo@
-- as the result of splitting is never used further down the pipeline.
-- After splitting, Agda reloads the file.
- let conp = ConP con noConPatternInfo $ applySubst rho2 $ teleNamedArgs gamma
+ let conp = ConP con noConPatternInfo $ applySubst rho2 $
+ map (setOrigin Inserted) $ tele2NamedArgs gamma0 gamma
+ -- Andreas, 2016-09-08, issue #2166: use gamma0 for correct argument names
-- Compute final context and substitution
let rho3 = consS conp rho1 -- Δ₁' ⊢ ρ₃ : Δ₁(x:D)
@@ -489,26 +561,29 @@ computeNeighbourhood delta1 n delta2 d pars ixs hix ps c = do
debugTel "delta'" delta'
debugSubst "rho" rho
+ addContext tel $ debugPs ps
-- Apply the substitution
let ps' = applySubst rho ps
- debugPlugged ps ps'
+ addContext delta' $ debugPlugged ps'
- return $ Just $ SClause delta' ps' rho Nothing -- target fixed later
+ let mpsub' = applySubst (fromPatternSubstitution rho) mpsub
+
+ return $ Just $ SClause delta' ps' rho mpsub' Nothing -- target fixed later
where
- debugInit con ctype d pars ixs cixs delta1 delta2 gamma hps hix =
+ debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix =
liftTCM $ reportSDoc "tc.cover.split.con" 20 $ vcat
[ text "computeNeighbourhood"
, nest 2 $ vcat
[ text "context=" <+> (inTopContext . prettyTCM =<< getContextTelescope)
, text "con =" <+> prettyTCM con
, text "ctype =" <+> prettyTCM ctype
- , text "hps =" <+> text (show hps)
+ , text "ps =" <+> do addContext tel $ prettyTCMPatternList ps
, text "d =" <+> prettyTCM d
, text "pars =" <+> prettyList (map prettyTCM pars)
- , text "ixs =" <+> addCtxTel delta1 (prettyList (map prettyTCM ixs))
- , text "cixs =" <+> do addCtxTel gamma $ prettyList (map prettyTCM cixs)
+ , text "ixs =" <+> addContext delta1 (prettyList (map prettyTCM ixs))
+ , text "cixs =" <+> do addContext gamma $ prettyList (map prettyTCM cixs)
, text "delta1 =" <+> prettyTCM delta1
, text "delta2 =" <+> prettyTCM delta2
, text "gamma =" <+> prettyTCM gamma
@@ -532,21 +607,14 @@ computeNeighbourhood delta1 n delta2 d pars ixs hix ps c = do
[ text (s ++ " =") <+> prettyTCM tel
]
- debugShow s x =
- liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat
- [ text (s ++ " =") <+> text (show x)
- ]
-
- debugPlugged ps ps' =
+ debugPs ps =
liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat
- [ text "ps =" <+> text (show ps)
- , text "ps' =" <+> text (show ps')
+ [ text "ps =" <+> prettyTCMPatternList ps
]
- debugFinal tel ps =
+ debugPlugged ps' =
liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat
- [ text "rtel =" <+> prettyTCM tel
- , text "rps =" <+> text (show ps)
+ [ text "ps' =" <+> do prettyTCMPatternList ps'
]
-- | Entry point from @Interaction.MakeCase@.
@@ -561,7 +629,7 @@ splitClauseWithAbsurd c x = split' Inductive False c (BlockingVar x Nothing)
splitLast :: Induction -> Telescope -> [NamedArg DeBruijnPattern] -> TCM (Either SplitError Covering)
splitLast ind tel ps = split ind sc (BlockingVar 0 Nothing)
- where sc = SClause tel ps __IMPOSSIBLE__ Nothing
+ where sc = SClause tel ps empty empty Nothing
-- | @split ind splitClause x = return res@
-- splits @splitClause@ at pattern var @x@ (de Bruijn index).
@@ -595,7 +663,8 @@ lookupPatternVar SClause{ scTel = tel, scPats = pats } x = arg $>
if n < 0 then __IMPOSSIBLE__ else n
where n = if k < 0
then __IMPOSSIBLE__
- else fromMaybe __IMPOSSIBLE__ $ permPicks (dbPatPerm pats) !!! k
+ else fromMaybe __IMPOSSIBLE__ $ permPicks perm !!! k
+ perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm pats
k = size tel - x - 1
arg = telVars (size tel) tel !! k
@@ -622,9 +691,9 @@ split' :: Induction
-> SplitClause
-> BlockingVar
-> TCM (Either SplitError (Either SplitClause Covering))
-split' ind fixtarget sc@(SClause tel ps _ target) (BlockingVar x mcons) = liftTCM $ runExceptionT $ do
+split' ind fixtarget sc@(SClause tel ps _ mpsub target) (BlockingVar x mcons) = liftTCM $ runExceptionT $ do
- debugInit tel x ps
+ debugInit tel x ps mpsub
-- Split the telescope at the variable
-- t = type of the variable, Δ₁ ⊢ t
@@ -641,19 +710,24 @@ split' ind fixtarget sc@(SClause tel ps _ target) (BlockingVar x mcons) = liftTC
ns <- catMaybes <$> do
forM cons $ \ con ->
fmap (con,) <$> do
- msc <- computeNeighbourhood delta1 n delta2 d pars ixs x ps con
+ msc <- computeNeighbourhood delta1 n delta2 d pars ixs x tel ps mpsub con
if not fixtarget then return msc else do
Trav.forM msc $ \ sc -> lift $ snd <$> fixTarget sc{ scTarget = target }
case ns of
[] -> do
- let ps' = (fmap . fmap . fmap . fmap) (\(y,name) -> if (x==y) then (y,"()") else (y,name)) ps
+ let ps' = (fmap . fmap . fmap . fmap)
+ (\(DBPatVar name y) -> if (x==y)
+ then DBPatVar absurdPatternName y
+ else DBPatVar name y)
+ ps
return $ Left $ SClause
{ scTel = telFromList $ telToList delta1 ++
[fmap ((,) "()") t] ++ -- add name "()"
telToList delta2
, scPats = ps
, scSubst = idS -- not used anyway
+ , scModuleParameterSub = __IMPOSSIBLE__ -- not used
, scTarget = Nothing -- not used
}
@@ -681,19 +755,20 @@ split' ind fixtarget sc@(SClause tel ps _ target) (BlockingVar x mcons) = liftTC
where
inContextOfT :: MonadTCM tcm => tcm a -> tcm a
- inContextOfT = addCtxTel tel . escapeContext (x + 1)
+ inContextOfT = addContext tel . escapeContext (x + 1)
inContextOfDelta2 :: MonadTCM tcm => tcm a -> tcm a
- inContextOfDelta2 = addCtxTel tel . escapeContext x
+ inContextOfDelta2 = addContext tel . escapeContext x
-- Debug printing
- debugInit tel x ps =
- liftTCM $ reportSDoc "tc.cover.top" 10 $ vcat
+ debugInit tel x ps mpsub = liftTCM $ do
+ reportSDoc "tc.cover.top" 10 $ vcat
[ text "TypeChecking.Coverage.split': split"
, nest 2 $ vcat
[ text "tel =" <+> prettyTCM tel
, text "x =" <+> text (show x)
- , text "ps =" <+> text (show ps)
+ , text "ps =" <+> do addContext tel $ prettyTCMPatternList ps
+ , text "mpsub =" <+> prettyTCM mpsub
]
]
@@ -713,7 +788,7 @@ split' ind fixtarget sc@(SClause tel ps _ target) (BlockingVar x mcons) = liftTC
-- otherwise @res == Nothing@.
-- Note that the empty set of split clauses is returned if the record has no fields.
splitResult :: QName -> SplitClause -> TCM (Maybe Covering)
-splitResult f sc@(SClause tel ps _ target) = do
+splitResult f sc@(SClause tel ps _ _ target) = do
reportSDoc "tc.cover.split" 10 $ vcat
[ text "splitting result:"
, nest 2 $ text "f =" <+> text (show f)
@@ -722,33 +797,36 @@ splitResult f sc@(SClause tel ps _ target) = do
-- if we want to split projections, but have no target type, we give up
let done = return Nothing
caseMaybe target done $ \ t -> do
- isR <- addCtxTel tel $ isRecordType $ unArg t
+ isR <- addContext tel $ isRecordType $ unArg t
case isR of
Just (_r, vs, Record{ recFields = fs }) -> do
reportSDoc "tc.cover" 20 $ sep
[ text $ "we are of record type _r = " ++ show _r
- , text "applied to parameters vs = " <+> (addCtxTel tel $ prettyTCM vs)
+ , text "applied to parameters vs = " <+> (addContext tel $ prettyTCM vs)
, text $ "and have fields fs = " ++ show fs
]
- fvs <- freeVarsToApply f
let es = patternsToElims ps
- let self = defaultArg $ Def f (map Apply fvs) `applyE` es
+ -- Note: module parameters are part of ps
+ let self = defaultArg $ Def f [] `applyE` es
pargs = vs ++ [self]
reportSDoc "tc.cover" 20 $ sep
- [ text "we are self = " <+> (addCtxTel tel $ prettyTCM $ unArg self)
+ [ text "we are self = " <+> (addContext tel $ prettyTCM $ unArg self)
]
- let n = defaultArg $ permRange (dbPatPerm ps)
+ let n = defaultArg $ permRange $ fromMaybe __IMPOSSIBLE__ $ dbPatPerm ps
-- Andreas & James, 2013-11-19 includes the dot patterns!
-- See test/succeed/CopatternsAndDotPatterns.agda for a case with dot patterns
-- and copatterns which fails for @n = size tel@ with a broken case tree.
+ -- Andreas, 2016-07-22 read the style of projections from the user's lips
+ projOrigin <- ifM (optPostfixProjections <$> pragmaOptions) (return ProjPostfix) (return ProjPrefix)
Just . Covering n <$> do
forM fs $ \ proj -> do
-- compute the new target
dType <- defType <$> do getConstInfo $ unArg proj -- WRONG: typeOfConst $ unArg proj
let -- type of projection instantiated at self
- target' = Just $ proj $> dType `piApply` pargs
- sc' = sc { scPats = scPats sc ++ [fmap (Named Nothing . ProjP) proj]
+ target' = Just $ proj $> dType `piApply` pargs -- Always visible (#2287)
+ projArg = fmap (Named Nothing . ProjP projOrigin) $ setHiding NotHidden proj
+ sc' = sc { scPats = scPats sc ++ [projArg]
, scSubst = idS
, scTarget = target'
}
@@ -759,13 +837,14 @@ splitResult f sc@(SClause tel ps _ target) = do
-- | For debugging only.
instance PrettyTCM SplitClause where
- prettyTCM (SClause tel pats sigma target) = sep
+ prettyTCM (SClause tel pats sigma mpsub target) = sep
[ text "SplitClause"
, nest 2 $ vcat
- [ text "tel = " <+> prettyTCM tel
- , text "pats = " <+> sep (map (prettyTCM . namedArg) pats)
- , text "subst = " <+> (text . show) sigma
- , text "target = " <+> do
+ [ text "tel =" <+> prettyTCM tel
+ , text "pats =" <+> sep (map (prettyTCM . namedArg) pats)
+ , text "subst =" <+> (text . show) sigma
+ , text "mpsub =" <+> prettyTCM mpsub
+ , text "target =" <+> do
caseMaybe target empty $ \ t -> do
addContext tel $ prettyTCM t
-- Triggers crash (see Issue 1374).
diff --git a/src/full/Agda/TypeChecking/Coverage/Match.hs b/src/full/Agda/TypeChecking/Coverage/Match.hs
index 6c55b6c..6ba5c95 100644
--- a/src/full/Agda/TypeChecking/Coverage/Match.hs
+++ b/src/full/Agda/TypeChecking/Coverage/Match.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Coverage.Match where
@@ -8,8 +6,8 @@ import Control.Applicative
import Control.Monad.State
import qualified Data.List as List
-import Data.Maybe (mapMaybe)
-import Data.Monoid
+import Data.Maybe (mapMaybe, isJust)
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat, Any(..))
import Data.Traversable (traverse)
import Agda.Syntax.Abstract (IsProjP(..))
@@ -18,6 +16,8 @@ import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern ()
import Agda.Syntax.Literal
+import Agda.TypeChecking.Substitute
+
import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.List
@@ -40,11 +40,9 @@ We try to split on this column first.
-}
-- | Match the given patterns against a list of clauses
-match :: [Clause] -> [Arg DeBruijnPattern] -> Match (Nat,[MPat])
+match :: [Clause] -> [NamedArg DeBruijnPattern] -> Match (Nat,([DeBruijnPattern],[Literal]))
match cs ps = foldr choice No $ zipWith matchIt [0..] cs
where
- mps = buildMPatterns ps
-
-- If liberal matching on literals fails or blocks we go with that.
-- If it succeeds we use the result from conservative literal matching.
-- This is to make sure that we split enough when literals are involved.
@@ -53,57 +51,46 @@ match cs ps = foldr choice No $ zipWith matchIt [0..] cs
-- f (c :: s) = ...
-- would never split the tail of the list if we only used conservative
-- literal matching.
- matchIt i c = matchClause yesMatchLit mps i c +++
- matchClause noMatchLit mps i c
-
- Yes _ +++ m = m
- No +++ _ = No
- Block x +++ _ = Block x
- BlockP +++ _ = BlockP
-
--- | We use a special representation of the patterns we're trying to match
--- against a clause. In particular we want to keep track of which variables
--- are blocking a match.
-data MPat
- = VarMP Nat -- ^ De Bruijn index (usually, rightmost variable in patterns is 0).
- | ConMP ConHead (Maybe ConPOrigin) [Arg MPat]
- | LitMP Literal
- | DotMP MPat -- ^ For keeping track of the original dot positions.
- | WildMP -- ^ For dot patterns that cannot be turned into patterns.
- | ProjMP QName -- ^ Projection copattern.
- deriving (Show)
-
-buildMPatterns :: [Arg DeBruijnPattern] -> [Arg MPat]
-buildMPatterns ps = map (fmap build) ps
- where
- build (VarP (i,_)) = VarMP i
- build (ConP con i ps) = ConMP con (conPRecord i) $ buildMPatterns $ map (fmap namedThing) $ ps
- build (DotP t) = DotMP $ buildT t
- build (LitP l) = LitMP l
- build (ProjP dest) = ProjMP dest
-
- buildT (Con c args) = ConMP c Nothing $ map (fmap buildT) args
- buildT (Var i []) = VarMP i
- buildT (Shared p) = buildT (derefPtr p)
- buildT _ = WildMP
-
-isTrivialMPattern :: MPat -> Bool
-isTrivialMPattern VarMP{} = True
-isTrivialMPattern (ConMP c (Just _) ps) = all isTrivialMPattern $ map unArg ps
-isTrivialMPattern (ConMP c Nothing ps) = False
-isTrivialMPattern LitMP{} = False
-isTrivialMPattern DotMP{} = True
-isTrivialMPattern WildMP{} = True
-isTrivialMPattern ProjMP{} = False -- or True?
+ matchIt i c = (i,) <$>
+ matchClause yesMatchLit ps i c +++
+ matchClause noMatchLit ps i c
+
+ Yes _ +++ m = m
+ No +++ _ = No
+ m@Block{} +++ _ = m
+
+-- | Convert the root of a term into a pattern constructor, if possible.
+buildPattern :: Term -> Maybe DeBruijnPattern
+buildPattern (Con c ci args) = Just $
+ ConP c (toConPatternInfo ci) $ map (fmap $ unnamed . DotP) args
+buildPattern (Var i []) = Just $ deBruijnVar i
+buildPattern (Shared p) = buildPattern (derefPtr p)
+buildPattern _ = Nothing
+
+-- | A pattern that matches anything (modulo eta).
+isTrivialPattern :: Pattern' a -> Bool
+isTrivialPattern p = case p of
+ VarP{} -> True
+ DotP{} -> True
+ ConP c i ps -> isJust (conPRecord i) && all (isTrivialPattern . namedArg) ps
+ LitP{} -> False
+ ProjP{} -> False
+
+-- | If matching succeeds, we return the instantiation of the clause pattern vector
+-- to obtain the split clause pattern vector, plus the literals of the clause patterns
+-- matched against split clause variables.
+type MatchResult = Match ([DeBruijnPattern],[Literal])
-- | If matching is inconclusive (@Block@) we want to know which
-- variables are blocking the match.
data Match a
- = Yes a -- ^ Matches unconditionally.
- | No -- ^ Definitely does not match.
- | Block BlockingVars -- ^ Could match if non-empty list of blocking variables
- -- is instantiated properly.
- | BlockP -- ^ Could match if split on possible projections is performed.
+ = Yes a -- ^ Matches unconditionally.
+ | No -- ^ Definitely does not match.
+ | Block Any BlockingVars
+ -- ^ Could match if non-empty list of blocking variables
+ -- is instantiated properly.
+ -- Also 'Any' is 'True' if all clauses have a result split.
+ -- (Only then can we do result splitting.)
deriving (Functor)
-- | Variable blocking a match.
@@ -120,6 +107,7 @@ data BlockingVar = BlockingVar
} deriving (Show)
type BlockingVars = [BlockingVar]
+-- | Lens for 'blockingVarCons'.
mapBlockingVarCons :: (Maybe [ConHead] -> Maybe [ConHead]) -> BlockingVar -> BlockingVar
mapBlockingVarCons f b = b { blockingVarCons = f (blockingVarCons b) }
@@ -144,64 +132,106 @@ zipBlockingVars xs ys = map upd xs
-- It is left-strict, to be used with @foldr@.
-- If one clause unconditionally matches ('Yes') we do not look further.
choice :: Match a -> Match a -> Match a
-choice (Yes a) _ = Yes a
-choice (Block x) (Block y) = Block (zipBlockingVars x y)
-choice (Block x) (Yes _) = Block $ overlapping x
-choice (Block x) _ = Block x
-choice BlockP m = BlockP
-choice No m = m
-
-type MatchLit = Literal -> MPat -> Match [MPat]
+choice (Yes a) _ = Yes a
+choice (Block r xs) (Block s ys) = Block (Any $ getAny r && getAny s) $
+ zipBlockingVars xs ys
+choice (Block r xs) (Yes _) = Block r $ overlapping xs
+choice m@Block{} No = m
+choice No m = m
+
+-- | Could the literal cover (an instantiation of) the split clause pattern?
+-- Basically, the split clause pattern needs to be a variable.
+--
+-- Note: literal patterns do not occur in the split clause
+-- since we cannot split into all possible literals (that would be infeasible).
+type MatchLit = Literal -> DeBruijnPattern -> MatchResult
+-- | Use this function if literal patterns should not cover a split clause pattern.
noMatchLit :: MatchLit
noMatchLit _ _ = No
+-- | Use this function if a literal pattern should cover a split clause variable pattern.
yesMatchLit :: MatchLit
-yesMatchLit _ q@VarMP{} = Yes [q]
-yesMatchLit _ q@WildMP{} = Yes [q]
-yesMatchLit _ _ = No
+yesMatchLit l q@VarP{} = Yes ([q], [l])
+yesMatchLit l (DotP t) = maybe No (yesMatchLit l) $ buildPattern t
+yesMatchLit _ ConP{} = No
+yesMatchLit _ ProjP{} = No
+yesMatchLit _ LitP{} = __IMPOSSIBLE__
-- | Check if a clause could match given generously chosen literals
-matchLits :: Clause -> [Arg DeBruijnPattern] -> Bool
+matchLits :: Clause -> [NamedArg DeBruijnPattern] -> Maybe [Literal]
matchLits c ps =
- case matchClause yesMatchLit (buildMPatterns ps) 0 c of
- Yes _ -> True
- _ -> False
+ case matchClause yesMatchLit ps 0 c of
+ Yes (qs,ls) -> Just ls
+ _ -> Nothing
-- | @matchClause mlit qs i c@ checks whether clause @c@ number @i@
-- covers a split clause with patterns @qs@.
-matchClause :: MatchLit -> [Arg MPat] -> Nat -> Clause -> Match (Nat,[MPat])
-matchClause mlit qs i c = (\q -> (i,q)) <$> matchPats mlit (clausePats c) qs
+matchClause
+ :: MatchLit
+ -- ^ Consider literals?
+ -> [NamedArg DeBruijnPattern]
+ -- ^ Split clause patterns @qs@.
+ -> Nat
+ -- ^ Clause number @i@.
+ -> Clause
+ -- ^ Clause @c@ to cover split clause.
+ -> MatchResult
+ -- ^ Result.
+ -- If 'Yes' the instantiation @rs@ such that @(namedClausePats c)[rs] == qs@.
+matchClause mlit qs i c = matchPats mlit (namedClausePats c) qs
+
-- | @matchPats mlit ps qs@ checks whether a function clause with patterns
-- @ps@ covers a split clause with patterns @qs@.
--
--- Issue 842: if in case of functions with varying arity,
--- the split clause has proper patterns left, we refuse to match,
--- because it would be troublesome to construct the split tree later.
--- We would have to move bindings from the rhs to the lhs.
--- For example, this is rejected:
+-- Issue #842 / #1986: This is accepted:
-- @
-- F : Bool -> Set1
-- F true = Set
-- F = \ x -> Set
-- @
-matchPats :: MatchLit -> [Arg (Pattern' a)] -> [Arg MPat] -> Match [MPat]
-matchPats mlit ps qs = mconcat $ properMatchesLeft :
- zipWith (matchPat mlit) (map unArg ps) (map unArg qs) ++
- [ projPatternsLeft ]
+-- For the second clause, the split clause is @F false@,
+-- so there are more patterns in the split clause than
+-- in the considered clause. These additional patterns
+-- are simply dropped by @zipWith@. This will result
+-- in @mconcat []@ which is @Yes []@.
+
+matchPats
+ :: MatchLit
+ -- ^ Matcher for literals.
+ -> [NamedArg (Pattern' a)]
+ -- ^ Clause pattern vector @ps@ (to cover split clause pattern vector).
+ -> [NamedArg DeBruijnPattern]
+ -- ^ Split clause pattern vector @qs@ (to be covered by clause pattern vector).
+ -> MatchResult
+ -- ^ Result.
+ -- If 'Yes' the instantiation @rs@ such that @ps[rs] == qs@.
+
+matchPats mlit ps qs = mconcat $ [ projPatternsLeftInSplitClause ] ++
+ zipWith (matchPat mlit) (map namedArg ps) (map namedArg qs) ++
+ [ projPatternsLeftInMatchedClause ]
where
- projPatternsLeft =
- let psrest = map unArg $ drop (length qs) ps
- in if null $ mapMaybe isProjP psrest -- not $ any properlyMatching psrest
- then Yes [] -- no proj. patterns left
- else BlockP -- proj. patterns left
- properMatchesLeft =
- if any (properMatch . unArg) $ drop (length ps) qs
- then No else Yes []
- properMatch ConMP{} = True
- properMatch LitMP{} = True
- properMatch _ = False
+ -- Patterns left in split clause:
+ qsrest = drop (length ps) qs
+ -- Andreas, 2016-06-03, issue #1986:
+ -- catch-all for copatterns is inconsistent as found by Ulf.
+ -- Thus, if the split clause has copatterns left,
+ -- the current (shorter) clause is not considered covering.
+ projPatternsLeftInSplitClause =
+ case mapMaybe isProjP qsrest of
+ [] -> mempty -- no proj. patterns left
+ _ -> No -- proj. patterns left
+
+ -- Patterns left in candidate clause:
+ psrest = drop (length qs) ps
+ -- If the current clause has additional copatterns in
+ -- comparison to the split clause, we should split on them.
+ projPatternsLeftInMatchedClause =
+ case mapMaybe isProjP psrest of
+ [] -> mempty -- no proj. patterns left
+ ds -> Block (Any True) [] -- proj. patterns left
+
-- | Combine results of checking whether function clause patterns
-- covers split clause patterns.
@@ -213,66 +243,56 @@ matchPats mlit ps qs = mconcat $ properMatchesLeft :
-- 'Yes' is neutral: for a match, all patterns have to match.
--
-- 'Block' accumulates variables of the split clause
--- that have to be instantiated
+-- that have to be instantiated (an projection names of copattern matches)
-- to make the split clause an instance of the function clause.
---
--- 'BlockP' yields to 'Block', since blocking vars can also
--- block the result type.
+
+instance Monoid a => Semigroup (Match a) where
+ Yes a <> Yes b = Yes $ mappend a b
+ Yes _ <> m = m
+ No <> _ = No
+ Block{} <> No = No
+ Block r xs <> Block s ys = Block (mappend r s) $ mappend xs ys
+ m@Block{} <> Yes{} = m
+
instance Monoid a => Monoid (Match a) where
- mempty = Yes mempty
- Yes a `mappend` Yes b = Yes $ mappend a b
- Yes _ `mappend` m = m
- No `mappend` _ = No
- Block x `mappend` No = No
- Block x `mappend` Block y = Block $ mappend x y
- Block x `mappend` _ = Block x
- BlockP `mappend` No = No
- BlockP `mappend` Block y = Block y
- BlockP `mappend` _ = BlockP
+ mempty = Yes mempty
+ mappend = (<>)
+
-- | @matchPat mlit p q@ checks whether a function clause pattern @p@
-- covers a split clause pattern @q@. There are three results:
--- @Yes ()@ means it covers, because @p@ is a variable
--- pattern or @q@ is a wildcard.
+-- @Yes rs@ means it covers, because @p@ is a variable pattern. @rs@ collects
+-- the instantiations of the variables in @p@ s.t. @p[rs] = q@.
-- @No@ means it does not cover.
-- @Block [x]@ means @p@ is a proper instance of @q@ and could become
-- a cover if @q@ was split on variable @x@.
-matchPat :: MatchLit -> Pattern' a -> MPat -> Match [MPat]
-matchPat _ (VarP _) q = Yes [q]
-matchPat _ (DotP _) q = Yes []
+
+matchPat
+ :: MatchLit
+ -- ^ Matcher for literals.
+ -> Pattern' a
+ -- ^ Clause pattern @p@ (to cover split clause pattern).
+ -> DeBruijnPattern
+ -- ^ Split clause pattern @q@ (to be covered by clause pattern).
+ -> MatchResult
+ -- ^ Result.
+ -- If 'Yes', also the instantiation @rs@ of the clause pattern variables
+ -- to produce the split clause pattern, @p[rs] = q@.
+
+matchPat _ VarP{} q = Yes ([q],[])
+matchPat _ DotP{} q = mempty
-- Jesper, 2014-11-04: putting 'Yes [q]' here triggers issue 1333.
--- Not checking for trivial MPats should be safe here, as dot patterns are
+-- Not checking for trivial patterns should be safe here, as dot patterns are
-- guaranteed to match if the rest of the pattern does, so some extra splitting
-- on them doesn't change the reduction behaviour.
-matchPat mlit p (DotMP q) = matchPat mlit p q
matchPat mlit (LitP l) q = mlit l q
-matchPat _ (ProjP d) (ProjMP d') = if d == d' then Yes [] else No
-matchPat _ (ProjP d) _ = __IMPOSSIBLE__
--- matchPat mlit (ConP c (Just _) ps) q | recordPattern ps = Yes () -- Andreas, 2012-07-25 record patterns always match!
-matchPat mlit (ConP c _ ps) q = case q of
- VarMP x -> Block [BlockingVar x (Just [c])]
- WildMP{} -> No -- Andreas, 2013-05-15 this was "Yes()" triggering issue 849
- ConMP c' i qs
- | c == c' -> matchPats mlit (map (fmap namedThing) ps) qs
+matchPat _ (ProjP _ d) (ProjP _ d') = if d == d' then mempty else No
+matchPat _ ProjP{} _ = __IMPOSSIBLE__
+matchPat mlit p@(ConP c _ ps) q = case q of
+ VarP x -> Block (Any False) [BlockingVar (dbPatVarIndex x) (Just [c])]
+ ConP c' i qs
+ | c == c' -> matchPats mlit ps qs
| otherwise -> No
- LitMP _ -> __IMPOSSIBLE__
- ProjMP _ -> __IMPOSSIBLE__
- DotMP _ -> __IMPOSSIBLE__
-
-{- UNUSED
-class RecordPattern a where
- recordPattern :: a -> Bool
-
-instance RecordPattern Pattern where
- recordPattern VarP{} = True
- recordPattern DotP{} = False
- recordPattern LitP{} = False
- recordPattern (ConP _ Nothing _) = False
- recordPattern (ConP _ (Just _) ps) = recordPattern ps
-
-instance RecordPattern a => RecordPattern [a] where
- recordPattern = all recordPattern
-
-instance RecordPattern a => RecordPattern (Arg a) where
- recordPattern = recordPattern . unArg
--}
+ DotP t -> maybe No (matchPat mlit p) $ buildPattern t
+ LitP _ -> __IMPOSSIBLE__ -- split clause has no literal patterns
+ ProjP{} -> __IMPOSSIBLE__ -- excluded by typing
diff --git a/src/full/Agda/TypeChecking/Coverage/SplitTree.hs b/src/full/Agda/TypeChecking/Coverage/SplitTree.hs
index a66a5a1..c994591 100644
--- a/src/full/Agda/TypeChecking/Coverage/SplitTree.hs
+++ b/src/full/Agda/TypeChecking/Coverage/SplitTree.hs
@@ -14,7 +14,6 @@ each leaf of the split tree.
module Agda.TypeChecking.Coverage.SplitTree where
import Data.Tree
-import Test.QuickCheck
import Agda.Syntax.Abstract.Name
import Agda.Syntax.Common
@@ -75,24 +74,3 @@ toTrees = map (\ (c,t) -> setCons c $ toTree t)
instance Show a => Show (SplitTree' a) where
show = drawTree . fmap show . toTree
-
--- * Generating random split trees for testing
-
-instance Arbitrary a => Arbitrary (SplitTree' a) where
- arbitrary = frequency
- [ (5, return $ SplittingDone 0)
- , (3, (SplitAt . defaultArg) <$> choose (1,5) <*> (take 3 <$> listOf1 arbitrary))
- ]
-
--- * Testing the printer
-
-newtype CName = CName String
-instance Show CName where
- show (CName s) = s
-
-instance Arbitrary CName where
- arbitrary = CName <$> elements
- [ "zero", "suc", "nil", "cons", "left", "right", "just", "nothing" ]
-
-testSplitTreePrinting :: IO ()
-testSplitTreePrinting = sample (arbitrary :: Gen (SplitTree' CName))
diff --git a/src/full/Agda/TypeChecking/Datatypes.hs b/src/full/Agda/TypeChecking/Datatypes.hs
index 3deca96..9a57671 100644
--- a/src/full/Agda/TypeChecking/Datatypes.hs
+++ b/src/full/Agda/TypeChecking/Datatypes.hs
@@ -26,15 +26,12 @@ import Agda.Utils.Impossible
getConHead :: QName -> TCM ConHead
getConHead c = conSrcCon . theDef <$> getConstInfo c
--- | Get true constructor as term.
-getConTerm :: QName -> TCM Term
-getConTerm c = flip Con [] <$> getConHead c
-
-- | Get true constructor with fields, expanding literals to constructors
-- if possible.
getConForm :: QName -> TCM ConHead
getConForm c = do
- Con con [] <- ignoreSharing <$> do constructorForm =<< getConTerm c
+ ch <- getConHead c
+ Con con _ [] <- ignoreSharing <$> constructorForm (Con ch ConOCon [])
return con
-- | Augment constructor with record fields (preserve constructor name).
@@ -42,10 +39,6 @@ getConForm c = do
getOrigConHead :: QName -> TCM ConHead
getOrigConHead c = setConName c <$> getConHead c
--- | Analogous to 'getConTerm'.
-getOrigConTerm :: QName -> TCM Term
-getOrigConTerm c = flip Con [] <$> getOrigConHead c
-
-- | Get the name of the datatype constructed by a given constructor.
-- Precondition: The argument must refer to a constructor
{-# SPECIALIZE getConstructorData :: QName -> TCM QName #-}
@@ -153,6 +146,15 @@ getNumberOfParameters d = do
Constructor{ conPars = n } -> return $ Just n
_ -> return Nothing
+-- | Precondition: Name is a data or record type.
+getConstructors :: QName -> TCM [QName]
+getConstructors d = do
+ def <- theDef <$> getConstInfo d
+ case def of
+ Datatype{dataCons = cs} -> return cs
+ Record{recConHead = h} -> return [conName h]
+ _ -> __IMPOSSIBLE__
+
{- UNUSED
data DatatypeInfo = DataInfo
{ datatypeName :: QName
diff --git a/src/full/Agda/TypeChecking/DisplayForm.hs b/src/full/Agda/TypeChecking/DisplayForm.hs
index 77d55bf..1e36e87 100644
--- a/src/full/Agda/TypeChecking/DisplayForm.hs
+++ b/src/full/Agda/TypeChecking/DisplayForm.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-- | Tools for 'DisplayTerm' and 'DisplayForm'.
@@ -8,6 +7,7 @@ module Agda.TypeChecking.DisplayForm where
import Prelude hiding (all)
import Control.Applicative
import Control.Monad
+import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe
import Data.Foldable (all)
import qualified Data.Set as Set
@@ -20,10 +20,12 @@ import Agda.Syntax.Scope.Base (inverseScopeLookupName)
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Level
+import Agda.TypeChecking.Reduce (instantiate)
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Except
+import Agda.Utils.Functor
#include "undefined.h"
import Agda.Utils.Impossible
@@ -31,43 +33,44 @@ import Agda.Utils.Impossible
-- | Convert a 'DisplayTerm' into a 'Term'.
dtermToTerm :: DisplayTerm -> Term
dtermToTerm dt = case dt of
- DWithApp d ds vs -> dtermToTerm d `apply` (map (defaultArg . dtermToTerm) ds ++ vs)
- DCon c args -> Con c $ map (fmap dtermToTerm) args
+ DWithApp d ds es ->
+ dtermToTerm d `apply` map (defaultArg . dtermToTerm) ds `applyE` es
+ DCon c ci args -> Con c ci $ map (fmap dtermToTerm) args
DDef f es -> Def f $ map (fmap dtermToTerm) es
DDot v -> v
DTerm v -> v
-- | Get the arities of all display forms for a name.
displayFormArities :: QName -> TCM [Int]
-displayFormArities q = map (length . dfPats . openThing) <$> getDisplayForms q
+displayFormArities q = map (length . dfPats . dget) <$> getDisplayForms q
--- | Find a matching display form for @q vs@.
--- In essence this tries to reqwrite @q vs@ with any
+-- | Find a matching display form for @q es@.
+-- In essence this tries to rewrite @q es@ with any
-- display form @q ps --> dt@ and returns the instantiated
-- @dt@ if successful. First match wins.
-displayForm :: QName -> Args -> TCM (Maybe DisplayTerm)
-displayForm q vs = do
+displayForm :: QName -> Elims -> TCM (Maybe DisplayTerm)
+displayForm q es = do
-- Get display forms for name q.
odfs <- getDisplayForms q `catchError` \_ -> return []
-- Display debug info about the @Open@s.
unless (null odfs) $ verboseS "tc.display.top" 100 $ do
n <- getContextId
reportSLn "tc.display.top" 100 $
- "displayForm: context = " ++ show n ++
- ", dfs = " ++ show (map openThingCtxIds odfs)
+ "displayForm for " ++ show q ++ ": context = " ++ show n ++
+ ", dfs = " ++ show odfs
-- Use only the display forms that can be opened in the current context.
- dfs <- catMaybes <$> mapM tryOpen odfs
+ dfs <- catMaybes <$> mapM getLocal odfs
scope <- getScope
- -- Keep the display forms that match the application @c vs@.
+ -- Keep the display forms that match the application @q es@.
ms <- do
- ms <- mapM (runMaybeT . (`matchDisplayForm` vs)) dfs
+ ms <- mapM (runMaybeT . (`matchDisplayForm` es)) dfs
return [ m | Just (d, m) <- ms, wellScoped scope d ]
-- Not safe when printing non-terminating terms.
- -- (nfdfs, us) <- normalise (dfs, vs)
+ -- (nfdfs, us) <- normalise (dfs, es)
unless (null odfs) $ reportSLn "tc.display.top" 100 $ unlines
[ "name : " ++ show q
, "displayForms: " ++ show dfs
- , "arguments : " ++ show vs
+ , "arguments : " ++ show es
, "matches : " ++ show ms
, "result : " ++ show (headMaybe ms)
]
@@ -92,16 +95,16 @@ displayForm q vs = do
isWithDisplay DWithApp{} = True
isWithDisplay _ = False
--- | Match a 'DisplayForm' @q ps = v@ against @q vs@.
+-- | Match a 'DisplayForm' @q ps = v@ against @q es@.
-- Return the 'DisplayTerm' @v[us]@ if the match was successful,
--- i.e., @vs / ps = Just us@.
-matchDisplayForm :: DisplayForm -> Args -> MaybeT TCM (DisplayForm, DisplayTerm)
-matchDisplayForm d@(Display _ ps v) vs
- | length ps > length vs = mzero
+-- i.e., @es / ps = Just us@.
+matchDisplayForm :: DisplayForm -> Elims -> MaybeT TCM (DisplayForm, DisplayTerm)
+matchDisplayForm d@(Display _ ps v) es
+ | length ps > length es = mzero
| otherwise = do
- let (vs0, vs1) = splitAt (length ps) vs
- us <- match ps $ raise 1 $ map unArg vs0
- return (d, applySubst (parallelS $ reverse us) v `apply` vs1)
+ let (es0, es1) = splitAt (length ps) es
+ us <- match ps $ raise 1 es0
+ return (d, applySubst (parallelS $ reverse us) v `applyE` es1)
-- | Class @Match@ for matching a term @p@ in the role of a pattern
-- against a term @v@.
@@ -130,16 +133,16 @@ instance Match a => Match (Arg a) where
instance Match a => Match (Elim' a) where
match p v =
case (p, v) of
- (Proj f, Proj f') | f == f' -> return []
+ (Proj _ f, Proj _ f') | f == f' -> return []
(Apply a, Apply a') -> match a a'
_ -> mzero
instance Match Term where
- match p v = case (ignoreSharing p, ignoreSharing v) of
+ match p v = lift (instantiate v) >>= \ v -> case (ignoreSharing p, ignoreSharing v) of
(Var 0 [], v) -> return [strengthen __IMPOSSIBLE__ v]
(Var i ps, Var j vs) | i == j -> match ps vs
(Def c ps, Def d vs) | c == d -> match ps vs
- (Con c ps, Con d vs) | c == d -> match ps vs
+ (Con c _ ps, Con d _ vs) | c == d -> match ps vs
(Lit l, Lit l') | l == l' -> return []
(p, v) | p == v -> return []
(p, Level l) -> match p =<< reallyUnLevelView l
diff --git a/src/full/Agda/TypeChecking/DropArgs.hs b/src/full/Agda/TypeChecking/DropArgs.hs
index 7a87a67..9cb42c2 100644
--- a/src/full/Agda/TypeChecking/DropArgs.hs
+++ b/src/full/Agda/TypeChecking/DropArgs.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
module Agda.TypeChecking.DropArgs where
@@ -8,7 +7,6 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Substitute
-import Agda.TypeChecking.Substitute.Pattern
import Agda.TypeChecking.CompiledClause
@@ -37,22 +35,17 @@ instance DropArgs Telescope where
instance DropArgs Permutation where
dropArgs n (Perm m p) = Perm (m - n) $ map (subtract n) $ drop n p
--- | NOTE: does not go into the body, so does not work for recursive functions.
-instance DropArgs ClauseBody where
- dropArgs 0 b = b
- dropArgs _ NoBody = NoBody
- dropArgs n (Bind b) = dropArgs (n - 1) (absBody b)
- dropArgs n Body{} = __IMPOSSIBLE__
-
-- | NOTE: does not work for recursive functions.
instance DropArgs Clause where
dropArgs n cl =
- cl{ clauseTel = dropArgs n $ clauseTel cl
- -- Andreas, 2012-09-25: just dropping the front of telescope
+ cl{ -- Andreas, 2012-09-25: just dropping the front of telescope
-- makes it ill-formed (unbound indices)
-- we should let the telescope intact!?
- , namedClausePats = drop n $ namedClausePats cl
- , clauseBody = dropArgs n $ clauseBody cl -- BUG: need to drop also from recursive calls!!
+ -- Ulf, 2016-06-23: Indeed. After parameter refinement it's even
+ -- worse: the module parameters we want to drop aren't necessarily
+ -- the first things in the telescope.
+ namedClausePats = drop n $ namedClausePats cl
+ -- BUG: need to drop also from recursive calls!!
}
instance DropArgs FunctionInverse where
diff --git a/src/full/Agda/TypeChecking/Empty.hs b/src/full/Agda/TypeChecking/Empty.hs
index 87af410..8e3ddc0 100644
--- a/src/full/Agda/TypeChecking/Empty.hs
+++ b/src/full/Agda/TypeChecking/Empty.hs
@@ -39,4 +39,4 @@ isEmptyType r t = do
Right cov -> do
let cs = splitClauses cov
unless (null cs) $
- typeError $ ShouldBeEmpty t $ map (namedArg . last . unnumberPatVars . scPats) $ cs
+ typeError $ ShouldBeEmpty t $ map (namedArg . last . scPats) cs
diff --git a/src/full/Agda/TypeChecking/Errors.hs b/src/full/Agda/TypeChecking/Errors.hs
index 5288d6c..66db96d 100644
--- a/src/full/Agda/TypeChecking/Errors.hs
+++ b/src/full/Agda/TypeChecking/Errors.hs
@@ -1,18 +1,19 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Agda.TypeChecking.Errors
( prettyError
, tcErrString
- , Warnings(..)
- , warningsToError
+ , prettyTCWarnings
+ , tcWarningsToError
+ , applyFlagsToTCWarnings
) where
import Prelude hiding (null)
+import Control.Monad.Reader
import Control.Monad.State
import Data.Function
@@ -23,6 +24,7 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Text.PrettyPrint.Boxes as Boxes
+import Agda.Interaction.Options
import Agda.Syntax.Common
import Agda.Syntax.Fixity
import Agda.Syntax.Notation
@@ -43,13 +45,16 @@ import Agda.TypeChecking.Monad.Context
import Agda.TypeChecking.Monad.Options
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Monad.State
+import Agda.TypeChecking.Positivity
import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Reduce (instantiate)
-import Agda.Utils.Except ( MonadError(catchError) )
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.FileName
import Agda.Utils.Function
import Agda.Utils.List
+import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Size
@@ -80,24 +85,96 @@ prettyError err = liftTCM $ show <$> prettyError' err []
-- * Warnings
---------------------------------------------------------------------------
--- | Warnings.
---
--- Invariant: The fields are never empty at the same time.
-
-data Warnings = Warnings
- { unsolvedMetaVariables :: [Range]
- -- ^ Meta-variable problems are reported as type errors unless
- -- 'optAllowUnsolved' is 'True'.
- , unsolvedConstraints :: Constraints
- -- ^ Same as 'unsolvedMetaVariables'.
- }
-
--- | Turns warnings into an error. Even if several errors are possible
--- only one is raised.
-warningsToError :: Warnings -> TCM a
-warningsToError (Warnings [] []) = typeError $ SolvedButOpenHoles
-warningsToError (Warnings w@(_:_) _) = typeError $ UnsolvedMetas w
-warningsToError (Warnings _ w@(_:_)) = typeError $ UnsolvedConstraints w
+instance PrettyTCM TCWarning where
+ prettyTCM (TCWarning tcst clw) = localState $ do
+ put tcst
+ sayWhen (envRange $ clEnv clw)
+ (envCall $ clEnv clw)
+ (prettyTCM $ clValue clw)
+
+instance PrettyTCM Warning where
+ prettyTCM wng = case wng of
+
+ UnsolvedMetaVariables ms ->
+ fsep ( pwords "Unsolved metas at the following locations:" )
+ $$ nest 2 (vcat $ map prettyTCM ms)
+
+ UnsolvedInteractionMetas is ->
+ fsep ( pwords "Unsolved interaction metas at the following locations:" )
+ $$ nest 2 (vcat $ map prettyTCM is)
+
+ UnsolvedConstraints cs ->
+ fsep ( pwords "Failed to solve the following constraints:" )
+ $$ nest 2 (P.vcat . nub <$> mapM prettyConstraint cs)
+
+ where prettyConstraint :: ProblemConstraint -> TCM Doc
+ prettyConstraint c = f (prettyTCM c)
+ where
+ r = getRange c
+ f d = if null $ P.pretty r
+ then d
+ else d $$ nest 4 (text "[ at" <+> prettyTCM r <+> text "]")
+
+ TerminationIssue tes ->
+ fwords "Termination checking failed for the following functions:"
+ $$ (nest 2 $ fsep $ punctuate comma $
+ map (pretty . dropTopLevelModule) $
+ concatMap termErrFunctions tes)
+ $$ fwords "Problematic calls:"
+ $$ (nest 2 $ fmap (P.vcat . nub) $
+ mapM prettyTCM $ sortBy (compare `on` callInfoRange) $
+ concatMap termErrCalls tes)
+
+ NotStrictlyPositive d ocs -> fsep $
+ [prettyTCM (dropTopLevelModule d)] ++
+ pwords "is not strictly positive, because it occurs"
+ ++ [prettyTCM ocs]
+
+ OldBuiltin old new -> fwords $
+ "Builtin " ++ old ++ " does no longer exist. " ++
+ "It is now bound by BUILTIN " ++ new
+
+ EmptyRewritePragma -> fsep . pwords $ "Empty REWRITE pragma"
+
+ ParseWarning pw -> pretty pw
+
+prettyTCWarnings :: [TCWarning] -> TCM String
+prettyTCWarnings = fmap (unlines . intersperse " ") . prettyTCWarnings'
+
+prettyTCWarnings' :: [TCWarning] -> TCM [String]
+prettyTCWarnings' = mapM (fmap show . prettyTCM)
+
+-- | Turns all warnings into errors.
+tcWarningsToError :: [TCWarning] -> TCM a
+tcWarningsToError ws = typeError $ case ws of
+ [] -> SolvedButOpenHoles
+ _ -> NonFatalErrors ws
+
+
+-- | Depending which flags are set, one may happily ignore some
+-- warnings.
+
+applyFlagsToTCWarnings :: IgnoreFlags -> [TCWarning] -> TCM [TCWarning]
+applyFlagsToTCWarnings ifs ws = do
+
+ unsolvedNotOK <- not . optAllowUnsolved <$> pragmaOptions
+ negativeNotOK <- not . optDisablePositivity <$> pragmaOptions
+ loopingNotOK <- optTerminationCheck <$> pragmaOptions
+
+ let cleanUp w =
+ let ignore = ifs == IgnoreFlags
+ keepUnsolved us = not (null us) && (ignore || unsolvedNotOK)
+ in case w of
+ TerminationIssue{} -> ignore || loopingNotOK
+ NotStrictlyPositive{} -> ignore || negativeNotOK
+ UnsolvedMetaVariables ums -> keepUnsolved ums
+ UnsolvedInteractionMetas uis -> keepUnsolved uis
+ UnsolvedConstraints ucs -> keepUnsolved ucs
+ OldBuiltin{} -> True
+ EmptyRewritePragma -> True
+ ParseWarning{} -> True
+
+ return $ filter (cleanUp . tcWarning) ws
---------------------------------------------------------------------------
-- * Helpers
@@ -126,7 +203,6 @@ tcErrString err = show (getRange err) ++ " " ++ case err of
Exception r s -> show r ++ " " ++ show s
IOException r e -> show r ++ " " ++ show e
PatternErr{} -> "PatternErr"
- {- AbortAssign _ -> "AbortAssign" -- UNUSED -}
errorString :: TypeError -> String
errorString err = case err of
@@ -184,6 +260,7 @@ errorString err = case err of
ModuleArityMismatch{} -> "ModuleArityMismatch"
ModuleDefinedInOtherFile {} -> "ModuleDefinedInOtherFile"
ModuleDoesntExport{} -> "ModuleDoesntExport"
+ ModuleNameUnexpected{} -> "ModuleNameUnexpected"
ModuleNameDoesntMatchFileName {} -> "ModuleNameDoesntMatchFileName"
NeedOptionCopatterns{} -> "NeedOptionCopatterns"
NeedOptionRewriting{} -> "NeedOptionRewriting"
@@ -204,12 +281,12 @@ errorString err = case err of
InvalidTypeSort{} -> "InvalidTypeSort"
FunctionTypeInSizeUniv{} -> "FunctionTypeInSizeUniv"
NotAValidLetBinding{} -> "NotAValidLetBinding"
+ NotValidBeforeField{} -> "NotValidBeforeField"
NotAnExpression{} -> "NotAnExpression"
NotImplemented{} -> "NotImplemented"
NotSupported{} -> "NotSupported"
NotInScope{} -> "NotInScope"
NotLeqSort{} -> "NotLeqSort"
- NotStrictlyPositive{} -> "NotStrictlyPositive"
NothingAppliedToHiddenArg{} -> "NothingAppliedToHiddenArg"
NothingAppliedToInstanceArg{} -> "NothingAppliedToInstanceArg"
OverlappingProjects {} -> "OverlappingProjects"
@@ -223,7 +300,8 @@ errorString err = case err of
SafeFlagNonTerminating{} -> "SafeFlagNonTerminating"
SafeFlagTerminating{} -> "SafeFlagTerminating"
SafeFlagPrimTrustMe{} -> "SafeFlagPrimTrustMe"
- SafeFlagNoPositivityCheck{} -> "SafeNoPositivityCheck"
+ SafeFlagNoPositivityCheck{} -> "SafeFlagNoPositivityCheck"
+ SafeFlagPolarity{} -> "SafeFlagPolarity"
ShadowedModule{} -> "ShadowedModule"
ShouldBeASort{} -> "ShouldBeASort"
ShouldBeApplicationOf{} -> "ShouldBeApplicationOf"
@@ -239,6 +317,7 @@ errorString err = case err of
TooFewFields{} -> "TooFewFields"
TooManyArgumentsInLHS{} -> "TooManyArgumentsInLHS"
TooManyFields{} -> "TooManyFields"
+ TooManyPolarities{} -> "TooManyPolarities"
SplitOnIrrelevant{} -> "SplitOnIrrelevant"
DefinitionIsIrrelevant{} -> "DefinitionIsIrrelevant"
VariableIsIrrelevant{} -> "VariableIsIrrelevant"
@@ -261,11 +340,10 @@ errorString err = case err of
UninstantiatedDotPattern{} -> "UninstantiatedDotPattern"
UninstantiatedModule{} -> "UninstantiatedModule"
UnreachableClauses{} -> "UnreachableClauses"
- UnsolvedConstraints{} -> "UnsolvedConstraints"
- UnsolvedMetas{} -> "UnsolvedMetas"
SolvedButOpenHoles{} -> "SolvedButOpenHoles"
UnusedVariableInPatternSynonym -> "UnusedVariableInPatternSynonym"
UnquoteFailed{} -> "UnquoteFailed"
+ DeBruijnIndexOutOfScope{} -> "DeBruijnIndexOutOfScope"
WithClausePatternMismatch{} -> "WithClausePatternMismatch"
WithoutKError{} -> "WithoutKError"
WrongHidingInApplication{} -> "WrongHidingInApplication"
@@ -277,9 +355,15 @@ errorString err = case err of
WrongNumberOfConstructorArguments{} -> "WrongNumberOfConstructorArguments"
HidingMismatch{} -> "HidingMismatch"
RelevanceMismatch{} -> "RelevanceMismatch"
+ NonFatalErrors{} -> "NonFatalErrors"
+ InstanceSearchDepthExhausted{} -> "InstanceSearchDepthExhausted"
instance PrettyTCM TCErr where
prettyTCM err = case err of
+ -- Gallais, 2016-05-14
+ -- Given where `NonFatalErrors` are created, we know for a
+ -- fact that ̀ws` is non-empty.
+ TypeError _ (Closure _ _ _ _ (NonFatalErrors ws)) -> foldr1 ($$) $ fmap prettyTCM ws
-- Andreas, 2014-03-23
-- This use of localState seems ok since we do not collect
-- Benchmark info during printing errors.
@@ -289,7 +373,6 @@ instance PrettyTCM TCErr where
Exception r s -> sayWhere r $ return s
IOException r e -> sayWhere r $ fwords $ show e
PatternErr{} -> sayWhere err $ panic "uncaught pattern violation"
- {- AbortAssign _ -> sayWhere err $ panic "uncaught aborted assignment" -- UNUSED -}
instance PrettyTCM CallInfo where
prettyTCM c = do
@@ -300,8 +383,11 @@ instance PrettyTCM CallInfo where
else call $$ nest 2 (text "(at" <+> prettyTCM r <> text ")")
-- | Drops the filename component of the qualified name.
+dropTopLevelModule' :: Int -> QName -> QName
+dropTopLevelModule' k (QName (MName ns) n) = QName (MName (drop k ns)) n
+
dropTopLevelModule :: QName -> QName
-dropTopLevelModule (QName (MName ns) n) = QName (MName (drop 1 ns)) n
+dropTopLevelModule = dropTopLevelModule' 1
instance PrettyTCM TypeError where
prettyTCM err = case err of
@@ -317,15 +403,19 @@ instance PrettyTCM TypeError where
GenericDocError d -> return d
- TerminationCheckFailed because ->
+ TerminationCheckFailed because -> do
+ dropTopLevelModule <- do
+ caseMaybeM (asks envCurrentPath) (return id) $ \ f -> do
+ m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f
+ return $ dropTopLevelModule' $ size m
fwords "Termination checking failed for the following functions:"
- $$ (nest 2 $ fsep $ punctuate comma $
- map (pretty . dropTopLevelModule) $
- concatMap termErrFunctions because)
- $$ fwords "Problematic calls:"
- $$ (nest 2 $ fmap (P.vcat . nub) $
- mapM prettyTCM $ sortBy (compare `on` callInfoRange) $
- concatMap termErrCalls because)
+ $$ (nest 2 $ fsep $ punctuate comma $
+ map (pretty . dropTopLevelModule) $
+ concatMap termErrFunctions because)
+ $$ fwords "Problematic calls:"
+ $$ (nest 2 $ fmap (P.vcat . nub) $
+ mapM prettyTCM $ sortBy (compare `on` callInfoRange) $
+ concatMap termErrCalls because)
PropMustBeSingleton -> fwords
"Datatypes in Prop must have at most one constructor when proof irrelevance is enabled"
@@ -575,9 +665,16 @@ instance PrettyTCM TypeError where
pwords "Duplicate fields" ++ punctuate comma (map pretty xs) ++
pwords "in record"
- WithOnFreeVariable e -> fsep $
- pwords "Cannot `with` on variable " ++ [prettyA e] ++
- pwords " bound in a module telescope (or patterns of a parent clause)"
+ WithOnFreeVariable e v -> do
+ de <- prettyA e
+ dv <- prettyTCM v
+ if show de == show dv
+ then fsep $
+ pwords "Cannot `with` on variable" ++ [return dv] ++
+ pwords " bound in a module telescope (or patterns of a parent clause)"
+ else fsep $
+ pwords "Cannot `with` on expression" ++ [return de] ++ pwords "which reduces to variable" ++ [return dv] ++
+ pwords " bound in a module telescope (or patterns of a parent clause)"
UnexpectedWithPatterns ps -> fsep $
pwords "Unexpected with patterns" ++ (punctuate (text " |") $ map prettyA ps)
@@ -647,22 +744,6 @@ instance PrettyTCM TypeError where
SolvedButOpenHoles ->
text "Module cannot be imported since it has open interaction points"
- UnsolvedMetas rs ->
- fsep ( pwords "Unsolved metas at the following locations:" )
- $$ nest 2 (vcat $ map prettyTCM rs)
-
- UnsolvedConstraints cs ->
- fsep ( pwords "Failed to solve the following constraints:" )
- $$ nest 2 (vcat $ map prettyConstraint cs)
-
- where prettyConstraint :: ProblemConstraint -> TCM Doc
- prettyConstraint c = f (prettyTCM c)
- where
- r = getRange c
- f d = if null $ P.pretty r
- then d
- else d $$ nest 4 (text "[ at" <+> prettyTCM r <+> text "]")
-
CyclicModuleDependency ms ->
fsep (pwords "cyclic module dependency:")
$$ nest 2 (vcat $ map pretty ms)
@@ -696,6 +777,12 @@ instance PrettyTCM TypeError where
pwords "However, according to the include path this module should" ++
pwords "be defined in" ++ [text (filePath file') <> text "."]
+ ModuleNameUnexpected given expected -> fsep $
+ pwords "The name of the top level module does not match the file name. The module" ++
+ [ pretty given ] ++
+ pwords "should probably be named" ++
+ [ pretty expected ]
+
ModuleNameDoesntMatchFileName given files ->
fsep (pwords "The name of the top level module does not match the file name. The module" ++
[ pretty given ] ++ pwords "should be defined in one of the following files:")
@@ -803,6 +890,9 @@ instance PrettyTCM TypeError where
NotAValidLetBinding nd -> fwords $
"Not a valid let-declaration"
+ NotValidBeforeField nd -> fwords $
+ "This declaration is illegal in a record before the last field"
+
NothingAppliedToHiddenArg e -> fsep $
[pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
pwords "a function expecting an implicit argument."
@@ -954,7 +1044,15 @@ instance PrettyTCM TypeError where
)
where
nota = sectNotation sect
- section = trim (notation nota)
+ section = qualifyFirstIdPart
+ (foldr (\x s -> C.nameToRawName x ++ "." ++ s)
+ ""
+ (init (C.qnameParts (notaName nota))))
+ (trim (notation nota))
+
+ qualifyFirstIdPart _ [] = []
+ qualifyFirstIdPart q (IdPart x : ps) = IdPart (q ++ x) : ps
+ qualifyFirstIdPart q (p : ps) = p : qualifyFirstIdPart q ps
trim = case sectKind sect of
InfixNotation -> trimLeft . trimRight
@@ -1012,7 +1110,7 @@ instance PrettyTCM TypeError where
where
display ps = do
ps <- nicify f ps
- prettyTCM f <+> fsep (map prettyArg ps)
+ prettyTCM f <+> fsep (map (prettyArg . fmap namedThing) ps)
nicify f ps = do
showImp <- showImplicitArguments
@@ -1022,7 +1120,7 @@ instance PrettyTCM TypeError where
CoverageCantSplitOn c tel cIxs gIxs
| length cIxs /= length gIxs -> __IMPOSSIBLE__
- | otherwise -> addCtxTel tel $ vcat (
+ | otherwise -> addContext tel $ vcat (
[ fsep $ pwords "I'm not sure if there should be a case for the constructor" ++
[prettyTCM c <> text ","] ++
pwords "because I get stuck when trying to solve the following" ++
@@ -1048,12 +1146,14 @@ instance PrettyTCM TypeError where
pwords "because K has been disabled."
UnifyConflict c c' -> fsep $
- pwords "There was a conflict between the constructors " ++
- [prettyTCM c] ++ pwords " and " ++ [prettyTCM c']
+ pwords "This case is impossible because of a conflict between the constructors " ++
+ [prettyTCM c] ++ pwords " and " ++ [prettyTCM c' <> text "."] ++
+ pwords "Possible solution: remove the clause, or use an absurd pattern ()."
UnifyCycle i u -> fsep $
- pwords "The variable " ++ [prettyTCM (var i)] ++
- pwords "occurs strongly rigid in" ++ [prettyTCM u]
+ pwords "This case is impossible because the variable " ++ [prettyTCM (var i)] ++
+ pwords "occurs strongly rigid in" ++ [prettyTCM u <> text "."] ++
+ pwords "Possible solution: remove the clause, or use an absurd pattern ()."
UnifyIndicesNotVars a u v ixs -> fsep $
pwords "Cannot apply injectivity to the equation" ++ [prettyTCM u] ++
@@ -1073,35 +1173,10 @@ instance PrettyTCM TypeError where
pwords "with" ++ [prettyList (map prettyTCM vs)] ++
pwords "in the telescope" ++ [prettyTCM tel]
- NotStrictlyPositive d ocs -> fsep $
- pwords "The datatype" ++ [prettyTCM d] ++
- pwords "is not strictly positive, because"
- ++ prettyOcc "it" ocs
- where
- prettyOcc _ [] = []
- prettyOcc it (OccCon d c r : ocs) = concat
- [ pwords it, pwords "occurs", prettyR r
- , pwords "in the constructor", [prettyTCM c], pwords "of"
- , [prettyTCM d <> com ocs], prettyOcc "which" ocs
- ]
- prettyOcc it (OccClause f n r : ocs) = concat
- [ pwords it, pwords "occurs", prettyR r
- , pwords "in the", [th n], pwords "clause of"
- , [prettyTCM f <> com ocs], prettyOcc "which" ocs
- ]
-
- prettyR NonPositively = pwords "negatively"
- prettyR (ArgumentTo i q) =
- pwords "as the" ++ [th i] ++
- pwords "argument to" ++ [prettyTCM q]
-
- th 0 = text "first"
- th 1 = text "second"
- th 2 = text "third"
- th n = prettyTCM (n - 1) <> text "th"
-
- com [] = empty
- com (_:_) = comma
+ TooManyPolarities x n -> fsep $
+ pwords "Too many polarities given in the POLARITY pragma for" ++
+ [prettyTCM x] ++
+ pwords "(at most" ++ [text (show n)] ++ pwords "allowed)."
IFSNoCandidateInScope t -> fsep $
pwords "No instance of type" ++ [prettyTCM t] ++ pwords "was found in scope."
@@ -1127,6 +1202,16 @@ instance PrettyTCM TypeError where
UnquotePanic err -> __IMPOSSIBLE__
+ DeBruijnIndexOutOfScope i EmptyTel [] -> fsep $
+ pwords $ "de Bruijn index " ++ show i ++ " is not in scope in the empty context"
+ DeBruijnIndexOutOfScope i cxt names ->
+ sep [ text ("de Bruijn index " ++ show i ++ " is not in scope in the context")
+ , inTopContext $ addContext "_" $ prettyTCM cxt' ]
+ where
+ cxt' = cxt `abstract` raise (size cxt) (nameCxt names)
+ nameCxt [] = EmptyTel
+ nameCxt (x : xs) = ExtendTel (defaultDom (El I.Prop $ I.Var 0 [])) $ NoAbs (show x) $ nameCxt xs
+
SafeFlagPostulate e -> fsep $
pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag"
@@ -1147,11 +1232,21 @@ instance PrettyTCM TypeError where
SafeFlagNoPositivityCheck -> fsep $
pwords "Cannot use NO_POSITIVITY_CHECK pragma with safe flag."
+ SafeFlagPolarity -> fsep $
+ pwords "The POLARITY pragma must not be used in safe mode."
+
NeedOptionCopatterns -> fsep $
pwords "Option --copatterns needed to enable destructor patterns"
+
NeedOptionRewriting -> fsep $
pwords "Option --rewriting needed to add and use rewrite rules"
+ NonFatalErrors ws -> foldr1 ($$) $ fmap prettyTCM ws
+
+ InstanceSearchDepthExhausted c a d -> fsep $
+ pwords ("Instance search depth exhaused (max depth: " ++ show d ++ ") for candidate") ++
+ [hang (prettyTCM c <+> text ":") 2 (prettyTCM a)]
+
where
mpar n args
| n > 0 && not (null args) = parens
@@ -1170,7 +1265,7 @@ instance PrettyTCM TypeError where
mpar n args $
prettyTCM c <+> fsep (map (prettyArg . fmap namedThing) args)
prettyPat _ (I.LitP l) = prettyTCM l
- prettyPat _ (I.ProjP p) = prettyTCM p
+ prettyPat _ (I.ProjP _ p) = text "." <> prettyTCM p
notCmp :: Comparison -> TCM Doc
notCmp cmp = text "!" <> prettyTCM cmp
@@ -1205,7 +1300,7 @@ prettyInEqual t1 t2 = do
"they contain different but identically rendered identifiers somewhere"
varVar :: Int -> Int -> TCM Doc
varVar i j = parens $ fwords $
- "because one has deBruijn index " ++ show i
+ "because one has de Bruijn index " ++ show i
++ " and the other " ++ show j
class PrettyUnequal a where
@@ -1252,7 +1347,7 @@ instance PrettyTCM Call where
pwords "when checking that the clause"
++ [prettyA cl] ++ pwords "has type" ++ [prettyTCM t]
- CheckPattern p tel t -> addCtxTel tel $ fsep $
+ CheckPattern p tel t -> addContext tel $ fsep $
pwords "when checking that the pattern"
++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t]
@@ -1291,7 +1386,7 @@ instance PrettyTCM Call where
CheckDataDef _ x ps cs ->
fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
- CheckConstructor d _ _ (A.Axiom _ _ _ c _) -> fsep $
+ CheckConstructor d _ _ (A.Axiom _ _ _ _ c _) -> fsep $
pwords "when checking the constructor" ++ [prettyTCM c] ++
pwords "in the declaration of" ++ [prettyTCM d]
@@ -1322,7 +1417,7 @@ instance PrettyTCM Call where
InferVar x ->
fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
- InferDef _ x ->
+ InferDef x ->
fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
CheckIsEmpty r t ->
@@ -1332,8 +1427,13 @@ instance PrettyTCM Call where
ScopeCheckExpr e -> fsep $ pwords "when scope checking" ++ [pretty e]
ScopeCheckDeclaration d ->
- fwords "when scope checking the declaration" $$
- nest 2 (pretty $ simpleDecl d)
+ fwords ("when scope checking the declaration" ++ suffix) $$
+ nest 2 (vcat $ map pretty ds)
+ where
+ ds = D.notSoNiceDeclarations d
+ suffix = case ds of
+ [_] -> ""
+ _ -> "s"
ScopeCheckLHS x p ->
fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++
@@ -1345,7 +1445,7 @@ instance PrettyTCM Call where
CheckSectionApplication _ m1 modapp -> fsep $
pwords "when checking the module application" ++
- [prettyA $ A.Apply info m1 modapp empty empty defaultImportDir]
+ [prettyA $ A.Apply info m1 modapp initCopyInfo defaultImportDir]
where
info = A.ModuleInfo noRange noRange Nothing Nothing Nothing
@@ -1355,8 +1455,6 @@ instance PrettyTCM Call where
hPretty :: Arg (Named_ Expr) -> TCM Doc
hPretty a = pretty =<< abstractToConcreteCtx (hiddenArgumentCtx (getHiding a)) a
- simpleDecl = D.notSoNiceDeclaration
-
---------------------------------------------------------------------------
-- * Natural language
---------------------------------------------------------------------------
diff --git a/src/full/Agda/TypeChecking/EtaContract.hs b/src/full/Agda/TypeChecking/EtaContract.hs
index 21d1681..cdc217f 100644
--- a/src/full/Agda/TypeChecking/EtaContract.hs
+++ b/src/full/Agda/TypeChecking/EtaContract.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
-- | Compute eta short normal forms.
module Agda.TypeChecking.EtaContract where
@@ -34,8 +32,8 @@ binAppView t = case t of
-- (Cf. also issue 889 (fixed differently).)
-- At least record constructors should be fully applied where possible!
-- TODO: also for ordinary constructors (\ x -> suc x vs. suc)?
- Con c xs
- | null (conFields c) -> app (Con c) xs
+ Con c ci xs
+ | null (conFields c) -> app (Con c ci) xs
| otherwise -> noApp
Lit _ -> noApp
Level _ -> noApp -- could be an application, but let's not eta contract levels
@@ -69,12 +67,11 @@ etaOnce v = case v of
-- reportSDoc "tc.eta" 70 $ text "eta-contracting" <+> prettyTCM v
Shared{} -> updateSharedTerm etaOnce v
Lam i (Abs _ b) -> do -- NoAbs can't be eta'd
- imp <- shouldEtaContractImplicit
tyty <- typeInType
case binAppView b of
App u (Arg info v)
| (isIrrelevant info || isVar0 tyty v)
- && allowed imp info
+ && getHiding i == getHiding info
&& not (freeIn 0 u) ->
return $ strengthen __IMPOSSIBLE__ u
_ -> return v
@@ -89,16 +86,15 @@ etaOnce v = case v of
BlockedLevel{} -> False
MetaLevel{} -> False
isVar0 _ _ = False
- allowed imp i' = getHiding i == getHiding i' && (imp || notHidden i)
-- Andreas, 2012-12-18: Abstract definitions could contain
-- abstract records whose constructors are not in scope.
-- To be able to eta-contract them, we ignore abstract.
- Con c args -> ignoreAbstractMode $ do
+ Con c ci args -> ignoreAbstractMode $ do
-- reportSDoc "tc.eta" 20 $ text "eta-contracting record" <+> prettyTCM t
r <- getConstructorData $ conName c -- fails in ConcreteMode if c is abstract
ifM (isEtaRecord r)
(do -- reportSDoc "tc.eta" 20 $ text "eta-contracting record" <+> prettyTCM t
- etaContractRecord r c args)
+ etaContractRecord r c ci args)
(return v)
v -> return v
diff --git a/src/full/Agda/TypeChecking/Forcing.hs b/src/full/Agda/TypeChecking/Forcing.hs
index ea6155d..691cba6 100644
--- a/src/full/Agda/TypeChecking/Forcing.hs
+++ b/src/full/Agda/TypeChecking/Forcing.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
{-| A constructor argument is forced if it appears as pattern variable
in an index of the target.
@@ -126,8 +125,8 @@ instance (ForcedVariables a, Foldable t) => ForcedVariables (t a) where
instance ForcedVariables Term where
forcedVariables t = case ignoreSharing t of
Var i [] -> [i]
- Con _ vs -> forcedVariables vs
- _ -> []
+ Con _ _ vs -> forcedVariables vs
+ _ -> []
-- | @force s xs t@ marks the domains @xs@ in function type @t@ as forced.
-- Domains bigger than @s@ are marked as @'Forced' 'Big'@, others as
diff --git a/src/full/Agda/TypeChecking/Free.hs b/src/full/Agda/TypeChecking/Free.hs
index 2d84533..5dca205 100644
--- a/src/full/Agda/TypeChecking/Free.hs
+++ b/src/full/Agda/TypeChecking/Free.hs
@@ -1,8 +1,3 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-- | Computing the free variables of a term.
--
@@ -26,13 +21,16 @@ module Agda.TypeChecking.Free
, Free, Free', FreeV, FreeVS
, IgnoreSorts(..)
, runFree , rigidVars, relevantVars, allVars
- , allFreeVars, allRelevantVars, allRelevantVarsIgnoring
+ , allFreeVars
+ , allRelevantVars, allRelevantVarsIgnoring
+ , allRelevantOrUnusedVars, allRelevantOrUnusedVarsIgnoring
, freeIn, freeInIgnoringSorts, isBinderUsed
, relevantIn, relevantInIgnoringSortAnn
, Occurrence(..)
, occurrence
, closed
, freeVars -- only for testing
+ , freeVars'
) where
import Prelude hiding (null)
@@ -40,11 +38,12 @@ import Prelude hiding (null)
import Control.Monad.Reader
import Data.Maybe
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat, Any(..), All(..))
import Data.IntSet (IntSet)
import qualified Data.IntSet as Set
import Data.IntMap (IntMap)
import qualified Data.IntMap as Map
+import Data.Set (Set)
import qualified Agda.Benchmarking as Bench
@@ -54,6 +53,7 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.Free.Lazy
( Free'(..) , FreeEnv(..), initFreeEnv
, VarOcc(..), IgnoreSorts(..), Variable, SingleVar
+ , MetaSet
)
import qualified Agda.TypeChecking.Free.Lazy as Free
@@ -75,9 +75,10 @@ data FreeVars = FV
-- whereas weakly rigid ones stay weakly rigid.
, weaklyRigidVars :: VarSet
-- ^ Ordinary rigid variables, e.g., in arguments of variables.
- , flexibleVars :: IntMap [MetaId]
+ , flexibleVars :: IntMap MetaSet
-- ^ Variables occuring in arguments of metas.
-- These are only potentially free, depending how the meta variable is instantiated.
+ -- The set contains the id's of the meta variables that this variable is an argument to.
, irrelevantVars :: VarSet
-- ^ Variables in irrelevant arguments and under a @DontCare@, i.e.,
-- in irrelevant positions.
@@ -93,7 +94,7 @@ mapWRV f fv = fv { weaklyRigidVars = f $ weaklyRigidVars fv }
mapIRV f fv = fv { irrelevantVars = f $ irrelevantVars fv }
mapUUV f fv = fv { unusedVars = f $ unusedVars fv }
-mapFXV :: (IntMap [MetaId] -> IntMap [MetaId]) -> FreeVars -> FreeVars
+mapFXV :: (IntMap MetaSet -> IntMap MetaSet) -> FreeVars -> FreeVars
mapFXV f fv = fv { flexibleVars = f $ flexibleVars fv }
-- | Rigid variables: either strongly rigid, unguarded, or weakly rigid.
@@ -118,7 +119,7 @@ data Occurrence
| StronglyRigid -- ^ Under at least one and only inductive constructors.
| Unguarded -- ^ In top position, or only under inductive record constructors.
| WeaklyRigid -- ^ In arguments to variables and definitions.
- | Flexible [MetaId] -- ^ In arguments of metas.
+ | Flexible MetaSet -- ^ In arguments of metas.
| Unused
deriving (Eq,Show)
@@ -138,14 +139,14 @@ occurrenceFV x fv
| otherwise = NoOccurrence
-- | Mark variables as flexible. Useful when traversing arguments of metas.
-flexible :: [MetaId] -> FreeVars -> FreeVars
+flexible :: MetaSet -> FreeVars -> FreeVars
flexible ms fv =
fv { stronglyRigidVars = Set.empty
, unguardedVars = Set.empty
, weaklyRigidVars = Set.empty
, flexibleVars = Map.unionsWith mappend
[ Map.fromSet (const ms) (rigidVars fv)
- , fmap (ms++) (flexibleVars fv) ]
+ , fmap (mappend ms) (flexibleVars fv) ]
}
-- | Mark rigid variables as non-strongly. Useful when traversing arguments of variables.
@@ -200,9 +201,12 @@ instance Null FreeVars where
null (FV a b c d e f) = null a && null b && null c && null d && null e && null f
-- | Free variable sets form a monoid under 'union'.
+instance Semigroup FreeVars where
+ (<>) = union
+
instance Monoid FreeVars where
mempty = empty
- mappend = union
+ mappend = (<>)
mconcat = unions
-- | @delete x fv@ deletes variable @x@ from variable set @fv@.
@@ -291,196 +295,20 @@ closed t = getAll $ runFree (const $ All False) IgnoreNot t
allFreeVars :: Free' a VarSet => a -> VarSet
allFreeVars = runFree (Set.singleton . fst) IgnoreNot
--- | Collect all relevant free variables, possibly ignoring sorts.
+-- | Collect all relevant free variables, excluding the "unused" ones, possibly ignoring sorts.
allRelevantVarsIgnoring :: Free' a VarSet => IgnoreSorts -> a -> VarSet
allRelevantVarsIgnoring = runFree sg
where sg (i, VarOcc _ r) = if irrelevantOrUnused r then Set.empty else Set.singleton i
--- | Collect all relevant free variables.
+-- | Collect all relevant free variables, excluding the "unused" ones.
allRelevantVars :: Free' a VarSet => a -> VarSet
allRelevantVars = allRelevantVarsIgnoring IgnoreNot
+-- | Collect all relevant free variables, possibly ignoring sorts.
+allRelevantOrUnusedVarsIgnoring :: Free' a VarSet => IgnoreSorts -> a -> VarSet
+allRelevantOrUnusedVarsIgnoring = runFree sg
+ where sg (i, VarOcc _ r) = if isIrrelevant r then Set.empty else Set.singleton i
-{- OLD
-
--- | A single unguarded variable.
-singleton :: Nat -> FreeVars
-singleton x = empty { unguardedVars = Set.singleton x }
-
--- * Collecting free variables.
-
--- | Where should we skip sorts in free variable analysis?
-data IgnoreSorts
- = IgnoreNot -- ^ Do not skip.
- | IgnoreInAnnotations -- ^ Skip when annotation to a type.
- | IgnoreAll -- ^ Skip unconditionally.
- deriving (Eq, Show)
-
-data FreeConf = FreeConf
- { fcIgnoreSorts :: !IgnoreSorts
- -- ^ Ignore free variables in sorts.
- , fcContext :: !Int
- -- ^ Under how many binders have we stepped?
- }
-
-initFreeConf :: FreeConf
-initFreeConf = FreeConf
- { fcIgnoreSorts = IgnoreNot
- , fcContext = 0
- }
-
--- | Return type of fold over syntax.
-type FreeT = Reader FreeConf FreeVars
-
-instance Monoid FreeT where
- mempty = pure mempty
- mappend = liftA2 mappend
- mconcat = mconcat <.> sequence
-
--- | Base case: a variable.
-variable :: Int -> FreeT
-variable n = do
- m <- (n -) <$> asks fcContext
- if m >= 0 then pure $ singleton m else mempty
-
--- | Going under a binder.
-bind :: FreeT -> FreeT
-bind = local $ \ e -> e { fcContext = 1 + fcContext e }
-
-class Free a where
- freeVars' :: a -> FreeT
-
-instance Free Term where
- freeVars' t = case t of
- Var n ts -> variable n `mappend` do weakly <$> freeVars' ts
- -- λ is not considered guarding, as
- -- we cannot prove that x ≡ λy.x is impossible.
- Lam _ t -> freeVars' t
- Lit _ -> mempty
- Def _ ts -> weakly <$> freeVars' ts -- because we are not in TCM
- -- we cannot query whether we are dealing with a data/record (strongly r.)
- -- or a definition by pattern matching (weakly rigid)
- -- thus, we approximate, losing that x = List x is unsolvable
- Con c ts -> underConstructor c <$> freeVars' ts
- -- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.
- -- Even as we do not permit infinite type expressions,
- -- we cannot prove their absence (as Set is not inductive).
- -- Also, this is incompatible with univalence (HoTT).
- Pi a b -> freeVars' (a,b)
- Sort s -> freeVars' s
- Level l -> freeVars' l
- MetaV _ ts -> flexible <$> freeVars' ts
- DontCare mt -> irrelevantly <$> freeVars' mt
- Shared p -> freeVars' (derefPtr p)
-
-instance Free Type where
- freeVars' (El s t) =
- ifM ((IgnoreNot ==) <$> asks fcIgnoreSorts)
- {- then -} (freeVars' (s, t))
- {- else -} (freeVars' t)
-
-instance Free Sort where
- freeVars' s =
- ifM ((IgnoreAll ==) <$> asks fcIgnoreSorts) mempty $ {- else -}
- case s of
- Type a -> freeVars' a
- Prop -> mempty
- Inf -> mempty
- SizeUniv -> mempty
- DLub s1 s2 -> weakly <$> freeVars' (s1, s2)
-
-instance Free Level where
- freeVars' (Max as) = freeVars' as
-
-instance Free PlusLevel where
- freeVars' ClosedLevel{} = mempty
- freeVars' (Plus _ l) = freeVars' l
-
-instance Free LevelAtom where
- freeVars' l = case l of
- MetaLevel _ vs -> flexible <$> freeVars' vs
- NeutralLevel _ v -> freeVars' v
- BlockedLevel _ v -> freeVars' v
- UnreducedLevel v -> freeVars' v
-
-instance Free a => Free [a] where
- freeVars' = foldMap freeVars'
-
-instance Free a => Free (Maybe a) where
- freeVars' = foldMap freeVars'
-
-instance (Free a, Free b) => Free (a,b) where
- freeVars' (x,y) = freeVars' x `mappend` freeVars' y
-
-instance Free a => Free (Elim' a) where
- freeVars' (Apply a) = freeVars' a
- freeVars' (Proj{} ) = mempty
-
-instance Free a => Free (Arg a) where
- freeVars' a = f <$> freeVars' (unArg a)
- where f = case getRelevance a of
- Irrelevant -> irrelevantly
- UnusedArg -> unused
- _ -> id
-
-
-instance Free a => Free (Dom a) where
- freeVars' = freeVars' . unDom
-
-instance Free a => Free (Abs a) where
- freeVars' (Abs _ b) = bind $ freeVars' b
- freeVars' (NoAbs _ b) = freeVars' b
-
-instance Free a => Free (Tele a) where
- freeVars' EmptyTel = mempty
- freeVars' (ExtendTel a tel) = freeVars' (a, tel)
-
-instance Free ClauseBody where
- freeVars' (Body t) = freeVars' t
- freeVars' (Bind b) = freeVars' b
- freeVars' NoBody = mempty
-
-instance Free Clause where
- freeVars' = freeVars' . clauseBody
-
-bench :: a -> a
-bench = Bench.billToPure [ Bench.Typing , Bench.Free ]
-
--- | Doesn't go inside solved metas, but collects the variables from a
--- metavariable application @X ts@ as @flexibleVars@.
-freeVars :: Free a => a -> FreeVars
-freeVars t =
- freeVars' t `runReader` initFreeConf
-
-freeVarsIgnore :: Free a => IgnoreSorts -> a -> FreeVars
-freeVarsIgnore i t =
- freeVars' t `runReader` initFreeConf{ fcIgnoreSorts = i }
-
-freeIn :: Free a => Nat -> a -> Bool
-freeIn v t = bench $
- v `Set.member` allVars (freeVars t)
-
-freeInIgnoringSorts :: Free a => Nat -> a -> Bool
-freeInIgnoringSorts v t = bench $
- v `Set.member` allVars (freeVarsIgnore IgnoreAll t)
-
-freeInIgnoringSortAnn :: Free a => Nat -> a -> Bool
-freeInIgnoringSortAnn v t = bench $
- v `Set.member` allVars (freeVarsIgnore IgnoreInAnnotations t)
-
-relevantInIgnoringSortAnn :: Free a => Nat -> a -> Bool
-relevantInIgnoringSortAnn v t = bench $
- v `Set.member` relevantVars (freeVarsIgnore IgnoreInAnnotations t)
-
-relevantIn :: Free a => Nat -> a -> Bool
-relevantIn v t = bench $
- v `Set.member` relevantVars (freeVarsIgnore IgnoreAll t)
-
--- | Is the variable bound by the abstraction actually used?
-isBinderUsed :: Free a => Abs a -> Bool
-isBinderUsed NoAbs{} = False
-isBinderUsed (Abs _ x) = 0 `freeIn` x
-
--- -}
--- -}
--- -}
+-- | Collect all relevant free variables.
+allRelevantOrUnusedVars :: Free' a VarSet => a -> VarSet
+allRelevantOrUnusedVars = allRelevantOrUnusedVarsIgnoring IgnoreNot
diff --git a/src/full/Agda/TypeChecking/Free/Lazy.hs b/src/full/Agda/TypeChecking/Free/Lazy.hs
index 33f5dd0..3cc1776 100644
--- a/src/full/Agda/TypeChecking/Free/Lazy.hs
+++ b/src/full/Agda/TypeChecking/Free/Lazy.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Computing the free variables of a term lazily.
@@ -36,9 +33,8 @@ import Control.Monad.Reader
import Data.Foldable (foldMap)
import Data.IntMap (IntMap)
-import Data.Monoid
-
-import Test.QuickCheck
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat)
+import Data.Set (Set)
import Agda.Syntax.Common
import Agda.Syntax.Internal
@@ -48,6 +44,9 @@ import Agda.Syntax.Internal
import Agda.Utils.Functor
import Agda.Utils.Monad
import Agda.Utils.Singleton
+import Agda.Utils.Size
+
+type MetaSet = Set MetaId
-- | Depending on the surrounding context of a variable,
-- it's occurrence can be classified as flexible or rigid,
@@ -55,7 +54,7 @@ import Agda.Utils.Singleton
--
-- The constructors are listed in increasing order (wrt. information content).
data FlexRig
- = Flexible [MetaId] -- ^ In arguments of metas.
+ = Flexible MetaSet -- ^ In arguments of metas.
| WeaklyRigid -- ^ In arguments to variables and definitions.
| Unguarded -- ^ In top position, or only under inductive record constructors.
| StronglyRigid -- ^ Under at least one and only inductive constructors.
@@ -74,7 +73,7 @@ data FlexRig
composeFlexRig :: FlexRig -> FlexRig -> FlexRig
composeFlexRig o o' =
case (o, o') of
- (Flexible ms1, Flexible ms2) -> Flexible $ ms1 ++ ms2
+ (Flexible ms1, Flexible ms2) -> Flexible $ ms1 `mappend` ms2
(Flexible ms1, _) -> Flexible ms1
(_, Flexible ms2) -> Flexible ms2
(WeaklyRigid, _) -> WeaklyRigid
@@ -107,7 +106,7 @@ topVarOcc :: VarOcc
topVarOcc = VarOcc StronglyRigid Relevant
botVarOcc :: VarOcc
-botVarOcc = VarOcc (Flexible []) Irrelevant
+botVarOcc = VarOcc (Flexible mempty) Irrelevant
type VarMap = IntMap VarOcc
@@ -152,9 +151,11 @@ initFreeEnv sing = FreeEnv
type FreeM c = Reader (FreeEnv c) c
+instance Monoid c => Semigroup (FreeM c) where
+ (<>) = liftA2 mappend
instance Monoid c => Monoid (FreeM c) where
mempty = pure mempty
- mappend = liftA2 mappend
+ mappend = (<>)
mconcat = mconcat <.> sequence
-- instance Singleton a c => Singleton a (FreeM c) where
@@ -172,7 +173,10 @@ variable n = do
-- | Going under a binder.
bind :: FreeM a -> FreeM a
-bind = local $ \ e -> e { feBinders = 1 + feBinders e }
+bind = bind' 1
+
+bind' :: Nat -> FreeM a -> FreeM a
+bind' n = local $ \ e -> e { feBinders = n + feBinders e }
-- | Changing the 'FlexRig' context.
go :: FlexRig -> FreeM a -> FreeM a
@@ -219,7 +223,7 @@ instance Free' Term c where
-- we cannot query whether we are dealing with a data/record (strongly r.)
-- or a definition by pattern matching (weakly rigid)
-- thus, we approximate, losing that x = List x is unsolvable
- Con c ts -> underConstructor c $ freeVars' ts
+ Con c _ ts -> underConstructor c $ freeVars' ts
-- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.
-- Even as we do not permit infinite type expressions,
-- we cannot prove their absence (as Set is not inductive).
@@ -231,7 +235,7 @@ instance Free' Term c where
DontCare mt -> goRel Irrelevant $ freeVars' mt
Shared p -> freeVars' (derefPtr p)
-instance Free' Type c where
+instance Free' a c => Free' (Type' a) c where
-- {-# SPECIALIZE instance Free' Type All #-}
-- {-# SPECIALIZE freeVars' :: Type -> FreeM Any #-}
-- {-# SPECIALIZE freeVars' :: Type -> FreeM All #-}
@@ -353,39 +357,14 @@ instance Free' a c => Free' (Tele a) c where
freeVars' EmptyTel = mempty
freeVars' (ExtendTel a tel) = freeVars' (a, tel)
-instance Free' ClauseBody c where
- -- {-# SPECIALIZE instance Free' ClauseBody All #-}
- -- {-# SPECIALIZE freeVars' :: ClauseBody -> FreeM Any #-}
- -- {-# SPECIALIZE freeVars' :: ClauseBody -> FreeM All #-}
- -- {-# SPECIALIZE freeVars' :: ClauseBody -> FreeM VarSet #-}
- -- {-# SPECIALIZE freeVars' :: ClauseBody -> FreeM VarMap #-}
- freeVars' (Body t) = freeVars' t
- freeVars' (Bind b) = freeVars' b
- freeVars' NoBody = mempty
-
instance Free' Clause c where
-- {-# SPECIALIZE instance Free' Clause All #-}
-- {-# SPECIALIZE freeVars' :: Clause -> FreeM Any #-}
-- {-# SPECIALIZE freeVars' :: Clause -> FreeM All #-}
-- {-# SPECIALIZE freeVars' :: Clause -> FreeM VarSet #-}
-- {-# SPECIALIZE freeVars' :: Clause -> FreeM VarMap #-}
- freeVars' = freeVars' . clauseBody
+ freeVars' cl = bind' (size $ clauseTel cl) $ freeVars' $ clauseBody cl
instance Free' EqualityView c where
freeVars' (OtherType t) = freeVars' t
freeVars' (EqualityType s _eq l t a b) = freeVars' s `mappend` freeVars' [l, t, a, b]
-
--- Generators
-
-instance Arbitrary FlexRig where
- arbitrary = oneof
- [ pure $ Flexible [] -- TODO
- , pure WeaklyRigid
- , pure Unguarded
- , pure StronglyRigid
- ]
-
-instance Arbitrary VarOcc where
- arbitrary = VarOcc <$> arbitrary <*> arbitrary
-
--- -}
diff --git a/src/full/Agda/TypeChecking/Free/Old.hs b/src/full/Agda/TypeChecking/Free/Old.hs
index 790460b..81daaac 100644
--- a/src/full/Agda/TypeChecking/Free/Old.hs
+++ b/src/full/Agda/TypeChecking/Free/Old.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-- | Computing the free variables of a term.
--
@@ -41,13 +40,14 @@ import Control.Applicative hiding (empty)
import Control.Monad.Reader
import Data.Foldable (foldMap)
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat)
import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Utils.Functor
import Agda.Utils.Monad
+import Agda.Utils.Size
import Agda.Utils.VarSet (VarSet)
import qualified Agda.Utils.VarSet as Set
@@ -173,9 +173,12 @@ empty :: FreeVars
empty = FV Set.empty Set.empty Set.empty Set.empty Set.empty Set.empty
-- | Free variable sets form a monoid under 'union'.
+instance Semigroup FreeVars where
+ (<>) = union
+
instance Monoid FreeVars where
mempty = empty
- mappend = union
+ mappend = (<>)
mconcat = unions
-- | @delete x fv@ deletes variable @x@ from variable set @fv@.
@@ -223,9 +226,12 @@ freeVarsIgnore i t = freeVars' t `runReader` initFreeConf{ fcIgnoreSorts = i }
-- | Return type of fold over syntax.
type FreeT = Reader FreeConf FreeVars
+instance Semigroup FreeT where
+ (<>) = liftA2 mappend
+
instance Monoid FreeT where
mempty = pure mempty
- mappend = liftA2 mappend
+ mappend = (<>)
mconcat = mconcat <.> sequence
-- | Base case: a variable.
@@ -236,7 +242,11 @@ variable n = do
-- | Going under a binder.
bind :: FreeT -> FreeT
-bind = local $ \ e -> e { fcContext = 1 + fcContext e }
+bind = bind' 1
+
+-- | Going under n binders.
+bind' :: Nat -> FreeT -> FreeT
+bind' n = local $ \ e -> e { fcContext = n + fcContext e }
class Free a where
freeVars' :: a -> FreeT
@@ -252,7 +262,7 @@ instance Free Term where
-- we cannot query whether we are dealing with a data/record (strongly r.)
-- or a definition by pattern matching (weakly rigid)
-- thus, we approximate, losing that x = List x is unsolvable
- Con c ts -> underConstructor c <$> freeVars' ts
+ Con c _ ts -> underConstructor c <$> freeVars' ts
-- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.
-- Even as we do not permit infinite type expressions,
-- we cannot prove their absence (as Set is not inductive).
@@ -326,13 +336,8 @@ instance Free a => Free (Tele a) where
freeVars' EmptyTel = mempty
freeVars' (ExtendTel a tel) = freeVars' (a, tel)
-instance Free ClauseBody where
- freeVars' (Body t) = freeVars' t
- freeVars' (Bind b) = freeVars' b
- freeVars' NoBody = mempty
-
instance Free Clause where
- freeVars' = freeVars' . clauseBody
+ freeVars' cl = bind' (size $ clauseTel cl) $ freeVars' $ clauseBody cl
freeIn :: Free a => Nat -> a -> Bool
freeIn v t = v `Set.member` allVars (freeVars t)
diff --git a/src/full/Agda/TypeChecking/Free/Tests.hs b/src/full/Agda/TypeChecking/Free/Tests.hs
deleted file mode 100644
index fe3a6cd..0000000
--- a/src/full/Agda/TypeChecking/Free/Tests.hs
+++ /dev/null
@@ -1,118 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
--- | Tests for free variable computations.
-
-module Agda.TypeChecking.Free.Tests (tests) where
-
-import qualified Data.IntMap as Map
-
-import Test.QuickCheck
-
-import Agda.Syntax.Common
-import Agda.Syntax.Internal
-
-import Agda.TypeChecking.Free.Lazy hiding (FlexRig(..))
-import qualified Agda.TypeChecking.Free.Lazy as Free
-
-import qualified Agda.TypeChecking.Free.Old as Old
-
-import Agda.TypeChecking.Free (freeIn)
-import qualified Agda.TypeChecking.Free as New
-
-import Agda.TypeChecking.Test.Generators
-import Agda.Utils.TestHelpers
-
--- * Properties of 'FlexRig'
-
--- | Ensure the correct linear order is derived.
-
---prop_FlexRig_min = minBound == Free.Flexible
-
-prop_FlexRig_order = strictlyAscending
- [ Free.Flexible [], Free.WeaklyRigid, Free.Unguarded, Free.StronglyRigid ]
-
-strictlyAscending l = and $ zipWith (<) l $ tail l
-
--- ** 'composeFlexRig' forms an idempotent commutative monoid with
--- unit 'Unguarded' and zero 'Flexible'
-
-prop_composeFlexRig_associative = associative composeFlexRig
-prop_composeFlexRig_commutative = commutative composeFlexRig
-prop_composeFlexRig_idempotent = idempotent composeFlexRig
-prop_composeFlexRig_zero = isZero (Free.Flexible []) composeFlexRig
-prop_composeFlexRig_unit = identity Free.Unguarded composeFlexRig
-
-prop_FlexRig_distributive = distributive composeFlexRig max
-
--- Not true (I did not expect it to be true, just for sanity I checked):
--- prop_FlexRig_distributive' = distributive max composeFlexRig
-
--- ** 'maxVarOcc'
-
-prop_maxVarOcc_top = isZero topVarOcc maxVarOcc
-prop_maxVarOcc_bot = identity botVarOcc maxVarOcc
-
--- * Unit tests
-
-prop_freeIn = all (0 `freeIn`)
- [ var 0
- , Lam defaultArgInfo $ Abs "x" $ var 1
- , Sort $ varSort 0
- ]
-
--- * Conformance with old implementation
-
-prop_old_freeVars_Pi = same_freeVars ty
-
-same_freeVars t = new_to_old_FV (New.freeVars t) == Old.freeVars t
-
-old_to_new_FV (Old.FV a b c d e f) = New.FV a b c (Map.fromSet (const []) d) e f
-new_to_old_FV (New.FV a b c d e f) = Old.FV a b c (Map.keysSet d) e f
-
-ty = Pi (defaultDom ab) $ Abs "x" $ El (Type $ Max []) $ var 5
- where
- a = El Prop $
- var 4
- b = El (Type $ Max []) $
- Sort $ Type $ Max []
- ab = El (Type $ Max [ClosedLevel 1]) $
- Pi (defaultDom a) (Abs "x" b)
-
-new_fv_ty :: New.FreeVars
-new_fv_ty = New.freeVars ty
-
-old_fv_ty :: Old.FreeVars
-old_fv_ty = Old.freeVars ty
-
-
-prop_old_freeVars_Term conf x = forAll (genC conf) $ \ (t :: Term) ->
- same_freeVars t
-
-prop_old_freeIn_Term conf x = forAll (genC conf) $ \ (t :: Term) ->
- New.freeIn x t == Old.freeIn x t
-prop_old_freeIn_Type conf x = forAll (genC conf) $ \ (t :: Type) ->
- New.freeIn x t == Old.freeIn x t
-
-
--- Template Haskell hack to make the following $quickCheckAll work
--- under ghc-7.8.
-return [] -- KEEP!
-
--- | All tests as collected by 'quickCheckAll'.
-tests :: IO Bool
-tests = do
- putStrLn "Agda.TypeChecking.Free.Tests"
- $quickCheckAll
diff --git a/src/full/Agda/TypeChecking/Implicit.hs b/src/full/Agda/TypeChecking/Implicit.hs
index 35282bb..3e09ef6 100644
--- a/src/full/Agda/TypeChecking/Implicit.hs
+++ b/src/full/Agda/TypeChecking/Implicit.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
{-| Functions for inserting implicit arguments at the right places.
-}
@@ -25,37 +24,68 @@ import Agda.Utils.Impossible
-- | @implicitArgs n expand eti t@ generates up to @n@ implicit arguments
-- metas (unbounded if @n<0@), as long as @t@ is a function type
--- and @expand@ holds on the hiding info of its domain. If @eti@ is
--- @ExplicitToInstance@, then explicit arguments are considered as instance
--- arguments.
+-- and @expand@ holds on the hiding info of its domain.
+--
+-- If explicit arguments are to be inserted as well, they are
+-- inserted as instance arguments (used for recursive instance search).
+
implicitArgs :: Int -> (Hiding -> Bool) -> Type -> TCM (Args, Type)
implicitArgs n expand t = mapFst (map (fmap namedThing)) <$> do
implicitNamedArgs n (\ h x -> expand h) t
-- | @implicitNamedArgs n expand eti t@ generates up to @n@ named implicit arguments
-- metas (unbounded if @n<0@), as long as @t@ is a function type
--- and @expand@ holds on the hiding and name info of its domain. If @eti@ is
--- @ExplicitToInstance@, then explicit arguments are considered as instance
--- arguments.
+-- and @expand@ holds on the hiding and name info of its domain.
+--
+-- If explicit arguments are to be inserted as well, they are
+-- inserted as instance arguments (used for recursive instance search).
+
implicitNamedArgs :: Int -> (Hiding -> ArgName -> Bool) -> Type -> TCM (NamedArgs, Type)
implicitNamedArgs 0 expand t0 = return ([], t0)
implicitNamedArgs n expand t0 = do
t0' <- reduce t0
case ignoreSharing $ unEl t0' of
Pi (Dom info a) b | let x = absName b, expand (getHiding info) x -> do
- when (getHiding info /= Hidden) $
+ info' <- if getHiding info == Hidden then return info else do
reportSDoc "tc.term.args.ifs" 15 $
- text "inserting instance meta for type" <+> prettyTCM a
- v <- applyRelevanceToContext (getRelevance info) $
- newMeta (getHiding info) (argNameToString x) a
+ text "inserting instance meta for type" <+> prettyTCM a
+ return $ setHiding Instance info
+ (_, v) <- newMetaArg info' x a
let narg = Arg info (Named (Just $ unranged x) v)
mapFst (narg :) <$> implicitNamedArgs (n-1) expand (absApp b v)
_ -> return ([], t0')
+
+-- | Create a metavariable according to the 'Hiding' info.
+
+newMetaArg
+ :: ArgInfo -- ^ Kind/relevance of meta.
+ -> ArgName -- ^ Name suggestion for meta.
+ -> Type -- ^ Type of meta.
+ -> TCM (MetaId, Term) -- ^ The created meta as id and as term.
+newMetaArg info x a = do
+ applyRelevanceToContext (getRelevance info) $
+ newMeta (getHiding info) (argNameToString x) a
+ where
+ newMeta :: Hiding -> String -> Type -> TCM (MetaId, Term)
+ newMeta Instance = newIFSMeta
+ newMeta Hidden = newNamedValueMeta RunMetaOccursCheck
+ newMeta NotHidden = newNamedValueMeta RunMetaOccursCheck
+
+-- | Create a questionmark according to the 'Hiding' info.
+
+newInteractionMetaArg
+ :: ArgInfo -- ^ Kind/relevance of meta.
+ -> ArgName -- ^ Name suggestion for meta.
+ -> Type -- ^ Type of meta.
+ -> TCM (MetaId, Term) -- ^ The created meta as id and as term.
+newInteractionMetaArg info x a = do
+ applyRelevanceToContext (getRelevance info) $
+ newMeta (getHiding info) (argNameToString x) a
where
- newMeta :: Hiding -> String -> Type -> TCM Term
- newMeta Hidden = newNamedValueMeta RunMetaOccursCheck
- newMeta Instance = newIFSMeta
- newMeta NotHidden = newIFSMeta
+ newMeta :: Hiding -> String -> Type -> TCM (MetaId, Term)
+ newMeta Instance = newIFSMeta
+ newMeta Hidden = newNamedValueMeta' DontRunMetaOccursCheck
+ newMeta NotHidden = newNamedValueMeta' DontRunMetaOccursCheck
---------------------------------------------------------------------------
diff --git a/src/full/Agda/TypeChecking/Injectivity.hs b/src/full/Agda/TypeChecking/Injectivity.hs
index a53b7b3..f447db1 100644
--- a/src/full/Agda/TypeChecking/Injectivity.hs
+++ b/src/full/Agda/TypeChecking/Injectivity.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Injectivity where
@@ -31,8 +30,9 @@ import Agda.TypeChecking.Constraints
import Agda.TypeChecking.Polarity
import Agda.Utils.Except ( MonadError(catchError, throwError) )
-import Agda.Utils.List
import Agda.Utils.Functor
+import Agda.Utils.List
+import Agda.Utils.Maybe
import Agda.Utils.Permutation
#include "undefined.h"
@@ -45,26 +45,28 @@ headSymbol v = do -- ignoreAbstractMode $ do
v <- ignoreBlocking <$> reduceHead v
case ignoreSharing v of
Def f _ -> do
+ let yes = return $ Just $ ConsHead f
+ no = return $ Nothing
def <- theDef <$> do ignoreAbstractMode $ getConstInfo f
-- Andreas, 2013-02-18
-- if we do not ignoreAbstractMode here, abstract Functions get turned
-- into Axioms, but we want to distinguish these.
case def of
- Datatype{} -> return (Just $ ConsHead f)
- Record{} -> return (Just $ ConsHead f)
+ Datatype{} -> yes
+ Record{} -> yes
Axiom{} -> do
reportSLn "tc.inj.axiom" 50 $ "headSymbol: " ++ show f ++ " is an Axiom."
-- Don't treat axioms in the current mutual block
-- as constructors (they might have definitions we
-- don't know about yet).
- fs <- lookupMutualBlock =<< currentOrFreshMutualBlock
- if Set.member f fs
- then return Nothing
- else return (Just $ ConsHead f)
- Function{} -> return Nothing
- Primitive{} -> return Nothing
+ caseMaybeM (asks envMutualBlock) yes $ \ mb -> do
+ fs <- mutualNames <$> lookupMutualBlock mb
+ if Set.member f fs then no else yes
+ Function{} -> no
+ Primitive{} -> no
Constructor{} -> __IMPOSSIBLE__
- Con c _ -> return (Just $ ConsHead $ conName c)
+ AbstractDefn -> __IMPOSSIBLE__
+ Con c _ _ -> return (Just $ ConsHead $ conName c)
Sort _ -> return (Just SortHead)
Pi _ _ -> return (Just PiHead)
Lit _ -> return Nothing -- handle literal heads as well? can't think of
@@ -86,7 +88,7 @@ checkInjectivity f cs
-- Is it pointless to use injectivity for this function?
pointLess [] = True
pointLess (_:_:_) = False
- pointLess [cl] = not $ any (properlyMatching . unArg) $ clausePats cl
+ pointLess [cl] = not $ any (properlyMatching . namedArg) $ namedClausePats cl
-- Andreas, 2014-06-12
-- If we only have record patterns, it is also pointless.
-- We need at least one proper match.
@@ -95,7 +97,7 @@ checkInjectivity f cs = do
-- Extract the head symbol of the rhs of each clause (skip absurd clauses)
es <- catMaybes <$> do
forM cs $ \ c -> do -- produces a list ...
- mapM ((,c) <.> headSymbol) $ getBodyUnraised c -- ... of maybes
+ mapM ((,c) <.> headSymbol) $ clauseBody c -- ... of maybes
let (hs, ps) = unzip es
reportSLn "tc.inj.check" 40 $ " right hand sides: " ++ show hs
if all isJust hs && distinct hs
@@ -105,7 +107,7 @@ checkInjectivity f cs = do
reportSDoc "tc.inj.check" 30 $ nest 2 $ vcat $
for (Map.toList inv) $ \ (h, c) ->
text (show h) <+> text "-->" <+>
- fsep (punctuate comma $ map (prettyTCM . unArg) $ clausePats c)
+ fsep (punctuate comma $ map (prettyTCM . namedArg) $ namedClausePats c)
return $ Inverse inv
else return NotInjective
@@ -183,7 +185,7 @@ useInjectivity cmp a u v = do
Nothing -> typeError $ UnequalTerms cmp u v a
Just cl@Clause{ clauseTel = tel } -> maybeAbort $ do
let ps = clausePats cl
- perm = clausePerm cl
+ perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl
-- These are what dot patterns should be instantiated at
ms <- map unArg <$> newTelMeta tel
reportSDoc "tc.inj.invert" 20 $ vcat
@@ -249,13 +251,13 @@ useInjectivity cmp a u v = do
sub <- ask
return $ applySubst sub v
- metaElim (Arg _ (ProjP p)) = return $ Proj p
+ metaElim (Arg _ (ProjP o p)) = lift $ lift $ Proj o <$> getOriginalProjection p
metaElim (Arg info p) = Apply . Arg info <$> metaPat p
metaArgs args = mapM (traverse $ metaPat . namedThing) args
metaPat (DotP v) = dotP v
metaPat (VarP _) = nextMeta
- metaPat (ConP c mt args) = Con c <$> metaArgs args
+ metaPat (ConP c mt args) = Con c (fromConPatternInfo mt) <$> metaArgs args
metaPat (LitP l) = return $ Lit l
metaPat ProjP{} = __IMPOSSIBLE__
diff --git a/src/full/Agda/TypeChecking/InstanceArguments.hs b/src/full/Agda/TypeChecking/InstanceArguments.hs
index bf49093..1698f91 100644
--- a/src/full/Agda/TypeChecking/InstanceArguments.hs
+++ b/src/full/Agda/TypeChecking/InstanceArguments.hs
@@ -1,13 +1,9 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
+{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.InstanceArguments where
-import Control.Applicative
+import Control.Applicative hiding (empty)
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Map as Map
@@ -24,6 +20,7 @@ import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Reduce
+import Agda.TypeChecking.Records
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Free
@@ -38,6 +35,7 @@ import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Functor
import Agda.Utils.Pretty (prettyShow)
+import Agda.Utils.Null (empty)
#include "undefined.h"
import Agda.Utils.Impossible
@@ -61,26 +59,58 @@ initialIFSCandidates t = do
getContextVars :: TCM [Candidate]
getContextVars = do
ctx <- getContext
- let vars = [ Candidate (var i) (raise (i + 1) t) ExplicitStayExplicit
+ let vars = [ Candidate (var i) (raise (i + 1) t) ExplicitStayExplicit (argInfoOverlappable info)
| (Dom info (x, t), i) <- zip ctx [0..]
, getHiding info == Instance
, not (unusableRelevance $ argInfoRelevance info)
]
+
+ -- {{}}-fields of variables are also candidates
+ let cxtAndTypes = [ (var i, snd $ unDom $ raise (i + 1) t) | (i, t) <- zip [0..] ctx ]
+ fields <- concat <$> mapM instanceFields (reverse cxtAndTypes)
+ reportSDoc "tc.instance.fields" 30 $ text "instance field candidates" $$ nest 2 (vcat
+ [ sep [ (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":"
+ , nest 2 $ prettyTCM t ] | Candidate v t _ overlap <- fields ])
+
-- get let bindings
env <- asks envLetBindings
env <- mapM (getOpen . snd) $ Map.toList env
- let lets = [ Candidate v t ExplicitStayExplicit
+ let lets = [ Candidate v t ExplicitStayExplicit False
| (v, Dom info t) <- env
, getHiding info == Instance
, not (unusableRelevance $ argInfoRelevance info)
]
- return $ vars ++ lets
+ return $ vars ++ fields ++ lets
+
+ etaExpand etaOnce t =
+ isEtaRecordType t >>= \case
+ Nothing | etaOnce -> do
+ isRecordType t >>= \case
+ Nothing -> return Nothing
+ Just (r, vs, _) -> do
+ m <- currentModule
+ -- Are we inside the record module? If so it's safe and desirable
+ -- to eta-expand once (issue #2320).
+ if qnameToList r `isPrefixOf` mnameToList m
+ then return (Just (r, vs))
+ else return Nothing
+ r -> return r
+
+ instanceFields = instanceFields' True
+ instanceFields' etaOnce (v, t) =
+ caseMaybeM (etaExpand etaOnce =<< reduce t) (return []) $ \ (r, pars) -> do
+ (tel, args) <- forceEtaExpandRecord r pars v
+ let types = map unDom $ applySubst (parallelS $ reverse $ map unArg args) (flattenTel tel)
+ fmap concat $ forM (zip args types) $ \ (arg, t) ->
+ ([ Candidate (unArg arg) t ExplicitStayExplicit (argInfoOverlappable $ argInfo arg)
+ | getHiding arg == Instance ] ++) <$>
+ instanceFields' False (unArg arg, t)
getScopeDefs :: QName -> TCM [Candidate]
getScopeDefs n = do
instanceDefs <- getInstanceDefs
rel <- asks envRelevance
- let qs = fromMaybe [] $ Map.lookup n instanceDefs
+ let qs = maybe [] Set.toList $ Map.lookup n instanceDefs
catMaybes <$> mapM (candidate rel) qs
candidate :: Relevance -> QName -> TCM (Maybe Candidate)
@@ -97,15 +127,15 @@ initialIFSCandidates t = do
args <- freeVarsToApply q
let v = case theDef def of
-- drop parameters if it's a projection function...
- Function{ funProjection = Just p } -> projDropPars p `apply` args
+ Function{ funProjection = Just p } -> projDropParsApply p ProjSystem args
-- Andreas, 2014-08-19: constructors cannot be declared as
-- instances (at least as of now).
-- I do not understand why the Constructor case is not impossible.
-- Ulf, 2014-08-20: constructors are always instances.
- Constructor{ conSrcCon = c } -> Con c []
+ Constructor{ conSrcCon = c } -> Con c ConOSystem []
_ -> Def q $ map Apply args
inScope <- isNameInScope q <$> getScope
- return $ Candidate v t ExplicitToInstance <$ guard inScope
+ return $ Candidate v t ExplicitToInstance False <$ guard inScope
where
-- unbound constant throws an internal error
handle (TypeError _ (Closure {clValue = InternalError _})) = return Nothing
@@ -151,15 +181,17 @@ findInScope' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Maybe MetaId))
findInScope' m cands = ifM (isFrozen m) (return (Just (cands, Nothing))) $ do
-- Andreas, 2013-12-28 issue 1003:
-- If instance meta is already solved, simply discard the constraint.
- ifM (isInstantiatedMeta m) (return Nothing) $ do
+ -- Ulf, 2016-12-06 issue 2325: But only if *fully* instantiated.
+ ifM (isFullyInstantiatedMeta m) (return Nothing) $ do
-- Andreas, 2015-02-07: New metas should be created with range of the
-- current instance meta, thus, we set the range.
mv <- lookupMeta m
setCurrentRange mv $ do
reportSLn "tc.instance" 15 $
"findInScope 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)
- reportSDoc "tc.instance" 70 $ nest 2 $ vcat
- [ sep [ prettyTCM v <+> text ":", nest 2 $ prettyTCM t ] | Candidate v t _ <- cands ]
+ reportSDoc "tc.instance" 60 $ nest 2 $ vcat
+ [ sep [ (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":"
+ , nest 2 $ prettyTCM t ] | Candidate v t _ overlap <- cands ]
t <- normalise =<< getMetaTypeInContext m
insidePi t $ \ t -> do
reportSDoc "tc.instance" 15 $ text "findInScope 3: t =" <+> prettyTCM t
@@ -167,7 +199,9 @@ findInScope' m cands = ifM (isFrozen m) (return (Just (cands, Nothing))) $ do
-- If one of the arguments of the typeclass is a meta which is not rigidly
-- constrained, then don’t do anything because it may loop.
- ifJustM (areThereNonRigidMetaArguments (unEl t)) (\ m -> return (Just (cands, Just m))) $ do
+ ifJustM (areThereNonRigidMetaArguments (unEl t)) (\ m -> do
+ reportSLn "tc.instance" 15 "aborting due to non-rigidly constrained metas"
+ return (Just (cands, Just m))) $ do
mcands <- checkCandidates m t cands
debugConstraints
@@ -178,7 +212,7 @@ findInScope' m cands = ifM (isFrozen m) (return (Just (cands, Nothing))) $ do
text "findInScope 5: not a single candidate found..."
typeError $ IFSNoCandidateInScope t
- Just [Candidate term t' _] -> do
+ Just [Candidate term t' _ _] -> do
reportSDoc "tc.instance" 15 $ vcat
[ text "findInScope 5: solved by instance search using the only candidate"
, nest 2 $ prettyTCM term
@@ -203,7 +237,7 @@ findInScope' m cands = ifM (isFrozen m) (return (Just (cands, Nothing))) $ do
insidePi :: Type -> (Type -> TCM a) -> TCM a
insidePi t ret =
case ignoreSharing $ unEl t of
- Pi a b -> addContext (absName b, a) $ insidePi (unAbs b) ret
+ Pi a b -> addContext' (absName b, a) $ insidePi (unAbs b) ret
Def{} -> ret t
Var{} -> ret t
Sort{} -> __IMPOSSIBLE__
@@ -270,7 +304,9 @@ areThereNonRigidMetaArguments t = case ignoreSharing t of
Def n args -> do
TelV tel _ <- telView . defType =<< getConstInfo n
let varOccs EmptyTel = []
- varOccs (ExtendTel _ btel) = occurrence 0 tel : varOccs tel
+ varOccs (ExtendTel a btel)
+ | getRelevance a == Irrelevant = WeaklyRigid : varOccs tel -- #2171: ignore irrelevant arguments
+ | otherwise = occurrence 0 tel : varOccs tel
where tel = unAbs btel
rigid StronglyRigid = True
rigid Unguarded = True
@@ -293,7 +329,7 @@ areThereNonRigidMetaArguments t = case ignoreSharing t of
where
areThereNonRigidMetaArgs :: Elims -> TCM (Maybe MetaId)
areThereNonRigidMetaArgs [] = return Nothing
- areThereNonRigidMetaArgs (Proj _ : xs) = areThereNonRigidMetaArgs xs
+ areThereNonRigidMetaArgs (Proj{} : xs) = areThereNonRigidMetaArgs xs
areThereNonRigidMetaArgs (Apply x : xs) = do
ifJustM (isNonRigidMeta $ unArg x) (return . Just) (areThereNonRigidMetaArgs xs)
@@ -302,7 +338,7 @@ areThereNonRigidMetaArguments t = case ignoreSharing t of
case ignoreSharing v of
Def _ es -> areThereNonRigidMetaArgs es
Var _ es -> areThereNonRigidMetaArgs es
- Con _ vs -> areThereNonRigidMetaArgs (map Apply vs)
+ Con _ _ vs-> areThereNonRigidMetaArgs (map Apply vs)
MetaV i _ -> ifM (isRigid i) (return Nothing) $ do
-- Ignore unconstrained level and size metas (#1865)
Def lvl [] <- ignoreSharing <$> primLevel
@@ -333,7 +369,13 @@ filterResetingState m cands f = disableDestructiveUpdate $ do
a <- instantiateFull =<< (`piApplyM` ctxArgs) =<< getMetaType m
return (ok, v, a)
result <- mapM (\c -> do bs <- localTCStateSaving (tryC c); return (c, bs)) cands
- let result' = [ (c, v, a, s) | (c, ((r, v, a), s)) <- result, r /= No ]
+
+ -- Check that there aren't any hard failures
+ case [ err | (_, ((HellNo err, _, _), _)) <- result ] of
+ err : _ -> throwError err
+ [] -> return ()
+
+ let result' = [ (c, v, a, s) | (c, ((r, v, a), s)) <- result, not (isNo r) ]
noMaybes = null [ Maybe | (_, ((Maybe, _, _), _)) <- result ]
-- It's not safe to compare maybes for equality because they might
-- not have instantiated at all.
@@ -345,9 +387,16 @@ filterResetingState m cands f = disableDestructiveUpdate $ do
-- Drop all candidates which are judgmentally equal to the first one.
-- This is sufficient to reduce the list to a singleton should all be equal.
dropSameCandidates :: MetaId -> [(Candidate, Term, Type, a)] -> TCM [(Candidate, Term, Type, a)]
-dropSameCandidates m cands = do
+dropSameCandidates m cands0 = do
metas <- Set.fromList . Map.keys <$> getMetaStore
let freshMetas x = not $ Set.null $ Set.difference (Set.fromList $ allMetas x) metas
+
+ -- Take overlappable candidates into account
+ let cands =
+ case partition (\ (c, _, _, _) -> candidateOverlappable c) cands0 of
+ (cand : _, []) -> [cand] -- only overlappable candidates: pick the first one
+ _ -> cands0 -- otherwise require equality
+
reportSDoc "tc.instance" 50 $ vcat
[ text "valid candidates:"
, nest 2 $ vcat [ if freshMetas (v, a) then text "(redacted)" else
@@ -372,8 +421,12 @@ dropSameCandidates m cands = do
{- else -} (\ _ -> return False)
`catchError` (\ _ -> return False)
-data YesNoMaybe = Yes | No | Maybe
- deriving (Show, Eq)
+data YesNoMaybe = Yes | No | Maybe | HellNo TCErr
+ deriving (Show)
+
+isNo :: YesNoMaybe -> Bool
+isNo No = True
+isNo _ = False
-- | Given a meta @m@ of type @t@ and a list of candidates @cands@,
-- @checkCandidates m t cands@ returns a refined list of valid candidates.
@@ -385,23 +438,32 @@ checkCandidates m t cands = disableDestructiveUpdate $
reportSDoc "tc.instance.candidates" 20 $ nest 2 $ text "target:" <+> prettyTCM t
reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat
[ text "candidates"
- , vcat [ text "-" <+> prettyTCM v <+> text ":" <+> prettyTCM t | Candidate v t _ <- cands ] ]
+ , vcat [ text "-" <+> (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":" <+> prettyTCM t
+ | Candidate v t _ overlap <- cands ] ]
cands' <- filterResetingState m cands (checkCandidateForMeta m t)
reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat
[ text "valid candidates"
- , vcat [ text "-" <+> prettyTCM v <+> text ":" <+> prettyTCM t | Candidate v t _ <- cands' ] ]
+ , vcat [ text "-" <+> (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":" <+> prettyTCM t
+ | Candidate v t _ overlap <- cands' ] ]
return cands'
where
anyMetaTypes :: [Candidate] -> TCM Bool
anyMetaTypes [] = return False
- anyMetaTypes (Candidate _ a _ : cands) = do
+ anyMetaTypes (Candidate _ a _ _ : cands) = do
a <- instantiate a
case ignoreSharing $ unEl a of
MetaV{} -> return True
_ -> anyMetaTypes cands
+ checkDepth :: Term -> Type -> TCM YesNoMaybe -> TCM YesNoMaybe
+ checkDepth c a k = locally eInstanceDepth succ $ do
+ d <- view eInstanceDepth
+ maxDepth <- maxInstanceSearchDepth
+ when (d > maxDepth) $ typeError $ InstanceSearchDepthExhausted c a maxDepth
+ k
+
checkCandidateForMeta :: MetaId -> Type -> Candidate -> TCM YesNoMaybe
- checkCandidateForMeta m t (Candidate term t' eti) = do
+ checkCandidateForMeta m t (Candidate term t' eti _) = checkDepth term t' $ do
-- Andreas, 2015-02-07: New metas should be created with range of the
-- current instance meta, thus, we set the range.
mv <- lookupMeta m
@@ -458,11 +520,20 @@ checkCandidates m t cands = disableDestructiveUpdate $
(return Yes)
(\ _ -> Maybe <$ reportSLn "tc.instance" 50 "assignment inconclusive")
+ hardFailure :: TCErr -> Bool
+ hardFailure (TypeError _ err) =
+ case clValue err of
+ InstanceSearchDepthExhausted{} -> True
+ _ -> False
+ hardFailure _ = False
+
handle :: TCErr -> TCM YesNoMaybe
- handle err = do
- reportSDoc "tc.instance" 50 $
- text "assignment failed:" <+> prettyTCM err
- return No
+ handle err
+ | hardFailure err = return $ HellNo err
+ | otherwise = do
+ reportSDoc "tc.instance" 50 $
+ text "assignment failed:" <+> prettyTCM err
+ return No
isIFSConstraint :: Constraint -> Bool
isIFSConstraint FindInScope{} = True
@@ -479,10 +550,10 @@ applyDroppingParameters :: Term -> Args -> TCM Term
applyDroppingParameters t vs = do
let fallback = return $ t `apply` vs
case ignoreSharing t of
- Con c [] -> do
+ Con c ci [] -> do
def <- theDef <$> getConInfo c
case def of
- Constructor {conPars = n} -> return $ Con c (genericDrop n vs)
+ Constructor {conPars = n} -> return $ Con c ci (genericDrop n vs)
_ -> __IMPOSSIBLE__
Def f [] -> do
mp <- isProjection f
@@ -490,6 +561,6 @@ applyDroppingParameters t vs = do
Just Projection{projIndex = n} -> do
case drop n vs of
[] -> return t
- u : us -> (`apply` us) <$> applyDef f u
+ u : us -> (`apply` us) <$> applyDef ProjPrefix f u
_ -> fallback
_ -> fallback
diff --git a/src/full/Agda/TypeChecking/Irrelevance.hs b/src/full/Agda/TypeChecking/Irrelevance.hs
index 0df6f70..2e71445 100644
--- a/src/full/Agda/TypeChecking/Irrelevance.hs
+++ b/src/full/Agda/TypeChecking/Irrelevance.hs
@@ -9,16 +9,13 @@ import Control.Monad.Reader
import qualified Data.Map as Map
-import Agda.Interaction.Options hiding (tests)
+import Agda.Interaction.Options
import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.TypeChecking.Monad
-import Agda.Utils.QuickCheck
-import Agda.Utils.TestHelpers
-
-- | data 'Relevance'
-- see "Agda.Syntax.Common".
@@ -48,17 +45,13 @@ workOnTypes cont = do
allowed <- optExperimentalIrrelevance <$> pragmaOptions
verboseBracket "tc.irr" 20 "workOnTypes" $ workOnTypes' allowed cont
--- | Call me if --experimental-irrelevance is set.
-doWorkOnTypes :: TCM a -> TCM a
-doWorkOnTypes = verboseBracket "tc.irr" 20 "workOnTypes" . workOnTypes' True
-
-- | Internal workhorse, expects value of --experimental-irrelevance flag
-- as argument.
workOnTypes' :: Bool -> TCM a -> TCM a
-workOnTypes' allowed cont =
- if allowed then
- liftTCM $ modifyContext (modifyContextEntries $ mapRelevance $ irrToNonStrict) cont
- else cont
+workOnTypes' experimental cont = modifyContext (modifyContextEntries $ mapRelevance f) cont
+ where
+ f | experimental = irrToNonStrict
+ | otherwise = nonStrictToRel
-- | (Conditionally) wake up irrelevant variables and make them relevant.
-- For instance,
@@ -84,18 +77,3 @@ applyRelevanceToContext rel =
-- may be used, so they are awoken before type checking the argument.
wakeIrrelevantVars :: TCM a -> TCM a
wakeIrrelevantVars = applyRelevanceToContext Irrelevant
-
-
-------------------------------------------------------------------------
--- * Tests
-------------------------------------------------------------------------
-
-prop_galois :: Relevance -> Relevance -> Relevance -> Bool
-prop_galois r x y =
- x `moreRelevant` (r `composeRelevance` y) ==
- (r `inverseComposeRelevance` x) `moreRelevant` y
-
-tests :: IO Bool
-tests = runTests "Agda.TypeChecking.Irrelevance"
- [ quickCheck' prop_galois
- ]
diff --git a/src/full/Agda/TypeChecking/Level.hs b/src/full/Agda/TypeChecking/Level.hs
index ac1020b..9295ea5 100644
--- a/src/full/Agda/TypeChecking/Level.hs
+++ b/src/full/Agda/TypeChecking/Level.hs
@@ -3,7 +3,9 @@
module Agda.TypeChecking.Level where
import Control.Applicative
+import Data.Maybe
import Data.List as List
+import Data.Traversable (Traversable,traverse)
import Agda.Syntax.Common
import Agda.Syntax.Internal
@@ -14,6 +16,7 @@ import Agda.TypeChecking.Reduce.Monad ()
import Agda.TypeChecking.Monad.Builtin
import Agda.Utils.Except ( MonadError(catchError) )
+import Agda.Utils.Monad ( tryMaybe )
#include "undefined.h"
import Agda.Utils.Impossible
@@ -29,10 +32,6 @@ data LevelKit = LevelKit
, zeroName :: QName
}
--- | Get the 'primLevel as a 'Term', if present.
-mlevel :: TCM (Maybe Term)
-mlevel = liftTCM $ (Just <$> primLevel) `catchError` \_ -> return Nothing
-
-- | Get the 'primLevel' as a 'Type'.
levelType :: TCM Type
levelType = El (mkType 0) <$> primLevel
@@ -40,13 +39,15 @@ levelType = El (mkType 0) <$> primLevel
levelSucFunction :: TCM (Term -> Term)
levelSucFunction = apply1 <$> primLevelSuc
-builtinLevelKit :: TCM (Maybe LevelKit)
-builtinLevelKit = liftTCM $ do
- level@(Def l []) <- ignoreSharing <$> primLevel
- zero@(Def z []) <- ignoreSharing <$> primLevelZero
- suc@(Def s []) <- ignoreSharing <$> primLevelSuc
- max@(Def m []) <- ignoreSharing <$> primLevelMax
- return $ Just $ LevelKit
+{-# SPECIALIZE builtinLevelKit :: TCM LevelKit #-}
+{-# SPECIALIZE builtinLevelKit :: ReduceM LevelKit #-}
+builtinLevelKit :: (HasBuiltins m) => m LevelKit
+builtinLevelKit = do
+ level@(Def l []) <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel
+ zero@(Def z []) <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero
+ suc@(Def s []) <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc
+ max@(Def m []) <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelMax
+ return $ LevelKit
{ lvlType = level
, lvlSuc = \ a -> suc `apply1` a
, lvlMax = \ a b -> max `applys` [a, b]
@@ -56,33 +57,30 @@ builtinLevelKit = liftTCM $ do
, maxName = m
, zeroName = z
}
- `catchError` \_ -> return Nothing
-- | Raises an error if no level kit is available.
-
requireLevels :: TCM LevelKit
-requireLevels = do
- mKit <- builtinLevelKit
- case mKit of
- Nothing -> sequence_ [primLevel, primLevelZero, primLevelSuc, primLevelMax] >> __IMPOSSIBLE__
- Just k -> return k
+requireLevels = builtinLevelKit
-unLevel :: Term -> TCM Term
+{-# SPECIALIZE unLevel :: Term -> TCM Term #-}
+{-# SPECIALIZE unLevel :: Term -> ReduceM Term #-}
+unLevel :: (HasBuiltins m) => Term -> m Term
unLevel (Level l) = reallyUnLevelView l
unLevel (Shared p) = unLevel (derefPtr p)
unLevel v = return v
{-# SPECIALIZE reallyUnLevelView :: Level -> TCM Term #-}
-reallyUnLevelView :: MonadTCM tcm => Level -> tcm Term
-reallyUnLevelView nv = liftTCM $ do
+{-# SPECIALIZE reallyUnLevelView :: Level -> ReduceM Term #-}
+reallyUnLevelView :: (HasBuiltins m) => Level -> m Term
+reallyUnLevelView nv = do
+ suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc
+ zer <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero
case nv of
- Max [] -> primLevelZero
+ Max [] -> return zer
Max [Plus 0 a] -> return $ unLevelAtom a
Max [a] -> do
- zer <- primLevelZero
- suc <- primLevelSuc
return $ unPlusV zer (apply1 suc) a
- _ -> (`unlevelWithKit` nv) <$> requireLevels
+ _ -> (`unlevelWithKit` nv) <$> builtinLevelKit
unlevelWithKit :: LevelKit -> Level -> Term
unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax = max } (Max as) =
@@ -96,16 +94,14 @@ unPlusV zer suc (ClosedLevel n) = foldr (.) id (genericReplicate n suc) zer
unPlusV _ suc (Plus n a) = foldr (.) id (genericReplicate n suc) (unLevelAtom a)
maybePrimCon :: TCM Term -> TCM (Maybe ConHead)
-maybePrimCon prim = liftTCM $ do
- Con c [] <- prim
- return (Just c)
- `catchError` \_ -> return Nothing
+maybePrimCon prim = tryMaybe $ do
+ Con c ci [] <- prim
+ return c
maybePrimDef :: TCM Term -> TCM (Maybe QName)
-maybePrimDef prim = liftTCM $ do
+maybePrimDef prim = tryMaybe $ do
Def f [] <- prim
- return (Just f)
- `catchError` \_ -> return Nothing
+ return f
levelView :: Term -> TCM Level
levelView a = do
@@ -116,29 +112,23 @@ levelView a = do
levelView' :: Term -> ReduceM Level
levelView' a = do
- msuc <- (getCon =<<) <$> getBuiltin' builtinLevelSuc
- mzer <- (getCon =<<) <$> getBuiltin' builtinLevelZero
- mmax <- (getDef =<<) <$> getBuiltin' builtinLevelMax
+ Def lzero [] <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero
+ Def lsuc [] <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc
+ Def lmax [] <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelMax
let view a = do
a <- reduce' a
case ignoreSharing a of
Level l -> return l
- Con s [arg]
- | Just s == msuc -> inc <$> view (unArg arg)
- Con z []
- | Just z == mzer -> return $ closed 0
+ Def s [Apply arg]
+ | s == lsuc -> inc <$> view (unArg arg)
+ Def z []
+ | z == lzero -> return $ closed 0
Def m [Apply arg1, Apply arg2]
- | Just m == mmax -> levelLub <$> view (unArg arg1) <*> view (unArg arg2)
- _ -> mkAtom a
+ | m == lmax -> levelLub <$> view (unArg arg1) <*> view (unArg arg2)
+ _ -> mkAtom a
v <- view a
return v
where
- getCon (Con c []) = Just c
- getCon _ = Nothing
-
- getDef (Def f []) = Just f
- getDef _ = Nothing
-
mkAtom a = do
b <- reduceB' a
return $ case ignoreSharing <$> b of
@@ -157,3 +147,12 @@ levelView' a = do
levelLub :: Level -> Level -> Level
levelLub (Max as) (Max bs) = levelMax $ as ++ bs
+
+subLevel :: Integer -> Level -> Maybe Level
+subLevel n (Max ls) = Max <$> traverse sub ls
+ where
+ sub :: PlusLevel -> Maybe PlusLevel
+ sub (ClosedLevel j) | j >= n = Just $ ClosedLevel $ j - n
+ | otherwise = Nothing
+ sub (Plus j l) | j >= n = Just $ Plus (j - n) l
+ | otherwise = Nothing
diff --git a/src/full/Agda/TypeChecking/LevelConstraints.hs b/src/full/Agda/TypeChecking/LevelConstraints.hs
index 5543fa9..b0f87e6 100644
--- a/src/full/Agda/TypeChecking/LevelConstraints.hs
+++ b/src/full/Agda/TypeChecking/LevelConstraints.hs
@@ -2,39 +2,60 @@
module Agda.TypeChecking.LevelConstraints ( simplifyLevelConstraint ) where
-import Agda.Syntax.Common (Nat)
+import Data.List as List
import Agda.Syntax.Internal
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Substitute
-import Agda.Utils.Size
+import Agda.TypeChecking.Free
+import Agda.Utils.Impossible
--- | @simplifyLevelConstraint n c cs@ turns an @c@ into an equality
+#include "undefined.h"
+
+-- | @simplifyLevelConstraint c cs@ turns an @c@ into an equality
-- constraint if it is an inequality constraint and the reverse
--- inequality is contained in @cs@. Number @n@ is the length
--- of the context @c@ is defined in.
-simplifyLevelConstraint :: Int -> Constraint -> Constraints -> Constraint
-simplifyLevelConstraint n new old =
+-- inequality is contained in @cs@.
+--
+-- The constraints doesn't necessarily have to live in the same context, but
+-- they do need to be universally quanitfied over the context. This function
+-- takes care of renaming variables when checking for matches.
+simplifyLevelConstraint :: Constraint -> [Constraint] -> Constraint
+simplifyLevelConstraint new old =
case inequalities new of
- [a :=< b] | elem (b' :=< a') leqs -> LevelCmp CmpEq (Max [a]) (Max [b])
- where (a', b') = raise (waterLevel - n) (a, b)
+ [a :=< b] | any (matchLeq (b :=< a)) leqs -> LevelCmp CmpEq (Max [a]) (Max [b])
_ -> new
where
- -- get the constraints plus their "waterLevels", i.e.,
- -- length of contexts they are defined in
- unClosure c = (size (envContext $ clEnv cl), clValue cl)
- where cl = theConstraint c
- (ns, ls) = unzip $ map unClosure old
- -- compute the common water level
- waterLevel :: Nat
- waterLevel = maximum (n:ns)
- -- raise deBruijn indices to largest context to
- -- enable comparing constraints under different contexts
- leqs = concatMap inequalities $ zipWith raise (map (waterLevel -) ns) ls
+ leqs = concatMap inequalities old
data Leq = PlusLevel :=< PlusLevel
deriving (Show, Eq)
+-- | Check if two inequality constraints are the same up to variable renaming.
+matchLeq :: Leq -> Leq -> Bool
+matchLeq (a :=< b) (c :=< d)
+ | length xs == length ys = (a, b) == applySubst rho (c, d)
+ | otherwise = False
+ where
+ free :: Free' a [Int] => a -> [Int]
+ free = nub . runFree ((:[]) . fst) IgnoreNot
+ xs = free (a, b)
+ ys = free (c, d)
+ rho = mkSub $ List.sort $ zip ys xs
+ mkSub = go 0
+ where
+ go _ [] = IdS
+ go y ren0@((y', x) : ren)
+ | y == y' = Var x [] :# go (y + 1) ren
+ | otherwise = Strengthen __IMPOSSIBLE__ $ go (y + 1) ren0
+
+-- | Turn a level constraint into a list of level inequalities, if possible.
+
inequalities :: Constraint -> [Leq]
+
+inequalities (LevelCmp CmpLeq (Max as) (Max [b])) = map (:=< b) as -- Andreas, 2016-09-28
+ -- Why was this most natural case missing?
+ -- See test/Succeed/LevelLeqGeq.agda for where it is useful!
+
+-- These are very special cases only, in no way complete:
inequalities (LevelCmp CmpEq (Max [a, b]) (Max [c]))
| a == c = [b :=< a]
| b == c = [a :=< b]
diff --git a/src/full/Agda/TypeChecking/MetaVars.hs b/src/full/Agda/TypeChecking/MetaVars.hs
index 781f249..89df8af 100644
--- a/src/full/Agda/TypeChecking/MetaVars.hs
+++ b/src/full/Agda/TypeChecking/MetaVars.hs
@@ -1,23 +1,23 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RelaxedPolyRec #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.MetaVars where
+import Prelude hiding (null)
+
import Control.Monad.Reader
import Data.Function
-import Data.List hiding (sort)
+import Data.List hiding (sort, null)
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Foldable as Fold
+import Agda.Syntax.Abstract.Name as A
import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Generic
+import Agda.Syntax.Position (killRange)
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
@@ -47,13 +47,15 @@ import Agda.Utils.Except
, runExceptT
)
+import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Size
import Agda.Utils.Tuple
import Agda.Utils.Permutation
-import Agda.Utils.Pretty (prettyShow)
+import Agda.Utils.Pretty ( prettyShow, render )
import qualified Agda.Utils.VarSet as Set
#include "undefined.h"
@@ -76,7 +78,6 @@ isBlockedTerm x = do
BlockedConst{} -> True
PostponedTypeCheckingProblem{} -> True
InstV{} -> False
- InstS{} -> False
Open{} -> False
OpenIFS{} -> False
reportSLn "tc.meta.blocked" 12 $
@@ -90,7 +91,6 @@ isEtaExpandable kinds x = do
Open{} -> True
OpenIFS{} -> notElem Records kinds
InstV{} -> False
- InstS{} -> False
BlockedConst{} -> False
PostponedTypeCheckingProblem{} -> False
@@ -98,7 +98,7 @@ isEtaExpandable kinds x = do
-- | Performing the meta variable assignment.
--
--- The instantiation should not be an 'InstV' or 'InstS' and the 'MetaId'
+-- The instantiation should not be an 'InstV' and the 'MetaId'
-- should point to something 'Open' or a 'BlockedConst'.
-- Further, the meta variable may not be 'Frozen'.
assignTerm :: MetaId -> [Arg ArgName] -> Term -> TCM ()
@@ -128,7 +128,7 @@ assignTerm' x tel v = do
-- dontAssignMetas $ do
-- checkInternal t . jMetaType . mvJudgement =<< lookupMeta x
- let i = metaInstance tel v
+ let i = metaInstance tel $ killRange v
verboseS "profile.metas" 10 $ liftTCM $ tickMax "max-open-metas" . size =<< getOpenMetas
modifyMetaStore $ ins x i
etaExpandListeners x
@@ -144,30 +144,42 @@ assignTerm' x tel v = do
-- * Creating meta variables.
+-- | Create a sort meta that cannot be instantiated with 'Inf' (Setω).
+newSortMetaBelowInf :: TCM Sort
+newSortMetaBelowInf = newSortMeta' $ HasType ()
+
+-- | Create a sort meta that may be instantiated with 'Inf' (Setω).
newSortMeta :: TCM Sort
-newSortMeta =
+newSortMeta = newSortMeta' $ IsSort ()
+
+newSortMeta' :: (Type -> Judgement ()) -> TCM Sort
+newSortMeta' judge =
ifM typeInType (return $ mkType 0) $ {- else -}
- ifM hasUniversePolymorphism (newSortMetaCtx =<< getContextArgs)
+ ifM hasUniversePolymorphism (newSortMetaCtx' judge =<< getContextArgs)
-- else (no universe polymorphism)
$ do i <- createMetaInfo
lvl <- levelType
- x <- newMeta i normalMetaPriority (idP 0) $ IsSort () lvl -- WAS: topSort
+ x <- newMeta i normalMetaPriority (idP 0) $ judge lvl
return $ Type $ Max [Plus 0 $ MetaLevel x []]
+-- | Create a sort meta that may be instantiated with 'Inf' (Setω).
newSortMetaCtx :: Args -> TCM Sort
-newSortMetaCtx vs =
+newSortMetaCtx = newSortMetaCtx' $ IsSort ()
+
+newSortMetaCtx' :: (Type -> Judgement ()) -> Args -> TCM Sort
+newSortMetaCtx' judge vs = do
ifM typeInType (return $ mkType 0) $ {- else -} do
i <- createMetaInfo
tel <- getContextTelescope
lvl <- levelType
- let t = telePi_ tel lvl -- WAS: topSort
- x <- newMeta i normalMetaPriority (idP 0) (IsSort () t)
+ let t = telePi_ tel lvl
+ x <- newMeta i normalMetaPriority (idP 0) $ judge t
reportSDoc "tc.meta.new" 50 $
text "new sort meta" <+> prettyTCM x <+> text ":" <+> prettyTCM t
return $ Type $ Max [Plus 0 $ MetaLevel x $ map Apply vs]
newTypeMeta :: Sort -> TCM Type
-newTypeMeta s = El s <$> newValueMeta RunMetaOccursCheck (sort s)
+newTypeMeta s = El s . snd <$> newValueMeta RunMetaOccursCheck (sort s)
newTypeMeta_ :: TCM Type
newTypeMeta_ = newTypeMeta =<< (workOnTypes $ newSortMeta)
@@ -180,15 +192,15 @@ newTypeMeta_ = newTypeMeta =<< (workOnTypes $ newSortMeta)
-- of type the output type of @t@ with name suggestion @s@.
-- If @t@ is a function type, then insert enough
-- lambdas in front of it.
-newIFSMeta :: MetaNameSuggestion -> Type -> TCM Term
+newIFSMeta :: MetaNameSuggestion -> Type -> TCM (MetaId, Term)
newIFSMeta s t = do
TelV tel t' <- telView t
- addCtxTel tel $ do
+ addContext tel $ do
vs <- getContextArgs
ctx <- getContextTelescope
- teleLam tel <$> newIFSMetaCtx s (telePi_ ctx t') vs
+ mapSnd (teleLam tel) <$> newIFSMetaCtx s (telePi_ ctx t') vs
-newIFSMetaCtx :: MetaNameSuggestion -> Type -> Args -> TCM Term
+newIFSMetaCtx :: MetaNameSuggestion -> Type -> Args -> TCM (MetaId, Term)
newIFSMetaCtx s t vs = do
reportSDoc "tc.meta.new" 50 $ fsep
[ text "new ifs meta:"
@@ -204,35 +216,42 @@ newIFSMetaCtx s t vs = do
]
addConstraint $ FindInScope x Nothing Nothing
etaExpandMetaSafe x
- return $ MetaV x $ map Apply vs
+ return (x, MetaV x $ map Apply vs)
--- | Create a new value meta with specific dependencies.
-newNamedValueMeta :: RunMetaOccursCheck -> MetaNameSuggestion -> Type -> TCM Term
+-- | Create a new value meta with specific dependencies, possibly η-expanding in the process.
+newNamedValueMeta :: RunMetaOccursCheck -> MetaNameSuggestion -> Type -> TCM (MetaId, Term)
newNamedValueMeta b s t = do
- v <- newValueMeta b t
- setValueMetaName v s
- return v
+ (x, v) <- newValueMeta b t
+ setMetaNameSuggestion x s
+ return (x, v)
+
+-- | Create a new value meta with specific dependencies without η-expanding.
+newNamedValueMeta' :: RunMetaOccursCheck -> MetaNameSuggestion -> Type -> TCM (MetaId, Term)
+newNamedValueMeta' b s t = do
+ (x, v) <- newValueMeta' b t
+ setMetaNameSuggestion x s
+ return (x, v)
-- | Create a new metavariable, possibly η-expanding in the process.
-newValueMeta :: RunMetaOccursCheck -> Type -> TCM Term
+newValueMeta :: RunMetaOccursCheck -> Type -> TCM (MetaId, Term)
newValueMeta b t = do
vs <- getContextArgs
tel <- getContextTelescope
newValueMetaCtx b t tel (idP $ size tel) vs
-newValueMetaCtx :: RunMetaOccursCheck -> Type -> Telescope -> Permutation -> Args -> TCM Term
+newValueMetaCtx :: RunMetaOccursCheck -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term)
newValueMetaCtx b t tel perm ctx =
- instantiateFull =<< newValueMetaCtx' b t tel perm ctx
+ mapSndM instantiateFull =<< newValueMetaCtx' b t tel perm ctx
-- | Create a new value meta without η-expanding.
-newValueMeta' :: RunMetaOccursCheck -> Type -> TCM Term
+newValueMeta' :: RunMetaOccursCheck -> Type -> TCM (MetaId, Term)
newValueMeta' b t = do
vs <- getContextArgs
tel <- getContextTelescope
newValueMetaCtx' b t tel (idP $ size tel) vs
-- | Create a new value meta with specific dependencies.
-newValueMetaCtx' :: RunMetaOccursCheck -> Type -> Telescope -> Permutation -> Args -> TCM Term
+newValueMetaCtx' :: RunMetaOccursCheck -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term)
newValueMetaCtx' b a tel perm vs = do
i <- createMetaInfo' b
let t = telePi_ tel a
@@ -246,7 +265,7 @@ newValueMetaCtx' b a tel perm vs = do
-- Andreas, 2012-09-24: for Metas X : Size< u add constraint X+1 <= u
u <- shared $ MetaV x $ map Apply vs
boundedSizeMetaHook u tel a
- return u
+ return (x, u)
newTelMeta :: Telescope -> TCM Args
newTelMeta tel = newArgsMeta (abstract tel $ typeDontCare)
@@ -273,7 +292,7 @@ newArgsMetaCtx' condition (El s tm) tel perm ctx = do
tm <- reduce tm
case ignoreSharing tm of
Pi dom@(Dom info a) codom | condition dom codom -> do
- u <- applyRelevanceToContext (getRelevance info) $
+ (_, u) <- applyRelevanceToContext (getRelevance info) $
{-
-- Andreas, 2010-09-24 skip irrelevant record fields when eta-expanding a meta var
-- Andreas, 2010-10-11 this is WRONG, see Issue 347
@@ -297,16 +316,26 @@ newRecordMetaCtx r pars tel perm ctx = do
ftel <- flip apply pars <$> getRecordFieldTypes r
fields <- newArgsMetaCtx (telePi_ ftel $ sort Prop) tel perm ctx
con <- getRecordConstructor r
- return $ Con con fields
+ return $ Con con ConOSystem fields
+
+newQuestionMark :: InteractionId -> Type -> TCM (MetaId, Term)
+newQuestionMark = newQuestionMark' $ newValueMeta' DontRunMetaOccursCheck
+
+newQuestionMark' :: (Type -> TCM (MetaId, Term)) -> InteractionId -> Type -> TCM (MetaId, Term)
+newQuestionMark' new ii t = do
+ -- Andreas, 2016-07-29, issue 1720-2
+ -- This is slightly risky, as the same interaction id
+ -- maybe be shared between different contexts.
+ -- Blame goes to the record processing hack, see issue #424
+ -- and @ConcreteToAbstract.recordConstructorType@.
+ let existing x = (x,) . MetaV x . map Apply <$> getContextArgs
+ flip (caseMaybeM $ lookupInteractionMeta ii) existing $ {-else-} do
-newQuestionMark :: InteractionId -> Type -> TCM Term
-newQuestionMark ii t = do
-- Do not run check for recursive occurrence of meta in definitions,
-- because we want to give the recursive solution interactively (Issue 589)
- m <- newValueMeta' DontRunMetaOccursCheck t
- MetaV x _ <- return $ ignoreSharing m -- needs to be strict!
+ (x, m) <- new t
connectInteractionPoint ii x
- return m
+ return (x, m)
-- | Construct a blocked constant if there are constraints.
blockTerm :: Type -> TCM Term -> TCM Term
@@ -338,10 +367,10 @@ blockTermOnProblem t v pid =
-- blocked terms can be instantiated before they are unblocked, thus making
-- constraint solving a bit more robust against instantiation order.
-- Andreas, 2015-05-22: DontRunMetaOccursCheck to avoid Issue585-17.
- v <- newValueMeta DontRunMetaOccursCheck t
+ (_, v) <- newValueMeta DontRunMetaOccursCheck t
i <- liftTCM fresh
-- This constraint is woken up when unblocking, so it doesn't need a problem id.
- cmp <- buildProblemConstraint 0 (ValueCmp CmpEq t v (MetaV x es))
+ cmp <- buildProblemConstraint_ (ValueCmp CmpEq t v (MetaV x es))
listenToMeta (CheckConstraint i cmp) x
return v
@@ -387,8 +416,8 @@ postponeTypeCheckingProblem p unblock = do
-- to run the extended occurs check (metaOccurs) to exclude
-- non-terminating solutions.
es <- map Apply <$> getContextArgs
- v <- newValueMeta DontRunMetaOccursCheck t
- cmp <- buildProblemConstraint 0 (ValueCmp CmpEq t v (MetaV m es))
+ (_, v) <- newValueMeta DontRunMetaOccursCheck t
+ cmp <- buildProblemConstraint_ (ValueCmp CmpEq t v (MetaV m es))
i <- liftTCM fresh
listenToMeta (CheckConstraint i cmp) m
addConstraint (UnBlock m)
@@ -609,23 +638,33 @@ assign dir x args v = do
-- Andreas, 2011-04-21 do the occurs check first
-- e.g. _1 x (suc x) = suc (_2 x y)
-- even though the lhs is not a pattern, we can prune the y from _2
- let relVL = Set.toList $ allRelevantVars args
-{- Andreas, 2012-04-02: DontCare no longer present
- -- take away top-level DontCare constructors
- args <- return $ map (fmap stripDontCare) args
--}
- -- Andreas, 2011-10-06 only irrelevant vars that are direct
- -- arguments to the meta, hence, can be abstracted over, may
- -- appear on the rhs. (test/fail/Issue483b)
- -- Update 2011-03-27: Also irr. vars under record constructors.
- let fromIrrVar (Var i []) = return [i]
- fromIrrVar (Con c vs) =
- ifM (isNothing <$> isRecordConstructor (conName c)) (return []) $
- concat <$> mapM (fromIrrVar . {- stripDontCare .-} unArg) vs
- fromIrrVar (Shared p) = fromIrrVar (derefPtr p)
- fromIrrVar _ = return []
- irrVL <- concat <$> mapM fromIrrVar
- [ v | Arg info v <- args, irrelevantOrUnused (getRelevance info) ]
+
+ (relVL, irrVL) <- do
+ -- Andreas, 2016-11-03 #2211 attempt to do s.th. for unused
+ if False -- irrelevantOrUnused $ getMetaRelevance mvar
+ then do
+ reportSDoc "tc.meta.assign" 25 $ text "meta is irrelevant or unused"
+ return (Set.toList $ allFreeVars args, empty)
+ else do
+ -- Andreas, 2016-11-03, issue #2211
+ -- treating UnusedArg as Irrelevant bears trouble
+ -- since the UnusedArg info is not consistently present
+ -- Thus, make sure we include the "unused" variables.
+ let relVL = Set.toList $ allRelevantOrUnusedVars args
+ -- Andreas, 2011-10-06 only irrelevant vars that are direct
+ -- arguments to the meta, hence, can be abstracted over, may
+ -- appear on the rhs. (test/fail/Issue483b)
+ -- Update 2011-03-27: Also irr. vars under record constructors.
+ let fromIrrVar (Var i []) = return [i]
+ fromIrrVar (Con c _ vs) =
+ ifM (isNothing <$> isRecordConstructor (conName c)) (return []) $
+ concat <$> mapM (fromIrrVar . {- stripDontCare .-} unArg) vs
+ fromIrrVar (Shared p) = fromIrrVar (derefPtr p)
+ fromIrrVar _ = return []
+ irrVL <- concat <$> mapM fromIrrVar
+ [ v | Arg info v <- args, isIrrelevant info ]
+ -- irrelevantOrUnused (getRelevance info) ]
+ return (relVL, irrVL)
reportSDoc "tc.meta.assign" 20 $
let pr (Var n []) = text (show n)
pr (Def c []) = prettyTCM c
@@ -677,7 +716,7 @@ assign dir x args v = do
Left NeutralArg -> Just <$> attemptPruning x args fvs
-- we have a projected variable which could not be eta-expanded away:
-- same as neutral
- Left (ProjectedVar i qs) -> Just <$> attemptPruning x args fvs
+ Left ProjectedVar{} -> Just <$> attemptPruning x args fvs
case mids of
Nothing -> patternViolation -- Ulf 2014-07-13: actually not needed after all: attemptInertRHSImprovement x args v
@@ -732,7 +771,7 @@ attemptInertRHSImprovement m args v = do
patternViolation
-- Solve the meta with _M := \ xs -> D (_Y1 xs) .. (_Yn xs), for fresh metas
-- _Yi.
- metaArgs <- inTopContext $ addCtxTel tel $ newArgsMeta a
+ metaArgs <- inTopContext $ addContext tel $ newArgsMeta a
let varArgs = map Apply $ reverse $ zipWith (\i a -> var i <$ a) [0..] (reverse args)
sol = mkRHS metaArgs
argTel = map ("x" <$) args
@@ -759,7 +798,7 @@ attemptInertRHSImprovement m args v = do
Just args -> return args
case ignoreSharing v of
Var x elims -> (, Var x . map Apply) <$> typeOfBV x
- Con c args -> notInert -- (, Con c) <$> defType <$> getConstInfo (conName c)
+ Con c ci args -> notInert -- (, Con c ci) <$> defType <$> getConstInfo (conName c)
Def f elims -> do
def <- getConstInfo f
let good = return (defType def, Def f . map Apply)
@@ -950,7 +989,7 @@ etaExpandProjectedVar i v fail succeed = do
class NoProjectedVar a where
noProjectedVar :: a -> Either ProjVarExc ()
-data ProjVarExc = ProjVarExc Int [QName]
+data ProjVarExc = ProjVarExc Int [(ProjOrigin, QName)]
-- ASR (17 June 2015). Unused Error instance.
-- instance Error ProjVarExc where
@@ -963,7 +1002,7 @@ instance NoProjectedVar Term where
| qs@(_:_) <- takeWhileJust id $ map isProjElim es -> Left $ ProjVarExc i qs
-- Andreas, 2015-09-12 Issue 1316:
-- Also look in inductive record constructors
- Con (ConHead _ Inductive (_:_)) vs -> noProjectedVar vs
+ Con (ConHead _ Inductive (_:_)) _ vs -> noProjectedVar vs
_ -> return ()
instance NoProjectedVar a => NoProjectedVar (Arg a) where
@@ -1026,7 +1065,7 @@ etaExpandProjectedVar mvar x t n qs = inTopContext $ do
-}
type FVs = Set.VarSet
-type SubstCand = [(Nat,Term)] -- ^ a possibly non-deterministic substitution
+type SubstCand = [(Int,Term)] -- ^ a possibly non-deterministic substitution
-- | Turn non-det substitution into proper substitution, if possible.
-- Otherwise, raise the error.
@@ -1053,7 +1092,7 @@ type Res = [(Arg Nat, Term)]
data InvertExcept
= CantInvert -- ^ Cannot recover.
| NeutralArg -- ^ A potentially neutral arg: can't invert, but can try pruning.
- | ProjectedVar Int [QName] -- ^ Try to eta-expand var to remove projs.
+ | ProjectedVar Int [(ProjOrigin, QName)] -- ^ Try to eta-expand var to remove projs.
#if !MIN_VERSION_transformers(0,4,1)
instance Error InvertExcept where
@@ -1095,18 +1134,24 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
-- (i, j) := x becomes [i := fst x, j := snd x]
-- Andreas, 2013-09-17 but only if constructor is fully applied
- Arg info (Con c vs) -> do
+ Arg info (Con c ci vs) -> do
let fallback
- | irrelevantOrUnused (getRelevance info) = return vars
+ | isIrrelevant info = return vars
+ -- Andreas, 2016-11-03, issue #2211
+ -- treating UnusedArg as Irrelevant bears trouble
+ -- since the UnusedArg info is not consistently present
+ -- irrelevantOrUnused (getRelevance info) = return vars
| otherwise = failure
isRC <- lift $ isRecordConstructor $ conName c
case isRC of
Just (_, Record{ recFields = fs })
| length fs == length vs -> do
- let aux (Arg _ v) (Arg info' f) = (Arg ai v,) $ t `applyE` [Proj f] where
+ let aux (Arg _ v) (Arg info' f) = (Arg ai v,) $ t `applyE` [Proj ProjSystem f] where
ai = ArgInfo
- { argInfoHiding = min (getHiding info) (getHiding info')
- , argInfoRelevance = max (getRelevance info) (getRelevance info')
+ { argInfoHiding = min (getHiding info) (getHiding info')
+ , argInfoRelevance = max (getRelevance info) (getRelevance info')
+ , argInfoOrigin = min (getOrigin info) (getOrigin info')
+ , argInfoOverlappable = False
}
res <- loop $ zipWith aux vs fs
return $ res `append` vars
@@ -1115,7 +1160,11 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
Nothing -> fallback
-- An irrelevant argument which is not an irrefutable pattern is dropped
- Arg info _ | irrelevantOrUnused (getRelevance info) -> return vars
+ Arg info _ | isIrrelevant info -> return vars
+ -- Andreas, 2016-11-03, issue #2211
+ -- treating UnusedArg as Irrelevant bears trouble
+ -- since the UnusedArg info is not consistently present
+ -- irrelevantOrUnused (getRelevance info) -> return vars
-- Andreas, 2013-10-29
-- An irrelevant part can also be marked by a DontCare
-- (coming from an irrelevant projection), see Issue 927:
@@ -1140,7 +1189,7 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
-- adding an irrelevant entry only if not present
cons :: (Arg Nat, Term) -> Res -> Res
- cons a@(Arg (ArgInfo _ Irrelevant) i, t) vars -- TODO? UnusedArg?!
+ cons a@(Arg (ArgInfo _ Irrelevant _ _) i, t) vars -- TODO? UnusedArg?!
| any ((i==) . unArg . fst) vars = vars
| otherwise = a : vars
-- adding a relevant entry:
@@ -1148,19 +1197,54 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
-- filter out duplicate irrelevants
filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars
--- | Used in 'Agda.Interaction.BasicOps.giveExpr'.
-updateMeta :: MetaId -> Term -> TCM ()
-updateMeta mI v = do
- mv <- lookupMeta mI
- withMetaInfo' mv $ do
- args <- getContextArgs
- noConstraints $ assignV DirEq mI args v
+-- UNUSED
+-- -- | Used in 'Agda.Interaction.BasicOps.giveExpr'.
+-- updateMeta :: MetaId -> Term -> TCM ()
+-- updateMeta mI v = do
+-- mv <- lookupMeta mI
+-- withMetaInfo' mv $ do
+-- args <- getContextArgs
+-- noConstraints $ assignV DirEq mI args v
--- | Returns every meta-variable occurrence in the given type, except
--- for those in 'Sort's.
-
-allMetas :: TermLike a => a -> [MetaId]
-allMetas = foldTerm metas
- where
- metas (MetaV m _) = [m]
- metas _ = []
+-- | Turn open metas into postulates.
+--
+-- Preconditions:
+--
+-- 1. We are 'inTopContext'.
+--
+-- 2. 'envCurrentModule' is set to the top-level module.
+--
+openMetasToPostulates :: TCM ()
+openMetasToPostulates = do
+ m <- asks envCurrentModule
+
+ -- Go through all open metas.
+ ms <- Map.assocs <$> use stMetaStore
+ forM_ ms $ \ (x, mv) -> do
+ when (isOpenMeta $ mvInstantiation mv) $ do
+ let t = jMetaType $ mvJudgement mv
+
+ -- Create a name for the new postulate.
+ let r = clValue $ miClosRange $ mvInfo mv
+ -- s <- render <$> prettyTCM x -- Using _ is a bad idea, as it prints as prefix op
+ let s = "unsolved#meta." ++ show (metaId x)
+ n <- freshName r s
+ let q = A.QName m n
+
+ -- Debug.
+ reportSDoc "meta.postulate" 20 $ vcat
+ [ text ("Turning " ++ if isSortMeta_ mv then "sort" else "value" ++ " meta ")
+ <+> prettyTCM x <+> text " into postulate."
+ , nest 2 $ vcat
+ [ text "Name: " <+> prettyTCM q
+ , text "Type: " <+> prettyTCM t
+ ]
+ ]
+
+ -- Add the new postulate to the signature.
+ addConstant q $ defaultDefn defaultArgInfo q t Axiom
+
+ -- Solve the meta.
+ let inst = InstV [] $ Def q []
+ stMetaStore %= Map.adjust (\ mv0 -> mv0 { mvInstantiation = inst }) x
+ return ()
diff --git a/src/full/Agda/TypeChecking/MetaVars.hs-boot b/src/full/Agda/TypeChecking/MetaVars.hs-boot
index fb309ad..c5a698a 100644
--- a/src/full/Agda/TypeChecking/MetaVars.hs-boot
+++ b/src/full/Agda/TypeChecking/MetaVars.hs-boot
@@ -12,8 +12,8 @@ assignTerm :: MetaId -> [Arg String] -> Term -> TCM ()
etaExpandMetaSafe :: MetaId -> TCM ()
assignV :: CompareDirection -> MetaId -> Args -> Term -> TCM ()
assign :: CompareDirection -> MetaId -> Args -> Term -> TCM ()
-newIFSMeta :: String -> Type -> TCM Term
-newValueMeta :: RunMetaOccursCheck -> Type -> TCM Term
-newNamedValueMeta :: RunMetaOccursCheck -> String -> Type -> TCM Term
+newIFSMeta :: String -> Type -> TCM (MetaId, Term)
+newValueMeta :: RunMetaOccursCheck -> Type -> TCM (MetaId, Term)
+newNamedValueMeta :: RunMetaOccursCheck -> String -> Type -> TCM (MetaId, Term)
+newNamedValueMeta':: RunMetaOccursCheck -> String -> Type -> TCM (MetaId, Term)
newTelMeta :: Telescope -> TCM Args
-allMetas :: TermLike a => a -> [MetaId]
diff --git a/src/full/Agda/TypeChecking/MetaVars/Mention.hs b/src/full/Agda/TypeChecking/MetaVars/Mention.hs
index 4a02019..36c960e 100644
--- a/src/full/Agda/TypeChecking/MetaVars/Mention.hs
+++ b/src/full/Agda/TypeChecking/MetaVars/Mention.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
module Agda.TypeChecking.MetaVars.Mention where
@@ -15,7 +14,7 @@ instance MentionsMeta Term where
Lam _ b -> mm b
Lit{} -> False
Def _ args -> mm args
- Con _ args -> mm args
+ Con _ _ args -> mm args
Pi a b -> mm (a, b)
Sort s -> mm s
Level l -> mm l
diff --git a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
index 6929950..29e699c 100644
--- a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
+++ b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE UndecidableInstances #-}
{- | The occurs check for unification. Does pruning on the fly.
@@ -25,6 +24,7 @@ import Data.Foldable (foldMap)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
+import Data.Traversable (traverse)
import qualified Agda.Benchmarking as Bench
@@ -37,6 +37,7 @@ import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Free hiding (Occurrence(..))
import Agda.TypeChecking.Substitute
+import Agda.TypeChecking.Datatypes
import Agda.TypeChecking.Records
import {-# SOURCE #-} Agda.TypeChecking.MetaVars
-- import Agda.TypeChecking.MetaVars
@@ -116,7 +117,7 @@ initOccursCheck mv = modifyOccursCheckDefs . const =<<
reportSLn "tc.meta.occurs" 20 $ "(none)"
return Set.empty
Just b -> do
- ds <- lookupMutualBlock b
+ ds <- mutualNames <$> lookupMutualBlock b
reportSDoc "tc.meta.occurs" 20 $ sep $ map prettyTCM $ Set.toList ds
return ds
@@ -130,11 +131,11 @@ tallyDef :: QName -> TCM ()
tallyDef d = modifyOccursCheckDefs $ \ s -> Set.delete d s
data OccursCtx
- = Flex -- ^ we are in arguments of a meta
- | Rigid -- ^ we are not in arguments of a meta but a bound var
- | StronglyRigid -- ^ we are at the start or in the arguments of a constructor
- | Top -- ^ we are at the term root (this turns into @StronglyRigid@)
- | Irrel -- ^ we are in an irrelevant argument
+ = Flex -- ^ We are in arguments of a meta.
+ | Rigid -- ^ We are not in arguments of a meta but a bound var.
+ | StronglyRigid -- ^ We are at the start or in the arguments of a constructor.
+ | Top -- ^ We are at the term root (this turns into @StronglyRigid@).
+ | Irrel -- ^ We are in an irrelevant argument.
deriving (Eq, Show)
data UnfoldStrategy = YesUnfold | NoUnfold
@@ -269,7 +270,7 @@ instance Occurs Term where
Lit l -> return v
DontCare v -> dontCare <$> occurs red Irrel m (goIrrelevant xs) v
Def d es -> Def d <$> occDef d (leaveTop ctx) es
- Con c vs -> Con c <$> occ (leaveTop ctx) vs -- if strongly rigid, remain so
+ Con c ci vs -> Con c ci <$> occ (leaveTop ctx) vs -- if strongly rigid, remain so
Pi a b -> uncurry Pi <$> occ (leaveTop ctx) (a,b)
Sort s -> Sort <$> occ (leaveTop ctx) s
v@Shared{} -> updateSharedTerm (occ ctx) v
@@ -316,12 +317,10 @@ instance Occurs Term where
-- a data or record type constructor propagates strong occurrences
-- since e.g. x = List x is unsolvable
occDef d ctx vs = do
- def <- theDef <$> getConstInfo d
- whenM (defNeedsChecking d) $ do
- tallyDef d
- reportSLn "tc.meta.occurs" 30 $ "Checking for occurrences in " ++ show d
- metaOccurs m def
- if (defIsDataOrRecord def) then (occ ctx vs) else (occ (defArgs red ctx) vs)
+ metaOccurs m d
+ ifM (isJust <$> isDataOrRecordType d)
+ {-then-} (occ ctx vs)
+ {-else-} (occ (defArgs red ctx) vs)
metaOccurs m v = do
v <- instantiate v
@@ -332,7 +331,7 @@ instance Occurs Term where
Lit l -> return ()
DontCare v -> metaOccurs m v
Def d vs -> metaOccurs m d >> metaOccurs m vs
- Con c vs -> metaOccurs m vs
+ Con c _ vs -> metaOccurs m vs
Pi a b -> metaOccurs m (a,b)
Sort s -> metaOccurs m s
Shared p -> metaOccurs m $ derefPtr p
@@ -345,7 +344,7 @@ instance Occurs QName where
metaOccurs m d = whenM (defNeedsChecking d) $ do
tallyDef d
reportSLn "tc.meta.occurs" 30 $ "Checking for occurrences in " ++ show d
- metaOccurs m . theDef =<< getConstInfo d
+ metaOccurs m . theDef =<< ignoreAbstractMode (getConstInfo d)
instance Occurs Defn where
occurs red ctx m xs def = __IMPOSSIBLE__
@@ -356,17 +355,15 @@ instance Occurs Defn where
-- we check the constructor types
metaOccurs m Datatype{ dataCons = cs } = mapM_ mocc cs
where mocc c = metaOccurs m . defType =<< getConstInfo c
- metaOccurs m Record{ recConType = v } = metaOccurs m v
+ metaOccurs m Record{ recConHead = c } = metaOccurs m . defType =<< getConstInfo (conName c)
metaOccurs m Constructor{} = return ()
metaOccurs m Primitive{} = return ()
+ metaOccurs m AbstractDefn{} = __IMPOSSIBLE__
instance Occurs Clause where
occurs red ctx m xs cl = __IMPOSSIBLE__
- metaOccurs m (Clause { clauseBody = body }) = walk body
- where walk NoBody = return ()
- walk (Body v) = metaOccurs m v
- walk (Bind b) = underAbstraction_ b walk
+ metaOccurs m = metaOccurs m . clauseBody
instance Occurs Level where
occurs red ctx m xs (Max as) = Max <$> occurs red ctx m xs as
@@ -465,6 +462,11 @@ instance Occurs a => Occurs [a] where
metaOccurs m ys = mapM_ (metaOccurs m) ys
+instance Occurs a => Occurs (Maybe a) where
+ occurs red ctx m mx my = traverse (occurs red ctx m mx) my
+
+ metaOccurs m = maybe (return ()) (metaOccurs m)
+
-- * Getting rid of flexible occurrences
-- | @prune m' vs xs@ attempts to remove all arguments from @vs@ whose
@@ -525,7 +527,7 @@ hasBadRigid xs t = do
-- offending variables under a constructor could be removed by
-- the right instantiation of the meta variable.
-- Thus, they are not rigid.
- Con c args -> do
+ Con c _ args -> do
ifM (liftTCM $ isEtaCon (conName c))
-- in case of a record con, we can in principle prune
-- (but not this argument; the meta could become a projection!)
@@ -542,7 +544,9 @@ isNeutral b f es = liftTCM $ do
let yes = return True
no = return False
def <- getConstInfo f
+ if defMatchable def then no else do
case theDef def of
+ AbstractDefn -> yes
Axiom{} -> yes
Datatype{} -> yes
Record{} -> yes
@@ -593,7 +597,7 @@ instance FoldRigid Term where
Blocked{} -> mempty
NotBlocked MissingClauses _ -> mempty
_ -> fold es
- Con _ ts -> fold ts
+ Con _ _ ts -> fold ts
Pi a b -> fold (a,b)
Sort s -> fold s
Level l -> fold l
diff --git a/src/full/Agda/TypeChecking/Monad.hs b/src/full/Agda/TypeChecking/Monad.hs
index ac9fb9c..349025b 100644
--- a/src/full/Agda/TypeChecking/Monad.hs
+++ b/src/full/Agda/TypeChecking/Monad.hs
@@ -5,6 +5,7 @@ module Agda.TypeChecking.Monad
, module Agda.TypeChecking.Monad.Context
, module Agda.TypeChecking.Monad.Env
, module Agda.TypeChecking.Monad.Imports
+ , module Agda.TypeChecking.Monad.Local
, module Agda.TypeChecking.Monad.MetaVars
, module Agda.TypeChecking.Monad.Mutual
, module Agda.TypeChecking.Monad.Open
@@ -24,6 +25,7 @@ import Agda.TypeChecking.Monad.Constraints
import Agda.TypeChecking.Monad.Context
import Agda.TypeChecking.Monad.Env
import Agda.TypeChecking.Monad.Imports
+import Agda.TypeChecking.Monad.Local
import Agda.TypeChecking.Monad.MetaVars
import Agda.TypeChecking.Monad.Mutual
import Agda.TypeChecking.Monad.Options
diff --git a/src/full/Agda/TypeChecking/Monad/Base.hs b/src/full/Agda/TypeChecking/Monad/Base.hs
index b225c01..6dba507 100644
--- a/src/full/Agda/TypeChecking/Monad/Base.hs
+++ b/src/full/Agda/TypeChecking/Monad/Base.hs
@@ -1,16 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -22,7 +13,7 @@ import qualified Control.Concurrent as C
import qualified Control.Exception as E
import Control.Monad.State
import Control.Monad.Reader
-import Control.Monad.Writer
+import Control.Monad.Writer hiding ((<>))
import Control.Monad.Trans.Maybe
import Control.Applicative hiding (empty)
@@ -36,8 +27,9 @@ import Data.Map (Map)
import qualified Data.Map as Map -- hiding (singleton, null, empty)
import Data.Set (Set)
import qualified Data.Set as Set -- hiding (singleton, null, empty)
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, Any(..))
import Data.Typeable (Typeable)
-import Data.Foldable
+import Data.Foldable (Foldable)
import Data.Traversable
import Data.IORef
@@ -53,6 +45,8 @@ import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract (AllNames)
import Agda.Syntax.Internal as I
import Agda.Syntax.Internal.Pattern ()
+import Agda.Syntax.Internal.Generic (TermLike(..))
+import Agda.Syntax.Parser (PM(..), ParseWarning, runPMIO)
import Agda.Syntax.Treeless (Compiled)
import Agda.Syntax.Fixity
import Agda.Syntax.Position
@@ -61,8 +55,8 @@ import qualified Agda.Syntax.Info as Info
import Agda.TypeChecking.CompiledClause
import Agda.TypeChecking.Positivity.Occurrence
+import Agda.TypeChecking.Free.Lazy (Free'(freeVars'), bind', bind)
-import Agda.Interaction.Exceptions
-- import {-# SOURCE #-} Agda.Interaction.FindFile
import Agda.Interaction.Options
import Agda.Interaction.Response
@@ -70,13 +64,13 @@ import Agda.Interaction.Response
import Agda.Interaction.Highlighting.Precise
(CompressedFile, HighlightingInfo)
-import qualified Agda.Compiler.JS.Syntax as JS
import qualified Agda.Compiler.UHC.Pragmas.Base as CR
import Agda.Utils.Except
( Error(strMsg)
, ExceptT
, MonadError(catchError, throwError)
+ , runExceptT
)
import Agda.Utils.Benchmark (MonadBench(..))
@@ -85,12 +79,14 @@ import Agda.Utils.HashMap (HashMap)
import qualified Agda.Utils.HashMap as HMap
import Agda.Utils.Hash
import Agda.Utils.Lens
+import Agda.Utils.List
import Agda.Utils.ListT
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Permutation
-import Agda.Utils.Pretty
+import Agda.Utils.Pretty hiding ((<>))
import Agda.Utils.Singleton
+import Agda.Utils.Functor
#include "undefined.h"
import Agda.Utils.Impossible
@@ -115,32 +111,35 @@ instance Show TCState where
show _ = "TCSt{}"
data PreScopeState = PreScopeState
- { stPreTokens :: CompressedFile -- from lexer
+ { stPreTokens :: !CompressedFile -- from lexer
-- ^ Highlighting info for tokens (but not those tokens for
-- which highlighting exists in 'stSyntaxInfo').
- , stPreImports :: Signature -- XX populated by scopec hecker
+ , stPreImports :: !Signature -- XX populated by scopec hecker
-- ^ Imported declared identifiers.
-- Those most not be serialized!
- , stPreImportedModules :: Set ModuleName -- imports logic
- , stPreModuleToSource :: ModuleToSource -- imports
- , stPreVisitedModules :: VisitedModules -- imports
- , stPreScope :: ScopeInfo
+ , stPreImportedModules :: !(Set ModuleName) -- imports logic
+ , stPreModuleToSource :: !ModuleToSource -- imports
+ , stPreVisitedModules :: !VisitedModules -- imports
+ , stPreScope :: !ScopeInfo
-- generated by scope checker, current file: which modules you have, public definitions, current file, maps concrete names to abstract names.
- , stPrePatternSyns :: A.PatternSynDefns
+ , stPrePatternSyns :: !A.PatternSynDefns
-- ^ Pattern synonyms of the current file. Serialized.
- , stPrePatternSynImports :: A.PatternSynDefns
+ , stPrePatternSynImports :: !A.PatternSynDefns
-- ^ Imported pattern synonyms. Must not be serialized!
- , stPrePragmaOptions :: PragmaOptions
+ , stPrePragmaOptions :: !PragmaOptions
-- ^ Options applying to the current file. @OPTIONS@
-- pragmas only affect this field.
- , stPreImportedBuiltins :: BuiltinThings PrimFun
- , stPreHaskellImports :: Set String
+ , stPreImportedBuiltins :: !(BuiltinThings PrimFun)
+ , stPreImportedDisplayForms :: !DisplayForms
+ -- ^ Display forms added by someone else to imported identifiers
+ , stPreImportedInstanceDefs :: !InstanceTable
+ , stPreHaskellImports :: !(Set String)
-- ^ Imports that should be generated by the compiler / MAlonzo
-- (this includes imports from imported modules).
- , stPreHaskellImportsUHC :: Set String
+ , stPreHaskellImportsUHC :: !(Set String)
-- ^ Imports that should be generated by the compiler / UHC backend
-- (this includes imports from imported modules).
- , stPreHaskellCode :: [String]
+ , stPreHaskellCode :: ![String]
-- ^ Inline Haskell code that should be inserted by the GHC backend
, stPreFreshInteractionId :: !InteractionId
}
@@ -148,48 +147,61 @@ data PreScopeState = PreScopeState
type DisambiguatedNames = IntMap A.QName
data PostScopeState = PostScopeState
- { stPostSyntaxInfo :: CompressedFile
+ { stPostSyntaxInfo :: !CompressedFile
-- ^ Highlighting info.
, stPostDisambiguatedNames :: !DisambiguatedNames
-- ^ Disambiguation carried out by the type checker.
-- Maps position of first name character to disambiguated @'A.QName'@
-- for each @'A.AmbiguousQName'@ already passed by the type checker.
- , stPostMetaStore :: MetaStore
- , stPostInteractionPoints :: InteractionPoints -- scope checker first
- , stPostAwakeConstraints :: Constraints
- , stPostSleepingConstraints :: Constraints
- , stPostDirty :: Bool -- local
+ , stPostMetaStore :: !MetaStore
+ , stPostInteractionPoints :: !InteractionPoints -- scope checker first
+ , stPostSolvedInteractionPoints :: !InteractionPoints
+ -- ^ Interaction points that have been filled by a give or solve action.
+ , stPostAwakeConstraints :: !Constraints
+ , stPostSleepingConstraints :: !Constraints
+ , stPostDirty :: !Bool -- local
-- ^ Dirty when a constraint is added, used to prevent pointer update.
-- Currently unused.
- , stPostOccursCheckDefs :: Set QName -- local
+ , stPostOccursCheckDefs :: !(Set QName) -- local
-- ^ Definitions to be considered during occurs check.
-- Initialized to the current mutual block before the check.
-- During occurs check, we remove definitions from this set
-- as soon we have checked them.
- , stPostSignature :: Signature
+ , stPostSignature :: !Signature
-- ^ Declared identifiers of the current file.
-- These will be serialized after successful type checking.
+ , stPostModuleParameters :: !ModuleParamDict
+ -- ^ TODO: can these be moved into the @TCEnv@?
, stPostImportsDisplayForms :: !DisplayForms
-- ^ Display forms we add for imported identifiers
- , stPostImportedDisplayForms :: !DisplayForms
- -- ^ Display forms added by someone else to imported identifiers
- , stPostCurrentModule :: Maybe ModuleName
+ , stPostCurrentModule :: !(Maybe ModuleName)
-- ^ The current module is available after it has been type
-- checked.
- , stPostInstanceDefs :: TempInstanceTable
- , stPostStatistics :: Statistics
+ , stPostInstanceDefs :: !TempInstanceTable
+ , stPostStatistics :: !Statistics
-- ^ Counters to collect various statistics about meta variables etc.
-- Only for current file.
- , stPostMutualBlocks :: Map MutualId (Set QName)
- , stPostLocalBuiltins :: BuiltinThings PrimFun
- , stPostFreshMetaId :: MetaId
- , stPostFreshMutualId :: MutualId
- , stPostFreshCtxId :: CtxId
- , stPostFreshProblemId :: ProblemId
- , stPostFreshInt :: Int
- , stPostFreshNameId :: NameId
+ , stPostTCWarnings :: ![TCWarning]
+ , stPostMutualBlocks :: !(Map MutualId MutualBlock)
+ , stPostLocalBuiltins :: !(BuiltinThings PrimFun)
+ , stPostFreshMetaId :: !MetaId
+ , stPostFreshMutualId :: !MutualId
+ , stPostFreshCtxId :: !CtxId
+ , stPostFreshProblemId :: !ProblemId
+ , stPostFreshInt :: !Int
+ , stPostFreshNameId :: !NameId
}
+-- | A mutual block of names in the signature.
+data MutualBlock = MutualBlock
+ { mutualInfo :: Info.MutualInfo
+ -- ^ The original info of the mutual block.
+ , mutualNames :: Set QName
+ } deriving (Show, Eq)
+
+instance Null MutualBlock where
+ empty = MutualBlock empty empty
+
-- | A part of the state which is not reverted when an error is thrown
-- or the state is reset.
data PersistentTCState = PersistentTCSt
@@ -266,6 +278,8 @@ initPreScopeState = PreScopeState
, stPrePatternSynImports = Map.empty
, stPrePragmaOptions = defaultInteractionOptions
, stPreImportedBuiltins = Map.empty
+ , stPreImportedDisplayForms = HMap.empty
+ , stPreImportedInstanceDefs = Map.empty
, stPreHaskellImports = Set.empty
, stPreHaskellImportsUHC = Set.empty
, stPreHaskellCode = []
@@ -278,16 +292,18 @@ initPostScopeState = PostScopeState
, stPostDisambiguatedNames = IntMap.empty
, stPostMetaStore = Map.empty
, stPostInteractionPoints = Map.empty
+ , stPostSolvedInteractionPoints = Map.empty
, stPostAwakeConstraints = []
, stPostSleepingConstraints = []
, stPostDirty = False
, stPostOccursCheckDefs = Set.empty
, stPostSignature = emptySignature
+ , stPostModuleParameters = Map.empty
, stPostImportsDisplayForms = HMap.empty
- , stPostImportedDisplayForms = HMap.empty
, stPostCurrentModule = Nothing
- , stPostInstanceDefs = (Map.empty , [])
+ , stPostInstanceDefs = (Map.empty , Set.empty)
, stPostStatistics = Map.empty
+ , stPostTCWarnings = []
, stPostMutualBlocks = Map.empty
, stPostLocalBuiltins = Map.empty
, stPostFreshMetaId = 0
@@ -403,6 +419,12 @@ stInteractionPoints f s =
f (stPostInteractionPoints (stPostScopeState s)) <&>
\x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}}
+stSolvedInteractionPoints :: Lens' InteractionPoints TCState
+stSolvedInteractionPoints f s =
+ f (stPostSolvedInteractionPoints (stPostScopeState s)) <&>
+ \ x -> s {stPostScopeState = (stPostScopeState s)
+ {stPostSolvedInteractionPoints = x}}
+
stAwakeConstraints :: Lens' Constraints TCState
stAwakeConstraints f s =
f (stPostAwakeConstraints (stPostScopeState s)) <&>
@@ -428,6 +450,11 @@ stSignature f s =
f (stPostSignature (stPostScopeState s)) <&>
\x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}}
+stModuleParameters :: Lens' (ModuleParamDict) TCState
+stModuleParameters f s =
+ f (stPostModuleParameters (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleParameters = x}}
+
stImportsDisplayForms :: Lens' DisplayForms TCState
stImportsDisplayForms f s =
f (stPostImportsDisplayForms (stPostScopeState s)) <&>
@@ -435,14 +462,19 @@ stImportsDisplayForms f s =
stImportedDisplayForms :: Lens' DisplayForms TCState
stImportedDisplayForms f s =
- f (stPostImportedDisplayForms (stPostScopeState s)) <&>
- \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportedDisplayForms = x}}
+ f (stPreImportedDisplayForms (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}}
stCurrentModule :: Lens' (Maybe ModuleName) TCState
stCurrentModule f s =
f (stPostCurrentModule (stPostScopeState s)) <&>
\x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = x}}
+stImportedInstanceDefs :: Lens' InstanceTable TCState
+stImportedInstanceDefs f s =
+ f (stPreImportedInstanceDefs (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}}
+
stInstanceDefs :: Lens' TempInstanceTable TCState
stInstanceDefs f s =
f (stPostInstanceDefs (stPostScopeState s)) <&>
@@ -453,7 +485,12 @@ stStatistics f s =
f (stPostStatistics (stPostScopeState s)) <&>
\x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}}
-stMutualBlocks :: Lens' (Map MutualId (Set QName)) TCState
+stTCWarnings :: Lens' [TCWarning] TCState
+stTCWarnings f s =
+ f (stPostTCWarnings (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}}
+
+stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState
stMutualBlocks f s =
f (stPostMutualBlocks (stPostScopeState s)) <&>
\x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}}
@@ -595,6 +632,11 @@ type ModuleToSource = Map TopLevelModuleName AbsolutePath
type SourceToModule = Map AbsolutePath TopLevelModuleName
-- | Creates a 'SourceToModule' map based on 'stModuleToSource'.
+--
+-- O(n log n).
+--
+-- For a single reverse lookup in 'stModuleToSource',
+-- rather use 'lookupModuleFromSourse'.
sourceToModule :: TCM SourceToModule
sourceToModule =
@@ -603,6 +645,14 @@ sourceToModule =
. Map.toList
<$> use stModuleToSource
+-- | Lookup an 'AbsolutePath' in 'sourceToModule'.
+--
+-- O(n).
+
+lookupModuleFromSource :: AbsolutePath -> TCM (Maybe TopLevelModuleName)
+lookupModuleFromSource f =
+ fmap fst . List.find ((f ==) . snd) . Map.toList <$> use stModuleToSource
+
---------------------------------------------------------------------------
-- ** Interface
---------------------------------------------------------------------------
@@ -686,12 +736,18 @@ iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)
-- ** Closure
---------------------------------------------------------------------------
-data Closure a = Closure { clSignature :: Signature
- , clEnv :: TCEnv
- , clScope :: ScopeInfo
- , clValue :: a
- }
- deriving (Typeable)
+data Closure a = Closure
+ { clSignature :: Signature
+ , clEnv :: TCEnv
+ , clScope :: ScopeInfo
+ , clModuleParameters :: ModuleParamDict
+ -- ^ Since module parameters are currently stored in 'TCState'
+ -- not in 'TCEnv', we save them here.
+ -- The map contains for each 'ModuleName' @M@ with module telescope @Γ_M@
+ -- a substitution @Γ ⊢ ρ_M : Γ_M@ from the current context @Γ = envContext (clEnv)@.
+ , clValue :: a
+ }
+ deriving (Typeable, Functor, Foldable)
instance Show a => Show (Closure a) where
show cl = "Closure " ++ show (clValue cl)
@@ -704,7 +760,8 @@ buildClosure x = do
env <- ask
sig <- use stSignature
scope <- use stScope
- return $ Closure sig env scope x
+ pars <- use stModuleParameters
+ return $ Closure sig env scope pars x
---------------------------------------------------------------------------
-- ** Constraints
@@ -758,6 +815,38 @@ instance HasRange Constraint where
getRange (FindInScope x cands) = getRange x
-}
+instance Free' Constraint c where
+ freeVars' c =
+ case c of
+ ValueCmp _ t u v -> freeVars' (t, (u, v))
+ ElimCmp _ t u es es' -> freeVars' ((t, u), (es, es'))
+ TypeCmp _ t t' -> freeVars' (t, t')
+ TelCmp _ _ _ tel tel' -> freeVars' (tel, tel')
+ SortCmp _ s s' -> freeVars' (s, s')
+ LevelCmp _ l l' -> freeVars' (l, l')
+ UnBlock _ -> mempty
+ Guarded c _ -> freeVars' c
+ IsEmpty _ t -> freeVars' t
+ CheckSizeLtSat u -> freeVars' u
+ FindInScope _ _ cs -> freeVars' cs
+
+instance TermLike Constraint where
+ foldTerm f = \case
+ ValueCmp _ t u v -> foldTerm f (t, u, v)
+ ElimCmp _ t u es es' -> foldTerm f (t, u, es, es')
+ TypeCmp _ t t' -> foldTerm f (t, t')
+ LevelCmp _ l l' -> foldTerm f (l, l')
+ IsEmpty _ t -> foldTerm f t
+ CheckSizeLtSat u -> foldTerm f u
+ TelCmp _ _ _ tel1 tel2 -> __IMPOSSIBLE__ -- foldTerm f (tel1, tel2) -- Not yet implemented
+ SortCmp _ s1 s2 -> __IMPOSSIBLE__ -- foldTerm f (s1, s2) -- Not yet implemented
+ UnBlock _ -> __IMPOSSIBLE__ -- mempty -- Not yet implemented
+ Guarded c _ -> __IMPOSSIBLE__ -- foldTerm c -- Not yet implemented
+ FindInScope _ _ cs -> __IMPOSSIBLE__ -- Not yet implemented
+ traverseTerm f c = __IMPOSSIBLE__ -- Not yet implemented
+ traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented
+
+
data Comparison = CmpEq | CmpLeq
deriving (Eq, Typeable)
@@ -811,6 +900,22 @@ dirToCmp cont DirGeq = flip $ cont CmpLeq
data Open a = OpenThing { openThingCtxIds :: [CtxId], openThing :: a }
deriving (Typeable, Show, Functor)
+instance Decoration Open where
+ traverseF f (OpenThing cxt x) = OpenThing cxt <$> f x
+
+data Local a = Local ModuleName a -- ^ Local to a given module, the value
+ -- should have module parameters as free variables.
+ | Global a -- ^ Global value, should be closed.
+ deriving (Typeable, Show, Functor, Foldable, Traversable)
+
+isGlobal :: Local a -> Bool
+isGlobal Global{} = True
+isGlobal Local{} = False
+
+instance Decoration Local where
+ traverseF f (Local m x) = Local m <$> f x
+ traverseF f (Global x) = Global <$> f x
+
---------------------------------------------------------------------------
-- * Judgements
--
@@ -871,7 +976,6 @@ data Frozen
data MetaInstantiation
= InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables)
- | InstS Term -- ^ solved by @Lam .. Sort s@
| Open -- ^ unsolved
| OpenIFS -- ^ open, to be instantiated as "implicit from scope"
| BlockedConst Term -- ^ solution blocked by unsolved constraints
@@ -894,7 +998,6 @@ data TypeCheckingProblem
instance Show MetaInstantiation where
show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")"
- show (InstS s) = "InstS (" ++ show s ++ ")"
show Open = "Open"
show OpenIFS = "OpenIFS"
show (BlockedConst t) = "BlockedConst (" ++ show t ++ ")"
@@ -984,6 +1087,9 @@ getMetaRelevance = envRelevance . getMetaEnv
data InteractionPoint = InteractionPoint
{ ipRange :: Range -- ^ The position of the interaction point.
, ipMeta :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc.
+ , ipClause:: IPClause
+ -- ^ The clause of the interaction point (if any).
+ -- Used for case splitting.
}
instance Eq InteractionPoint where (==) = (==) `on` ipMeta
@@ -991,6 +1097,19 @@ instance Eq InteractionPoint where (==) = (==) `on` ipMeta
-- | Data structure managing the interaction points.
type InteractionPoints = Map InteractionId InteractionPoint
+-- | Which clause is an interaction point located in?
+data IPClause = IPClause
+ { ipcQName :: QName -- ^ The name of the function.
+ , ipcClauseNo :: Int -- ^ The number of the clause of this function.
+ , ipcClause :: A.RHS -- ^ The original AST clause rhs.
+ }
+ | IPNoClause -- ^ The interaction point is not in the rhs of a clause.
+
+instance Eq IPClause where
+ IPNoClause == IPNoClause = True
+ IPClause x i _ == IPClause x' i' _ = x == x' && i == i'
+ _ == _ = False
+
---------------------------------------------------------------------------
-- ** Signature
---------------------------------------------------------------------------
@@ -1020,7 +1139,7 @@ sigRewriteRules f s =
type Sections = Map ModuleName Section
type Definitions = HashMap QName Definition
type RewriteRuleMap = HashMap QName RewriteRules
-type DisplayForms = HashMap QName [Open DisplayForm]
+type DisplayForms = HashMap QName [LocalDisplayForm]
data Section = Section { _secTelescope :: Telescope }
deriving (Typeable, Show)
@@ -1049,25 +1168,29 @@ emptySignature = Sig Map.empty HMap.empty HMap.empty
data DisplayForm = Display
{ dfFreeVars :: Nat
-- ^ Number @n@ of free variables in 'dfRHS'.
- , dfPats :: [Term]
+ , dfPats :: Elims
-- ^ Left hand side patterns, where @var 0@ stands for a pattern
-- variable. There should be @n@ occurrences of @var0@ in
-- 'dfPats'.
+ -- The 'ArgInfo' is ignored in these patterns.
, dfRHS :: DisplayTerm
-- ^ Right hand side, with @n@ free variables.
}
deriving (Typeable, Show)
+type LocalDisplayForm = Local DisplayForm
+
-- | A structured presentation of a 'Term' for reification into
-- 'Abstract.Syntax'.
data DisplayTerm
- = DWithApp DisplayTerm [DisplayTerm] Args
- -- ^ @(f vs | ws) us@.
+ = DWithApp DisplayTerm [DisplayTerm] Elims
+ -- ^ @(f vs | ws) es@.
-- The first 'DisplayTerm' is the parent function @f@ with its args @vs@.
-- The list of 'DisplayTerm's are the with expressions @ws@.
- -- The 'Args' are additional arguments @us@
- -- (possible in case the with-application is of function type).
- | DCon ConHead [Arg DisplayTerm]
+ -- The 'Elims' are additional arguments @es@
+ -- (possible in case the with-application is of function type)
+ -- or projections (if it is of record type).
+ | DCon ConHead ConInfo [Arg DisplayTerm]
-- ^ @c vs@.
| DDef QName [Elim' DisplayTerm]
-- ^ @d vs@.
@@ -1077,8 +1200,18 @@ data DisplayTerm
-- ^ @v@.
deriving (Typeable, Show)
+instance Free' DisplayForm c where
+ freeVars' (Display n ps t) = bind (freeVars' ps) `mappend` bind' n (freeVars' t)
+
+instance Free' DisplayTerm c where
+ freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es))
+ freeVars' (DCon _ _ vs) = freeVars' vs
+ freeVars' (DDef _ es) = freeVars' es
+ freeVars' (DDot v) = freeVars' v
+ freeVars' (DTerm v) = freeVars' v
+
-- | By default, we have no display form.
-defaultDisplayForm :: QName -> [Open DisplayForm]
+defaultDisplayForm :: QName -> [LocalDisplayForm]
defaultDisplayForm c = []
defRelevance :: Definition -> Relevance
@@ -1086,15 +1219,16 @@ defRelevance = argInfoRelevance . defArgInfo
-- | Non-linear (non-constructor) first-order pattern.
data NLPat
- = PVar (Maybe CtxId) !Int
- -- ^ Matches anything (modulo non-linearity).
+ = PVar (Maybe CtxId) !Int [Arg Int]
+ -- ^ Matches anything (modulo non-linearity) that only contains bound
+ -- variables that occur in the given arguments.
| PWild
-- ^ Matches anything (e.g. irrelevant terms).
| PDef QName PElims
-- ^ Matches @f es@
| PLam ArgInfo (Abs NLPat)
-- ^ Matches @λ x → t@
- | PPi (Dom (Type' NLPat)) (Abs (Type' NLPat))
+ | PPi (Dom NLPType) (Abs NLPType)
-- ^ Matches @(x : A) → B@
| PBoundVar {-# UNPACK #-} !Int PElims
-- ^ Matches @x es@ where x is a lambda-bound variable
@@ -1103,14 +1237,20 @@ data NLPat
deriving (Typeable, Show)
type PElims = [Elim' NLPat]
+data NLPType = NLPType
+ { nlpTypeLevel :: NLPat -- always PWild or PVar (with all bound variables in scope)
+ , nlpTypeUnEl :: NLPat
+ } deriving (Typeable, Show)
+
type RewriteRules = [RewriteRule]
-- | Rewrite rules can be added independently from function clauses.
data RewriteRule = RewriteRule
- { rewName :: QName -- ^ Name of rewrite rule @q : Γ → lhs ≡ rhs@
+ { rewName :: QName -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@
-- where @≡@ is the rewrite relation.
, rewContext :: Telescope -- ^ @Γ@.
- , rewLHS :: NLPat -- ^ @Γ ⊢ lhs : t@.
+ , rewHead :: QName -- ^ @f@.
+ , rewPats :: PElims -- ^ @Γ ⊢ ps : t@.
, rewRHS :: Term -- ^ @Γ ⊢ rhs : t@.
, rewType :: Type -- ^ @Γ ⊢ t@.
}
@@ -1166,7 +1306,7 @@ data Definition = Defn
-- 23, 3
-- 27, 1
- , defDisplay :: [Open DisplayForm]
+ , defDisplay :: [LocalDisplayForm]
, defMutual :: MutualId
, defCompiledRep :: CompiledRepresentation
, defInstance :: Maybe QName
@@ -1174,10 +1314,15 @@ data Definition = Defn
, defCopy :: Bool
-- ^ Has this function been created by a module
-- instantiation?
+ , defMatchable :: Bool
+ -- ^ Is the def matched against in a rewrite rule?
, theDef :: Defn
}
deriving (Typeable, Show)
+theDefLens :: Lens' Defn Definition
+theDefLens f d = f (theDef d) <&> \ df -> d { theDef = df }
+
-- | Create a definition with sensible defaults.
defaultDefn :: ArgInfo -> QName -> Type -> Defn -> Definition
defaultDefn info x t def = Defn
@@ -1191,13 +1336,14 @@ defaultDefn info x t def = Defn
, defCompiledRep = noCompiledRep
, defInstance = Nothing
, defCopy = False
+ , defMatchable = False
, theDef = def
}
type HaskellCode = String
type HaskellType = String
type EpicCode = String
-type JSCode = JS.Exp
+type JSCode = String
data HaskellRepresentation
= HsDefn HaskellType HaskellCode
@@ -1240,19 +1386,21 @@ data ExtLamInfo = ExtLamInfo
-- | Additional information for projection 'Function's.
data Projection = Projection
- { projProper :: Maybe QName
- -- ^ @Nothing@ if only projection-like, @Just q@ if record projection,
- -- where @q@ is the original projection name
- -- (current name could be from module app).
- , projFromType :: QName
- -- ^ Type projected from. Record type if @projProper = Just{}@.
+ { projProper :: Bool
+ -- ^ @False@ if only projection-like, @True@ if record projection.
+ , projOrig :: QName
+ -- ^ The original projection name
+ -- (current name could be from module application).
+ , projFromType :: Arg QName
+ -- ^ Type projected from. Record type if @projProper = Just{}@. Also
+ -- stores @ArgInfo@ of the principal argument.
, projIndex :: Int
-- ^ Index of the record argument.
-- Start counting with 1, because 0 means that
-- it is already applied to the record value.
-- This can happen in module instantiation, but
-- then either the record value is @var 0@, or @funProjection == Nothing@.
- , projDropPars :: Term
+ , projLams :: ProjLams
-- ^ Term @t@ to be be applied to record parameters and record value.
-- The parameters will be dropped.
-- In case of a proper projection, a postfix projection application
@@ -1260,22 +1408,56 @@ data Projection = Projection
-- (Invariant: the number of abstractions equals 'projIndex'.)
-- In case of a projection-like function, just the function symbol
-- is returned as 'Def': @t = \ pars -> f@.
- , projArgInfo :: ArgInfo
- -- ^ The info of the principal (record) argument.
} deriving (Typeable, Show)
-data EtaEquality = Specified !Bool | Inferred !Bool deriving (Typeable,Show)
+-- | Abstractions to build projection function (dropping parameters).
+newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }
+ deriving (Typeable, Show, Null)
+
+-- | Building the projection function (which drops the parameters).
+projDropPars :: Projection -> ProjOrigin -> Term
+-- Proper projections:
+projDropPars (Projection True d _ _ lams) o =
+ case initLast $ getProjLams lams of
+ Nothing -> Def d []
+ Just (pars, Arg i y) ->
+ let core = Lam i $ Abs y $ Var 0 [Proj o d] in
+ List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars
+-- Projection-like functions:
+projDropPars (Projection False _ _ _ lams) o | null lams = __IMPOSSIBLE__
+projDropPars (Projection False d _ _ lams) o =
+ List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $ init $ getProjLams lams
+
+-- | The info of the principal (record) argument.
+projArgInfo :: Projection -> ArgInfo
+projArgInfo (Projection _ _ _ _ lams) =
+ maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams
+
+-- | Should a record type admit eta-equality?
+data EtaEquality
+ = Specified !Bool -- ^ User specifed 'eta-equality' or 'no-eta-equality'
+ | Inferred !Bool -- ^ Positivity checker inferred whether eta is safe/
+ deriving (Typeable, Show, Eq)
etaEqualityToBool :: EtaEquality -> Bool
etaEqualityToBool (Specified b) = b
etaEqualityToBool (Inferred b) = b
+-- | Make sure we do not overwrite a user specification.
setEtaEquality :: EtaEquality -> Bool -> EtaEquality
setEtaEquality e@Specified{} _ = e
setEtaEquality _ b = Inferred b
+data FunctionFlag
+ = FunStatic -- ^ Should calls to this function be normalised at compile-time?
+ | FunInline -- ^ Should calls to this function be inlined by the compiler?
+ | FunMacro -- ^ Is this function a macro?
+ deriving (Typeable, Eq, Ord, Enum, Show)
+
data Defn = Axiom
-- ^ Postulate.
+ | AbstractDefn
+ -- ^ Returned by 'getConstInfo' if definition is abstract.
| Function
{ funClauses :: [Clause]
, funCompiled :: Maybe CompiledClauses
@@ -1298,12 +1480,7 @@ data Defn = Axiom
-- it is already applied to the record. (Can happen in module
-- instantiation.) This information is used in the termination
-- checker.
- , funStatic :: Bool
- -- ^ Should calls to this function be normalised at compile-time?
- , funInline :: Bool
- -- ^ Should calls to this function be inlined by the compiler?
- , funSmashable :: Bool
- -- ^ Are we allowed to smash this function?
+ , funFlags :: Set FunctionFlag
, funTerminates :: Maybe Bool
-- ^ Has this function been termination checked? Did it pass?
, funExtLam :: Maybe ExtLamInfo
@@ -1332,7 +1509,6 @@ data Defn = Axiom
, recClause :: Maybe Clause
, recConHead :: ConHead -- ^ Constructor name and fields.
, recNamedCon :: Bool
- , recConType :: Type -- ^ The record constructor's type. (Includes record parameters.)
, recFields :: [Arg QName]
, recTel :: Telescope -- ^ The record field telescope. (Includes record parameters.)
-- Note: @TelV recTel _ == telView' recConType@.
@@ -1352,6 +1528,7 @@ data Defn = Axiom
, conData :: QName -- ^ Name of datatype or record type.
, conAbstr :: IsAbstract
, conInd :: Induction -- ^ Inductive or coinductive?
+ , conErased :: [Bool] -- ^ Which arguments are erased at runtime (computed during compilation to treeless)
}
| Primitive
{ primAbstr :: IsAbstract
@@ -1379,15 +1556,27 @@ emptyFunction = Function
, funAbstr = ConcreteDef
, funDelayed = NotDelayed
, funProjection = Nothing
- , funStatic = False
- , funInline = False
- , funSmashable = True
+ , funFlags = Set.empty
, funTerminates = Nothing
, funExtLam = Nothing
, funWith = Nothing
, funCopatternLHS = False
}
+funFlag :: FunctionFlag -> Lens' Bool Defn
+funFlag flag f def@Function{ funFlags = flags } =
+ f (Set.member flag flags) <&>
+ \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags }
+funFlag _ f def = f False <&> const def
+
+funStatic, funInline, funMacro :: Lens' Bool Defn
+funStatic = funFlag FunStatic
+funInline = funFlag FunInline
+funMacro = funFlag FunMacro
+
+isMacro :: Defn -> Bool
+isMacro = (^. funMacro)
+
-- | Checking whether we are dealing with a function yet to be defined.
isEmptyFunction :: Defn -> Bool
isEmptyFunction def =
@@ -1396,7 +1585,7 @@ isEmptyFunction def =
_ -> False
isCopatternLHS :: [Clause] -> Bool
-isCopatternLHS = List.any (List.any (isJust . A.isProjP) . clausePats)
+isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats)
recCon :: Defn -> QName
recCon Record{ recConHead } = conName recConHead
@@ -1428,10 +1617,13 @@ instance Null Simplification where
empty = NoSimplification
null = (== NoSimplification)
+instance Semigroup Simplification where
+ YesSimplification <> _ = YesSimplification
+ NoSimplification <> s = s
+
instance Monoid Simplification where
mempty = NoSimplification
- mappend YesSimplification _ = YesSimplification
- mappend NoSimplification s = s
+ mappend = (<>)
data Reduced no yes = NoReduction no | YesReduction Simplification yes
deriving (Typeable, Functor)
@@ -1522,16 +1714,10 @@ defNonterminating :: Definition -> Bool
defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True
defNonterminating _ = False
--- | Beware when using this function on a @def@ obtained with @getConstInfo q@!
--- If the identifier @q@ is abstract, 'getConstInfo' will turn its @def@ into
--- an 'Axiom' and you always get 'ConcreteDef', paradoxically.
--- Use it in 'IgnoreAbstractMode', like this:
--- @
--- a <- ignoreAbstractMode $ defAbstract <$> getConstInfo q
--- @
defAbstract :: Definition -> IsAbstract
defAbstract d = case theDef d of
Axiom{} -> ConcreteDef
+ AbstractDefn{} -> AbstractDef
Function{funAbstr = a} -> a
Datatype{dataAbstr = a} -> a
Record{recAbstr = a} -> a
@@ -1582,7 +1768,7 @@ data Call = CheckClause Type A.SpineClause
| IsTypeCall A.Expr Sort
| IsType_ A.Expr
| InferVar Name
- | InferDef Range QName
+ | InferDef QName
| CheckArguments Range [NamedArg A.Expr] Type Type
| CheckDataDef Range Name [A.LamBinding] [A.Constructor]
| CheckRecDef Range Name [A.LamBinding] [A.Constructor]
@@ -1641,7 +1827,7 @@ instance HasRange Call where
getRange (IsTypeCall e s) = getRange e
getRange (IsType_ e) = getRange e
getRange (InferVar x) = getRange x
- getRange (InferDef _ f) = getRange f
+ getRange (InferDef f) = getRange f
getRange (CheckArguments r _ _ _) = r
getRange (CheckDataDef i _ _ _) = getRange i
getRange (CheckRecDef i _ _ _) = getRange i
@@ -1667,7 +1853,7 @@ instance HasRange Call where
-- | The instance table is a @Map@ associating to every name of
-- record/data type/postulate its list of instances
-type InstanceTable = Map QName [QName]
+type InstanceTable = Map QName (Set QName)
-- | When typechecking something of the following form:
--
@@ -1677,7 +1863,7 @@ type InstanceTable = Map QName [QName]
--
-- it's not yet known where to add @x@, so we add it to a list of
-- unresolved instances and we'll deal with it later.
-type TempInstanceTable = (InstanceTable , [QName])
+type TempInstanceTable = (InstanceTable , Set QName)
---------------------------------------------------------------------------
-- ** Builtin things
@@ -1744,6 +1930,18 @@ ifTopLevelAndHighlightingLevelIs l m = do
-- * Type checking environment
---------------------------------------------------------------------------
+data ModuleParameters = ModuleParams
+ { mpSubstitution :: Substitution
+ -- ^ @Δ ⊢ σ : Γ@ for a @module M Γ@ where @Δ@ is the current context @envContext@.
+ } deriving (Typeable, Show)
+
+defaultModuleParameters :: ModuleParameters
+defaultModuleParameters = ModuleParams IdS
+
+type ModuleParamDict = Map ModuleName ModuleParameters
+ -- ^ The map contains for each 'ModuleName' @M@ with module telescope @Γ_M@
+ -- a substitution @Γ ⊢ ρ_M : Γ_M@ from the current context @Γ = envContext (clEnv)@.
+
data TCEnv =
TCEnv { envContext :: Context
, envLetBindings :: LetBindings
@@ -1775,24 +1973,20 @@ data TCEnv =
-- Other value: @Relevant@, then only relevant decls. are avail.
, envDisplayFormsEnabled :: Bool
-- ^ Sometimes we want to disable display forms.
- , envReifyInteractionPoints :: Bool
- -- ^ should we try to recover interaction points when reifying?
- -- disabled when generating types for with functions
- , envEtaContractImplicit :: Bool
- -- ^ it's safe to eta contract implicit lambdas as long as we're
- -- not going to reify and retypecheck (like when doing with
- -- abstraction)
, envRange :: Range
, envHighlightingRange :: Range
-- ^ Interactive highlighting uses this range rather
-- than 'envRange'.
+ , envClause :: IPClause
+ -- ^ What is the current clause we are type-checking?
+ -- Will be recorded in interaction points in this clause.
, envCall :: Maybe (Closure Call)
-- ^ what we're doing at the moment
, envHighlightingLevel :: HighlightingLevel
-- ^ Set to 'None' when imported modules are
-- type-checked.
, envHighlightingMethod :: HighlightingMethod
- , envModuleNestingLevel :: Integer
+ , envModuleNestingLevel :: !Int
-- ^ This number indicates how far away from the
-- top-level module Agda has come when chasing
-- modules. The level of a given module is not
@@ -1822,12 +2016,20 @@ data TCEnv =
-- No by default.
-- Yes for rewriting feature.
, envPrintDomainFreePi :: Bool
- -- ^ When True types will be omitted from printed pi types if they
- -- can be inferred
+ -- ^ When @True@, types will be omitted from printed pi types if they
+ -- can be inferred.
+ , envPrintMetasBare :: Bool
+ -- ^ When @True@, throw away meta numbers and meta elims.
+ -- This is used for reifying terms for feeding into the
+ -- user's source code, e.g., for the interaction tactics @solveAll@.
, envInsideDotPattern :: Bool
-- ^ Used by the scope checker to make sure that certain forms
-- of expressions are not used inside dot patterns: extended
-- lambdas and let-expressions.
+ , envUnquoteFlags :: UnquoteFlags
+ , envInstanceDepth :: !Int
+ -- ^ Until we get a termination checker for instance search (#1743) we
+ -- limit the search depth to ensure termination.
}
deriving (Typeable)
@@ -1855,10 +2057,9 @@ initEnv = TCEnv { envContext = []
-- definition (which sets 'AbstractMode').
, envRelevance = Relevant
, envDisplayFormsEnabled = True
- , envReifyInteractionPoints = True
- , envEtaContractImplicit = True
, envRange = noRange
, envHighlightingRange = noRange
+ , envClause = IPNoClause
, envCall = Nothing
, envHighlightingLevel = None
, envHighlightingMethod = Indirect
@@ -1870,12 +2071,125 @@ initEnv = TCEnv { envContext = []
, envAllowedReductions = allReductions
, envCompareBlocked = False
, envPrintDomainFreePi = False
+ , envPrintMetasBare = False
, envInsideDotPattern = False
+ , envUnquoteFlags = defaultUnquoteFlags
+ , envInstanceDepth = 0
}
disableDestructiveUpdate :: TCM a -> TCM a
disableDestructiveUpdate = local $ \e -> e { envAllowDestructiveUpdate = False }
+data UnquoteFlags = UnquoteFlags
+ { _unquoteNormalise :: Bool }
+ deriving (Typeable)
+
+defaultUnquoteFlags :: UnquoteFlags
+defaultUnquoteFlags = UnquoteFlags
+ { _unquoteNormalise = False }
+
+unquoteNormalise :: Lens' Bool UnquoteFlags
+unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }
+
+eUnquoteNormalise :: Lens' Bool TCEnv
+eUnquoteNormalise = eUnquoteFlags . unquoteNormalise
+
+-- * e-prefixed lenses
+------------------------------------------------------------------------
+
+eContext :: Lens' Context TCEnv
+eContext f e = f (envContext e) <&> \ x -> e { envContext = x }
+
+eLetBindings :: Lens' LetBindings TCEnv
+eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }
+
+eCurrentModule :: Lens' ModuleName TCEnv
+eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }
+
+eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv
+eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }
+
+eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv
+eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }
+
+eImportPath :: Lens' [C.TopLevelModuleName] TCEnv
+eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }
+
+eMutualBlock :: Lens' (Maybe MutualId) TCEnv
+eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }
+
+eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv
+eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }
+
+eSolvingConstraints :: Lens' Bool TCEnv
+eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }
+
+eCheckingWhere :: Lens' Bool TCEnv
+eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }
+
+eAssignMetas :: Lens' Bool TCEnv
+eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }
+
+eActiveProblems :: Lens' [ProblemId] TCEnv
+eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }
+
+eAbstractMode :: Lens' AbstractMode TCEnv
+eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }
+
+eRelevance :: Lens' Relevance TCEnv
+eRelevance f e = f (envRelevance e) <&> \ x -> e { envRelevance = x }
+
+eDisplayFormsEnabled :: Lens' Bool TCEnv
+eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }
+
+eRange :: Lens' Range TCEnv
+eRange f e = f (envRange e) <&> \ x -> e { envRange = x }
+
+eHighlightingRange :: Lens' Range TCEnv
+eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }
+
+eCall :: Lens' (Maybe (Closure Call)) TCEnv
+eCall f e = f (envCall e) <&> \ x -> e { envCall = x }
+
+eHighlightingLevel :: Lens' HighlightingLevel TCEnv
+eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }
+
+eHighlightingMethod :: Lens' HighlightingMethod TCEnv
+eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }
+
+eModuleNestingLevel :: Lens' Int TCEnv
+eModuleNestingLevel f e = f (envModuleNestingLevel e) <&> \ x -> e { envModuleNestingLevel = x }
+
+eAllowDestructiveUpdate :: Lens' Bool TCEnv
+eAllowDestructiveUpdate f e = f (envAllowDestructiveUpdate e) <&> \ x -> e { envAllowDestructiveUpdate = x }
+
+eExpandLast :: Lens' ExpandHidden TCEnv
+eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }
+
+eAppDef :: Lens' (Maybe QName) TCEnv
+eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }
+
+eSimplification :: Lens' Simplification TCEnv
+eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }
+
+eAllowedReductions :: Lens' AllowedReductions TCEnv
+eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }
+
+eCompareBlocked :: Lens' Bool TCEnv
+eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }
+
+ePrintDomainFreePi :: Lens' Bool TCEnv
+ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }
+
+eInsideDotPattern :: Lens' Bool TCEnv
+eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }
+
+eUnquoteFlags :: Lens' UnquoteFlags TCEnv
+eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }
+
+eInstanceDepth :: Lens' Int TCEnv
+eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }
+
---------------------------------------------------------------------------
-- ** Context
---------------------------------------------------------------------------
@@ -1904,7 +2218,16 @@ data AbstractMode
= AbstractMode -- ^ Abstract things in the current module can be accessed.
| ConcreteMode -- ^ No abstract things can be accessed.
| IgnoreAbstractMode -- ^ All abstract things can be accessed.
- deriving (Typeable, Show)
+ deriving (Typeable, Show, Eq)
+
+aDefToMode :: IsAbstract -> AbstractMode
+aDefToMode AbstractDef = AbstractMode
+aDefToMode ConcreteDef = ConcreteMode
+
+aModeToDef :: AbstractMode -> IsAbstract
+aModeToDef AbstractMode = AbstractDef
+aModeToDef ConcreteMode = ConcreteDef
+aModeToDef _ = __IMPOSSIBLE__
---------------------------------------------------------------------------
-- ** Insertion of implicit arguments
@@ -1926,27 +2249,52 @@ data ExplicitToInstance
data Candidate = Candidate { candidateTerm :: Term
, candidateType :: Type
, candidateEti :: ExplicitToInstance
+ , candidateOverlappable :: Bool
}
deriving (Show)
+instance Free' Candidate c where
+ freeVars' (Candidate t u _ _) = freeVars' (t, u)
---------------------------------------------------------------------------
--- * Type checking errors
+-- * Type checking warnings (aka non-fatal errors)
---------------------------------------------------------------------------
--- Occurence of a name in a datatype definition
-data Occ = OccCon { occDatatype :: QName
- , occConstructor :: QName
- , occPosition :: OccPos
- }
- | OccClause { occFunction :: QName
- , occClause :: Int
- , occPosition :: OccPos
- }
- deriving (Show)
+-- | A non-fatal error is an error which does not prevent us from
+-- checking the document further and interacting with the user.
+
+-- We keep the state for termination issues, positivity issues and
+-- unsolved constraints from when we encountered the warning so that
+-- we can print it later
+data Warning =
+ TerminationIssue [TerminationError]
+ | NotStrictlyPositive QName OccursWhere
+ | UnsolvedMetaVariables [Range] -- ^ Do not use directly with 'warning'
+ | UnsolvedInteractionMetas [Range] -- ^ Do not use directly with 'warning'
+ | UnsolvedConstraints Constraints
+ -- ^ Do not use directly with 'warning'
+ | OldBuiltin String String
+ -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new
+ | EmptyRewritePragma
+ -- ^ If the user wrote just @{-# REWRITE #-}@.
+ | ParseWarning ParseWarning
+ deriving Show
+
+data TCWarning
+ = TCWarning
+ { tcWarningState :: TCState
+ -- ^ The state in which the warning was raised.
+ , tcWarningClosure :: Closure Warning
+ -- ^ The warning and the environment in which it was raised.
+ }
+ deriving Show
-data OccPos = NonPositively | ArgumentTo Nat QName
- deriving (Show)
+tcWarning :: TCWarning -> Warning
+tcWarning = clValue . tcWarningClosure
+
+---------------------------------------------------------------------------
+-- * Type checking errors
+---------------------------------------------------------------------------
-- | Information about a call.
@@ -2083,13 +2431,13 @@ data TypeError
| CannotEliminateWithPattern (NamedArg A.Pattern) Type
| TooManyArgumentsInLHS Type
| WrongNumberOfConstructorArguments QName Nat Nat
- | ShouldBeEmpty Type [Pattern]
+ | ShouldBeEmpty Type [DeBruijnPattern]
| ShouldBeASort Type
-- ^ The given type should have been a sort.
| ShouldBePi Type
-- ^ The given type should have been a pi.
| ShouldBeRecordType Type
- | ShouldBeRecordPattern Pattern
+ | ShouldBeRecordPattern DeBruijnPattern
| NotAProjectionPattern (NamedArg A.Pattern)
| NotAProperTerm
| SetOmegaNotValidType
@@ -2137,7 +2485,7 @@ data TypeError
| TooManyFields QName [C.Name]
| DuplicateFields [C.Name]
| DuplicateConstructors [C.Name]
- | WithOnFreeVariable A.Expr
+ | WithOnFreeVariable A.Expr Term
| UnexpectedWithPatterns [A.Pattern]
| WithClausePatternMismatch A.Pattern Pattern
| FieldOutsideRecord
@@ -2146,8 +2494,8 @@ data TypeError
-- TODO: Remove some of the constructors in this section, now that
-- the SplitError constructor has been added?
| IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off
- | CoverageFailure QName [[Arg DeBruijnPattern]]
- | UnreachableClauses QName [[Arg DeBruijnPattern]]
+ | CoverageFailure QName [[NamedArg DeBruijnPattern]]
+ | UnreachableClauses QName [[NamedArg DeBruijnPattern]]
| CoverageCantSplitOn QName Telescope Args Args
| CoverageCantSplitIrrelevantType Type
| CoverageCantSplitType Type
@@ -2160,13 +2508,11 @@ data TypeError
| UnificationStuck Telescope [Term] [Term]
| SplitError SplitError
-- Positivity errors
- | NotStrictlyPositive QName [Occ]
+ | TooManyPolarities QName Integer
-- Import errors
| LocalVsImportedModuleClash ModuleName
- | UnsolvedMetas [Range]
- | UnsolvedConstraints Constraints
| SolvedButOpenHoles
- -- ^ Some interaction points (holes) have not be filled by user.
+ -- ^ Some interaction points (holes) have not been filled by user.
-- There are not 'UnsolvedMetas' since unification solved them.
-- This is an error, since interaction points are never filled
-- without user interaction.
@@ -2174,6 +2520,8 @@ data TypeError
| FileNotFound C.TopLevelModuleName [AbsolutePath]
| OverlappingProjects AbsolutePath C.TopLevelModuleName C.TopLevelModuleName
| AmbiguousTopLevelModuleName C.TopLevelModuleName [AbsolutePath]
+ | ModuleNameUnexpected C.TopLevelModuleName C.TopLevelModuleName
+ -- ^ Found module name, expected module name.
| ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]
| ClashingFileNamesFor ModuleName [AbsolutePath]
| ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath
@@ -2201,6 +2549,7 @@ data TypeError
-- definition, but it wasn't of the form @m Delta@.
| NotAnExpression C.Expr
| NotAValidLetBinding D.NiceDeclaration
+ | NotValidBeforeField D.NiceDeclaration
| NothingAppliedToHiddenArg C.Expr
| NothingAppliedToInstanceArg C.Expr
-- Pattern synonym errors
@@ -2223,6 +2572,7 @@ data TypeError
| IFSNoCandidateInScope Type
-- Reflection errors
| UnquoteFailed UnquoteError
+ | DeBruijnIndexOutOfScope Nat Telescope [Name]
-- Safe flag errors
| SafeFlagPostulate C.Name
| SafeFlagPragma [String]
@@ -2230,9 +2580,14 @@ data TypeError
| SafeFlagTerminating
| SafeFlagPrimTrustMe
| SafeFlagNoPositivityCheck
+ | SafeFlagPolarity
-- Language option errors
| NeedOptionCopatterns
| NeedOptionRewriting
+ -- Failure associated to warnings
+ | NonFatalErrors [TCWarning]
+ -- Instance search errors
+ | InstanceSearchDepthExhausted Term Type Int
deriving (Typeable, Show)
-- | Distinguish error message when parsing lhs or pattern synonym, resp.
@@ -2248,11 +2603,19 @@ instance Error TypeError where
-- | Type-checking errors.
-data TCErr = TypeError TCState (Closure TypeError)
- | Exception Range Doc
- | IOException Range E.IOException
- | PatternErr -- TCState -- ^ for pattern violations
- {- AbortAssign TCState -- ^ used to abort assignment to meta when there are instantiations -- UNUSED -}
+data TCErr
+ = TypeError
+ { tcErrState :: TCState
+ -- ^ The state in which the error was raised.
+ , tcErrClosErr :: Closure TypeError
+ -- ^ The environment in which the error as raised plus the error.
+ }
+ | Exception Range Doc
+ | IOException Range E.IOException
+ | PatternErr
+ -- ^ The exception which is usually caught.
+ -- Raised for pattern violations during unification ('assignV')
+ -- but also in other situations where we want to backtrack.
deriving (Typeable)
instance Error TCErr where
@@ -2263,14 +2626,12 @@ instance Show TCErr where
show (Exception r d) = show r ++ ": " ++ render d
show (IOException r e) = show r ++ ": " ++ show e
show PatternErr{} = "Pattern violation (you shouldn't see this)"
- {- show (AbortAssign _) = "Abort assignment (you shouldn't see this)" -- UNUSED -}
instance HasRange TCErr where
getRange (TypeError _ cl) = envRange $ clEnv cl
getRange (Exception r _) = r
getRange (IOException r _) = r
getRange PatternErr{} = noRange
- {- getRange (AbortAssign s) = noRange -- UNUSED -}
instance E.Exception TCErr
@@ -2297,16 +2658,29 @@ mapRedEnvSt f g (ReduceEnv e s) = ReduceEnv (f e) (g s)
newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }
-- deriving (Functor, Applicative, Monad)
+fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b
+fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e
+{-# INLINE fmapReduce #-}
+
+apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b
+apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e -> f e $! x e
+{-# INLINE apReduce #-}
+
+bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b
+bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e
+{-# INLINE bindReduce #-}
+
instance Functor ReduceM where
- fmap f (ReduceM m) = ReduceM $ \ e -> f $! m e
+ fmap = fmapReduce
instance Applicative ReduceM where
pure x = ReduceM (const x)
- ReduceM f <*> ReduceM x = ReduceM $ \ e -> f e $! x e
+ (<*>) = apReduce
instance Monad ReduceM where
return = pure
- ReduceM m >>= f = ReduceM $ \ e -> unReduceM (f $! m e) e
+ (>>=) = bindReduce
+ (>>) = (*>)
instance ReadTCState ReduceM where
getTCState = ReduceM redSt
@@ -2369,6 +2743,16 @@ instance MonadError TCErr (TCMT IO) where
writeIORef r $ oldState { stPersistentState = stPersistentState newState }
unTCM (h err) r e
+-- | Parse monad
+
+runPM :: PM a -> TCM a
+runPM m = do
+ (res, ws) <- runPMIO m
+ mapM_ (warning . ParseWarning) ws
+ case res of
+ Left e -> throwError (Exception (getRange e) (pretty e))
+ Right a -> return a
+
-- | Interaction monad.
type IM = TCMT (Haskeline.InputT IO)
@@ -2491,11 +2875,9 @@ instance MonadIO m => MonadIO (TCMT m) where
x <- m
x `seq` return x
where
- wrap r m = failOnException handleException
- $ E.catch m (handleIOException r)
+ wrap r m = E.catch m (handleIOException r)
handleIOException r e = E.throwIO $ IOException r e
- handleException r s = E.throwIO $ Exception r s
-- | We store benchmark statistics in an IORef.
-- This enables benchmarking pure computation, see
@@ -2510,9 +2892,12 @@ instance Null (TCM Doc) where
null = __IMPOSSIBLE__
-- | Short-cutting disjunction forms a monoid.
+instance Semigroup (TCM Any) where
+ ma <> mb = Any <$> do (getAny <$> ma) `or2M` (getAny <$> mb)
+
instance Monoid (TCM Any) where
mempty = return mempty
- ma `mappend` mb = Any <$> do (getAny <$> ma) `or2M` (getAny <$> mb)
+ mappend = (<>)
patternViolation :: TCM a
patternViolation = throwError PatternErr
@@ -2523,6 +2908,10 @@ internalError s = typeError $ InternalError s
genericError :: MonadTCM tcm => String -> tcm a
genericError = typeError . GenericError
+{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}
+genericDocError :: MonadTCM tcm => Doc -> tcm a
+genericDocError = typeError . GenericDocError
+
{-# SPECIALIZE typeError :: TypeError -> TCM a #-}
typeError :: MonadTCM tcm => TypeError -> tcm a
typeError err = liftTCM $ throwError =<< typeError_ err
@@ -2531,6 +2920,16 @@ typeError err = liftTCM $ throwError =<< typeError_ err
typeError_ :: MonadTCM tcm => TypeError -> tcm TCErr
typeError_ err = liftTCM $ TypeError <$> get <*> buildClosure err
+{-# SPECIALIZE warning_ :: Warning -> TCM TCWarning #-}
+warning_ :: MonadTCM tcm => Warning -> tcm TCWarning
+warning_ w = liftTCM $ TCWarning <$> get <*> buildClosure w
+
+{-# SPECIALIZE warning :: Warning -> TCM () #-}
+warning :: MonadTCM tcm => Warning -> tcm ()
+warning w = do
+ tcwarn <- warning_ w
+ stTCWarnings %= (tcwarn :)
+
-- | Running the type checking monad (most general form).
{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-}
runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState)
@@ -2614,15 +3013,15 @@ instance KillRange Section where
killRange (Section tel) = killRange1 Section tel
instance KillRange Definition where
- killRange (Defn ai name t pols occs displ mut compiled inst copy def) =
- killRange11 Defn ai name t pols occs displ mut compiled inst copy def
+ killRange (Defn ai name t pols occs displ mut compiled inst copy ma def) =
+ killRange11 Defn ai name t pols occs displ mut compiled inst copy ma def
-- TODO clarify: Keep the range in the defName field?
instance KillRange CtxId where
killRange (CtxId x) = killRange1 CtxId x
instance KillRange NLPat where
- killRange (PVar x y) = killRange1 PVar x y
+ killRange (PVar x y z) = killRange3 PVar x y z
killRange (PWild) = PWild
killRange (PDef x y) = killRange2 PDef x y
killRange (PLam x y) = killRange2 PLam x y
@@ -2630,9 +3029,12 @@ instance KillRange NLPat where
killRange (PBoundVar x y) = killRange2 PBoundVar x y
killRange (PTerm x) = killRange1 PTerm x
+instance KillRange NLPType where
+ killRange (NLPType s a) = killRange2 NLPType s a
+
instance KillRange RewriteRule where
- killRange (RewriteRule q gamma lhs rhs t) =
- killRange5 RewriteRule q gamma lhs rhs t
+ killRange (RewriteRule q gamma f es rhs t) =
+ killRange6 RewriteRule q gamma f es rhs t
instance KillRange CompiledRepresentation where
killRange = id
@@ -2644,15 +3046,19 @@ instance KillRange EtaEquality where
instance KillRange ExtLamInfo where
killRange = id
+instance KillRange FunctionFlag where
+ killRange = id
+
instance KillRange Defn where
killRange def =
case def of
Axiom -> Axiom
- Function cls comp tt inv mut isAbs delayed proj static inline smash term extlam with cop ->
- killRange15 Function cls comp tt inv mut isAbs delayed proj static inline smash term extlam with cop
+ AbstractDefn -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!
+ Function cls comp tt inv mut isAbs delayed proj flags term extlam with copat ->
+ killRange13 Function cls comp tt inv mut isAbs delayed proj flags term extlam with copat
Datatype a b c d e f g h i j -> killRange10 Datatype a b c d e f g h i j
- Record a b c d e f g h i j k l -> killRange12 Record a b c d e f g h i j k l
- Constructor a b c d e -> killRange5 Constructor a b c d e
+ Record a b c d e f g h i j k -> killRange11 Record a b c d e f g h i j k
+ Constructor a b c d e f -> killRange6 Constructor a b c d e f
Primitive a b c d -> killRange4 Primitive a b c d
instance KillRange MutualId where
@@ -2668,13 +3074,20 @@ instance KillRange TermHead where
killRange (ConsHead q) = ConsHead $ killRange q
instance KillRange Projection where
- killRange (Projection a b c d e) = killRange4 Projection a b c d e
+ killRange (Projection a b c d e) = killRange5 Projection a b c d e
+
+instance KillRange ProjLams where
+ killRange = id
instance KillRange a => KillRange (Open a) where
killRange = fmap killRange
+instance KillRange a => KillRange (Local a) where
+ killRange (Local a b) = killRange2 Local a b
+ killRange (Global a) = killRange1 Global a
+
instance KillRange DisplayForm where
- killRange (Display n vs dt) = killRange3 Display n vs dt
+ killRange (Display n es dt) = killRange3 Display n es dt
instance KillRange Polarity where
killRange = id
@@ -2682,8 +3095,8 @@ instance KillRange Polarity where
instance KillRange DisplayTerm where
killRange dt =
case dt of
- DWithApp dt dts args -> killRange3 DWithApp dt dts args
- DCon q dts -> killRange2 DCon q dts
+ DWithApp dt dts es -> killRange3 DWithApp dt dts es
+ DCon q ci dts -> killRange3 DCon q ci dts
DDef q dts -> killRange2 DDef q dts
DDot v -> killRange1 DDot v
DTerm v -> killRange1 DTerm v
diff --git a/src/full/Agda/TypeChecking/Monad/Benchmark.hs b/src/full/Agda/TypeChecking/Monad/Benchmark.hs
index 0bed27a..d3a428a 100644
--- a/src/full/Agda/TypeChecking/Monad/Benchmark.hs
+++ b/src/full/Agda/TypeChecking/Monad/Benchmark.hs
@@ -5,7 +5,7 @@ module Agda.TypeChecking.Monad.Benchmark
, B.MonadBench
, B.getBenchmark
, updateBenchmarkingStatus
- , B.billTo, B.billPureTo
+ , B.billTo, B.billPureTo, B.billToCPS
, B.reset
, print
) where
diff --git a/src/full/Agda/TypeChecking/Monad/Builtin.hs b/src/full/Agda/TypeChecking/Monad/Builtin.hs
index 6b6ec9b..a0510de 100644
--- a/src/full/Agda/TypeChecking/Monad/Builtin.hs
+++ b/src/full/Agda/TypeChecking/Monad/Builtin.hs
@@ -4,6 +4,7 @@ module Agda.TypeChecking.Monad.Builtin where
import Control.Applicative
import Control.Monad.State
+import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
@@ -16,7 +17,7 @@ import Agda.TypeChecking.Substitute
import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Lens
-import Agda.Utils.Monad (when_)
+import Agda.Utils.Monad
import Agda.Utils.Maybe
import Agda.Utils.Tuple
@@ -26,6 +27,9 @@ import Agda.Utils.Impossible
class (Functor m, Applicative m, Monad m) => HasBuiltins m where
getBuiltinThing :: String -> m (Maybe (Builtin PrimFun))
+instance HasBuiltins m => HasBuiltins (MaybeT m) where
+ getBuiltinThing b = lift $ getBuiltinThing b
+
litType :: Literal -> TCM Type
litType l = case l of
LitNat _ n -> do
@@ -116,6 +120,9 @@ primInteger, primIntegerPos, primIntegerNegSuc,
primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartName,
primHiding, primHidden, primInstance, primVisible,
primRelevance, primRelevant, primIrrelevant,
+ primAssoc, primAssocLeft, primAssocRight, primAssocNon,
+ primPrecedence, primPrecRelated, primPrecUnrelated,
+ primFixity, primFixityFixity,
primAgdaLiteral, primAgdaLitNat, primAgdaLitFloat, primAgdaLitString, primAgdaLitChar, primAgdaLitQName, primAgdaLitMeta,
primAgdaSort, primAgdaSortSet, primAgdaSortLit, primAgdaSortUnsupported,
primAgdaDefinition, primAgdaDefinitionFunDef, primAgdaDefinitionDataDef, primAgdaDefinitionRecordDef,
@@ -127,11 +134,13 @@ primInteger, primIntegerPos, primIntegerNegSuc,
primAgdaMeta,
primAgdaTCM, primAgdaTCMReturn, primAgdaTCMBind, primAgdaTCMUnify,
primAgdaTCMTypeError, primAgdaTCMInferType, primAgdaTCMCheckType,
- primAgdaTCMNormalise, primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext,
+ primAgdaTCMNormalise, primAgdaTCMReduce,
+ primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext,
primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDefineFun,
primAgdaTCMGetType, primAgdaTCMGetDefinition,
primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm,
- primAgdaTCMBlockOnMeta, primAgdaTCMCommit
+ primAgdaTCMBlockOnMeta, primAgdaTCMCommit, primAgdaTCMIsMacro,
+ primAgdaTCMWithNormalisation
:: TCM Term
primInteger = getBuiltin builtinInteger
@@ -191,6 +200,15 @@ primVisible = getBuiltin builtinVisible
primRelevance = getBuiltin builtinRelevance
primRelevant = getBuiltin builtinRelevant
primIrrelevant = getBuiltin builtinIrrelevant
+primAssoc = getBuiltin builtinAssoc
+primAssocLeft = getBuiltin builtinAssocLeft
+primAssocRight = getBuiltin builtinAssocRight
+primAssocNon = getBuiltin builtinAssocNon
+primPrecedence = getBuiltin builtinPrecedence
+primPrecRelated = getBuiltin builtinPrecRelated
+primPrecUnrelated = getBuiltin builtinPrecUnrelated
+primFixity = getBuiltin builtinFixity
+primFixityFixity = getBuiltin builtinFixityFixity
primArgInfo = getBuiltin builtinArgInfo
primArgArgInfo = getBuiltin builtinArgArgInfo
primAgdaSortSet = getBuiltin builtinAgdaSortSet
@@ -244,6 +262,7 @@ primAgdaTCMTypeError = getBuiltin builtinAgdaTCMTypeError
primAgdaTCMInferType = getBuiltin builtinAgdaTCMInferType
primAgdaTCMCheckType = getBuiltin builtinAgdaTCMCheckType
primAgdaTCMNormalise = getBuiltin builtinAgdaTCMNormalise
+primAgdaTCMReduce = getBuiltin builtinAgdaTCMReduce
primAgdaTCMCatchError = getBuiltin builtinAgdaTCMCatchError
primAgdaTCMGetContext = getBuiltin builtinAgdaTCMGetContext
primAgdaTCMExtendContext = getBuiltin builtinAgdaTCMExtendContext
@@ -257,6 +276,8 @@ primAgdaTCMQuoteTerm = getBuiltin builtinAgdaTCMQuoteTerm
primAgdaTCMUnquoteTerm = getBuiltin builtinAgdaTCMUnquoteTerm
primAgdaTCMBlockOnMeta = getBuiltin builtinAgdaTCMBlockOnMeta
primAgdaTCMCommit = getBuiltin builtinAgdaTCMCommit
+primAgdaTCMIsMacro = getBuiltin builtinAgdaTCMIsMacro
+primAgdaTCMWithNormalisation = getBuiltin builtinAgdaTCMWithNormalisation
builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,
builtinNatTimes, builtinNatDivSucAux, builtinNatModSucAux, builtinNatEquals,
@@ -274,6 +295,9 @@ builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,
builtinAgdaSortUnsupported,
builtinHiding, builtinHidden, builtinInstance, builtinVisible,
builtinRelevance, builtinRelevant, builtinIrrelevant, builtinArg,
+ builtinAssoc, builtinAssocLeft, builtinAssocRight, builtinAssocNon,
+ builtinPrecedence, builtinPrecRelated, builtinPrecUnrelated,
+ builtinFixity, builtinFixityFixity,
builtinArgInfo, builtinArgArgInfo, builtinArgArg,
builtinAbs, builtinAbsAbs, builtinAgdaTerm,
builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam,
@@ -292,12 +316,14 @@ builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,
builtinAgdaMeta,
builtinAgdaTCM, builtinAgdaTCMReturn, builtinAgdaTCMBind, builtinAgdaTCMUnify,
builtinAgdaTCMTypeError, builtinAgdaTCMInferType,
- builtinAgdaTCMCheckType, builtinAgdaTCMNormalise, builtinAgdaTCMCatchError,
+ builtinAgdaTCMCheckType, builtinAgdaTCMNormalise, builtinAgdaTCMReduce,
+ builtinAgdaTCMCatchError,
builtinAgdaTCMGetContext, builtinAgdaTCMExtendContext, builtinAgdaTCMInContext,
builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDefineFun,
builtinAgdaTCMGetType, builtinAgdaTCMGetDefinition,
builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm,
- builtinAgdaTCMBlockOnMeta, builtinAgdaTCMCommit
+ builtinAgdaTCMBlockOnMeta, builtinAgdaTCMCommit, builtinAgdaTCMIsMacro,
+ builtinAgdaTCMWithNormalisation
:: String
builtinNat = "NATURAL"
@@ -356,6 +382,15 @@ builtinVisible = "VISIBLE"
builtinRelevance = "RELEVANCE"
builtinRelevant = "RELEVANT"
builtinIrrelevant = "IRRELEVANT"
+builtinAssoc = "ASSOC"
+builtinAssocLeft = "ASSOCLEFT"
+builtinAssocRight = "ASSOCRIGHT"
+builtinAssocNon = "ASSOCNON"
+builtinPrecedence = "PRECEDENCE"
+builtinPrecRelated = "PRECRELATED"
+builtinPrecUnrelated = "PRECUNRELATED"
+builtinFixity = "FIXITY"
+builtinFixityFixity = "FIXITYFIXITY"
builtinArg = "ARG"
builtinArgInfo = "ARGINFO"
builtinArgArgInfo = "ARGARGINFO"
@@ -410,6 +445,7 @@ builtinAgdaTCMTypeError = "AGDATCMTYPEERROR"
builtinAgdaTCMInferType = "AGDATCMINFERTYPE"
builtinAgdaTCMCheckType = "AGDATCMCHECKTYPE"
builtinAgdaTCMNormalise = "AGDATCMNORMALISE"
+builtinAgdaTCMReduce = "AGDATCMREDUCE"
builtinAgdaTCMCatchError = "AGDATCMCATCHERROR"
builtinAgdaTCMGetContext = "AGDATCMGETCONTEXT"
builtinAgdaTCMExtendContext = "AGDATCMEXTENDCONTEXT"
@@ -423,6 +459,8 @@ builtinAgdaTCMBlockOnMeta = "AGDATCMBLOCKONMETA"
builtinAgdaTCMCommit = "AGDATCMCOMMIT"
builtinAgdaTCMQuoteTerm = "AGDATCMQUOTETERM"
builtinAgdaTCMUnquoteTerm = "AGDATCMUNQUOTETERM"
+builtinAgdaTCMIsMacro = "AGDATCMISMACRO"
+builtinAgdaTCMWithNormalisation = "AGDATCMWITHNORMALISATION"
-- | Builtins that come without a definition in Agda syntax.
-- These are giving names to Agda internal concepts which
@@ -467,9 +505,7 @@ coinductionKit' = do
}
coinductionKit :: TCM (Maybe CoinductionKit)
-coinductionKit =
- (Just <$> coinductionKit')
- `catchError` \_ -> return Nothing
+coinductionKit = tryMaybe coinductionKit'
------------------------------------------------------------------------
-- * Builtin equality
diff --git a/src/full/Agda/TypeChecking/Monad/Caching.hs b/src/full/Agda/TypeChecking/Monad/Caching.hs
index edc97f6..3c50fcf 100644
--- a/src/full/Agda/TypeChecking/Monad/Caching.hs
+++ b/src/full/Agda/TypeChecking/Monad/Caching.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Monad.Caching
( -- * Log reading/writing operations
diff --git a/src/full/Agda/TypeChecking/Monad/Closure.hs b/src/full/Agda/TypeChecking/Monad/Closure.hs
index 1e988bc..0ea738c 100644
--- a/src/full/Agda/TypeChecking/Monad/Closure.hs
+++ b/src/full/Agda/TypeChecking/Monad/Closure.hs
@@ -1,11 +1,21 @@
module Agda.TypeChecking.Monad.Closure where
+import Control.Monad
+
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.Env
import Agda.TypeChecking.Monad.State
+import Agda.TypeChecking.Monad.Context
enterClosure :: Closure a -> (a -> TCM b) -> TCM b
-enterClosure (Closure sig env scope x) k =
+enterClosure (Closure sig env scope pars x) k =
withScope_ scope
$ withEnv env
+ $ withModuleParameters pars
$ k x
+
+withClosure :: Closure a -> (a -> TCM b) -> TCM (Closure b)
+withClosure cl k = enterClosure cl $ k >=> buildClosure
+
+mapClosure :: (a -> TCM b) -> Closure a -> TCM (Closure b)
+mapClosure k cl = enterClosure cl $ k >=> buildClosure
diff --git a/src/full/Agda/TypeChecking/Monad/Constraints.hs b/src/full/Agda/TypeChecking/Monad/Constraints.hs
index 4eb0457..1872307 100644
--- a/src/full/Agda/TypeChecking/Monad/Constraints.hs
+++ b/src/full/Agda/TypeChecking/Monad/Constraints.hs
@@ -23,7 +23,7 @@ import Agda.Utils.Impossible
-- | Get the current problem
currentProblem :: TCM ProblemId
-currentProblem = headWithDefault __IMPOSSIBLE__ <$> asks envActiveProblems
+currentProblem = headWithDefault 0 <$> asks envActiveProblems
-- | Steal all constraints belonging to the given problem and add them to the current problem.
stealConstraints :: ProblemId -> TCM ()
@@ -78,13 +78,6 @@ wakeConstraints wake = do
modifySleepingConstraints $ const sleepin
modifyAwakeConstraints (++ wakeup)
-partitionM :: (a -> TCM Bool) -> [a] -> TCM ([a], [a])
-partitionM f [] = return ([], [])
-partitionM f (x:xs) = do
- b <- f x
- (l, r) <- partitionM f xs
- if b then return (x:l, r) else return (l, x:r)
-
-- danger...
dropConstraints :: (ProblemConstraint -> Bool) -> TCM ()
dropConstraints crit = do
@@ -92,11 +85,15 @@ dropConstraints crit = do
modifySleepingConstraints filt
modifyAwakeConstraints filt
-putAllConstraintsToSleep :: TCM ()
-putAllConstraintsToSleep = do
+putConstraintsToSleep :: (ProblemConstraint -> Bool) -> TCM ()
+putConstraintsToSleep sleepy = do
awakeOnes <- use stAwakeConstraints
- modifySleepingConstraints $ (++ awakeOnes)
- modifyAwakeConstraints $ const []
+ let (gotoSleep, stayAwake) = partition sleepy awakeOnes
+ modifySleepingConstraints $ (++ gotoSleep)
+ modifyAwakeConstraints $ const stayAwake
+
+putAllConstraintsToSleep :: TCM ()
+putAllConstraintsToSleep = putConstraintsToSleep (const True)
data ConstraintStatus = AwakeConstraint | SleepingConstraint
deriving (Eq, Show)
@@ -135,11 +132,14 @@ withConstraint f (PConstr pids c) = do
local (\e -> e { envActiveProblems = pids', envSolvingConstraints = isSolving }) $
solvingProblems pids (f c)
-buildProblemConstraint :: ProblemId -> Constraint -> TCM ProblemConstraint
-buildProblemConstraint pid c = PConstr [pid] <$> buildClosure c
+buildProblemConstraint :: [ProblemId] -> Constraint -> TCM ProblemConstraint
+buildProblemConstraint pids c = PConstr pids <$> buildClosure c
+
+buildProblemConstraint_ :: Constraint -> TCM ProblemConstraint
+buildProblemConstraint_ = buildProblemConstraint []
buildConstraint :: Constraint -> TCM ProblemConstraint
-buildConstraint c = flip buildProblemConstraint c =<< currentProblem
+buildConstraint c = flip buildProblemConstraint c . nub . filter (> 0) =<< asks envActiveProblems
-- | Add new a constraint
addConstraint' :: Constraint -> TCM ()
@@ -149,7 +149,7 @@ addConstraint' c = do
stSleepingConstraints %= (pc :)
where
build | isBlocking c = buildConstraint c
- | otherwise = buildProblemConstraint 0 c
+ | otherwise = buildProblemConstraint_ c
isBlocking SortCmp{} = False
isBlocking LevelCmp{} = False
isBlocking ValueCmp{} = True
diff --git a/src/full/Agda/TypeChecking/Monad/Context.hs b/src/full/Agda/TypeChecking/Monad/Context.hs
index 6a283d3..6d4c15b 100644
--- a/src/full/Agda/TypeChecking/Monad/Context.hs
+++ b/src/full/Agda/TypeChecking/Monad/Context.hs
@@ -1,7 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
#if __GLASGOW_HASKELL__ <= 708
{-# LANGUAGE OverlappingInstances #-}
@@ -11,8 +8,10 @@ module Agda.TypeChecking.Monad.Context where
import Control.Applicative
import Control.Monad.Reader
+import Control.Monad.State
import Data.List hiding (sort)
+import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
@@ -24,10 +23,13 @@ import Agda.Syntax.Scope.Monad (getLocalVars, setLocalVars)
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Monad.Open
+import Agda.TypeChecking.Monad.Options
import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Functor
import Agda.Utils.List ((!!!), downFrom)
+import Agda.Utils.Size
+import Agda.Utils.Lens
-- * Modifying the context
@@ -50,14 +52,9 @@ mkContextEntry x = do
i <- fresh
return $ Ctx i x
--- | Change the context.
-{-# SPECIALIZE inContext :: [Dom (Name, Type)] -> TCM a -> TCM a #-}
-inContext :: MonadTCM tcm => [Dom (Name, Type)] -> tcm a -> tcm a
-inContext xs ret = do
- ctx <- mapM mkContextEntry xs
- modifyContext (const ctx) ret
-
-- | Change to top (=empty) context.
+--
+-- TODO: currently, this makes the @ModuleParamDict@ ill-formed!
{-# SPECIALIZE inTopContext :: TCM a -> TCM a #-}
inTopContext :: MonadTCM tcm => tcm a -> tcm a
inTopContext cont = do
@@ -68,30 +65,107 @@ inTopContext cont = do
return a
-- | Delete the last @n@ bindings from the context.
+--
+-- TODO: currently, this makes the @ModuleParamDict@ ill-formed!
{-# SPECIALIZE escapeContext :: Int -> TCM a -> TCM a #-}
escapeContext :: MonadTCM tcm => Int -> tcm a -> tcm a
escapeContext n = modifyContext $ drop n
+-- * Manipulating module parameters --
+
+-- | Locally set module parameters for a computation.
+
+withModuleParameters :: ModuleParamDict -> TCM a -> TCM a
+withModuleParameters mp ret = do
+ old <- use stModuleParameters
+ stModuleParameters .= mp
+ x <- ret
+ stModuleParameters .= old
+ return x
+
+-- | Apply a substitution to all module parameters.
+
+updateModuleParameters :: MonadTCM tcm => Substitution -> tcm a -> tcm a
+updateModuleParameters sub ret = do
+ pm <- use stModuleParameters
+ let showMP pref mps = intercalate "\n" $
+ [ p ++ show m ++ " : " ++ show (mpSubstitution mp)
+ | (p, (m, mp)) <- zip (pref : repeat (map (const ' ') pref))
+ (Map.toList mps)
+ ]
+ cxt <- reverse <$> getContext
+ reportSLn "tc.cxt.param" 90 $ unlines $
+ [ "updatingModuleParameters"
+ , " sub = " ++ show sub
+ , " cxt = " ++ unwords (map (show . fst . unDom) cxt)
+ , showMP " old = " pm
+ ]
+ let pm' = applySubst sub pm
+ reportSLn "tc.cxt.param" 90 $ showMP " new = " pm'
+ stModuleParameters .= pm'
+ x <- ret -- We need to keep introduced modules around
+ pm1 <- use stModuleParameters
+ let pm'' = Map.union pm (defaultModuleParameters <$ Map.difference pm1 pm)
+ stModuleParameters .= pm''
+ reportSLn "tc.cxt.param" 90 $ showMP " restored = " pm''
+ return x
+
+-- | Since the @ModuleParamDict@ is relative to the current context,
+-- this function should be called everytime the context is extended.
+--
+weakenModuleParameters :: MonadTCM tcm => Nat -> tcm a -> tcm a
+weakenModuleParameters n = updateModuleParameters (raiseS n)
+
+-- | Get substitution @Γ ⊢ ρ : Γm@ where @Γ@ is the current context
+-- and @Γm@ is the module parameter telescope of module @m@.
+--
+-- In case the current 'ModuleParamDict' does not know @m@,
+-- we return the identity substitution.
+-- This is ok for instance if we are outside module @m@
+-- (in which case we have to supply all module parameters to any
+-- symbol defined within @m@ we want to refer).
+getModuleParameterSub :: MonadTCM tcm => ModuleName -> tcm Substitution
+getModuleParameterSub m = do
+ r <- use stModuleParameters
+ case Map.lookup m r of
+ Nothing -> return IdS
+ Just mp -> return $ mpSubstitution mp
+
+
-- * Adding to the context
-- | @addCtx x arg cont@ add a variable to the context.
--
-- Chooses an unused 'Name'.
+--
+-- Warning: Does not update module parameter substitution!
{-# SPECIALIZE addCtx :: Name -> Dom Type -> TCM a -> TCM a #-}
addCtx :: MonadTCM tcm => Name -> Dom Type -> tcm a -> tcm a
addCtx x a ret = do
- ctx <- map (nameConcrete . fst . unDom) <$> getContext
- let x' = head $ filter (notTaken ctx) $ iterate nextName x
- ce <- mkContextEntry $ (x',) <$> a
+ ce <- mkContextEntry $ (x,) <$> a
modifyContext (ce :) ret
-- let-bindings keep track of own their context
+
+-- | Pick a concrete name that doesn't shadow anything in the context.
+unshadowName :: MonadTCM tcm => Name -> tcm Name
+unshadowName x = do
+ ctx <- map (nameConcrete . fst . unDom) <$> getContext
+ return $ head $ filter (notTaken ctx) $ iterate nextName x
where
notTaken xs x = isNoName x || nameConcrete x `notElem` xs
-- | Various specializations of @addCtx@.
{-# SPECIALIZE addContext :: b -> TCM a -> TCM a #-}
class AddContext b where
- addContext :: MonadTCM tcm => b -> tcm a -> tcm a
+ addContext :: MonadTCM tcm => b -> tcm a -> tcm a
+ contextSize :: b -> Nat
+
+-- | Since the module parameter substitution is relative to
+-- the current context, we need to weaken it when we
+-- extend the context. This function takes care of that.
+--
+addContext' :: (MonadTCM tcm, AddContext b) => b -> tcm a -> tcm a
+addContext' cxt = addContext cxt . weakenModuleParameters (contextSize cxt)
#if __GLASGOW_HASKELL__ >= 710
instance {-# OVERLAPPABLE #-} AddContext a => AddContext [a] where
@@ -99,37 +173,46 @@ instance {-# OVERLAPPABLE #-} AddContext a => AddContext [a] where
instance AddContext a => AddContext [a] where
#endif
addContext = flip (foldr addContext)
+ contextSize = sum . map contextSize
instance AddContext (Name, Dom Type) where
addContext = uncurry addCtx
+ contextSize _ = 1
instance AddContext (Dom (Name, Type)) where
addContext = addContext . distributeF
-- addContext dom = addCtx (fst $ unDom dom) (snd <$> dom)
+ contextSize _ = 1
instance AddContext ([Name], Dom Type) where
addContext (xs, dom) = addContext (bindsToTel' id xs dom)
+ contextSize (xs, _) = length xs
instance AddContext ([WithHiding Name], Dom Type) where
addContext ([] , dom) = id
addContext (WithHiding h x : xs, dom) =
addContext (x , mapHiding (mappend h) dom) .
addContext (xs, raise 1 dom)
+ contextSize (xs, _) = length xs
instance AddContext (String, Dom Type) where
addContext (s, dom) ret = do
- x <- freshName_ s
+ x <- unshadowName =<< freshName_ s
addCtx x dom ret
+ contextSize _ = 1
instance AddContext (Dom (String, Type)) where
addContext = addContext . distributeF
-- addContext dom = addContext (fst $ unDom dom, snd <$> dom)
+ contextSize _ = 1
instance AddContext (Dom Type) where
addContext dom = addContext ("_", dom)
+ contextSize _ = 1
instance AddContext Name where
addContext x = addContext (x, dummyDom)
+ contextSize _ = 1
#if __GLASGOW_HASKELL__ >= 710
instance {-# OVERLAPPING #-} AddContext String where
@@ -137,41 +220,13 @@ instance {-# OVERLAPPING #-} AddContext String where
instance AddContext String where
#endif
addContext s = addContext (s, dummyDom)
+ contextSize _ = 1
instance AddContext Telescope where
addContext tel ret = loop tel where
loop EmptyTel = ret
loop (ExtendTel t tel) = underAbstraction t tel loop
-
-{-
--- | N-ary variant of @addCtx@.
-{-# SPECIALIZE addContext :: [Dom (Name, Type)] -> TCM a -> TCM a #-}
-addContext :: MonadTCM tcm => [Dom (Name, Type)] -> tcm a -> tcm a
-addContext ctx m =
- foldr (\arg -> addCtx (fst $ unDom arg) (snd <$> arg)) m ctx
--}
-
--- | add a bunch of variables with the same type to the context
-{-# SPECIALIZE addCtxs :: [Name] -> Dom Type -> TCM a -> TCM a #-}
-addCtxs :: MonadTCM tcm => [Name] -> Dom Type -> tcm a -> tcm a
-addCtxs [] _ k = k
-addCtxs (x:xs) t k = addCtx x t $ addCtxs xs (raise 1 t) k
-
--- | Turns the string into a name and adds it to the context.
-{-# SPECIALIZE addCtxString :: String -> Dom Type -> TCM a -> TCM a #-}
-addCtxString :: MonadTCM tcm => String -> Dom Type -> tcm a -> tcm a
-addCtxString s a m = do
- x <- freshName_ s
- addCtx x a m
-
--- | Turns the string into a name and adds it to the context, with dummy type.
-{-# SPECIALIZE addCtxString_ :: String -> TCM a -> TCM a #-}
-addCtxString_ :: MonadTCM tcm => String -> tcm a -> tcm a
-addCtxString_ s = addCtxString s dummyDom
-
-{-# SPECIALIZE addCtxStrings_ :: [String] -> TCM a -> TCM a #-}
-addCtxStrings_ :: MonadTCM tcm => [String] -> tcm a -> tcm a
-addCtxStrings_ = flip (foldr addCtxString_)
+ contextSize = size
-- | Context entries without a type have this dummy type.
dummyDom :: Dom Type
@@ -182,8 +237,8 @@ dummyDom = defaultDom typeDontCare
underAbstraction :: (Subst t a, MonadTCM tcm) => Dom Type -> Abs a -> (a -> tcm b) -> tcm b
underAbstraction _ (NoAbs _ v) k = k v
underAbstraction t a k = do
- x <- freshName_ $ realName $ absName a
- addCtx x t $ k $ absBody a
+ x <- unshadowName =<< freshName_ (realName $ absName a)
+ addContext (x, t) $ k $ absBody a
where
realName s = if isNoName s then "x" else argNameToString s
@@ -192,14 +247,7 @@ underAbstraction t a k = do
underAbstraction_ :: (Subst t a, MonadTCM tcm) => Abs a -> (a -> tcm b) -> tcm b
underAbstraction_ = underAbstraction dummyDom
--- | Add a telescope to the context.
-{-# SPECIALIZE addCtxTel :: Telescope -> TCM a -> TCM a #-}
-addCtxTel :: MonadTCM tcm => Telescope -> tcm a -> tcm a
-addCtxTel tel ret = loop tel where
- loop EmptyTel = ret
- loop (ExtendTel t tel) = underAbstraction t tel loop
-
--- | Add a let bound variable
+-- | Add a let bound variable.
{-# SPECIALIZE addLetBinding :: ArgInfo -> Name -> Term -> Type -> TCM a -> TCM a #-}
addLetBinding :: MonadTCM tcm => ArgInfo -> Name -> Term -> Type -> tcm a -> tcm a
addLetBinding info x v t0 ret = do
@@ -252,7 +300,7 @@ getContextNames = map (fst . unDom) <$> getContext
lookupBV :: MonadReader TCEnv m => Nat -> m (Dom (Name, Type))
lookupBV n = do
ctx <- getContext
- let failure = fail $ "deBruijn index out of scope: " ++ show n ++
+ let failure = fail $ "de Bruijn index out of scope: " ++ show n ++
" in context " ++ show (map (fst . unDom) ctx)
maybe failure (return . fmap (raise $ n + 1)) $ ctx !!! n
diff --git a/src/full/Agda/TypeChecking/Monad/Env.hs b/src/full/Agda/TypeChecking/Monad/Env.hs
index ee3df1f..3a154b4 100644
--- a/src/full/Agda/TypeChecking/Monad/Env.hs
+++ b/src/full/Agda/TypeChecking/Monad/Env.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
module Agda.TypeChecking.Monad.Env where
@@ -38,7 +37,11 @@ withAnonymousModule m n =
-- | Set the current environment to the given
withEnv :: TCEnv -> TCM a -> TCM a
-withEnv env m = local (\env0 -> env { envAllowDestructiveUpdate = envAllowDestructiveUpdate env0 }) m
+withEnv env = local $ \ env0 -> env
+ -- Keep persistent settings
+ { envAllowDestructiveUpdate = envAllowDestructiveUpdate env0
+ , envPrintMetasBare = envPrintMetasBare env0
+ }
-- | Get the current environment
getEnv :: TCM TCEnv
diff --git a/src/full/Agda/TypeChecking/Monad/Exception.hs b/src/full/Agda/TypeChecking/Monad/Exception.hs
index b67eb59..f602612 100644
--- a/src/full/Agda/TypeChecking/Monad/Exception.hs
+++ b/src/full/Agda/TypeChecking/Monad/Exception.hs
@@ -1,7 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Basically a copy of the ErrorT monad transformer. It's handy to slap
diff --git a/src/full/Agda/TypeChecking/Monad/Local.hs b/src/full/Agda/TypeChecking/Monad/Local.hs
new file mode 100644
index 0000000..b47b9ba
--- /dev/null
+++ b/src/full/Agda/TypeChecking/Monad/Local.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE CPP #-}
+module Agda.TypeChecking.Monad.Local where
+
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+
+import Agda.Syntax.Internal
+import Agda.TypeChecking.Substitute
+import Agda.TypeChecking.Monad.Base
+import Agda.TypeChecking.Monad.Context
+import Agda.TypeChecking.Monad.Env
+import Agda.TypeChecking.Monad.Options
+import Agda.TypeChecking.Free
+import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (inFreshModuleIfFreeParams, lookupSection)
+
+import Agda.Utils.Size
+import Agda.Utils.Impossible
+#include "undefined.h"
+
+-- | Precondition: must not be called if the module parameter of the current
+-- module have been refined or (touched at all).
+makeLocal :: Free' a All => a -> TCM (Local a)
+makeLocal x | closed x = return $ Global x
+ | otherwise = inFreshModuleIfFreeParams $ do
+ m <- currentModule
+ return (Local m x)
+
+makeGlobal :: Free' a All => a -> TCM (Local a)
+makeGlobal x | closed x = return $ Global x
+ | otherwise = __IMPOSSIBLE__
+
+getLocal :: Subst Term a => Local a -> TCM (Maybe a)
+getLocal (Global x) = return (Just x)
+getLocal l@(Local m x) = do
+ m' <- currentModule
+ if m' == m || isSubModuleOf m' m
+ then Just . (`applySubst` x) <$> getModuleParameterSub m
+ else return Nothing
+
diff --git a/src/full/Agda/TypeChecking/Monad/MetaVars.hs b/src/full/Agda/TypeChecking/Monad/MetaVars.hs
index 96b8057..315599e 100644
--- a/src/full/Agda/TypeChecking/Monad/MetaVars.hs
+++ b/src/full/Agda/TypeChecking/Monad/MetaVars.hs
@@ -1,20 +1,24 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Monad.MetaVars where
-import Control.Applicative
+import Prelude hiding (null)
+
+import Control.Applicative hiding (empty)
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
+import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Foldable as Fold
import Agda.Syntax.Common
import Agda.Syntax.Internal
+import Agda.Syntax.Internal.Generic
import Agda.Syntax.Position
import Agda.Syntax.Scope.Base
@@ -28,12 +32,15 @@ import {-# SOURCE #-} Agda.TypeChecking.Telescope
import Agda.Utils.Functor ((<.>))
import Agda.Utils.Lens
+import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Tuple
import Agda.Utils.Size
+import qualified Agda.Utils.Maybe.Strict as Strict
#include "undefined.h"
import Agda.Utils.Impossible
@@ -49,6 +56,14 @@ getMetaStore = use stMetaStore
modifyMetaStore :: (MetaStore -> MetaStore) -> TCM ()
modifyMetaStore f = stMetaStore %= f
+-- | Run a computation and record which new metas it created.
+metasCreatedBy :: TCM a -> TCM (a, Set MetaId)
+metasCreatedBy m = do
+ before <- Map.keysSet <$> use stMetaStore
+ a <- m
+ after <- Map.keysSet <$> use stMetaStore
+ return (a, after Set.\\ before)
+
-- | Lookup a meta variable
lookupMeta :: MetaId -> TCM MetaVariable
lookupMeta m = fromMaybeM failure $ Map.lookup m <$> getMetaStore
@@ -106,7 +121,7 @@ instance IsInstantiatedMeta Term where
DontCare v -> loop v
Level l -> isInstantiatedMeta l
Lam _ b -> isInstantiatedMeta b
- Con _ vs -> isInstantiatedMeta vs
+ Con _ _ vs -> isInstantiatedMeta vs
_ -> __IMPOSSIBLE__
instance IsInstantiatedMeta Level where
@@ -138,9 +153,26 @@ isInstantiatedMeta' m = do
mv <- lookupMeta m
return $ case mvInstantiation mv of
InstV tel v -> Just $ foldr mkLam v tel
- InstS v -> Just v
_ -> Nothing
+
+-- | Returns every meta-variable occurrence in the given type, except
+-- for those in 'Sort's.
+allMetas :: TermLike a => a -> [MetaId]
+allMetas = foldTerm metas
+ where
+ metas (MetaV m _) = [m]
+ metas (Level l) = levelMetas l
+ metas _ = []
+
+ levelMetas (Max as) = concatMap plusLevelMetas as
+
+ plusLevelMetas ClosedLevel{} = []
+ plusLevelMetas (Plus _ l) = levelAtomMetas l
+
+ levelAtomMetas (MetaLevel m _) = [m]
+ levelAtomMetas _ = []
+
-- | Create 'MetaInfo' in the current environment.
createMetaInfo :: TCM MetaInfo
createMetaInfo = createMetaInfo' RunMetaOccursCheck
@@ -168,7 +200,7 @@ getMetaNameSuggestion :: MetaId -> TCM MetaNameSuggestion
getMetaNameSuggestion mi = miNameSuggestion . mvInfo <$> lookupMeta mi
setMetaNameSuggestion :: MetaId -> MetaNameSuggestion -> TCM ()
-setMetaNameSuggestion mi s = do
+setMetaNameSuggestion mi s = unless (null s || isUnderscore s) $ do
reportSLn "tc.meta.name" 20 $
"setting name of meta " ++ prettyShow mi ++ " to " ++ s
updateMetaVar mi $ \ mvar ->
@@ -185,13 +217,22 @@ modifyInteractionPoints f =
-- | Register an interaction point during scope checking.
-- If there is no interaction id yet, create one.
-registerInteractionPoint :: Range -> Maybe Nat -> TCM InteractionId
-registerInteractionPoint r maybeId = do
+registerInteractionPoint :: Bool -> Range -> Maybe Nat -> TCM InteractionId
+registerInteractionPoint preciseRange r maybeId = do
+ m <- use stInteractionPoints
+ if not preciseRange then continue m else do
+ -- If the range does not come from a file, it is not
+ -- precise, so ignore it.
+ Strict.caseMaybe (rangeFile r) (continue m) $ \ _ -> do
+ -- First, try to find the interaction point by Range.
+ caseMaybe (findInteractionPoint_ r m) (continue m) {-else-} return
+ where
+ continue m = do
+ -- We did not find an interaction id with the same Range, so let's create one!
ii <- case maybeId of
Just i -> return $ InteractionId i
Nothing -> fresh
- m <- use stInteractionPoints
- let ip = InteractionPoint { ipRange = r, ipMeta = Nothing }
+ let ip = InteractionPoint { ipRange = r, ipMeta = Nothing, ipClause = IPNoClause }
case Map.insertLookupWithKey (\ key new old -> old) ii ip m of
-- If the interaction point is already present, we keep the old ip.
-- However, it needs to be at the same range as the new one.
@@ -202,11 +243,25 @@ registerInteractionPoint r maybeId = do
modifyInteractionPoints (const m')
return ii
+-- | Find an interaction point by 'Range' by searching the whole map.
+--
+-- O(n): linear in the number of registered interaction points.
+
+findInteractionPoint_ :: Range -> InteractionPoints -> Maybe InteractionId
+findInteractionPoint_ r m = do
+ guard $ not $ null r
+ headMaybe $ mapMaybe sameRange $ Map.toList m
+ where
+ sameRange :: (InteractionId, InteractionPoint) -> Maybe InteractionId
+ sameRange (ii, InteractionPoint r' _ _) | r == r' = Just ii
+ sameRange _ = Nothing
+
-- | Hook up meta variable to interaction point.
connectInteractionPoint :: InteractionId -> MetaId -> TCM ()
connectInteractionPoint ii mi = do
+ ipCl <- asks envClause
m <- use stInteractionPoints
- let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi }
+ let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi, ipClause = ipCl }
-- The interaction point needs to be present already, we just set the meta.
case Map.insertLookupWithKey (\ key new old -> new { ipRange = ipRange old }) ii ip m of
(Nothing, _) -> __IMPOSSIBLE__
@@ -215,8 +270,11 @@ connectInteractionPoint ii mi = do
-- | Move an interaction point from the current ones to the old ones.
removeInteractionPoint :: InteractionId -> TCM ()
removeInteractionPoint ii = do
- scope <- getInteractionScope ii
- modifyInteractionPoints $ Map.delete ii
+ ip <- stInteractionPoints %%= \ m -> do
+ let (mip, m') = Map.updateLookupWithKey (\ _ _ -> Nothing) ii m
+ return (m',
+ fromMaybe __IMPOSSIBLE__ mip)
+ stSolvedInteractionPoints %= Map.insert ii ip
-- | Get a list of interaction ids.
getInteractionPoints :: TCM [InteractionId]
@@ -249,7 +307,14 @@ lookupInteractionPoint ii =
lookupInteractionId :: InteractionId -> TCM MetaId
lookupInteractionId ii = fromMaybeM err2 $ ipMeta <$> lookupInteractionPoint ii
where
- err2 = typeError $ GenericError $ "No type nor action available for hole " ++ show ii
+ err2 = typeError $ GenericError $ "No type nor action available for hole " ++ show ii ++ ". Possible cause: the hole has not been reached during type checking (do you see yellow?)"
+
+-- | Check whether an interaction id is already associated with a meta variable.
+lookupInteractionMeta :: InteractionId -> TCM (Maybe MetaId)
+lookupInteractionMeta ii = lookupInteractionMeta_ ii <$> use stInteractionPoints
+
+lookupInteractionMeta_ :: InteractionId -> InteractionPoints -> Maybe MetaId
+lookupInteractionMeta_ ii m = ipMeta =<< Map.lookup ii m
-- | Generate new meta variable.
newMeta :: MetaInfo -> MetaPriority -> Permutation -> Judgement a -> TCM MetaId
@@ -296,19 +361,18 @@ getInstantiatedMetas = do
isInst BlockedConst{} = False
isInst PostponedTypeCheckingProblem{} = False
isInst InstV{} = True
- isInst InstS{} = True
getOpenMetas :: TCM [MetaId]
getOpenMetas = do
store <- getMetaStore
- return [ i | (i, MetaVar{ mvInstantiation = mi }) <- Map.assocs store, isOpen mi ]
- where
- isOpen Open = True
- isOpen OpenIFS = True
- isOpen BlockedConst{} = True
- isOpen PostponedTypeCheckingProblem{} = True
- isOpen InstV{} = False
- isOpen InstS{} = False
+ return [ i | (i, MetaVar{ mvInstantiation = mi }) <- Map.assocs store, isOpenMeta mi ]
+
+isOpenMeta :: MetaInstantiation -> Bool
+isOpenMeta Open = True
+isOpenMeta OpenIFS = True
+isOpenMeta BlockedConst{} = True
+isOpenMeta PostponedTypeCheckingProblem{} = True
+isOpenMeta InstV{} = False
-- | @listenToMeta l m@: register @l@ as a listener to @m@. This is done
-- when the type of l is blocked by @m@.
@@ -343,14 +407,18 @@ withFreezeMetas cont = do
-- | Freeze all meta variables and return the list of metas that got frozen.
freezeMetas :: TCM [MetaId]
-freezeMetas = execWriterT $ stMetaStore %== Map.traverseWithKey freeze
+freezeMetas = freezeMetas' $ const True
+
+-- | Freeze some meta variables and return the list of metas that got frozen.
+freezeMetas' :: (MetaId -> Bool) -> TCM [MetaId]
+freezeMetas' p = execWriterT $ stMetaStore %== Map.traverseWithKey freeze
where
freeze :: Monad m => MetaId -> MetaVariable -> WriterT [MetaId] m MetaVariable
freeze m mvar
- | mvFrozen mvar == Frozen = return mvar
- | otherwise = do
+ | p m && mvFrozen mvar /= Frozen = do
tell [m]
return $ mvar { mvFrozen = Frozen }
+ | otherwise = return mvar
-- | Thaw all meta variables.
unfreezeMetas :: TCM ()
diff --git a/src/full/Agda/TypeChecking/Monad/Mutual.hs b/src/full/Agda/TypeChecking/Monad/Mutual.hs
index 1daf185..c8ac2ef 100644
--- a/src/full/Agda/TypeChecking/Monad/Mutual.hs
+++ b/src/full/Agda/TypeChecking/Monad/Mutual.hs
@@ -2,64 +2,83 @@
module Agda.TypeChecking.Monad.Mutual where
+import Prelude hiding (null)
+
import Control.Monad.Reader
-import qualified Data.Map as Map
-import Data.Set (Set)
import Data.Functor ((<$>))
+import Data.Set (Set)
import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Agda.Syntax.Info as Info
import Agda.Syntax.Internal
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.State
import Agda.Utils.Lens
+import Agda.Utils.Null
noMutualBlock :: TCM a -> TCM a
noMutualBlock = local $ \e -> e { envMutualBlock = Nothing }
-inMutualBlock :: TCM a -> TCM a
+-- | Pass the current mutual block id
+-- or create a new mutual block if we are not already inside on.
+inMutualBlock :: (MutualId -> TCM a) -> TCM a
inMutualBlock m = do
mi <- asks envMutualBlock
case mi of
Nothing -> do
i <- fresh
- flip local m $ \e -> e { envMutualBlock = Just i }
+ local (\ e -> e { envMutualBlock = Just i }) $ m i
-- Don't create a new mutual block if we're already inside one.
- Just _ -> m
+ Just i -> m i
+
+-- | Set the mutual block info for a block,
+-- possibly overwriting the existing one.
+
+setMutualBlockInfo :: MutualId -> Info.MutualInfo -> TCM ()
+setMutualBlockInfo mi info = stMutualBlocks %= Map.alter f mi
+ where
+ f Nothing = Just $ MutualBlock info empty
+ f (Just (MutualBlock _ xs)) = Just $ MutualBlock info xs
+
+-- | Set the mutual block info for a block if non-existing.
+
+insertMutualBlockInfo :: MutualId -> Info.MutualInfo -> TCM ()
+insertMutualBlockInfo mi info = stMutualBlocks %= Map.alter f mi
+ where
+ f Nothing = Just $ MutualBlock info empty
+ f (Just mb@(MutualBlock info0 xs))
+ | null info0 = Just $ MutualBlock info xs
+ | otherwise = Just mb
+
+-- | Set the mutual block for a definition.
--- | Set the mutual block for a definition
setMutualBlock :: MutualId -> QName -> TCM ()
setMutualBlock i x = do
- stMutualBlocks %= Map.insertWith Set.union i (Set.singleton x)
+ stMutualBlocks %= Map.alter f i
stSignature %= updateDefinition x (\ defn -> defn { defMutual = i })
-
--- | Get all mutual blocks
-getMutualBlocks :: TCM [Set QName]
-getMutualBlocks = Map.elems <$> use stMutualBlocks
+ where
+ f Nothing = Just $ MutualBlock empty $ Set.singleton x
+ f (Just (MutualBlock mi xs)) = Just $ MutualBlock mi $ Set.insert x xs
-- | Get the current mutual block, if any, otherwise a fresh mutual
-- block is returned.
currentOrFreshMutualBlock :: TCM MutualId
currentOrFreshMutualBlock = maybe fresh return =<< asks envMutualBlock
-lookupMutualBlock :: MutualId -> TCM (Set QName)
+lookupMutualBlock :: MutualId -> TCM MutualBlock
lookupMutualBlock mi = do
- mb <- use stMutualBlocks
- case Map.lookup mi mb of
- Just qs -> return qs
- Nothing -> return Set.empty -- can end up here if we ask for the current mutual block and there is none
+ mbs <- use stMutualBlocks
+ case Map.lookup mi mbs of
+ Just mb -> return mb
+ Nothing -> return empty -- can end up here if we ask for the current mutual block and there is none
+-- | Reverse lookup of a mutual block id for a names.
mutualBlockOf :: QName -> TCM MutualId
mutualBlockOf x = do
mb <- Map.toList <$> use stMutualBlocks
- case filter (Set.member x . snd) mb of
+ case filter (Set.member x . mutualNames . snd) mb of
(i, _) : _ -> return i
_ -> fail $ "No mutual block for " ++ show x
-
-findMutualBlock :: QName -> TCM (Set QName)
-findMutualBlock f = do
- bs <- getMutualBlocks
- case filter (Set.member f) bs of
- [] -> fail $ "No mutual block for " ++ show f
- b : _ -> return b
diff --git a/src/full/Agda/TypeChecking/Monad/Open.hs b/src/full/Agda/TypeChecking/Monad/Open.hs
index d59c0bf..ebecc2c 100644
--- a/src/full/Agda/TypeChecking/Monad/Open.hs
+++ b/src/full/Agda/TypeChecking/Monad/Open.hs
@@ -1,5 +1,4 @@
-- {-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
module Agda.TypeChecking.Monad.Open
( makeOpen
diff --git a/src/full/Agda/TypeChecking/Monad/Options.hs b/src/full/Agda/TypeChecking/Monad/Options.hs
index 88a25d4..3086fd2 100644
--- a/src/full/Agda/TypeChecking/Monad/Options.hs
+++ b/src/full/Agda/TypeChecking/Monad/Options.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
module Agda.TypeChecking.Monad.Options where
@@ -17,12 +16,13 @@ import System.Directory
import System.FilePath
import Agda.Syntax.Internal
+import Agda.Syntax.Common
import Agda.Syntax.Concrete
import {-# SOURCE #-} Agda.TypeChecking.Errors
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.State
import Agda.TypeChecking.Monad.Benchmark
-import Agda.Interaction.FindFile
+import {-# SOURCE #-} Agda.Interaction.FindFile
import Agda.Interaction.Options
import qualified Agda.Interaction.Options.Lenses as Lens
import Agda.Interaction.Response
@@ -83,7 +83,7 @@ setCommandLineOptions' relativeTo opts = do
getIncludeDirs
incs -> return incs
modify $ Lens.setCommandLineOptions opts{ optAbsoluteIncludePaths = incs }
- . Lens.setPragmaOptions (optPragmaOptions opts)
+ setPragmaOptions (optPragmaOptions opts)
updateBenchmarkingStatus
libToTCM :: LibM a -> TCM a
@@ -106,11 +106,11 @@ setLibraryIncludes o = do
addDefaultLibraries :: RelativeTo -> CommandLineOptions -> TCM CommandLineOptions
addDefaultLibraries rel o
| or [ not $ null $ optLibraries o
- , not $ optDefaultLibs o
+ , not $ optUseLibs o
, optShowVersion o ] = pure o
| otherwise = do
root <- getProjectRoot rel
- (libs, incs) <- libToTCM $ getDefaultLibraries (filePath root)
+ (libs, incs) <- libToTCM $ getDefaultLibraries (filePath root) (optDefaultLibs o)
return o{ optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs }
class (Functor m, Applicative m, Monad m) => HasOptions m where
@@ -149,27 +149,6 @@ disableDisplayForms =
displayFormsEnabled :: TCM Bool
displayFormsEnabled = asks envDisplayFormsEnabled
--- | Don't eta contract implicit
-dontEtaContractImplicit :: TCM a -> TCM a
-dontEtaContractImplicit = local $ \e -> e { envEtaContractImplicit = False }
-
--- | Do eta contract implicit
-{-# SPECIALIZE doEtaContractImplicit :: TCM a -> TCM a #-}
-doEtaContractImplicit :: MonadTCM tcm => tcm a -> tcm a
-doEtaContractImplicit = local $ \e -> e { envEtaContractImplicit = True }
-
-{-# SPECIALIZE shouldEtaContractImplicit :: TCM Bool #-}
-shouldEtaContractImplicit :: MonadReader TCEnv m => m Bool
-shouldEtaContractImplicit = asks envEtaContractImplicit
-
--- | Don't reify interaction points
-dontReifyInteractionPoints :: TCM a -> TCM a
-dontReifyInteractionPoints =
- local $ \e -> e { envReifyInteractionPoints = False }
-
-shouldReifyInteractionPoints :: TCM Bool
-shouldReifyInteractionPoints = asks envReifyInteractionPoints
-
-- | Gets the include directories.
--
-- Precondition: 'optAbsoluteIncludePaths' must be nonempty (i.e.
@@ -195,7 +174,7 @@ data RelativeTo
getProjectRoot :: RelativeTo -> TCM AbsolutePath
getProjectRoot CurrentDir = liftIO (absolute =<< getCurrentDirectory)
getProjectRoot (ProjectRoot f) = do
- m <- moduleName' f
+ Ranged _ m <- moduleName' f
return (projectRoot f m)
-- | Makes the given directories absolute and stores them as include
@@ -214,11 +193,6 @@ setIncludeDirs incs relativeTo = do
oldIncs <- gets Lens.getAbsoluteIncludePaths
root <- getProjectRoot relativeTo
- check <- case relativeTo of
- CurrentDir -> return (return ())
- ProjectRoot f -> do
- m <- moduleName' f
- return (checkModuleName m f)
-- Add the current dir if no include path is given
incs <- return $ if null incs then ["."] else incs
@@ -247,7 +221,24 @@ setIncludeDirs incs relativeTo = do
setInteractionOutputCallback ho
Lens.putAbsoluteIncludePaths incs
- check
+
+ -- Andreas, 2016-07-11 (reconstructing semantics):
+ --
+ -- Check that the module name of the project root
+ -- is still correct wrt. to the changed include path.
+ --
+ -- E.g. if the include path was "/" and file "/A/B" was named "module A.B",
+ -- and then the include path changes to "/A/", the module name
+ -- becomes invalid; correct would then be "module B".
+
+ case relativeTo of
+ CurrentDir -> return ()
+ ProjectRoot f -> void $ moduleName f
+ -- Andreas, 2016-07-12 WAS:
+ -- do
+ -- Ranged _ m <- moduleName' f
+ -- checkModuleName m f Nothing
+
setInputFile :: FilePath -> TCM ()
setInputFile file =
@@ -301,11 +292,14 @@ showIrrelevantArguments = optShowIrrelevant <$> pragmaOptions
-- | Switch on printing of implicit and irrelevant arguments.
-- E.g. for reification in with-function generation.
withShowAllArguments :: TCM a -> TCM a
-withShowAllArguments ret = do
+withShowAllArguments = withShowAllArguments' True
+
+withShowAllArguments' :: Bool -> TCM a -> TCM a
+withShowAllArguments' yes ret = do
opts <- pragmaOptions
let imp = optShowImplicit opts
irr = optShowIrrelevant opts
- setPragmaOptions $ opts { optShowImplicit = True, optShowIrrelevant = True }
+ setPragmaOptions $ opts { optShowImplicit = yes, optShowIrrelevant = yes }
x <- ret
opts <- pragmaOptions
setPragmaOptions $ opts { optShowImplicit = imp, optShowIrrelevant = irr }
@@ -336,6 +330,9 @@ typeInType = not . optUniverseCheck <$> pragmaOptions
etaEnabled :: TCM Bool
etaEnabled = optEta <$> pragmaOptions
+maxInstanceSearchDepth :: TCM Int
+maxInstanceSearchDepth = optInstanceSearchDepth <$> pragmaOptions
+
------------------------------------------------------------------------
-- Verbosity
@@ -362,7 +359,7 @@ hasVerbosity k n | n < 0 = __IMPOSSIBLE__
| otherwise = do
t <- getVerbosity
let ks = wordsBy (`elem` ".:") k
- m = maximum $ 0 : Trie.lookupPath ks t
+ m = last $ 0 : Trie.lookupPath ks t
return (n <= m)
-- | Displays a debug message in a suitable way.
diff --git a/src/full/Agda/TypeChecking/Monad/Sharing.hs b/src/full/Agda/TypeChecking/Monad/Sharing.hs
index aef2210..36e6b47 100644
--- a/src/full/Agda/TypeChecking/Monad/Sharing.hs
+++ b/src/full/Agda/TypeChecking/Monad/Sharing.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
module Agda.TypeChecking.Monad.Sharing where
diff --git a/src/full/Agda/TypeChecking/Monad/Signature.hs b/src/full/Agda/TypeChecking/Monad/Signature.hs
index c716e79..a6fe715 100644
--- a/src/full/Agda/TypeChecking/Monad/Signature.hs
+++ b/src/full/Agda/TypeChecking/Monad/Signature.hs
@@ -1,9 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Monad.Signature where
@@ -13,6 +9,7 @@ import Control.Arrow (first, second, (***))
import Control.Applicative hiding (empty)
import Control.Monad.State
import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
import Data.List hiding (null)
import Data.Set (Set)
@@ -23,14 +20,13 @@ import Data.Maybe
import Data.Monoid
import Agda.Syntax.Abstract.Name
-import Agda.Syntax.Abstract (Ren)
+import Agda.Syntax.Abstract (Ren, ScopeCopyInfo(..))
import Agda.Syntax.Common
import Agda.Syntax.Internal as I
import Agda.Syntax.Internal.Names
import Agda.Syntax.Position
import Agda.Syntax.Treeless (Compiled(..), TTerm)
-import qualified Agda.Compiler.JS.Parser as JS
import qualified Agda.Compiler.UHC.Pragmas.Base as CR
import Agda.TypeChecking.Monad.Base
@@ -40,6 +36,7 @@ import Agda.TypeChecking.Monad.Env
import Agda.TypeChecking.Monad.Exception ( ExceptionT )
import Agda.TypeChecking.Monad.Mutual
import Agda.TypeChecking.Monad.Open
+import Agda.TypeChecking.Monad.Local
import Agda.TypeChecking.Monad.State
import Agda.TypeChecking.Positivity.Occurrence
import Agda.TypeChecking.Substitute
@@ -70,8 +67,15 @@ addConstant q d = do
reportSLn "tc.signature" 20 $ "adding constant " ++ show q ++ " to signature"
tel <- getContextTelescope
let tel' = replaceEmptyName "r" $ killRange $ case theDef d of
- Constructor{} -> fmap (setHiding Hidden) tel
- _ -> tel
+ Constructor{} -> fmap hideOrKeepInstance tel
+ Function{ funProjection = Just Projection{ projProper = True, projIndex = n } } ->
+ let fallback = fmap hideOrKeepInstance tel in
+ if n > 0 then fallback else
+ -- if the record value is part of the telescope, its hiding should left unchanged
+ case initLast $ telToList tel of
+ Nothing -> fallback
+ Just (doms, dom) -> telFromList $ fmap hideOrKeepInstance doms ++ [dom]
+ _ -> tel
let d' = abstract tel' $ d { defName = q }
reportSLn "tc.signature" 30 $ "lambda-lifted definition = " ++ show d'
modifySignature $ updateDefinitions $ HMap.insertWith (+++) q d'
@@ -134,14 +138,9 @@ addEpicCode q epDef = modifySignature $ updateDefinition q $ updateDefCompiledRe
addEp crep = crep { compiledEpic = Just epDef }
addJSCode :: QName -> String -> TCM ()
-addJSCode q jsDef =
- case JS.parse jsDef of
- Left e ->
- modifySignature $ updateDefinition q $ updateDefCompiledRep $ addJS (Just e)
- Right s ->
- typeError (CompilationError ("Failed to parse ECMAScript (..." ++ s ++ ") for " ++ show q))
+addJSCode q jsDef = modifySignature $ updateDefinition q $ updateDefCompiledRep $ addJS
where
- addJS e crep = crep { compiledJS = e }
+ addJS crep = crep { compiledJS = Just jsDef }
addCoreCode :: QName -> CR.CoreExpr -> TCM ()
addCoreCode q crDef = modifySignature $ updateDefinition q $ updateDefCompiledRep $ addCore crDef
@@ -159,26 +158,14 @@ addCoreType q crTy = modifySignature $ updateDefinition q $ updateDefCompiledRep
where
addCr crep = crep { compiledCore = Just $ CrType crTy }
-markNoSmashing :: QName -> TCM ()
-markNoSmashing q = modifySignature $ updateDefinition q $ mark
- where
- mark def@Defn{theDef = fun@Function{}} =
- def{theDef = fun{funSmashable = False}}
- mark def = def
+setFunctionFlag :: FunctionFlag -> Bool -> QName -> TCM ()
+setFunctionFlag flag val q = modifyGlobalDefinition q $ set (theDefLens . funFlag flag) val
markStatic :: QName -> TCM ()
-markStatic q = modifySignature $ updateDefinition q $ mark
- where
- mark def@Defn{theDef = fun@Function{}} =
- def{theDef = fun{funStatic = True}}
- mark def = def
+markStatic = setFunctionFlag FunStatic True
markInline :: QName -> TCM ()
-markInline q = modifySignature $ updateDefinition q $ mark
- where
- mark def@Defn{theDef = fun@Function{}} =
- def{theDef = fun{funInline = True}}
- mark def = def
+markInline = setFunctionFlag FunInline True
unionSignatures :: [Signature] -> Signature
unionSignatures ss = foldr unionSignature emptySignature ss
@@ -210,67 +197,84 @@ addSection m = do
reportSLn "impossible" 60 $ "with content " ++ show sec
__IMPOSSIBLE__
-- Add the new section.
+ setDefaultModuleParameters m
modifySignature $ over sigSections $ Map.insert m sec
--- | Lookup a section. If it doesn't exist that just means that the module
--- wasn't parameterised.
+setDefaultModuleParameters :: ModuleName -> TCM ()
+setDefaultModuleParameters m =
+ stModuleParameters %= Map.insert m defaultModuleParameters
+
+-- | Get a section.
+--
+-- Why Maybe? The reason is that we look up all prefixes of a module to
+-- compute number of parameters, and for hierarchical top-level modules,
+-- A.B.C say, A and A.B do not exist.
+{-# SPECIALIZE getSection :: ModuleName -> TCM (Maybe Section) #-}
+{-# SPECIALIZE getSection :: ModuleName -> ReduceM (Maybe Section) #-}
+getSection :: (Functor m, ReadTCState m) => ModuleName -> m (Maybe Section)
+getSection m = do
+ sig <- (^. stSignature . sigSections) <$> getTCState
+ isig <- (^. stImports . sigSections) <$> getTCState
+ return $ Map.lookup m sig `mplus` Map.lookup m isig
+
+-- | Lookup a section telescope.
+--
+-- If it doesn't exist, like in hierarchical top-level modules,
+-- the section telescope is empty.
{-# SPECIALIZE lookupSection :: ModuleName -> TCM Telescope #-}
{-# SPECIALIZE lookupSection :: ModuleName -> ReduceM Telescope #-}
lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope
-lookupSection m = do
- sig <- (^. stSignature . sigSections) <$> getTCState
- isig <- (^. stImports . sigSections) <$> getTCState
- return $ maybe EmptyTel (^. secTelescope) $ Map.lookup m sig `mplus` Map.lookup m isig
+lookupSection m = maybe EmptyTel (^. secTelescope) <$> getSection m
-- Add display forms to all names @xn@ such that @x = x1 es1@, ... @xn-1 = xn esn@.
addDisplayForms :: QName -> TCM ()
addDisplayForms x = do
def <- getConstInfo x
- args <- getContextArgs
- add (drop (projectionArgs $ theDef def) args) x x []
+ args <- drop (projectionArgs $ theDef def) <$> getContextArgs
+ add args x x $ map Apply $ raise 1 args -- make room for the single match variable of the display form
where
- add args top x vs0 = do
+ add args top x es0 = do
def <- getConstInfo x
let cs = defClauses def
isCopy = defCopy def
case cs of
- [ Clause{ namedClausePats = pats, clauseBody = b } ]
- | isCopy
- , all (isVar . namedArg) pats
- , Just (m, Def y es) <- strip (b `apply` vs0)
- , Just vs <- mapM isApplyElim es -> do
- let ps = raise 1 $ map unArg vs
- df = Display 0 ps $ DTerm $ Def top $ map Apply args
+ [ cl ] -> do
+ if not isCopy
+ then noDispForm x "not a copy" else do
+ if not $ all (isVar . namedArg) $ namedClausePats cl
+ then noDispForm x "properly matching patterns" else do
+ -- We have
+ -- x ps = e
+ -- and we're trying to generate a display form
+ -- x es0 <-- e[es0/ps]
+ -- Of course x es0 might be an over- or underapplication, hence the
+ -- n/m arithmetic.
+ let n = size $ namedClausePats cl
+ (es1, es2) = splitAt n es0
+ m = n - size es1
+ vs1 = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1
+ sub = parallelS $ reverse $ vs1 ++ replicate m (var 0)
+ body = applySubst sub (compiledClauseBody cl) `applyE` es2
+ case unSpine <$> body of
+ Just (Def y es) -> do
+ let df = Display m es $ DTerm $ Def top $ map Apply args
reportSLn "tc.display.section" 20 $ "adding display form " ++ show y ++ " --> " ++ show top
++ "\n " ++ show df
addDisplayForm y df
- add args top y vs
+ add args top y es
+ Just v -> noDispForm x $ "not a def body, but " ++ show v
+ Nothing -> noDispForm x $ "bad body"
[] | Constructor{ conSrcCon = h } <- theDef def -> do
let y = conName h
- df = Display 0 [] $ DTerm $ Con (h {conName = top }) []
+ df = Display 0 [] $ DTerm $ Con (h {conName = top }) ConOSystem []
reportSLn "tc.display.section" 20 $ "adding display form " ++ show y ++ " --> " ++ show top
++ "\n " ++ show df
addDisplayForm y df
- _ -> do
- let reason = if not isCopy then "not a copy" else
- case cs of
- [] -> "no clauses"
- _:_:_ -> "many clauses"
- [ Clause{ clauseBody = b } ] -> case strip b of
- Nothing -> "bad body"
- Just (m, Def y es)
- | m < length args -> "too few args"
- | m > length args -> "too many args"
- | otherwise -> "args=" ++ show args ++ " es=" ++ show es
- Just (m, v) -> "not a def body, but " ++ show v
- reportSLn "tc.display.section" 30 $
- "no display form from " ++ show x ++ " because " ++ reason
-
- strip (Body v) = return (0, unSpine v)
- strip NoBody = Nothing
- strip (Bind b) = do
- (n, v) <- strip $ absBody b
- return (n + 1, ignoreSharing v)
+ [] -> noDispForm x "no clauses"
+ (_:_:_) -> noDispForm x "many clauses"
+
+ noDispForm x reason = reportSLn "tc.display.section" 30 $
+ "no display form from " ++ show x ++ " because " ++ reason
isVar VarP{} = True
isVar _ = False
@@ -281,12 +285,11 @@ applySection
-> Telescope -- ^ Parameters of new module.
-> ModuleName -- ^ Name of old module applied to arguments.
-> Args -- ^ Arguments of module application.
- -> Ren QName -- ^ Imported names (given as renaming).
- -> Ren ModuleName -- ^ Imported modules (given as renaming).
+ -> ScopeCopyInfo -- ^ Imported names and modules
-> TCM ()
-applySection new ptel old ts rd rm = do
+applySection new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd } = do
rd <- closeConstructors rd
- applySection' new ptel old ts rd rm
+ applySection' new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd }
where
-- If a datatype is being copied, all its constructors need to be copied,
-- and if a constructor is copied its datatype needs to be.
@@ -316,8 +319,8 @@ applySection new ptel old ts rd rm = do
Record{ recConHead = h } -> [conName h]
_ -> []
-applySection' :: ModuleName -> Telescope -> ModuleName -> Args -> Ren QName -> Ren ModuleName -> TCM ()
-applySection' new ptel old ts rd rm = do
+applySection' :: ModuleName -> Telescope -> ModuleName -> Args -> ScopeCopyInfo -> TCM ()
+applySection' new ptel old ts ScopeCopyInfo{ renNames = rd, renModules = rm } = do
reportSLn "tc.mod.apply" 10 $ render $ vcat
[ text "applySection"
, text "new =" <+> text (show new)
@@ -354,10 +357,11 @@ applySection' new ptel old ts rd rm = do
copyDef' np def
where
copyDef' np d = do
- reportSLn "tc.mod.apply" 60 $ "making new def for " ++ show y ++ " from " ++ show x ++ " with " ++ show np ++ " args " ++ show abstr
+ reportSLn "tc.mod.apply" 60 $ "making new def for " ++ show y ++ " from " ++ show x ++ " with " ++ show np ++ " args " ++ show (defAbstract d)
reportSLn "tc.mod.apply" 80 $
"args = " ++ show ts' ++ "\n" ++
- "old type = " ++ prettyShow (defType d) ++ "\n" ++
+ "old type = " ++ prettyShow (defType d)
+ reportSLn "tc.mod.apply" 80 $
"new type = " ++ prettyShow t
addConstant y =<< nd y
makeProjection y
@@ -382,7 +386,6 @@ applySection' new ptel old ts rd rm = do
pol = defPolarity d `apply` ts'
occ = defArgOccurrences d `apply` ts'
inst = defInstance d
- abstr = defAbstract d
-- the name is set by the addConstant function
nd :: QName -> TCM Definition
nd y = for def $ \ df -> Defn
@@ -396,6 +399,7 @@ applySection' new ptel old ts rd rm = do
, defCompiledRep = noCompiledRep
, defInstance = inst
, defCopy = True
+ , defMatchable = False
, theDef = df }
oldDef = theDef d
isCon = case oldDef of { Constructor{} -> True ; _ -> False }
@@ -409,9 +413,9 @@ applySection' new ptel old ts rd rm = do
isVar0 t = case ignoreSharing $ unArg t of Var 0 [] -> True; _ -> False
proj = case oldDef of
Function{funProjection = Just p@Projection{projIndex = n}}
- | size ts < n || (size ts == n && isVar0 (last ts))
- -> Just $ p { projIndex = n - size ts
- , projDropPars = projDropPars p `apply` ts
+ | size ts' < n || (size ts' == n && maybe True isVar0 (lastMaybe ts'))
+ -> Just $ p { projIndex = n - size ts'
+ , projLams = projLams p `apply` ts'
}
_ -> Nothing
def =
@@ -425,26 +429,22 @@ applySection' new ptel old ts rd rm = do
, dataClause = Just cl
, dataCons = map copyName cs
}
- Record{ recPars = np, recConType = t, recTel = tel } -> return $
+ Record{ recPars = np, recTel = tel } -> return $
oldDef { recPars = np - size ts'
, recClause = Just cl
- , recConType = piApply t ts'
, recTel = apply tel ts'
}
_ -> do
cc <- compileClauses Nothing [cl] -- Andreas, 2012-10-07 non need for record pattern translation
- let newDef = Function
+ let newDef =
+ set funMacro (oldDef ^. funMacro) $
+ set funStatic (oldDef ^. funStatic) $
+ set funInline True $
+ emptyFunction
{ funClauses = [cl]
- , funCompiled = Just $ cc
- , funTreeless = Nothing
- , funDelayed = NotDelayed
- , funInv = NotInjective
+ , funCompiled = Just cc
, funMutual = mutual
- , funAbstr = ConcreteDef -- OR: abstr -- ?!
, funProjection = proj
- , funStatic = False
- , funInline = False
- , funSmashable = True
, funTerminates = Just True
, funExtLam = extlam
, funWith = with
@@ -453,14 +453,12 @@ applySection' new ptel old ts rd rm = do
reportSLn "tc.mod.apply" 80 $ "new def for " ++ show x ++ "\n " ++ show newDef
return newDef
- head = case oldDef of
- Function{funProjection = Just Projection{ projDropPars = f}}
- -> f
- _ -> Def x []
cl = Clause { clauseRange = getRange $ defClauses d
, clauseTel = EmptyTel
, namedClausePats = []
- , clauseBody = Body $ head `apply` ts'
+ , clauseBody = Just $ case oldDef of
+ Function{funProjection = Just p} -> projDropParsApply p ProjSystem ts'
+ _ -> Def x $ map Apply ts'
, clauseType = Just $ defaultArg t
, clauseCatchall = False
}
@@ -505,26 +503,29 @@ applySection' new ptel old ts rd rm = do
reportSLn "tc.mod.apply" 80 $ " totalArgs = " ++ show totalArgs
reportSLn "tc.mod.apply" 80 $ " tel = " ++ intercalate " " (map (fst . unDom) $ telToList tel) -- only names
reportSLn "tc.mod.apply" 80 $ " sectionTel = " ++ intercalate " " (map (fst . unDom) $ telToList ptel) -- only names
- addCtxTel sectionTel $ addSection y
+ addContext sectionTel $ addSection y
-- | Add a display form to a definition (could be in this or imported signature).
addDisplayForm :: QName -> DisplayForm -> TCM ()
addDisplayForm x df = do
- d <- makeOpen df
+ d <- makeLocal df
let add = updateDefinition x $ \ def -> def{ defDisplay = d : defDisplay def }
- inCurrentSig <- isJust . HMap.lookup x <$> use (stSignature . sigDefinitions)
- if inCurrentSig
- then modifySignature add
- else stImportsDisplayForms %= HMap.insertWith (++) x [d]
+ ifM (isLocal x)
+ {-then-} (modifySignature add)
+ {-else-} (stImportsDisplayForms %= HMap.insertWith (++) x [d])
whenM (hasLoopingDisplayForm x) $
typeError . GenericDocError $ text "Cannot add recursive display form for" <+> pretty x
-getDisplayForms :: QName -> TCM [Open DisplayForm]
+isLocal :: QName -> TCM Bool
+isLocal x = isJust . HMap.lookup x <$> use (stSignature . sigDefinitions)
+
+getDisplayForms :: QName -> TCM [LocalDisplayForm]
getDisplayForms q = do
ds <- defDisplay <$> getConstInfo q
ds1 <- maybe [] id . HMap.lookup q <$> use stImportsDisplayForms
ds2 <- maybe [] id . HMap.lookup q <$> use stImportedDisplayForms
- return $ ds ++ ds1 ++ ds2
+ ifM (isLocal q) (return $ ds ++ ds1 ++ ds2)
+ (return $ ds1 ++ ds ++ ds2)
-- | Find all names used (recursively) by display forms of a given name.
chaseDisplayForms :: QName -> TCM (Set QName)
@@ -533,7 +534,7 @@ chaseDisplayForms q = go Set.empty [q]
go used [] = pure used
go used (q : qs) = do
let rhs (Display _ _ e) = e -- Only look at names in the right-hand side (#1870)
- ds <- (`Set.difference` used) . Set.unions . map (namesIn . rhs . openThing)
+ ds <- (`Set.difference` used) . Set.unions . map (namesIn . rhs . dget)
<$> (getDisplayForms q `catchError_` \ _ -> pure []) -- might be a pattern synonym
go (Set.union ds used) (Set.toList ds ++ qs)
@@ -546,15 +547,14 @@ canonicalName x = do
def <- theDef <$> getConstInfo x
case def of
Constructor{conSrcCon = c} -> return $ conName c
- Record{recClause = Just (Clause{ clauseBody = body })} -> canonicalName $ extract body
- Datatype{dataClause = Just (Clause{ clauseBody = body })} -> canonicalName $ extract body
+ Record{recClause = Just (Clause{ clauseBody = body })} -> can body
+ Datatype{dataClause = Just (Clause{ clauseBody = body })} -> can body
_ -> return x
where
- extract NoBody = __IMPOSSIBLE__
- extract (Body (Def x _)) = x
- extract (Body (Shared p)) = extract (Body $ derefPtr p)
- extract (Body _) = __IMPOSSIBLE__
- extract (Bind b) = extract (unAbs b)
+ can body = canonicalName $ extract $ fromMaybe __IMPOSSIBLE__ body
+ extract (Def x _) = x
+ extract (Shared p) = extract $ derefPtr p
+ extract _ = __IMPOSSIBLE__
sameDef :: QName -> QName -> TCM (Maybe QName)
sameDef d1 d2 = do
@@ -607,6 +607,11 @@ defaultGetRewriteRulesFor getTCState q = do
look s = HMap.lookup q $ s ^. sigRewriteRules
return $ mconcat $ catMaybes [look sig, look imp]
+-- | Get the original name of the projection
+-- (the current one could be from a module application).
+getOriginalProjection :: HasConstInfo m => QName -> m QName
+getOriginalProjection q = projOrig . fromMaybe __IMPOSSIBLE__ <$> isProjection q
+
instance HasConstInfo (TCMT IO) where
getRewriteRulesFor = defaultGetRewriteRulesFor get
getConstInfo q = join $ pureTCM $ \st env ->
@@ -635,6 +640,10 @@ instance HasConstInfo (TCMT IO) where
dropLastModule q@QName{ qnameModule = m } =
q{ qnameModule = mnameFromList $ ifNull (mnameToList m) __IMPOSSIBLE__ init }
+instance (HasConstInfo m) => HasConstInfo (MaybeT m) where
+ getConstInfo = lift . getConstInfo
+ getRewriteRulesFor = lift . getRewriteRulesFor
+
instance (HasConstInfo m, Error err) => HasConstInfo (ExceptionT err m) where
getConstInfo = lift . getConstInfo
getRewriteRulesFor = lift . getRewriteRulesFor
@@ -655,7 +664,10 @@ getPolarity' CmpLeq q = getPolarity q -- composition with Covariant is identity
-- | Set the polarity of a definition.
setPolarity :: QName -> [Polarity] -> TCM ()
-setPolarity q pol = modifySignature $ updateDefinition q $ updateDefPolarity $ const pol
+setPolarity q pol = do
+ reportSLn "tc.polarity.set" 20 $
+ "Setting polarity of " ++ show q ++ " to " ++ show pol ++ "."
+ modifySignature $ updateDefinition q $ updateDefPolarity $ const pol
-- | Get argument occurrence info for argument @i@ of definition @d@ (never fails).
getArgOccurrence :: QName -> Nat -> TCM Occurrence
@@ -665,6 +677,8 @@ getArgOccurrence d i = do
Constructor{} -> StrictPos
_ -> fromMaybe Mixed $ defArgOccurrences def !!! i
+-- | Sets the 'defArgOccurrences' for the given identifier (which
+-- should already exist in the signature).
setArgOccurrences :: QName -> [Occurrence] -> TCM ()
setArgOccurrences d os = modifyArgOccurrences d $ const os
@@ -693,6 +707,27 @@ getCompiled q = do
Function{ funTreeless = t } -> t
_ -> Nothing
+getErasedConArgs :: QName -> TCM [Bool]
+getErasedConArgs q = do
+ def <- getConstInfo q
+ case theDef def of
+ Constructor{ conData = d, conPars = np, conErased = es } -> do
+ ddef <- getConstInfo d
+ case compiledHaskell $ defCompiledRep ddef of
+ Nothing -> return es
+ Just _ -> do
+ -- Can't erase arguments of COMPILED_DATA constructors yet
+ TelV tel _ <- telView $ defType def
+ return $ replicate (size tel - np) False
+ _ -> __IMPOSSIBLE__
+
+setErasedConArgs :: QName -> [Bool] -> TCM ()
+setErasedConArgs q args = modifyGlobalDefinition q setArgs
+ where
+ setArgs def@Defn{theDef = con@Constructor{}} =
+ def{ theDef = con{ conErased = args } }
+ setArgs def = def -- no-op for non-constructors
+
getTreeless :: QName -> TCM (Maybe TTerm)
getTreeless q = fmap cTreeless <$> getCompiled q
@@ -722,15 +757,6 @@ setMutual d m = modifySignature $ updateDefinition d $ updateTheDef $ \ def ->
mutuallyRecursive :: QName -> QName -> TCM Bool
mutuallyRecursive d d' = (d `elem`) <$> getMutual d'
--- | Why Maybe? The reason is that we look up all prefixes of a module to
--- compute number of parameters, and for hierarchical top-level modules,
--- A.B.C say, A and A.B do not exist.
-getSection :: ModuleName -> TCM (Maybe Section)
-getSection m = do
- sig <- use $ stSignature . sigSections
- isig <- use $ stImports . sigSections
- return $ Map.lookup m sig <|> Map.lookup m isig
-
-- | Get the number of parameters to the current module.
getCurrentModuleFreeVars :: TCM Nat
getCurrentModuleFreeVars = size <$> (lookupSection =<< currentModule)
@@ -738,11 +764,16 @@ getCurrentModuleFreeVars = size <$> (lookupSection =<< currentModule)
-- | Compute the number of free variables of a defined name. This is the sum of
-- number of parameters shared with the current module and the number of
-- anonymous variables (if the name comes from a let-bound module).
-{-# SPECIALIZE getDefFreeVars :: QName -> TCM Nat #-}
-{-# SPECIALIZE getDefFreeVars :: QName -> ReduceM Nat #-}
getDefFreeVars :: (Functor m, Applicative m, ReadTCState m, MonadReader TCEnv m) => QName -> m Nat
-getDefFreeVars q = do
- let m = qnameModule q
+getDefFreeVars = getModuleFreeVars . qnameModule
+
+freeVarsToApply :: QName -> TCM Args
+freeVarsToApply = moduleParamsToApply . qnameModule
+
+{-# SPECIALIZE getModuleFreeVars :: ModuleName -> TCM Nat #-}
+{-# SPECIALIZE getModuleFreeVars :: ModuleName -> ReduceM Nat #-}
+getModuleFreeVars :: (Functor m, Applicative m, ReadTCState m, MonadReader TCEnv m) => ModuleName -> m Nat
+getModuleFreeVars m = do
m0 <- commonParentModule m <$> currentModule
(+) <$> getAnonymousVariables m <*> (size <$> lookupSection m0)
@@ -760,40 +791,51 @@ getDefFreeVars q = do
-- module M₃ Θ where
-- ... M₁.M₂.f [insert Γ raised by Θ]
-- @
-freeVarsToApply :: QName -> TCM Args
-freeVarsToApply x = do
- -- Get the correct number of free variables (correctly raised) of @x@.
-
- args <- take <$> getDefFreeVars x <*> getContextArgs
+moduleParamsToApply :: ModuleName -> TCM Args
+moduleParamsToApply m = do
+ -- Get the correct number of free variables (correctly raised) of @m@.
+
+ reportSLn "tc.sig.param" 90 $ "computing module parameters of " ++ show m
+ cxt <- getContext
+ n <- getModuleFreeVars m
+ tel <- take n . telToList <$> lookupSection m
+ sub <- getModuleParameterSub m
+ reportSLn "tc.sig.param" 60 $ unlines $
+ [ " n = " ++ show n
+ , " cxt = " ++ show (map (fmap fst) cxt)
+ , " sub = " ++ show sub
+ ]
+ unless (size tel == n) __IMPOSSIBLE__
+ let args = applySubst sub $ zipWith (\ i a -> var i <$ argFromDom a) (downFrom n) tel
+ reportSLn "tc.sig.param" 60 $ " args = " ++ show args
-- Apply the original ArgInfo, as the hiding information in the current
- -- context might be different from the hiding information expected by @x@.
+ -- context might be different from the hiding information expected by @m@.
- getSection (qnameModule x) >>= \case
+ getSection m >>= \case
Nothing -> do
- -- We have no section for @x@.
+ -- We have no section for @m@.
-- This should only happen for toplevel definitions, and then there
-- are no free vars to apply, or?
-- unless (null args) __IMPOSSIBLE__
-- No, this invariant is violated by private modules, see Issue1701a.
return args
- Just (Section tel) -> do
- -- The section telescope of the home of @x@ should be as least
- -- as long as the number of free vars @x@ is applied to.
+ Just (Section stel) -> do
+ -- The section telescope of @m@ should be as least
+ -- as long as the number of free vars @m@ is applied to.
-- We still check here as in no case, we want @zipWith@ to silently
-- drop some @args@.
-- And there are also anonymous modules, thus, the invariant is not trivial.
- when (size tel < size args) __IMPOSSIBLE__
- return $ zipWith (\ (Dom ai _) (Arg _ v) -> Arg ai v) (telToList tel) args
+ when (size stel < size args) __IMPOSSIBLE__
+ return $ zipWith (\ (Dom ai _) (Arg _ v) -> Arg ai v) (telToList stel) args
-- | Unless all variables in the context are module parameters, create a fresh
-- module to capture the non-module parameters. Used when unquoting to make
-- sure generated definitions work properly.
inFreshModuleIfFreeParams :: TCM a -> TCM a
inFreshModuleIfFreeParams k = do
- a <- getCurrentModuleFreeVars
- b <- size <$> getContext
- if a == b then k else do
+ sub <- getModuleParameterSub =<< currentModule
+ if sub == IdS then k else do
m <- currentModule
m' <- qualifyM m . mnameFromList . (:[]) <$> freshName_ "_"
addSection m'
@@ -824,23 +866,26 @@ makeAbstract d =
, theDef = def
}
where
- makeAbs Datatype {} = Just Axiom
- makeAbs Function {} = Just Axiom
+ makeAbs Axiom = Just Axiom
+ makeAbs Datatype {} = Just AbstractDefn
+ makeAbs Function {} = Just AbstractDefn
makeAbs Constructor{} = Nothing
-- Andreas, 2012-11-18: Make record constructor and projections abstract.
- makeAbs d@Record{} = Just Axiom
- -- Q: what about primitive?
- makeAbs d = Just d
+ makeAbs d@Record{} = Just AbstractDefn
+ makeAbs Primitive{} = __IMPOSSIBLE__
+ makeAbs AbstractDefn = __IMPOSSIBLE__
-- | Enter abstract mode. Abstract definition in the current module are transparent.
-inAbstractMode :: TCM a -> TCM a
+{-# SPECIALIZE inAbstractMode :: TCM a -> TCM a #-}
+inAbstractMode :: MonadReader TCEnv m => m a -> m a
inAbstractMode = local $ \e -> e { envAbstractMode = AbstractMode,
envAllowDestructiveUpdate = False }
-- Allowing destructive updates when seeing through
-- abstract may break the abstraction.
-- | Not in abstract mode. All abstract definitions are opaque.
-inConcreteMode :: TCM a -> TCM a
+{-# SPECIALIZE inConcreteMode :: TCM a -> TCM a #-}
+inConcreteMode :: MonadReader TCEnv m => m a -> m a
inConcreteMode = local $ \e -> e { envAbstractMode = ConcreteMode }
-- | Ignore abstract mode. All abstract definitions are transparent.
@@ -852,14 +897,15 @@ ignoreAbstractMode = local $ \e -> e { envAbstractMode = IgnoreAbstractMode,
-- | Enter concrete or abstract mode depending on whether the given identifier
-- is concrete or abstract.
-inConcreteOrAbstractMode :: QName -> TCM a -> TCM a
+{-# SPECIALIZE inConcreteOrAbstractMode :: QName -> (Definition -> TCM a) -> TCM a #-}
+inConcreteOrAbstractMode :: (MonadReader TCEnv m, HasConstInfo m) => QName -> (Definition -> m a) -> m a
inConcreteOrAbstractMode q cont = do
-- Andreas, 2015-07-01: If we do not ignoreAbstractMode here,
-- we will get ConcreteDef for abstract things, as they are turned into axioms.
- a <- ignoreAbstractMode $ defAbstract <$> getConstInfo q
- case a of
- AbstractDef -> inAbstractMode cont
- ConcreteDef -> inConcreteMode cont
+ def <- ignoreAbstractMode $ getConstInfo q
+ case defAbstract def of
+ AbstractDef -> inAbstractMode $ cont def
+ ConcreteDef -> inConcreteMode $ cont def
-- | Check whether a name might have to be treated abstractly (either if we're
-- 'inAbstractMode' or it's not a local name). Returns true for things not
@@ -904,16 +950,6 @@ sortOfConst q =
Datatype{dataSort = s} -> return s
_ -> fail $ "Expected " ++ show q ++ " to be a datatype."
--- | The number of parameters of a definition.
-defPars :: Definition -> Int
-defPars d = case theDef d of
- Axiom{} -> 0
- def@Function{} -> projectionArgs def
- Datatype {dataPars = n} -> n
- Record {recPars = n} -> n
- Constructor{conPars = n} -> n
- Primitive{} -> 0
-
-- | The number of dropped parameters for a definition.
-- 0 except for projection(-like) functions and constructors.
droppedPars :: Definition -> Int
@@ -924,6 +960,7 @@ droppedPars d = case theDef d of
Record {recPars = _} -> 0 -- not dropped
Constructor{conPars = n} -> n
Primitive{} -> 0
+ AbstractDefn -> __IMPOSSIBLE__
-- | Is it the name of a record projection?
{-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-}
@@ -938,20 +975,18 @@ isProjection_ def =
-- | Is it a function marked STATIC?
isStaticFun :: Defn -> Bool
-isStaticFun Function{ funStatic = b } = b
-isStaticFun _ = False
+isStaticFun = (^. funStatic)
-- | Is it a function marked INLINE?
isInlineFun :: Defn -> Bool
-isInlineFun Function{ funInline = b } = b
-isInlineFun _ = False
+isInlineFun = (^. funInline)
-- | Returns @True@ if we are dealing with a proper projection,
-- i.e., not a projection-like function nor a record field value
-- (projection applied to argument).
isProperProjection :: Defn -> Bool
isProperProjection d = caseMaybe (isProjection_ d) False $ \ isP ->
- if projIndex isP <= 0 then False else isJust $ projProper isP
+ if projIndex isP <= 0 then False else projProper isP
-- | Number of dropped initial arguments of a projection(-like) function.
projectionArgs :: Defn -> Int
@@ -967,11 +1002,11 @@ usesCopatterns q = do
-- | Apply a function @f@ to its first argument, producing the proper
-- postfix projection if @f@ is a projection.
-applyDef :: QName -> Arg Term -> TCM Term
-applyDef f a = do
+applyDef :: ProjOrigin -> QName -> Arg Term -> TCM Term
+applyDef o f a = do
let fallback = return $ Def f [Apply a]
caseMaybeM (isProjection f) fallback $ \ isP -> do
if projIndex isP <= 0 then fallback else do
-- Get the original projection, if existing.
- caseMaybe (projProper isP) fallback $ \ f' -> do
- return $ unArg a `applyE` [Proj f']
+ if not (projProper isP) then fallback else do
+ return $ unArg a `applyE` [Proj o $ projOrig isP]
diff --git a/src/full/Agda/TypeChecking/Monad/Signature.hs-boot b/src/full/Agda/TypeChecking/Monad/Signature.hs-boot
new file mode 100644
index 0000000..1d3e537
--- /dev/null
+++ b/src/full/Agda/TypeChecking/Monad/Signature.hs-boot
@@ -0,0 +1,9 @@
+
+module Agda.TypeChecking.Monad.Signature where
+
+import Agda.Syntax.Internal (ModuleName, Telescope)
+import Agda.TypeChecking.Monad.Base (TCM, ReadTCState)
+
+inFreshModuleIfFreeParams :: TCM a -> TCM a
+lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope
+
diff --git a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs
index ddf1e2c..89b7db8 100644
--- a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs
+++ b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TupleSections #-}
-- | Stuff for sized types that does not require modules
-- "Agda.TypeChecking.Reduce" or "Agda.TypeChecking.Constraints"
@@ -131,11 +129,10 @@ sizeType = El sizeSort <$> primSize
-- | The name of @SIZESUC@.
sizeSucName :: TCM (Maybe QName)
-sizeSucName = liftTCM $
- ifM (not . optSizedTypes <$> pragmaOptions) (return Nothing) $ do
+sizeSucName = do
+ ifM (not . optSizedTypes <$> pragmaOptions) (return Nothing) $ tryMaybe $ do
Def x [] <- ignoreSharing <$> primSizeSuc
- return $ Just x
- `catchError` \_ -> return Nothing
+ return x
sizeSuc :: Nat -> Term -> TCM Term
sizeSuc n v | n < 0 = __IMPOSSIBLE__
diff --git a/src/full/Agda/TypeChecking/Monad/State.hs b/src/full/Agda/TypeChecking/Monad/State.hs
index d1ce131..c58c835 100644
--- a/src/full/Agda/TypeChecking/Monad/State.hs
+++ b/src/full/Agda/TypeChecking/Monad/State.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
-- | Lenses for 'TCState' and more.
@@ -10,7 +11,8 @@ import qualified Control.Exception as E
import Control.Monad.State (put, get, gets, modify)
import Control.Monad.Trans (liftIO)
-import Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
@@ -31,6 +33,7 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.Monad.Base
import {-# SOURCE #-} Agda.TypeChecking.Monad.Options
import Agda.TypeChecking.Positivity.Occurrence
+import Agda.TypeChecking.CompiledClause
import Agda.Utils.Hash
import qualified Agda.Utils.HashMap as HMap
@@ -176,9 +179,6 @@ modifyImportedSignature f = stImports %= f
getSignature :: TCM Signature
getSignature = use stSignature
-getImportedSignature :: TCM Signature
-getImportedSignature = use stImports
-
-- | Update a possibly imported definition. Warning: changes made to imported
-- definitions (during type checking) will not persist outside the current
-- module. This function is currently used to update the compiled
@@ -190,9 +190,6 @@ modifyGlobalDefinition q f = modifySignature (updateDefinition q f) >>
setSignature :: Signature -> TCM ()
setSignature sig = modifySignature $ const sig
-setImportedSignature :: Signature -> TCM ()
-setImportedSignature sig = stImports .= sig
-
-- | Run some computation in a different signature, restore original signature.
withSignature :: Signature -> TCM a -> TCM a
withSignature sig m = do
@@ -203,14 +200,17 @@ withSignature sig m = do
return r
-- ** Modifiers for rewrite rules
-addRewriteRulesFor :: QName -> RewriteRules -> Signature -> Signature
-addRewriteRulesFor f rews =
+addRewriteRulesFor :: QName -> RewriteRules -> [QName] -> Signature -> Signature
+addRewriteRulesFor f rews matchables =
(over sigRewriteRules $ HMap.insertWith mappend f rews)
. (updateDefinition f $ updateTheDef setNotInjective)
+ . (foldr (.) id $ map (\g -> updateDefinition g setMatchable) matchables)
where
setNotInjective def@Function{} = def { funInv = NotInjective }
setNotInjective def = def
+ setMatchable def = def { defMatchable = True }
+
-- ** Modifiers for parts of the signature
lookupDefinition :: QName -> Signature -> Maybe Definition
@@ -241,6 +241,10 @@ updateFunClauses :: ([Clause] -> [Clause]) -> (Defn -> Defn)
updateFunClauses f def@Function{ funClauses = cs} = def { funClauses = f cs }
updateFunClauses f _ = __IMPOSSIBLE__
+updateCompiledClauses :: (Maybe CompiledClauses -> Maybe CompiledClauses) -> (Defn -> Defn)
+updateCompiledClauses f def@Function{ funCompiled = cc} = def { funCompiled = f cc }
+updateCompiledClauses f _ = __IMPOSSIBLE__
+
---------------------------------------------------------------------------
-- * Top level module
---------------------------------------------------------------------------
@@ -380,11 +384,12 @@ freshTCM m = do
---------------------------------------------------------------------------
-- | Look through the signature and reconstruct the instance table.
-addSignatureInstances :: Signature -> TCM ()
-addSignatureInstances sig = do
- let itable = Map.fromListWith (++)
- [ (c, [i]) | (i, Defn{ defInstance = Just c }) <- HMap.toList $ sig ^. sigDefinitions ]
- modifyInstanceDefs $ first $ Map.unionWith (++) itable
+addImportedInstances :: Signature -> TCM ()
+addImportedInstances sig = do
+ let itable = Map.fromListWith Set.union
+ [ (c, Set.singleton i)
+ | (i, Defn{ defInstance = Just c }) <- HMap.toList $ sig ^. sigDefinitions ]
+ stImportedInstanceDefs %= Map.unionWith Set.union itable
-- | Lens for 'stInstanceDefs'.
updateInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> (TCState -> TCState)
@@ -394,20 +399,24 @@ modifyInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> TCM ()
modifyInstanceDefs = modify . updateInstanceDefs
getAllInstanceDefs :: TCM TempInstanceTable
-getAllInstanceDefs = use stInstanceDefs
+getAllInstanceDefs = do
+ (table,xs) <- use stInstanceDefs
+ itable <- use stImportedInstanceDefs
+ let !table' = Map.unionWith Set.union itable table
+ return (table', xs)
-getAnonInstanceDefs :: TCM [QName]
+getAnonInstanceDefs :: TCM (Set QName)
getAnonInstanceDefs = snd <$> getAllInstanceDefs
-- | Remove all instances whose type is still unresolved.
clearAnonInstanceDefs :: TCM ()
-clearAnonInstanceDefs = modifyInstanceDefs $ mapSnd $ const []
+clearAnonInstanceDefs = modifyInstanceDefs $ mapSnd $ const Set.empty
-- | Add an instance whose type is still unresolved.
addUnknownInstance :: QName -> TCM ()
addUnknownInstance x = do
reportSLn "tc.decl.instance" 10 $ "adding definition " ++ show x ++ " to the instance table (the type is not yet known)"
- modifyInstanceDefs $ mapSnd (x:)
+ modifyInstanceDefs $ mapSnd $ Set.insert x
-- | Add instance to some ``class''.
addNamedInstance
@@ -419,4 +428,4 @@ addNamedInstance x n = do
-- Mark x as instance for n.
modifySignature $ updateDefinition x $ \ d -> d { defInstance = Just n }
-- Add x to n's instances.
- modifyInstanceDefs $ mapFst $ Map.insertWith (++) n [x]
+ modifyInstanceDefs $ mapFst $ Map.insertWith Set.union n $ Set.singleton x
diff --git a/src/full/Agda/TypeChecking/Monad/Trace.hs b/src/full/Agda/TypeChecking/Monad/Trace.hs
index cb4dbcb..b83330b 100644
--- a/src/full/Agda/TypeChecking/Monad/Trace.hs
+++ b/src/full/Agda/TypeChecking/Monad/Trace.hs
@@ -45,17 +45,21 @@ traceCall :: MonadTCM tcm => Call -> tcm a -> tcm a
traceCall mkCall m = do
let call = mkCall
callRange = getRange call
- -- Andreas, 2015-02-09 Make sure we do not set a range
- -- outside the current file
- verboseS "check.ranges" 10 $
+ -- Andreas, 2016-09-13 issue #2177
+ -- Since the fix of #2092 we may report an error outside the current file.
+ -- (For instance, if we import a module which then happens to have the
+ -- wrong name.)
+ -- Thus, we no longer crash, but just report the alien range.
+ -- -- Andreas, 2015-02-09 Make sure we do not set a range
+ -- -- outside the current file
+ verboseS "check.ranges" 90 $
Strict.whenJust (rangeFile callRange) $ \f -> do
currentFile <- asks envCurrentPath
when (currentFile /= Just f) $ do
- reportSLn "impossible" 10 $
+ reportSLn "check.ranges" 90 $
prettyShow call ++
- " is trying to set the current range to " ++ show callRange ++
+ " is setting the current range to " ++ show callRange ++
" which is outside of the current file " ++ show currentFile
- __IMPOSSIBLE__
cl <- liftTCM $ buildClosure call
let trace = local $ foldr (.) id $
[ \e -> e { envCall = Just cl } | interestingCall cl ] ++
diff --git a/src/full/Agda/TypeChecking/Patterns/Abstract.hs b/src/full/Agda/TypeChecking/Patterns/Abstract.hs
index e27b85f..53a3868 100644
--- a/src/full/Agda/TypeChecking/Patterns/Abstract.hs
+++ b/src/full/Agda/TypeChecking/Patterns/Abstract.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Tools to manipulate patterns in abstract syntax
@@ -38,12 +37,12 @@ expandLitPattern p = traverse (traverse expand) p
| n < 0 -> __IMPOSSIBLE__
| n > 20 -> tooBig
| otherwise -> do
- Con z _ <- ignoreSharing <$> primZero
- Con s _ <- ignoreSharing <$> primSuc
+ Con z _ _ <- ignoreSharing <$> primZero
+ Con s _ _ <- ignoreSharing <$> primSuc
let zero = A.ConP cinfo (A.AmbQ [setRange r $ conName z]) []
suc p = A.ConP cinfo (A.AmbQ [setRange r $ conName s]) [defaultNamedArg p]
info = A.PatRange r
- cinfo = A.ConPatInfo ConPCon info
+ cinfo = A.ConPatInfo ConOCon info
p' = foldr ($) zero $ genericReplicate n suc
return $ foldr (A.AsP info) p' xs
_ -> return p
@@ -80,6 +79,7 @@ instance ExpandPatternSynonyms A.Pattern where
A.DotP{} -> return p
A.LitP{} -> return p
A.AbsurdP{} -> return p
+ A.ProjP{} -> return p
A.ConP i ds as -> A.ConP i ds <$> expandPatternSynonyms as
A.DefP i q as -> A.DefP i q <$> expandPatternSynonyms as
A.AsP i x p -> A.AsP i x <$> expandPatternSynonyms p
diff --git a/src/full/Agda/TypeChecking/Patterns/Match.hs b/src/full/Agda/TypeChecking/Patterns/Match.hs
index 1cfe33f..acede98 100644
--- a/src/full/Agda/TypeChecking/Patterns/Match.hs
+++ b/src/full/Agda/TypeChecking/Patterns/Match.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NondecreasingIndentation #-}
-- | Pattern matcher used in the reducer for clauses that
-- have not been compiled to case trees yet.
@@ -9,6 +9,8 @@ module Agda.TypeChecking.Patterns.Match where
import Prelude hiding (null)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
import Data.Monoid
import Data.Traversable (traverse)
@@ -20,10 +22,16 @@ import Agda.TypeChecking.Reduce.Monad
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Monad hiding (reportSDoc)
import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Records
+import Agda.TypeChecking.Datatypes
+import Agda.Utils.Empty
import Agda.Utils.Functor (for, ($>))
+import Agda.Utils.List
+import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
+import Agda.Utils.Singleton
import Agda.Utils.Size
import Agda.Utils.Tuple
@@ -32,7 +40,7 @@ import Agda.Utils.Impossible
-- | If matching is inconclusive (@DontKnow@) we want to know whether
-- it is due to a particular meta variable.
-data Match a = Yes Simplification [a]
+data Match a = Yes Simplification (IntMap (Arg a))
| No
| DontKnow (Blocked ())
deriving Functor
@@ -42,6 +50,17 @@ instance Null (Match a) where
null (Yes simpl as) = null simpl && null as
null _ = False
+matchedArgs :: Empty -> Int -> IntMap (Arg a) -> [Arg a]
+matchedArgs err n vs = map get [0..n-1]
+ where
+ get k = fromMaybe (absurd err) $ IntMap.lookup k vs
+
+-- | Builds a proper substitution from an IntMap produced by match(Co)patterns
+buildSubstitution :: (DeBruijn a)
+ => Empty -> Int -> IntMap (Arg a) -> Substitution' a
+buildSubstitution err n vs = parallelS $ map unArg $ matchedArgs err n vs
+
+
-- 'mappend' is UNUSED.
--
-- instance Monoid (Match a) where
@@ -96,15 +115,15 @@ foldMatch match = loop where
(r', vs') <- loop ps vs
let vs1 = v' : vs'
case r' of
- Yes s' us' -> return (Yes (s `mappend` s') (us ++ us'), vs1)
- No -> return (No , vs1)
- DontKnow m -> return (DontKnow m , vs1)
+ Yes s' us' -> return (Yes (s `mappend` s') (us `mappend` us'), vs1)
+ No -> return (No , vs1)
+ DontKnow m -> return (DontKnow m , vs1)
_ -> __IMPOSSIBLE__
-- | @matchCopatterns ps es@ matches spine @es@ against copattern spine @ps@.
--
-- Returns 'Yes' and a substitution for the pattern variables
--- (in form of [Term]) if matching was successful.
+-- (in form of IntMap Term) if matching was successful.
--
-- Returns 'No' if there was a constructor or projection mismatch.
--
@@ -114,7 +133,9 @@ foldMatch match = loop where
-- In any case, also returns spine @es@ in reduced form
-- (with all the weak head reductions performed that were necessary
-- to come to a decision).
-matchCopatterns :: [NamedArg Pattern] -> [Elim] -> ReduceM (Match Term, [Elim])
+matchCopatterns :: [NamedArg DeBruijnPattern]
+ -> [Elim]
+ -> ReduceM (Match Term, [Elim])
matchCopatterns ps vs = do
traceSDoc "tc.match" 50
(vcat [ text "matchCopatterns"
@@ -126,15 +147,21 @@ matchCopatterns ps vs = do
foldMatch (matchCopattern . namedArg) ps vs
-- | Match a single copattern.
-matchCopattern :: Pattern -> Elim -> ReduceM (Match Term, Elim)
-matchCopattern (ProjP p) elim@(Proj q)
- | p == q = return (Yes YesSimplification [], elim)
- | otherwise = return (No , elim)
+matchCopattern :: DeBruijnPattern
+ -> Elim
+ -> ReduceM (Match Term, Elim)
+matchCopattern pat@ProjP{} elim@(Proj _ q) = do
+ ProjP _ p <- normaliseProjP pat
+ q <- getOriginalProjection q
+ return $ if p == q then (Yes YesSimplification empty, elim)
+ else (No, elim)
matchCopattern ProjP{} Apply{} = __IMPOSSIBLE__
matchCopattern _ Proj{} = __IMPOSSIBLE__
matchCopattern p (Apply v) = mapSnd Apply <$> matchPattern p v
-matchPatterns :: [NamedArg Pattern] -> [Arg Term] -> ReduceM (Match Term, [Arg Term])
+matchPatterns :: [NamedArg DeBruijnPattern]
+ -> [Arg Term]
+ -> ReduceM (Match Term, [Arg Term])
matchPatterns ps vs = do
traceSDoc "tc.match" 50
(vcat [ text "matchPatterns"
@@ -147,36 +174,51 @@ matchPatterns ps vs = do
foldMatch (matchPattern . namedArg) ps vs
-- | Match a single pattern.
-matchPattern :: Pattern -> Arg Term -> ReduceM (Match Term, Arg Term)
+matchPattern :: DeBruijnPattern
+ -> Arg Term
+ -> ReduceM (Match Term, Arg Term)
matchPattern p u = case (p, u) of
(ProjP{}, _ ) -> __IMPOSSIBLE__
- (VarP _ , arg@(Arg _ v)) -> return (Yes NoSimplification [v], arg)
- (DotP _ , arg@(Arg _ v)) -> return (Yes NoSimplification [v], arg)
+ (VarP x , arg ) -> return (Yes NoSimplification entry, arg)
+ where entry = singleton (dbPatVarIndex x, arg)
+ (DotP _ , arg@(Arg _ v)) -> return (Yes NoSimplification empty, arg)
(LitP l , arg@(Arg _ v)) -> do
w <- reduceB' v
let arg' = arg $> ignoreBlocking w
case ignoreSharing <$> w of
NotBlocked _ (Lit l')
- | l == l' -> return (Yes YesSimplification [] , arg')
+ | l == l' -> return (Yes YesSimplification empty , arg')
| otherwise -> return (No , arg')
NotBlocked _ (MetaV x _) -> return (DontKnow $ Blocked x () , arg')
Blocked x _ -> return (DontKnow $ Blocked x () , arg')
NotBlocked r t -> return (DontKnow $ NotBlocked r' () , arg')
where r' = stuckOn (Apply arg') r
- -- Case record pattern: always succeed!
- -- This case is necessary if we want to use the clauses before
- -- record pattern translation (e.g., in type-checking definitions by copatterns).
- (ConP con@(ConHead c _ ds) ConPatternInfo{conPRecord = Just{}} ps, arg@(Arg info v))
- -- precondition: con actually comes with the record fields
- | size ds == size ps -> mapSnd (Arg info . Con con) <$> do
- matchPatterns ps $ for ds $ \ d -> Arg info $ v `applyE` [Proj d]
- -- TODO: correct info for projected terms
- | otherwise -> __IMPOSSIBLE__
-
- -- Case data constructor pattern.
- (ConP c _ ps, Arg info v) ->
- do w <- traverse constructorForm =<< reduceB' v
+ -- Case constructor pattern.
+ (ConP c cpi ps, Arg info v) -> do
+ if isNothing $ conPRecord cpi then fallback else do
+ isEtaRecordCon (conName c) >>= \case
+ Nothing -> fallback
+ Just fs -> do
+ -- Case: Eta record constructor.
+ -- This case is necessary if we want to use the clauses before
+ -- record pattern translation (e.g., in type-checking definitions by copatterns).
+ unless (size fs == size ps) __IMPOSSIBLE__
+ mapSnd (Arg info . Con c (fromConPatternInfo cpi)) <$> do
+ matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f]
+ where
+ isEtaRecordCon :: QName -> ReduceM (Maybe [Arg QName])
+ isEtaRecordCon c = do
+ (theDef <$> getConstInfo c) >>= \case
+ Constructor{ conData = d } -> do
+ (theDef <$> getConstInfo d) >>= \case
+ r@Record{ recFields = fs } | recEtaEquality r -> return $ Just fs
+ _ -> return Nothing
+ _ -> __IMPOSSIBLE__
+
+ -- Default: not an eta record constructor.
+ fallback = do
+ w <- reduceB' v
-- Unfold delayed (corecursive) definitions one step. This is
-- only necessary if c is a coinductive constructor, but
-- 1) it does not hurt to do it all the time, and
@@ -192,21 +234,24 @@ matchPattern p u = case (p, u) of
-- unfolded (due to open public).
_ -> return w
-}
- w <- case w of
+ -- Jesper, 23-06-2016: Note that unfoldCorecursion may destroy
+ -- constructor forms, so we only call constructorForm after.
+ w <- traverse constructorForm =<< case w of
NotBlocked r u -> unfoldCorecursion u -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient?
_ -> return w
let v = ignoreBlocking w
arg = Arg info v -- the reduced argument
case ignoreSharing <$> w of
- NotBlocked _ (Con c' vs)
+ NotBlocked _ (Con c' ci vs)
| c == c' -> do
(m, vs) <- yesSimplification <$> matchPatterns ps vs
- return (m, Arg info $ Con c' vs)
+ return (m, Arg info $ Con c' ci vs)
| otherwise -> return (No , arg)
NotBlocked _ (MetaV x vs) -> return (DontKnow $ Blocked x () , arg)
Blocked x _ -> return (DontKnow $ Blocked x () , arg)
NotBlocked r _ -> return (DontKnow $ NotBlocked r' () , arg)
where r' = stuckOn (Apply arg) r
+
-- ASR (08 November 2014). The type of the function could be
--
-- @(Match Term, [Arg Term]) -> (Match Term, [Arg Term])@.
diff --git a/src/full/Agda/TypeChecking/Patterns/Match.hs-boot b/src/full/Agda/TypeChecking/Patterns/Match.hs-boot
index d8d7135..eb7ba5c 100644
--- a/src/full/Agda/TypeChecking/Patterns/Match.hs-boot
+++ b/src/full/Agda/TypeChecking/Patterns/Match.hs-boot
@@ -1,11 +1,19 @@
module Agda.TypeChecking.Patterns.Match where
+import Data.IntMap (IntMap)
+
import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.TypeChecking.Monad
+import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM)
+import Agda.TypeChecking.Substitute (DeBruijn)
+
+import Agda.Utils.Empty
+
+data Match a = Yes Simplification (IntMap (Arg a)) | No | DontKnow (Blocked ())
-data Match a = Yes Simplification [a] | No | DontKnow (Blocked ())
+buildSubstitution :: (DeBruijn a) => Empty -> Int -> IntMap (Arg a) -> Substitution' a
-matchPatterns :: [NamedArg Pattern] -> Args -> ReduceM (Match Term, Args)
-matchCopatterns :: [NamedArg Pattern] -> Elims -> ReduceM (Match Term, Elims)
+matchPatterns :: [NamedArg DeBruijnPattern] -> Args -> ReduceM (Match Term, Args)
+matchCopatterns :: [NamedArg DeBruijnPattern] -> Elims -> ReduceM (Match Term, Elims)
diff --git a/src/full/Agda/TypeChecking/Polarity.hs b/src/full/Agda/TypeChecking/Polarity.hs
index df42617..dfe150e 100644
--- a/src/full/Agda/TypeChecking/Polarity.hs
+++ b/src/full/Agda/TypeChecking/Polarity.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Polarity where
@@ -92,11 +90,10 @@ purgeNonvariant = map (\ p -> if p == Nonvariant then Covariant else p)
-- | Main function of this module.
computePolarity :: QName -> TCM ()
-computePolarity x = inConcreteOrAbstractMode x $ do
+computePolarity x = inConcreteOrAbstractMode x $ \ def -> do
reportSLn "tc.polarity.set" 25 $ "Computing polarity of " ++ show x
-- get basic polarity from positivity analysis
- def <- getConstInfo x
let npars = droppedPars def
let pol0 = replicate npars Nonvariant ++ map polFromOcc (defArgOccurrences def)
reportSLn "tc.polarity.set" 15 $ "Polarity of " ++ show x ++ " from positivity: " ++ show pol0
@@ -165,13 +162,13 @@ usagePolarity :: Defn -> [Polarity]
usagePolarity def = case def of
Axiom{} -> []
Function{ funClauses = [] } -> []
- Function{ funClauses = cs } -> usage $ map clausePats cs
+ Function{ funClauses = cs } -> usage $ map namedClausePats cs
Datatype{ dataPars = np, dataIxs = ni } -> genericReplicate np Nonvariant
Record{ recPars = n } -> genericReplicate n Nonvariant
Constructor{} -> []
Primitive{} -> []
where
- usage = foldr1 (zipWith (/\)) . map (map (usagePat . unArg))
+ usage = foldr1 (zipWith (/\)) . map (map (usagePat . namedArg))
usagePat VarP{} = Nonvariant
usagePat DotP{} = Nonvariant
usagePat ConP{} = Invariant
@@ -258,7 +255,7 @@ nonvariantToUnusedArgInClause pol cl@Clause{clauseTel = tel, namedClausePats = p
-- get a list of 'Relevance's for the variables bound in the pattern
rels0 = getRelevance <$> (concatMap (patternVars . fmap namedThing) ps')
-- this is the order the variables appear in the telescope
- perm = clausePerm cl
+ perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl
rels = permute perm rels0
-- now improve 'Relevance' in 'Telescope' by pattern relevance
updateDom UnusedArg = mapRelevance mkUnused
@@ -293,7 +290,7 @@ sizePolarity d pol0 = do
-- and seek confirm it by looking at the constructor types
let check c = do
t <- defType <$> getConstInfo c
- addCtxTel (telFromList parTel) $ do
+ addContext (telFromList parTel) $ do
let pars = map (defaultArg . var) $ downFrom np
TelV conTel target <- telView =<< (t `piApplyM` pars)
case conTel of
@@ -387,7 +384,7 @@ instance HasPolarity Type where
polarities i (El _ v) = polarities i v
instance HasPolarity a => HasPolarity (Elim' a) where
- polarities i (Proj p) = return []
+ polarities i Proj{} = return []
polarities i (Apply a) = polarities i a
instance HasPolarity Term where
@@ -405,7 +402,7 @@ instance HasPolarity Term where
pols <- getPolarity x
let compose p ps = map (composePol p) ps
concat . zipWith compose (pols ++ repeat Invariant) <$> mapM (polarities i) ts
- Con _ ts -> polarities i ts -- constructors can be seen as monotone in all args.
+ Con _ _ ts -> polarities i ts -- constructors can be seen as monotone in all args.
Pi a b -> (++) <$> (map neg <$> polarities i a) <*> polarities i b
Sort s -> return [] -- polarities i s -- return []
MetaV _ ts -> map (const Invariant) <$> polarities i ts
diff --git a/src/full/Agda/TypeChecking/Positivity.hs b/src/full/Agda/TypeChecking/Positivity.hs
index d7add67..f94cf4b 100644
--- a/src/full/Agda/TypeChecking/Positivity.hs
+++ b/src/full/Agda/TypeChecking/Positivity.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Check that a datatype is strictly positive.
@@ -13,28 +10,31 @@ import Prelude hiding (null)
import Control.Applicative hiding (empty)
import Control.DeepSeq
import Control.Monad.Reader
+import Control.Monad.State (get)
import Data.Either
import qualified Data.Foldable as Fold
import Data.Function
import Data.Graph (SCC(..), flattenSCC)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
import Data.List as List hiding (null)
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Monoid (mconcat)
import qualified Data.Sequence as DS
import Data.Set (Set)
import qualified Data.Set as Set
import Debug.Trace
-import Test.QuickCheck
-
import Agda.Syntax.Common
import qualified Agda.Syntax.Info as Info
+import Agda.Syntax.Position (fuseRange, Range, HasRange(..), noRange)
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import Agda.TypeChecking.Datatypes (isDataOrRecordType, DataOrRecord(..))
-import Agda.TypeChecking.Records (unguardedRecord, recursiveRecord)
+import Agda.TypeChecking.Records
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin (primInf, CoinductionKit(..), coinductionKit)
import Agda.TypeChecking.Reduce
@@ -51,6 +51,7 @@ import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Utils.Permutation as Perm
import Agda.Utils.SemiRing
+import Agda.Utils.Singleton
import Agda.Utils.Size
#include "undefined.h"
@@ -109,7 +110,7 @@ checkStrictlyPositive mi qset = disableDestructiveUpdate $ do
checkPos :: Graph Node Edge ->
Graph Node Occurrence ->
QName -> TCM ()
- checkPos g gstar q = inConcreteOrAbstractMode q $ do
+ checkPos g gstar q = inConcreteOrAbstractMode q $ \ _def -> do
-- we check positivity only for data or record definitions
whenJustM (isDatatype q) $ \ dr -> do
reportSDoc "tc.pos.check" 10 $ text "Checking positivity of" <+> prettyTCM q
@@ -122,15 +123,17 @@ checkStrictlyPositive mi qset = disableDestructiveUpdate $ do
-- which relates productOfEdgesInBoundedWalk to
-- gaussJordanFloydWarshallMcNaughtonYamada.
- how :: String -> Occurrence -> TCM Doc
- how msg bound =
+ reason bound =
case productOfEdgesInBoundedWalk
occ g (DefNode q) (DefNode q) bound of
- Just (Edge _ how) -> fsep $
+ Just (Edge _ how) -> how
+ Nothing -> __IMPOSSIBLE__
+
+ how :: String -> Occurrence -> TCM Doc
+ how msg bound = fsep $
[prettyTCM q] ++ pwords "is" ++
pwords (msg ++ ", because it occurs") ++
- [prettyTCM how]
- Nothing -> __IMPOSSIBLE__
+ [prettyTCM (reason bound)]
-- if we have a negative loop, raise error
@@ -140,9 +143,8 @@ checkStrictlyPositive mi qset = disableDestructiveUpdate $ do
when (Info.mutualPositivityCheck mi) $
whenM positivityCheckEnabled $
case loop of
- Just o | o <= JustPos -> do
- err <- how "not strictly positive" JustPos
- setCurrentRange q $ typeError $ GenericDocError err
+ Just o | o <= JustPos ->
+ warning $ NotStrictlyPositive q (reason JustPos)
_ -> return ()
-- if we find an unguarded record, mark it as such
@@ -157,6 +159,13 @@ checkStrictlyPositive mi qset = disableDestructiveUpdate $ do
reportSDoc "tc.pos.record" 5 $ how "recursive" GuardPos
recursiveRecord q
checkInduction q
+ -- If the record is not recursive, switch on eta
+ -- unless it is coinductive or a no-eta-equality record.
+ Nothing -> do
+ reportSDoc "tc.pos.record" 10 $
+ text "record type " <+> prettyTCM q <+>
+ text "is not recursive"
+ nonRecursiveRecord q
_ -> return ()
checkInduction :: QName -> TCM ()
@@ -202,9 +211,9 @@ checkStrictlyPositive mi qset = disableDestructiveUpdate $ do
-- Compute a map from each name in q to the maximal argument index
let maxs = Map.fromListWith max
[ (q, i) | ArgNode q i <- Set.toList $ Graph.sourceNodes g, q `Set.member` qset ]
- forM_ qs $ \ q -> inConcreteOrAbstractMode q $ do
+ forM_ qs $ \ q -> inConcreteOrAbstractMode q $ \ def -> do
reportSDoc "tc.pos.args" 10 $ text "checking args of" <+> prettyTCM q
- n <- getDefArity =<< getConstInfo q
+ n <- getDefArity def
-- If there is no outgoing edge @ArgNode q i@, all @n@ arguments are @Unused@.
-- Otherwise, we obtain the occurrences from the Graph.
let findOcc i = fromMaybe Unused $ Graph.lookup (ArgNode q i) (DefNode q) g
@@ -231,37 +240,14 @@ getDefArity def = case theDef def of
Record{ recPars = n } -> return n
_ -> return 0
--- Specification of occurrences -------------------------------------------
+-- Operations on occurrences -------------------------------------------
-- See also Agda.TypeChecking.Positivity.Occurrence.
--- | Description of an occurrence.
-data OccursWhere
- = Unknown
- -- ^ an unknown position (treated as negative)
- | Known (DS.Seq Where)
- -- ^ The elements of the sequence, from left to right, explain how
- -- to get to the occurrence.
- deriving (Show, Eq, Ord)
-
--- | One part of the description of an occurrence.
-data Where
- = LeftOfArrow
- | DefArg QName Nat -- ^ in the nth argument of a define constant
- | UnderInf -- ^ in the principal argument of built-in ∞
- | VarArg -- ^ as an argument to a bound variable
- | MetaArg -- ^ as an argument of a metavariable
- | ConArgType QName -- ^ in the type of a constructor
- | IndArgType QName -- ^ in a datatype index of a constructor
- | InClause Nat -- ^ in the nth clause of a defined function
- | Matched -- ^ matched against in a clause of a defined function
- | InDefOf QName -- ^ in the definition of a constant
- deriving (Show, Eq, Ord)
-
(>*<) :: OccursWhere -> OccursWhere -> OccursWhere
-Unknown >*< _ = Unknown
-Known _ >*< Unknown = Unknown
-Known os1 >*< Known os2 = Known (os1 DS.>< os2)
+Unknown >*< _ = Unknown
+Known _ _ >*< Unknown = Unknown
+Known r1 os1 >*< Known r2 os2 = Known (fuseRange r1 r2) (os1 DS.>< os2)
instance PrettyTCM OccursWhere where
prettyTCM o = prettyOs $ map maxOneLeftOfArrow $ uniq $ splitOnDef o
@@ -278,8 +264,8 @@ instance PrettyTCM OccursWhere where
prettyOs [o] = prettyO o <> text "."
prettyOs (o:os) = prettyO o <> text ", which occurs" $$ prettyOs os
- prettyO Unknown = empty
- prettyO (Known ws) =
+ prettyO Unknown = empty
+ prettyO (Known _ ws) =
Fold.foldrM (\w d -> return d $$ fsep (prettyW w)) empty ws
prettyW w = case w of
@@ -298,8 +284,8 @@ instance PrettyTCM OccursWhere where
Matched -> pwords "as matched against"
InDefOf d -> pwords "in the definition of" ++ [prettyTCM d]
- maxOneLeftOfArrow Unknown = Unknown
- maxOneLeftOfArrow (Known ws) = Known $
+ maxOneLeftOfArrow Unknown = Unknown
+ maxOneLeftOfArrow (Known r ws) = Known r $
noArrows
DS.><
case DS.viewl startsWithArrow of
@@ -311,20 +297,20 @@ instance PrettyTCM OccursWhere where
isArrow LeftOfArrow{} = True
isArrow _ = False
- splitOnDef Unknown = [Unknown]
- splitOnDef (Known ws) = split ws DS.empty
+ splitOnDef Unknown = [Unknown]
+ splitOnDef (Known r ws) = split ws DS.empty
where
split ws acc = case DS.viewl ws of
w@InDefOf{} DS.:< ws -> let rest = split ws (DS.singleton w) in
if DS.null acc
then rest
- else Known acc : rest
+ else Known r acc : rest
w DS.:< ws -> split ws (acc DS.|> w)
- DS.EmptyL -> [Known acc]
+ DS.EmptyL -> [Known r acc]
instance Sized OccursWhere where
- size Unknown = 1
- size (Known ws) = 1 + size ws
+ size Unknown = 1
+ size (Known _ ws) = 1 + size ws
-- Computing occurrences --------------------------------------------------
@@ -332,6 +318,10 @@ data Item = AnArg Nat
| ADef QName
deriving (Eq, Ord, Show)
+instance HasRange Item where
+ getRange (AnArg _) = noRange
+ getRange (ADef qn) = getRange qn
+
type Occurrences = Map Item [OccursWhere]
-- | Used to build 'Occurrences' and occurrence graphs.
@@ -377,7 +367,7 @@ preprocess ob = case pp Nothing DS.empty ob of
pp m ws (OccursAs w ob) = OccursAs' w <$> pp m (ws DS.|> w) ob
pp m ws (OnlyVarsUpTo n ob) = pp (Just $! maybe n (min n) m) ws ob
pp m ws (OccursHere i) = do guard keep
- return (OccursHere' i (Known ws))
+ return (OccursHere' i (Known (getRange i) ws))
where
keep = case (m, i) of
(Nothing, _) -> True
@@ -427,7 +417,10 @@ data OccEnv = OccEnv
type OccM = Reader OccEnv
withExtendedOccEnv :: Maybe Item -> OccM a -> OccM a
-withExtendedOccEnv i = local $ \ e -> e { vars = i : vars e }
+withExtendedOccEnv i = withExtendedOccEnv' [i]
+
+withExtendedOccEnv' :: [Maybe Item] -> OccM a -> OccM a
+withExtendedOccEnv' is = local $ \ e -> e { vars = is ++ vars e }
-- | Running the monad
getOccurrences
@@ -444,30 +437,27 @@ class ComputeOccurrences a where
instance ComputeOccurrences Clause where
occurrences cl = do
- let ps = unnumberPatVars $ clausePats cl
+ let ps = namedClausePats cl
+ items = IntMap.elems $ patItems ps -- sorted from low to high DBI
(Concat (mapMaybe matching (zip [0..] ps)) >+<) <$>
- walk (patItems ps) (clauseBody cl)
+ withExtendedOccEnv' items (occurrences $ clauseBody cl)
where
matching (i, p)
- | properlyMatching (unArg p) = Just $ OccursAs Matched $
- OccursHere $ AnArg i
+ | properlyMatching (namedThing $ unArg p) =
+ Just $ OccursAs Matched $ OccursHere $ AnArg i
| otherwise = Nothing
- walk _ NoBody = return emptyOB
- walk [] (Body v) = occurrences v
- walk (i : pis) (Bind b) = withExtendedOccEnv i $ walk pis $ absBody b
- walk [] Bind{} = __IMPOSSIBLE__
- walk (_ : _) Body{} = __IMPOSSIBLE__
-
-- @patItems ps@ creates a map from the pattern variables of @ps@
-- to the index of the argument they are bound in.
- -- This map is given as a list.
- patItems ps = concat $ zipWith patItem [0..] ps
+ patItems ps = mconcat $ zipWith patItem [0..] ps
- -- @patItem i p@ replicates index @i@ as often as there are
- -- pattern variables in @p@ (dot patterns count as variable)
- patItem :: Int -> Arg Pattern -> [Maybe Item]
- patItem i p = map (const $ Just $ AnArg i) $ patternVars p
+ -- @patItem i p@ assigns index @i@ to each pattern variable in @p@
+ patItem :: Int -> NamedArg DeBruijnPattern -> IntMap (Maybe Item)
+ patItem i p = Fold.foldMap makeEntry ixs
+ where
+ ixs = map dbPatVarIndex $ lefts $ map unArg $ patternVars $ namedThing <$> p
+
+ makeEntry x = singleton (x, Just $ AnArg i)
instance ComputeOccurrences Term where
occurrences v = case unSpine v of
@@ -490,7 +480,7 @@ instance ComputeOccurrences Term where
if n == 1 then OccursAs UnderInf else OccursAs (DefArg d n)
occs <- mapM occurrences args
return $ OccursHere (ADef d) >+< Concat (zipWith occsAs [0..] occs)
- Con c args -> occurrences args
+ Con _ _ args -> occurrences args
MetaV _ args -> OccursAs MetaArg <$> occurrences args
Pi a b -> do
oa <- occurrences a
@@ -512,7 +502,11 @@ instance ComputeOccurrences PlusLevel where
instance ComputeOccurrences LevelAtom where
occurrences l = case l of
- MetaLevel _ vs -> OccursAs MetaArg <$> occurrences vs
+ MetaLevel x es -> occurrences $ MetaV x es
+ -- Andreas, 2016-07-25, issue 2108
+ -- NOT: OccursAs MetaArg <$> occurrences vs
+ -- since we need to unSpine!
+ -- (Otherwise, we run into __IMPOSSIBLE__ at Proj elims)
BlockedLevel _ v -> occurrences v
NeutralLevel _ v -> occurrences v
UnreducedLevel v -> occurrences v
@@ -541,6 +535,10 @@ instance ComputeOccurrences a => ComputeOccurrences (Dom a) where
instance ComputeOccurrences a => ComputeOccurrences [a] where
occurrences vs = Concat <$> mapM occurrences vs
+instance ComputeOccurrences a => ComputeOccurrences (Maybe a) where
+ occurrences (Just v) = occurrences v
+ occurrences Nothing = return emptyOB
+
instance (ComputeOccurrences a, ComputeOccurrences b) => ComputeOccurrences (a, b) where
occurrences (x, y) = do
ox <- occurrences x
@@ -557,12 +555,13 @@ computeOccurrences q = flatten <$> computeOccurrences' q
-- | Computes the occurrences in the given definition.
computeOccurrences' :: QName -> TCM OccurrencesBuilder
-computeOccurrences' q = inConcreteOrAbstractMode q $ do
+computeOccurrences' q = inConcreteOrAbstractMode q $ \ def -> do
reportSDoc "tc.pos" 25 $ do
- a <- defAbstract <$> getConstInfo q
+ let a = defAbstract def
m <- asks envAbstractMode
+ cur <- asks envCurrentModule
text "computeOccurrences" <+> prettyTCM q <+> text (show a) <+> text (show m)
- def <- getConstInfo q
+ <+> prettyTCM cur
OccursAs (InDefOf q) <$> case theDef def of
Function{funClauses = cs} -> do
n <- getDefArity def
@@ -597,33 +596,31 @@ computeOccurrences' q = inConcreteOrAbstractMode q $ do
Constructor{} -> return emptyOB
Axiom{} -> return emptyOB
Primitive{} -> return emptyOB
+ AbstractDefn -> __IMPOSSIBLE__
-- | Eta expand a clause to have the given number of variables.
-- Warning: doesn't put correct types in telescope!
-- This is used instead of special treatment of lambdas
-- (which was unsound: issue 121)
etaExpandClause :: Nat -> Clause -> Clause
-etaExpandClause n c@Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b }
+etaExpandClause n c
| m <= 0 = c
| otherwise = c
- { namedClausePats = raise m ps ++ map (defaultArg . unnamed . VarP . (,underscore)) (downFrom m)
- , clauseBody = liftBody m b
+ { namedClausePats = raise m (namedClausePats c) ++
+ map (\i -> defaultArg $ namedDBVarP i underscore) (downFrom m)
+ , clauseBody = liftBody m $ clauseBody c
, clauseTel = telFromList $
- telToList tel ++ (replicate m $ (underscore,) <$> dummyDom)
+ telToList (clauseTel c) ++ (replicate m $ (underscore,) <$> dummyDom)
-- dummyDom, not __IMPOSSIBLE__, because of debug printing.
}
where
- m = n - genericLength ps
-
- bind 0 = id
- bind n = Bind . Abs underscore . bind (n - 1)
+ m = n - genericLength (namedClausePats c)
vars = map (defaultArg . var) $ downFrom m
-- vars = reverse [ defaultArg $ var i | i <- [0..m - 1] ]
- liftBody m (Bind b) = Bind $ fmap (liftBody m) b
- liftBody m NoBody = bind m NoBody
- liftBody m (Body v) = bind m $ Body $ raise m v `apply` vars
+ liftBody m (Just v) = Just $ raise m v `apply` vars
+ liftBody m Nothing = Nothing
-- Building the occurrence graph ------------------------------------------
@@ -690,9 +687,8 @@ buildOccurrenceGraph qs =
mapM defGraph (Set.toList qs)
where
defGraph :: QName -> TCM [Graph.Edge Node Node Edge]
- defGraph q = do
+ defGraph q = inConcreteOrAbstractMode q $ \ _def -> do
occs <- computeOccurrences' q
- es <- computeEdges qs q occs
reportSDoc "tc.pos.occs" 40 $
(text "Occurrences in" <+> prettyTCM q <> text ":")
@@ -712,6 +708,11 @@ buildOccurrenceGraph qs =
$+$
(nest 2 $ vcat $ map (text . show) os))
(Map.toList (flatten occs)))
+
+ -- Placing this line before the reportSDoc lines above creates a
+ -- space leak: occs is retained for too long.
+ es <- computeEdges qs q occs
+
reportSDoc "tc.pos.occs.edges" 60 $
text "Edges:"
$+$
@@ -800,54 +801,3 @@ computeEdges muts q ob =
return $ case isDR of
Just IsData -> GuardPos -- a datatype is guarding
_ -> StrictPos
-
-------------------------------------------------------------------------
--- * Generators and tests
-------------------------------------------------------------------------
-
-instance Arbitrary OccursWhere where
- arbitrary = oneof [return Unknown, Known <$> arbitrary]
-
- shrink Unknown = []
- shrink (Known ws) = Unknown : [ Known ws | ws <- shrink ws ]
-
-instance Arbitrary Where where
- arbitrary = oneof
- [ return LeftOfArrow
- , DefArg <$> arbitrary <*> arbitrary
- , return UnderInf
- , return VarArg
- , return MetaArg
- , ConArgType <$> arbitrary
- , IndArgType <$> arbitrary
- , InClause <$> arbitrary
- , return Matched
- , InDefOf <$> arbitrary
- ]
-
-instance CoArbitrary OccursWhere where
- coarbitrary (Known ws) = variant 0 . coarbitrary ws
- coarbitrary Unknown = variant 1
-
-instance CoArbitrary Where where
- coarbitrary LeftOfArrow = variant 0
- coarbitrary (DefArg a b) = variant 1 . coarbitrary (a, b)
- coarbitrary UnderInf = variant 2
- coarbitrary VarArg = variant 3
- coarbitrary MetaArg = variant 4
- coarbitrary (ConArgType a) = variant 5 . coarbitrary a
- coarbitrary (IndArgType a) = variant 6 . coarbitrary a
- coarbitrary (InClause a) = variant 7 . coarbitrary a
- coarbitrary Matched = variant 8
- coarbitrary (InDefOf a) = variant 9 . coarbitrary a
-
-instance Arbitrary Edge where
- arbitrary = Edge <$> arbitrary <*> arbitrary
-
- shrink (Edge o w) = [ Edge o w | o <- shrink o ] ++
- [ Edge o w | w <- shrink w ]
-
-instance CoArbitrary Edge where
- coarbitrary (Edge o w) = coarbitrary (o, w)
-
--- properties moved to Agda.TypeChecking.Positivity.Tests
diff --git a/src/full/Agda/TypeChecking/Positivity/Occurrence.hs b/src/full/Agda/TypeChecking/Positivity/Occurrence.hs
index 1534c9f..deac357 100644
--- a/src/full/Agda/TypeChecking/Positivity/Occurrence.hs
+++ b/src/full/Agda/TypeChecking/Positivity/Occurrence.hs
@@ -1,14 +1,15 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE TemplateHaskell #-}
+
-- | Occurrences.
module Agda.TypeChecking.Positivity.Occurrence
( Occurrence(..)
+ , OccursWhere(..)
+ , Where(..)
, boundToEverySome
, productOfEdgesInBoundedWalk
- , Agda.TypeChecking.Positivity.Occurrence.tests
) where
import Control.Applicative
@@ -19,8 +20,10 @@ import Data.Maybe
import Data.Typeable (Typeable)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
-import Test.QuickCheck
+import qualified Data.Sequence as DS
+import Agda.Syntax.Common
+import Agda.Syntax.Abstract.Name
import Agda.Syntax.Position
import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph)
import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph
@@ -31,6 +34,33 @@ import Agda.Utils.SemiRing
#include "undefined.h"
import Agda.Utils.Impossible
+-- Specification of occurrences -------------------------------------------
+
+-- Operations and instances in Agda.TypeChecking.Positivity.
+
+-- | Description of an occurrence.
+data OccursWhere
+ = Unknown
+ -- ^ an unknown position (treated as negative)
+ | Known Range (DS.Seq Where)
+ -- ^ The elements of the sequence, from left to right, explain how
+ -- to get to the occurrence.
+ deriving (Show, Eq, Ord)
+
+-- | One part of the description of an occurrence.
+data Where
+ = LeftOfArrow
+ | DefArg QName Nat -- ^ in the nth argument of a define constant
+ | UnderInf -- ^ in the principal argument of built-in ∞
+ | VarArg -- ^ as an argument to a bound variable
+ | MetaArg -- ^ as an argument of a metavariable
+ | ConArgType QName -- ^ in the type of a constructor
+ | IndArgType QName -- ^ in a datatype index of a constructor
+ | InClause Nat -- ^ in the nth clause of a defined function
+ | Matched -- ^ matched against in a clause of a defined function
+ | InDefOf QName -- ^ in the definition of a constant
+ deriving (Show, Eq, Ord)
+
-- | Subterm occurrences for positivity checking.
-- The constructors are listed in increasing information they provide:
-- @Mixed <= JustPos <= StrictPos <= GuardPos <= Unused@
@@ -49,15 +79,6 @@ instance NFData Occurrence where rnf x = seq x ()
instance KillRange Occurrence where
killRange = id
-instance Arbitrary Occurrence where
- arbitrary = elements [minBound .. maxBound]
-
- shrink Unused = []
- shrink _ = [Unused]
-
-instance CoArbitrary Occurrence where
- coarbitrary = coarbitrary . fromEnum
-
-- | 'Occurrence' is a complete lattice with least element 'Mixed'
-- and greatest element 'Unused'.
--
@@ -154,128 +175,3 @@ productOfEdgesInBoundedWalk occ g u v bound =
Just es@(_ : _) -> Just (foldr1 otimes (map Graph.label es))
Just [] -> __IMPOSSIBLE__
Nothing -> Nothing
-
-------------------------------------------------------------------------
--- Tests
-
-prop_Occurrence_oplus_associative ::
- Occurrence -> Occurrence -> Occurrence -> Bool
-prop_Occurrence_oplus_associative x y z =
- oplus x (oplus y z) == oplus (oplus x y) z
-
-prop_Occurrence_oplus_ozero :: Occurrence -> Bool
-prop_Occurrence_oplus_ozero x =
- oplus ozero x == x
-
-prop_Occurrence_oplus_commutative :: Occurrence -> Occurrence -> Bool
-prop_Occurrence_oplus_commutative x y =
- oplus x y == oplus y x
-
-prop_Occurrence_otimes_associative ::
- Occurrence -> Occurrence -> Occurrence -> Bool
-prop_Occurrence_otimes_associative x y z =
- otimes x (otimes y z) == otimes (otimes x y) z
-
-prop_Occurrence_otimes_oone :: Occurrence -> Bool
-prop_Occurrence_otimes_oone x =
- otimes oone x == x
- &&
- otimes x oone == x
-
-prop_Occurrence_distributive ::
- Occurrence -> Occurrence -> Occurrence -> Bool
-prop_Occurrence_distributive x y z =
- otimes x (oplus y z) == oplus (otimes x y) (otimes x z)
- &&
- otimes (oplus x y) z == oplus (otimes x z) (otimes y z)
-
-prop_Occurrence_otimes_ozero :: Occurrence -> Bool
-prop_Occurrence_otimes_ozero x =
- otimes ozero x == ozero
- &&
- otimes x ozero == ozero
-
-prop_Occurrence_ostar :: Occurrence -> Bool
-prop_Occurrence_ostar x =
- ostar x == oplus oone (otimes x (ostar x))
- &&
- ostar x == oplus oone (otimes (ostar x) x)
-
--- | Is the given predicate satisfiable?
-
-satisfiable :: (Occurrence -> Bool) -> Bool
-satisfiable p = or [ p o | o <- [minBound .. maxBound] ]
-
--- Some properties that are used in the implementation of
--- prop_boundToEverySome2.
-
-prop_boundToEverySome0 :: Bool
-prop_boundToEverySome0 = and
- [ length ess >= 1
- &&
- all satisfiable ps
- &&
- and [ p minBound | p <- ps ]
- &&
- all (\p -> satisfiable (not . p)) [ e | (e, _) <- ess ]
- &&
- and [ not (p maxBound) | p <- ps, satisfiable (not . p) ]
- | (_, ess) <- Map.toList boundToEverySome
- , let ps = concat [ [e, s] | (e, s) <- ess ]
- ]
-
--- A simple property that does not always generate enough interesting
--- test cases.
-
-prop_boundToEverySome1 :: NonEmptyList Occurrence -> Property
-prop_boundToEverySome1 (NonEmpty w) =
- forAll (elements $ Map.toList boundToEverySome) $ \(bound, ess) ->
- (foldr1 otimes w <= bound)
- ==
- or [ all every w && any some w | (every, some) <- ess ]
-
--- A more complicated property that does not always generate enough
--- interesting test cases.
-
-prop_boundToEverySome2 :: Property
-prop_boundToEverySome2 =
- forAll (elements $ Map.toList boundToEverySome) $ \(bound, ess) ->
- (forAll (oneof [ do os1 <- listOf (arbitrary `suchThat` every)
- o <- arbitrary
- `suchThat` (\o -> every o && some o)
- os2 <- listOf (arbitrary `suchThat` every)
- return (os1 ++ [o] ++ os2)
- | (every, some) <- ess
- ]) $ \w ->
- foldr1 otimes w <= bound)
- .&&.
- (forAll (do
- ess <- mapM (\(e, s) ->
- elements
- (Left e :
- [ Right s | satisfiable (not . s) ])) ess
- let (es, ss) = partitionEithers ess
- every = \o -> and [ not (s o) | s <- ss ]
- some e = \o -> every o && not (e o)
- everyG = arbitrary `suchThat` every
- segment = listOf everyG
- os <- uniqOn id <$> mapM (\e -> arbitrary `suchThat` some e) es
- if Prelude.null os
- then listOf1 everyG
- else (++) <$> listOf everyG
- <*> (concat <$>
- mapM (\o -> (o :) <$> listOf everyG) os))
- (\w -> not (foldr1 otimes w <= bound)))
-
-------------------------------------------------------------------------
-
--- Template Haskell hack to make the following $quickCheckAll work
--- under GHC 7.8.
-return []
-
--- | Tests.
-
-tests :: IO Bool
-tests = do
- putStrLn "Agda.TypeChecking.Positivity.Occurrence"
- $quickCheckAll
diff --git a/src/full/Agda/TypeChecking/Positivity/Tests.hs b/src/full/Agda/TypeChecking/Positivity/Tests.hs
deleted file mode 100644
index 8efeb9d..0000000
--- a/src/full/Agda/TypeChecking/Positivity/Tests.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Agda.TypeChecking.Positivity.Tests where
-
-import Test.QuickCheck
-
-import Agda.TypeChecking.Positivity
-
-import Agda.Utils.SemiRing
-
--- | The 'oplus' method for 'Occurrence' matches that for 'Edge'.
-
-prop_oplus_Occurrence_Edge :: Edge -> Edge -> Bool
-prop_oplus_Occurrence_Edge e1@(Edge o1 _) e2@(Edge o2 _) =
- case oplus e1 e2 of
- Edge o _ -> o == oplus o1 o2
-
--- Template Haskell hack to make the following $quickCheckAll work
--- under GHC 7.8.
-return []
-
--- | Tests.
-
-tests :: IO Bool
-tests = do
- putStrLn "Agda.TypeChecking.Positivity"
- $quickCheckAll
diff --git a/src/full/Agda/TypeChecking/Pretty.hs b/src/full/Agda/TypeChecking/Pretty.hs
index d3136c0..61aeec1 100644
--- a/src/full/Agda/TypeChecking/Pretty.hs
+++ b/src/full/Agda/TypeChecking/Pretty.hs
@@ -1,9 +1,17 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
+-- To define <>, we will probably need to add:
+--import Prelude hiding ((<>))
+-- but using that now gives warnings and doesn't silence -Wsemigroup
+#if __GLASGOW_HASKELL__ >= 800
+{-# OPTIONS_GHC -Wno-semigroup #-}
+#endif
+#if __GLASGOW_HASKELL__ <= 708
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
+
module Agda.TypeChecking.Pretty where
import Prelude hiding (null)
@@ -11,6 +19,7 @@ import Prelude hiding (null)
import Control.Applicative hiding (empty)
import Control.Monad
+import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
@@ -69,6 +78,9 @@ prettyAs x = AP.prettyAs x
text :: String -> TCM Doc
text s = return $ P.text s
+multiLineText :: String -> TCM Doc
+multiLineText s = return $ P.multiLineText s
+
pwords :: String -> [TCM Doc]
pwords s = map return $ P.pwords s
@@ -82,6 +94,9 @@ hsep ds = P.hsep <$> sequence ds
hcat ds = P.hcat <$> sequence ds
vcat ds = P.vcat <$> sequence ds
+hang :: TCM Doc -> Int -> TCM Doc -> TCM Doc
+hang p n q = P.hang <$> p <*> pure n <*> q
+
($$), ($+$), (<>), (<+>) :: TCM Doc -> TCM Doc -> TCM Doc
d1 $$ d2 = (P.$$) <$> d1 <*> d2
d1 $+$ d2 = (P.$+$) <$> d1 <*> d2
@@ -132,7 +147,11 @@ instance PrettyTCM Range where prettyTCM = pretty
instance PrettyTCM a => PrettyTCM (Closure a) where
prettyTCM cl = enterClosure cl prettyTCM
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM [a] where
+#else
instance PrettyTCM a => PrettyTCM [a] where
+#endif
prettyTCM = prettyList . map prettyTCM
instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (a,b) where
@@ -147,6 +166,7 @@ instance PrettyTCM Type where prettyTCM = prettyA <=< reify
instance PrettyTCM Sort where prettyTCM = prettyA <=< reify
instance PrettyTCM DisplayTerm where prettyTCM = prettyA <=< reify
instance PrettyTCM NamedClause where prettyTCM = prettyA <=< reify
+instance PrettyTCM (QNamed Clause) where prettyTCM = prettyA <=< reify
instance PrettyTCM Level where prettyTCM = prettyA <=< reify . Level
instance PrettyTCM Permutation where prettyTCM = text . show
instance PrettyTCM Polarity where prettyTCM = text . show
@@ -161,22 +181,14 @@ instance (Show a, PrettyTCM a, Subst a a) => PrettyTCM (Substitution' a) where
(rho1, rho2) = splitS 1 rho
u = lookupS rho2 0
+instance PrettyTCM ModuleParameters where
+ prettyTCM = prettyTCM . mpSubstitution
+
instance PrettyTCM Clause where
prettyTCM cl = do
x <- qualify_ <$> freshName_ "<unnamedclause>"
prettyTCM (QNamed x cl)
-instance PrettyTCM ClauseBody where
- prettyTCM b = do
- (binds, body) <- walk b
- sep [ brackets (fsep binds), return body ]
- where
- walk NoBody = return ([], P.text "()")
- walk (Body v) = ([],) <$> prettyTCM v
- walk (Bind b) = do
- (bs, v) <- underAbstraction_ b walk
- return (text (argNameToString $ absName b) : bs, v)
-
instance PrettyTCM a => PrettyTCM (Judgement a) where
prettyTCM (HasType a t) = prettyTCM a <+> text ":" <+> prettyTCM t
prettyTCM (IsSort a t) = text "Sort" <+> prettyTCM a <+> text ":" <+> prettyTCM t
@@ -199,10 +211,21 @@ instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Arg a) where
instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Dom a) where
prettyTCM x = prettyA =<< reify x
+instance (PrettyTCM k, PrettyTCM v) => PrettyTCM (Map k v) where
+ prettyTCM m = text "Map" <> braces (sep $ punctuate comma
+ [ hang (prettyTCM k <+> text "=") 2 (prettyTCM v) | (k, v) <- Map.toList m ])
+
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPING #-} PrettyTCM ArgName where
+#else
+instance PrettyTCM ArgName where
+#endif
+ prettyTCM = text . show
+
-- instance (Reify a e, ToConcrete e c, P.Pretty c, PrettyTCM a) => PrettyTCM (Elim' a) where
instance PrettyTCM Elim where
prettyTCM (Apply v) = text "$" <+> prettyTCM v
- prettyTCM (Proj f) = text "." <> prettyTCM f
+ prettyTCM (Proj _ f)= text "." <> prettyTCM f
instance PrettyTCM a => PrettyTCM (MaybeReduced a) where
prettyTCM = prettyTCM . ignoreReduced
@@ -213,6 +236,9 @@ instance PrettyTCM EqualityView where
instance PrettyTCM A.Expr where
prettyTCM = prettyA
+instance PrettyTCM A.TypedBinding where
+ prettyTCM = prettyA
+
instance PrettyTCM Relevance where
prettyTCM Irrelevant = text "."
prettyTCM NonStrict = text ".."
@@ -221,7 +247,8 @@ instance PrettyTCM Relevance where
prettyTCM UnusedArg = empty
instance PrettyTCM ProblemConstraint where
- prettyTCM (PConstr pid c) = prettyList (map prettyTCM pid) <+> prettyTCM c
+ prettyTCM (PConstr [] c) = prettyTCM c
+ prettyTCM (PConstr pids c) = prettyList (map prettyTCM pids) <+> prettyTCM c
instance PrettyTCM Constraint where
prettyTCM c = case c of
@@ -269,23 +296,26 @@ instance PrettyTCM Constraint where
, nest 2 $ prettyTCM p ]
Open{} -> __IMPOSSIBLE__
OpenIFS{} -> __IMPOSSIBLE__
- InstS{} -> __IMPOSSIBLE__
InstV{} -> __IMPOSSIBLE__
- FindInScope m mb Nothing -> do
- t <- getMetaType m
- sep [ text "Find in scope" <+> pretty m
- <+> maybe (text ":") (\ b -> text "blocked on" <+> pretty b <+> text ":") mb
- , prettyTCM t
- , text " (no candidate for now)"
- ]
- FindInScope m mb (Just cands) -> do
+ FindInScope m mb mcands -> do
t <- getMetaType m
- sep [ text "Find in scope" <+> pretty m
- <+> maybe (text ":") (\ b -> text "blocked on" <+> pretty b <+> text ":") mb
- , nest 2 $ prettyTCM t
- , sep $ flip map cands $ \cand ->
- prettyTCM (candidateTerm cand) <+> text ": " <+> prettyTCM (candidateType cand)
+ sep [ hang (text "Resolve instance argument" <+> blk) 2 $
+ hang (pretty m <+> text ":") 2 $ prettyTCM t
+ , cands
]
+ where
+ blk = case mb of
+ Nothing -> empty
+ Just b -> parens $ text "blocked on" <+> pretty b
+ cands =
+ case mcands of
+ Nothing -> text "No candidates yet"
+ Just cnds ->
+ hang (text "Candidates") 2 $
+ vcat [ hang (overlap c <+> prettyTCM (candidateTerm c) <+> text ":") 2 $
+ prettyTCM (candidateType c) | c <- cnds ]
+ where overlap c | candidateOverlappable c = text "overlap"
+ | otherwise = empty
IsEmpty r t ->
sep [ text "Is empty:", nest 2 $ prettyTCM t ]
CheckSizeLtSat t ->
@@ -340,15 +370,7 @@ instance PrettyTCM Telescope where
newtype PrettyContext = PrettyContext Context
instance PrettyTCM PrettyContext where
- prettyTCM (PrettyContext ctx) = P.fsep . reverse <$> pr (map ctxEntry ctx)
- where
- pr :: [Dom (Name, Type)] -> TCM [P.Doc]
- pr [] = return []
- pr (Dom info (x,t) : ctx) = escapeContext 1 $ do
- -- TODO guilhem: show colors
- d <- CP.prettyRelevance info . CP.prettyHiding info P.parens <$> do
- prettyTCM x <+> text ":" <+> prettyTCM t
- (d :) <$> pr ctx
+ prettyTCM (PrettyContext ctx) = prettyTCM $ telFromList' nameToArgName $ map ctxEntry $ reverse ctx
instance PrettyTCM Context where
prettyTCM = prettyTCM . PrettyContext
@@ -356,72 +378,82 @@ instance PrettyTCM Context where
instance PrettyTCM CtxId where
prettyTCM (CtxId x) = prettyTCM x
-instance PrettyTCM Pattern where
- prettyTCM = showPat' (text . patVarNameToString)
-
-instance PrettyTCM DeBruijnPattern where
- prettyTCM = showPat' $ \ (i, x) -> prettyTCM $ var i
+instance PrettyTCM DBPatVar where
+ prettyTCM = prettyTCM . var . dbPatVarIndex
--- | Show a pattern, given a method how to show pattern variables.
-showPat' :: (a -> TCM Doc) -> Pattern' a -> TCM Doc
-showPat' showVar = showPat
- where
- showPat (VarP x) = showVar x
- showPat (DotP t) = text ".(" <> prettyTCM t <> text ")"
- showPat (ConP c i ps) = (if b then braces else parens) $ prTy $
- prettyTCM c <+> fsep (map (showPat . namedArg) ps)
+instance PrettyTCM a => PrettyTCM (Pattern' a) where
+ prettyTCM (VarP x) = prettyTCM x
+ prettyTCM (DotP t) = text ".(" <> prettyTCM t <> text ")"
+ prettyTCM (ConP c i ps) = (if b then braces else parens) $ prTy $
+ prettyTCM c <+> fsep (map (prettyTCM . namedArg) ps)
where
- b = maybe False (/= ConPCon) $ conPRecord i
+ b = maybe False (/= ConOCon) $ conPRecord i
showRec :: TCM Doc
showRec = sep
[ text "record"
, bracesAndSemicolons <$> zipWithM showField (conFields c) ps
]
showField x p =
- sep [ prettyTCM (A.qnameName x) <+> text "=" , nest 2 $ showPat $ namedArg p ]
- showCon = parens $ prTy $ prettyTCM c <+> fsep (map (showPat . namedArg) ps)
+ sep [ prettyTCM (A.qnameName x) <+> text "=" , nest 2 $ prettyTCM $ namedArg p ]
+ showCon = parens $ prTy $ prettyTCM c <+> fsep (map (prettyTCM . namedArg) ps)
prTy d = d -- caseMaybe (conPType i) d $ \ t -> d <+> text ":" <+> prettyTCM t
- showPat (LitP l) = text (show l)
- showPat (ProjP q) = text (show q)
+ prettyTCM (LitP l) = text (show l)
+ prettyTCM (ProjP _ q) = text ("." ++ show q)
+
+-- | Proper pretty printing of patterns:
+prettyTCMPatternList :: [NamedArg DeBruijnPattern] -> TCM Doc
+prettyTCMPatternList = prettyList . map prettyA <=< reifyPatterns
instance PrettyTCM (Elim' DisplayTerm) where
prettyTCM (Apply v) = text "$" <+> prettyTCM (unArg v)
- prettyTCM (Proj f) = text "." <> prettyTCM f
+ prettyTCM (Proj _ f)= text "." <> prettyTCM f
raisePatVars :: Int -> NLPat -> NLPat
-raisePatVars k (PVar id x) = PVar id (k+x)
+raisePatVars k (PVar id x bvs) = PVar id (k+x) bvs
raisePatVars k (PWild) = PWild
raisePatVars k (PDef f es) = PDef f $ (fmap . fmap) (raisePatVars k) es
raisePatVars k (PLam i u) = PLam i $ fmap (raisePatVars k) u
-raisePatVars k (PPi a b) = PPi ((fmap . fmap) (raisePatVars k) a) ((fmap . fmap) (raisePatVars k) b)
+raisePatVars k (PPi a b) =
+ PPi (fmap (raisePatVarsInType k) a) (fmap (raisePatVarsInType k) b)
raisePatVars k (PBoundVar i es) = PBoundVar i $ (fmap . fmap) (raisePatVars k) es
raisePatVars k (PTerm t) = PTerm t
+raisePatVarsInType :: Int -> NLPType -> NLPType
+raisePatVarsInType k (NLPType l a) =
+ NLPType (raisePatVars k l) (raisePatVars k a)
+
instance PrettyTCM NLPat where
- prettyTCM (PVar id x) = prettyTCM (var x)
+ prettyTCM (PVar id x bvs) = prettyTCM (Var x (map (Apply . fmap var) bvs))
prettyTCM (PWild) = text $ "_"
prettyTCM (PDef f es) = parens $
prettyTCM f <+> fsep (map prettyTCM es)
- prettyTCM (PLam i u) = text ("λ " ++ absName u ++ " →") <+>
- (addContext (absName u) $ prettyTCM (raisePatVars 1 $ absBody u))
- prettyTCM (PPi a b) = text "Π" <+> prettyTCM (unDom a) <+>
- (addContext (absName b) $ prettyTCM (fmap (raisePatVars 1) $ unAbs b))
+ prettyTCM (PLam i u) = parens $
+ text ("λ " ++ absName u ++ " →") <+>
+ (addContext (absName u) $ prettyTCM (raisePatVars 1 $ absBody u))
+ prettyTCM (PPi a b) = parens $
+ text ("(" ++ absName b ++ " :") <+> prettyTCM (unDom a) <> text ") →" <+>
+ (addContext (absName b) $ prettyTCM (raisePatVarsInType 1 $ unAbs b))
+ prettyTCM (PBoundVar i []) = prettyTCM (var i)
prettyTCM (PBoundVar i es) = parens $ prettyTCM (var i) <+> fsep (map prettyTCM es)
prettyTCM (PTerm t) = text "." <> parens (prettyTCM t)
+instance PrettyTCM NLPType where
+ prettyTCM (NLPType PWild a) = prettyTCM a
+ prettyTCM (NLPType l a) = text "{" <> prettyTCM l <> text "}" <> prettyTCM a
+
instance PrettyTCM (Elim' NLPat) where
- prettyTCM (Apply v) = text "$" <+> prettyTCM (unArg v)
- prettyTCM (Proj f) = text "." <> prettyTCM f
+ prettyTCM (Apply v) = prettyTCM (unArg v)
+ prettyTCM (Proj _ f)= text "." <> prettyTCM f
instance PrettyTCM (Type' NLPat) where
prettyTCM = prettyTCM . unEl
instance PrettyTCM RewriteRule where
- prettyTCM (RewriteRule q gamma lhs rhs b) = sep
- [ prettyTCM q <+> text " rule "
+ prettyTCM (RewriteRule q gamma f ps rhs b) = fsep
+ [ prettyTCM q
, prettyTCM gamma <+> text " |- "
- , addContext gamma $ hsep
- [ prettyTCM lhs
+ , addContext gamma $ sep
+ [ prettyTCM (PDef f ps)
, text " --> "
, prettyTCM rhs
, text " : "
diff --git a/src/full/Agda/TypeChecking/Pretty.hs-boot b/src/full/Agda/TypeChecking/Pretty.hs-boot
index 1176cbb..2b39b0d 100644
--- a/src/full/Agda/TypeChecking/Pretty.hs-boot
+++ b/src/full/Agda/TypeChecking/Pretty.hs-boot
@@ -27,3 +27,4 @@ instance PrettyTCM Elim
instance PrettyTCM Type
instance PrettyTCM Sort
instance PrettyTCM DisplayTerm
+instance PrettyTCM DBPatVar
diff --git a/src/full/Agda/TypeChecking/Primitive.hs b/src/full/Agda/TypeChecking/Primitive.hs
index 850f947..5bc4a6b 100644
--- a/src/full/Agda/TypeChecking/Primitive.hs
+++ b/src/full/Agda/TypeChecking/Primitive.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -19,6 +18,8 @@ import Data.Maybe
import Data.Traversable (traverse)
import Data.Monoid (mempty)
+import Numeric.IEEE ( IEEE(identicalIEEE) )
+
import Agda.Interaction.Options
import Agda.Syntax.Position
@@ -27,6 +28,7 @@ import Agda.Syntax.Internal
import Agda.Syntax.Internal.Generic (TermLike(..))
import Agda.Syntax.Literal
import Agda.Syntax.Concrete.Pretty ()
+import Agda.Syntax.Fixity
import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst)
import qualified Agda.TypeChecking.Monad as TCM
@@ -38,7 +40,6 @@ import Agda.TypeChecking.Errors
import Agda.TypeChecking.Level
import Agda.TypeChecking.Quote (QuotingKit, quoteTermWithKit, quoteTypeWithKit, quoteClauseWithKit, quotingKit)
import Agda.TypeChecking.Pretty () -- instances only
-import Agda.TypeChecking.MetaVars (allMetas)
import Agda.Utils.Monad
import Agda.Utils.Pretty (pretty)
@@ -102,6 +103,8 @@ instance PrimTerm QName where primTerm _ = primQName
instance PrimTerm MetaId where primTerm _ = primAgdaMeta
instance PrimTerm Type where primTerm _ = primAgdaTerm
+instance PrimTerm Fixity' where primTerm _ = primFixity
+
instance PrimTerm a => PrimTerm [a] where
primTerm _ = list (primTerm (undefined :: a))
@@ -159,12 +162,12 @@ instance ToTerm ArgInfo where
ins <- primInstance
rel <- primRelevant
irr <- primIrrelevant
- return $ \ (ArgInfo h r) -> info `applys`
- [ case h of
+ return $ \ i -> info `applys`
+ [ case getHiding i of
NotHidden -> vis
Hidden -> hid
Instance -> ins
- , case r of
+ , case getRelevance i of
Relevant -> rel
Irrelevant -> irr
NonStrict -> rel
@@ -172,6 +175,38 @@ instance ToTerm ArgInfo where
UnusedArg -> irr
]
+instance ToTerm Fixity' where
+ toTerm = (. theFixity) <$> toTerm
+
+instance ToTerm Fixity where
+ toTerm = do
+ lToTm <- toTerm
+ aToTm <- toTerm
+ fixity <- primFixityFixity
+ return $ \ Fixity{fixityAssoc = a, fixityLevel = l} ->
+ fixity `apply` [defaultArg (aToTm a), defaultArg (lToTm l)]
+
+instance ToTerm Associativity where
+ toTerm = do
+ lassoc <- primAssocLeft
+ rassoc <- primAssocRight
+ nassoc <- primAssocNon
+ return $ \ a ->
+ case a of
+ NonAssoc -> nassoc
+ LeftAssoc -> lassoc
+ RightAssoc -> rassoc
+
+instance ToTerm PrecedenceLevel where
+ toTerm = do
+ (iToTm :: Integer -> Term) <- toTerm
+ related <- primPrecRelated
+ unrelated <- primPrecUnrelated
+ return $ \ p ->
+ case p of
+ Unrelated -> unrelated
+ Related n -> related `apply` [defaultArg $ iToTm n]
+
-- | @buildList A ts@ builds a list of type @List A@. Assumes that the terms
-- @ts@ all have type @A@.
buildList :: TCM ([Term] -> Term)
@@ -198,22 +233,22 @@ class FromTerm a where
instance FromTerm Integer where
fromTerm = do
- Con pos [] <- ignoreSharing <$> primIntegerPos
- Con negsuc [] <- ignoreSharing <$> primIntegerNegSuc
+ Con pos _ [] <- ignoreSharing <$> primIntegerPos
+ Con negsuc _ [] <- ignoreSharing <$> primIntegerNegSuc
toNat <- fromTerm :: TCM (FromTermFunction Nat)
return $ \ v -> do
b <- reduceB' v
let v' = ignoreBlocking b
arg = (<$ v')
case ignoreSharing $ unArg (ignoreBlocking b) of
- Con c [u]
+ Con c ci [u]
| c == pos ->
redBind (toNat u)
- (\ u' -> notReduced $ arg $ Con c [ignoreReduced u']) $ \ n ->
+ (\ u' -> notReduced $ arg $ Con c ci [ignoreReduced u']) $ \ n ->
redReturn $ fromIntegral n
| c == negsuc ->
redBind (toNat u)
- (\ u' -> notReduced $ arg $ Con c [ignoreReduced u']) $ \ n ->
+ (\ u' -> notReduced $ arg $ Con c ci [ignoreReduced u']) $ \ n ->
redReturn $ fromIntegral $ -n - 1
_ -> return $ NoReduction (reduced b)
@@ -263,7 +298,7 @@ instance FromTerm Bool where
where
a =?= b = ignoreSharing a === ignoreSharing b
Def x [] === Def y [] = x == y
- Con x [] === Con y [] = x == y
+ Con x _ [] === Con y _ [] = x == y
Var n [] === Var m [] = n == m
_ === _ = False
@@ -278,7 +313,7 @@ instance (ToTerm a, FromTerm a) => FromTerm [a] where
return $ mkList nil cons toA fromA
where
isCon (Lam _ b) = isCon $ absBody b
- isCon (Con c _) = return c
+ isCon (Con c _ _)= return c
isCon (Shared p) = isCon (derefPtr p)
isCon v = __IMPOSSIBLE__
@@ -287,15 +322,15 @@ instance (ToTerm a, FromTerm a) => FromTerm [a] where
let t = ignoreBlocking b
let arg = (<$ t)
case ignoreSharing $ unArg t of
- Con c []
+ Con c ci []
| c == nil -> return $ YesReduction NoSimplification []
- Con c [x,xs]
+ Con c ci [x,xs]
| c == cons ->
redBind (toA x)
- (\x' -> notReduced $ arg $ Con c [ignoreReduced x',xs]) $ \y ->
+ (\x' -> notReduced $ arg $ Con c ci [ignoreReduced x',xs]) $ \y ->
redBind
(mkList nil cons toA fromA xs)
- (fmap $ \xs' -> arg $ Con c [defaultArg $ fromA y, xs']) $ \ys ->
+ (fmap $ \xs' -> arg $ Con c ci [defaultArg $ fromA y, xs']) $ \ys ->
redReturn (y : ys)
_ -> return $ NoReduction (reduced b)
@@ -334,11 +369,11 @@ primTrustMe = do
hPi "y" (El (varSort 2) <$> varM 1) $
El (varSort 3) <$>
primEquality <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0
- Con rf [] <- ignoreSharing <$> primRefl
+ Con rf ci [] <- ignoreSharing <$> primRefl
n <- conPars . theDef <$> getConInfo rf
-- Andreas, 2015-02-27 Forced Big vs. Forced Small should not matter here
- let refl x | n == 2 = Con rf [setRelevance (Forced Small) $ hide $ defaultArg x]
- | n == 3 = Con rf []
+ let refl x | n == 2 = Con rf ci [setRelevance (Forced Small) $ hide $ defaultArg x]
+ | n == 3 = Con rf ci []
| otherwise = __IMPOSSIBLE__
return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ts ->
case ts of
@@ -670,21 +705,32 @@ primitiveFunctions = Map.fromList
, "primLevelMax" |-> mkPrimLevelMax
-- Floating point functions
- , "primNatToFloat" |-> mkPrimFun1 (fromIntegral :: Nat -> Double)
- , "primFloatPlus" |-> mkPrimFun2 ((+) :: Op Double)
- , "primFloatMinus" |-> mkPrimFun2 ((-) :: Op Double)
- , "primFloatTimes" |-> mkPrimFun2 ((*) :: Op Double)
- , "primFloatDiv" |-> mkPrimFun2 ((/) :: Op Double)
- , "primFloatEquality" |-> mkPrimFun2 (floatEq :: Rel Double)
- , "primFloatLess" |-> mkPrimFun2 (floatLt :: Rel Double)
- , "primFloatSqrt" |-> mkPrimFun1 (sqrt :: Double -> Double)
- , "primRound" |-> mkPrimFun1 (round :: Double -> Integer)
- , "primFloor" |-> mkPrimFun1 (floor :: Double -> Integer)
- , "primCeiling" |-> mkPrimFun1 (ceiling :: Double -> Integer)
- , "primExp" |-> mkPrimFun1 (exp :: Fun Double)
- , "primLog" |-> mkPrimFun1 (log :: Fun Double)
- , "primSin" |-> mkPrimFun1 (sin :: Fun Double)
- , "primShowFloat" |-> mkPrimFun1 (Str . floatShow :: Double -> Str)
+ , "primNatToFloat" |-> mkPrimFun1 (fromIntegral :: Nat -> Double)
+ , "primFloatPlus" |-> mkPrimFun2 ((+) :: Op Double)
+ , "primFloatMinus" |-> mkPrimFun2 ((-) :: Op Double)
+ , "primFloatTimes" |-> mkPrimFun2 ((*) :: Op Double)
+ , "primFloatNegate" |-> mkPrimFun1 (negate :: Fun Double)
+ , "primFloatDiv" |-> mkPrimFun2 ((/) :: Op Double)
+ -- ASR (2016-09-29). We use bitwise equality for comparing Double
+ -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove
+ -- a contradiction (see Issue #2169).
+ , "primFloatEquality" |-> mkPrimFun2 (floatEq :: Rel Double)
+ , "primFloatNumericalEquality" |-> mkPrimFun2 ((==) :: Rel Double)
+ , "primFloatNumericalLess" |-> mkPrimFun2 (floatLt :: Rel Double)
+ , "primFloatSqrt" |-> mkPrimFun1 (sqrt :: Double -> Double)
+ , "primRound" |-> mkPrimFun1 (round :: Double -> Integer)
+ , "primFloor" |-> mkPrimFun1 (floor :: Double -> Integer)
+ , "primCeiling" |-> mkPrimFun1 (ceiling :: Double -> Integer)
+ , "primExp" |-> mkPrimFun1 (exp :: Fun Double)
+ , "primLog" |-> mkPrimFun1 (log :: Fun Double)
+ , "primSin" |-> mkPrimFun1 (sin :: Fun Double)
+ , "primCos" |-> mkPrimFun1 (cos :: Fun Double)
+ , "primTan" |-> mkPrimFun1 (tan :: Fun Double)
+ , "primASin" |-> mkPrimFun1 (asin :: Fun Double)
+ , "primACos" |-> mkPrimFun1 (acos :: Fun Double)
+ , "primATan" |-> mkPrimFun1 (atan :: Fun Double)
+ , "primATan2" |-> mkPrimFun2 (atan2 :: Double -> Double -> Double)
+ , "primShowFloat" |-> mkPrimFun1 (Str . show :: Double -> Str)
-- Character functions
, "primCharEquality" |-> mkPrimFun2 ((==) :: Rel Char)
@@ -717,6 +763,7 @@ primitiveFunctions = Map.fromList
, "primQNameEquality" |-> mkPrimFun2 ((==) :: Rel QName)
, "primQNameLess" |-> mkPrimFun2 ((<) :: Rel QName)
, "primShowQName" |-> mkPrimFun1 (Str . show :: QName -> Str)
+ , "primQNameFixity" |-> mkPrimFun1 (nameFixity . qnameName)
, "primMetaEquality" |-> mkPrimFun2 ((==) :: Rel MetaId)
, "primMetaLess" |-> mkPrimFun2 ((<) :: Rel MetaId)
, "primShowMeta" |-> mkPrimFun1 (Str . show . pretty :: MetaId -> Str)
@@ -725,22 +772,26 @@ primitiveFunctions = Map.fromList
(|->) = (,)
floatEq :: Double -> Double -> Bool
-floatEq x y | isNaN x && isNaN y = True
- | otherwise = x == y
+floatEq x y = identicalIEEE x y || (isNaN x && isNaN y)
floatLt :: Double -> Double -> Bool
-floatLt x y
- | isNegInf y = False
- | isNegInf x = True
- | isNaN x = True
- | otherwise = x < y
+floatLt x y =
+ case compareFloat x y of
+ LT -> True
+ _ -> False
where
+ -- Also implemented in the GHC/UHC backends
+ compareFloat :: Double -> Double -> Ordering
+ compareFloat x y
+ | identicalIEEE x y = EQ
+ | isNegInf x = LT
+ | isNegInf y = GT
+ | isNaN x && isNaN y = EQ
+ | isNaN x = LT
+ | isNaN y = GT
+ | otherwise = compare x y
isNegInf z = z < 0 && isInfinite z
-floatShow :: Double -> String
-floatShow x | isNegativeZero x = "0.0"
- | otherwise = show x
-
lookupPrimitiveFunction :: String -> TCM PrimitiveImpl
lookupPrimitiveFunction x =
fromMaybe (typeError $ NoSuchPrimitiveFunction x)
@@ -758,7 +809,7 @@ getBuiltinName b = do
caseMaybeM (getBuiltin' b) (return Nothing) $ \v -> do
v <- normalise v
let getName (Def x _) = x
- getName (Con x _) = conName x
+ getName (Con x _ _) = conName x
getName (Lam _ b) = getName $ ignoreSharing $ unAbs b
getName _ = __IMPOSSIBLE__
return $ Just $ getName (ignoreSharing v)
diff --git a/src/full/Agda/TypeChecking/ProjectionLike.hs b/src/full/Agda/TypeChecking/ProjectionLike.hs
index 19d8560..4ad75c0 100644
--- a/src/full/Agda/TypeChecking/ProjectionLike.hs
+++ b/src/full/Agda/TypeChecking/ProjectionLike.hs
@@ -1,16 +1,11 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
module Agda.TypeChecking.ProjectionLike where
import Control.Monad
import qualified Data.Map as Map
+import Data.Monoid (Any(..), getAny)
import Agda.Syntax.Abstract.Name
import Agda.Syntax.Common
@@ -18,7 +13,7 @@ import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import Agda.TypeChecking.Monad
-import Agda.TypeChecking.Free (isBinderUsed)
+import Agda.TypeChecking.Free (runFree, IgnoreSorts(..))
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Positivity
import Agda.TypeChecking.Pretty
@@ -111,9 +106,9 @@ elimView loneProjToLambda v = do
case pv of
NoProjection{} -> return v
LoneProjectionLike f ai
- | loneProjToLambda -> return $ Lam ai $ Abs "r" $ Var 0 [Proj f]
+ | loneProjToLambda -> return $ Lam ai $ Abs "r" $ Var 0 [Proj ProjPrefix f]
| otherwise -> return v
- ProjectionView f a es -> (`applyE` (Proj f : es)) <$> elimView loneProjToLambda (unArg a)
+ ProjectionView f a es -> (`applyE` (Proj ProjPrefix f : es)) <$> elimView loneProjToLambda (unArg a)
-- | Which @Def@types are eligible for the principle argument
-- of a projection-like function?
@@ -124,11 +119,18 @@ eligibleForProjectionLike d = do
Datatype{} -> True
Record{} -> True
Axiom{} -> True
- _ -> False
+ Function{} -> False
+ Primitive{} -> False
+ Constructor{} -> __IMPOSSIBLE__
+ AbstractDefn -> False
+ -- Andreas, 2016-10-11 AIM XXIV
+ -- Projection-like at abstract types violates the parameter reconstructibility property.
+ -- See test/Fail/AbstractTypeProjectionLike.
-- | Turn a definition into a projection if it looks like a projection.
makeProjection :: QName -> TCM ()
-makeProjection x = inTopContext $ do
+makeProjection x = -- if True then return () else do
+ inTopContext $ do
-- reportSLn "tc.proj.like" 30 $ "Considering " ++ show x ++ " for projection likeness"
defn <- getConstInfo x
let t = defType defn
@@ -138,7 +140,7 @@ makeProjection x = inTopContext $ do
]
case theDef defn of
Function{funClauses = cls}
- | any (isNothing . getBodyUnraised) cls ->
+ | any (isNothing . clauseBody) cls ->
reportSLn "tc.proj.like" 30 $ " projection-like functions cannot have absurd clauses"
-- Constructor-headed functions can't be projection-like (at the moment). The reason
-- for this is that invoking constructor-headedness will circumvent the inference of
@@ -177,17 +179,15 @@ makeProjection x = inTopContext $ do
reportSLn "tc.proj.like" 60 $ " rewrote clauses to\n " ++ show cc
-- Andreas, 2013-10-20 build parameter dropping function
- let (ptel, Dom ai _ : _) = splitAt n $ telToList $ theTel $ telView' t
- -- leading lambdas are to ignore parameter applications
- proj = teleNoAbs ptel $ Def x []
- -- proj = foldr (\ (Dom ai (y, _)) -> Lam ai . NoAbs y) (Def x []) ptel
-
+ let pIndex = n + 1
+ tel = take pIndex $ telToList $ theTel $ telView' t
+ unless (length tel == pIndex) __IMPOSSIBLE__
let projection = Projection
- { projProper = Nothing
+ { projProper = False
+ , projOrig = x
, projFromType = d
- , projIndex = n + 1
- , projDropPars = proj
- , projArgInfo = ai
+ , projIndex = pIndex
+ , projLams = ProjLams $ map (\ (Dom ai (y, _)) -> Arg ai y) tel
}
let newDef = def
{ funProjection = Just projection
@@ -210,9 +210,9 @@ makeProjection x = inTopContext $ do
where
-- @validProj (d,n)@ checks whether the head @d@ of the type of the
-- @n@th argument is injective in all args (i.d. being name of data/record/axiom).
- validProj :: (QName, Int) -> TCM Bool
+ validProj :: (Arg QName, Int) -> TCM Bool
validProj (_, 0) = return False
- validProj (d, _) = eligibleForProjectionLike d
+ validProj (d, _) = eligibleForProjectionLike (unArg d)
-- NOTE: If the following definition turns out to be slow, then
-- one could perhaps reuse information computed by the termination
@@ -231,11 +231,12 @@ makeProjection x = inTopContext $ do
, onlyMatch n ps -- projection-like functions are only allowed to match on the eliminatee
-- otherwise we may end up projecting from constructor applications, in
-- which case we can't reconstruct the dropped parameters
- , checkBody n b ]
+ , checkBody m n b ]
where
- Perm _ p = clausePerm cl
+ Perm _ p = fromMaybe __IMPOSSIBLE__ $ clausePerm cl
ps = namedClausePats cl
- b = clauseBody cl
+ b = compiledClauseBody cl
+ m = size $ concatMap patternVars $ clausePats cl
onlyMatch n ps = all (shallowMatch . namedArg) (take 1 ps1) &&
@@ -251,10 +252,8 @@ makeProjection x = inTopContext $ do
noMatch VarP{} = True
noMatch DotP{} = True
- checkBody 0 _ = True
- checkBody _ NoBody = __IMPOSSIBLE__ -- we check this earlier
- checkBody n (Bind b) = not (isBinderUsed b) && checkBody (n - 1) (unAbs b)
- checkBody _ Body{} = __IMPOSSIBLE__
+ checkBody m n b = not . getAny $ runFree badVar IgnoreNot b
+ where badVar (x,_) = Any $ m-1-n < x && x < m
-- @candidateArgs [var 0,...,var(n-1)] t@ adds @(n,d)@ to the output,
-- if @t@ is a function-type with domain @t 0 .. (n-1)@
@@ -267,13 +266,13 @@ makeProjection x = inTopContext $ do
-- E.g. f : {x : _}(y : _){z : _} -> D x y z -> ...
-- will return (D,3) as a candidate (amongst maybe others).
--
- candidateArgs :: [Term] -> Type -> [(QName,Int)]
+ candidateArgs :: [Term] -> Type -> [(Arg QName, Int)]
candidateArgs vs t =
case ignoreSharing $ unEl t of
Pi a b
| Def d es <- ignoreSharing $ unEl $ unDom a,
Just us <- allApplyElims es,
- vs == map unArg us -> (d, length vs) : candidateRec b
+ vs == map unArg us -> (d <$ argFromDom a, length vs) : candidateRec b
| otherwise -> candidateRec b
_ -> []
where
diff --git a/src/full/Agda/TypeChecking/Quote.hs b/src/full/Agda/TypeChecking/Quote.hs
index 9672082..197127b 100644
--- a/src/full/Agda/TypeChecking/Quote.hs
+++ b/src/full/Agda/TypeChecking/Quote.hs
@@ -1,7 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RankNTypes #-}
module Agda.TypeChecking.Quote where
@@ -17,6 +14,7 @@ import Data.Traversable (traverse)
import Agda.Syntax.Common
import Agda.Syntax.Internal as I
+import Agda.Syntax.Internal.Pattern ( dbPatPerm' )
import Agda.Syntax.Literal
import Agda.Syntax.Position
import Agda.Syntax.Translation.InternalToAbstract
@@ -38,7 +36,7 @@ import Agda.TypeChecking.Telescope
import Agda.Utils.Except
import Agda.Utils.Impossible
import Agda.Utils.Monad ( ifM )
-import Agda.Utils.Permutation ( Permutation(Perm), compactP )
+import Agda.Utils.Permutation ( Permutation(Perm), compactP, reverseP )
import Agda.Utils.String ( Str(Str), unStr )
import Agda.Utils.VarSet (VarSet)
import qualified Agda.Utils.VarSet as Set
@@ -97,8 +95,8 @@ quotingKit = do
sucLevel <- primLevelSuc
lub <- primLevelMax
lkit <- requireLevels
- Con z _ <- ignoreSharing <$> primZero
- Con s _ <- ignoreSharing <$> primSuc
+ Con z _ _ <- ignoreSharing <$> primZero
+ Con s _ _ <- ignoreSharing <$> primSuc
unsupported <- primAgdaTermUnsupported
agdaDefinitionFunDef <- primAgdaDefinitionFunDef
@@ -130,16 +128,15 @@ quotingKit = do
quoteRelevance UnusedArg = pure relevant
quoteArgInfo :: ArgInfo -> ReduceM Term
- quoteArgInfo (ArgInfo h r) = arginfo !@ quoteHiding h
- @@ quoteRelevance r
+ quoteArgInfo (ArgInfo h r _ _) = arginfo !@ quoteHiding h @@ quoteRelevance r
quoteLit :: Literal -> ReduceM Term
- quoteLit l@LitNat{} = lit !@ (litNat !@! Lit l)
- quoteLit l@LitFloat{} = lit !@ (litFloat !@! Lit l)
- quoteLit l@LitChar{} = lit !@ (litChar !@! Lit l)
- quoteLit l@LitString{} = lit !@ (litString !@! Lit l)
- quoteLit l@LitQName{} = lit !@ (litQName !@! Lit l)
- quoteLit l@LitMeta {} = lit !@ (litMeta !@! Lit l)
+ quoteLit l@LitNat{} = litNat !@! Lit l
+ quoteLit l@LitFloat{} = litFloat !@! Lit l
+ quoteLit l@LitChar{} = litChar !@! Lit l
+ quoteLit l@LitString{} = litString !@! Lit l
+ quoteLit l@LitQName{} = litQName !@! Lit l
+ quoteLit l@LitMeta {} = litMeta !@! Lit l
-- We keep no ranges in the quoted term, so the equality on terms
-- is only on the structure.
@@ -165,23 +162,21 @@ quotingKit = do
quotePats ps = list $ map (quoteArg quotePat . fmap namedThing) ps
quotePat :: DeBruijnPattern -> ReduceM Term
- quotePat (VarP (_,"()")) = pure absurdP
- quotePat (VarP (_,x)) = varP !@! quoteString x
+ quotePat (VarP x) | isAbsurdPatternName (dbPatVarName x) = pure absurdP
+ quotePat (VarP x) = varP !@! quoteString (dbPatVarName x)
quotePat (DotP _) = pure dotP
quotePat (ConP c _ ps) = conP !@ quoteQName (conName c) @@ quotePats ps
- quotePat (LitP l) = litP !@! Lit l
- quotePat (ProjP x) = projP !@ quoteQName x
-
- quoteBody :: I.ClauseBody -> Maybe (ReduceM Term)
- quoteBody (Body a) = Just (quoteTerm a)
- quoteBody (Bind b) = quoteBody (absBody b)
- quoteBody NoBody = Nothing
+ quotePat (LitP l) = litP !@ quoteLit l
+ quotePat (ProjP _ x) = projP !@ quoteQName x
quoteClause :: Clause -> ReduceM Term
- quoteClause Clause{namedClausePats = ps, clauseBody = body} =
- case quoteBody body of
+ quoteClause cl@Clause{namedClausePats = ps, clauseBody = body} =
+ case body of
Nothing -> absurdClause !@ quotePats ps
- Just b -> normalClause !@ quotePats ps @@ b
+ Just b ->
+ let perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm' False ps -- Dot patterns don't count (#2203)
+ v = applySubst (renamingR perm) b
+ in normalClause !@ quotePats ps @@ quoteTerm v
list :: [ReduceM Term] -> ReduceM Term
list [] = pure nil
@@ -211,32 +206,44 @@ quotingKit = do
in var !@! Lit (LitNat noRange $ fromIntegral n) @@ quoteArgs ts
Lam info t -> lam !@ quoteHiding (getHiding info) @@ quoteAbs quoteTerm t
Def x es -> do
- d <- theDef <$> getConstInfo x
+ def <- getConstInfo x
+ let d = theDef def
n <- getDefFreeVars x
- qx d @@ quoteArgs (drop n ts)
+ -- #2220: remember to restore dropped parameters
+ qx d @@ list (drop n $ defParameters def ++ map (quoteArg quoteTerm) ts)
where
ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
qx Function{ funExtLam = Just (ExtLamInfo h nh), funClauses = cs } =
extlam !@ list (map (quoteClause . dropArgs (h + nh)) cs)
qx Function{ funCompiled = Just Fail, funClauses = [cl] } =
- extlam !@ list [quoteClause $ dropArgs (length (clausePats cl) - 1) cl]
+ extlam !@ list [quoteClause $ dropArgs (length (namedClausePats cl) - 1) cl]
qx _ = def !@! quoteName x
- Con x ts -> do
- Constructor{conPars = np} <- theDef <$> getConstInfo (conName x)
- let par = arg !@ (arginfo !@ pure hidden @@ pure relevant) @@ pure unsupported
- pars = replicate np $ par
- args = list $ pars ++ map (quoteArg quoteTerm) ts
+ Con x ci ts -> do
+ cDef <- getConstInfo (conName x)
+ n <- getDefFreeVars (conName x)
+ let args = list $ drop n $ defParameters cDef ++ map (quoteArg quoteTerm) ts
con !@! quoteConName x @@ args
Pi t u -> pi !@ quoteDom quoteType t
@@ quoteAbs quoteType u
Level l -> quoteTerm (unlevelWithKit lkit l)
- Lit lit -> quoteLit lit
+ Lit l -> lit !@ quoteLit l
Sort s -> sort !@ quoteSort s
Shared p -> quoteTerm $ derefPtr p
MetaV x es -> meta !@! quoteMeta currentFile x @@ quoteArgs vs
where vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
DontCare{} -> pure unsupported -- could be exposed at some point but we have to take care
+ defParameters :: Definition -> [ReduceM Term]
+ defParameters def = map par hiding
+ where
+ np = case theDef def of
+ Constructor{ conPars = np } -> np
+ Function{ funProjection = Just p } -> projIndex p - 1
+ _ -> 0
+ TelV tel _ = telView' (defType def)
+ hiding = map getHiding $ take np $ telToList tel
+ par h = arg !@ (arginfo !@ quoteHiding h @@ pure relevant) @@ pure unsupported
+
quoteDefn :: Definition -> ReduceM Term
quoteDefn def =
case theDef def of
@@ -247,6 +254,7 @@ quotingKit = do
Record{recConHead = c} ->
agdaDefinitionRecordDef !@! quoteName (conName c)
Axiom{} -> pure agdaDefinitionPostulate
+ AbstractDefn{}-> pure agdaDefinitionPostulate
Primitive{primClauses = cs} | not $ null cs ->
agdaDefinitionFunDef !@ quoteList quoteClause cs
Primitive{} -> pure agdaDefinitionPrimitive
@@ -296,4 +304,3 @@ quoteList :: [Term] -> TCM Term
quoteList xs = do
kit <- quotingKit
runReduceM (quoteListWithKit kit pure xs)
-
diff --git a/src/full/Agda/TypeChecking/ReconstructParameters.hs b/src/full/Agda/TypeChecking/ReconstructParameters.hs
index b929c48..8c96939 100644
--- a/src/full/Agda/TypeChecking/ReconstructParameters.hs
+++ b/src/full/Agda/TypeChecking/ReconstructParameters.hs
@@ -54,7 +54,7 @@ reconstructParameters a v = do
where
reconstruct a v = do
case ignoreSharing v of
- Con h vs -> do
+ Con h ci vs -> do
TelV tel a <- telView a
let under = size tel -- under-applied when under > 0
reportSDoc "tc.with.reconstruct" 50 $
@@ -67,7 +67,7 @@ reconstructParameters a v = do
let Just ps = applySubst (strengthenS __IMPOSSIBLE__ under) . take n <$> allApplyElims es
reportSLn "tc.with.reconstruct" 50 $ show n ++ " parameters"
-- TODO: the reconstructed parameters are not reconstructed recursively!
- return $ Con h (ps ++ vs)
+ return $ Con h ci (ps ++ vs)
_ -> __IMPOSSIBLE__
_ -> return v
@@ -76,8 +76,8 @@ dropParameters = traverseTermM dropPars
where
dropPars v =
case ignoreSharing v of
- Con c vs -> do
+ Con c ci vs -> do
Constructor{ conData = d } <- theDef <$> getConstInfo (conName c)
Just n <- defParameters <$> getConstInfo d
- return $ Con c $ drop n vs
+ return $ Con c ci $ drop n vs
_ -> return v
diff --git a/src/full/Agda/TypeChecking/RecordPatterns.hs b/src/full/Agda/TypeChecking/RecordPatterns.hs
index 70795e3..4a876da 100644
--- a/src/full/Agda/TypeChecking/RecordPatterns.hs
+++ b/src/full/Agda/TypeChecking/RecordPatterns.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-- | Code which replaces pattern matching on record constructors with
-- uses of projection functions.
@@ -61,7 +58,7 @@ import Agda.Utils.Impossible
-- E.g. for @(x , (y , z))@ we return @[ fst, fst . snd, snd . snd ]@.
--
-- If it is not a record pattern, error 'ShouldBeRecordPattern' is raised.
-recordPatternToProjections :: Pattern -> TCM [Term -> Term]
+recordPatternToProjections :: DeBruijnPattern -> TCM [Term -> Term]
recordPatternToProjections p =
case p of
VarP{} -> return [ \ x -> x ]
@@ -75,8 +72,8 @@ recordPatternToProjections p =
concat <$> zipWithM comb (map proj fields) (map namedArg ps)
ProjP{} -> __IMPOSSIBLE__ -- copattern cannot appear here
where
- proj p = (`applyE` [Proj $ unArg p])
- comb :: (Term -> Term) -> Pattern -> TCM [Term -> Term]
+ proj p = (`applyE` [Proj ProjSystem $ unArg p])
+ comb :: (Term -> Term) -> DeBruijnPattern -> TCM [Term -> Term]
comb prj p = map (\ f -> f . prj) <$> recordPatternToProjections p
@@ -249,7 +246,7 @@ replaceByProjections (Arg ai i) projs cc =
| otherwise = map unArg xs1
x = Arg ai $ foldr1 appendArgNames names
xs' = xs0 ++ x : xs2
- us = map (\ p -> Var 0 [Proj p]) (reverse projs)
+ us = map (\ p -> Var 0 [Proj ProjSystem p]) (reverse projs)
-- go from level (i + n - 1) to index (subtract from |xs|-1)
index = length xs - (i + n)
in Done xs' $ applySubst (liftS (length xs2) $ us ++# raiseS 1) v
@@ -455,7 +452,8 @@ translateRecordPatterns clause = do
-- Substitution used to convert terms in the old telescope's
-- context to terms in the new RHS's context.
- rhsSubst' = mkSub $ permute (reverseP $ clausePerm clause) s'
+ perm = fromMaybe __IMPOSSIBLE__ $ clausePerm clause
+ rhsSubst' = mkSub $ permute (reverseP perm) s'
-- TODO: Is it OK to replace the definition above with the
-- following one?
--
@@ -465,7 +463,7 @@ translateRecordPatterns clause = do
-- order (i.e. the type signature for the variable which occurs
-- first in the list of patterns comes first).
flattenedOldTel =
- permute (invertP __IMPOSSIBLE__ $ compactP $ clausePerm clause) $
+ permute (invertP __IMPOSSIBLE__ $ compactP perm) $
zip (teleNames $ clauseTel clause) $
flattenTel $
clauseTel clause
@@ -495,7 +493,7 @@ translateRecordPatterns clause = do
-- Substitution used to convert terms in the new RHS's context
-- to terms in the new telescope's context.
- lhsSubst' = renaming (reverseP newPerm)
+ lhsSubst' = {-'-} renaming __IMPOSSIBLE__ (reverseP newPerm)
-- Substitution used to convert terms in the old telescope's
-- context to terms in the new telescope's context.
@@ -512,8 +510,8 @@ translateRecordPatterns clause = do
-- New clause.
c = clause
{ clauseTel = newTel
- , namedClausePats = numberPatVars newPerm $ applySubst lhsSubst ps
- , clauseBody = translateBody cs rhsSubst $ clauseBody clause
+ , namedClausePats = numberPatVars __IMPOSSIBLE__ newPerm $ applySubst lhsSubst ps
+ , clauseBody = applySubst lhsSubst $ clauseBody clause
}
reportSDoc "tc.lhs.recpat" 20 $ vcat
@@ -546,7 +544,7 @@ translateRecordPatterns clause = do
[ text "delta =" <+> prettyTCM (clauseTel c)
, text "ps =" <+> text (show $ clausePats c)
, text "body =" <+> text (show $ clauseBody c)
- , text "body =" <+> prettyTCM (clauseBody c)
+ , text "body =" <+> addContext (clauseTel c) (maybe (text "_|_") prettyTCM (clauseBody c))
]
]
@@ -584,7 +582,7 @@ nextVar = RecPatM $ do
n <- lift get
lift $ put $ succ n
noVars <- lift ask
- return (VarP "r", var $ noVars - n - 1)
+ return (varP "r", var $ noVars - n - 1)
------------------------------------------------------------------------
-- Types used to record changes to a clause
@@ -689,7 +687,7 @@ removeTree tree = do
translatePattern :: Pattern -> RecPatM (Pattern, [Term], Changes)
translatePattern p@(ConP c ci ps)
-- Andreas, 2015-05-28 only translate implicit record patterns
- | Just ConPImplicit <- conPRecord ci = do
+ | Just ConOSystem <- conPRecord ci = do
r <- recordTree p
case r of
Left r -> r
@@ -725,7 +723,7 @@ recordTree ::
Pattern ->
RecPatM (Either (RecPatM (Pattern, [Term], Changes)) RecordTree)
-- Andreas, 2015-05-28 only translate implicit record patterns
-recordTree (ConP c ci ps) | Just ConPImplicit <- conPRecord ci = do
+recordTree (ConP c ci ps) | Just ConOSystem <- conPRecord ci = do
let t = fromMaybe __IMPOSSIBLE__ $ conPType ci
rs <- mapM (recordTree . namedArg) ps
case allRight rs of
@@ -738,7 +736,7 @@ recordTree (ConP c ci ps) | Just ConPImplicit <- conPRecord ci = do
t <- reduce t
fields <- getRecordTypeFields (unArg t)
-- let proj p = \x -> Def (unArg p) [defaultArg x]
- let proj p = (`applyE` [Proj $ unArg p])
+ let proj p = (`applyE` [Proj ProjSystem $ unArg p])
return $ Right $ RecCon t $ zip (map proj fields) ts
recordTree p@(ConP _ ci _) = return $ Left $ translatePattern p
recordTree p@VarP{} = return (Right (Leaf p))
@@ -769,27 +767,3 @@ translateTel (Left _ : rest) (t : tel) = Just t : translateTel rest tel
translateTel [] [] = []
translateTel (Left _ : _) [] = __IMPOSSIBLE__
translateTel [] (_ : _) = __IMPOSSIBLE__
-
--- | Translates the clause body. The substitution should take things
--- in the context of the old RHS to the new RHS's context.
-
-translateBody :: Changes -> Substitution -> ClauseBody -> ClauseBody
-translateBody _ s NoBody = NoBody
-translateBody (Right (n, x, _) : rest) s b =
- Bind $ Abs x $ translateBody rest s $ dropBinds n' b
- where n' = sum $ map n [VarPat, DotPat]
-translateBody (Left _ : rest) s (Bind b) = Bind $ fmap (translateBody rest s) b
-translateBody [] s (Body t) = Body $ applySubst s t
-translateBody _ _ _ = __IMPOSSIBLE__
-
-------------------------------------------------------------------------
--- Helper functions
-
--- | @dropBinds n b@ drops the initial @n@ occurrences of 'Bind' from @b@.
---
--- Precondition: @b@ has to start with @n@ occurrences of 'Bind'.
-
-dropBinds :: Nat -> ClauseBody -> ClauseBody
-dropBinds n b | n == 0 = b
-dropBinds n (Bind b) | n > 0 = dropBinds (pred n) (absBody b)
-dropBinds _ _ = __IMPOSSIBLE__
diff --git a/src/full/Agda/TypeChecking/Records.hs b/src/full/Agda/TypeChecking/Records.hs
index db7906a..b3a64ab 100644
--- a/src/full/Agda/TypeChecking/Records.hs
+++ b/src/full/Agda/TypeChecking/Records.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Records where
@@ -11,6 +10,7 @@ import Data.Function
import Data.List
import Data.Maybe
import qualified Data.Set as Set
+import Data.Traversable (traverse)
import Agda.Syntax.Common
import qualified Agda.Syntax.Concrete.Name as C
@@ -83,7 +83,7 @@ insertMissingFields r placeholder fs axs = do
givenFields = [ (x, Just $ arg x e) | FieldAssignment x e <- fs ]
-- Compute a list of p[aceholders for the missing visible fields.
let missingExplicits =
- [ (x, Just $ unnamed . placeholder <$> a)
+ [ (x, Just $ setOrigin Inserted $ unnamed . placeholder <$> a)
| a <- filter notHidden axs
, let x = unArg a
, x `notElem` map (view nameFieldA) fs
@@ -109,8 +109,9 @@ getRecordDef r = maybe err return =<< isRecord r
-- | Get the record name belonging to a field name.
getRecordOfField :: QName -> TCM (Maybe QName)
-getRecordOfField d = maybe Nothing fromP <$> isProjection d
- where fromP Projection{ projProper = mp, projFromType = r} = mp $> r
+getRecordOfField d = caseMaybeM (isProjection d) (return Nothing) $
+ \ Projection{ projProper = proper, projFromType = r} ->
+ return $ if proper then Just (unArg r) else Nothing
-- | Get the field names of a record.
getRecordFieldNames :: QName -> TCM [Arg C.Name]
@@ -122,13 +123,18 @@ recordFieldNames = map (fmap (nameConcrete . qnameName)) . recFields
-- | Find all records with at least the given fields.
findPossibleRecords :: [C.Name] -> TCM [QName]
findPossibleRecords fields = do
- defs <- (HMap.union `on` (^. sigDefinitions)) <$> getSignature <*> getImportedSignature
- let possible def = case theDef def of
- Record{ recFields = fs } -> Set.isSubsetOf given inrecord
- where inrecord = Set.fromList $ map (nameConcrete . qnameName . unArg) fs
- _ -> False
- return [ defName d | d <- HMap.elems defs, possible d ]
+ defs <- HMap.elems <$> use (stSignature . sigDefinitions)
+ idefs <- HMap.elems <$> use (stImports . sigDefinitions)
+ return $ cands defs ++ cands idefs
where
+ cands defs = [ defName d | d <- defs, possible d ]
+ possible def =
+ -- Check whether the given fields are contained
+ -- in the fields of record @def@ (if it is a record).
+ case theDef def of
+ Record{ recFields = fs } -> Set.isSubsetOf given $
+ Set.fromList $ map (nameConcrete . qnameName . unArg) fs
+ _ -> False
given = Set.fromList fields
-- | Get the field types of a record.
@@ -146,17 +152,6 @@ getRecordTypeFields t =
_ -> __IMPOSSIBLE__
_ -> __IMPOSSIBLE__
--- | Get the original name of the projection
--- (the current one could be from a module application).
-getOriginalProjection :: QName -> TCM QName
-getOriginalProjection q = do
- proj <- fromMaybe __IMPOSSIBLE__ <$> isProjection q
- return $ fromMaybe __IMPOSSIBLE__ $ projProper proj
-
--- | Get the type of the record constructor.
-getRecordConstructorType :: QName -> TCM Type
-getRecordConstructorType r = recConType <$> getRecordDef r
-
-- | Returns the given record type's constructor name (with an empty
-- range).
getRecordConstructor :: QName -> TCM ConHead
@@ -192,6 +187,19 @@ tryRecordType t = ifBlockedType t (\ _ _ -> return $ Left Nothing) $ \ t -> do
caseMaybeM (isRecord r) no $ \ def -> return $ Right (r,vs,def)
_ -> no
+-- | Get the original projection info for name.
+{-# SPECIALIZE origProjection :: QName -> TCM (QName, Definition, Maybe Projection) #-}
+origProjection :: HasConstInfo m => QName -> m (QName, Definition, Maybe Projection)
+origProjection f = do
+ def <- getConstInfo f
+ let proj = isProjection_ $ theDef def
+ fallback = return (f, def, proj)
+ caseMaybe proj fallback $
+ \ p@Projection{ projProper = proper, projOrig = f' } ->
+ if not proper || f == f' then fallback else do
+ def <- getConstInfo f'
+ return (f', def, isProjection_ $ theDef def)
+
-- | @getDefType f t@ computes the type of (possibly projection-(like))
-- function @f@ whose first argument has type @t@.
-- The `parameters' for @f@ are extracted from @t@.
@@ -203,15 +211,27 @@ tryRecordType t = ifBlockedType t (\ _ _ -> return $ Left Nothing) $ \ t -> do
-- See also: 'Agda.TypeChecking.Datatypes.getConType'
getDefType :: QName -> Type -> TCM (Maybe Type)
getDefType f t = do
- def <- getConstInfo f
+ -- Andreas, Issue #1973: we need to take the original projection
+ -- since the parameters from the reduced type t are correct for
+ -- the original projection only.
+ -- Due to module application, the given (non-original) projection f
+ -- may expect less parameters, those corresponding to a unreduced
+ -- version of t (which we cannot obtain here).
+ (f, def, mp) <- origProjection f
let a = defType def
-- if @f@ is not a projection (like) function, @a@ is the correct type
fallback = return $ Just a
- caseMaybe (isProjection_ $ theDef def) fallback $
+ reportSDoc "tc.deftype" 20 $ vcat
+ [ text "definition f = " <> prettyTCM f <+> text ("raw: " ++ show f)
+ , text "has type a = " <> prettyTCM a
+ , text "principal t = " <> prettyTCM t
+ ]
+ caseMaybe mp fallback $
\ (Projection{ projIndex = n }) -> if n <= 0 then fallback else do
-- otherwise, we have to instantiate @a@ to the "parameters" of @f@
let npars | n == 0 = __IMPOSSIBLE__
| otherwise = n - 1
+ reportSLn "tc.deftype" 20 $ "projIndex = " ++ show n
-- we get the parameters from type @t@
case ignoreSharing $ unEl t of
Def d es -> do
@@ -223,7 +243,13 @@ getDefType f t = do
ifNotM (eligibleForProjectionLike d) failNotElig $ {- else -} do
-- now we know it is reduced, we can safely take the parameters
let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take npars es
- Just <$> a `piApplyM` pars
+ reportSDoc "tc.deftype" 20 $ vcat
+ [ text $ "head d = " ++ show d
+ , text "parameters =" <+> sep (map prettyTCM pars)
+ ]
+ reportSLn "tc.deftype" 60 $ "parameters = " ++ show pars
+ if length pars < npars then failure "does not supply enough parameters"
+ else Just <$> a `piApplyM` pars
_ -> failNotDef
where
failNotElig = failure "is not eligible for projection-likeness"
@@ -239,15 +265,17 @@ getDefType f t = do
-- | The analogue of 'piApply'. If @v@ is a value of record type @t@
-- with field @f@, then @projectTyped v t f@ returns the type of @f v@.
+-- And also the record type (as first result).
--
-- Works also for projection-like definitions @f@.
+-- In this case, the first result is not a record type.
--
-- Precondition: @t@ is reduced.
-projectTyped :: Term -> Type -> QName -> TCM (Maybe (Term, Type))
-projectTyped v t f = caseMaybeM (getDefType f t) (return Nothing) $ \ tf -> do
- (dom, b) <- mustBePi tf
- u <- f `applyDef` (argFromDom dom $> v)
- return $ Just (u, b `absApp` v)
+projectTyped :: Term -> Type -> ProjOrigin -> QName -> TCM (Maybe (Dom Type, Term, Type))
+projectTyped v t o f = caseMaybeM (getDefType f t) (return Nothing) $ \ tf -> do
+ ifNotPiType tf (const $ return Nothing) {- else -} $ \ dom b -> do
+ u <- applyDef o f (argFromDom dom $> v)
+ return $ Just (dom, u, b `absApp` v)
-- | Check if a name refers to an eta expandable record.
{-# SPECIALIZE isEtaRecord :: QName -> TCM Bool #-}
@@ -276,8 +304,8 @@ isEtaRecordType a = case ignoreSharing $ unEl a of
-- | Check if a name refers to a record constructor.
-- If yes, return record definition.
-isRecordConstructor :: MonadTCM tcm => QName -> tcm (Maybe (QName, Defn))
-isRecordConstructor c = liftTCM $ do
+isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, Defn))
+isRecordConstructor c = do
def <- theDef <$> getConstInfo c
case def of
Constructor{ conData = r } -> fmap (r,) <$> isRecord r
@@ -298,16 +326,34 @@ isGeneratedRecordConstructor c = do
-- | Mark record type as unguarded.
-- No eta-expansion. Projections do not preserve guardedness.
unguardedRecord :: QName -> TCM ()
-unguardedRecord q = modifySignature $ updateDefinition q $ updateTheDef $ updateRecord
- where updateRecord r@Record{} = r { recEtaEquality' = setEtaEquality (recEtaEquality' r) False, recRecursive = True }
- updateRecord _ = __IMPOSSIBLE__
+unguardedRecord q = modifySignature $ updateDefinition q $ updateTheDef $ \case
+ r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) False, recRecursive = True }
+ _ -> __IMPOSSIBLE__
-- | Mark record type as recursive.
-- Projections do not preserve guardedness.
recursiveRecord :: QName -> TCM ()
-recursiveRecord q = modifySignature $ updateDefinition q $ updateTheDef $ updateRecord
- where updateRecord r@Record{} = r { recRecursive = True }
- updateRecord _ = __IMPOSSIBLE__
+recursiveRecord q = do
+ ok <- etaEnabled
+ modifySignature $ updateDefinition q $ updateTheDef $ \case
+ r@Record{ recInduction = ind, recEtaEquality' = eta } ->
+ r { recRecursive = True, recEtaEquality' = eta' }
+ where
+ eta' | ok, eta == Inferred False, ind /= Just CoInductive = Inferred True
+ | otherwise = eta
+ _ -> __IMPOSSIBLE__
+
+-- | Turn on eta for non-recursive record, unless user declared otherwise.
+nonRecursiveRecord :: QName -> TCM ()
+nonRecursiveRecord q = whenM etaEnabled $ do
+ -- Do nothing if eta is disabled by option.
+ modifySignature $ updateDefinition q $ updateTheDef $ \case
+ r@Record{ recInduction = ind, recEtaEquality' = Inferred False }
+ | ind /= Just CoInductive ->
+ r { recEtaEquality' = Inferred True }
+ r@Record{} -> r
+ _ -> __IMPOSSIBLE__
+
-- | Check whether record type is marked as recursive.
--
@@ -365,14 +411,14 @@ expandRecordVar i gamma0 = do
fs = recFields def
-- Construct the record pattern @Γ₁, Γ' ⊢ u := c ys@.
ys = zipWith (\ f i -> f $> var i) fs $ downFrom m
- u = Con (recConHead def) ys
+ u = Con (recConHead def) ConOSystem ys
-- @Γ₁, Γ' ⊢ τ₀ : Γ₁, x:_@
tau0 = consS u $ raiseS m
-- @Γ₁, Γ', Γ₂ ⊢ τ₀ : Γ₁, x:_, Γ₂@
tau = liftS (size gamma2) tau0
-- Fields are in order first-first.
- zs = for fs $ fmap $ \ f -> Var 0 [Proj f]
+ zs = for fs $ fmap $ \ f -> Var 0 [Proj ProjSystem f]
-- We need to reverse the field sequence to build the substitution.
-- @Γ₁, x:_ ⊢ σ₀ : Γ₁, Γ'@
sigma0 = reverse (map unArg zs) ++# raiseS 1
@@ -427,14 +473,14 @@ curryAt t n = do
m = size tel
fs = recFields def
ys = zipWith (\ f i -> f $> var i) fs $ downFrom m
- u = Con (recConHead def) ys
+ u = Con (recConHead def) ConOSystem ys
b' = raise m b `absApp` u
t' = gamma `telePi` (tel `telePi` b')
gammai = map domInfo $ telToList gamma
xs = reverse $ zipWith (\ ai i -> Arg ai $ var i) gammai [m..]
curry v = teleLam gamma $ teleLam tel $
raise (n+m) v `apply` (xs ++ [Arg ai u])
- zs = for fs $ fmap $ \ f -> Var 0 [Proj f]
+ zs = for fs $ fmap $ \ f -> Var 0 [Proj ProjSystem f]
atel = sgTel $ Dom ai (absName b, a)
uncurry v = teleLam gamma $ teleLam atel $
raise (n + 1) v `apply` (xs ++ zs)
@@ -444,7 +490,8 @@ curryAt t n = do
{-| @etaExpand r pars u@ computes the eta expansion of record value @u@
at record type @r pars@.
- The first argument @r@ should be the name of a record type. Given
+ The first argument @r@ should be the name of an eta-expandable record type.
+ Given
@record R : Set where field x : A; y : B; .z : C@
@@ -455,30 +502,48 @@ curryAt t n = do
where @tel@ is the record telescope instantiated at the parameters @pars@.
-}
etaExpandRecord :: QName -> Args -> Term -> TCM (Telescope, Args)
-etaExpandRecord r pars u = do
+etaExpandRecord = etaExpandRecord' False
+
+-- | Eta expand a record regardless of whether it's an eta-record or not.
+forceEtaExpandRecord :: QName -> Args -> Term -> TCM (Telescope, Args)
+forceEtaExpandRecord = etaExpandRecord' True
+
+etaExpandRecord' :: Bool -> QName -> Args -> Term -> TCM (Telescope, Args)
+etaExpandRecord' forceEta r pars u = do
def <- getRecordDef r
- (tel, _, args) <- etaExpandRecord_ r pars def u
+ (tel, _, _, args) <- etaExpandRecord'_ forceEta r pars def u
return (tel, args)
-etaExpandRecord_ :: QName -> Args -> Defn -> Term -> TCM (Telescope, ConHead, Args)
-etaExpandRecord_ r pars def u = do
+etaExpandRecord_ :: QName -> Args -> Defn -> Term -> TCM (Telescope, ConHead, ConInfo, Args)
+etaExpandRecord_ = etaExpandRecord'_ False
+
+etaExpandRecord'_ :: Bool -> QName -> Args -> Defn -> Term -> TCM (Telescope, ConHead, ConInfo, Args)
+etaExpandRecord'_ forceEta r pars def u = do
let Record{ recConHead = con
, recFields = xs
, recTel = tel
} = def
eta = recEtaEquality def
tel' = apply tel pars
- unless eta __IMPOSSIBLE__ -- make sure we do not expand non-eta records
+ unless (eta || forceEta) __IMPOSSIBLE__ -- make sure we do not expand non-eta records (unless forced to)
case ignoreSharing u of
+
-- Already expanded.
- Con con_ args -> do
- when (con /= con_) __IMPOSSIBLE__
- return (tel', con, args)
+ Con con_ ci args -> do
+ when (con /= con_) $ do
+ reportSDoc "impossible" 10 $ vcat
+ [ text "etaExpandRecord_: the following two constructors should be identical"
+ , nest 2 $ text $ "con = " ++ show con
+ , nest 2 $ text $ "con_ = " ++ show con_
+ ]
+ __IMPOSSIBLE__
+ return (tel', con, ci, args)
+
-- Not yet expanded.
- _ -> do
+ _ -> do
-- Andreas, < 2016-01-18: Note: recFields are always the original projections,
-- thus, we can use them in Proj directly.
- let xs' = for xs $ fmap $ \ x -> u `applyE` [Proj x]
+ let xs' = for xs $ fmap $ \ x -> u `applyE` [Proj ProjSystem x]
reportSDoc "tc.record.eta" 20 $ vcat
[ text "eta expanding" <+> prettyTCM u <+> text ":" <+> prettyTCM r
, nest 2 $ vcat
@@ -486,13 +551,13 @@ etaExpandRecord_ r pars def u = do
, text "args =" <+> prettyTCM xs'
]
]
- return (tel', con, xs')
+ return (tel', con, ConOSystem, xs')
etaExpandAtRecordType :: Type -> Term -> TCM (Telescope, Term)
etaExpandAtRecordType t u = do
(r, pars, def) <- fromMaybe __IMPOSSIBLE__ <$> isRecordType t
- (tel, con, args) <- etaExpandRecord_ r pars def u
- return (tel, Con con args)
+ (tel, con, ci, args) <- etaExpandRecord_ r pars def u
+ return (tel, Con con ci args)
-- | The fields should be eta contracted already.
--
@@ -502,10 +567,10 @@ etaExpandAtRecordType t u = do
--
-- TODO: this can be moved out of TCM (but only if ConHead
-- stores also the Arg-decoration of the record fields.
-{-# SPECIALIZE etaContractRecord :: QName -> ConHead -> Args -> TCM Term #-}
-{-# SPECIALIZE etaContractRecord :: QName -> ConHead -> Args -> ReduceM Term #-}
-etaContractRecord :: HasConstInfo m => QName -> ConHead -> Args -> m Term
-etaContractRecord r c args = do
+{-# SPECIALIZE etaContractRecord :: QName -> ConHead -> ConInfo -> Args -> TCM Term #-}
+{-# SPECIALIZE etaContractRecord :: QName -> ConHead -> ConInfo -> Args -> ReduceM Term #-}
+etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term
+etaContractRecord r c ci args = do
Just Record{ recFields = xs } <- isRecord r
let check :: Arg Term -> Arg QName -> Maybe (Maybe Term)
check a ax = do
@@ -516,10 +581,10 @@ etaContractRecord r c args = do
-- if @a@ is the record field name applied to a single argument
-- then it passes the check
(_, Just (_, [])) -> Nothing -- not a projection
- (_, Just (h, es)) | Proj f <- last es, unArg ax == f
+ (_, Just (h, es)) | Proj _o f <- last es, unArg ax == f
-> Just $ Just $ h $ init es
_ -> Nothing
- fallBack = return (Con c args)
+ fallBack = return (Con c ci args)
case compare (length args) (length xs) of
LT -> fallBack -- Not fully applied
GT -> __IMPOSSIBLE__ -- Too many arguments. Impossible.
@@ -551,7 +616,7 @@ isSingletonRecord' :: Bool -> QName -> Args -> TCM (Either MetaId (Maybe Term))
isSingletonRecord' regardIrrelevance r ps = do
reportSLn "tc.meta.eta" 30 $ "Is " ++ show r ++ " a singleton record type?"
def <- getRecordDef r
- emap (Con $ recConHead def) <$> check (recTel def `apply` ps)
+ emap (Con (recConHead def) ConOSystem) <$> check (recTel def `apply` ps)
where
check :: Telescope -> TCM (Either MetaId (Maybe [Arg Term]))
check tel = do
@@ -597,3 +662,27 @@ isSingletonType' regardIrrelevance t = do
-- | Auxiliary function.
emap :: (a -> b) -> Either c (Maybe a) -> Either c (Maybe b)
emap = mapRight . fmap
+
+class NormaliseProjP a where
+ normaliseProjP :: HasConstInfo m => a -> m a
+
+instance NormaliseProjP Clause where
+ normaliseProjP cl = do
+ ps <- normaliseProjP $ namedClausePats cl
+ return $ cl { namedClausePats = ps }
+
+instance NormaliseProjP a => NormaliseProjP [a] where
+ normaliseProjP = traverse normaliseProjP
+
+instance NormaliseProjP a => NormaliseProjP (Arg a) where
+ normaliseProjP = traverse normaliseProjP
+
+instance NormaliseProjP a => NormaliseProjP (Named_ a) where
+ normaliseProjP = traverse normaliseProjP
+
+instance NormaliseProjP (Pattern' x) where
+ normaliseProjP p@VarP{} = return p
+ normaliseProjP p@DotP{} = return p
+ normaliseProjP (ConP c cpi ps) = ConP c cpi <$> normaliseProjP ps
+ normaliseProjP p@LitP{} = return p
+ normaliseProjP (ProjP o d0) = ProjP o <$> getOriginalProjection d0
diff --git a/src/full/Agda/TypeChecking/Records.hs-boot b/src/full/Agda/TypeChecking/Records.hs-boot
index fb3c06a..c17e4ba 100644
--- a/src/full/Agda/TypeChecking/Records.hs-boot
+++ b/src/full/Agda/TypeChecking/Records.hs-boot
@@ -9,6 +9,6 @@ import Agda.TypeChecking.Monad
isRecord :: HasConstInfo m => QName -> m (Maybe Defn)
isEtaRecord :: HasConstInfo m => QName -> m Bool
getRecordFieldNames :: QName -> TCM [Arg C.Name]
-etaContractRecord :: HasConstInfo m => QName -> ConHead -> Args -> m Term
+etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term
isGeneratedRecordConstructor :: QName -> TCM Bool
-isRecordConstructor :: MonadTCM tcm => QName -> tcm (Maybe (QName, Defn))
+isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, Defn))
diff --git a/src/full/Agda/TypeChecking/Reduce.hs b/src/full/Agda/TypeChecking/Reduce.hs
index e2f5e65..dc71c43 100644
--- a/src/full/Agda/TypeChecking/Reduce.hs
+++ b/src/full/Agda/TypeChecking/Reduce.hs
@@ -1,12 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE UndecidableInstances #-}
module Agda.TypeChecking.Reduce where
@@ -20,6 +14,8 @@ import Data.Map (Map)
import Data.Traversable
import Data.Hashable
+import Agda.Interaction.Options
+
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Internal
@@ -42,11 +38,13 @@ import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Match
import {-# SOURCE #-} Agda.TypeChecking.Patterns.Match
import {-# SOURCE #-} Agda.TypeChecking.Pretty
import {-# SOURCE #-} Agda.TypeChecking.Rewriting
+import {-# SOURCE #-} Agda.TypeChecking.Reduce.Fast
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Monad
import Agda.Utils.HashMap (HashMap)
+import Agda.Utils.Size
import Agda.Utils.Tuple
#include "undefined.h"
@@ -70,6 +68,14 @@ normalise = runReduceM . normalise'
simplify :: Simplify a => a -> TCM a
simplify = runReduceM . simplify'
+-- | Meaning no metas left in the instantiation.
+isFullyInstantiatedMeta :: MetaId -> TCM Bool
+isFullyInstantiatedMeta m = do
+ mv <- TCM.lookupMeta m
+ case mvInstantiation mv of
+ InstV sub v -> null . allMetas <$> instantiateFull (sub, v)
+ _ -> return False
+
-- | Instantiate something.
-- Results in an open meta variable or a non meta.
-- Doesn't do any reduction, and preserves blocking tags (when blocking meta
@@ -98,7 +104,6 @@ instance Instantiate Term where
OpenIFS -> return t
BlockedConst _ -> return t
PostponedTypeCheckingProblem _ _ -> return t
- InstS _ -> __IMPOSSIBLE__
instantiate' (Level l) = levelTm <$> instantiate' l
instantiate' (Sort s) = sortTm <$> instantiate' s
instantiate' v@Shared{} =
@@ -132,7 +137,6 @@ instance Instantiate a => Instantiate (Blocked a) where
OpenIFS -> return v
BlockedConst{} -> return v
PostponedTypeCheckingProblem{} -> return v
- InstS{} -> __IMPOSSIBLE__
instance Instantiate Type where
instantiate' (El s t) = El <$> instantiate' s <*> instantiate' t
@@ -144,7 +148,7 @@ instance Instantiate Sort where
instance Instantiate Elim where
instantiate' (Apply v) = Apply <$> instantiate' v
- instantiate' (Proj f) = pure $ Proj f
+ instantiate' (Proj o f)= pure $ Proj o f
instance Instantiate t => Instantiate (Abs t) where
instantiate' = traverse instantiate'
@@ -195,7 +199,7 @@ instance Instantiate e => Instantiate (Map k e) where
instantiate' = traverse instantiate'
instance Instantiate Candidate where
- instantiate' (Candidate u t eti) = Candidate <$> instantiate' u <*> instantiate' t <*> return eti
+ instantiate' (Candidate u t eti ov) = Candidate <$> instantiate' u <*> instantiate' t <*> pure eti <*> pure ov
instance Instantiate EqualityView where
instantiate' (OtherType t) = OtherType
@@ -257,7 +261,7 @@ instance Reduce Sort where
instance Reduce Elim where
reduce' (Apply v) = Apply <$> reduce' v
- reduce' (Proj f) = pure $ Proj f
+ reduce' (Proj o f)= pure $ Proj o f
instance Reduce Level where
reduce' (Max as) = levelMax <$> mapM reduce' as
@@ -311,7 +315,23 @@ instance (Reduce a, Reduce b,Reduce c) => Reduce (a,b,c) where
reduce' (x,y,z) = (,,) <$> reduce' x <*> reduce' y <*> reduce' z
instance Reduce Term where
- reduceB' = {-# SCC "reduce'<Term>" #-} rewriteAfter $ \ v -> do
+ reduceB' = {-# SCC "reduce'<Term>" #-} maybeFastReduceTerm
+
+maybeFastReduceTerm :: Term -> ReduceM (Blocked Term)
+maybeFastReduceTerm v = do
+ let tryFast = case v of
+ Def{} -> True
+ Con{} -> True
+ _ -> False
+ if not tryFast then slowReduceTerm v
+ else do
+ s <- optSharing <$> commandLineOptions
+ allowed <- asks envAllowedReductions
+ let notAll = delete NonTerminatingReductions allowed /= allReductions
+ if s || notAll then slowReduceTerm v else fastReduce (elem NonTerminatingReductions allowed) v
+
+slowReduceTerm :: Term -> ReduceM (Blocked Term)
+slowReduceTerm v = do
v <- instantiate' v
let done = return $ notBlocked v
case v of
@@ -320,10 +340,10 @@ instance Reduce Term where
-- MetaV x args -> notBlocked . MetaV x <$> reduce' args
MetaV x es -> done
Def f es -> unfoldDefinitionE False reduceB' (Def f []) f es
- Con c args -> do
+ Con c ci args -> do
-- Constructors can reduce' when they come from an
-- instantiated module.
- v <- unfoldDefinition False reduceB' (Con c []) (conName c) args
+ v <- unfoldDefinition False reduceB' (Con c ci []) (conName c) args
traverse reduceNat v
Sort s -> fmap sortTm <$> reduceB' s
Level l -> ifM (elem LevelReductions <$> asks envAllowedReductions)
@@ -338,64 +358,71 @@ instance Reduce Term where
where
-- NOTE: reduceNat can traverse the entire term.
reduceNat v@Shared{} = updateSharedTerm reduceNat v
- reduceNat v@(Con c []) = do
+ reduceNat v@(Con c ci []) = do
mz <- getBuiltin' builtinZero
case v of
_ | Just v == mz -> return $ Lit $ LitNat (getRange c) 0
_ -> return v
- reduceNat v@(Con c [a]) | notHidden a && isRelevant a = do
+ reduceNat v@(Con c ci [a]) | notHidden a && isRelevant a = do
ms <- fmap ignoreSharing <$> getBuiltin' builtinSuc
case v of
- _ | Just (Con c []) == ms -> inc <$> reduce' (unArg a)
+ _ | Just (Con c ci []) == ms -> inc <$> reduce' (unArg a)
_ -> return v
where
inc w = case ignoreSharing w of
Lit (LitNat r n) -> Lit (LitNat (fuseRange c r) $ n + 1)
- _ -> Con c [defaultArg w]
+ _ -> Con c ci [defaultArg w]
reduceNat v = return v
-rewriteAfter :: (Term -> ReduceM (Blocked Term)) -> Term -> ReduceM (Blocked Term)
-rewriteAfter f = trampolineM $ rewrite <=< f
-
-- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion
-- need also to instantiate metas, see Issue 826.
unfoldCorecursionE :: Elim -> ReduceM (Blocked Elim)
-unfoldCorecursionE e@(Proj f) = return $ notBlocked e
+unfoldCorecursionE (Proj o p) = notBlocked . Proj o <$> getOriginalProjection p
unfoldCorecursionE (Apply (Arg info v)) = fmap (Apply . Arg info) <$>
unfoldCorecursion v
unfoldCorecursion :: Term -> ReduceM (Blocked Term)
-unfoldCorecursion = rewriteAfter $ \ v -> do
+unfoldCorecursion v = do
v <- instantiate' v
case compressPointerChain v of
Def f es -> unfoldDefinitionE True unfoldCorecursion (Def f []) f es
v@(Shared p) ->
case derefPtr p of
Def{} -> updateSharedFM unfoldCorecursion v
- _ -> reduceB' v
- _ -> reduceB' v
+ _ -> slowReduceTerm v
+ _ -> slowReduceTerm v
-- | If the first argument is 'True', then a single delayed clause may
-- be unfolded.
unfoldDefinition ::
Bool -> (Term -> ReduceM (Blocked Term)) ->
Term -> QName -> Args -> ReduceM (Blocked Term)
-unfoldDefinition b keepGoing v f args = snd <$> do
- unfoldDefinition' b (\ t -> (NoSimplification,) <$> keepGoing t) v f $
- map Apply args
+unfoldDefinition unfoldDelayed keepGoing v f args =
+ unfoldDefinitionE unfoldDelayed keepGoing v f (map Apply args)
unfoldDefinitionE ::
Bool -> (Term -> ReduceM (Blocked Term)) ->
Term -> QName -> Elims -> ReduceM (Blocked Term)
-unfoldDefinitionE b keepGoing v f es = snd <$>
- unfoldDefinition' b (\ t -> (NoSimplification,) <$> keepGoing t) v f es
+unfoldDefinitionE unfoldDelayed keepGoing v f es = do
+ r <- unfoldDefinitionStep unfoldDelayed v f es
+ case r of
+ NoReduction v -> return v
+ YesReduction _ v -> keepGoing v
unfoldDefinition' ::
- Bool -> (Term -> ReduceM (Simplification, Blocked Term)) ->
+ Bool -> (Simplification -> Term -> ReduceM (Simplification, Blocked Term)) ->
Term -> QName -> Elims -> ReduceM (Simplification, Blocked Term)
-unfoldDefinition' unfoldDelayed keepGoing v0 f es =
+unfoldDefinition' unfoldDelayed keepGoing v0 f es = do
+ r <- unfoldDefinitionStep unfoldDelayed v0 f es
+ case r of
+ NoReduction v -> return (NoSimplification, v)
+ YesReduction simp v -> keepGoing simp v
+
+unfoldDefinitionStep :: Bool -> Term -> QName -> Elims -> ReduceM (Reduced (Blocked Term) Term)
+unfoldDefinitionStep unfoldDelayed v0 f es =
{-# SCC "reduceDef" #-} do
info <- getConstInfo f
+ rewr <- getRewriteRulesFor f
allowed <- asks envAllowedReductions
let def = theDef info
v = v0 `applyE` es
@@ -412,30 +439,29 @@ unfoldDefinition' unfoldDelayed keepGoing v0 f es =
_ -> False
case def of
Constructor{conSrcCon = c} ->
- retSimpl $ notBlocked $ Con (c `withRangeOf` f) [] `applyE` es
+ noReduction $ notBlocked $ Con (c `withRangeOf` f) ConOSystem [] `applyE` es
Primitive{primAbstr = ConcreteDef, primName = x, primClauses = cls} -> do
pf <- fromMaybe __IMPOSSIBLE__ <$> getPrimitive' x
if FunctionReductions `elem` allowed
then reducePrimitive x v0 f es pf dontUnfold
- cls (defCompiled info)
- else retSimpl $ notBlocked v
+ cls (defCompiled info) rewr
+ else noReduction $ notBlocked v
_ -> do
if FunctionReductions `elem` allowed ||
(isJust (isProjection_ def) && ProjectionReductions `elem` allowed) || -- includes projection-like
(isInlineFun def && InlineReductions `elem` allowed) ||
(copatterns && CopatternReductions `elem` allowed)
then
- reduceNormalE keepGoing v0 f (map notReduced es)
- dontUnfold
- (defClauses info) (defCompiled info)
- else retSimpl $ notBlocked v -- Andrea(s), 2014-12-05 OK?
+ reduceNormalE v0 f (map notReduced es) dontUnfold
+ (defClauses info) (defCompiled info) rewr
+ else noReduction $ notBlocked v -- Andrea(s), 2014-12-05 OK?
where
- retSimpl v = (,v) <$> getSimplification
-
- reducePrimitive x v0 f es pf dontUnfold cls mcc
+ noReduction = return . NoReduction
+ yesReduction s = return . YesReduction s
+ reducePrimitive x v0 f es pf dontUnfold cls mcc rewr
| genericLength es < ar
- = retSimpl $ NotBlocked Underapplied $ v0 `applyE` es -- not fully applied
+ = noReduction $ NotBlocked Underapplied $ v0 `applyE` es -- not fully applied
| otherwise = {-# SCC "reducePrimitive" #-} do
let (es1,es2) = genericSplitAt ar es
args1 = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es1
@@ -444,63 +470,46 @@ unfoldDefinition' unfoldDelayed keepGoing v0 f es =
NoReduction args1' -> do
let es1' = map (fmap Apply) args1'
if null cls then do
- retSimpl $ applyE (Def f []) <$> do
+ noReduction $ applyE (Def f []) <$> do
traverse id $
map mredToBlocked es1' ++ map notBlocked es2
else
- reduceNormalE keepGoing v0 f
- (es1' ++ map notReduced es2)
- dontUnfold cls mcc
- YesReduction simpl v -> performedSimplification' simpl $
- keepGoing $ v `applyE` es2
+ reduceNormalE v0 f (es1' ++ map notReduced es2) dontUnfold cls mcc rewr
+ YesReduction simpl v -> yesReduction simpl $ v `applyE` es2
where
ar = primFunArity pf
mredToBlocked :: MaybeReduced a -> Blocked a
mredToBlocked (MaybeRed NotReduced x) = notBlocked x
mredToBlocked (MaybeRed (Reduced b) x) = x <$ b
- reduceNormalE :: (Term -> ReduceM (Simplification, Blocked Term)) -> Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause] -> Maybe CompiledClauses -> ReduceM (Simplification, Blocked Term)
- reduceNormalE keepGoing v0 f es dontUnfold def mcc = {-# SCC "reduceNormal" #-} do
- case def of
+ reduceNormalE :: Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> ReduceM (Reduced (Blocked Term) Term)
+ reduceNormalE v0 f es dontUnfold def mcc rewr = {-# SCC "reduceNormal" #-} do
+ case (def,rewr) of
_ | dontUnfold -> defaultResult -- non-terminating or delayed
- [] -> defaultResult -- no definition for head
- cls -> do
- ev <- appDefE_ f v0 cls mcc es
- case ev of
- NoReduction v -> do
- traceSDoc "tc.reduce'" 90 (vcat
- [ text "*** tried to reduce' " <+> prettyTCM f
- , text " es = " <+> sep (map (prettyTCM . ignoreReduced) es)
--- [ text "*** tried to reduce' " <+> prettyTCM vfull
- , text " stuck on" <+> prettyTCM (ignoreBlocking v) ]) $ do
- retSimpl v
- YesReduction simpl v -> performedSimplification' simpl $ do
- traceSDoc "tc.reduce'" 90 (text "*** reduced definition: " <+> prettyTCM f) $ do
- traceSDoc "tc.reduce'" 95 (text " result" <+> prettyTCM v) $ do
- traceSDoc "tc.reduce'" 100 (text " raw " <+> text (show v)) $ do
- keepGoing v
- where defaultResult = retSimpl $ NotBlocked AbsurdMatch vfull
+ ([],[]) -> defaultResult -- no definition for head
+ (cls,rewr) -> appDefE_ f v0 cls mcc rewr es
+ where defaultResult = noReduction $ NotBlocked AbsurdMatch vfull
vfull = v0 `applyE` map ignoreReduced es
-- | Reduce a non-primitive definition if it is a copy linking to another def.
-reduceDefCopy :: QName -> Args -> TCM (Reduced () Term)
-reduceDefCopy f vs = do
+reduceDefCopy :: QName -> Elims -> TCM (Reduced () Term)
+reduceDefCopy f es = do
info <- TCM.getConstInfo f
- if (defCopy info) then reduceDef_ info f vs else return $ NoReduction ()
+ rewr <- TCM.getRewriteRulesFor f
+ if (defCopy info) then reduceDef_ info rewr f es else return $ NoReduction ()
where
- reduceDef_ :: Definition -> QName -> Args -> TCM (Reduced () Term)
- reduceDef_ info f vs = do
+ reduceDef_ :: Definition -> RewriteRules -> QName -> Elims -> TCM (Reduced () Term)
+ reduceDef_ info rewr f es = do
let v0 = Def f []
- args = map notReduced vs
cls = (defClauses info)
mcc = (defCompiled info)
if (defDelayed info == Delayed) || (defNonterminating info)
then return $ NoReduction ()
else do
- ev <- runReduceM $ appDef_ f v0 cls mcc args
+ ev <- runReduceM $ appDefE_ f v0 cls mcc rewr $ map notReduced es
case ev of
YesReduction simpl t -> return $ YesReduction simpl t
- NoReduction args' -> return $ NoReduction ()
+ NoReduction{} -> return $ NoReduction ()
-- | Reduce simple (single clause) definitions.
reduceHead :: Term -> TCM (Blocked Term)
@@ -542,38 +551,37 @@ reduceHead' v = do -- ignoreAbstractMode $ do
-- | Apply a definition using the compiled clauses, or fall back to
-- ordinary clauses if no compiled clauses exist.
-appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
-appDef_ f v0 cls mcc args = appDefE_ f v0 cls mcc $ map (fmap Apply) args
+appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
+appDef_ f v0 cls mcc rewr args = appDefE_ f v0 cls mcc rewr $ map (fmap Apply) args
-appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
-appDefE_ f v0 cls mcc args =
+appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
+appDefE_ f v0 cls mcc rewr args =
local (\ e -> e { envAppDef = Just f }) $
- maybe (appDefE' v0 cls args)
- (\cc -> appDefE v0 cc args) mcc
+ maybe (appDefE' v0 cls rewr args)
+ (\cc -> appDefE v0 cc rewr args) mcc
-- | Apply a defined function to it's arguments, using the compiled clauses.
-- The original term is the first argument applied to the third.
-appDef :: Term -> CompiledClauses -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
-appDef v cc args = appDefE v cc $ map (fmap Apply) args
+appDef :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
+appDef v cc rewr args = appDefE v cc rewr $ map (fmap Apply) args
-appDefE :: Term -> CompiledClauses -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
-appDefE v cc es = do
+appDefE :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
+appDefE v cc rewr es = do
r <- matchCompiledE cc es
case r of
YesReduction simpl t -> return $ YesReduction simpl t
- NoReduction es' -> return $ NoReduction $ applyE v <$> es'
+ NoReduction es' -> rewrite (void es') v rewr (ignoreBlocking es')
-- | Apply a defined function to it's arguments, using the original clauses.
-appDef' :: Term -> [Clause] -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
-appDef' v cls args = appDefE' v cls $ map (fmap Apply) args
+appDef' :: Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
+appDef' v cls rewr args = appDefE' v cls rewr $ map (fmap Apply) args
-appDefE' :: Term -> [Clause] -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
-appDefE' v cls es = goCls cls $ map ignoreReduced es
+appDefE' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
+appDefE' v cls rewr es = goCls cls $ map ignoreReduced es
where
goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term)
goCls cl es = do
- traceSLn "tc.reduce'" 95 ("Reduce.goCls tries reduction, #clauses = " ++ show (length cl)) $ do
case cl of
-- Andreas, 2013-10-26 In case of an incomplete match,
-- we just do not reduce. This allows adding single function
@@ -581,43 +589,28 @@ appDefE' v cls es = goCls cls $ map ignoreReduced es
-- the remaining clauses (see Issue 907).
-- Andrea(s), 2014-12-05: We return 'MissingClauses' here, since this
-- is the most conservative reason.
- [] -> return $ NoReduction $ NotBlocked MissingClauses $ v `applyE` es
- Clause{ namedClausePats = pats, clauseBody = body } : cls -> do
- let n = length pats
+ [] -> rewrite (NotBlocked MissingClauses ()) v rewr es
+ cl : cls -> do
+ let pats = namedClausePats cl
+ body = clauseBody cl
+ npats = length pats
+ nvars = size $ clauseTel cl
-- if clause is underapplied, skip to next clause
- if length es < n then goCls cls es else do
- let (es0, es1) = splitAt n es
- (m, es0) <- matchCopatterns (unnumberPatVars pats) es0
+ if length es < npats then goCls cls es else do
+ let (es0, es1) = splitAt npats es
+ (m, es0) <- matchCopatterns pats es0
es <- return $ es0 ++ es1
case m of
No -> goCls cls es
- DontKnow b -> return $ NoReduction $ b $> v `applyE` es
+ DontKnow b -> rewrite b v rewr es
Yes simpl vs -- vs is the subst. for the variables bound in body
- | isJust (getBodyUnraised body) -- clause has body?
- -> return $ YesReduction simpl $
+ | Just w <- body -> do -- clause has body?
-- TODO: let matchPatterns also return the reduced forms
-- of the original arguments!
-- Andreas, 2013-05-19 isn't this done now?
- app vs body EmptyS `applyE` es1
- | otherwise -> return $ NoReduction $ NotBlocked AbsurdMatch $ v `applyE` es
-
- -- Build an explicit substitution from arguments
- -- and execute it using parallel substitution.
- -- Calculating the de Bruijn indices: ;-) for the Bind case
- -- Simply-typed version
- -- (we are not interested in types, only in de Bruijn indices here)
- -- Γ ⊢ σ : Δ
- -- Γ ⊢ v : A
- -- Γ ⊢ (σ,v) : Δ.A
- -- Δ ⊢ λ b : A → B
- -- Δ.A ⊢ b : B
- app :: [Term] -> ClauseBody -> Substitution -> Term
- app [] (Body v) sigma = applySubst sigma v
- app (v : vs) (Bind (Abs _ b)) sigma = app vs b $ consS v sigma -- CBN
- app (v : vs) (Bind (NoAbs _ b)) sigma = app vs b sigma
- app _ NoBody sigma = __IMPOSSIBLE__
- app (_ : _) (Body _) sigma = __IMPOSSIBLE__
- app [] (Bind _) sigma = __IMPOSSIBLE__
+ let sigma = buildSubstitution __IMPOSSIBLE__ nvars vs
+ return $ YesReduction simpl $ applySubst sigma w `applyE` es1
+ | otherwise -> rewrite (NotBlocked AbsurdMatch ()) v rewr es
instance Reduce a => Reduce (Closure a) where
reduce' cl = do
@@ -648,7 +641,7 @@ instance Reduce e => Reduce (Map k e) where
reduce' = traverse reduce'
instance Reduce Candidate where
- reduce' (Candidate u t eti) = Candidate <$> reduce' u <*> reduce' t <*> return eti
+ reduce' (Candidate u t eti ov) = Candidate <$> reduce' u <*> reduce' t <*> pure eti <*> pure ov
instance Reduce EqualityView where
reduce' (OtherType t) = OtherType
@@ -675,7 +668,7 @@ instance Simplify Term where
v <- instantiate' v
case v of
Def f vs -> do
- let keepGoing v = (,notBlocked v) <$> getSimplification -- Andrea(s), 2014-12-05 OK?
+ let keepGoing simp v = return (simp, notBlocked v)
(simpl, v) <- unfoldDefinition' False keepGoing (Def f []) f vs
traceSDoc "tc.simplify'" 20 (
text ("simplify': unfolding definition returns " ++ show simpl)
@@ -684,7 +677,7 @@ instance Simplify Term where
YesSimplification -> simplifyBlocked' v -- Dangerous, but if @simpl@ then @v /= Def f vs@
NoSimplification -> Def f <$> simplify' vs
MetaV x vs -> MetaV x <$> simplify' vs
- Con c vs -> Con c <$> simplify' vs
+ Con c ci vs-> Con c ci <$> simplify' vs
Sort s -> sortTm <$> simplify' s
Level l -> levelTm <$> simplify' l
Pi a b -> Pi <$> simplify' a <*> simplify' b
@@ -703,7 +696,7 @@ instance Simplify Type where
instance Simplify Elim where
simplify' (Apply v) = Apply <$> simplify' v
- simplify' (Proj f) = pure $ Proj f
+ simplify' (Proj o f)= pure $ Proj o f
instance Simplify Sort where
simplify' s = do
@@ -804,16 +797,11 @@ instance Simplify Bool where
-- DotP v -> DotP <$> simplify' v
-- ProjP _ -> return p
-instance Simplify ClauseBody where
- simplify' (Body t) = Body <$> simplify' t
- simplify' (Bind b) = Bind <$> simplify' b
- simplify' NoBody = return NoBody
-
instance Simplify DisplayForm where
simplify' (Display n ps v) = Display n <$> simplify' ps <*> return v
instance Simplify Candidate where
- simplify' (Candidate u t eti) = Candidate <$> simplify' u <*> simplify' t <*> return eti
+ simplify' (Candidate u t eti ov) = Candidate <$> simplify' u <*> simplify' t <*> pure eti <*> pure ov
instance Simplify EqualityView where
simplify' (OtherType t) = OtherType
@@ -847,12 +835,12 @@ instance Normalise Type where
normalise' (El s t) = El <$> normalise' s <*> normalise' t
instance Normalise Term where
- normalise' = ignoreBlocking <.> rewriteAfter (reduceB' >=> traverse normaliseArgs)
+ normalise' = ignoreBlocking <.> (reduceB' >=> traverse normaliseArgs)
where
normaliseArgs :: Term -> ReduceM Term
normaliseArgs v = case v of
Var n vs -> Var n <$> normalise' vs
- Con c vs -> Con c <$> normalise' vs
+ Con c ci vs -> Con c ci <$> normalise' vs
Def f vs -> Def f <$> normalise' vs
MetaV x vs -> MetaV x <$> normalise' vs
Lit _ -> return v
@@ -865,7 +853,7 @@ instance Normalise Term where
instance Normalise Elim where
normalise' (Apply v) = Apply <$> normalise' v
- normalise' (Proj f) = pure $ Proj f
+ normalise' (Proj o f)= pure $ Proj o f
instance Normalise Level where
normalise' (Max as) = levelMax <$> normalise' as
@@ -883,11 +871,6 @@ instance Normalise LevelAtom where
NeutralLevel r v -> NeutralLevel r <$> normalise' v
UnreducedLevel{} -> __IMPOSSIBLE__ -- I hope
-instance Normalise ClauseBody where
- normalise' (Body t) = Body <$> normalise' t
- normalise' (Bind b) = Bind <$> normalise' b
- normalise' NoBody = return NoBody
-
instance (Subst t a, Normalise a) => Normalise (Abs a) where
normalise' a@(Abs x _) = Abs x <$> underAbstraction_ a normalise'
normalise' (NoAbs x v) = NoAbs x <$> normalise' v
@@ -953,13 +936,16 @@ instance Normalise Char where
instance Normalise ConPatternInfo where
normalise' (ConPatternInfo mr mt) = ConPatternInfo mr <$> normalise' mt
+instance Normalise DBPatVar where
+ normalise' = return
+
instance Normalise a => Normalise (Pattern' a) where
normalise' p = case p of
VarP x -> VarP <$> normalise' x
LitP _ -> return p
ConP c mt ps -> ConP c <$> normalise' mt <*> normalise' ps
DotP v -> DotP <$> normalise' v
- ProjP _ -> return p
+ ProjP{} -> return p
instance Normalise DisplayForm where
normalise' (Display n ps v) = Display n <$> normalise' ps <*> return v
@@ -971,7 +957,7 @@ instance Normalise a => Normalise (Maybe a) where
normalise' = traverse normalise'
instance Normalise Candidate where
- normalise' (Candidate u t eti) = Candidate <$> normalise' u <*> normalise' t <*> return eti
+ normalise' (Candidate u t eti ov) = Candidate <$> normalise' u <*> normalise' t <*> pure eti <*> pure ov
instance Normalise EqualityView where
normalise' (OtherType t) = OtherType
@@ -1019,7 +1005,7 @@ instance InstantiateFull Term where
v <- instantiate' v
case v of
Var n vs -> Var n <$> instantiateFull' vs
- Con c vs -> Con c <$> instantiateFull' vs
+ Con c ci vs -> Con c ci <$> instantiateFull' vs
Def f vs -> Def f <$> instantiateFull' vs
MetaV x vs -> MetaV x <$> instantiateFull' vs
Lit _ -> return v
@@ -1071,6 +1057,9 @@ instance InstantiateFull Int where
instance InstantiateFull ConPatternInfo where
instantiateFull' (ConPatternInfo mr mt) = ConPatternInfo mr <$> instantiateFull' mt
+instance InstantiateFull DBPatVar where
+ instantiateFull' = return
+
instance InstantiateFull a => InstantiateFull (Pattern' a) where
instantiateFull' (VarP x) = VarP <$> instantiateFull' x
instantiateFull' (DotP t) = DotP <$> instantiateFull' t
@@ -1078,11 +1067,6 @@ instance InstantiateFull a => InstantiateFull (Pattern' a) where
instantiateFull' l@LitP{} = return l
instantiateFull' p@ProjP{} = return p
-instance InstantiateFull ClauseBody where
- instantiateFull' (Body t) = Body <$> instantiateFull' t
- instantiateFull' (Bind b) = Bind <$> instantiateFull' b
- instantiateFull' NoBody = return NoBody
-
instance (Subst t a, InstantiateFull a) => InstantiateFull (Abs a) where
instantiateFull' a@(Abs x _) = Abs x <$> underAbstraction_ a instantiateFull'
instantiateFull' (NoAbs x a) = NoAbs x <$> instantiateFull' a
@@ -1134,7 +1118,7 @@ instance InstantiateFull Constraint where
instance (InstantiateFull a) => InstantiateFull (Elim' a) where
instantiateFull' (Apply v) = Apply <$> instantiateFull' v
- instantiateFull' (Proj f) = pure $ Proj f
+ instantiateFull' (Proj o f)= pure $ Proj o f
instance InstantiateFull e => InstantiateFull (Map k e) where
instantiateFull' = traverse instantiateFull'
@@ -1162,12 +1146,12 @@ instance InstantiateFull Char where
instantiateFull' = return
instance InstantiateFull Definition where
- instantiateFull' (Defn rel x t pol occ df i c inst copy d) = do
+ instantiateFull' (Defn rel x t pol occ df i c inst copy ma d) = do
(t, df, d) <- instantiateFull' (t, df, d)
- return $ Defn rel x t pol occ df i c inst copy d
+ return $ Defn rel x t pol occ df i c inst copy ma d
instance InstantiateFull NLPat where
- instantiateFull' (PVar x y) = return $ PVar x y
+ instantiateFull' (PVar x y z) = return $ PVar x y z
instantiateFull' (PWild) = return PWild
instantiateFull' (PDef x y) = PDef <$> instantiateFull' x <*> instantiateFull' y
instantiateFull' (PLam x y) = PLam x <$> instantiateFull' y
@@ -1175,30 +1159,40 @@ instance InstantiateFull NLPat where
instantiateFull' (PBoundVar x y) = PBoundVar x <$> instantiateFull' y
instantiateFull' (PTerm x) = PTerm <$> instantiateFull' x
+instance InstantiateFull NLPType where
+ instantiateFull' (NLPType l a) = NLPType
+ <$> instantiateFull' l
+ <*> instantiateFull' a
+
instance InstantiateFull RewriteRule where
- instantiateFull' (RewriteRule q gamma lhs rhs t) =
+ instantiateFull' (RewriteRule q gamma f ps rhs t) =
RewriteRule q
<$> instantiateFull' gamma
- <*> instantiateFull' lhs
+ <*> pure f
+ <*> instantiateFull' ps
<*> instantiateFull' rhs
<*> instantiateFull' t
instance InstantiateFull a => InstantiateFull (Open a) where
instantiateFull' (OpenThing n a) = OpenThing n <$> instantiateFull' a
+instance InstantiateFull a => InstantiateFull (Local a) where
+ instantiateFull' = traverseF instantiateFull'
+
instance InstantiateFull DisplayForm where
instantiateFull' (Display n ps v) = uncurry (Display n) <$> instantiateFull' (ps, v)
instance InstantiateFull DisplayTerm where
instantiateFull' (DTerm v) = DTerm <$> instantiateFull' v
instantiateFull' (DDot v) = DDot <$> instantiateFull' v
- instantiateFull' (DCon c vs) = DCon c <$> instantiateFull' vs
+ instantiateFull' (DCon c ci vs) = DCon c ci <$> instantiateFull' vs
instantiateFull' (DDef c es) = DDef c <$> instantiateFull' es
instantiateFull' (DWithApp v vs ws) = uncurry3 DWithApp <$> instantiateFull' (v, vs, ws)
instance InstantiateFull Defn where
instantiateFull' d = case d of
Axiom{} -> return d
+ AbstractDefn -> return d
Function{ funClauses = cs, funCompiled = cc, funInv = inv } -> do
(cs, cc, inv) <- instantiateFull' (cs, cc, inv)
return $ d { funClauses = cs, funCompiled = cc, funInv = inv }
@@ -1206,11 +1200,10 @@ instance InstantiateFull Defn where
s <- instantiateFull' s
cl <- instantiateFull' cl
return $ d { dataSort = s, dataClause = cl }
- Record{ recConType = t, recClause = cl, recTel = tel } -> do
- t <- instantiateFull' t
+ Record{ recClause = cl, recTel = tel } -> do
cl <- instantiateFull' cl
tel <- instantiateFull' tel
- return $ d { recConType = t, recClause = cl, recTel = tel }
+ return $ d { recClause = cl, recTel = tel }
Constructor{} -> return d
Primitive{ primClauses = cs } -> do
cs <- instantiateFull' cs
@@ -1268,7 +1261,8 @@ instance InstantiateFull a => InstantiateFull (Maybe a) where
instantiateFull' = mapM instantiateFull'
instance InstantiateFull Candidate where
- instantiateFull' (Candidate u t eti) = Candidate <$> instantiateFull' u <*> instantiateFull' t <*> return eti
+ instantiateFull' (Candidate u t eti ov) =
+ Candidate <$> instantiateFull' u <*> instantiateFull' t <*> pure eti <*> pure ov
instance InstantiateFull EqualityView where
instantiateFull' (OtherType t) = OtherType
diff --git a/src/full/Agda/TypeChecking/Reduce/Fast.hs b/src/full/Agda/TypeChecking/Reduce/Fast.hs
new file mode 100644
index 0000000..2a91287
--- /dev/null
+++ b/src/full/Agda/TypeChecking/Reduce/Fast.hs
@@ -0,0 +1,534 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BangPatterns #-}
+
+{-|
+
+This module contains an optimised implementation of the reduction algorithm
+from 'Agda.TypeChecking.Reduce' and 'Agda.TypeChecking.CompiledClause.Match'.
+It runs roughly an order of magnitude faster than the original implementation.
+
+The differences are the following:
+
+- Only applies when we don't have --sharing and when all reductions are
+ allowed.
+
+ This means we can skip a number of checks that would otherwise be performed
+ at each reduction step.
+
+- Does not track whether simplifications were made.
+
+ This information is only used when trying to simplify terms, so the
+ simplifier runs the slow implementation.
+
+- Precomputes primZero and primSuc.
+
+ Since all the functions involved in reduction are implemented in this module
+ in a single where block, we can look up zero and suc once instead of once for
+ each reduction step.
+
+- Run outside ReduceM
+
+ ReduceM is already just a plain reader monad, but pulling out the environment
+ and doing all reduction non-monadically saves a significant amount of time.
+
+- Memoise getConstInfo.
+
+ A big chunk of the time during reduction is spent looking up definitions in
+ the signature. Any long-running reduction will use only a handful definitions
+ though, so memoising getConstInfo is a big win.
+
+- Optimised case trees.
+
+ Since we memoise getConstInfo we can do some preprocessing of the
+ definitions, returning a 'CompactDef' instead of a 'Definition'. In
+ particular we streamline the case trees used for matching in a few ways:
+
+ - Drop constructor arity information.
+ - Use NameId instead of QName as map keys.
+ - Special branch for natural number successor.
+
+ None of these changes would make sense to incorporate into the actual case
+ trees. The first two loses information that we need in other places and the
+ third would complicate a lot of code working with case trees.
+
+- Optimised parallel substitution.
+
+ When substituting arguments into function bodies we always have a complete
+ (a term for every free variable) parallel substitution. We run an specialised
+ substitution for this case that falls back to normal substitution when it
+ hits a binder.
+
+-}
+module Agda.TypeChecking.Reduce.Fast
+ ( fastReduce ) where
+
+import Control.Applicative
+import Control.Monad.Reader
+
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Traversable (traverse)
+
+import System.IO.Unsafe
+import Data.IORef
+
+import Agda.Syntax.Internal
+import Agda.Syntax.Common
+import Agda.Syntax.Position
+import Agda.Syntax.Literal
+
+import Agda.TypeChecking.CompiledClause
+import Agda.TypeChecking.Monad
+import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Reduce as R
+import Agda.TypeChecking.Rewriting (rewrite)
+import Agda.TypeChecking.Reduce.Monad as RedM
+import Agda.TypeChecking.Substitute
+import Agda.TypeChecking.Monad.Builtin hiding (constructorForm)
+import Agda.TypeChecking.CompiledClause.Match
+
+import Agda.Interaction.Options
+
+import Agda.Utils.Maybe
+import Agda.Utils.Memo
+import Agda.Utils.Function
+import Agda.Utils.Functor
+
+#include "undefined.h"
+import Agda.Utils.Impossible
+
+-- Compact definitions ----------------------------------------------------
+
+-- This is what the memoised getConstInfo returns. We essentially pick out only the
+-- information needed for fast reduction from the definition.
+
+data CompactDef =
+ CompactDef { cdefDelayed :: Bool
+ , cdefNonterminating :: Bool
+ , cdefDef :: CompactDefn
+ , cdefRewriteRules :: RewriteRules
+ }
+
+data CompactDefn
+ = CFun { cfunCompiled :: FastCompiledClauses, cfunProjection :: Maybe QName }
+ | CCon { cconSrcCon :: ConHead }
+ | CForce -- ^ primForce
+ | CTyCon -- ^ Datatype or record type. Need to know this for primForce.
+ | COther -- ^ In this case we fall back to slow reduction
+
+compactDef :: Maybe ConHead -> Maybe ConHead -> Maybe QName -> Definition -> RewriteRules -> ReduceM CompactDef
+compactDef z s pf def rewr = do
+ cdefn <-
+ case theDef def of
+ _ | Just (defName def) == pf -> pure CForce
+ Constructor{conSrcCon = c} -> pure CCon{cconSrcCon = c}
+ Function{funCompiled = Just cc, funClauses = _:_, funProjection = proj} ->
+ pure CFun{ cfunCompiled = fastCompiledClauses z s cc
+ , cfunProjection = projOrig <$> proj }
+ Datatype{dataClause = Nothing} -> pure CTyCon
+ Record{recClause = Nothing} -> pure CTyCon
+ _ -> pure COther
+ return $
+ CompactDef { cdefDelayed = defDelayed def == Delayed
+ , cdefNonterminating = defNonterminating def
+ , cdefDef = cdefn
+ , cdefRewriteRules = rewr
+ }
+
+-- Faster case trees ------------------------------------------------------
+
+data FastCase c = FBranches
+ { fprojPatterns :: Bool
+ -- ^ We are constructing a record here (copatterns).
+ -- 'conBranches' lists projections.
+ , fconBranches :: Map NameId c
+ -- ^ Map from constructor (or projection) names to their arity
+ -- and the case subtree. (Projections have arity 0.)
+ , fsucBranch :: Maybe c
+ , flitBranches :: Map Literal c
+ -- ^ Map from literal to case subtree.
+ , fcatchAllBranch :: Maybe c
+ -- ^ (Possibly additional) catch-all clause.
+ }
+
+-- | Case tree with bodies.
+
+data FastCompiledClauses
+ = FCase Int (FastCase FastCompiledClauses)
+ -- ^ @Case n bs@ stands for a match on the @n@-th argument
+ -- (counting from zero) with @bs@ as the case branches.
+ -- If the @n@-th argument is a projection, we have only 'conBranches'
+ -- with arity 0.
+ | FDone [Arg ArgName] Term
+ -- ^ @Done xs b@ stands for the body @b@ where the @xs@ contains hiding
+ -- and name suggestions for the free variables. This is needed to build
+ -- lambdas on the right hand side for partial applications which can
+ -- still reduce.
+ | FFail
+ -- ^ Absurd case.
+
+type FastStack = [(FastCompiledClauses, MaybeReducedElims, Elims -> Elims)]
+
+fastCompiledClauses :: Maybe ConHead -> Maybe ConHead -> CompiledClauses -> FastCompiledClauses
+fastCompiledClauses z s cc =
+ case cc of
+ Fail -> FFail
+ Done xs b -> FDone xs b
+ Case (Arg _ n) bs -> FCase n (fastCase z s bs)
+
+fastCase :: Maybe ConHead -> Maybe ConHead -> Case CompiledClauses -> FastCase FastCompiledClauses
+fastCase z s (Branches proj con lit wild) =
+ FBranches
+ { fprojPatterns = proj
+ , fconBranches = Map.mapKeysMonotonic (nameId . qnameName) $ fmap (fastCompiledClauses z s . content) con
+ , fsucBranch = fmap (fastCompiledClauses z s . content) $ flip Map.lookup con . conName =<< s
+ , flitBranches = fmap (fastCompiledClauses z s) lit
+ , fcatchAllBranch = fmap (fastCompiledClauses z s) wild }
+
+{-# INLINE lookupCon #-}
+lookupCon :: QName -> FastCase c -> Maybe c
+lookupCon c (FBranches _ cons _ _ _) = Map.lookup (nameId $ qnameName c) cons
+
+-- QName memo -------------------------------------------------------------
+
+{-# NOINLINE memoQName #-}
+memoQName :: (QName -> a) -> (QName -> a)
+memoQName f = unsafePerformIO $ do
+ tbl <- newIORef Map.empty
+ return (unsafePerformIO . f' tbl)
+ where
+ f' tbl x = do
+ let i = nameId (qnameName x)
+ m <- readIORef tbl
+ case Map.lookup i m of
+ Just y -> return y
+ Nothing -> do
+ let y = f x
+ writeIORef tbl (Map.insert i y m)
+ return y
+
+-- Faster substitution ----------------------------------------------------
+
+-- Precondition: All free variables of the term are assigned values in the
+-- list.
+-- Reverts to normal substitution if it hits a binder or other icky stuff (like
+-- levels). It's strict in the shape of the result to avoid creating huge
+-- thunks for accumulator arguments.
+strictSubst :: Bool -> [Term] -> Term -> Term
+strictSubst strict us
+ | not strict = applySubst rho
+ | otherwise = go 0
+ where
+ rho = parallelS us
+ go k v =
+ case v of
+ Var x es
+ | x < k -> Var x $! map' (goE k) es
+ | otherwise -> applyE (raise k $ us !! (x - k)) $! map' (goE k) es
+ Def f es -> defApp f [] $! map' (goE k) es
+ Con c ci vs -> Con c ci $! map' (mapArg' $ go k) vs
+ Lam i b -> Lam i $! goAbs k b
+ Lit{} -> v
+ _ -> applySubst (liftS k rho) v
+
+ goE k (Apply v) = Apply $! mapArg' (go k) v
+ goE _ p = p
+
+ goAbs k (Abs x v) = Abs x $! go (k + 1) v
+ goAbs k (NoAbs x v) = NoAbs x $! go k v
+
+map' :: (a -> b) -> [a] -> [b]
+map' f [] = []
+map' f (x : xs) = ((:) $! f x) $! map' f xs
+
+mapArg' :: (a -> b) -> Arg a -> Arg b
+mapArg' f (Arg i x) = Arg i $! f x
+
+
+-- Fast reduction ---------------------------------------------------------
+
+-- | First argument: allow non-terminating reductions.
+fastReduce :: Bool -> Term -> ReduceM (Blocked Term)
+fastReduce allowNonTerminating v = do
+ let name (Con c _ _) = c
+ name _ = __IMPOSSIBLE__
+ z <- fmap name <$> getBuiltin' builtinZero
+ s <- fmap name <$> getBuiltin' builtinSuc
+ pf <- fmap primFunName <$> getPrimitive' "primForce"
+ rwr <- optRewriting <$> pragmaOptions
+ constInfo <- unKleisli $ \f -> do
+ info <- getConstInfo f
+ rewr <- getRewriteRulesFor f
+ compactDef z s pf info rewr
+ ReduceM $ \ env -> reduceTm env (memoQName constInfo) allowNonTerminating rwr z s v
+
+unKleisli :: (a -> ReduceM b) -> ReduceM (a -> b)
+unKleisli f = ReduceM $ \ env x -> unReduceM (f x) env
+
+reduceTm :: ReduceEnv -> (QName -> CompactDef) -> Bool -> Bool -> Maybe ConHead -> Maybe ConHead -> Term -> Blocked Term
+reduceTm env !constInfo allowNonTerminating hasRewriting zero suc = reduceB' 0
+ where
+ -- Force substitutions every nth step to avoid memory leaks. Doing it in
+ -- every is too expensive (issue 2215).
+ strictEveryNth = 1000
+
+ runReduce m = unReduceM m env
+ conNameId = nameId . qnameName . conName
+ isZero =
+ case zero of
+ Nothing -> const False
+ Just z -> (conNameId z ==) . conNameId
+
+ isSuc =
+ case suc of
+ Nothing -> const False
+ Just s -> (conNameId s ==) . conNameId
+
+ reduceB' steps v =
+ case v of
+ Def f es -> unfoldDefinitionE steps False reduceB' (Def f []) f es
+ Con c ci vs ->
+ -- Constructors can reduce' when they come from an
+ -- instantiated module.
+ case unfoldDefinition steps False reduceB' (Con c ci []) (conName c) vs of
+ NotBlocked r v -> NotBlocked r $ reduceNat v
+ b -> b
+ Lit{} -> done
+ Var{} -> done
+ _ -> runReduce (slowReduceTerm v)
+ where
+ done = notBlocked v
+
+ reduceNat v@(Con c ci [])
+ | isZero c = Lit $ LitNat (getRange c) 0
+ reduceNat v@(Con c ci [a])
+ | isSuc c = inc . ignoreBlocking $ reduceB' 0 (unArg a)
+ where
+ inc (Lit (LitNat r n)) = Lit (LitNat noRange $ n + 1)
+ inc w = Con c ci [defaultArg w]
+ reduceNat v = v
+
+ originalProjection :: QName -> QName
+ originalProjection q =
+ case cdefDef $ constInfo q of
+ CFun{ cfunProjection = Just p } -> p
+ _ -> __IMPOSSIBLE__
+
+ -- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion
+ -- need also to instantiate metas, see Issue 826.
+ unfoldCorecursionE :: Elim -> Blocked Elim
+ unfoldCorecursionE (Proj o p) = notBlocked $ Proj o $ originalProjection p
+ unfoldCorecursionE (Apply (Arg info v)) = fmap (Apply . Arg info) $
+ unfoldCorecursion 0 v
+
+ unfoldCorecursion :: Int -> Term -> Blocked Term
+ unfoldCorecursion steps (Def f es) = unfoldDefinitionE steps True unfoldCorecursion (Def f []) f es
+ unfoldCorecursion steps v = reduceB' steps v
+
+ -- | If the first argument is 'True', then a single delayed clause may
+ -- be unfolded.
+ unfoldDefinition ::
+ Int -> Bool -> (Int -> Term -> Blocked Term) ->
+ Term -> QName -> Args -> Blocked Term
+ unfoldDefinition steps unfoldDelayed keepGoing v f args =
+ unfoldDefinitionE steps unfoldDelayed keepGoing v f (map Apply args)
+
+ unfoldDefinitionE ::
+ Int -> Bool -> (Int -> Term -> Blocked Term) ->
+ Term -> QName -> Elims -> Blocked Term
+ unfoldDefinitionE steps unfoldDelayed keepGoing v f es =
+ case unfoldDefinitionStep steps unfoldDelayed (constInfo f) v f es of
+ NoReduction v -> v
+ YesReduction _ v -> (keepGoing $! steps + 1) v
+
+ unfoldDefinitionStep :: Int -> Bool -> CompactDef -> Term -> QName -> Elims -> Reduced (Blocked Term) Term
+ unfoldDefinitionStep steps unfoldDelayed CompactDef{cdefDelayed = delayed, cdefNonterminating = nonterm, cdefDef = def, cdefRewriteRules = rewr} v0 f es =
+ let v = v0 `applyE` es
+ -- Non-terminating functions
+ -- (i.e., those that failed the termination check)
+ -- and delayed definitions
+ -- are not unfolded unless explicitely permitted.
+ dontUnfold =
+ (not allowNonTerminating && nonterm)
+ || (not unfoldDelayed && delayed)
+ in case def of
+ CCon{cconSrcCon = c} ->
+ if hasRewriting then
+ runReduce $ rewrite (notBlocked ()) (Con c ConOSystem []) rewr es
+ else
+ NoReduction $ notBlocked $ Con c ConOSystem [] `applyE` es
+ CFun{cfunCompiled = cc} ->
+ reduceNormalE steps v0 f (map notReduced es) dontUnfold cc
+ CForce -> reduceForce unfoldDelayed v0 f es
+ CTyCon -> if hasRewriting then
+ runReduce $ rewrite (notBlocked ()) v0 rewr es
+ else
+ NoReduction $ notBlocked v
+ COther -> runReduce $ R.unfoldDefinitionStep unfoldDelayed v0 f es
+ where
+ yesReduction = YesReduction NoSimplification
+
+ reduceForce :: Bool -> Term -> QName -> Elims -> Reduced (Blocked Term) Term
+ reduceForce unfoldDelayed v0 pf (Apply a : Apply b : Apply s : Apply t : Apply u : Apply f : es) =
+ case reduceB' 0 (unArg u) of
+ ub@Blocked{} -> noGo ub
+ ub@(NotBlocked _ u)
+ | isWHNF u -> yesReduction $ unArg f `applyE` (Apply (defaultArg u) : es)
+ | otherwise -> noGo ub
+ where
+ noGo ub = NoReduction $ ub <&> \ u -> Def pf (Apply a : Apply b : Apply s : Apply t : Apply (defaultArg u) : Apply f : es)
+
+ isWHNF u = case u of
+ Lit{} -> True
+ Con{} -> True
+ Lam{} -> True
+ Pi{} -> True
+ Sort{} -> True
+ Level{} -> True
+ DontCare{} -> True
+ MetaV{} -> False
+ Var{} -> False
+ Def q _ -> isTyCon q
+ Shared{} -> __IMPOSSIBLE__
+
+ isTyCon q =
+ case cdefDef $ constInfo q of
+ CTyCon -> True
+ _ -> False
+
+ -- TODO: partially applied to u
+ reduceForce unfoldDelayed v0 pf es = runReduce $ R.unfoldDefinitionStep unfoldDelayed v0 f es
+
+ reduceNormalE :: Int -> Term -> QName -> [MaybeReduced Elim] -> Bool -> FastCompiledClauses -> Reduced (Blocked Term) Term
+ reduceNormalE steps v0 f es dontUnfold cc
+ | dontUnfold = defaultResult -- non-terminating or delayed
+ | otherwise =
+ case match' steps f [(cc, es, id)] of
+ YesReduction s u -> YesReduction s u
+ NoReduction es' -> if hasRewriting then
+ runReduce $ rewrite (void es') v0 rewr (ignoreBlocking es')
+ else
+ NoReduction $ applyE v0 <$> es'
+ where defaultResult = if hasRewriting then
+ runReduce $ rewrite (NotBlocked AbsurdMatch ()) v0 rewr (map ignoreReduced es)
+ else
+ NoReduction $ NotBlocked AbsurdMatch vfull
+ vfull = v0 `applyE` map ignoreReduced es
+
+ match' :: Int -> QName -> FastStack -> Reduced (Blocked Elims) Term
+ match' steps f ((c, es, patch) : stack) =
+ let no blocking es = NoReduction $ blocking $ patch $ map ignoreReduced es
+ yes t = yesReduction t
+
+ in case c of
+
+ -- impossible case
+ FFail -> no (NotBlocked AbsurdMatch) es
+
+ -- done matching
+ FDone xs t
+ -- common case: exact number of arguments
+ | m == n -> {-# SCC match'Done #-} yes $ doSubst es t
+ -- if the function was partially applied, return a lambda
+ | m < n -> yes $ doSubst es $ foldr lam t (drop m xs)
+ -- otherwise, just apply instantiation to body
+ -- apply the result to any extra arguments
+ | otherwise -> yes $ doSubst es0 t `applyE` map ignoreReduced es1
+ where
+ n = length xs
+ m = length es
+ useStrictSubst = rem steps strictEveryNth == 0
+ doSubst es t = strictSubst useStrictSubst (reverse $ map (unArg . argFromElim . ignoreReduced) es) t
+ (es0, es1) = splitAt n es
+ lam x t = Lam (argInfo x) (Abs (unArg x) t)
+
+ -- splitting on the @n@th elimination
+ FCase n bs -> {-# SCC "match'Case" #-}
+ case splitAt n es of
+ -- if the @n@th elimination is not supplied, no match
+ (_, []) -> no (NotBlocked Underapplied) es
+ -- if the @n@th elimination is @e0@
+ (es0, MaybeRed red e0 : es1) ->
+ -- get the reduced form of @e0@
+ let eb = case red of
+ Reduced b -> e0 <$ b
+ NotReduced -> unfoldCorecursionE e0
+ e = ignoreBlocking eb
+ -- replace the @n@th argument by its reduced form
+ es' = es0 ++ [MaybeRed (Reduced $ () <$ eb) e] ++ es1
+ -- if a catch-all clause exists, put it on the stack
+ catchAllFrame stack = maybe stack (\c -> (c, es', patch) : stack) (fcatchAllBranch bs)
+ -- If our argument is @Lit l@, we push @litFrame l@ onto the stack.
+ litFrame l stack =
+ case Map.lookup l (flitBranches bs) of
+ Nothing -> stack
+ Just cc -> (cc, es0 ++ es1, patchLit) : stack
+ -- If our argument (or its constructor form) is @Con c ci vs@
+ -- we push @conFrame c ci vs@ onto the stack.
+ conFrame c ci vs stack =
+ case lookupCon (conName c) bs of
+ Nothing -> stack
+ Just cc -> ( cc
+ , es0 ++ map (MaybeRed NotReduced . Apply) vs ++ es1
+ , patchCon c ci (length vs)
+ ) : stack
+
+ sucFrame n stack =
+ case fsucBranch bs of
+ Nothing -> stack
+ Just cc -> (cc, es0 ++ [v] ++ es1, patchCon (fromJust suc) ConOSystem 1)
+ : stack
+ where v = MaybeRed (Reduced $ notBlocked ()) $ Apply $ defaultArg $ Lit $ LitNat noRange n
+
+ -- If our argument is @Proj p@, we push @projFrame p@ onto the stack.
+ projFrame p stack =
+ case lookupCon p bs of
+ Nothing -> stack
+ Just cc -> (cc, es0 ++ es1, patchLit) : stack
+ -- The new patch function restores the @n@th argument to @v@:
+ -- In case we matched a literal, just put @v@ back.
+ patchLit es = patch (es0 ++ [e] ++ es1)
+ where (es0, es1) = splitAt n es
+ -- In case we matched constructor @c@ with @m@ arguments,
+ -- contract these @m@ arguments @vs@ to @Con c ci vs@.
+ patchCon c ci m es = patch (es0 ++ [Con c ci vs <$ e] ++ es2)
+ where (es0, rest) = splitAt n es
+ (es1, es2) = splitAt m rest
+ vs = map argFromElim es1
+ -- Now do the matching on the @n@ths argument:
+ in case eb of
+ Blocked x _ -> no (Blocked x) es'
+ NotBlocked blk elim ->
+ case elim of
+ Apply (Arg info v) ->
+ case v of
+ MetaV x _ -> no (Blocked x) es'
+
+ -- In case of a natural number literal, try also its constructor form
+ Lit l@(LitNat r n) ->
+ let cFrame stack
+ | n > 0 = sucFrame (n - 1) stack
+ | n == 0, Just z <- zero = conFrame z ConOSystem [] stack
+ | otherwise = stack
+ in match' steps f $ litFrame l $ cFrame $ catchAllFrame stack
+
+ Lit l -> match' steps f $ litFrame l $ catchAllFrame stack
+ Con c ci vs -> match' steps f $ conFrame c ci vs $ catchAllFrame $ stack
+
+ -- Otherwise, we are stuck. If we were stuck before,
+ -- we keep the old reason, otherwise we give reason StuckOn here.
+ _ -> no (NotBlocked $ stuckOn elim blk) es'
+
+ -- In case of a projection, push the projFrame
+ Proj _ p -> match' steps f $ projFrame p stack
+
+
+ -- If we reach the empty stack, then pattern matching was incomplete
+ match' _ f [] = {- new line here since __IMPOSSIBLE__ does not like the ' in match' -}
+ runReduce $
+ traceSLn "impossible" 10
+ ("Incomplete pattern matching when applying " ++ show f)
+ __IMPOSSIBLE__
diff --git a/src/full/Agda/TypeChecking/Reduce/Fast.hs-boot b/src/full/Agda/TypeChecking/Reduce/Fast.hs-boot
new file mode 100644
index 0000000..94e6061
--- /dev/null
+++ b/src/full/Agda/TypeChecking/Reduce/Fast.hs-boot
@@ -0,0 +1,8 @@
+
+module Agda.TypeChecking.Reduce.Fast where
+
+import Agda.Syntax.Internal
+import Agda.TypeChecking.Monad.Base
+
+fastReduce :: Bool -> Term -> ReduceM (Blocked Term)
+
diff --git a/src/full/Agda/TypeChecking/Reduce/Monad.hs b/src/full/Agda/TypeChecking/Reduce/Monad.hs
index b348ee1..7cdca08 100644
--- a/src/full/Agda/TypeChecking/Reduce/Monad.hs
+++ b/src/full/Agda/TypeChecking/Reduce/Monad.hs
@@ -1,7 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -12,7 +9,6 @@ module Agda.TypeChecking.Reduce.Monad
, getConstInfo
, isInstantiatedMeta
, lookupMeta
- , reportSDoc, reportSLn
, traceSLn, traceSDoc
, askR, applyWhenVerboseS
) where
@@ -79,10 +75,12 @@ constructorForm v = do
return $ fromMaybe v $ constructorForm' mz ms v
enterClosure :: Closure a -> (a -> ReduceM b) -> ReduceM b
-enterClosure (Closure sig env scope x) f = localR (mapRedEnvSt inEnv inState) (f x)
+enterClosure (Closure sig env scope pars x) f = localR (mapRedEnvSt inEnv inState) (f x)
where
inEnv e = env { envAllowDestructiveUpdate = envAllowDestructiveUpdate e }
- inState s = set stScope scope s -- TODO: use the signature here? would that fix parts of issue 118?
+ inState s =
+ -- TODO: use the signature here? would that fix parts of issue 118?
+ set stScope scope $ set stModuleParameters pars s
withFreshR :: HasFresh i => (i -> ReduceM a) -> ReduceM a
withFreshR f = do
@@ -127,7 +125,6 @@ isInstantiatedMeta i = do
mv <- lookupMeta i
return $ case mvInstantiation mv of
InstV{} -> True
- InstS{} -> True
_ -> False
-- | Run a computation if a certain verbosity level is activated.
@@ -136,12 +133,6 @@ isInstantiatedMeta i = do
verboseS :: VerboseKey -> Int -> ReduceM () -> ReduceM ()
verboseS k n action = whenM (hasVerbosity k n) action
-reportSDoc :: VerboseKey -> Int -> TCM Doc -> ReduceM ()
-reportSDoc k n doc = return () -- Cannot implement this!
-
-reportSLn :: VerboseKey -> Int -> String -> ReduceM ()
-reportSLn k n s = return () -- Cannot implement this!
-
-- | Apply a function if a certain verbosity level is activated.
--
-- Precondition: The level must be non-negative.
diff --git a/src/full/Agda/TypeChecking/Rewriting.hs b/src/full/Agda/TypeChecking/Rewriting.hs
index ae019cf..eb83dbe 100644
--- a/src/full/Agda/TypeChecking/Rewriting.hs
+++ b/src/full/Agda/TypeChecking/Rewriting.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Rewriting with arbitrary rules.
--
@@ -47,7 +47,7 @@ import Prelude hiding (null)
import Control.Applicative hiding (empty)
import Control.Monad
-import Control.Monad.Reader (local)
+import Control.Monad.Reader (local, asks)
import Data.Foldable ( Foldable, foldMap )
import Data.IntSet (IntSet)
@@ -64,6 +64,7 @@ import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.EtaContract
import Agda.TypeChecking.Free
+import Agda.TypeChecking.Free.Lazy
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Conversion
import Agda.TypeChecking.Pretty
@@ -74,11 +75,16 @@ import Agda.TypeChecking.Rewriting.NonLinMatch
import qualified Agda.TypeChecking.Reduce.Monad as Red
import Agda.Utils.Functor
+import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.Lens
+import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Singleton
import Agda.Utils.Size
+import Agda.Utils.Lens
+import qualified Agda.Utils.HashMap as HMap
#include "undefined.h"
import Agda.Utils.Impossible
@@ -89,7 +95,7 @@ requireOptionRewriting =
-- | Check that the name given to the BUILTIN REWRITE is actually
-- a relation symbol.
--- I.e., its type should be of the form @Δ → (lhs rhs : A) → Set ℓ@.
+-- I.e., its type should be of the form @Δ → (lhs : A) (rhs : B) → Set ℓ@.
-- Note: we do not care about hiding/non-hiding of lhs and rhs.
verifyBuiltinRewrite :: Term -> Type -> TCM ()
verifyBuiltinRewrite v t = do
@@ -101,13 +107,9 @@ verifyBuiltinRewrite v t = do
caseMaybeM (relView t)
(failure $ text "because it should accept at least two arguments") $
\ (RelView tel delta a b core) -> do
+ unless (visible a && visible b) $ failure $ text "because its two final arguments are not both visible."
case ignoreSharing (unEl core) of
- Sort{} -> do
- -- Check that the types of the last two arguments are equal.
- unlessM (tryConversion $
- inTopContext $ addContext tel $ escapeContext 1 $
- equalType (raise 1 a) b) $
- failure $ text $ "because the types of the last two arguments are different"
+ Sort{} -> return ()
Con{} -> __IMPOSSIBLE__
Level{} -> __IMPOSSIBLE__
Lam{} -> __IMPOSSIBLE__
@@ -120,8 +122,8 @@ verifyBuiltinRewrite v t = do
data RelView = RelView
{ relViewTel :: Telescope -- ^ The whole telescope @Δ, t, t'@.
, relViewDelta :: ListTel -- ^ @Δ@.
- , relViewType :: Type -- ^ @t@.
- , relViewType' :: Type -- ^ @t'@.
+ , relViewType :: Dom Type -- ^ @t@.
+ , relViewType' :: Dom Type -- ^ @t'@.
, relViewCore :: Type -- ^ @core@.
}
@@ -133,7 +135,7 @@ relView t = do
let n = size tel
(delta, lastTwo) = splitAt (n - 2) $ telToList tel
if size lastTwo < 2 then return Nothing else do
- let [a, b] = snd . unDom <$> lastTwo
+ let [a, b] = fmap snd <$> lastTwo
return $ Just $ RelView tel delta a b core
-- | Add @q : Γ → rel us lhs rhs@ as rewrite rule
@@ -178,8 +180,6 @@ addRewriteRule q = do
[ prettyTCM q , text " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ]
let failureFreeVars xs = typeError . GenericDocError =<< hsep
[ prettyTCM q , text " is not a legal rewrite rule, since the following variables are not bound by the left hand side: " , prettyList_ (map (prettyTCM . var) $ IntSet.toList xs) ]
- let failureLhsReduction lhs = typeError . GenericDocError =<< hsep
- [ prettyTCM q , text " is not a legal rewrite rule, since the left-hand side " , prettyTCM lhs , text " has top-level reductions" ]
let failureIllegalRule = typeError . GenericDocError =<< hsep
[ prettyTCM q , text " is not a legal rewrite rule" ]
@@ -198,28 +198,44 @@ addRewriteRule q = do
gamma1 <- instantiateFull gamma1
let gamma = gamma0 `abstract` gamma1
- unless (null $ allMetas (telToList gamma1)) failureMetas
+ unless (null $ allMetas (telToList gamma1)) $ do
+ reportSDoc "rewriting" 30 $ text "metas in gamma1: " <+> text (show $ allMetas $ telToList gamma1)
+ failureMetas
- -- Find head symbol f of the lhs.
- f <- case ignoreSharing lhs of
- Def f es -> return f
- Con c vs -> return $ conName c
+ -- Find head symbol f of the lhs and its arguments.
+ (f , hd , es) <- case ignoreSharing lhs of
+ Def f es -> return (f , Def f , es)
+ Con c ci vs -> do
+ let hd = Con c ci . fromMaybe __IMPOSSIBLE__ . allApplyElims
+ return (conName c , hd , map Apply vs)
_ -> failureNotDefOrCon
rew <- addContext gamma1 $ do
- -- Normalize lhs: we do not want to match redexes.
- lhs <- normaliseArgs lhs
- unlessM (isNormal lhs) $ failureLhsReduction lhs
+ -- Normalize lhs args: we do not want to match redexes.
+ es <- etaContract =<< normalise es
+ checkNoLhsReduction f (hd es)
-- Normalize rhs: might be more efficient.
rhs <- etaContract =<< normalise rhs
- unless (null $ allMetas (lhs, rhs, b)) failureMetas
- pat <- patternFrom 0 lhs
+ unless (null $ allMetas (es, rhs, b)) $ do
+ reportSDoc "rewriting" 30 $ text "metas in lhs: " <+> text (show $ allMetas es)
+ reportSDoc "rewriting" 30 $ text "metas in rhs: " <+> text (show $ allMetas rhs)
+ reportSDoc "rewriting" 30 $ text "metas in b : " <+> text (show $ allMetas b)
+ failureMetas
+ ps <- patternFrom Relevant 0 es
+ reportSDoc "rewriting" 30 $
+ text "Pattern generated from lhs: " <+> prettyTCM (PDef f ps)
-- check that FV(rhs) ⊆ nlPatVars(lhs)
- unlessNull (allFreeVars rhs IntSet.\\ nlPatVars pat) failureFreeVars
+ let freeVars = usedArgs gamma1 `IntSet.union` allFreeVars (ps,rhs)
+ boundVars = nlPatVars ps
+ reportSDoc "rewriting" 40 $
+ text "variables bound by the pattern: " <+> text (show boundVars)
+ reportSDoc "rewriting" 40 $
+ text "variables free in the rewrite rule: " <+> text (show freeVars)
+ unlessNull (freeVars IntSet.\\ boundVars) failureFreeVars
- return $ RewriteRule q gamma pat rhs b
+ return $ RewriteRule q gamma f ps rhs (unDom b)
reportSDoc "rewriting" 10 $
text "considering rewrite rule " <+> prettyTCM rew
@@ -238,43 +254,83 @@ addRewriteRule q = do
_ -> failureWrongTarget
where
- normaliseArgs :: Term -> TCM Term
- normaliseArgs v = case ignoreSharing v of
- Def f es -> Def f <$> do etaContract =<< normalise es
- Con c vs -> Con c <$> do etaContract =<< normalise vs
- _ -> __IMPOSSIBLE__
-
- isNormal :: Term -> TCM Bool
- isNormal v = do
+ checkNoLhsReduction :: QName -> Term -> TCM ()
+ checkNoLhsReduction f v = do
v' <- normalise v
- return $ v == v'
+ unless (v == v') $ do
+ reportSDoc "rewriting" 20 $ text "v = " <+> text (show v)
+ reportSDoc "rewriting" 20 $ text "v' = " <+> text (show v')
+ -- Andreas, 2016-06-01, issue 1997
+ -- A reason for a reduction of the lhs could be that
+ -- the rewrite rule has already been added.
+ -- In this case, we want a nicer error message.
+ checkNotAlreadyAdded f
+ typeError . GenericDocError =<< fsep
+ [ prettyTCM q <+> text " is not a legal rewrite rule, since the left-hand side "
+ , prettyTCM v <+> text " reduces to " <+> prettyTCM v' ]
+
+ checkNotAlreadyAdded :: QName -> TCM ()
+ checkNotAlreadyAdded f = do
+ rews <- getRewriteRulesFor f
+ -- check if q is already an added rewrite rule
+ when (any ((q ==) . rewName) rews) $
+ typeError . GenericDocError =<< do
+ text "Rewrite rule " <+> prettyTCM q <+> text " has already been added"
+
+ usedArgs :: Telescope -> IntSet
+ usedArgs tel = IntSet.fromList $ map unDom $ usedIxs
+ where
+ n = size tel
+ allIxs = zipWith ($>) (flattenTel tel) (downFrom n)
+ usedIxs = filter (not . unused . getRelevance) allIxs
+ unused UnusedArg{} = True
+ unused _ = False
-- | Append rewrite rules to a definition.
addRewriteRules :: QName -> RewriteRules -> TCM ()
addRewriteRules f rews = do
reportSDoc "rewriting" 10 $ text "rewrite rule ok, adding it to the definition of " <+> prettyTCM f
- modifySignature $ addRewriteRulesFor f rews
+ let matchables = getMatchables rews
+ reportSDoc "rewriting" 30 $ text "matchable symbols: " <+> prettyTCM matchables
+ modifySignature $ addRewriteRulesFor f rews matchables
--rules <- getRewriteRulesFor f
--reportSDoc "rewriting" 20 $ vcat
-- [ text "rewrite rules for " <+> prettyTCM f <+> text ":"
-- , vcat (map prettyTCM rules)
-- ]
--- | @rewriteWith t v rew@
--- tries to rewrite @v : t@ with @rew@, returning the reduct if successful.
-rewriteWith :: Maybe Type -> Term -> RewriteRule -> ReduceM (Either (Blocked Term) Term)
-rewriteWith mt v rew@(RewriteRule q gamma lhs rhs b) = do
+-- | Sledgehammer approach to local rewrite rules. Rebind them after each
+-- left-hand side (which scrambles the context).
+rebindLocalRewriteRules :: TCM ()
+rebindLocalRewriteRules = do
+ current <- currentModule
+ ruleMap <- use $ stSignature . sigRewriteRules
+ let isLocal r = m == current || m `isSubModuleOf` current
+ where m = qnameModule $ rewName r
+ ruleMap' = HMap.map (filter (not . isLocal)) ruleMap
+ locals = map rewName $ filter isLocal $ concat $ map reverse $ HMap.elems ruleMap
+ stSignature . sigRewriteRules .= ruleMap'
+ mapM_ addRewriteRule locals
+
+-- | @rewriteWith t f es rew@
+-- tries to rewrite @f es : t@ with @rew@, returning the reduct if successful.
+rewriteWith :: Maybe Type
+ -> Term
+ -> RewriteRule
+ -> Elims
+ -> ReduceM (Either (Blocked Term) Term)
+rewriteWith mt v rew@(RewriteRule q gamma _ ps rhs b) es = do
Red.traceSDoc "rewriting" 75 (sep
- [ text "attempting to rewrite term " <+> prettyTCM v
+ [ text "attempting to rewrite term " <+> prettyTCM (v `applyE` es)
, text " with rule " <+> prettyTCM rew
]) $ do
- result <- nonLinMatch gamma lhs v
+ result <- nonLinMatch gamma ps es
case result of
- Left block -> return $ Left $ const v <$> block
+ Left block -> return $ Left $ block $> v `applyE` es -- TODO: remember reductions
Right sub -> do
let v' = applySubst sub rhs
Red.traceSDoc "rewriting" 70 (sep
- [ text "rewrote " <+> prettyTCM v
+ [ text "rewrote " <+> prettyTCM (v `applyE` es)
, text " to " <+> prettyTCM v'
]) $ return $ Right v'
@@ -304,38 +360,28 @@ rewriteWith mt v rew@(RewriteRule q gamma lhs rhs b) = do
unfreezeMetas' (`elem` ms)
return res-}
--- | @rewrite t@ tries to rewrite a reduced term.
-rewrite :: Blocked Term -> ReduceM (Either (Blocked Term) Term)
-rewrite bv = ifNotM (optRewriting <$> pragmaOptions) (return $ Left bv) $ {- else -} do
- let v = ignoreBlocking bv
- case ignoreSharing v of
- -- We only rewrite @Def@s and @Con@s.
- Def f es -> rew f (Def f) es
- Con c vs -> rew (conName c) hd (Apply <$> vs)
- where hd es = Con c $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- _ -> return $ Left bv
+-- | @rewrite b v rules es@ tries to rewrite @v@ applied to @es@ with the
+-- rewrite rules @rules@. @b@ is the default blocking tag.
+rewrite :: Blocked_ -> Term -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)
+rewrite block v rules es = do
+ rewritingAllowed <- optRewriting <$> pragmaOptions
+ if (rewritingAllowed && not (null rules)) then
+ loop block rules =<< instantiateFull' es
+ else
+ return $ NoReduction (block $> v `applyE` es)
where
- -- Try all rewrite rules for f.
- rew :: QName -> (Elims -> Term) -> Elims -> ReduceM (Either (Blocked Term) Term)
- rew f hd es = do
- rules <- getRewriteRulesFor f
- case rules of
- [] -> return $ Left $ bv $> hd es
- _ -> do
- es <- instantiateFull' es
- loop (void bv) es rules
- where
- loop :: Blocked_ -> Elims -> RewriteRules -> ReduceM (Either (Blocked Term) Term)
- loop block es [] = return $ Left $ block $> hd es
- loop block es (rew:rews)
- | let n = rewArity rew, length es >= n = do
- let (es1, es2) = List.genericSplitAt n es
- result <- rewriteWith Nothing (hd es1) rew
- case result of
- Left (Blocked m u) -> loop (block `mappend` Blocked m ()) es rews
- Left (NotBlocked _ _) -> loop block es rews
- Right w -> return $ Right $ w `applyE` es2
- | otherwise = loop (block `mappend` NotBlocked Underapplied ()) es rews
+ loop :: Blocked_ -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)
+ loop block [] es = return $ NoReduction $ block $> v `applyE` es
+ loop block (rew:rews) es
+ | let n = rewArity rew, length es >= n = do
+ let (es1, es2) = List.genericSplitAt n es
+ result <- rewriteWith Nothing v rew es1
+ case result of
+ Left (Blocked m u) -> loop (block `mappend` Blocked m ()) rews es
+ Left (NotBlocked _ _) -> loop block rews es
+ Right w -> return $ YesReduction YesSimplification $ w `applyE` es2
+ | otherwise = loop (block `mappend` NotBlocked Underapplied ()) rews es
+
------------------------------------------------------------------------
-- * Auxiliary functions
@@ -347,10 +393,13 @@ class NLPatVars a where
instance (Foldable f, NLPatVars a) => NLPatVars (f a) where
nlPatVars = foldMap nlPatVars
+instance NLPatVars NLPType where
+ nlPatVars (NLPType l a) = nlPatVars l `IntSet.union` nlPatVars a
+
instance NLPatVars NLPat where
nlPatVars p =
case p of
- PVar _ i -> singleton i
+ PVar _ i _ -> singleton i
PDef _ es -> nlPatVars es
PWild -> empty
PLam _ p' -> nlPatVars $ unAbs p'
@@ -359,9 +408,7 @@ instance NLPatVars NLPat where
PTerm{} -> empty
rewArity :: RewriteRule -> Int
-rewArity rew = case rewLHS rew of
- PDef _f es -> length es
- _ -> __IMPOSSIBLE__
+rewArity = length . rewPats
-- | Erase the CtxId's of rewrite rules
class KillCtxId a where
@@ -371,14 +418,55 @@ instance (Functor f, KillCtxId a) => KillCtxId (f a) where
killCtxId = fmap killCtxId
instance KillCtxId RewriteRule where
- killCtxId rule@RewriteRule{ rewLHS = lhs } = rule{ rewLHS = killCtxId lhs }
+ killCtxId rule@RewriteRule{ rewPats = ps } = rule{ rewPats = killCtxId ps }
+
+instance KillCtxId NLPType where
+ killCtxId (NLPType l a) = NLPType (killCtxId l) (killCtxId a)
instance KillCtxId NLPat where
killCtxId p = case p of
- PVar _ i -> PVar Nothing i
+ PVar _ i bvs -> PVar Nothing i bvs
PWild -> p
PDef f es -> PDef f $ killCtxId es
PLam i x -> PLam i $ killCtxId x
PPi a b -> PPi (killCtxId a) (killCtxId b)
PBoundVar i es -> PBoundVar i $ killCtxId es
PTerm _ -> p
+
+-- | Get all symbols that a rewrite rule matches against
+class GetMatchables a where
+ getMatchables :: a -> [QName]
+
+instance (Foldable f, GetMatchables a) => GetMatchables (f a) where
+ getMatchables = foldMap getMatchables
+
+instance GetMatchables NLPat where
+ getMatchables p =
+ case p of
+ PVar _ _ _ -> empty
+ PWild -> empty
+ PDef f _ -> singleton f
+ PLam _ x -> empty
+ PPi a b -> empty
+ PBoundVar i es -> empty
+ PTerm _ -> empty -- should be safe (I hope)
+
+instance GetMatchables RewriteRule where
+ getMatchables = getMatchables . rewPats
+
+-- Only computes free variables that are not bound (i.e. those in a PTerm)
+instance Free' NLPat c where
+ freeVars' p = case p of
+ PVar _ _ _ -> mempty
+ PWild -> mempty
+ PDef _ es -> freeVars' es
+ PLam _ u -> freeVars' u
+ PPi a b -> freeVars' (a,b)
+ PBoundVar _ es -> freeVars' es
+ PTerm t -> freeVars' t
+
+instance Free' NLPType c where
+ freeVars' (NLPType l a) =
+ ifM ((IgnoreNot ==) <$> asks feIgnoreSorts)
+ {- then -} (freeVars' (l, a))
+ {- else -} (freeVars' a)
diff --git a/src/full/Agda/TypeChecking/Rewriting.hs-boot b/src/full/Agda/TypeChecking/Rewriting.hs-boot
index 3ccbfed..26e9827 100644
--- a/src/full/Agda/TypeChecking/Rewriting.hs-boot
+++ b/src/full/Agda/TypeChecking/Rewriting.hs-boot
@@ -4,4 +4,4 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.Monad.Base
verifyBuiltinRewrite :: Term -> Type -> TCM ()
-rewrite :: Blocked Term -> ReduceM (Either (Blocked Term) Term)
+rewrite :: Blocked_ -> Term -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)
diff --git a/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs b/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs
index bc76d4b..6d37ead 100644
--- a/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs
+++ b/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs
@@ -1,9 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE UndecidableInstances #-}
{- | Non-linear matching of the lhs of a rewrite rule against a
neutral term.
@@ -38,13 +35,13 @@ import Data.Foldable ( foldMap )
#endif
import Data.Maybe
-import Data.Functor
-import Data.Traversable hiding (for)
+import Data.Traversable (Traversable,traverse)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List (elemIndex)
+import Data.Monoid
import Agda.Syntax.Common
import qualified Agda.Syntax.Common as C
@@ -52,18 +49,25 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.EtaContract
import Agda.TypeChecking.Free
+import Agda.TypeChecking.Level (levelView', unLevel, reallyUnLevelView, subLevel)
import Agda.TypeChecking.Monad
+import Agda.TypeChecking.Monad.Builtin (primLevelSuc, primLevelMax)
import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Records (isRecordConstructor)
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Reduce.Monad
import Agda.TypeChecking.Substitute
+import Agda.TypeChecking.Telescope (permuteTel)
import Agda.Utils.Either
import Agda.Utils.Except
import Agda.Utils.Functor
+import Agda.Utils.Lens
+import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
+import Agda.Utils.Permutation
import Agda.Utils.Singleton
import Agda.Utils.Size
@@ -72,60 +76,119 @@ import Agda.Utils.Impossible
-- | Turn a term into a non-linear pattern, treating the
-- free variables as pattern variables.
--- The first argument is the number of bound variables (from pattern lambdas).
+-- The first argument indicates the relevance we are working under: if this
+-- is Irrelevant, then we construct a pattern that never fails to match.
+-- The second argument is the number of bound variables (from pattern lambdas).
class PatternFrom a b where
- patternFrom :: Int -> a -> TCM b
+ patternFrom :: Relevance -> Int -> a -> TCM b
instance (PatternFrom a b) => PatternFrom [a] [b] where
- patternFrom k = traverse $ patternFrom k
+ patternFrom r k = traverse $ patternFrom r k
instance (PatternFrom a b) => PatternFrom (Arg a) (Arg b) where
- patternFrom k = traverse $ patternFrom k
+ patternFrom r k u = let r' = r `composeRelevance` getRelevance u
+ in traverse (patternFrom r' k) u
-instance (PatternFrom a b) => PatternFrom (Elim' a) (Elim' b) where
- patternFrom k = traverse $ patternFrom k
+instance (PatternFrom a NLPat) => PatternFrom (Elim' a) (Elim' NLPat) where
+ patternFrom r k (Apply u) = let r' = r `composeRelevance` getRelevance u
+ in Apply <$> traverse (patternFrom r' k) u
+ patternFrom r k (Proj o f) = return $ Proj o f
instance (PatternFrom a b) => PatternFrom (Dom a) (Dom b) where
- patternFrom k = traverse $ patternFrom k
-
-instance (PatternFrom a b) => PatternFrom (Type' a) (Type' b) where
- patternFrom k = traverse $ patternFrom k
+ patternFrom r k = traverse $ patternFrom r k
+
+instance PatternFrom Type NLPType where
+ patternFrom r k a = NLPType <$> patternFrom r k (getSort a)
+ <*> patternFrom r k (unEl a)
+
+instance PatternFrom Sort NLPat where
+ patternFrom r k s = do
+ s <- reduce s
+ let done = return PWild
+ case s of
+ Type l -> patternFrom Irrelevant k (Level l)
+ Prop -> done
+ Inf -> done
+ SizeUniv -> done
+ DLub _ _ -> done
instance PatternFrom Term NLPat where
- patternFrom k v = do
- v <- reduce v
- let done = return $ PTerm v
+ patternFrom r k v = do
+ v <- unLevel =<< reduce v
+ let done = if isIrrelevant r then
+ return PWild
+ else
+ return $ PTerm v
case ignoreSharing v of
Var i es
- | i < k -> PBoundVar i <$> patternFrom k es
- | null es -> do
- let i' = i-k
- -- Pattern variables are labeled with their context id, because they
- -- can only be instantiated once they're no longer bound by the
- -- context (see Issue 1652).
- id <- (!! i') <$> getContextId
- return $ PVar (Just id) i'
- | otherwise -> done
- Lam i t -> PLam i <$> patternFrom k t
+ | i < k -> PBoundVar i <$> patternFrom r k es
+ | otherwise -> do
+ -- The arguments of `var i` should be distinct bound variables
+ -- in order to build a Miller pattern
+ let mbvs = mfilter fastDistinct $ forM es $ \e -> do
+ e <- isApplyElim e
+ case ignoreSharing $ unArg e of
+ Var j [] | j < k -> Just $ e $> j
+ _ -> Nothing
+ case mbvs of
+ Just bvs -> do
+ let i' = i-k
+ allBoundVars = IntSet.fromList (downFrom k)
+ ok = not (isIrrelevant r) ||
+ IntSet.fromList (map unArg bvs) == allBoundVars
+ -- Pattern variables are labeled with their context id, because they
+ -- can only be instantiated once they're no longer bound by the
+ -- context (see Issue 1652).
+ id <- (!! i') <$> getContextId
+ if ok then return (PVar (Just id) i' bvs) else done
+ Nothing -> done
+ Lam i t -> PLam i <$> patternFrom r k t
Lit{} -> done
- Def f es -> PDef f <$> patternFrom k es
- Con c vs -> PDef (conName c) <$> patternFrom k (Apply <$> vs)
- Pi a b -> PPi <$> patternFrom k a <*> patternFrom k b
- Sort{} -> done
- Level{} -> return PWild -- TODO: unLevel and continue
+ Def f es | isIrrelevant r -> done
+ Def f es -> do
+ Def lsuc [] <- ignoreSharing <$> primLevelSuc
+ Def lmax [] <- ignoreSharing <$> primLevelMax
+ case es of
+ [x] | f == lsuc -> done
+ [x , y] | f == lmax -> done
+ _ -> PDef f <$> patternFrom r k es
+ Con c ci vs | isIrrelevant r -> do
+ mr <- isRecordConstructor (conName c)
+ case mr of
+ Just (_, def) | recEtaEquality def ->
+ PDef (conName c) <$> patternFrom r k (Apply <$> vs)
+ _ -> done
+ Con c ci vs -> PDef (conName c) <$> patternFrom r k (Apply <$> vs)
+ Pi a b | isIrrelevant r -> done
+ Pi a b -> PPi <$> patternFrom r k a <*> patternFrom r k b
+ Sort s -> done
+ Level l -> __IMPOSSIBLE__
DontCare{} -> return PWild
MetaV{} -> __IMPOSSIBLE__
Shared{} -> __IMPOSSIBLE__
instance (PatternFrom a b) => PatternFrom (Abs a) (Abs b) where
- patternFrom k (Abs name x) = Abs name <$> patternFrom (k+1) x
- patternFrom k (NoAbs name x) = NoAbs name <$> patternFrom k x
+ patternFrom r k (Abs name x) = Abs name <$> patternFrom r (k+1) x
+ patternFrom r k (NoAbs name x) = NoAbs name <$> patternFrom r k x
-- | Monad for non-linear matching.
type NLM = ExceptT Blocked_ (StateT NLMState ReduceM)
-type NLMState = (Sub, PostponedEquations)
+data NLMState = NLMState
+ { _nlmSub :: Sub
+ , _nlmEqs :: PostponedEquations
+ }
+
+instance Null NLMState where
+ empty = NLMState { _nlmSub = empty , _nlmEqs = empty }
+ null s = null (s^.nlmSub) && null (s^.nlmEqs)
+
+nlmSub :: Lens' Sub NLMState
+nlmSub f s = f (_nlmSub s) <&> \x -> s {_nlmSub = x}
+
+nlmEqs :: Lens' PostponedEquations NLMState
+nlmEqs f s = f (_nlmEqs s) <&> \x -> s {_nlmEqs = x}
liftRed :: ReduceM a -> NLM a
liftRed = lift . lift
@@ -150,19 +213,24 @@ matchingBlocked :: Blocked_ -> NLM ()
matchingBlocked = throwError
-- | Add substitution @i |-> v@ to result of matching.
-tellSub :: Int -> Term -> NLM ()
-tellSub i v = do
- caseMaybeM (IntMap.lookup i <$> gets fst) (modify $ first $ IntMap.insert i v) $ \v' -> do
- unlessM (liftRed $ equal v v') $ matchingBlocked $ NotBlocked ReallyNotBlocked () -- lies!
+tellSub :: Relevance -> Int -> Term -> NLM ()
+tellSub r i v = do
+ old <- IntMap.lookup i <$> use nlmSub
+ case old of
+ Nothing -> nlmSub %= IntMap.insert i (r,v)
+ Just (r',v')
+ | isIrrelevant r -> return ()
+ | isIrrelevant r' -> nlmSub %= IntMap.insert i (r,v)
+ | otherwise -> whenJustM (liftRed $ equal v v') matchingBlocked
tellEq :: Telescope -> Telescope -> Term -> Term -> NLM ()
tellEq gamma k u v =
traceSDocNLM "rewriting" 60 (sep
[ text "adding equality between" <+> addContext (gamma `abstract` k) (prettyTCM u)
, text " and " <+> addContext k (prettyTCM v) ]) $ do
- modify $ second $ (PostponedEquation k u v:)
+ nlmEqs %= (PostponedEquation k u v:)
-type Sub = IntMap Term
+type Sub = IntMap (Relevance, Term)
-- | Matching against a term produces a constraint
-- which we have to verify after applying
@@ -178,25 +246,28 @@ type PostponedEquations = [PostponedEquation]
-- returning a substitution.
class Match a b where
- match :: Telescope -- ^ The telescope of pattern variables
+ match :: Relevance -- ^ Are we currently matching in an irrelevant context?
+ -> Telescope -- ^ The telescope of pattern variables
-> Telescope -- ^ The telescope of lambda-bound variables
-> a -- ^ The pattern to match
-> b -- ^ The term to be matched against the pattern
-> NLM ()
instance Match a b => Match [a] [b] where
- match gamma k ps vs
- | length ps == length vs = zipWithM_ (match gamma k) ps vs
+ match r gamma k ps vs
+ | length ps == length vs = zipWithM_ (match r gamma k) ps vs
| otherwise = matchingBlocked $ NotBlocked ReallyNotBlocked ()
instance Match a b => Match (Arg a) (Arg b) where
- match gamma k p v = match gamma k (unArg p) (unArg v)
+ match r gamma k p v = let r' = r `composeRelevance` getRelevance p
+ in match r' gamma k (unArg p) (unArg v)
instance Match a b => Match (Elim' a) (Elim' b) where
- match gamma k p v =
+ match r gamma k p v =
case (p, v) of
- (Apply p, Apply v) -> match gamma k p v
- (Proj x , Proj y ) -> if x == y then return () else
+ (Apply p, Apply v) -> let r' = r `composeRelevance` getRelevance p
+ in match r' gamma k p v
+ (Proj _ x, Proj _ y) -> if x == y then return () else
traceSDocNLM "rewriting" 80 (sep
[ text "mismatch between projections " <+> prettyTCM x
, text " and " <+> prettyTCM y ]) mzero
@@ -204,32 +275,50 @@ instance Match a b => Match (Elim' a) (Elim' b) where
(Proj{} , Apply{}) -> __IMPOSSIBLE__
instance Match a b => Match (Dom a) (Dom b) where
- match gamma k p v = match gamma k (C.unDom p) (C.unDom v)
+ match r gamma k p v = match r gamma k (C.unDom p) (C.unDom v)
+
+instance Match NLPType Type where
+ match r gamma k (NLPType lp p) (El s a) = match r gamma k lp s >> match r gamma k p a
-instance Match a b => Match (Type' a) (Type' b) where
- match gamma k p v = match gamma k (unEl p) (unEl v)
+instance Match NLPat Sort where
+ match r gamma k p s = case (p , s) of
+ (PWild , _ ) -> return ()
+ (p , Type l) -> match Irrelevant gamma k p l
+ _ -> matchingBlocked $ NotBlocked ReallyNotBlocked ()
-instance (Match a b, Subst t1 a, Subst t2 b) => Match (Abs a) (Abs b) where
- match gamma k (Abs n p) (Abs _ v) = match gamma (ExtendTel dummyDom (Abs n k)) p v
- match gamma k (Abs n p) (NoAbs _ v) = match gamma (ExtendTel dummyDom (Abs n k)) p (raise 1 v)
- match gamma k (NoAbs n p) (Abs _ v) = match gamma (ExtendTel dummyDom (Abs n k)) (raise 1 p) v
- match gamma k (NoAbs _ p) (NoAbs _ v) = match gamma k p v
+instance (Match a b, RaiseNLP a, Subst t2 b) => Match (Abs a) (Abs b) where
+ match r gamma k (Abs n p) (Abs _ v) = match r gamma (ExtendTel dummyDom (Abs n k)) p v
+ match r gamma k (Abs n p) (NoAbs _ v) = match r gamma (ExtendTel dummyDom (Abs n k)) p (raise 1 v)
+ match r gamma k (NoAbs n p) (Abs _ v) = match r gamma (ExtendTel dummyDom (Abs n k)) (raiseNLP 1 p) v
+ match r gamma k (NoAbs _ p) (NoAbs _ v) = match r gamma k p v
+
+instance Match NLPat Level where
+ match r gamma k p l = match r gamma k p =<< liftRed (reallyUnLevelView l)
instance Match NLPat Term where
- match gamma k p v = do
+ match r gamma k p v = do
+ vb <- liftRed $ reduceB' v
let n = size k
+ b = void vb
+ v = ignoreBlocking vb
+ prettyPat = addContext (gamma `abstract` k) (prettyTCM (raisePatVars n p))
+ prettyTerm = addContext k (prettyTCM v)
traceSDocNLM "rewriting" 100 (sep
- [ text "matching" <+> addContext (gamma `abstract` k) (prettyTCM (raisePatVars n p))
- , text "with" <+> addContext k (prettyTCM v)]) $ do
+ [ text "matching" <+> prettyPat
+ , text "with" <+> prettyTerm]) $ do
let yes = return ()
no msg =
traceSDocNLM "rewriting" 80 (sep
- [ text "mismatch between" <+> addContext (gamma `abstract` k) (prettyTCM (raisePatVars n p))
- , text " and " <+> addContext k (prettyTCM v)
- , msg ]) mzero
+ [ text "mismatch between" <+> prettyPat
+ , text " and " <+> prettyTerm
+ , msg ]) $ matchingBlocked b
+ block b' =
+ traceSDocNLM "rewriting" 80 (sep
+ [ text "matching blocked on meta"
+ , text (show b) ]) $ matchingBlocked (b `mappend` b')
case p of
PWild -> yes
- PVar id i -> do
+ PVar id i bvs -> do
-- If the variable is still bound by the current context, we cannot
-- instantiate it so it has to match on the nose (see Issue 1652).
ctx <- zip <$> getContextNames <*> getContextId
@@ -237,59 +326,118 @@ instance Match NLPat Term where
cid <- getContextId
case (maybe Nothing (\i -> elemIndex i cid) id) of
Just j -> if v == var (j+n)
- then tellSub i (var j)
+ then tellSub r i (var j)
else no (text $ "(CtxId = " ++ show id ++ ")")
Nothing -> do
- let boundVarOccs :: FreeVars
- boundVarOccs = runFree (\var@(i,_) -> if i < n then singleton var else empty) IgnoreNot v
- if null (rigidVars boundVarOccs)
- then if null (flexibleVars boundVarOccs)
- then tellSub i (raise (-n) v)
- else matchingBlocked $ foldMap (foldMap $ \m -> Blocked m ()) $ flexibleVars boundVarOccs
- else no (text "")
+ let allowedVars :: IntSet
+ allowedVars = IntSet.fromList (map unArg bvs)
+ isBadVar :: Int -> Bool
+ isBadVar i = i < n && not (i `IntSet.member` allowedVars)
+ perm :: Permutation
+ perm = Perm n $ reverse $ map unArg $ bvs
+ tel :: Telescope
+ tel = permuteTel perm k
+ ok <- liftRed $ reallyFree isBadVar v
+ case ok of
+ Left b -> block b
+ Right Nothing -> no (text "")
+ Right (Just v) -> tellSub r i $ teleLam tel $ renameP __IMPOSSIBLE__ perm v
PDef f ps -> do
- v <- liftRed $ constructorForm v
+ v <- liftRed $ constructorForm =<< unLevel v
case ignoreSharing v of
Def f' es
- | f == f' -> matchArgs gamma k ps es
- | otherwise -> no (text "")
- Con c vs
- | f == conName c -> matchArgs gamma k ps (Apply <$> vs)
- | otherwise -> no (text "")
+ | f == f' -> match r gamma k ps es
+ Con c _ vs
+ | f == conName c -> match r gamma k ps (Apply <$> vs)
+ | otherwise -> do -- @c@ may be a record constructor
+ mr <- liftRed $ isRecordConstructor (conName c)
+ case mr of
+ Just (_, def) | recEtaEquality def -> do
+ let fs = recFields def
+ qs = map (fmap $ \f -> PDef f (ps ++ [Proj ProjSystem f])) fs
+ match r gamma k qs vs
+ _ -> no (text "")
Lam i u -> do
- let pbody = PDef f (raiseNLP 1 ps ++ [Apply $ Arg i $ PBoundVar 0 []])
- body <- liftRed $ reduce' $ absBody u
- match gamma (ExtendTel dummyDom (Abs (absName u) k)) pbody body
+ let pbody = PDef f (raiseNLP 1 ps ++ [Apply $ Arg i $ PTerm (var 0)])
+ body = absBody u
+ match r gamma (ExtendTel dummyDom (Abs (absName u) k)) pbody body
MetaV m es -> do
matchingBlocked $ Blocked m ()
- _ -> no (text "")
+ v' -> do -- @f@ may be a record constructor as well
+ mr <- liftRed $ isRecordConstructor f
+ case mr of
+ Just (_, def) | recEtaEquality def -> do
+ let fs = recFields def
+ ws = map (fmap $ \f -> v `applyE` [Proj ProjSystem f]) fs
+ qs = fromMaybe __IMPOSSIBLE__ $ allApplyElims ps
+ match r gamma k qs ws
+ _ -> no (text "")
PLam i p' -> do
let body = Abs (absName p') $ raise 1 v `apply` [Arg i (var 0)]
- body <- liftRed $ reduce' body
- match gamma k p' body
+ match r gamma k p' body
PPi pa pb -> case ignoreSharing v of
- Pi a b -> do
- (a,b) <- liftRed $ reduce' (a,b)
- match gamma k pa a >> match gamma k pb b
+ Pi a b -> match r gamma k pa a >> match r gamma k pb b
MetaV m es -> matchingBlocked $ Blocked m ()
_ -> no (text "")
PBoundVar i ps -> case ignoreSharing v of
- Var i' es | i == i' -> matchArgs gamma k ps es
+ Var i' es | i == i' -> match r gamma k ps es
+ Con c _ vs -> do -- @c@ may be a record constructor
+ mr <- liftRed $ isRecordConstructor (conName c)
+ case mr of
+ Just (_, def) | recEtaEquality def -> do
+ let fs = recFields def
+ qs = map (fmap $ \f -> PBoundVar i (ps ++ [Proj ProjSystem f])) fs
+ match r gamma k qs vs
+ _ -> no (text "")
+ Lam info u -> do
+ let pbody = PBoundVar i (raiseNLP 1 ps ++ [Apply $ Arg info $ PTerm (var 0)])
+ body = absBody u
+ match r gamma (ExtendTel dummyDom (Abs (absName u) k)) pbody body
MetaV m es -> matchingBlocked $ Blocked m ()
_ -> no (text "")
PTerm u -> tellEq gamma k u v
- where
- matchArgs :: Telescope -> Telescope -> [Elim' NLPat] -> Elims -> NLM ()
- matchArgs gamma k ps es = match gamma k ps =<< liftRed (reduce' es)
+
+-- Checks if the given term contains any free variables that satisfy the
+-- given condition on their DBI, possibly normalizing the term in the process.
+-- Returns `Right Nothing` if there are such variables, `Right (Just v')`
+-- if there are none (where v' is the possibly normalized version of the given
+-- term) or `Left b` if the problem is blocked on a meta.
+reallyFree :: (Reduce a, Normalise a, Free' a FreeVars)
+ => (Int -> Bool) -> a -> ReduceM (Either Blocked_ (Maybe a))
+reallyFree f v = do
+ let xs = getVars v
+ if null (stronglyRigidVars xs) && null (unguardedVars xs)
+ then do
+ if null (weaklyRigidVars xs) && null (flexibleVars xs)
+ && null (irrelevantVars xs)
+ then return $ Right $ Just v
+ else do
+ bv <- normaliseB' v
+ let b = void bv
+ v = ignoreBlocking bv
+ xs = getVars v
+ b' = foldMap (foldMap $ \m -> Blocked m ()) $ flexibleVars xs
+ if null (stronglyRigidVars xs) && null (unguardedVars xs)
+ && null (weaklyRigidVars xs) && null (irrelevantVars xs)
+ then if null (flexibleVars xs)
+ then return $ Right $ Just v
+ else return $ Left $ b `mappend` b'
+ else return $ Right Nothing
+ else return $ Right Nothing
+ where
+ getVars v = runFree (\var@(i,_) -> if f i then singleton var else empty) IgnoreNot v
makeSubstitution :: Telescope -> Sub -> Substitution
makeSubstitution gamma sub =
prependS __IMPOSSIBLE__ (map val [0 .. size gamma-1]) EmptyS
where
- val i = IntMap.lookup i sub
+ val i = case IntMap.lookup i sub of
+ Just (Irrelevant, v) -> Just $ dontCare v
+ Just (_ , v) -> Just v
+ Nothing -> Nothing
-checkPostponedEquations :: Substitution -> PostponedEquations -> ReduceM Bool
-checkPostponedEquations sub eqs = andM $ for eqs $
+checkPostponedEquations :: Substitution -> PostponedEquations -> ReduceM (Maybe Blocked_)
+checkPostponedEquations sub eqs = forM' eqs $
\ (PostponedEquation k lhs rhs) -> equal (applySubst (liftS (size k) sub) lhs) rhs
-- main function
@@ -298,23 +446,38 @@ nonLinMatch gamma p v = do
let no msg b = traceSDoc "rewriting" 80 (sep
[ text "matching failed during" <+> text msg
, text "blocking: " <+> text (show b) ]) $ return (Left b)
- caseEitherM (runNLM $ match gamma EmptyTel p v) (no "matching") $ \ (s, eqs) -> do
- let sub = makeSubstitution gamma s
+ caseEitherM (runNLM $ match Relevant gamma EmptyTel p v) (no "matching") $ \ s -> do
+ let sub = makeSubstitution gamma $ s^.nlmSub
+ eqs = s^.nlmEqs
traceSDoc "rewriting" 90 (text $ "sub = " ++ show sub) $ do
- ifM (checkPostponedEquations sub eqs)
- (return $ Right sub)
- (no "checking of postponed equations" $ NotBlocked ReallyNotBlocked ()) -- more lies
+ ok <- checkPostponedEquations sub eqs
+ case ok of
+ Nothing -> return $ Right sub
+ Just b -> no "checking of postponed equations" b
-- | Untyped βη-equality, does not handle things like empty record types.
-equal :: Term -> Term -> ReduceM Bool
+-- Returns `Nothing` if the terms are equal, or `Just b` if the terms are not
+-- (where b contains information about possible metas blocking the comparison)
+
+-- TODO: implement a type-directed, lazy version of this function.
+equal :: Term -> Term -> ReduceM (Maybe Blocked_)
equal u v = do
(u, v) <- etaContract =<< normalise' (u, v)
- let ok = u == v
- if ok then return True else
+ let ok = u == v
+ metas = allMetas (u, v)
+ block = caseMaybe (headMaybe metas)
+ (NotBlocked ReallyNotBlocked ())
+ (\m -> Blocked m ())
+ if ok then return Nothing else
traceSDoc "rewriting" 80 (sep
[ text "mismatch between " <+> prettyTCM u
, text " and " <+> prettyTCM v
- ]) $ return False
+ ]) $ return $ Just block
+
+-- | Normalise the given term but also preserve blocking tags
+-- TODO: implement a more efficient version of this.
+normaliseB' :: (Reduce t, Normalise t) => t -> ReduceM (Blocked t)
+normaliseB' = normalise' >=> reduceB'
-- | Raise (bound) variables in a NLPat
@@ -327,6 +490,9 @@ class RaiseNLP a where
instance RaiseNLP a => RaiseNLP [a] where
raiseNLPFrom c k = fmap $ raiseNLPFrom c k
+instance RaiseNLP a => RaiseNLP (Maybe a) where
+ raiseNLPFrom c k = fmap $ raiseNLPFrom c k
+
instance RaiseNLP a => RaiseNLP (Arg a) where
raiseNLPFrom c k = fmap $ raiseNLPFrom c k
@@ -336,8 +502,9 @@ instance RaiseNLP a => RaiseNLP (Elim' a) where
instance RaiseNLP a => RaiseNLP (Dom a) where
raiseNLPFrom c k = fmap $ raiseNLPFrom c k
-instance RaiseNLP a => RaiseNLP (Type' a) where
- raiseNLPFrom c k = fmap $ raiseNLPFrom c k
+instance RaiseNLP NLPType where
+ raiseNLPFrom c k (NLPType l a) =
+ NLPType (raiseNLPFrom c k l) (raiseNLPFrom c k a)
instance RaiseNLP a => RaiseNLP (Abs a) where
raiseNLPFrom c k (Abs i p) = Abs i $ raiseNLPFrom (c+1) k p
@@ -345,7 +512,8 @@ instance RaiseNLP a => RaiseNLP (Abs a) where
instance RaiseNLP NLPat where
raiseNLPFrom c k p = case p of
- PVar _ _ -> p
+ PVar id i bvs -> let raise j = if j < c then j else j + k
+ in PVar id i $ map (fmap raise) bvs
PWild -> p
PDef f ps -> PDef f $ raiseNLPFrom c k ps
PLam i q -> PLam i $ raiseNLPFrom c k q
@@ -353,4 +521,3 @@ instance RaiseNLP NLPat where
PBoundVar i ps -> let j = if i < c then i else i + k
in PBoundVar j $ raiseNLPFrom c k ps
PTerm u -> PTerm $ raiseFrom c k u
-
diff --git a/src/full/Agda/TypeChecking/Rules/Builtin.hs b/src/full/Agda/TypeChecking/Rules/Builtin.hs
index 9b4a20a..1642962 100644
--- a/src/full/Agda/TypeChecking/Rules/Builtin.hs
+++ b/src/full/Agda/TypeChecking/Rules/Builtin.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Rules.Builtin
( bindBuiltin
@@ -13,6 +11,8 @@ module Agda.TypeChecking.Rules.Builtin
import Control.Applicative hiding (empty)
import Control.Monad
+import Control.Monad.Reader (ask)
+import Control.Monad.State (get)
import Data.List (find)
import qualified Agda.Syntax.Abstract as A
@@ -102,7 +102,22 @@ coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)
return (sort $ varSort 1))
[builtinRefl])
, (builtinHiding |-> BuiltinData tset [builtinHidden, builtinInstance, builtinVisible])
+ -- Relevance
, (builtinRelevance |-> BuiltinData tset [builtinRelevant, builtinIrrelevant])
+ , (builtinRelevant |-> BuiltinDataCons trelevance)
+ , (builtinIrrelevant |-> BuiltinDataCons trelevance)
+ -- Associativity
+ , builtinAssoc |-> BuiltinData tset [builtinAssocLeft, builtinAssocRight, builtinAssocNon]
+ , builtinAssocLeft |-> BuiltinDataCons tassoc
+ , builtinAssocRight |-> BuiltinDataCons tassoc
+ , builtinAssocNon |-> BuiltinDataCons tassoc
+ -- Precedence
+ , builtinPrecedence |-> BuiltinData tset [builtinPrecRelated, builtinPrecUnrelated]
+ , builtinPrecRelated |-> BuiltinDataCons (tint --> tprec)
+ , builtinPrecUnrelated |-> BuiltinDataCons tprec
+ -- Fixity
+ , builtinFixity |-> BuiltinData tset [builtinFixityFixity]
+ , builtinFixityFixity |-> BuiltinDataCons (tassoc --> tprec --> tfixity)
, (builtinRefl |-> BuiltinDataCons (hPi "a" (el primLevel) $
hPi "A" (return $ sort $ varSort 0) $
hPi "x" (El (varSort 1) <$> varM 0) $
@@ -136,8 +151,6 @@ coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)
, (builtinHidden |-> BuiltinDataCons thiding)
, (builtinInstance |-> BuiltinDataCons thiding)
, (builtinVisible |-> BuiltinDataCons thiding)
- , (builtinRelevant |-> BuiltinDataCons trelevance)
- , (builtinIrrelevant |-> BuiltinDataCons trelevance)
, (builtinSizeUniv |-> builtinPostulate tSizeUniv) -- SizeUniv : SizeUniv
-- See comment on tSizeUniv: the following does not work currently.
-- , (builtinSizeUniv |-> builtinPostulate tSetOmega) -- SizeUniv : Setω
@@ -188,6 +201,7 @@ coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)
, builtinAgdaTCMInferType |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)
, builtinAgdaTCMCheckType |-> builtinPostulate (tterm --> ttype --> tTCM_ primAgdaTerm)
, builtinAgdaTCMNormalise |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)
+ , builtinAgdaTCMReduce |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)
, builtinAgdaTCMCatchError |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))
, builtinAgdaTCMGetContext |-> builtinPostulate (tTCM_ (unEl <$> tlist (targ ttype)))
, builtinAgdaTCMExtendContext |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))
@@ -201,6 +215,8 @@ coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)
, builtinAgdaTCMUnquoteTerm |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tterm --> tTCM 1 (varM 0))
, builtinAgdaTCMBlockOnMeta |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tmeta --> tTCM 1 (varM 0))
, builtinAgdaTCMCommit |-> builtinPostulate (tTCM_ primUnit)
+ , builtinAgdaTCMIsMacro |-> builtinPostulate (tqname --> tTCM_ primBool)
+ , builtinAgdaTCMWithNormalisation |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tbool --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))
]
where
(|->) = (,)
@@ -230,6 +246,7 @@ coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)
tterm = el primAgdaTerm
terrorpart = el primAgdaErrorPart
tnat = el primNat
+ tint = el primInteger
tunit = el primUnit
tinteger = el primInteger
tfloat = el primFloat
@@ -241,6 +258,9 @@ coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)
tbool = el primBool
thiding = el primHiding
trelevance = el primRelevance
+ tassoc = el primAssoc
+ tprec = el primPrecedence
+ tfixity = el primFixity
-- tcolors = el (list primAgdaTerm) -- TODO guilhem
targinfo = el primArgInfo
ttype = el primAgdaTerm
@@ -365,7 +385,7 @@ coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)
suc n = s `apply1` n
choice = foldr1 (\x y -> x `catchError` \_ -> y)
xs <- mapM freshName_ xs
- addCtxs xs (domFromArg $ defaultArg nat) $ f apply1 zero suc (==) (===) choice
+ addContext (xs, domFromArg $ defaultArg nat) $ f apply1 zero suc (==) (===) choice
inductiveCheck :: String -> Int -> Term -> TCM ()
@@ -397,7 +417,7 @@ bindPostulatedName ::
String -> A.Expr -> (QName -> Definition -> TCM Term) -> TCM ()
bindPostulatedName builtin e m = do
q <- getName e
- def <- ignoreAbstractMode $ getConstInfo q
+ def <- getConstInfo q
case theDef def of
Axiom {} -> bindBuiltinName builtin =<< m q def
_ -> err
@@ -456,7 +476,7 @@ bindBuiltinUnit t = do
case def of
Record { recFields = [], recConHead = con } -> do
bindBuiltinName builtinUnit t
- bindBuiltinName builtinUnitUnit (Con con [])
+ bindBuiltinName builtinUnitUnit (Con con ConOSystem [])
_ -> genericError "Builtin UNIT must be a singleton record type"
bindBuiltinInfo :: BuiltinInfo -> A.Expr -> TCM ()
@@ -477,17 +497,17 @@ bindBuiltinInfo (BuiltinInfo s d) e = do
BuiltinDataCons t -> do
let name (Lam h b) = name (absBody b)
- name (Con c _) = Con c []
+ name (Con c ci _) = Con c ci []
name (Shared p) = name $ ignoreSharing (derefPtr p)
name _ = __IMPOSSIBLE__
e' <- checkExpr e =<< t
case e of
- A.Con _ -> return ()
+ A.Con{} -> return ()
_ -> typeError $ BuiltinMustBeConstructor s e
- let v@(Con h []) = name e'
+ let v@(Con h _ []) = name e'
c = conName h
when (s == builtinTrue) $ addHaskellCode c "Bool" "True"
when (s == builtinFalse) $ addHaskellCode c "Bool" "False"
@@ -521,7 +541,7 @@ bindBuiltinInfo (BuiltinInfo s d) e = do
"The argument to BUILTIN " ++ s ++ " must be a postulated name"
case e of
A.Def q -> do
- def <- ignoreAbstractMode $ getConstInfo q
+ def <- getConstInfo q
case theDef def of
Axiom {} -> do
builtinSizeHook s q t'
@@ -552,9 +572,7 @@ bindBuiltin b e = do
_ | Just i <- find ((b ==) . builtinName) coreBuiltins -> bindBuiltinInfo i e
_ -> typeError $ NoSuchBuiltinName b
where
- nowNat b = genericError $
- "Builtin " ++ b ++ " does no longer exist. " ++
- "It is now bound by BUILTIN " ++ builtinNat
+ nowNat b = warning $ OldBuiltin b builtinNat
isUntypedBuiltin :: String -> Bool
isUntypedBuiltin b = elem b [builtinFromNat, builtinFromNeg, builtinFromString]
@@ -563,8 +581,8 @@ bindUntypedBuiltin :: String -> A.Expr -> TCM ()
bindUntypedBuiltin b e =
case A.unScope e of
A.Def q -> bindBuiltinName b (Def q [])
- A.Proj q -> bindBuiltinName b (Def q [])
- e -> genericError $ "The argument to BUILTIN " ++ b ++ " must be a defined name"
+ A.Proj _ (AmbQ [q]) -> bindBuiltinName b (Def q [])
+ e -> genericError $ "The argument to BUILTIN " ++ b ++ " must be a defined unambiguous name"
-- | Bind a builtin thing to a new name.
bindBuiltinNoDef :: String -> A.QName -> TCM ()
@@ -580,7 +598,7 @@ bindBuiltinNoDef b q = do
-- Andreas, 2015-02-14
-- Special treatment of SizeUniv, should maybe be a primitive.
def | b == builtinSizeUniv = emptyFunction
- { funClauses = [ (empty :: Clause) { clauseBody = Body $ Sort sSizeUniv } ]
+ { funClauses = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ]
, funCompiled = Just (CC.Done [] $ Sort sSizeUniv)
, funTerminates = Just True
}
diff --git a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs
index d96198a..543118d 100644
--- a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs
+++ b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs
@@ -9,6 +9,7 @@ module Agda.TypeChecking.Rules.Builtin.Coinduction where
import Control.Applicative
import qualified Data.Map as Map
+import qualified Data.Set as Set
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Common
@@ -82,7 +83,6 @@ bindBuiltinSharp e =
, recInduction = Just CoInductive
, recClause = Nothing
, recConHead = ConHead sharp CoInductive [] -- flat is added later
- , recConType = sharpType
, recNamedCon = True
, recFields = [] -- flat is added later
, recTel = fieldTel
@@ -99,6 +99,7 @@ bindBuiltinSharp e =
, conData = defName infDefn
, conAbstr = ConcreteDef
, conInd = CoInductive
+ , conErased = []
}
}
return sharpE
@@ -130,8 +131,8 @@ bindBuiltinFlat e =
{ clauseRange = noRange
, clauseTel = tel
, namedClausePats = [ argN $ Named Nothing $
- ConP sharpCon cpi [ argN $ Named Nothing $ VarP (0,"x") ] ]
- , clauseBody = Bind $ Abs "x" $ Body $ var 0
+ ConP sharpCon cpi [ argN $ Named Nothing $ debruijnNamedVar "x" 0 ] ]
+ , clauseBody = Just $ var 0
, clauseType = Just $ defaultArg $ El (varSort 2) $ var 1
, clauseCatchall = False
}
@@ -141,30 +142,20 @@ bindBuiltinFlat e =
Map.empty
Nothing
projection = Projection
- { projProper = Just flat
- , projFromType = inf
+ { projProper = True
+ , projOrig = flat
+ , projFromType = defaultArg inf
, projIndex = 3
- , projDropPars = teleNoAbs (take 2 $ telToList tel) $ Lam defaultArgInfo $ Abs "x" $ Var 0 [Proj flat]
- , projArgInfo = defaultArgInfo
+ , projLams = ProjLams $ [ argH "a" , argH "A" , argN "x" ]
}
addConstant flat $
flatDefn { defPolarity = []
, defArgOccurrences = [StrictPos] -- changing that to [Mixed] destroys monotonicity of 'Rec' in test/succeed/GuardednessPreservingTypeConstructors
- , theDef = Function
- { funClauses = [clause]
- , funCompiled = Just $ cc
- , funTreeless = Nothing
- , funInv = NotInjective
- , funMutual = []
- , funAbstr = ConcreteDef
- , funDelayed = NotDelayed
- , funProjection = Just projection
- , funSmashable = False
- , funStatic = False
- , funInline = False
- , funTerminates = Just True
- , funExtLam = Nothing
- , funWith = Nothing
+ , theDef = emptyFunction
+ { funClauses = [clause]
+ , funCompiled = Just $ cc
+ , funProjection = Just projection
+ , funTerminates = Just True
, funCopatternLHS = isCopatternLHS [clause]
}
}
diff --git a/src/full/Agda/TypeChecking/Rules/Data.hs b/src/full/Agda/TypeChecking/Rules/Data.hs
index 0497e53..f73b8af 100644
--- a/src/full/Agda/TypeChecking/Rules/Data.hs
+++ b/src/full/Agda/TypeChecking/Rules/Data.hs
@@ -1,9 +1,5 @@
{-# LANGUAGE CPP #-}
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-
module Agda.TypeChecking.Rules.Data where
import Control.Applicative
@@ -35,6 +31,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ )
import Agda.Interaction.Options
+import Agda.Utils.Except
import Agda.Utils.List
import Agda.Utils.Monad
import Agda.Utils.Permutation
@@ -83,16 +80,26 @@ checkDataDef i name ps cs =
-- The type we get from bindParameters is Θ -> s where Θ is the type of
-- the indices. We count the number of indices and return s.
-- We check that s is a sort.
- (nofIxs, s) <- splitType t0
-
- when (any (`freeIn` s) [0..nofIxs - 1]) $ do
- err <- fsep [ text "The sort of" <+> prettyTCM name
+ let TelV ixTel s0 = telView' t0
+ nofIxs = size ixTel
+
+ s <- workOnTypes $ do
+ -- Andreas, 2016-11-02 issue #2290
+ -- Trying to unify the sort with a fresh sort meta which is
+ -- defined outside the index telescope is the most robust way
+ -- to check independence of the indices.
+ -- However, it might give the dreaded "Cannot instantiate meta..."
+ -- error which we replace by a more understandable error
+ -- in case of a suspected dependency.
+ s <- newSortMetaBelowInf
+ catchError_ (addContext ixTel $ equalType s0 $ raise nofIxs $ sort s) $ \ err ->
+ if any (`freeIn` s0) [0..nofIxs - 1] then typeError . GenericDocError =<<
+ fsep [ text "The sort of" <+> prettyTCM name
, text "cannot depend on its indices in the type"
, prettyTCM t0
]
- typeError $ GenericError $ show err
-
- s <- return $ raise (-nofIxs) s
+ else throwError err
+ return s
-- the small parameters are taken into consideration for --without-K
smallPars <- smallParams tel s
@@ -162,19 +169,16 @@ checkDataDef i name ps cs =
-- Andreas 2012-02-13: postpone polarity computation until after positivity check
-- computePolarity name
- where
- -- Take a type of form @tel -> a@ and return
- -- @size tel@ (number of data type indices) and
- -- @a@ as a sort (either @a@ directly if it is a sort,
- -- or a fresh sort meta set equal to a.
- splitType :: Type -> TCM (Int, Sort)
- splitType t = case ignoreSharing $ unEl t of
- Pi a b -> mapFst (+ 1) <$> do addContext (absName b, a) $ splitType (absBody b)
- Sort s -> return (0, s)
- _ -> do
- s <- newSortMeta
- equalType t (sort s)
- return (0, s)
+
+-- | Ensure that the type is a sort.
+-- If it is not directly a sort, compare it to a 'newSortMetaBelowInf'.
+forceSort :: Type -> TCM Sort
+forceSort t = case ignoreSharing $ unEl t of
+ Sort s -> return s
+ _ -> do
+ s <- newSortMetaBelowInf
+ equalType t (sort s)
+ return s
-- | A parameter is small if its sort fits into the data sort.
@@ -209,7 +213,7 @@ checkConstructor
checkConstructor d tel nofIxs s (A.ScopedDecl scope [con]) = do
setScope scope
checkConstructor d tel nofIxs s con
-checkConstructor d tel nofIxs s con@(A.Axiom _ i ai c e) =
+checkConstructor d tel nofIxs s con@(A.Axiom _ i ai Nothing c e) =
traceCall (CheckConstructor d tel s con) $ do
{- WRONG
-- Andreas, 2011-04-26: the following happens to the right of ':'
@@ -244,7 +248,7 @@ checkConstructor d tel nofIxs s con@(A.Axiom _ i ai c e) =
escapeContext (size tel) $
addConstant c $
defaultDefn defaultArgInfo c (telePi tel t') $
- Constructor (size tel) con d (Info.defAbstract i) Inductive
+ Constructor (size tel) con d (Info.defAbstract i) Inductive []
-- Add the constructor to the instance table, if needed
when (Info.defInstance i == InstanceDef) $ do
@@ -289,7 +293,7 @@ bindParameters ps0@(A.DomainFree info x : ps) (El _ (Pi arg@(Dom info' a) b)) re
-- Andreas, 2011-04-07 ignore relevance information in binding?!
| argInfoHiding info /= argInfoHiding info' =
__IMPOSSIBLE__
- | otherwise = addContext (x, arg) $ bindParameters ps (absBody b) $ \tel s ->
+ | otherwise = addContext' (x, arg) $ bindParameters ps (absBody b) $ \tel s ->
ret (ExtendTel arg $ Abs (nameToArgName x) tel) s
bindParameters bs (El s (Shared p)) ret = bindParameters bs (El s $ derefPtr p) ret
bindParameters (b : bs) t _ = __IMPOSSIBLE__
@@ -441,6 +445,7 @@ isCoinductive t = do
Record { recInduction = _ } -> return (Just False)
Constructor {} -> __IMPOSSIBLE__
Primitive {} -> __IMPOSSIBLE__
+ AbstractDefn{} -> __IMPOSSIBLE__
Var {} -> return Nothing
Lam {} -> __IMPOSSIBLE__
Lit {} -> __IMPOSSIBLE__
diff --git a/src/full/Agda/TypeChecking/Rules/Decl.hs b/src/full/Agda/TypeChecking/Rules/Decl.hs
index 86a5335..db68dd9 100644
--- a/src/full/Agda/TypeChecking/Rules/Decl.hs
+++ b/src/full/Agda/TypeChecking/Rules/Decl.hs
@@ -1,21 +1,21 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Rules.Decl where
+import Prelude hiding (null)
+
import Control.Monad
import Control.Monad.Reader
-import Control.Monad.State (modify, gets)
+import Control.Monad.State (modify, gets, get)
import Control.Monad.Writer (tell)
+import Data.Either (partitionEithers)
import qualified Data.Foldable as Fold
+import Data.List (genericLength)
import Data.Maybe
import Data.Map (Map)
+import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Set (Set)
@@ -45,6 +45,7 @@ import Agda.TypeChecking.Errors
import Agda.TypeChecking.Injectivity
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Positivity
+import Agda.TypeChecking.Positivity.Occurrence
import Agda.TypeChecking.Polarity
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Primitive
@@ -52,6 +53,7 @@ import Agda.TypeChecking.ProjectionLike
import Agda.TypeChecking.Quote
import Agda.TypeChecking.Unquote
import Agda.TypeChecking.Records
+import Agda.TypeChecking.RecordPatterns
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Rewriting
import Agda.TypeChecking.SizedTypes.Solve
@@ -62,18 +64,21 @@ import Agda.TypeChecking.Unquote
import Agda.TypeChecking.Rules.Term
import Agda.TypeChecking.Rules.Data ( checkDataDef )
import Agda.TypeChecking.Rules.Record ( checkRecDef )
-import Agda.TypeChecking.Rules.Def ( checkFunDef, useTerPragma )
+import Agda.TypeChecking.Rules.Def ( checkFunDef, newSection, useTerPragma )
import Agda.TypeChecking.Rules.Builtin
import Agda.TypeChecking.Rules.Display ( checkDisplayPragma )
import Agda.Termination.TermCheck
-import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.Except
+import Agda.Utils.Functor
+import Agda.Utils.Function
+import Agda.Utils.Lens
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Size
-import Agda.Utils.Except
#include "undefined.h"
import Agda.Utils.Impossible
@@ -147,17 +152,16 @@ checkDecl d = setCurrentRange d $ do
reportSDoc "tc.decl" 10 $ prettyA d -- Might loop, see e.g. Issue 1597
-- Issue 418 fix: freeze metas before checking an abstract thing
- when_ isAbstract freezeMetas
+ -- when_ isAbstract freezeMetas -- WAS IN PLACE 2012-2016, but too crude
+ -- applyWhen isAbstract withFreezeMetas $ do -- WRONG
let -- What kind of final checks/computations should be performed
-- if we're not inside a mutual block?
- none m = m >> return Nothing
- meta m = m >> return (Just (return ()))
- mutual i ds m = m >>= return . Just . uncurry (mutualChecks i d ds)
- impossible m = m >> return __IMPOSSIBLE__
- -- We're definitely inside a mutual block.
-
- let mi = Info.MutualInfo TerminationCheck True noRange
+ none m = m $> Nothing -- skip all checks
+ meta m = m $> Just (return ()) -- do the usual checks
+ mutual i ds m = m <&> Just . uncurry (mutualChecks i d ds)
+ impossible m = m $> __IMPOSSIBLE__
+ -- We're definitely inside a mutual block.
finalChecks <- case d of
A.Axiom{} -> meta $ checkTypeSignature d
@@ -165,15 +169,28 @@ checkDecl d = setCurrentRange d $ do
A.Primitive i x e -> meta $ checkPrimitive i x e
A.Mutual i ds -> mutual i ds $ checkMutual i ds
A.Section i x tel ds -> meta $ checkSection i x tel ds
- A.Apply i x modapp rd rm _adir -> meta $ checkSectionApplication i x modapp rd rm
+ A.Apply i x modapp ci _adir -> meta $ checkSectionApplication i x modapp ci
A.Import i x _adir -> none $ checkImport i x
A.Pragma i p -> none $ checkPragma i p
A.ScopedDecl scope ds -> none $ setScope scope >> mapM_ checkDeclCached ds
A.FunDef i x delayed cs -> impossible $ check x i $ checkFunDef delayed i x cs
A.DataDef i x ps cs -> impossible $ check x i $ checkDataDef i x ps cs
- A.RecDef i x ind eta c ps tel cs -> mutual mi [d] $ check x i $ do
+ A.RecDef i x ind eta c ps tel cs -> mutual empty [d] $ check x i $ do
checkRecDef i x ind eta c ps tel cs
blockId <- mutualBlockOf x
+
+ -- Andreas, 2016-10-01 testing whether
+ -- envMutualBlock is set correctly.
+ -- Apparently not.
+ verboseS "tc.decl.mutual" 70 $ do
+ current <- asks envMutualBlock
+ unless (Just blockId == current) $ do
+ reportSLn "" 0 $ unlines
+ [ "mutual block id discrepancy for " ++ show x
+ , " current mut. bl. = " ++ show current
+ , " calculated mut. bl. = " ++ show blockId
+ ]
+
return (blockId, Set.singleton x)
A.DataSig i x ps t -> impossible $ checkSig i x ps t
A.RecSig i x ps t -> none $ checkSig i x ps t
@@ -209,7 +226,8 @@ checkDecl d = setCurrentRange d $ do
-- check record or data type signature
checkSig i x ps t = checkTypeSignature $
- A.Axiom A.NoFunSig i defaultArgInfo x (A.Pi (Info.ExprRange (fuseRange ps t)) ps t)
+ A.Axiom A.NoFunSig i defaultArgInfo Nothing x
+ (A.Pi (Info.ExprRange (fuseRange ps t)) ps t)
check x i m = do
reportSDoc "tc.decl" 5 $ text "Checking" <+> prettyTCM x <> text "."
@@ -230,11 +248,13 @@ checkDecl d = setCurrentRange d $ do
mutualChecks :: Info.MutualInfo -> A.Declaration -> [A.Declaration] -> MutualId -> Set QName -> TCM ()
mutualChecks mi d ds mid names = do
-- Andreas, 2014-04-11: instantiate metas in definition types
- mapM_ instantiateDefinitionType $ Set.toList names
+ let nameList = Set.toList names
+ mapM_ instantiateDefinitionType nameList
-- Andreas, 2013-02-27: check termination before injectivity,
-- to avoid making the injectivity checker loop.
- checkTermination_ mid d
+ local (\ e -> e { envMutualBlock = Just mid }) $ checkTermination_ d
checkPositivity_ mi names
+ revisitRecordPatternTranslation nameList -- Andreas, 2016-11-19 issue #2308
-- Andreas, 2015-03-26 Issue 1470:
-- Restricting coinduction to recursive does not solve the
-- actual problem, and prevents interesting sound applications
@@ -251,6 +271,30 @@ mutualChecks mi d ds mid names = do
checkInjectivity_ names
checkProjectionLikeness_ names
+-- | Check if there is a inferred eta record type in the mutual block.
+-- If yes, repeat the record pattern translation for all function definitions
+-- in the block.
+-- This is necessary since the original record pattern translation will
+-- have skipped record patterns of the new record types (as eta was off for them).
+-- See issue #2308 (and #2197).
+revisitRecordPatternTranslation :: [QName] -> TCM ()
+revisitRecordPatternTranslation qs = do
+ -- rs: inferred eta record types of this mutual block
+ -- qccs: compiled clauses of definitions
+ (rs, qccs) <- partitionEithers . catMaybes <$> mapM classify qs
+ unless (null rs) $ forM_ qccs $ \(q,cc) -> do
+ cc <- translateCompiledClauses cc
+ modifySignature $ updateDefinition q $ updateTheDef $
+ updateCompiledClauses $ const $ Just cc
+ where
+ -- Walk through the definitions and return the set of inferred eta record types
+ -- and the set of function definitions in the mutual block
+ classify q = inConcreteOrAbstractMode q $ \ def -> do
+ case theDef def of
+ Record{ recEtaEquality' = Inferred True } -> return $ Just $ Left q
+ Function{ funCompiled = Just cc } -> return $ Just $ Right (q, cc)
+ _ -> return Nothing
+
type FinalChecks = Maybe (TCM ())
checkUnquoteDecl :: Info.MutualInfo -> [Info.DefInfo] -> [QName] -> A.Expr -> TCM FinalChecks
@@ -353,17 +397,19 @@ highlight_ d = do
"do not highlight construct(ed/or) type"
-- | Termination check a declaration.
-checkTermination_ :: MutualId -> A.Declaration -> TCM ()
-checkTermination_ mid d = Bench.billTo [Bench.Termination] $ do
+checkTermination_ :: A.Declaration -> TCM ()
+checkTermination_ d = Bench.billTo [Bench.Termination] $ do
reportSLn "tc.decl" 20 $ "checkDecl: checking termination..."
- whenM (optTerminationCheck <$> pragmaOptions) $ do
- case d of
+ case d of
-- Record module definitions should not be termination-checked twice.
A.RecDef {} -> return ()
_ -> disableDestructiveUpdate $ do
- termErrs <- termDecl mid d
- unless (null termErrs) $
- typeError $ TerminationCheckFailed termErrs
+ termErrs <- termDecl d
+ -- If there are some termination errors, we collect them in
+ -- the state.
+ -- The termination checker already marked non-terminating functions as such.
+ unless (null termErrs) $ do
+ warning $ TerminationIssue termErrs
-- | Check a set of mutual names for positivity.
checkPositivity_ :: Info.MutualInfo -> Set QName -> TCM ()
@@ -381,7 +427,7 @@ checkPositivity_ mi names = Bench.billTo [Bench.Positivity] $ do
-- (Otherwise, one can implement invalid recursion schemes just like
-- for the old coinduction.)
checkCoinductiveRecords :: [A.Declaration] -> TCM ()
-checkCoinductiveRecords ds = forM_ ds $ \ d -> case d of
+checkCoinductiveRecords ds = forM_ ds $ \case
A.RecDef _ q (Just (Ranged r CoInductive)) _ _ _ _ _ -> setCurrentRange r $ do
unlessM (isRecursiveRecord q) $ typeError $ GenericError $
"Only recursive records can be coinductive"
@@ -394,7 +440,7 @@ checkInjectivity_ names = Bench.billTo [Bench.Injectivity] $ do
-- Andreas, 2015-07-01, see Issue1366b:
-- Injectivity check needs also to be run for abstract definitions.
-- Fold.forM_ names $ \ q -> ignoreAbstractMode $ do -- NOT NECESSARY after all
- Fold.forM_ names $ \ q -> inConcreteOrAbstractMode q $ do
+ Fold.forM_ names $ \ q -> inConcreteOrAbstractMode q $ \ def -> do
-- For abstract q, we should be inAbstractMode,
-- otherwise getConstInfo returns Axiom.
--
@@ -406,7 +452,6 @@ checkInjectivity_ names = Bench.billTo [Bench.Injectivity] $ do
-- or super modules inAbstractMode.
-- I changed that in Monad.Signature.treatAbstractly', so we can see
-- our own local definitions.
- def <- getConstInfo q
case theDef def of
d@Function{ funClauses = cs, funTerminates = term } -> do
case term of
@@ -447,9 +492,27 @@ checkProjectionLikeness_ names = Bench.billTo [Bench.ProjectionLikeness] $ do
_ -> reportSLn "tc.proj.like" 25 $
"mutual definitions are not considered for projection-likeness"
+-- | Freeze metas created by given computation if in abstract mode.
+whenAbstractFreezeMetasAfter :: Info.DefInfo -> TCM a -> TCM a
+whenAbstractFreezeMetasAfter Info.DefInfo{ defAccess, defAbstract} m = do
+ let pubAbs = defAccess == PublicAccess && defAbstract == AbstractDef
+ if not pubAbs then m else do
+ (a, ms) <- metasCreatedBy m
+ xs <- freezeMetas' $ (`Set.member` ms)
+ reportSDoc "tc.decl.ax" 20 $ vcat
+ [ text "Abstract type signature produced new metas: " <+> sep (map prettyTCM $ Set.toList ms)
+ , text "We froze the following ones of these: " <+> sep (map prettyTCM xs)
+ ]
+ return a
+
-- | Type check an axiom.
-checkAxiom :: A.Axiom -> Info.DefInfo -> ArgInfo -> QName -> A.Expr -> TCM ()
-checkAxiom funSig i info0 x e = do
+checkAxiom :: A.Axiom -> Info.DefInfo -> ArgInfo ->
+ Maybe [Occurrence] -> QName -> A.Expr -> TCM ()
+checkAxiom funSig i info0 mp x e = whenAbstractFreezeMetasAfter i $ do
+ -- Andreas, 2016-07-19 issues #418 #2102:
+ -- We freeze metas in type signatures of abstract definitions, to prevent
+ -- leakage of implementation details.
+
-- Andreas, 2012-04-18 if we are in irrelevant context, axioms is irrelevant
-- even if not declared as such (Issue 610).
rel <- max (getRelevance info0) <$> asks envRelevance
@@ -462,37 +525,48 @@ checkAxiom funSig i info0 x e = do
, nest 2 $ text "of sort " <+> prettyTCM (getSort t)
]
- -- check macro type if necessary
- when (Info.defMacro i == MacroDef) $ do
- t' <- normalise t
- TelV tel tr <- telView t'
-
- let telList = telToList tel
- resType = abstract (telFromList (drop (length telList - 1) telList)) tr
- expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit)
- equalType resType expectedType
- `catchError` \ _ -> typeError . GenericDocError =<< sep [ text "Result type of a macro must be"
- , nest 2 $ prettyTCM expectedType ]
-
-- Andreas, 2015-03-17 Issue 1428: Do not postulate sizes in parametrized
-- modules!
when (funSig == A.NoFunSig) $ do
whenM ((== SizeUniv) <$> do reduce $ getSort t) $ do
whenM ((> 0) <$> getContextSize) $ do
typeError $ GenericError $ "We don't like postulated sizes in parametrized modules."
+
+ -- Ensure that polarity pragmas do not contain too many occurrences.
+ (occs, pols) <- case mp of
+ Nothing -> return ([], [])
+ Just occs -> do
+ TelV tel _ <- telView t
+ let n = genericLength (telToList tel)
+ when (n < genericLength occs) $
+ typeError $ TooManyPolarities x n
+ let pols = map polFromOcc occs
+ reportSLn "tc.polarity.pragma" 10 $
+ "Setting occurrences and polarity for " ++ show x ++ ":\n " ++
+ show occs ++ "\n " ++ show pols
+ return (occs, pols)
+
-- Not safe. See Issue 330
-- t <- addForcingAnnotations t
addConstant x =<< do
- useTerPragma $ defaultDefn info x t $
- case funSig of
- A.FunSig -> emptyFunction
- A.NoFunSig -> Axiom -- NB: used also for data and record type sigs
+ useTerPragma $
+ (defaultDefn info x t $
+ case funSig of
+ A.FunSig -> set funMacro (Info.defMacro i == MacroDef) emptyFunction
+ A.NoFunSig -> Axiom) -- NB: used also for data and record type sigs
+ { defArgOccurrences = occs
+ , defPolarity = pols
+ }
-- Add the definition to the instance table, if needed
when (Info.defInstance i == InstanceDef) $ do
addTypedInstance x t
- traceCall (IsType_ e) $ solveSizeConstraints DefaultToInfty -- need Range for error message
+ traceCall (IsType_ e) $ do -- need Range for error message
+ -- Andreas, 2016-06-21, issue #2054
+ -- Do not default size metas to ∞ in local type signatures
+ checkingWhere <- asks envCheckingWhere
+ solveSizeConstraints $ if checkingWhere then DontDefaultToInfty else DefaultToInfty
-- Andreas, 2011-05-31, that freezing below is probably wrong:
-- when_ (Info.defAbstract i == AbstractDef) $ freezeMetas
@@ -662,11 +736,6 @@ checkPragma r p =
addCoreType x dt'
sequence_ $ zipWith addCoreConstr cs cons'
_ -> typeError $ GenericError "COMPILED_DATA_UHC on non datatype"
- A.NoSmashingPragma x -> do
- def <- getConstInfo x
- case theDef def of
- Function{} -> markNoSmashing x
- _ -> typeError $ GenericError "NO_SMASHING directive only works on functions"
A.StaticPragma x -> do
def <- getConstInfo x
case theDef def of
@@ -685,43 +754,42 @@ checkPragma r p =
-- All definitions which have so far been assigned to the given mutual
-- block are returned.
checkMutual :: Info.MutualInfo -> [A.Declaration] -> TCM (MutualId, Set QName)
-checkMutual i ds = inMutualBlock $ do
+checkMutual i ds = inMutualBlock $ \ blockId -> do
- blockId <- currentOrFreshMutualBlock
verboseS "tc.decl.mutual" 20 $ do
reportSDoc "tc.decl.mutual" 20 $ vcat $
(text "Checking mutual block" <+> text (show blockId) <> text ":") :
map (nest 2 . prettyA) ds
+ insertMutualBlockInfo blockId i
local (\e -> e { envTerminationCheck = () <$ Info.mutualTermCheck i }) $
mapM_ checkDecl ds
- (blockId, ) <$> lookupMutualBlock blockId
+ (blockId, ) . mutualNames <$> lookupMutualBlock blockId
-- | Type check the type signature of an inductive or recursive definition.
checkTypeSignature :: A.TypeSignature -> TCM ()
checkTypeSignature (A.ScopedDecl scope ds) = do
setScope scope
mapM_ checkTypeSignature ds
-checkTypeSignature (A.Axiom funSig i info x e) =
- case Info.defAccess i of
- PublicAccess -> inConcreteMode $ checkAxiom funSig i info x e
- PrivateAccess -> inAbstractMode $ checkAxiom funSig i info x e
- OnlyQualified -> __IMPOSSIBLE__
+checkTypeSignature (A.Axiom funSig i info mp x e) =
+ Bench.billTo [Bench.Typing, Bench.TypeSig] $
+ let abstr = case Info.defAccess i of
+ PrivateAccess{}
+ | Info.defAbstract i == AbstractDef -> inAbstractMode
+ -- Issue #2321, only go to AbstractMode for abstract definitions
+ | otherwise -> inConcreteMode
+ PublicAccess -> inConcreteMode
+ OnlyQualified -> __IMPOSSIBLE__
+ in abstr $ checkAxiom funSig i info mp x e
checkTypeSignature _ = __IMPOSSIBLE__ -- type signatures are always axioms
+
-- | Type check a module.
+
checkSection :: Info.ModuleInfo -> ModuleName -> A.Telescope -> [A.Declaration] -> TCM ()
-checkSection i x tel ds =
- checkTelescope tel $ \ tel' -> do
- addSection x
- verboseS "tc.mod.check" 10 $ do
- dx <- prettyTCM x
- dtel <- mapM prettyAs tel
- dtel' <- prettyTCM =<< lookupSection x
- reportSLn "tc.mod.check" 10 $ "checking section " ++ show dx ++ " " ++ show dtel
- reportSLn "tc.mod.check" 10 $ " actual tele: " ++ show dtel'
- withCurrentModule x $ mapM_ checkDeclCached ds
+checkSection _ x tel ds = newSection x tel $ mapM_ checkDeclCached ds
+
-- | Helper for 'checkSectionApplication'.
--
@@ -768,22 +836,20 @@ checkSectionApplication
:: Info.ModuleInfo
-> ModuleName -- ^ Name @m1@ of module defined by the module macro.
-> A.ModuleApplication -- ^ The module macro @λ tel → m2 args@.
- -> A.Ren QName -- ^ Imported names (given as renaming).
- -> A.Ren ModuleName -- ^ Imported modules (given as renaming).
+ -> A.ScopeCopyInfo -- ^ Imported names and modules
-> TCM ()
-checkSectionApplication i m1 modapp rd rm =
+checkSectionApplication i m1 modapp copyInfo =
traceCall (CheckSectionApplication (getRange i) m1 modapp) $
- checkSectionApplication' i m1 modapp rd rm
+ checkSectionApplication' i m1 modapp copyInfo
-- | Check an application of a section.
checkSectionApplication'
:: Info.ModuleInfo
-> ModuleName -- ^ Name @m1@ of module defined by the module macro.
-> A.ModuleApplication -- ^ The module macro @λ tel → m2 args@.
- -> A.Ren QName -- ^ Imported names (given as renaming).
- -> A.Ren ModuleName -- ^ Imported modules (given as renaming).
+ -> A.ScopeCopyInfo -- ^ Imported names and modules
-> TCM ()
-checkSectionApplication' i m1 (A.SectionApp ptel m2 args) rd rm = do
+checkSectionApplication' i m1 (A.SectionApp ptel m2 args) copyInfo = do
-- Module applications can appear in lets, in which case we treat
-- lambda-bound variables as additional parameters to the module.
extraParams <- do
@@ -825,17 +891,22 @@ checkSectionApplication' i m1 (A.SectionApp ptel m2 args) rd rm = do
]
-- Andreas, 2014-04-06, Issue 1094:
-- Add the section with well-formed telescope.
- addCtxTel aTel $ addSection m1
+ addContext aTel $ do
+ reportSDoc "tc.mod.apply" 80 $
+ text "addSection" <+> prettyTCM m1 <+> (getContextTelescope >>= \ tel -> inTopContext (prettyTCM tel))
+ addSection m1
reportSDoc "tc.mod.apply" 20 $ vcat
[ sep [ text "applySection", prettyTCM m1, text "=", prettyTCM m2, fsep $ map prettyTCM (vs ++ ts) ]
- , nest 2 $ text " defs:" <+> text (show rd)
- , nest 2 $ text " mods:" <+> text (show rm)
+ , nest 2 $ pretty copyInfo
]
args <- instantiateFull $ vs ++ ts
- applySection m1 ptel m2 args rd rm
+ let n = size aTel
+ etaArgs <- inTopContext $ addContext aTel getContextArgs
+ addContext' aTel $
+ applySection m1 (ptel `abstract` aTel) m2 (raise n args ++ etaArgs) copyInfo
-checkSectionApplication' i m1 (A.RecordModuleIFS x) rd rm = do
+checkSectionApplication' i m1 (A.RecordModuleIFS x) copyInfo = do
let name = mnameToQName x
tel' <- lookupSection x
vs <- freeVarsToApply name
@@ -853,7 +924,7 @@ checkSectionApplication' i m1 (A.RecordModuleIFS x) rd rm = do
instFinal (ExtendTel (Dom info t) (Abs n EmptyTel)) =
ExtendTel (Dom ifo' t) (Abs n EmptyTel)
where ifo' = setHiding Instance info
- -- Otherwise, keep searchinf for last parameter:
+ -- Otherwise, keep searching for last parameter:
instFinal (ExtendTel arg (Abs n tel)) =
ExtendTel arg (Abs n (instFinal tel))
-- Before instFinal is invoked, we have checked that the @tel@ is not empty.
@@ -875,7 +946,7 @@ checkSectionApplication' i m1 (A.RecordModuleIFS x) rd rm = do
when (tel == EmptyTel) $
typeError $ GenericError $ show (qnameToConcrete name) ++ " is not a parameterised section"
- addCtxTel telInst $ do
+ addContext' telInst $ do
vs <- freeVarsToApply name
reportSDoc "tc.mod.apply" 20 $ vcat
[ nest 2 $ text "vs =" <+> sep (map prettyTCM vs)
@@ -885,7 +956,8 @@ checkSectionApplication' i m1 (A.RecordModuleIFS x) rd rm = do
[ nest 2 $ text "vs =" <+> text (show vs)
, nest 2 $ text "args =" <+> text (show args)
]
- applySection m1 telInst x (vs ++ args) rd rm
+ addSection m1
+ applySection m1 telInst x (vs ++ args) copyInfo
-- | Type check an import declaration. Actually doesn't do anything, since all
-- the work is done when scope checking.
diff --git a/src/full/Agda/TypeChecking/Rules/Decl.hs-boot b/src/full/Agda/TypeChecking/Rules/Decl.hs-boot
index 69f6d41..4db1f27 100644
--- a/src/full/Agda/TypeChecking/Rules/Decl.hs-boot
+++ b/src/full/Agda/TypeChecking/Rules/Decl.hs-boot
@@ -2,11 +2,9 @@
module Agda.TypeChecking.Rules.Decl where
import Agda.Syntax.Info (ModuleInfo)
-import Agda.Syntax.Abstract (QName, Declaration, ModuleName, ModuleApplication, Ren)
+import Agda.Syntax.Abstract (QName, Declaration, ModuleName, ModuleApplication, ScopeCopyInfo)
import Agda.TypeChecking.Monad (TCM)
checkDecls :: [Declaration] -> TCM ()
checkDecl :: Declaration -> TCM ()
-checkSectionApplication ::
- ModuleInfo -> ModuleName -> ModuleApplication ->
- Ren QName -> Ren ModuleName -> TCM ()
+checkSectionApplication :: ModuleInfo -> ModuleName -> ModuleApplication -> ScopeCopyInfo -> TCM ()
diff --git a/src/full/Agda/TypeChecking/Rules/Def.hs b/src/full/Agda/TypeChecking/Rules/Def.hs
index 56b9782..381be77 100644
--- a/src/full/Agda/TypeChecking/Rules/Def.hs
+++ b/src/full/Agda/TypeChecking/Rules/Def.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Rules.Def where
@@ -15,11 +13,14 @@ import Data.Function
import Data.List hiding (sort)
import Data.Maybe
import Data.Traversable
+import qualified Data.Set as Set
import Agda.Syntax.Common
+import qualified Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete (exprFieldA)
import Agda.Syntax.Position
import qualified Agda.Syntax.Abstract as A
+import qualified Agda.Syntax.Abstract.Views as A
import Agda.Syntax.Internal as I
import Agda.Syntax.Internal.Pattern as I
import qualified Agda.Syntax.Info as Info
@@ -48,9 +49,11 @@ import Agda.TypeChecking.SizedTypes.Solve
import Agda.TypeChecking.RecordPatterns
import Agda.TypeChecking.CompiledClause (CompiledClauses(..))
import Agda.TypeChecking.CompiledClause.Compile
+import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Rules.Term ( checkExpr, inferExpr, inferExprForWith, checkDontExpandLast, checkTelescope )
-import Agda.TypeChecking.Rules.LHS ( checkLeftHandSide, LHSResult(..) )
+import Agda.TypeChecking.Rules.LHS ( checkLeftHandSide, LHSResult(..), bindAsPatterns )
+import Agda.TypeChecking.Rules.LHS.Problem ( AsBinding(..) )
import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl ( checkDecls )
import Agda.Utils.Except ( MonadError(catchError, throwError) )
@@ -59,6 +62,7 @@ import Agda.Utils.Maybe ( whenNothing )
import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Size
+import Agda.Utils.Functor
#include "undefined.h"
import Agda.Utils.Impossible
@@ -73,33 +77,49 @@ checkFunDef delayed i name cs = do
t <- typeOfConst name
info <- flip setRelevance defaultArgInfo <$> relOfConst name
case isAlias cs t of
- Just (e, x) ->
+ Just (e, mc, x) ->
traceCall (CheckFunDef (getRange i) (qnameName name) cs) $ do
-- Andreas, 2012-11-22: if the alias is in an abstract block
-- it has been frozen. We unfreeze it to enable type inference.
-- See issue 729.
whenM (isFrozen x) $ unfreezeMeta x
- checkAlias t info delayed i name e
+ checkAlias t info delayed i name e mc
_ -> checkFunDef' t info delayed Nothing Nothing i name cs
+ -- If it's a macro check that it ends in Term → TC ⊤
+ ismacro <- isMacro . theDef <$> getConstInfo name
+ when (ismacro || Info.defMacro i =