summaryrefslogtreecommitdiff
path: root/src/full
diff options
context:
space:
mode:
Diffstat (limited to 'src/full')
-rw-r--r--src/full/Agda/Auto/Auto.hs126
-rw-r--r--src/full/Agda/Auto/CaseSplit.hs4
-rw-r--r--src/full/Agda/Auto/Convert.hs8
-rw-r--r--src/full/Agda/Auto/NarrowingSearch.hs17
-rw-r--r--src/full/Agda/Auto/SearchControl.hs41
-rw-r--r--src/full/Agda/Auto/Syntax.hs2
-rw-r--r--src/full/Agda/Auto/Typecheck.hs6
-rw-r--r--src/full/Agda/Compiler/CallCompiler.hs2
-rw-r--r--src/full/Agda/Compiler/Epic/Erasure.hs25
-rw-r--r--src/full/Agda/Compiler/Epic/ForceConstrs.hs18
-rw-r--r--src/full/Agda/Compiler/Epic/Forcing.hs2
-rw-r--r--src/full/Agda/Compiler/Epic/FromAgda.hs6
-rw-r--r--src/full/Agda/Compiler/Epic/Injection.hs23
-rw-r--r--src/full/Agda/Compiler/Epic/Interface.hs2
-rw-r--r--src/full/Agda/Compiler/Epic/Static.hs5
-rw-r--r--src/full/Agda/Compiler/JS/Compiler.hs17
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Compiler.hs65
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Pretty.hs6
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Primitives.hs1
-rw-r--r--src/full/Agda/Interaction/BasicOps.hs86
-rw-r--r--src/full/Agda/Interaction/CommandLine.hs (renamed from src/full/Agda/Interaction/CommandLine/CommandLine.hs)30
-rw-r--r--src/full/Agda/Interaction/EmacsCommand.hs3
-rw-r--r--src/full/Agda/Interaction/Exceptions.hs6
-rw-r--r--src/full/Agda/Interaction/Highlighting/Generate.hs71
-rw-r--r--src/full/Agda/Interaction/Highlighting/HTML.hs61
-rw-r--r--src/full/Agda/Interaction/Highlighting/LaTeX.hs2
-rw-r--r--src/full/Agda/Interaction/Highlighting/Precise.hs18
-rw-r--r--src/full/Agda/Interaction/Imports.hs55
-rw-r--r--src/full/Agda/Interaction/InteractionTop.hs136
-rw-r--r--src/full/Agda/Interaction/InteractionTop.hs-boot5
-rw-r--r--src/full/Agda/Interaction/MakeCase.hs23
-rw-r--r--src/full/Agda/Interaction/Monad.hs3
-rw-r--r--src/full/Agda/Interaction/Options.hs133
-rw-r--r--src/full/Agda/Interaction/Response.hs5
-rw-r--r--src/full/Agda/Main.hs58
-rw-r--r--src/full/Agda/Syntax/Abstract.hs79
-rw-r--r--src/full/Agda/Syntax/Abstract/Copatterns.hs31
-rw-r--r--src/full/Agda/Syntax/Abstract/Name.hs44
-rw-r--r--src/full/Agda/Syntax/Abstract/Name.hs-boot10
-rw-r--r--src/full/Agda/Syntax/Abstract/Views.hs10
-rw-r--r--src/full/Agda/Syntax/Common.hs128
-rw-r--r--src/full/Agda/Syntax/Concrete.hs134
-rw-r--r--src/full/Agda/Syntax/Concrete/Definitions.hs232
-rw-r--r--src/full/Agda/Syntax/Concrete/Generic.hs9
-rw-r--r--src/full/Agda/Syntax/Concrete/Name.hs35
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators.hs219
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators/Parser.hs24
-rw-r--r--src/full/Agda/Syntax/Concrete/Pretty.hs117
-rw-r--r--src/full/Agda/Syntax/Fixity.hs110
-rw-r--r--src/full/Agda/Syntax/Fixity.hs-boot3
-rw-r--r--src/full/Agda/Syntax/Info.hs6
-rw-r--r--src/full/Agda/Syntax/Internal.hs484
-rw-r--r--src/full/Agda/Syntax/Internal/Defs.hs8
-rw-r--r--src/full/Agda/Syntax/Internal/Generic.hs11
-rw-r--r--src/full/Agda/Syntax/Internal/Pattern.hs30
-rw-r--r--src/full/Agda/Syntax/Notation.hs18
-rw-r--r--src/full/Agda/Syntax/Parser/LookAhead.hs2
-rw-r--r--src/full/Agda/Syntax/Parser/Monad.hs85
-rw-r--r--src/full/Agda/Syntax/Parser/Parser.y144
-rw-r--r--src/full/Agda/Syntax/Position.hs142
-rw-r--r--src/full/Agda/Syntax/Scope/Base.hs13
-rw-r--r--src/full/Agda/Syntax/Scope/Monad.hs84
-rw-r--r--src/full/Agda/Syntax/Translation/AbstractToConcrete.hs279
-rw-r--r--src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs297
-rw-r--r--src/full/Agda/Syntax/Translation/InternalToAbstract.hs539
-rw-r--r--src/full/Agda/Termination/CallGraph.hs39
-rw-r--r--src/full/Agda/Termination/CallMatrix.hs40
-rw-r--r--src/full/Agda/Termination/CutOff.hs4
-rw-r--r--src/full/Agda/Termination/Inlining.hs38
-rw-r--r--src/full/Agda/Termination/Monad.hs198
-rw-r--r--src/full/Agda/Termination/Order.hs9
-rw-r--r--src/full/Agda/Termination/SparseMatrix.hs18
-rw-r--r--src/full/Agda/Termination/TermCheck.hs480
-rw-r--r--src/full/Agda/Tests.hs2
-rw-r--r--src/full/Agda/TypeChecking/Abstract.hs14
-rw-r--r--src/full/Agda/TypeChecking/CheckInternal.hs51
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause.hs12
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause/Match.hs206
-rw-r--r--src/full/Agda/TypeChecking/Constraints.hs7
-rw-r--r--src/full/Agda/TypeChecking/Conversion.hs201
-rw-r--r--src/full/Agda/TypeChecking/Coverage.hs73
-rw-r--r--src/full/Agda/TypeChecking/Coverage/Match.hs11
-rw-r--r--src/full/Agda/TypeChecking/DisplayForm.hs16
-rw-r--r--src/full/Agda/TypeChecking/DropArgs.hs5
-rw-r--r--src/full/Agda/TypeChecking/Empty.hs38
-rw-r--r--src/full/Agda/TypeChecking/Errors.hs1824
-rw-r--r--src/full/Agda/TypeChecking/EtaContract.hs10
-rw-r--r--src/full/Agda/TypeChecking/Forcing.hs162
-rw-r--r--src/full/Agda/TypeChecking/Free.hs8
-rw-r--r--src/full/Agda/TypeChecking/Implicit.hs22
-rw-r--r--src/full/Agda/TypeChecking/Injectivity.hs8
-rw-r--r--src/full/Agda/TypeChecking/InstanceArguments.hs238
-rw-r--r--src/full/Agda/TypeChecking/Irrelevance.hs18
-rw-r--r--src/full/Agda/TypeChecking/Level.hs6
-rw-r--r--src/full/Agda/TypeChecking/MetaVars.hs97
-rw-r--r--src/full/Agda/TypeChecking/MetaVars/Mention.hs8
-rw-r--r--src/full/Agda/TypeChecking/MetaVars/Occurs.hs245
-rw-r--r--src/full/Agda/TypeChecking/Monad/Base.hs199
-rw-r--r--src/full/Agda/TypeChecking/Monad/Base.hs-boot2
-rw-r--r--src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs25
-rw-r--r--src/full/Agda/TypeChecking/Monad/Base/KillRange.hs19
-rw-r--r--src/full/Agda/TypeChecking/Monad/Benchmark.hs102
-rw-r--r--src/full/Agda/TypeChecking/Monad/Builtin.hs51
-rw-r--r--src/full/Agda/TypeChecking/Monad/Constraints.hs2
-rw-r--r--src/full/Agda/TypeChecking/Monad/Context.hs24
-rw-r--r--src/full/Agda/TypeChecking/Monad/Exception.hs6
-rw-r--r--src/full/Agda/TypeChecking/Monad/MetaVars.hs50
-rw-r--r--src/full/Agda/TypeChecking/Monad/Mutual.hs9
-rw-r--r--src/full/Agda/TypeChecking/Monad/Options.hs29
-rw-r--r--src/full/Agda/TypeChecking/Monad/Signature.hs111
-rw-r--r--src/full/Agda/TypeChecking/Monad/SizedTypes.hs10
-rw-r--r--src/full/Agda/TypeChecking/Monad/State.hs9
-rw-r--r--src/full/Agda/TypeChecking/Monad/Statistics.hs16
-rw-r--r--src/full/Agda/TypeChecking/Monad/Trace.hs25
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Abstract.hs9
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Match.hs178
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Match.hs-boot2
-rw-r--r--src/full/Agda/TypeChecking/Polarity.hs9
-rw-r--r--src/full/Agda/TypeChecking/Positivity.hs103
-rw-r--r--src/full/Agda/TypeChecking/Pretty.hs219
-rw-r--r--src/full/Agda/TypeChecking/Pretty.hs-boot3
-rw-r--r--src/full/Agda/TypeChecking/Primitive.hs325
-rw-r--r--src/full/Agda/TypeChecking/ProjectionLike.hs44
-rw-r--r--src/full/Agda/TypeChecking/Quote.hs10
-rw-r--r--src/full/Agda/TypeChecking/RecordPatterns.hs49
-rw-r--r--src/full/Agda/TypeChecking/Records.hs66
-rw-r--r--src/full/Agda/TypeChecking/Reduce.hs141
-rw-r--r--src/full/Agda/TypeChecking/Reduce/Monad.hs7
-rw-r--r--src/full/Agda/TypeChecking/Rewriting.hs192
-rw-r--r--src/full/Agda/TypeChecking/Rewriting.hs-boot2
-rw-r--r--src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs266
-rw-r--r--src/full/Agda/TypeChecking/Rules/Builtin.hs86
-rw-r--r--src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs5
-rw-r--r--src/full/Agda/TypeChecking/Rules/Data.hs18
-rw-r--r--src/full/Agda/TypeChecking/Rules/Decl.hs53
-rw-r--r--src/full/Agda/TypeChecking/Rules/Def.hs106
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS.hs132
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs28
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs4
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Problem.hs17
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs5
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Split.hs60
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Unify.hs132
-rw-r--r--src/full/Agda/TypeChecking/Rules/Record.hs11
-rw-r--r--src/full/Agda/TypeChecking/Rules/Term.hs230
-rw-r--r--src/full/Agda/TypeChecking/Rules/Term.hs-boot6
-rw-r--r--src/full/Agda/TypeChecking/Serialise.hs185
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes.hs107
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Solve.hs17
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Syntax.hs15
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs81
-rw-r--r--src/full/Agda/TypeChecking/Substitute.hs191
-rw-r--r--src/full/Agda/TypeChecking/SyntacticEquality.hs16
-rw-r--r--src/full/Agda/TypeChecking/Telescope.hs36
-rw-r--r--src/full/Agda/TypeChecking/Test/Generators.hs14
-rw-r--r--src/full/Agda/TypeChecking/Unquote.hs9
-rw-r--r--src/full/Agda/TypeChecking/With.hs382
-rw-r--r--src/full/Agda/Utils/AssocList.hs2
-rw-r--r--src/full/Agda/Utils/Bag.hs15
-rw-r--r--src/full/Agda/Utils/BiMap.hs12
-rw-r--r--src/full/Agda/Utils/Cluster.hs6
-rw-r--r--src/full/Agda/Utils/Empty.hs2
-rw-r--r--src/full/Agda/Utils/Except.hs5
-rw-r--r--src/full/Agda/Utils/Favorites.hs34
-rw-r--r--src/full/Agda/Utils/FileName.hs10
-rw-r--r--src/full/Agda/Utils/Functor.hs17
-rw-r--r--src/full/Agda/Utils/Graph/AdjacencyMap.hs4
-rw-r--r--src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs8
-rw-r--r--src/full/Agda/Utils/Impossible.hs2
-rw-r--r--src/full/Agda/Utils/Lens.hs18
-rw-r--r--src/full/Agda/Utils/Lens/Examples.hs2
-rw-r--r--src/full/Agda/Utils/List.hs4
-rw-r--r--src/full/Agda/Utils/ListT.hs116
-rw-r--r--src/full/Agda/Utils/ListT/Tests.hs52
-rw-r--r--src/full/Agda/Utils/Map/Compat.hs20
-rw-r--r--src/full/Agda/Utils/Maybe/Strict.hs15
-rw-r--r--src/full/Agda/Utils/Monad.hs20
-rw-r--r--src/full/Agda/Utils/Null.hs20
-rw-r--r--src/full/Agda/Utils/PartialOrd.hs6
-rw-r--r--src/full/Agda/Utils/Permutation.hs23
-rw-r--r--src/full/Agda/Utils/Permutation/Tests.hs10
-rw-r--r--src/full/Agda/Utils/Pointed.hs19
-rw-r--r--src/full/Agda/Utils/Pointer.hs4
-rw-r--r--src/full/Agda/Utils/Pretty.hs46
-rw-r--r--src/full/Agda/Utils/ReadP.hs23
-rw-r--r--src/full/Agda/Utils/Singleton.hs73
-rw-r--r--src/full/Agda/Utils/Size.hs9
-rw-r--r--src/full/Agda/Utils/String.hs24
-rw-r--r--src/full/Agda/Utils/Suffix.hs2
-rw-r--r--src/full/Agda/Utils/Time.hs7
-rw-r--r--src/full/Agda/Utils/Trie.hs10
-rw-r--r--src/full/Agda/Utils/Tuple.hs8
-rw-r--r--src/full/Agda/Utils/Warshall.hs3
193 files changed, 8033 insertions, 5384 deletions
diff --git a/src/full/Agda/Auto/Auto.hs b/src/full/Agda/Auto/Auto.hs
index d18b0ff..3643e7b 100644
--- a/src/full/Agda/Auto/Auto.hs
+++ b/src/full/Agda/Auto/Auto.hs
@@ -1,6 +1,10 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
module Agda.Auto.Auto (auto) where
import Prelude hiding (null)
@@ -15,14 +19,16 @@ import Data.Functor
import qualified Data.Traversable as Trav
import Agda.Utils.Permutation (permute, takeP)
-import Agda.TypeChecking.Monad.Base
-import Agda.TypeChecking.Monad.MetaVars
-import Agda.TypeChecking.Monad.Context
-import Agda.TypeChecking.Monad.Signature
+import Agda.TypeChecking.Monad hiding (withCurrentModule)
+-- import Agda.TypeChecking.Monad.Base
+-- import Agda.TypeChecking.Monad.MetaVars
+-- import Agda.TypeChecking.Monad.Context
+-- import Agda.TypeChecking.Monad.Signature
import Agda.TypeChecking.Substitute
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Pretty (prettyA)
import qualified Text.PrettyPrint as PP
+import qualified Agda.TypeChecking.Pretty as TCM
import Agda.Syntax.Position
import qualified Agda.Syntax.Internal as I
import Agda.Syntax.Translation.InternalToAbstract
@@ -143,17 +149,23 @@ auto ii rng argstr = do
let (mainm, _, _, _) = tccons Map.! mi
case mode of
MNormal listmode disprove -> do
+ let numsols = if listmode then 10 else 1
+ -- Andreas, 2015-05-17 Issue 1504:
+ -- wish to produce several solutions, as
+ -- the first one might be ill-typed.
+ -- However, currently changing the 1 to something higher makes Agsy loop.
sols <- liftIO $ newIORef ([] :: [[I.Term]])
- nsol <- liftIO $ newIORef $ if listmode then pick + 10 else pick + 1
+ nsol <- liftIO $ newIORef $ pick + numsols
let hsol = do
nsol' <- readIORef nsol
- let cond = if listmode then nsol' <= 10 else nsol' == 1
+ let cond = nsol' <= numsols
when cond $ do
trms <- runExceptT $ mapM (\ (m, _, _, _) -> frommy (Meta m)) $ Map.elems tccons
case trms of
Left{} -> writeIORef nsol $! nsol' + 1
- Right trms -> if listmode then modifyIORef sols (trms :)
- else writeIORef sols [trms]
+ Right trms -> modifyIORef sols (trms :)
+ -- Right trms -> if listmode then modifyIORef sols (trms :)
+ -- else writeIORef sols [trms]
ticks <- liftIO $ newIORef 0
let exsearch initprop recinfo defdfv =
@@ -207,7 +219,7 @@ auto ii rng argstr = do
rsols <- liftM reverse $ liftIO $ readIORef sols
if null rsols then do
nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + (if listmode then 10 else 1) - nsol')
+ dispmsg $ insuffsols (pick + numsols - nsol')
else do
aexprss <- mapM getsols rsols
cexprss <- forM aexprss $ mapM $ \(mi, e) -> do
@@ -261,55 +273,77 @@ auto ii rng argstr = do
rsols <- liftM reverse $ liftIO $ readIORef sols
if null rsols then do
nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + 10 - nsol') ++ timeoutString
+ dispmsg $ insuffsols (pick + numsols - nsol') ++ timeoutString
else do
aexprss <- mapM getsols rsols
- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss
+ -- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss
+ cexprss <- forM aexprss $ do
+ mapM $ \ (mi, e) -> do
+ mv <- lookupMeta mi
+ withMetaInfo (getMetaInfo mv) $ do
+ e' <- abstractToConcrete_ e
+ return (mi, e')
let disp [(_, cexpr)] = show cexpr
- disp cexprs = concat (map (\(mi, cexpr) -> case lookup mi riis of {Nothing -> show mi; Just ii -> show ii} ++ " := " ++ show cexpr ++ " ") cexprs)
+ disp cexprs = concat $ for cexprs $ \ (mi, cexpr) ->
+ maybe (show mi) show (lookup mi riis)
+ ++ " := " ++ show cexpr ++ " "
ticks <- liftIO $ readIORef ticks
dispmsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++
"\n" ++ unlines (map (\(x, y) -> show y ++ " " ++ disp x) $ zip cexprss [pick..])
- else
+ else {- not listmode -}
case res of
Nothing -> do
nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + 1 - nsol') ++ timeoutString
+ dispmsg $ insuffsols (pick + numsols - nsol') ++ timeoutString
Just depthreached -> do
ticks <- liftIO $ readIORef ticks
rsols <- liftIO $ readIORef sols
case rsols of
- [] -> do
- nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + 1 - nsol')
- (term : _) -> do
- exprs <- getsols term
- giveress <-
- mapM (\(mi, expr) ->
- case lookup mi riis of
- Nothing ->
- catchError
- (giveExpr mi expr >>= \_ -> return (Nothing, Nothing))
- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi)))
- Just ii' -> do ae <- give ii' Nothing expr
- mv <- lookupMeta mi
- let scope = getMetaScope mv
- ce <- abstractToConcreteEnv (makeEnv scope) ae
- let cmnt = if ii' == ii then agsyinfo ticks else ""
- return (Just (ii', show ce ++ cmnt), Nothing)
- ) exprs
- let msg = if length exprs == 1 then
- Nothing
- else
- Just $ "Also gave solution(s) for hole(s)" ++
- concatMap (\(mi', _) ->
- if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii})
- ) exprs
- let msgs = catMaybes $ msg : map snd giveress
- msg' = case msgs of
- [] -> Nothing
- _ -> Just $ unlines msgs
- return (Left $ catMaybes $ map fst giveress, msg')
+ [] -> do
+ nsol' <- liftIO $ readIORef nsol
+ dispmsg $ insuffsols (pick + numsols - nsol')
+ terms -> loop terms where
+ -- Andreas, 2015-05-17 Issue 1504
+ -- If giving a solution failed (e.g. ill-typed)
+ -- we could try the next one.
+ -- However, currently @terms@ is always a singleton list.
+ -- Thus, the following @loop@ is not doing something very
+ -- meaningful.
+ loop [] = return (Left [], Just "")
+ loop (term : terms') = do
+ -- On exception, try next solution
+ flip catchError (const $ loop terms') $ do
+ exprs <- getsols term
+ reportSDoc "auto" 20 $ TCM.text "Trying solution " TCM.<+> TCM.prettyTCM exprs
+ giveress <- forM exprs $ \ (mi, expr) ->
+ case lookup mi riis of
+ Nothing ->
+ -- catchError
+ (giveExpr mi expr >> return (Nothing, Nothing))
+ -- (const retry)
+ -- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi)))
+ Just ii' -> do ae <- give ii' Nothing expr
+ mv <- lookupMeta mi
+ let scope = getMetaScope mv
+ ce <- abstractToConcreteEnv (makeEnv scope) ae
+ let cmnt = if ii' == ii then agsyinfo ticks else ""
+ return (Just (ii', show ce ++ cmnt), Nothing)
+ -- Andreas, 2015-05-17, Issue 1504
+ -- When Agsy produces an ill-typed solution, return nothing.
+ -- TODO: try other solution.
+ -- `catchError` const retry -- (return (Nothing, Nothing))
+ let msg = if length exprs == 1 then
+ Nothing
+ else
+ Just $ "Also gave solution(s) for hole(s)" ++
+ concatMap (\(mi', _) ->
+ if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii})
+ ) exprs
+ let msgs = catMaybes $ msg : map snd giveress
+ msg' = case msgs of
+ [] -> Nothing
+ _ -> Just $ unlines msgs
+ return (Left $ catMaybes $ map fst giveress, msg')
MCaseSplit -> do
case thisdefinfo of
diff --git a/src/full/Agda/Auto/CaseSplit.hs b/src/full/Agda/Auto/CaseSplit.hs
index 5720314..30019f6 100644
--- a/src/full/Agda/Auto/CaseSplit.hs
+++ b/src/full/Agda/Auto/CaseSplit.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.CaseSplit where
diff --git a/src/full/Agda/Auto/Convert.hs b/src/full/Agda/Auto/Convert.hs
index a12e5dd..13718e4 100644
--- a/src/full/Agda/Auto/Convert.hs
+++ b/src/full/Agda/Auto/Convert.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
module Agda.Auto.Convert where
import Control.Applicative hiding (getConst, Const(..))
@@ -462,7 +466,7 @@ fmLevel :: I.MetaId -> I.PlusLevel -> Bool
fmLevel m I.ClosedLevel{} = False
fmLevel m (I.Plus _ l) = case l of
I.MetaLevel m' _ -> m == m'
- I.NeutralLevel v -> fmExp m v
+ I.NeutralLevel _ v -> fmExp m v
I.BlockedLevel _ v -> fmExp m v
I.UnreducedLevel v -> fmExp m v
@@ -667,7 +671,7 @@ frommyClause (ids, pats, mrhs) = do
let (Just ndrop, name) = cdorigin cdef
ps' <- cnvps ndrop ps
let con = I.ConHead name Common.Inductive [] -- TODO: restore record fields!
- return (I.ConP con Nothing ps')
+ return (I.ConP con I.noConPatternInfo ps')
CSPatExp e -> do
e' <- frommyExp e {- renm e -} -- renaming before adding to clause below
return (I.DotP e')
diff --git a/src/full/Agda/Auto/NarrowingSearch.hs b/src/full/Agda/Auto/NarrowingSearch.hs
index 8e60324..89cb007 100644
--- a/src/full/Agda/Auto/NarrowingSearch.hs
+++ b/src/full/Agda/Auto/NarrowingSearch.hs
@@ -1,11 +1,10 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
--- {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.NarrowingSearch where
@@ -19,10 +18,10 @@ import Agda.Utils.Impossible
type Prio = Int
class Trav a blk | a -> blk where
- traverse :: Monad m => (forall b . Trav b blk => MM b blk -> m ()) -> a -> m ()
+ trav :: Monad m => (forall b . Trav b blk => MM b blk -> m ()) -> a -> m ()
instance Trav a blk => Trav (MM a blk) blk where
- traverse f me = f me
+ trav f me = f me
data Term blk = forall a . Trav a blk => Term a
diff --git a/src/full/Agda/Auto/SearchControl.hs b/src/full/Agda/Auto/SearchControl.hs
index ad7d69d..3121909 100644
--- a/src/full/Agda/Auto/SearchControl.hs
+++ b/src/full/Agda/Auto/SearchControl.hs
@@ -1,8 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
module Agda.Auto.SearchControl where
@@ -350,33 +349,27 @@ prioTypecheck True = 0
-- ---------------------------------
instance Trav a blk => Trav [a] blk where
- traverse _ [] = return ()
- traverse f (x:xs) = traverse f x >> traverse f xs
+ trav _ [] = return ()
+ trav f (x:xs) = trav f x >> trav f xs
instance Trav (MId, CExp o) (RefInfo o) where
- traverse f (_, ce) = traverse f ce
+ trav f (_, ce) = trav f ce
instance Trav (TrBr a o) (RefInfo o) where
- traverse f (TrBr es _) = traverse f es
+ trav f (TrBr es _) = trav f es
instance Trav (Exp o) (RefInfo o) where
- traverse f e = case e of
- App _ _ _ args -> traverse f args
- Lam _ (Abs _ b) -> traverse f b
- Pi _ _ _ it (Abs _ ot) -> traverse f it >> traverse f ot
- Sort _ -> return ()
-
- AbsurdLambda{} -> return ()
-
+ trav f e = case e of
+ App _ _ _ args -> trav f args
+ Lam _ (Abs _ b) -> trav f b
+ Pi _ _ _ it (Abs _ ot) -> trav f it >> trav f ot
+ Sort _ -> return ()
+ AbsurdLambda{} -> return ()
instance Trav (ArgList o) (RefInfo o) where
- traverse _ ALNil = return ()
- traverse f (ALCons _ arg args) = traverse f arg >> traverse f args
-
- traverse f (ALProj eas _ _ as) = traverse f eas >> traverse f as
-
-
- traverse f (ALConPar args) = traverse f args
-
+ trav _ ALNil = return ()
+ trav f (ALCons _ arg args) = trav f arg >> trav f args
+ trav f (ALProj eas _ _ as) = trav f eas >> trav f as
+ trav f (ALConPar args) = trav f args
-- ---------------------------------
diff --git a/src/full/Agda/Auto/Syntax.hs b/src/full/Agda/Auto/Syntax.hs
index 849c382..2f997e0 100644
--- a/src/full/Agda/Auto/Syntax.hs
+++ b/src/full/Agda/Auto/Syntax.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
module Agda.Auto.Syntax where
diff --git a/src/full/Agda/Auto/Typecheck.hs b/src/full/Agda/Auto/Typecheck.hs
index f4284f0..037aaeb 100644
--- a/src/full/Agda/Auto/Typecheck.hs
+++ b/src/full/Agda/Auto/Typecheck.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.Typecheck where
diff --git a/src/full/Agda/Compiler/CallCompiler.hs b/src/full/Agda/Compiler/CallCompiler.hs
index 6c3e441..2bd266f 100644
--- a/src/full/Agda/Compiler/CallCompiler.hs
+++ b/src/full/Agda/Compiler/CallCompiler.hs
@@ -75,7 +75,7 @@ callCompiler' cmd args = do
exitcode <- liftIO $ do
-- Ensure that the output has been read before waiting for the
-- process.
- E.evaluate (length errors)
+ _ <- E.evaluate (length errors)
waitForProcess p
case exitcode of
diff --git a/src/full/Agda/Compiler/Epic/Erasure.hs b/src/full/Agda/Compiler/Epic/Erasure.hs
index 3759940..154eb23 100644
--- a/src/full/Agda/Compiler/Epic/Erasure.hs
+++ b/src/full/Agda/Compiler/Epic/Erasure.hs
@@ -24,7 +24,7 @@ import Agda.Compiler.Epic.Interface
import Agda.TypeChecking.Monad.Base (TCM)
import qualified Agda.Syntax.Internal as SI
-import qualified Agda.Syntax.Common as SC
+import qualified Agda.Syntax.Common as Common
import Agda.TypeChecking.Monad (reportSDoc)
import Agda.TypeChecking.Pretty as P
@@ -133,20 +133,19 @@ initiate f@(EpicFun {funName = name, funQName = mqname}) = case mqname of
Nothing -> return ()
initialRels :: SI.Type -> Relevance -> [Relevance]
-initialRels ty rel =
- case SI.unEl ty of
- SI.Pi a b -> mkRel a : initialRels (SI.unAbs b) rel
- _ -> []
+initialRels ty rel = case SI.unEl ty of
+ SI.Pi a b -> mkRel a : initialRels (SI.unAbs b) rel
+ _ -> []
where
mkRel :: SI.Dom SI.Type -> Relevance
- mkRel a | ignoreForced (SC.getRelevance a) = Irr
- mkRel a = case SI.unEl (SC.unDom a) of
- SI.Sort _ -> Irr
- _ -> rel
-
-ignoreForced :: SC.Relevance -> Bool
-ignoreForced SC.Relevant = False
-ignoreForced _ = True
+ mkRel a | ignoreForced (Common.getRelevance a) = Irr
+ mkRel a = case SI.unEl (Common.unDom a) of
+ SI.Sort _ -> Irr
+ _ -> rel
+
+ignoreForced :: Common.Relevance -> Bool
+ignoreForced Common.Relevant = False
+ignoreForced _ = True
-- | Calculate if a variable is relevant in an expression
relevant :: (Functor m, Monad m) => Var -> Expr -> Erasure m Relevance
diff --git a/src/full/Agda/Compiler/Epic/ForceConstrs.hs b/src/full/Agda/Compiler/Epic/ForceConstrs.hs
index b658ea3..ec41aad 100644
--- a/src/full/Agda/Compiler/Epic/ForceConstrs.hs
+++ b/src/full/Agda/Compiler/Epic/ForceConstrs.hs
@@ -9,7 +9,7 @@ import Agda.Compiler.Epic.AuxAST
import Agda.Compiler.Epic.CompileState
import Agda.Compiler.Epic.Interface
-import qualified Agda.Syntax.Common as S
+import qualified Agda.Syntax.Common as Common
import qualified Agda.Syntax.Internal as T
import Agda.TypeChecking.Monad (TCM)
@@ -19,16 +19,16 @@ import Agda.Utils.Impossible
-- | Check which arguments are forced
makeForcedArgs :: T.Type -> ForcedArgs
makeForcedArgs (T.El _ term) = case term of
- T.Pi arg ab -> isRel arg : makeForcedArgs (T.unAbs ab)
- _ -> []
+ T.Pi arg ab -> isRel arg : makeForcedArgs (T.unAbs ab)
+ _ -> []
where
isRel :: T.Dom T.Type -> Forced
- isRel arg = case S.getRelevance arg of
- S.Relevant -> NotForced
- S.Irrelevant -> Forced
- S.UnusedArg -> Forced
- S.NonStrict -> Forced -- can never be executed
- S.Forced -> Forced -- It can be inferred
+ isRel arg = case Common.getRelevance arg of
+ Common.Relevant -> NotForced
+ Common.Irrelevant -> Forced
+ Common.UnusedArg -> Forced
+ Common.NonStrict -> Forced -- can never be executed
+ Common.Forced{} -> Forced -- It can be inferred
-- | Remove forced arguments from constructors and branches
forceConstrs :: [Fun] -> Compile TCM [Fun]
diff --git a/src/full/Agda/Compiler/Epic/Forcing.hs b/src/full/Agda/Compiler/Epic/Forcing.hs
index d7a2fad..d3b06c5 100644
--- a/src/full/Agda/Compiler/Epic/Forcing.hs
+++ b/src/full/Agda/Compiler/Epic/Forcing.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Compiler.Epic.Forcing where
diff --git a/src/full/Agda/Compiler/Epic/FromAgda.hs b/src/full/Agda/Compiler/Epic/FromAgda.hs
index d54842e..1bb545f 100644
--- a/src/full/Agda/Compiler/Epic/FromAgda.hs
+++ b/src/full/Agda/Compiler/Epic/FromAgda.hs
@@ -47,7 +47,6 @@ translateDefn msharp (n, defini) =
f@(Function{}) -> do
let projArgs = projectionArgs f
cc = fromMaybe __IMPOSSIBLE__ $ funCompiled f
- -- let projArgs = maybe 0 (pred . projIndex) (funProjection f)
ccs <- reverseCCBody projArgs <$> normaliseStatic cc
let len = (+ projArgs) . length . clausePats . head . funClauses $ f
toEta = arity (defType defini) - len
@@ -242,11 +241,6 @@ substTerm env term = case T.unSpine term of
del <- getDelayed q
def <- theDef <$> lift (getConstInfo q)
let nr = projectionArgs def
-{- MOVED to Signature.hs
- case def of
- Function{funProjection = Just p} -> pred $ projIndex p
- _ -> 0
- -}
f <- apps name . (replicate nr UNIT ++) <$> mapM (substTerm env . unArg) args
return $ case del of
True -> Lazy f
diff --git a/src/full/Agda/Compiler/Epic/Injection.hs b/src/full/Agda/Compiler/Epic/Injection.hs
index 2ce0887..0729bee 100644
--- a/src/full/Agda/Compiler/Epic/Injection.hs
+++ b/src/full/Agda/Compiler/Epic/Injection.hs
@@ -1,9 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.Epic.Injection where
@@ -26,7 +23,7 @@ import Agda.Syntax.Literal
import Agda.TypeChecking.CompiledClause
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
-import Agda.TypeChecking.Pretty hiding (empty)
+import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.Utils.List
@@ -69,8 +66,8 @@ findInjection defs = do
replaceFunCC :: QName -> CompiledClauses -> Compile TCM ()
replaceFunCC name cc = lift $ do
- stSignature %= \sig -> sig {sigDefinitions = HM.adjust replaceDef name (sigDefinitions sig)}
- stImports %= \imp -> imp {sigDefinitions = HM.adjust replaceDef name (sigDefinitions imp)}
+ stSignature %= updateDefinition name replaceDef
+ stImports %= updateDefinition name replaceDef
where
replaceDef :: Definition -> Definition
replaceDef def = case theDef def of
@@ -123,7 +120,7 @@ substForDot = makeSubst 0 0 . reverse . calcDots
where
makeSubst i accum [] = raiseS (i + accum)
makeSubst i accum (True : ps) = makeSubst i (accum +1) ps
- makeSubst i accum (False : ps) = var (i + accum) :# makeSubst (i+1) accum ps
+ makeSubst i accum (False : ps) = consS (var $ i + accum) $ makeSubst (i+1) accum ps
calcDots = concatMap calcDots' . map namedArg
calcDots' p = case p of
@@ -186,8 +183,8 @@ litInt LitInt{} = True
litInt _ = False
insertAt :: (Nat,Term) -> Term -> Term
-insertAt (index, ins) =
- applySubst ([var i | i <- [0 .. index - 1]] ++# ins :# raiseS (index + 1))
+insertAt (index, ins) = applySubst $
+ [var i | i <- [0 .. index - 1]] ++# consS ins (raiseS $ index + 1)
solve :: [QName] -> [((QName, InjectiveFun), [(QName,QName)])] -> Compile TCM [(QName, InjectiveFun)]
solve newNames xs = do
@@ -216,7 +213,7 @@ solve newNames xs = do
let (hasTags, eqs) = Map.partition isTag (constrGroup tags)
isTag (IsTag _) = True
isTag _ = False
- forM (Map.toList hasTags) $ \ (c, tagged) -> case tagged of
+ forM_ (Map.toList hasTags) $ \ (c, tagged) -> case tagged of
IsTag tag -> putCon c tag
_ -> __IMPOSSIBLE__
case Map.toList eqs of
diff --git a/src/full/Agda/Compiler/Epic/Interface.hs b/src/full/Agda/Compiler/Epic/Interface.hs
index 876f7ce..c37ab6c 100644
--- a/src/full/Agda/Compiler/Epic/Interface.hs
+++ b/src/full/Agda/Compiler/Epic/Interface.hs
@@ -10,7 +10,7 @@ import Data.Function
import Data.Map(Map)
import Data.Monoid
import Data.Set (Set)
-import Data.Typeable
+import Data.Typeable ( Typeable )
import Agda.Syntax.Common (Nat)
import Agda.Syntax.Internal
diff --git a/src/full/Agda/Compiler/Epic/Static.hs b/src/full/Agda/Compiler/Epic/Static.hs
index bb91fe7..13fee87 100644
--- a/src/full/Agda/Compiler/Epic/Static.hs
+++ b/src/full/Agda/Compiler/Epic/Static.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
-- | Find the places where the builtin static is used and do some normalisation
-- there.
diff --git a/src/full/Agda/Compiler/JS/Compiler.hs b/src/full/Agda/Compiler/JS/Compiler.hs
index 7a758a1..37ec59c 100644
--- a/src/full/Agda/Compiler/JS/Compiler.hs
+++ b/src/full/Agda/Compiler/JS/Compiler.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module Agda.Compiler.JS.Compiler where
@@ -444,21 +444,6 @@ isSingleton t = case unEl t of
_ -> return (Nothing)
_ -> return (Nothing)
-{- OBSOLETE, see Signature.hs
-defProjection :: Definition -> Maybe (QName, Int)
-defProjection Defn { theDef = Function { funProjection = p } } = p
-defProjection _ = Nothing
--}
-
-{-
-args :: Maybe Projection -> Args -> TCM [Exp]
-args Nothing as =
- mapM (term . unArg) as
-args (Just p) as = do
- es <- mapM (term . unArg) as
- return (replicate (projIndex p - 1) Undefined ++ es)
--}
-
args :: Int -> Args -> TCM [Exp]
args n as = (replicate n Undefined ++) <$>
mapM (term . unArg) as
diff --git a/src/full/Agda/Compiler/MAlonzo/Compiler.hs b/src/full/Agda/Compiler/MAlonzo/Compiler.hs
index 335499b..7398c73 100644
--- a/src/full/Agda/Compiler/MAlonzo/Compiler.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Compiler.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.MAlonzo.Compiler where
@@ -111,11 +111,8 @@ imports = (++) <$> hsImps <*> imps where
((++) <$> importsForPrim <*> (List.map mazMod <$> mnames))
decl :: HS.ModuleName -> HS.ImportDecl
-#if MIN_VERSION_haskell_src_exts(1,16,0)
decl m = HS.ImportDecl dummy m True False False Nothing Nothing Nothing
-#else
- decl m = HS.ImportDecl dummy m True False Nothing Nothing Nothing
-#endif
+
mnames :: TCM [ModuleName]
mnames = (++) <$> (Set.elems <$> use stImportedModules)
<*> (List.map fst . iImportedModules <$> curIF)
@@ -149,7 +146,7 @@ definitions defs = do
definition :: Maybe CoinductionKit -> Definition -> TCM [HS.Decl]
-- ignore irrelevant definitions
{- Andreas, 2012-10-02: Invariant no longer holds
-definition kit (Defn Forced _ _ _ _ _ _ _ _) = __IMPOSSIBLE__
+definition kit (Defn Forced{} _ _ _ _ _ _ _ _) = __IMPOSSIBLE__
definition kit (Defn UnusedArg _ _ _ _ _ _ _ _) = __IMPOSSIBLE__
definition kit (Defn NonStrict _ _ _ _ _ _ _ _) = __IMPOSSIBLE__
-}
@@ -282,11 +279,8 @@ checkCover q ty n cs = do
(a, _) <- conArityAndPars c
Just (HsDefn _ hsc) <- compiledHaskell . defCompiledRep <$> getConstInfo c
let pat = HS.PApp (HS.UnQual $ HS.Ident hsc) $ genericReplicate a HS.PWildCard
-#if MIN_VERSION_haskell_src_exts(1,16,0)
return $ HS.Alt dummy pat (HS.UnGuardedRhs $ HS.unit_con) (HS.BDecls [])
-#else
- return $ HS.Alt dummy pat (HS.UnGuardedAlt $ HS.unit_con) (HS.BDecls [])
-#endif
+
cs <- mapM makeClause cs
let rhs = case cs of
[] -> fakeExp "()" -- There is no empty case statement in Haskell
@@ -336,11 +330,9 @@ argpatts ps0 bvs = evalStateT (mapM pat' ps0) bvs
pat (ProjP _ ) = lift $ typeError $ NotImplemented $ "Compilation of copatterns"
pat (VarP _ ) = do v <- gets head; modify tail; return v
pat (DotP _ ) = pat (VarP dummy) -- WHY NOT: return HS.PWildCard -- SEE ABOVE
-#if MIN_VERSION_haskell_src_exts(1,16,0)
+ pat (LitP (LitQName _ x)) = return $ litqnamepat x
pat (LitP l ) = return $ HS.PLit HS.Signless $ hslit l
-#else
- pat (LitP l ) = return $ HS.PLit $ hslit l
-#endif
+
pat p@(ConP c _ ps) = do
-- Note that irr is applied once for every subpattern, so in the
-- worst case it is quadratic in the size of the pattern. I
@@ -431,7 +423,7 @@ literal l = case l of
LitInt _ _ -> do toN <- bltQual "NATURAL" mazIntegerToNat
return $ HS.Var toN `HS.App` typed "Integer"
LitFloat _ _ -> return $ typed "Double"
- LitQName _ x -> litqname x
+ LitQName _ x -> return $ litqname x
_ -> return $ l'
where l' = HS.Lit $ hslit l
typed = HS.ExpTypeSig dummy l' . HS.TyCon . rtmQual
@@ -443,13 +435,25 @@ hslit l = case l of LitInt _ x -> HS.Int x
LitChar _ x -> HS.Char x
LitQName _ x -> __IMPOSSIBLE__
-litqname :: QName -> TCM HS.Exp
-litqname x = return $
+litqname :: QName -> HS.Exp
+litqname x =
HS.Con (HS.Qual mazRTE $ HS.Ident "QName") `HS.App`
HS.Lit (HS.Int n) `HS.App`
HS.Lit (HS.Int m) `HS.App`
(rtmError "primQNameType: not implemented") `HS.App`
- (rtmError "primQNameDefinition: not implemented")
+ (rtmError "primQNameDefinition: not implemented") `HS.App`
+ HS.Lit (HS.String $ show x )
+ where
+ NameId n m = nameId $ qnameName x
+
+litqnamepat :: QName -> HS.Pat
+litqnamepat x =
+ HS.PApp (HS.Qual mazRTE $ HS.Ident "QName")
+ [ HS.PLit HS.Signless (HS.Int n)
+ , HS.PLit HS.Signless (HS.Int m)
+ , HS.PWildCard
+ , HS.PWildCard
+ , HS.PWildCard]
where
NameId n m = nameId $ qnameName x
@@ -460,11 +464,7 @@ condecl q = do
cdecl :: QName -> Nat -> HS.ConDecl
cdecl q n = HS.ConDecl (unqhname "C" q)
-#if MIN_VERSION_haskell_src_exts(1,16,0)
[ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1] ]
-#else
- [ HS.UnBangedTy $ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1] ]
-#endif
tvaldecl :: QName
-> Induction
@@ -548,9 +548,9 @@ rteModule = ok $ parse $ unlines
, "{-# RULES \"coerce-id\" forall (x :: a) . mazCoerce x = x #-}"
, ""
, "-- Builtin QNames, the third field is for the type."
- , "data QName a b = QName { nameId, moduleId :: Integer, qnameType :: a, qnameDefinition :: b }"
+ , "data QName a b = QName { nameId, moduleId :: Integer, qnameType :: a, qnameDefinition :: b, qnameString :: String}"
, "instance Eq (QName a b) where"
- , " QName a b _ _ == QName c d _ _ = (a, b) == (c, d)"
+ , " QName a b _ _ _ == QName c d _ _ _ = (a, b) == (c, d)"
, ""
, "mazIncompleteMatch :: String -> a"
, "mazIncompleteMatch s = error (\"MAlonzo Runtime Error: incomplete pattern matching: \" ++ s)"
@@ -558,24 +558,13 @@ rteModule = ok $ parse $ unlines
where
parse :: String -> HS.ParseResult HS.Module
parse = HS.parseModuleWithMode
- HS.defaultParseMode{HS.extensions = [explicitForAll]}
+ HS.defaultParseMode
+ { HS.extensions = [ HS.EnableExtension HS.ExplicitForAll ] }
ok :: HS.ParseResult HS.Module -> HS.Module
ok (HS.ParseOk d) = d
ok HS.ParseFailed{} = __IMPOSSIBLE__
-explicitForAll :: HS.Extension
-explicitForAll =
--- GHC 7.0.1 cannot parse the following CPP conditional
--- error: missing binary operator before token "("
-#if MIN_VERSION_haskell_src_exts(1,14,0)
- HS.EnableExtension HS.ExplicitForAll
-#elif MIN_VERSION_haskell_src_exts(1,12,0)
- HS.ExplicitForAll
-#else
- HS.ExplicitForall
-#endif
-
compileDir :: TCM FilePath
compileDir = do
mdir <- optCompileDir <$> commandLineOptions
diff --git a/src/full/Agda/Compiler/MAlonzo/Pretty.hs b/src/full/Agda/Compiler/MAlonzo/Pretty.hs
index db08a8d..379589e 100644
--- a/src/full/Agda/Compiler/MAlonzo/Pretty.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Pretty.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
------------------------------------------------------------------------
-- Pretty-printing of Haskell modules
diff --git a/src/full/Agda/Compiler/MAlonzo/Primitives.hs b/src/full/Agda/Compiler/MAlonzo/Primitives.hs
index 5cfb6be..944f1ea 100644
--- a/src/full/Agda/Compiler/MAlonzo/Primitives.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Primitives.hs
@@ -240,6 +240,7 @@ primBody s = maybe unimplemented (either (hsVarUQ . HS.Ident) id <$>) $
-- Reflection
, "primQNameEquality" |-> rel "(==)" "MAlonzo.RTE.QName () ()"
+ , "primShowQName" |-> return "MAlonzo.RTE.qnameString"
, "primQNameType" |-> return "MAlonzo.RTE.qnameType"
, "primQNameDefinition" |-> return "MAlonzo.RTE.qnameDefinition"
diff --git a/src/full/Agda/Interaction/BasicOps.hs b/src/full/Agda/Interaction/BasicOps.hs
index 03296ff..938d1fa 100644
--- a/src/full/Agda/Interaction/BasicOps.hs
+++ b/src/full/Agda/Interaction/BasicOps.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
module Agda.Interaction.BasicOps where
@@ -136,7 +136,7 @@ give ii mr e = liftTCM $ do
reportSDoc "interaction.give" 10 $ TP.text "giving expression" TP.<+> prettyTCM e
reportSDoc "interaction.give" 50 $ TP.text $ show $ deepUnScope e
-- Try to give mi := e
- giveExpr mi e `catchError` \ err -> case err of
+ _ <- catchError (giveExpr mi e) $ \ err -> case err of
-- Turn PatternErr into proper error:
PatternErr{} -> do
err <- withInteractionId ii $ TP.text "Failed to give" TP.<+> prettyTCM e
@@ -277,44 +277,48 @@ instance Reify Constraint (OutputConstraint Expr Expr) where
return $ Guard o pid
reify (UnBlock m) = do
mi <- mvInstantiation <$> lookupMeta m
+ m' <- reify (MetaV m [])
case mi of
BlockedConst t -> do
e <- reify t
- m' <- reify (MetaV m [])
return $ Assign m' e
PostponedTypeCheckingProblem cl _ -> enterClosure cl $ \p -> case p of
CheckExpr e a -> do
a <- reify a
- m' <- reify (MetaV m [])
return $ TypedAssign m' e a
+ CheckLambda (Arg ai (xs, mt)) body target -> do
+ domType <- maybe (return underscore) reify mt
+ target <- reify target
+ let bs = TypedBindings noRange $ Arg (mapArgInfoColors (const []) ai) $
+ TBind noRange xs domType
+ e = A.Lam Info.exprNoRange (DomainFull bs) body
+ return $ TypedAssign m' e target
CheckArgs _ _ _ args t0 t1 _ -> do
t0 <- reify t0
t1 <- reify t1
- m <- reify (MetaV m [])
- return $ PostponedCheckArgs m (map (namedThing . unArg) args) t0 t1
+ return $ PostponedCheckArgs m' (map (namedThing . unArg) args) t0 t1
Open{} -> __IMPOSSIBLE__
OpenIFS{} -> __IMPOSSIBLE__
InstS{} -> __IMPOSSIBLE__
InstV{} -> __IMPOSSIBLE__
- reify (FindInScope m mcands) = do
- let cands = caseMaybe mcands [] (\ x -> x)
- m' <- reify (MetaV m [])
- ctxArgs <- getContextArgs
- t <- getMetaType m
- t' <- reify t
- cands' <- mapM (\(tm,ty) -> (,) <$> reify tm <*> reify ty) cands
- return $ FindInScopeOF m' t' cands' -- IFSTODO
+ reify (FindInScope m mcands) = FindInScopeOF
+ <$> (reify $ MetaV m [])
+ <*> (reify =<< getMetaType m)
+ <*> (forM (fromMaybe [] mcands) $ \ (tm, ty) -> do
+ (,) <$> reify tm <*> reify ty)
reify (IsEmpty r a) = IsEmptyType <$> reify a
+-- ASR TODO (28 December 2014): This function will be unnecessary when
+-- using a Pretty instance for OutputConstraint instead of the Show
+-- instance.
showComparison :: Comparison -> String
-showComparison CmpEq = " = "
-showComparison CmpLeq = " =< "
+showComparison cmp = " " ++ prettyShow cmp ++ " "
instance (Show a,Show b) => Show (OutputForm a b) where
show o =
case o of
OutputForm r 0 c -> show c ++ range r
- OutputForm r pid c -> "[" ++ show pid ++ "] " ++ show c ++ range r
+ OutputForm r pid c -> "[" ++ prettyShow pid ++ "] " ++ show c ++ range r
where
range r | null s = ""
| otherwise = " [ at " ++ s ++ " ]"
@@ -330,7 +334,7 @@ instance (Show a,Show b) => Show (OutputConstraint a b) where
show (CmpLevels cmp t t') = show t ++ showComparison cmp ++ show t'
show (CmpTeles cmp t t') = show t ++ showComparison cmp ++ show t'
show (CmpSorts cmp s s') = show s ++ showComparison cmp ++ show s'
- show (Guard o pid) = show o ++ " [blocked by problem " ++ show pid ++ "]"
+ show (Guard o pid) = show o ++ " [blocked by problem " ++ prettyShow pid ++ "]"
show (Assign m e) = show m ++ " := " ++ show e
show (TypedAssign m e a) = show m ++ " := " ++ show e ++ " :? " ++ show a
show (PostponedCheckArgs m es t0 t1) = show m ++ " := (_ : " ++ show t0 ++ ") " ++ unwords (map (paren . show) es)
@@ -338,9 +342,11 @@ instance (Show a,Show b) => Show (OutputConstraint a b) where
where paren s | elem ' ' s = "(" ++ s ++ ")"
| otherwise = s
show (IsEmptyType a) = "Is empty: " ++ show a
- show (FindInScopeOF s t cs) = "Resolve instance argument " ++ showCand (s,t) ++ ". Candidates: [" ++
- intercalate ", " (map showCand cs) ++ "]"
- where showCand (tm,ty) = show tm ++ " : " ++ show ty
+ show (FindInScopeOF s t cs) = "Resolve instance argument " ++ showCand (s,t) ++ ".\n Candidates:\n [ " ++
+ intercalate "\n , " (map showCand cs) ++ " ]"
+ where showCand (tm,ty) = indent 6 $ show tm ++ " : " ++ show ty
+ indent n s = intercalate ("\n" ++ replicate n ' ') (l:ls)
+ where l:ls = lines s
instance (ToConcrete a c, ToConcrete b d) =>
ToConcrete (OutputForm a b) (OutputForm c d) where
@@ -387,11 +393,7 @@ instance ToConcrete InteractionId C.Expr where
instance ToConcrete NamedMeta C.Expr where
toConcrete i = do
- return $ C.Underscore noRange (Just $ show i)
-
-judgToOutputForm :: Judgement a c -> OutputConstraint a c
-judgToOutputForm (HasType e t) = OfType e t
-judgToOutputForm (IsSort s t) = JustSort s
+ return $ C.Underscore noRange (Just $ prettyShow i)
getConstraints :: TCM [OutputForm C.Expr C.Expr]
getConstraints = liftTCM $ do
@@ -445,7 +447,7 @@ typeOfMetaMI norm mi =
withMetaInfo (getMetaInfo mv) $
rewriteJudg mv (mvJudgement mv)
where
- rewriteJudg :: MetaVariable -> Judgement Type MetaId ->
+ rewriteJudg :: MetaVariable -> Judgement MetaId ->
TCM (OutputConstraint Expr NamedMeta)
rewriteJudg mv (HasType i t) = do
ms <- getMetaNameSuggestion i
@@ -458,7 +460,7 @@ typeOfMetaMI norm mi =
[ TP.text "len =" TP.<+> TP.text (show $ length vs)
, TP.text "args =" TP.<+> prettyTCM vs
, TP.text "t =" TP.<+> prettyTCM t
- , TP.text "x =" TP.<+> TP.text (show x)
+ , TP.text "x =" TP.<+> TP.pretty x
]
]
OfType x <$> reify (t `piApply` permute (takeP (size vs) $ mvPermutation mv) vs)
@@ -483,9 +485,14 @@ typesOfHiddenMetas norm = liftTCM $ do
store <- Map.filterWithKey (openAndImplicit is) <$> getMetaStore
mapM (typeOfMetaMI norm) $ Map.keys store
where
- openAndImplicit is x (MetaVar{mvInstantiation = M.Open}) = x `notElem` is
- openAndImplicit is x (MetaVar{mvInstantiation = M.BlockedConst _}) = True
- openAndImplicit _ _ _ = False
+ openAndImplicit is x m =
+ case mvInstantiation m of
+ M.InstV{} -> False
+ M.InstS{} -> False
+ M.Open -> x `notElem` is
+ M.OpenIFS -> x `notElem` is -- OR: True !?
+ M.BlockedConst{} -> True
+ M.PostponedTypeCheckingProblem{} -> False
metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Expr)
metaHelperType norm ii rng s = case words s of
@@ -720,17 +727,14 @@ introTactic pmLambda ii = do
Left err -> return []
Right cov -> mapM showTCM $ concatMap (conName . scPats) $ splitClauses cov
+ introRec :: QName -> TCM [String]
introRec d = do
hfs <- getRecordFieldNames d
fs <- ifM showImplicitArguments
(return $ map unArg hfs)
(return [ unArg a | a <- hfs, getHiding a == NotHidden ])
- return
- [ concat $
- "record {" :
- intersperse ";" (map (\ f -> show f ++ " = ?") fs) ++
- ["}"]
- ]
+ let e = C.Rec noRange $ map (, C.QuestionMark noRange Nothing) fs
+ return [ prettyShow e ]
-- | Runs the given computation as if in an anonymous goal at the end
-- of the top-level module.
diff --git a/src/full/Agda/Interaction/CommandLine/CommandLine.hs b/src/full/Agda/Interaction/CommandLine.hs
index 37c9a30..0ae6ad5 100644
--- a/src/full/Agda/Interaction/CommandLine/CommandLine.hs
+++ b/src/full/Agda/Interaction/CommandLine.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
-module Agda.Interaction.CommandLine.CommandLine where
+module Agda.Interaction.CommandLine where
import Control.Monad.Reader
import Control.Applicative
@@ -27,6 +27,7 @@ import Agda.TypeChecking.Constraints
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Errors
+import Agda.TypeChecking.Pretty ( PrettyTCM(prettyTCM) )
import Agda.TypeChecking.Substitute
import Agda.Utils.Except ( MonadError(catchError) )
@@ -116,12 +117,19 @@ interactionLoop doTypeCheck =
(|>) = (,)
continueAfter :: TCM a -> TCM (ExitCode b)
-continueAfter m = m >> return Continue
+continueAfter m = withCurrentFile $ do
+ m >> return Continue
+
+-- | Set 'envCurrentPath' to 'optInputFile'.
+withCurrentFile :: TCM a -> TCM a
+withCurrentFile cont = do
+ mpath <- getInputFile'
+ local (\ e -> e { envCurrentPath = mpath }) cont
loadFile :: TCM () -> [String] -> TCM ()
-loadFile reload [file] =
- do setInputFile file
- reload
+loadFile reload [file] = do
+ setInputFile file
+ withCurrentFile reload
loadFile _ _ = liftIO $ putStrLn ":load file"
showConstraints :: [String] -> TCM ()
@@ -193,17 +201,17 @@ actOnMeta _ _ = __IMPOSSIBLE__
giveMeta :: [String] -> TCM ()
-giveMeta s | length s >= 2 =
- do actOnMeta s (\ii -> \e -> give ii Nothing e)
- return ()
+giveMeta s | length s >= 2 = do
+ _ <- actOnMeta s (\ii -> \e -> give ii Nothing e)
+ return ()
giveMeta _ = liftIO $ putStrLn $ ": give" ++ " metaid expr"
refineMeta :: [String] -> TCM ()
-refineMeta s | length s >= 2 =
- do actOnMeta s (\ii -> \e -> refine ii Nothing e)
- return ()
+refineMeta s | length s >= 2 = do
+ _ <- actOnMeta s (\ii -> \e -> refine ii Nothing e)
+ return ()
refineMeta _ = liftIO $ putStrLn $ ": refine" ++ " metaid expr"
diff --git a/src/full/Agda/Interaction/EmacsCommand.hs b/src/full/Agda/Interaction/EmacsCommand.hs
index 0f6bd67..76cc29a 100644
--- a/src/full/Agda/Interaction/EmacsCommand.hs
+++ b/src/full/Agda/Interaction/EmacsCommand.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
------------------------------------------------------------------------
-- | Code for instructing Emacs to do things
diff --git a/src/full/Agda/Interaction/Exceptions.hs b/src/full/Agda/Interaction/Exceptions.hs
index 8b6e37f..0c46e82 100644
--- a/src/full/Agda/Interaction/Exceptions.hs
+++ b/src/full/Agda/Interaction/Exceptions.hs
@@ -8,12 +8,14 @@ import Control.Exception as E
import Agda.Syntax.Position
import Agda.Syntax.Parser ( ParseError(..) )
+import Agda.Utils.Pretty
+
handleParseException :: (ParseError -> IO a) -> ParseError -> IO a
handleParseException crash e = crash e
-- | Note that 'failOnException' only catches 'ParseError's.
-failOnException :: (Range -> String -> IO a) -> IO a -> IO a
+failOnException :: (Range -> Doc -> IO a) -> IO a -> IO a
failOnException h m = m `E.catch` handleParseException handler
where
- handler x = h (getRange x) (show x)
+ handler x = h (getRange x) (pretty x)
diff --git a/src/full/Agda/Interaction/Highlighting/Generate.hs b/src/full/Agda/Interaction/Highlighting/Generate.hs
index e073421..0c0fbb1 100644
--- a/src/full/Agda/Interaction/Highlighting/Generate.hs
+++ b/src/full/Agda/Interaction/Highlighting/Generate.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RelaxedPolyRec #-}
+{-# LANGUAGE RelaxedPolyRec #-}
-- | Generates data used for precise syntax highlighting.
@@ -20,10 +20,29 @@ module Agda.Interaction.Highlighting.Generate
import Prelude hiding (null)
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Applicative
+import Control.Arrow ((***), first, second)
+
+import Data.Monoid
+import Data.Generics.Geniplate
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HSet
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.List ((\\), isPrefixOf)
+import qualified Data.Foldable as Fold (toList, fold, foldMap)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+
import Agda.Interaction.FindFile
import Agda.Interaction.Response (Response(Resp_HighlightingInfo))
import Agda.Interaction.Highlighting.Precise hiding (tests)
import Agda.Interaction.Highlighting.Range hiding (tests)
+
import qualified Agda.TypeChecking.Errors as E
import Agda.TypeChecking.MetaVars (isBlockedTerm)
import Agda.TypeChecking.Monad
@@ -31,9 +50,10 @@ import Agda.TypeChecking.Monad
import qualified Agda.TypeChecking.Monad as M
import Agda.TypeChecking.Pretty
import qualified Agda.TypeChecking.Reduce as R
+
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Common (Delayed(..))
-import qualified Agda.Syntax.Common as SC
+import qualified Agda.Syntax.Common as Common
import qualified Agda.Syntax.Concrete as C
import qualified Agda.Syntax.Info as SI
import qualified Agda.Syntax.Internal as I
@@ -41,32 +61,16 @@ import qualified Agda.Syntax.Literal as L
import qualified Agda.Syntax.Parser as Pa
import qualified Agda.Syntax.Parser.Tokens as T
import qualified Agda.Syntax.Position as P
+
+import Agda.Utils.FileName
+import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
+import Agda.Utils.Maybe
+import Agda.Utils.Null
import Agda.Utils.TestHelpers
import Agda.Utils.HashMap (HashMap)
import qualified Agda.Utils.HashMap as HMap
-import Control.Monad
-import Control.Monad.Trans
-import Control.Monad.State
-import Control.Monad.Reader
-import Control.Applicative
-import Control.Arrow ((***), first, second)
-import Data.Monoid
-import Data.Generics.Geniplate
-import Agda.Utils.FileName
-import Data.HashSet (HashSet)
-import qualified Data.HashSet as HSet
-import qualified Data.Map as Map
-import Data.Maybe
-import Data.List ((\\), isPrefixOf)
-import qualified Data.Foldable as Fold (toList, fold, foldMap)
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-
-import Agda.Utils.Functor
-import Agda.Utils.Maybe
-import Agda.Utils.Null
#include "undefined.h"
import Agda.Utils.Impossible
@@ -144,7 +148,7 @@ data Level
generateAndPrintSyntaxInfo :: A.Declaration -> Level -> TCM ()
generateAndPrintSyntaxInfo decl _ | P.noRange == P.getRange decl = return ()
generateAndPrintSyntaxInfo decl hlLevel = do
- file <- envCurrentPath <$> ask
+ file <- fromMaybe __IMPOSSIBLE__ <$> asks envCurrentPath
reportSLn "import.iface.create" 15 $
"Generating syntax info for " ++ filePath file ++ ' ' :
@@ -223,8 +227,10 @@ generateAndPrintSyntaxInfo decl hlLevel = do
bound n = nameToFile modMap file [] (A.nameConcrete n)
(\isOp -> mempty { aspect = Just $ Name (Just Bound) isOp })
(Just $ A.nameBindingSite n)
+
patsyn n = nameToFileA modMap file n True $ \isOp ->
- mempty { aspect = Just $ Name (Just $ Constructor SC.Inductive) isOp }
+ mempty { aspect = Just $ Name (Just $ Constructor Common.Inductive) isOp }
+
field m n = nameToFile modMap file m n
(\isOp -> mempty { aspect = Just $ Name (Just Field) isOp })
Nothing
@@ -232,6 +238,7 @@ generateAndPrintSyntaxInfo decl hlLevel = do
n
(\isOp -> mempty { aspect = Just $ Name (Just Module) isOp })
Nothing
+
mod isTopLevelModule n =
nameToFile modMap file []
(A.nameConcrete n)
@@ -246,7 +253,7 @@ generateAndPrintSyntaxInfo decl hlLevel = do
-- Ulf, 2014-04-09: It would be nicer to have it on Named_ a, but
-- you can't have polymorphic functions in universeBi.
- getNamedArg :: SC.RString -> File
+ getNamedArg :: Common.RString -> File
getNamedArg x = singleton (rToR $ P.getRange x) mempty{ aspect = Just $ Name (Just Argument) False }
getLet :: A.LetBinding -> File
@@ -260,11 +267,11 @@ generateAndPrintSyntaxInfo decl hlLevel = do
getLam (A.DomainFull {}) = mempty
getTyped :: A.TypedBinding -> File
- getTyped (A.TBind _ xs _) = mconcat $ map bound xs
+ getTyped (A.TBind _ xs _) = mconcat $ map (bound . dget) xs
getTyped A.TLet{} = mempty
getPatSynArgs :: A.Declaration -> File
- getPatSynArgs (A.PatternSynDef _ xs _) = mconcat $ map (bound . SC.unArg) xs
+ getPatSynArgs (A.PatternSynDef _ xs _) = mconcat $ map (bound . Common.unArg) xs
getPatSynArgs _ = mempty
getPattern :: A.Pattern -> File
@@ -416,20 +423,20 @@ nameKinds hlLevel decl = do
declToKind (A.Pragma {}) = id
declToKind (A.ScopedDecl {}) = id
declToKind (A.Open {}) = id
- declToKind (A.PatternSynDef q _ _) = insert q (Constructor SC.Inductive)
+ declToKind (A.PatternSynDef q _ _) = insert q (Constructor Common.Inductive)
declToKind (A.FunDef _ q _ _) = insert q Function
declToKind (A.UnquoteDecl _ _ q _) = insert q Function
declToKind (A.DataSig _ q _ _) = insert q Datatype
declToKind (A.DataDef _ q _ cs) = \m ->
insert q Datatype $
foldr (\d -> insert (A.axiomName d)
- (Constructor SC.Inductive))
+ (Constructor Common.Inductive))
m cs
declToKind (A.RecSig _ q _ _) = insert q Record
declToKind (A.RecDef _ q _ c _ _ _) = insert q Record .
case c of
Nothing -> id
- Just q -> insert q (Constructor SC.Inductive)
+ Just q -> insert q (Constructor Common.Inductive)
-- | Generates syntax highlighting information for all constructors
-- occurring in patterns and expressions in the given declaration.
diff --git a/src/full/Agda/Interaction/Highlighting/HTML.hs b/src/full/Agda/Interaction/Highlighting/HTML.hs
index 3c33264..6126ab5 100644
--- a/src/full/Agda/Interaction/Highlighting/HTML.hs
+++ b/src/full/Agda/Interaction/Highlighting/HTML.hs
@@ -5,6 +5,13 @@
module Agda.Interaction.Highlighting.HTML
( generateHTML
+ -- Reused by PandocAgda
+ , defaultCSSFile
+ , generateHTMLWithPageGen
+ , generatePage
+ , page
+ , tokenStream
+ , code
) where
import Control.Applicative
@@ -57,7 +64,22 @@ defaultCSSFile = "Agda.css"
-- completed successfully.
generateHTML :: TCM ()
-generateHTML = do
+generateHTML = generateHTMLWithPageGen pageGen
+ where
+ pageGen dir mod hinfo = generatePage renderer dir mod
+ where
+ renderer css _ contents = page css mod $ code $ tokenStream contents hinfo
+
+-- | Prepare information for HTML page generation.
+--
+-- The page generator receives the file path of the module,
+-- the top level module name of the module
+-- and the highlighting information of the module.
+
+generateHTMLWithPageGen
+ :: (FilePath -> C.TopLevelModuleName -> CompressedFile -> TCM ()) -- ^ Page generator
+ -> TCM ()
+generateHTMLWithPageGen generatePage = do
options <- TCM.commandLineOptions
-- There is a default directory given by 'defaultHTMLDir'
@@ -87,15 +109,14 @@ generateHTML = do
modToFile :: C.TopLevelModuleName -> FilePath
modToFile m = render (pretty m) <.> "html"
--- | Generates an HTML file with a highlighted, hyperlinked version of
--- the given module.
+-- | Generates a highlighted, hyperlinked version of the given module.
generatePage
- :: FilePath -- ^ Directory in which to create files.
+ :: (FilePath -> FilePath -> String -> String) -- ^ Page renderer
+ -> FilePath -- ^ Directory in which to create files.
-> C.TopLevelModuleName -- ^ Module to be highlighted.
- -> HighlightingInfo -- ^ Syntax highlighting info for the module.
-> TCM ()
-generatePage dir mod highlighting = do
+generatePage renderpage dir mod = do
mf <- Map.lookup mod <$> use TCM.stModuleToSource
case mf of
Nothing -> __IMPOSSIBLE__
@@ -103,21 +124,20 @@ generatePage dir mod highlighting = do
contents <- liftIO $ UTF8.readTextFile $ filePath f
css <- maybe defaultCSSFile id . optCSSFile <$>
TCM.commandLineOptions
- let html = page css mod contents highlighting
+ let html = renderpage css (filePath f) contents
TCM.reportSLn "html" 1 $ "Generating HTML for " ++
render (pretty mod) ++
" (" ++ target ++ ")."
- liftIO $ UTF8.writeFile target (renderHtml html)
+ liftIO $ UTF8.writeFile target html
where target = dir </> modToFile mod
-- | Constructs the web page, including headers.
page :: FilePath -- ^ URL to the CSS file.
-> C.TopLevelModuleName -- ^ Module to be highlighted.
- -> String -- ^ The contents of the module.
- -> CompressedFile -- ^ Highlighting information.
-> Html
-page css modName contents info =
+ -> String
+page css modName pagecontent = renderHtml $
header (thetitle << render (pretty modName)
+++
meta ! [ httpequiv "Content-Type"
@@ -133,16 +153,15 @@ page css modName contents info =
, thetype "text/css"
])
+++
- body << pre << code contents info
+ body << pre << pagecontent
--- | Constructs the HTML displaying the code.
+-- | Constructs token stream ready to print.
-code :: String -- ^ The contents of the module.
+tokenStream
+ :: String -- ^ The contents of the module.
-> CompressedFile -- ^ Highlighting information.
- -> Html
-code contents info =
- mconcat $
- map (\(pos, s, mi) -> annotate pos mi (stringToHtml s)) $
+ -> [(Int, String, Aspects)] -- ^ (position, contents, info)
+tokenStream contents info =
map (\cs -> case cs of
(mi, (pos, _)) : _ ->
(pos, map (snd . snd) cs, maybe mempty id mi)
@@ -153,6 +172,12 @@ code contents info =
where
infoMap = toMap (decompress info)
+-- | Constructs the HTML displaying the code.
+
+code :: [(Int, String, Aspects)]
+ -> Html
+code = mconcat . map (\(pos, s, mi) -> annotate pos mi (stringToHtml s))
+ where
annotate :: Int -> Aspects -> Html -> Html
annotate pos mi = anchor ! attributes
where
diff --git a/src/full/Agda/Interaction/Highlighting/LaTeX.hs b/src/full/Agda/Interaction/Highlighting/LaTeX.hs
index 0363fdd..2adf0c6 100644
--- a/src/full/Agda/Interaction/Highlighting/LaTeX.hs
+++ b/src/full/Agda/Interaction/Highlighting/LaTeX.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
-- | Function for generating highlighted and aligned LaTeX from literate
diff --git a/src/full/Agda/Interaction/Highlighting/Precise.hs b/src/full/Agda/Interaction/Highlighting/Precise.hs
index 932dafa..66f8f56 100644
--- a/src/full/Agda/Interaction/Highlighting/Precise.hs
+++ b/src/full/Agda/Interaction/Highlighting/Precise.hs
@@ -47,7 +47,7 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.Typeable (Typeable)
-import qualified Agda.Syntax.Common as C
+import qualified Agda.Syntax.Common as Common
import qualified Agda.Syntax.Concrete as SC
import Agda.Interaction.Highlighting.Range
@@ -72,16 +72,16 @@ data Aspect
-- | @NameKind@s are figured our during scope checking.
data NameKind
- = Bound -- ^ Bound variable.
- | Constructor C.Induction -- ^ Inductive or coinductive constructor.
+ = Bound -- ^ Bound variable.
+ | Constructor Common.Induction -- ^ Inductive or coinductive constructor.
| Datatype
- | Field -- ^ Record field.
+ | Field -- ^ Record field.
| Function
- | Module -- ^ Module name.
+ | Module -- ^ Module name.
| Postulate
- | Primitive -- ^ Primitive.
- | Record -- ^ Record type.
- | Argument -- ^ Named argument, like x in {x = v}
+ | Primitive -- ^ Primitive.
+ | Record -- ^ Record type.
+ | Argument -- ^ Named argument, like x in {x = v}
deriving (Eq, Show, Typeable)
-- | Other aspects, generated by type checking.
@@ -449,7 +449,7 @@ instance CoArbitrary File where
instance Arbitrary CompressedFile where
arbitrary = do
rs <- (\ns1 ns2 -> toRanges $ sort $
- ns1 ++ concatMap (\n -> [n, succ n]) ns2) <$>
+ ns1 ++ concatMap (\n -> [n, succ n]) (ns2 :: [Int])) <$>
arbitrary <*> arbitrary
CompressedFile <$> mapM (\r -> (,) r <$> arbitrary) rs
where
diff --git a/src/full/Agda/Interaction/Imports.hs b/src/full/Agda/Interaction/Imports.hs
index e193baa..02f1ca1 100644
--- a/src/full/Agda/Interaction/Imports.hs
+++ b/src/full/Agda/Interaction/Imports.hs
@@ -1,6 +1,10 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
{-| This module deals with finding imported modules and loading their
interface files.
-}
@@ -28,8 +32,6 @@ import System.FilePath ((</>))
import qualified Text.PrettyPrint.Boxes as Boxes
-import Paths_Agda (getDataFileName)
-
import qualified Agda.Syntax.Abstract as A
import qualified Agda.Syntax.Concrete as C
import Agda.Syntax.Abstract.Name
@@ -46,12 +48,12 @@ import Agda.TypeChecking.Monad.Base.KillRange -- killRange for Signature
import Agda.TypeChecking.Serialise
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Primitive
-import Agda.TypeChecking.Monad.Benchmark (billTop, reimburseTop)
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TheTypeChecker
import Agda.Interaction.FindFile
+import {-# SOURCE #-} Agda.Interaction.InteractionTop (showOpenMetas)
import Agda.Interaction.Options
import qualified Agda.Interaction.Options.Lenses as Lens
import Agda.Interaction.Highlighting.Precise (HighlightingInfo)
@@ -131,7 +133,7 @@ scopeCheckImport x = do
" visited: " ++ intercalate ", " (map (render . pretty) visited)
-- Since scopeCheckImport is called from the scope checker,
-- we need to reimburse her account.
- i <- reimburseTop Bench.Scoping $ getInterface x
+ i <- Bench.billTo [] $ getInterface x
addImport x
return (iModuleName i `withRangesOfQ` mnameToConcrete x, iScope i)
@@ -179,11 +181,11 @@ typeCheckMain f = do
-- liftIO $ putStrLn $ "This is typeCheckMain " ++ show f
-- liftIO . putStrLn . show =<< getVerbosity
reportSLn "import.main" 10 $ "Importing the primitive modules."
- libpath <- liftIO $ getDataFileName "lib"
- reportSLn "import.main" 20 $ "Library path = " ++ show libpath
+ libdir <- liftIO defaultLibDir
+ reportSLn "import.main" 20 $ "Library dir = " ++ show libdir
-- To allow posulating the built-ins, check the primitive module
-- in unsafe mode
- bracket_ (gets $ Lens.getSafeMode) Lens.putSafeMode $ do
+ _ <- bracket_ (gets $ Lens.getSafeMode) Lens.putSafeMode $ do
Lens.putSafeMode False
-- Turn off import-chasing messages.
-- We have to modify the persistent verbosity setting, since
@@ -194,7 +196,7 @@ typeCheckMain f = do
withHighlightingLevel None $
getInterface_ =<< do
moduleName $ mkAbsolute $
- libpath </> "prim" </> "Agda" </> "Primitive.agda"
+ libdir </> "prim" </> "Agda" </> "Primitive.agda"
reportSLn "import.main" 10 $ "Done importing the primitive modules."
-- Now do the type checking via getInterface.
@@ -245,7 +247,7 @@ getInterface' x isMain = do
reportSLn "import.iface" 10 $ " Check for cycle"
checkForImportCycle
- uptodate <- billTop Bench.Import $ do
+ uptodate <- Bench.billTo [Bench.Import] $ do
ignore <- ignoreInterfaces
cached <- isCached file -- if it's cached ignoreInterfaces has no effect
-- to avoid typechecking a file more than once
@@ -279,7 +281,7 @@ getInterface' x isMain = do
else " New module. Let's check it out."
unless (visited || stateChangesIncluded) $ do
mergeInterface i
- billTop Bench.Highlighting $
+ Bench.billTo [Bench.Highlighting] $
ifTopLevelAndHighlightingLevelIs NonInteractive $
highlightFromInterface i file
@@ -324,7 +326,7 @@ getInterface' x isMain = do
let ifile = filePath $ toIFile file
h <- fmap snd <$> getInterfaceFileHashes ifile
mm <- getDecodedModule x
- (cached, mi) <- billTop Bench.Deserialization $ case mm of
+ (cached, mi) <- Bench.billTo [Bench.Deserialization] $ case mm of
Just mi ->
if Just (iFullHash mi) /= h
then do dropDecodedModule x
@@ -516,9 +518,10 @@ createInterface
-> C.TopLevelModuleName -- ^ The expected module name.
-> TCM (Interface, MaybeWarnings)
createInterface file mname =
- local (\e -> e { envCurrentPath = file }) $ do
+ local (\e -> e { envCurrentPath = Just file }) $ do
modFile <- use stModuleToSource
- fileTokenInfo <- billTop Bench.Highlighting $ generateTokenInfo file
+ fileTokenInfo <- Bench.billTo [Bench.Highlighting] $
+ generateTokenInfo file
stTokens .= fileTokenInfo
reportSLn "import.iface.create" 5 $
@@ -531,7 +534,7 @@ createInterface file mname =
previousHsImports <- getHaskellImports
-- Parsing.
- (pragmas, top) <- billTop Bench.Parsing $
+ (pragmas, top) <- Bench.billTo [Bench.Parsing] $
liftIO $ parseFile' moduleParser file
pragmas <- concat <$> concreteToAbstract_ pragmas
@@ -542,20 +545,20 @@ createInterface file mname =
mapM_ setOptionsFromPragma options
-- Scope checking.
- topLevel <- billTop Bench.Scoping $
+ topLevel <- Bench.billTo [Bench.Scoping] $
concreteToAbstract_ (TopLevel file top)
let ds = topLevelDecls topLevel
-- Highlighting from scope checker.
- billTop Bench.Highlighting $ do
+ Bench.billTo [Bench.Highlighting] $ do
ifTopLevelAndHighlightingLevelIs NonInteractive $ do
-- Generate and print approximate syntax highlighting info.
printHighlightingInfo fileTokenInfo
mapM_ (\ d -> generateAndPrintSyntaxInfo d Partial) ds
-- Type checking.
- billTop Bench.Typing $ checkDecls ds
+ Bench.billTo [Bench.Typing] $ checkDecls ds
-- Ulf, 2013-11-09: Since we're rethrowing the error, leave it up to the
-- code that handles that error to reset the state.
@@ -573,7 +576,7 @@ createInterface file mname =
tickN "metas" (fromIntegral n)
-- Highlighting from type checker.
- billTop Bench.Highlighting $ do
+ Bench.billTo [Bench.Highlighting] $ do
-- Move any remaining token highlighting to stSyntaxInfo.
toks <- use stTokens
@@ -591,13 +594,16 @@ createInterface file mname =
-- Serialization.
syntaxInfo <- use stSyntaxInfo
- i <- billTop Bench.Serialization $ do
+ i <- Bench.billTo [Bench.Serialization] $ do
buildInterface file topLevel syntaxInfo previousHsImports options
-- TODO: It would be nice if unsolved things were highlighted
-- after every mutual block.
- unsolvedMetas <- List.nub <$> (mapM getMetaRange =<< getOpenMetas)
+ openMetas <- getOpenMetas
+ unless (null openMetas) $ do
+ reportSLn "import.metas" 10 . unlines =<< showOpenMetas
+ unsolvedMetas <- List.nub <$> mapM getMetaRange openMetas
unsolvedConstraints <- getAllConstraints
interactionPoints <- getInteractionPoints
@@ -605,7 +611,7 @@ createInterface file mname =
printUnsolvedInfo
r <- if and [ null unsolvedMetas, null unsolvedConstraints, null interactionPoints ]
- then billTop Bench.Serialization $ do
+ then Bench.billTo [Bench.Serialization] $ do
-- The file was successfully type-checked (and no warnings were
-- encountered), so the interface should be written out.
let ifile = filePath $ toIFile file
@@ -655,7 +661,10 @@ buildInterface file topLevel syntaxInfo previousHsImports pragmas = do
ms <- getImports
mhs <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms
hsImps <- getHaskellImports
- patsyns <- getPatternSyns
+ -- Andreas, 2015-02-09 kill ranges in pattern synonyms before
+ -- serialization to avoid error locations pointing to external files
+ -- when expanding a pattern synoym.
+ patsyns <- killRange <$> getPatternSyns
h <- liftIO $ hashFile file
let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin
reportSLn "import.iface" 7 " instantiating all meta variables"
diff --git a/src/full/Agda/Interaction/InteractionTop.hs b/src/full/Agda/Interaction/InteractionTop.hs
index c956729..d49795e 100644
--- a/src/full/Agda/Interaction/InteractionTop.hs
+++ b/src/full/Agda/Interaction/InteractionTop.hs
@@ -1,21 +1,22 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
{-# OPTIONS -fno-cse #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
module Agda.Interaction.InteractionTop
( module Agda.Interaction.InteractionTop
)
where
+import Prelude hiding (null)
+
import Control.Applicative hiding (empty)
import qualified Control.Exception as E
import Control.Monad.Identity
@@ -25,7 +26,7 @@ import Control.Monad.State
import qualified Data.Char as Char
import Data.Foldable (Foldable)
import Data.Function
-import Data.List as List
+import Data.List as List hiding (null)
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
@@ -58,6 +59,7 @@ import Agda.Syntax.Scope.Base
import Agda.Interaction.FindFile
import Agda.Interaction.Options
+import Agda.Interaction.Options.Lenses as Lenses
import Agda.Interaction.MakeCase
import Agda.Interaction.Response hiding (Function, ExtendedLambda)
import qualified Agda.Interaction.Response as R
@@ -84,7 +86,9 @@ import Agda.Utils.FileName
import Agda.Utils.Hash
import qualified Agda.Utils.HashMap as HMap
import Agda.Utils.Lens
+import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Pretty
import Agda.Utils.String
import Agda.Utils.Time
@@ -217,7 +221,7 @@ runInteraction (IOTCM current highlighting highlightingMethod cmd)
when (not (independent cmd) && Just current /= (fst <$> cf)) $
lift $ typeError $ GenericError "Error: First load the file."
- interpret cmd
+ withCurrentFile $ interpret cmd
cf <- gets theCurrentFile
when (Just current == (fst <$> cf)) $
@@ -234,7 +238,10 @@ runInteraction (IOTCM current highlighting highlightingMethod cmd)
-- If an independent command fails we should reset theCurrentFile (Issue853).
let sErr | independent cmd = s { theCurrentFile = Nothing }
| otherwise = s
- (x, s') <- lift (runStateT m s `catchError_` \e -> runStateT (h e) sErr)
+ (x, s') <- lift $ do
+ disableDestructiveUpdate (runStateT m s)
+ `catchError_` \ e ->
+ runStateT (h e) sErr
put s'
return x
@@ -246,8 +253,9 @@ runInteraction (IOTCM current highlighting highlightingMethod cmd)
-- | Handle nasty errors like stack space overflow (issue 637)
-- We assume that the input action handles other kind of errors.
handleNastyErrors :: CommandM () -> CommandM ()
- handleNastyErrors m = commandMToIO $ \toIO ->
- toIO m `E.catch` (toIO . handleErr . Exception noRange . (show :: E.SomeException -> String))
+ handleNastyErrors m = commandMToIO $ \ toIO ->
+ toIO m `E.catch` \ (e :: E.SomeException) ->
+ toIO $ handleErr $ Exception noRange $ text $ show e
-- | Displays an error and instructs Emacs to jump to the site of the
-- error. Because this function may switch the focus to another file
@@ -517,31 +525,11 @@ interpret Cmd_constraints =
display_info . Info_Constraints . unlines . map show =<< lift B.getConstraints
interpret Cmd_metas = do -- CL.showMetas []
- ims <- lift $ B.typesOfVisibleMetas B.AsIs
- -- Show unsolved implicit arguments simplified.
- hms <- lift $ B.typesOfHiddenMetas B.Simplified
- if not $ null ims && null hms
- then do
- di <- lift $ forM ims $ \i -> B.withInteractionId (B.outputFormId $ B.OutputForm noRange 0 i) (showATop i)
- dh <- lift $ mapM showA' hms
- display_info $ Info_AllGoals $ unlines $ di ++ dh
- else do
- cs <- lift B.getConstraints
- if null cs
- then display_info $ Info_AllGoals ""
- else interpret Cmd_constraints
- where
- metaId (B.OfType i _) = i
- metaId (B.JustType i) = i
- metaId (B.JustSort i) = i
- metaId (B.Assign i e) = i
- metaId _ = __IMPOSSIBLE__
- showA' :: B.OutputConstraint A.Expr NamedMeta -> TCM String
- showA' m = do
- let i = nmid $ metaId m
- r <- getMetaRange i
- d <- B.withMetaId i (showATop m)
- return $ d ++ " [ at " ++ show r ++ " ]"
+ ms <- lift $ showOpenMetas
+ -- If we do not have open metas, but open constaints, display those.
+ ifM (return (null ms) `and2M` do not . null <$> lift B.getConstraints)
+ {-then-} (interpret Cmd_constraints)
+ {-else-} (display_info $ Info_AllGoals $ unlines ms)
interpret (Cmd_show_module_contents_toplevel norm s) =
liftCommandMT B.atTopLevel $ showModuleContents norm noRange s
@@ -606,7 +594,7 @@ interpret (Cmd_load_highlighting_info source) = do
return Nothing
mapM_ putResponse resp
-interpret (Cmd_highlight ii rng s) = withCurrentFile $ do
+interpret (Cmd_highlight ii rng s) = do
scope <- getOldInteractionScope ii
removeOldInteractionScope ii
handle $ do
@@ -647,7 +635,8 @@ interpret (Cmd_intro pmLambda ii rng _) = do
]
interpret (Cmd_refine_or_intro pmLambda ii r s) = interpret $
- (if null s then Cmd_intro pmLambda else Cmd_refine) ii r s
+ let s' = trim s
+ in (if null s' then Cmd_intro pmLambda else Cmd_refine) ii r s'
interpret (Cmd_auto ii rng s) = do
-- Andreas, 2014-07-05 Issue 1226:
@@ -762,10 +751,33 @@ interpret (Cmd_compute ignore ii rng s) = do
interpret Cmd_show_version = display_info Info_Version
-type GoalCommand = InteractionId -> Range -> String -> Interaction
+-- | Print open metas nicely.
+showOpenMetas :: TCM [String]
+showOpenMetas = do
+ ims <- B.typesOfVisibleMetas B.AsIs
+ di <- forM ims $ \ i ->
+ B.withInteractionId (B.outputFormId $ B.OutputForm noRange 0 i) $
+ showATop i
+ -- Show unsolved implicit arguments simplified.
+ dh <- mapM showA' =<< B.typesOfHiddenMetas B.Simplified
+ return $ di ++ dh
+ where
+ metaId (B.OfType i _) = i
+ metaId (B.JustType i) = i
+ metaId (B.JustSort i) = i
+ metaId (B.Assign i e) = i
+ metaId _ = __IMPOSSIBLE__
+ showA' :: B.OutputConstraint A.Expr NamedMeta -> TCM String
+ showA' m = do
+ let i = nmid $ metaId m
+ r <- getMetaRange i
+ d <- B.withMetaId i (showATop m)
+ return $ d ++ " [ at " ++ show r ++ " ]"
+
--- | @cmd_load' m includes cmd cmd2@ loads the module in file @m@,
--- using @includes@ as the include directories.
+-- | @cmd_load' file includes unsolvedOk cmd@
+-- loads the module in file @file@,
+-- using @includes@ as the include directories.
--
-- If type checking completes without any exceptions having been
-- encountered then the command @cmd r@ is executed, where @r@ is the
@@ -778,7 +790,7 @@ cmd_load' :: FilePath -> [FilePath]
cmd_load' file includes unsolvedOK cmd = do
f <- liftIO $ absolute file
ex <- liftIO $ doesFileExist $ filePath f
- lift $ setIncludeDirs includes $
+ lift $ TM.setIncludeDirs includes $
if ex then ProjectRoot f else CurrentDir
-- Forget the previous "current file" and interaction points.
@@ -795,12 +807,9 @@ cmd_load' file includes unsolvedOK cmd = do
opts <- lift $ commandLineOptions
defaultOptions <- gets optionsOnReload
setCommandLineOptions' $
- defaultOptions { optIncludeDirs = optIncludeDirs opts
- , optPragmaOptions =
- (optPragmaOptions defaultOptions)
- { optAllowUnsolved = unsolvedOK
- }
- }
+ Lenses.setIncludeDirs (optIncludeDirs opts) $
+ mapPragmaOptions (\ o -> o { optAllowUnsolved = unsolvedOK }) $
+ defaultOptions
-- Reset the state, preserving options and decoded modules. Note
-- that if the include directories have changed, then the decoded
@@ -828,10 +837,11 @@ cmd_load' file includes unsolvedOK cmd = do
cmd ok
+-- | Set 'envCurrentPath' to 'theCurrentFile', if any.
withCurrentFile :: CommandM a -> CommandM a
withCurrentFile m = do
- Just (file, _) <- gets $ theCurrentFile
- local (\e -> e { envCurrentPath = file }) m
+ mfile <- fmap fst <$> gets theCurrentFile
+ local (\ e -> e { envCurrentPath = mfile }) m
-- | Available backends.
@@ -857,8 +867,12 @@ give_gen
-> String
-> GiveRefine
-> CommandM ()
-give_gen ii rng s giveRefine = withCurrentFile $ do
+give_gen ii rng s0 giveRefine = do
+ let s = trim s0
lift $ reportSLn "interaction.give" 20 $ "give_gen " ++ s
+ -- Andreas, 2015-02-26 if string is empty do nothing rather
+ -- than giving a parse error.
+ unless (null s) $ do
let give_ref =
case giveRefine of
Give -> B.give
@@ -981,7 +995,7 @@ showModuleContents :: B.Rewrite -> Range -> String -> CommandM ()
showModuleContents norm rng s = do
(modules, types) <- lift $ B.moduleContents norm rng s
types' <- lift $ forM types $ \ (x, t) -> do
- t <- prettyTCM t
+ t <- TCP.prettyTCM t
return (show x, text ":" <+> t)
display_info $ Info_ModuleContents $
text "Modules" $$
@@ -1021,7 +1035,7 @@ whyInScope s = do
where
asVar :: TCM Doc
asVar = do
- TCP.text "* a variable bound at" TCP.<+> prettyTCM (nameBindingSite $ localVar x)
+ TCP.text "* a variable bound at" TCP.<+> TCP.prettyTCM (nameBindingSite $ localVar x)
shadowing :: LocalVar -> TCM Doc
shadowing LocalVar{} = TCP.text "shadowing"
shadowing ShadowedVar{} = TCP.text "in conflict with"
@@ -1050,20 +1064,20 @@ whyInScope s = do
TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a))
pWhy :: Range -> WhyInScope -> TCM Doc
- pWhy r Defined = TCP.text "- its definition at" TCP.<+> prettyTCM r
+ pWhy r Defined = TCP.text "- its definition at" TCP.<+> TCP.prettyTCM r
pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w
pWhy r (Opened m w) =
TCP.text "- the opening of"
TCP.<+> TCP.text (show m)
TCP.<+> TCP.text "at"
- TCP.<+> prettyTCM (getRange m)
+ TCP.<+> TCP.prettyTCM (getRange m)
TCP.$$
pWhy r w
pWhy r (Applied m w) =
TCP.text "- the application of"
TCP.<+> TCP.text (show m)
TCP.<+> TCP.text "at"
- TCP.<+> prettyTCM (getRange m)
+ TCP.<+> TCP.prettyTCM (getRange m)
TCP.$$
pWhy r w
diff --git a/src/full/Agda/Interaction/InteractionTop.hs-boot b/src/full/Agda/Interaction/InteractionTop.hs-boot
new file mode 100644
index 0000000..41d5e1e
--- /dev/null
+++ b/src/full/Agda/Interaction/InteractionTop.hs-boot
@@ -0,0 +1,5 @@
+module Agda.Interaction.InteractionTop where
+
+import Agda.TypeChecking.Monad.Base (TCM)
+
+showOpenMetas :: TCM [String]
diff --git a/src/full/Agda/Interaction/MakeCase.hs b/src/full/Agda/Interaction/MakeCase.hs
index 2e6775c..fbb9cb5 100644
--- a/src/full/Agda/Interaction/MakeCase.hs
+++ b/src/full/Agda/Interaction/MakeCase.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Interaction.MakeCase where
@@ -28,6 +28,7 @@ import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Irrelevance
import Agda.TheTypeChecker
+import Agda.Interaction.Options
import Agda.Interaction.BasicOps
import Agda.Utils.Functor
@@ -164,18 +165,24 @@ makeCase hole rng s = withInteractionId hole $ do
let vars = words s
if null vars then do
-- split result
- (newPats, sc) <- fixTarget (clauseToSplitClause clause)
- res <- splitResult f sc
- scs <- case res of
- Nothing -> if newPats then return [sc] else
- typeError $ GenericError $ "Cannot split on result here"
- Just cov -> mapM (snd <.> fixTarget) $ splitClauses cov
+ (newPats, sc) <- fixTarget $ clauseToSplitClause clause
+ -- Andreas, 2015-05-05 If we introduced new function arguments
+ -- do not split on result. This might be more what the user wants.
+ -- To split on result, he can then C-c C-c again.
+ scs <- if newPats then return [sc] else do
+ res <- splitResult f sc
+ case res of
+ Nothing -> typeError $ GenericError $ "Cannot split on result here"
+ Just cov -> ifNotM (optCopatterns <$> pragmaOptions) failNoCop $ {-else-} do
+ mapM (snd <.> fixTarget) $ splitClauses cov
(casectxt,) <$> mapM (makeAbstractClause f) scs
else do
-- split on variables
vars <- parseVariables hole rng vars
(casectxt,) <$> split f vars clause
where
+ failNoCop = typeError $ GenericError $
+ "OPTION --copatterns needed to split on result here"
split :: QName -> [Nat] -> Clause -> TCM [A.Clause]
split f [] clause =
(:[]) <$> makeAbstractClause f (clauseToSplitClause clause)
diff --git a/src/full/Agda/Interaction/Monad.hs b/src/full/Agda/Interaction/Monad.hs
index 089fc92..9edb2fe 100644
--- a/src/full/Agda/Interaction/Monad.hs
+++ b/src/full/Agda/Interaction/Monad.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
module Agda.Interaction.Monad where
diff --git a/src/full/Agda/Interaction/Options.hs b/src/full/Agda/Interaction/Options.hs
index 3249c26..5ee7e02 100644
--- a/src/full/Agda/Interaction/Options.hs
+++ b/src/full/Agda/Interaction/Options.hs
@@ -1,10 +1,5 @@
{-# LANGUAGE CPP #-}
-#if __GLASGOW_HASKELL__ <= 706
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE StandaloneDeriving #-}
-#endif
-
module Agda.Interaction.Options
( CommandLineOptions(..)
, PragmaOptions(..)
@@ -26,40 +21,51 @@ module Agda.Interaction.Options
, mapFlag
, usage
, tests
+ , defaultLibDir
+ -- Reused by PandocAgda
+ , inputFlag
+ , standardOptions
+ , getOptSimple
) where
import Control.Monad ( when )
-import Data.Maybe ( isJust )
+
+-- base-4.7 defines the Functor instances for OptDescr and ArgDescr
+#if !(MIN_VERSION_base(4,7,0))
+import Data.Orphans ()
+#endif
+
+import Data.Maybe
import Data.List ( isSuffixOf , intercalate )
-import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(ReturnInOrder)
+import System.Console.GetOpt ( getOpt', usageInfo, ArgOrder(ReturnInOrder)
, OptDescr(..), ArgDescr(..)
)
+import System.Directory ( doesDirectoryExist )
+
+import Text.EditDistance
import Agda.Termination.CutOff ( CutOff(..) )
import Agda.Utils.TestHelpers ( runTests )
import Agda.Utils.QuickCheck ( quickCheck' )
-import Agda.Utils.FileName ( AbsolutePath )
-import Agda.Utils.Monad ( readM )
-import Agda.Utils.List ( wordsBy )
+import Agda.Utils.FileName ( absolute, AbsolutePath, filePath )
+import Agda.Utils.Monad ( ifM, readM )
+import Agda.Utils.List ( groupOn, wordsBy )
import Agda.Utils.String ( indent )
import Agda.Utils.Trie ( Trie )
import qualified Agda.Utils.Trie as Trie
import Agda.Utils.Except ( MonadError(catchError, throwError) )
+-- Paths_Agda.hs is in $(BUILD_DIR)/build/autogen/.
+import Paths_Agda ( getDataFileName )
+
-- | This should probably go somewhere else.
isLiterate :: FilePath -> Bool
isLiterate file = ".lagda" `isSuffixOf` file
-- OptDescr is a Functor --------------------------------------------------
--- base-4.7 defines these
-#if !(MIN_VERSION_base(4,7,0))
-deriving instance Functor OptDescr
-deriving instance Functor ArgDescr
-#endif
-
type Verbosity = Trie String Int
type IncludeDirs = Either [FilePath] [AbsolutePath]
@@ -390,8 +396,10 @@ compileFlag o = return $ o { optCompile = True }
compileFlagNoMain :: Flag CommandLineOptions
compileFlagNoMain o = return $ o { optCompileNoMain = True }
+-- The Epic backend has been disabled. See Issue 1481.
compileEpicFlag :: Flag CommandLineOptions
-compileEpicFlag o = return $ o { optEpicCompile = True}
+-- compileEpicFlag o = return $ o { optEpicCompile = True}
+compileEpicFlag o = throwError "the Epic backend has been disabled"
compileJSFlag :: Flag CommandLineOptions
compileJSFlag o = return $ o { optJSCompile = True }
@@ -404,8 +412,10 @@ ghcFlag :: String -> Flag CommandLineOptions
ghcFlag f o = return $ o { optGhcFlags = optGhcFlags o ++ [f] }
-- NOTE: Quadratic in number of flags.
+-- The Epic backend has been disabled. See Issue 1481.
epicFlagsFlag :: String -> Flag CommandLineOptions
-epicFlagsFlag s o = return $ o { optEpicFlags = optEpicFlags o ++ [s] }
+-- epicFlagsFlag s o = return $ o { optEpicFlags = optEpicFlags o ++ [s] }
+epicFlagsFlag s o = throwError "the Epic backend has been disabled"
htmlFlag :: Flag CommandLineOptions
htmlFlag o = return $ o { optGenerateHTML = True }
@@ -459,14 +469,23 @@ standardOptions =
"compile program using the MAlonzo backend (experimental)"
, Option [] ["no-main"] (NoArg compileFlagNoMain)
"when compiling using the MAlonzo backend (experimental), do not treat the requested module as the main module of a program"
- , Option [] ["epic"] (NoArg compileEpicFlag) "compile program using the Epic backend"
+
+ -- The Epic backend has been disabled. See Issue 1481.
+ , Option [] ["epic"] (NoArg compileEpicFlag)
+ -- "compile program using the Epic backend"
+ "the Epic backend has been disabled"
+
, Option [] ["js"] (NoArg compileJSFlag) "compile program using the JS backend"
, Option [] ["compile-dir"] (ReqArg compileDirFlag "DIR")
("directory for compiler output (default: the project root)")
, Option [] ["ghc-flag"] (ReqArg ghcFlag "GHC-FLAG")
"give the flag GHC-FLAG to GHC when compiling using MAlonzo"
+
+ -- The Epic backend has been disabled. See Issue 1481.
, Option [] ["epic-flag"] (ReqArg epicFlagsFlag "EPIC-FLAG")
- "give the flag EPIC-FLAG to Epic when compiling using Epic"
+ -- "give the flag EPIC-FLAG to Epic when compiling using Epic"
+ "the Epic backend has been disabled"
+
, Option [] ["test"] (NoArg runTestsFlag)
"run internal test suite"
, Option [] ["vim"] (NoArg vimFlag)
@@ -552,19 +571,59 @@ pragmaOptions =
standardOptions_ :: [OptDescr ()]
standardOptions_ = map (fmap $ const ()) standardOptions
--- | Don't export
-parseOptions' ::
- [String] -> [OptDescr (Flag opts)] -> (String -> Flag opts) -> Flag opts
-parseOptions' argv opts fileArg = \defaults ->
- case getOpt (ReturnInOrder fileArg) opts argv of
- (o,_,[]) -> foldl (>>=) (return defaults) o
- (_,_,errs) -> throwError $ concat errs
+-- | Simple interface for System.Console.GetOpt
+-- Could be moved to Agda.Utils.Options (does not exist yet)
+getOptSimple
+ :: [String] -- ^ command line argument words
+ -> [OptDescr (Flag opts)] -- ^ options handlers
+ -> (String -> Flag opts) -- ^ handler of non-options (only one is allowed)
+ -> Flag opts -- ^ combined opts data structure transformer
+getOptSimple argv opts fileArg = \ defaults ->
+ case getOpt' (ReturnInOrder fileArg) opts argv of
+ (o, _, [] , [] ) -> foldl (>>=) (return defaults) o
+ (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg
+
+ where
+ ucap = "Unrecognized " ++ plural unrecognized "option" ++ ":"
+ ecap = plural errs "Option error" ++ ":"
+ umsg = if null unrecognized then "" else unlines $
+ ucap : map suggest unrecognized
+ emsg = if null errs then "" else unlines $
+ ecap : errs
+ plural [_] x = x
+ plural _ x = x ++ "s"
+
+ -- Suggest alternatives that are at most 3 typos away
+
+ longopts :: [String]
+ longopts = map ("--" ++) $ concat $ map (\ (Option _ long _ _) -> long) opts
+
+ dist :: String -> String -> Int
+ dist s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t
+
+ close :: String -> String -> Maybe (Int, String)
+ close s t = let d = dist s t in if d <= 3 then Just (d, t) else Nothing
+
+ closeopts :: String -> [(Int, String)]
+ closeopts s = mapMaybe (close s) longopts
+
+ alts :: String -> [[String]]
+ alts s = map (map snd) $ groupOn fst $ closeopts s
+
+ suggest :: String -> String
+ suggest s = case alts s of
+ [] -> s
+ as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)"
+
+ sugs :: [String] -> String
+ sugs [a] = a
+ sugs as = "any of " ++ intercalate " " as
-- | Parse the standard options.
parseStandardOptions :: [String] -> Either String CommandLineOptions
parseStandardOptions argv =
checkOpts =<<
- parseOptions' argv standardOptions inputFlag defaultOptions
+ getOptSimple argv standardOptions inputFlag defaultOptions
-- | Parse options from an options pragma.
parsePragmaOptions
@@ -574,16 +633,16 @@ parsePragmaOptions
-- ^ Command-line options which should be updated.
-> Either String PragmaOptions
parsePragmaOptions argv opts = do
- ps <- parseOptions' argv pragmaOptions
+ ps <- getOptSimple argv pragmaOptions
(\s _ -> throwError $ "Bad option in pragma: " ++ s)
(optPragmaOptions opts)
- checkOpts (opts { optPragmaOptions = ps })
+ _ <- checkOpts (opts { optPragmaOptions = ps })
return ps
-- | Parse options for a plugin.
parsePluginOptions :: [String] -> [OptDescr (Flag opts)] -> Flag opts
parsePluginOptions argv opts =
- parseOptions' argv opts
+ getOptSimple argv opts
(\s _ -> throwError $
"Internal error: Flag " ++ s ++ " passed to a plugin")
@@ -614,6 +673,18 @@ usage options pluginInfos progName =
"\n Inherits options from: " ++ unwords pls
------------------------------------------------------------------------
+-- Some paths
+
+-- | Returns the absolute default lib dir. This directory is used to
+-- store the Primitive.agda file.
+defaultLibDir :: IO FilePath
+defaultLibDir = do
+ libdir <- fmap filePath (absolute =<< getDataFileName "lib")
+ ifM (doesDirectoryExist libdir)
+ (return libdir)
+ (error $ "The lib directory " ++ libdir ++ " does not exist")
+
+------------------------------------------------------------------------
-- All tests
tests :: IO Bool
diff --git a/src/full/Agda/Interaction/Response.hs b/src/full/Agda/Interaction/Response.hs
index f620452..2caf51f 100644
--- a/src/full/Agda/Interaction/Response.hs
+++ b/src/full/Agda/Interaction/Response.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
------------------------------------------------------------------------
-- | Data type for all interactive responses
diff --git a/src/full/Agda/Main.hs b/src/full/Agda/Main.hs
index f5f1c79..f7e4293 100644
--- a/src/full/Agda/Main.hs
+++ b/src/full/Agda/Main.hs
@@ -7,18 +7,15 @@ module Agda.Main where
import Control.Monad.State
import Control.Applicative
-import qualified Data.List as List
import Data.Maybe
import System.Environment
import System.Exit
-import qualified Text.PrettyPrint.Boxes as Boxes
-
import Agda.Syntax.Concrete.Pretty ()
import Agda.Syntax.Abstract.Name (toTopLevelModuleName)
-import Agda.Interaction.CommandLine.CommandLine
+import Agda.Interaction.CommandLine
import Agda.Interaction.Options
import Agda.Interaction.Monad
import Agda.Interaction.EmacsTop (mimicGHCi)
@@ -29,7 +26,6 @@ import qualified Agda.Interaction.Highlighting.LaTeX as LaTeX
import Agda.Interaction.Highlighting.HTML
import Agda.TypeChecking.Monad
-import Agda.TypeChecking.Monad.Benchmark
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TypeChecking.Errors
@@ -39,9 +35,7 @@ import Agda.Compiler.JS.Compiler as JS
import Agda.Utils.Lens
import Agda.Utils.Monad
-import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.String
-import qualified Agda.Utils.Trie as Trie
import Agda.Tests
import Agda.Version
@@ -59,38 +53,32 @@ runAgda = do
let opts = parseStandardOptions argv
case opts of
Left err -> liftIO $ optionError err
- Right opts
- | optShowHelp opts -> liftIO printUsage
- | optShowVersion opts -> liftIO printVersion
- | optRunTests opts -> liftIO $ do
+ Right opts -> runAgdaWithOptions generateHTML progName opts
+
+-- | Run Agda with parsed command line options and with a custom HTML generator
+runAgdaWithOptions
+ :: TCM () -- ^ HTML generating action
+ -> String -- ^ program name
+ -> CommandLineOptions -- ^ parsed command line options
+ -> TCM ()
+runAgdaWithOptions generateHTML progName opts
+ | optShowHelp opts = liftIO printUsage
+ | optShowVersion opts = liftIO printVersion
+ | optRunTests opts = liftIO $ do
ok <- testSuite
unless ok exitFailure
| isNothing (optInputFile opts)
&& not (optInteractive opts)
&& not (optGHCiInteraction opts)
- -> liftIO printUsage
- | otherwise -> do
+ = liftIO printUsage
+ | otherwise = do
setCommandLineOptions opts
-- Main function.
-- Bill everything to root of Benchmark trie.
- billTo [] $ checkFile
+ Bench.billTo [] $ checkFile
-- Print benchmarks.
- whenM benchmarking $ do
- (accounts, times) <- List.unzip . Trie.toList <$> getBenchmark
- -- Generate a table.
- let showAccount [] = "Total time"
- showAccount ks = List.concat . List.intersperse "." . map show $ ks
- -- First column is accounts.
- col1 = Boxes.vcat Boxes.left $
- map (Boxes.text . showAccount) $
- accounts
- -- Second column is times.
- col2 = Boxes.vcat Boxes.right $
- map (Boxes.text . prettyShow) $
- times
- table = Boxes.hsep 1 Boxes.left [col1, col2]
- reportBenchmarkingLn $ Boxes.render table
+ Bench.print
-- Print accumulated statistics.
printStatistics 20 Nothing =<< use lensAccumStatistics
@@ -179,10 +167,10 @@ optionError err = do
printUsage
exitFailure
--- | Main
-main :: IO ()
-main = do
- r <- runTCMTop $ runAgda `catchError` \err -> do
+-- | Run a TCM action in IO; catch and pretty print errors.
+runTCMPrettyErrors :: TCM () -> IO ()
+runTCMPrettyErrors tcm = do
+ r <- runTCMTop $ tcm `catchError` \err -> do
s <- prettyError err
liftIO $ putStrLn s
throwError err
@@ -192,3 +180,7 @@ main = do
`catchImpossible` \e -> do
putStr $ show e
exitFailure
+
+-- | Main
+main :: IO ()
+main = runTCMPrettyErrors runAgda
diff --git a/src/full/Agda/Syntax/Abstract.hs b/src/full/Agda/Syntax/Abstract.hs
index 406e8f9..ea02ed4 100644
--- a/src/full/Agda/Syntax/Abstract.hs
+++ b/src/full/Agda/Syntax/Abstract.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveDataTypeable,
+ DeriveFoldable,
+ DeriveFunctor,
+ DeriveTraversable,
+ FlexibleInstances,
+ MultiParamTypeClasses,
+ TemplateHaskell #-}
{-| The abstract syntax. This is what you get after desugaring and scope
analysis of the concrete syntax. The type checker works on abstract syntax,
@@ -117,7 +117,7 @@ data Axiom
deriving (Typeable, Eq, Ord, Show)
-- | Renaming (generic).
-type Ren a = Map a a
+type Ren a = [(a, a)]
data Declaration
= Axiom Axiom DefInfo ArgInfo QName Expr -- ^ type signature (can be irrelevant and colored, but not hidden)
@@ -170,6 +170,9 @@ data ModuleApplication
data Pragma
= OptionsPragma [String]
| BuiltinPragma String Expr
+ | BuiltinNoDefPragma String QName
+ -- ^ Builtins that do not come with a definition,
+ -- but declare a name for an Agda concept.
| RewritePragma QName
| CompiledPragma QName String
| CompiledExportPragma QName String
@@ -209,20 +212,25 @@ data TypedBindings = TypedBindings Range (Arg TypedBinding)
-- ^ . @(xs : e)@ or @{xs : e}@
deriving (Typeable, Show)
--- | A typed binding. Appears in dependent function spaces, typed lambdas, and
--- telescopes. I might be tempting to simplify this to only bind a single
--- name at a time. This would mean that we would have to typecheck the type
--- several times (@(x y : A)@ vs. @(x : A)(y : A)@).
--- In most cases this wouldn't really be a problem, but it's good
--- principle to not do extra work unless you have to.
+-- | A typed binding. Appears in dependent function spaces, typed lambdas, and
+-- telescopes. It might be tempting to simplify this to only bind a single
+-- name at a time, and translate, say, @(x y : A)@ to @(x : A)(y : A)@
+-- before type-checking. However, this would be slightly problematic:
--
--- (Andreas, 2013-12-10: The more serious problem would that the translation
--- from @(x y : ?)@ to @(x : ?) (y : ?)@ duplicates the hole @?@.
+-- 1. We would have to typecheck the type @A@ several times.
+--
+-- 2. If @A@ contains a meta variable or hole, it would be duplicated
+-- by such a translation.
+--
+-- While 1. is only slightly inefficient, 2. would be an outright bug.
+-- Duplicating @A@ could not be done naively, we would have to make sure
+-- that the metas of the copy are aliases of the metas of the original.
+
data TypedBinding
- = TBind Range [Name] Expr
+ = TBind Range [WithHiding Name] Expr
-- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B@.
| TLet Range [LetBinding]
- -- ^
+ -- ^ E.g. @(let x = e)@ or @(let open M)@.
deriving (Typeable, Show)
type Telescope = [TypedBindings]
@@ -244,7 +252,7 @@ data RHS
| AbsurdRHS
| WithRHS QName [Expr] [Clause]
-- ^ The 'QName' is the name of the with function.
- | RewriteRHS [QName] [Expr] RHS [Declaration]
+ | RewriteRHS [(QName, Expr)] RHS [Declaration]
-- ^ The 'QName's are the names of the generated with functions.
-- One for each 'Expr'.
-- The RHS shouldn't be another @RewriteRHS@.
@@ -399,6 +407,16 @@ instance IsProjP a => IsProjP (Named n a) where
Instances
--------------------------------------------------------------------------}
+instance LensHiding TypedBindings where
+ getHiding (TypedBindings _ a) = getHiding a
+ mapHiding f (TypedBindings r a) = TypedBindings r $ mapHiding f a
+
+instance LensHiding LamBinding where
+ getHiding (DomainFree ai _) = getHiding ai
+ getHiding (DomainFull tb) = getHiding tb
+ mapHiding f (DomainFree ai x) = mapHiding f ai `DomainFree` x
+ mapHiding f (DomainFull tb) = DomainFull $ mapHiding f tb
+
instance HasRange LamBinding where
getRange (DomainFree _ x) = getRange x
getRange (DomainFull b) = getRange b
@@ -488,7 +506,7 @@ instance HasRange RHS where
getRange AbsurdRHS = noRange
getRange (RHS e) = getRange e
getRange (WithRHS _ e cs) = fuseRange e cs
- getRange (RewriteRHS _ es rhs wh) = getRange (es, rhs, wh)
+ getRange (RewriteRHS xes rhs wh) = getRange (map snd xes, rhs, wh)
instance HasRange LetBinding where
getRange (LetBind i _ _ _ _ ) = getRange i
@@ -531,17 +549,15 @@ instance KillRange Expr where
killRange (App i e1 e2) = killRange3 App i e1 e2
killRange (WithApp i e es) = killRange3 WithApp i e es
killRange (Lam i b e) = killRange3 Lam i b e
- killRange (AbsurdLam i h) = killRange1 AbsurdLam i h
+ killRange (AbsurdLam i h) = killRange2 AbsurdLam i h
killRange (ExtendedLam i n d ps) = killRange4 ExtendedLam i n d ps
killRange (Pi i a b) = killRange3 Pi i a b
killRange (Fun i a b) = killRange3 Fun i a b
- killRange (Set i n) = Set (killRange i) n
+ killRange (Set i n) = killRange2 Set i n
killRange (Prop i) = killRange1 Prop i
killRange (Let i ds e) = killRange3 Let i ds e
- killRange (Rec i fs) = Rec (killRange i) (map (id -*- killRange) fs)
- killRange (RecUpdate i e fs) = RecUpdate (killRange i)
- (killRange e)
- (map (id -*- killRange) fs)
+ killRange (Rec i fs) = killRange2 Rec i fs
+ killRange (RecUpdate i e fs) = killRange3 RecUpdate i e fs
killRange (ETel tel) = killRange1 ETel tel
killRange (ScopedExpr s e) = killRange1 (ScopedExpr s) e
killRange (QuoteGoal i x e) = killRange3 QuoteGoal i x e
@@ -549,7 +565,7 @@ instance KillRange Expr where
killRange (Quote i) = killRange1 Quote i
killRange (QuoteTerm i) = killRange1 QuoteTerm i
killRange (Unquote i) = killRange1 Unquote i
- killRange (DontCare e) = DontCare e
+ killRange (DontCare e) = killRange1 DontCare e
killRange (PatternSyn x) = killRange1 PatternSyn x
instance KillRange Declaration where
@@ -608,7 +624,7 @@ instance KillRange RHS where
killRange AbsurdRHS = AbsurdRHS
killRange (RHS e) = killRange1 RHS e
killRange (WithRHS q e cs) = killRange3 WithRHS q e cs
- killRange (RewriteRHS x es rhs wh) = killRange4 RewriteRHS x es rhs wh
+ killRange (RewriteRHS xes rhs wh) = killRange3 RewriteRHS xes rhs wh
instance KillRange LetBinding where
killRange (LetBind i info a b c) = killRange5 LetBind i info a b c
@@ -685,7 +701,7 @@ instance AllNames RHS where
allNames (RHS e) = allNames e
allNames AbsurdRHS{} = Seq.empty
allNames (WithRHS q _ cls) = q <| allNames cls
- allNames (RewriteRHS qs _ rhs cls) = Seq.fromList qs >< allNames rhs >< allNames cls
+ allNames (RewriteRHS qes rhs cls) = Seq.fromList (map fst qes) >< allNames rhs >< allNames cls
instance AllNames Expr where
allNames Var{} = Seq.empty
@@ -892,4 +908,3 @@ insertImplicitPatSynArgs wild r ns as = matchArgs r ns as
matchArgs r (n:ns) as = do
(p, as) <- matchNextArg r n as
first ((unArg n, p) :) <$> matchArgs (getRange p) ns as
-
diff --git a/src/full/Agda/Syntax/Abstract/Copatterns.hs b/src/full/Agda/Syntax/Abstract/Copatterns.hs
index 5220c0c..56fe44c 100644
--- a/src/full/Agda/Syntax/Abstract/Copatterns.hs
+++ b/src/full/Agda/Syntax/Abstract/Copatterns.hs
@@ -1,12 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Syntax.Abstract.Copatterns (translateCopatternClauses) where
@@ -263,6 +262,10 @@ class Rename e where
rename' :: NameMap -> e -> e
rename' rho = rename (flip lookup rho)
+-- | 'QName's are not renamed.
+instance Rename QName where
+ rename _ q = q
+
instance Rename Expr where
rename rho e =
case e of
@@ -325,19 +328,13 @@ instance Rename RHS where
RHS e -> RHS (rename rho e)
AbsurdRHS -> e
WithRHS n es cs -> WithRHS n (rename rho es) (rename rho cs)
- RewriteRHS ns es r ds -> RewriteRHS ns (rename rho es) (rename rho r) (rename rho ds)
+ RewriteRHS nes r ds -> RewriteRHS (rename rho nes) (rename rho r) (rename rho ds)
instance Rename LHS where
rename rho (LHS i core ps) = LHS i (rename rho core) (rename rho ps)
instance Rename LHSCore where
rename rho = fmap (rename rho) -- only rename in dot patterns
-{-
- rename rho = ren where
- ren e = case e of
- LHSHead f ps -> LHSHead f (ren ps)
- LHSProj d ps1 core ps2 -> LHSProj d (ren ps1) (ren core) (ren ps2)
--}
instance Rename Pattern where
rename rho = fmap (rename rho) -- only rename in dot patterns
@@ -354,6 +351,8 @@ instance Rename a => Rename (Named n a) where
instance Rename a => Rename [a] where
rename rho = map (rename rho)
+instance (Rename a, Rename b) => Rename (a, b) where
+ rename rho (a,b) = (rename rho a, rename rho b)
diff --git a/src/full/Agda/Syntax/Abstract/Name.hs b/src/full/Agda/Syntax/Abstract/Name.hs
index 1e29f4e..f62811b 100644
--- a/src/full/Agda/Syntax/Abstract/Name.hs
+++ b/src/full/Agda/Syntax/Abstract/Name.hs
@@ -1,12 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeSynonymInstances #-}
{-| Abstract names carry unique identifiers and stuff.
-}
@@ -288,6 +287,9 @@ instance Pretty ModuleName where
instance Pretty QName where
pretty = hcat . punctuate (text ".") . map pretty . qnameToList
+instance Pretty AmbiguousQName where
+ pretty (AmbQ qs) = hcat $ punctuate (text " | ") $ map pretty qs
+
------------------------------------------------------------------------
-- * Range instances
------------------------------------------------------------------------
@@ -326,23 +328,25 @@ instance SetRange ModuleName where
-- ** KillRange
instance KillRange Name where
- killRange x = x { nameConcrete = killRange $ nameConcrete x
- -- Andreas, 2014-03-30
- -- An experiment: what happens if we preserve
- -- the range of the binding site, but kill all
- -- other ranges before serialization?
- -- Andreas, Makoto, 2014-10-18 AIM XX
- -- Kill all ranges in signature, including nameBindingSite.
- , nameBindingSite = noRange
- }
+ killRange (Name a b c d) = killRange4 Name a b c d
+ -- killRange x = x { nameConcrete = killRange $ nameConcrete x
+ -- -- Andreas, 2014-03-30
+ -- -- An experiment: what happens if we preserve
+ -- -- the range of the binding site, but kill all
+ -- -- other ranges before serialization?
+ -- -- Andreas, Makoto, 2014-10-18 AIM XX
+ -- -- Kill all ranges in signature, including nameBindingSite.
+ -- , nameBindingSite = noRange
+ -- }
instance KillRange ModuleName where
killRange (MName xs) = MName $ killRange xs
instance KillRange QName where
- killRange q = q { qnameModule = killRange $ qnameModule q
- , qnameName = killRange $ qnameName q
- }
+ killRange (QName a b) = killRange2 QName a b
+ -- killRange q = q { qnameModule = killRange $ qnameModule q
+ -- , qnameName = killRange $ qnameName q
+ -- }
instance KillRange AmbiguousQName where
killRange (AmbQ xs) = AmbQ $ killRange xs
diff --git a/src/full/Agda/Syntax/Abstract/Name.hs-boot b/src/full/Agda/Syntax/Abstract/Name.hs-boot
new file mode 100644
index 0000000..187181b
--- /dev/null
+++ b/src/full/Agda/Syntax/Abstract/Name.hs-boot
@@ -0,0 +1,10 @@
+module Agda.Syntax.Abstract.Name where
+
+import {-# SOURCE #-} Agda.Syntax.Fixity (Fixity')
+
+data Name
+
+instance Show Name
+instance Ord Name
+
+nameFixity :: Name -> Fixity'
diff --git a/src/full/Agda/Syntax/Abstract/Views.hs b/src/full/Agda/Syntax/Abstract/Views.hs
index f5a8b55..2262217 100644
--- a/src/full/Agda/Syntax/Abstract/Views.hs
+++ b/src/full/Agda/Syntax/Abstract/Views.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Syntax.Abstract.Views where
@@ -59,7 +59,7 @@ deepUnScope = mapExpr unScope
-- * Traversal
-- | Apply an expression rewriting to every subexpression, inside-out.
--- See 'Agda.Syntax.Internal.Generic'
+-- See "Agda.Syntax.Internal.Generic".
class ExprLike a where
foldExpr :: Monoid m => (Expr -> m) -> a -> m
traverseExpr :: (Monad m, Applicative m) => (Expr -> m Expr) -> a -> m a
@@ -214,7 +214,7 @@ instance ExprLike RHS where
RHS e -> fold e
AbsurdRHS{} -> mempty
WithRHS _ es cs -> fold es `mappend` fold cs
- RewriteRHS _ es rhs ds -> fold es `mappend` fold rhs `mappend` fold ds
+ RewriteRHS xes rhs ds -> fold xes `mappend` fold rhs `mappend` fold ds
where fold e = foldExpr f e
traverseExpr f rhs =
@@ -222,7 +222,7 @@ instance ExprLike RHS where
RHS e -> RHS <$> trav e
AbsurdRHS{} -> pure rhs
WithRHS x es cs -> WithRHS x <$> trav es <*> trav cs
- RewriteRHS xs es rhs ds -> RewriteRHS xs <$> trav es <*> trav rhs <*> trav ds
+ RewriteRHS xes rhs ds -> RewriteRHS <$> trav xes <*> trav rhs <*> trav ds
where trav e = traverseExpr f e
instance ExprLike Declaration where
diff --git a/src/full/Agda/Syntax/Common.hs b/src/full/Agda/Syntax/Common.hs
index 381b300..32c4420 100644
--- a/src/full/Agda/Syntax/Common.hs
+++ b/src/full/Agda/Syntax/Common.hs
@@ -1,11 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeSynonymInstances #-}
{-| Some common syntactic entities are defined in this module.
-}
@@ -17,16 +16,16 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as ByteString
import Data.Foldable
import Data.Hashable
+import Data.Monoid
import Data.Traversable
import Data.Typeable (Typeable)
-import Test.QuickCheck
+import Test.QuickCheck hiding (Small)
import Agda.Syntax.Position
import Agda.Utils.Functor
import Agda.Utils.Pretty
-import Agda.Utils.Size
#include "undefined.h"
import Agda.Utils.Impossible
@@ -73,9 +72,39 @@ instance CoArbitrary Induction where
data Hiding = Hidden | Instance | NotHidden
deriving (Typeable, Show, Eq, Ord)
+-- | 'Hiding' is an idempotent partial monoid, with unit 'NotHidden'.
+-- 'Instance' and 'NotHidden' are incompatible.
+instance Monoid Hiding where
+ mempty = NotHidden
+ mappend NotHidden h = h
+ mappend h NotHidden = h
+ mappend Hidden Hidden = Hidden
+ mappend Instance Instance = Instance
+ mappend _ _ = __IMPOSSIBLE__
+
instance KillRange Hiding where
killRange = id
+-- | Decorating something with 'Hiding' information.
+data WithHiding a = WithHiding Hiding a
+ deriving (Typeable, Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance Decoration WithHiding where
+ traverseF f (WithHiding h a) = WithHiding h <$> f a
+
+instance Applicative WithHiding where
+ pure = WithHiding mempty
+ WithHiding h f <*> WithHiding h' a = WithHiding (mappend h h') (f a)
+
+instance HasRange a => HasRange (WithHiding a) where
+ getRange = getRange . dget
+
+instance SetRange a => SetRange (WithHiding a) where
+ setRange = fmap . setRange
+
+instance KillRange a => KillRange (WithHiding a) where
+ killRange = fmap killRange
+
-- | A lens to access the 'Hiding' attribute in data structures.
-- Minimal implementation: @getHiding@ and one of @setHiding@ or @mapHiding@.
class LensHiding a where
@@ -93,6 +122,15 @@ instance LensHiding Hiding where
setHiding = const
mapHiding = id
+instance LensHiding (WithHiding a) where
+ getHiding (WithHiding h _) = h
+ setHiding h (WithHiding _ a) = WithHiding h a
+ mapHiding f (WithHiding h a) = WithHiding (f h) a
+
+-- | Monoidal composition of 'Hiding' information in some data.
+mergeHiding :: LensHiding a => WithHiding a -> a
+mergeHiding (WithHiding h a) = mapHiding (mappend h) a
+
-- | @isHidden@ does not apply to 'Instance', only to 'Hidden'.
isHidden :: LensHiding a => a -> Bool
isHidden a = getHiding a == Hidden
@@ -119,27 +157,55 @@ makeInstance = setHiding Instance
-- * Relevance
---------------------------------------------------------------------------
+-- | An constructor argument is big if the sort of its type is bigger than
+-- the sort of the data type. Only parameters (and maybe forced arguments)
+-- are allowed to be big.
+-- @
+-- List : Set -> Set
+-- nil : (A : Set) -> List A
+-- @
+-- @A@ is big in constructor @nil@ as the sort @Set1@ of its type @Set@
+-- is bigger than the sort @Set@ of the data type @List@.
+data Big = Big | Small
+ deriving (Typeable, Show, Eq, Enum, Bounded)
+
+instance Ord Big where
+ Big <= Small = False
+ _ <= _ = True
+
-- | A function argument can be relevant or irrelevant.
--- See 'Agda.TypeChecking.Irrelevance'.
+-- See "Agda.TypeChecking.Irrelevance".
data Relevance
= Relevant -- ^ The argument is (possibly) relevant at compile-time.
| NonStrict -- ^ The argument may never flow into evaluation position.
-- Therefore, it is irrelevant at run-time.
-- It is treated relevantly during equality checking.
| Irrelevant -- ^ The argument is irrelevant at compile- and runtime.
- | Forced -- ^ The argument can be skipped during equality checking
+ | Forced Big -- ^ The argument can be skipped during equality checking
-- because its value is already determined by the type.
+ -- If a constructor argument is big, it has to be regarded
+ -- absent, otherwise we get into paradoxes.
| UnusedArg -- ^ The polarity checker has determined that this argument
-- is unused in the definition. It can be skipped during
-- equality checking but should be mined for solutions
-- of meta-variables with relevance 'UnusedArg'
- deriving (Typeable, Show, Eq, Enum, Bounded)
+ deriving (Typeable, Show, Eq)
+
+allRelevances :: [Relevance]
+allRelevances =
+ [ Relevant
+ , NonStrict
+ , Irrelevant
+ , Forced Small
+ , Forced Big
+ , UnusedArg
+ ]
instance KillRange Relevance where
killRange rel = rel -- no range to kill
instance Arbitrary Relevance where
- arbitrary = elements [minBound..maxBound]
+ arbitrary = elements allRelevances
instance Ord Relevance where
(<=) = moreRelevant
@@ -186,8 +252,8 @@ moreRelevant r r' =
(UnusedArg, _) -> True
(_, UnusedArg) -> False
-- third bottom
- (Forced, _) -> True
- (_, Forced) -> False
+ (Forced{}, _) -> True
+ (_, Forced{}) -> False
-- remaining case
(NonStrict,NonStrict) -> True
@@ -206,7 +272,7 @@ data ArgInfo c = ArgInfo
instance KillRange c => KillRange (ArgInfo c) where
killRange (ArgInfo h r cs) = killRange3 ArgInfo h r cs
-{- FAILED to define a less for ArgInfo, since it is parametrized by c
+{- FAILED to define a lens for ArgInfo, since it is parametrized by c
can't instantiate the following to f c = Arg c e
since Haskell does not have lambda abstraction
@@ -270,12 +336,12 @@ instance Decoration (Arg c) where
instance HasRange a => HasRange (Arg c a) where
getRange = getRange . unArg
+instance SetRange a => SetRange (Arg c a) where
+ setRange r = fmap $ setRange r
+
instance (KillRange c, KillRange a) => KillRange (Arg c a) where
killRange (Arg info a) = killRange2 Arg info a
-instance Sized a => Sized (Arg c a) where
- size = size . unArg
-
instance (Eq a, Eq c) => Eq (Arg c a) where
Arg (ArgInfo h1 _ cs1) x1 == Arg (ArgInfo h2 _ cs2) x2 = (h1, cs1, x1) == (h2, cs2, x2)
@@ -285,11 +351,13 @@ instance (Show a, Show c) => Show (Arg c a) where
showH Hidden s = "{" ++ s ++ "}"
showH NotHidden s = "(" ++ s ++ ")"
showH Instance s = "{{" ++ s ++ "}}"
- showR Irrelevant s = "." ++ s
- showR NonStrict s = "?" ++ s
- showR Forced s = "!" ++ s
- showR UnusedArg s = "k" ++ s -- constant
- showR Relevant s = "r" ++ s -- Andreas: I want to see it explicitly
+ showR r s = case r of
+ Irrelevant -> "." ++ s
+ NonStrict -> "?" ++ s
+ Forced Big -> "!b" ++ s
+ Forced Small -> "!" ++ s
+ UnusedArg -> "k" ++ s -- constant
+ Relevant -> "r" ++ s -- Andreas: I want to see it explicitly
showC cs s = show cs ++ s
instance LensHiding (Arg c e) where
@@ -392,9 +460,6 @@ instance HasRange a => HasRange (Dom c a) where
instance (KillRange c, KillRange a) => KillRange (Dom c a) where
killRange (Dom info a) = killRange2 Dom info a
-instance Sized a => Sized (Dom c a) where
- size = size . unDom
-
instance (Show a, Show c) => Show (Dom c a) where
show = show . argFromDom
@@ -447,12 +512,12 @@ instance Decoration (Named name) where
instance HasRange a => HasRange (Named name a) where
getRange = getRange . namedThing
+instance SetRange a => SetRange (Named name a) where
+ setRange r = fmap $ setRange r
+
instance (KillRange name, KillRange a) => KillRange (Named name a) where
killRange (Named n a) = Named (killRange n) (killRange a)
-instance Sized a => Sized (Named name a) where
- size = size . namedThing
-
instance Show a => Show (Named_ a) where
show (Named Nothing x) = show x
show (Named (Just n) x) = rawNameToString (rangedThing n) ++ " = " ++ show x
@@ -555,6 +620,9 @@ type Arity = Nat
data NameId = NameId Integer Integer
deriving (Eq, Ord, Typeable)
+instance KillRange NameId where
+ killRange = id
+
instance Show NameId where
show (NameId x i) = show x ++ "@" ++ show i
diff --git a/src/full/Agda/Syntax/Concrete.hs b/src/full/Agda/Syntax/Concrete.hs
index 1ba4fa2..bc124d4 100644
--- a/src/full/Agda/Syntax/Concrete.hs
+++ b/src/full/Agda/Syntax/Concrete.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveDataTypeable,
+ DeriveFoldable,
+ DeriveFunctor,
+ DeriveTraversable,
+ FlexibleInstances #-}
{-| The concrete syntax is a raw representation of the program text
without any desugaring at all. This is what the parser produces.
@@ -62,6 +62,8 @@ import Data.Typeable (Typeable)
import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
import Data.List
+import Data.Set (Set)
+
import Agda.Syntax.Position
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo)
import qualified Agda.Syntax.Common as Common
@@ -70,6 +72,7 @@ import Agda.Syntax.Notation
import Agda.Syntax.Literal
import Agda.Syntax.Concrete.Name
+import qualified Agda.Syntax.Abstract.Name as A
import Agda.Utils.Lens
@@ -101,7 +104,14 @@ data Expr
| Underscore !Range (Maybe String) -- ^ ex: @_@ or @_A_5@
| RawApp !Range [Expr] -- ^ before parsing operators
| App !Range Expr (NamedArg Expr) -- ^ ex: @e e@, @e {e}@, or @e {x = e}@
- | OpApp !Range QName [NamedArg (OpApp Expr)] -- ^ ex: @e + e@
+ | OpApp !Range QName (Set A.Name)
+ [NamedArg (OpApp Expr)] -- ^ ex: @e + e@
+ -- The 'QName' is
+ -- possibly ambiguous,
+ -- but it must
+ -- correspond to one of
+ -- the names in the
+ -- set.
| WithApp !Range Expr [Expr] -- ^ ex: @e | e1 | .. | en@
| HiddenArg !Range (Named_ Expr) -- ^ ex: @{e}@ or @{x=e}@
| InstanceArg !Range (Named_ Expr) -- ^ ex: @{{e}}@ or @{{x=e}}@
@@ -131,7 +141,7 @@ data Expr
| Equal !Range Expr Expr -- ^ ex: @a = b@, used internally in the parser
deriving (Typeable)
-instance NFData Expr
+instance NFData Expr where rnf x = seq x ()
-- | Concrete patterns. No literals in patterns at the moment.
data Pattern
@@ -139,7 +149,12 @@ data Pattern
| QuoteP !Range -- ^ @quote@
| AppP Pattern (NamedArg Pattern) -- ^ @p p'@ or @p {x = p'}@
| RawAppP !Range [Pattern] -- ^ @p1..pn@ before parsing operators
- | OpAppP !Range QName [NamedArg Pattern] -- ^ eg: @p => p'@ for operator @_=>_@
+ | OpAppP !Range QName (Set A.Name)
+ [NamedArg Pattern] -- ^ eg: @p => p'@ for operator @_=>_@
+ -- The 'QName' is possibly
+ -- ambiguous, but it must
+ -- correspond to one of
+ -- the names in the set.
| HiddenP !Range (Named_ Pattern) -- ^ @{p}@ or @{x = p}@
| InstanceP !Range (Named_ Pattern) -- ^ @{{p}}@ or @{{x = p}}@
| ParenP !Range Pattern -- ^ @(p)@
@@ -150,7 +165,7 @@ data Pattern
| LitP Literal -- ^ @0@, @1@, etc.
deriving (Typeable)
-instance NFData Pattern
+instance NFData Pattern where rnf x = seq x ()
-- | A lambda binding is either domain free or typed.
type LamBinding = LamBinding' TypedBindings
@@ -162,11 +177,14 @@ data LamBinding' a
-- | A sequence of typed bindings with hiding information. Appears in dependent
-- function spaces, typed lambdas, and telescopes.
+--
+-- If the individual binding contains hiding information as well, the
+-- 'Hiding' in @TypedBindings@ must be the unit 'NotHidden'.
type TypedBindings = TypedBindings' TypedBinding
data TypedBindings' a = TypedBindings !Range (Arg a)
- -- ^ . @(xs : e)@ or @{xs : e}@
+ -- ^ . @(xs : e)@ or @{xs : e}@ or something like @(x {y} _ : e)@.
deriving (Typeable, Functor, Foldable, Traversable)
data BoundName = BName
@@ -187,7 +205,7 @@ mkBoundName x f = BName x x f
type TypedBinding = TypedBinding' Expr
data TypedBinding' e
- = TBind !Range [BoundName] e -- ^ Binding @(x1 ... xn : A)@.
+ = TBind !Range [WithHiding BoundName] e -- ^ Binding @(x1 ... xn : A)@.
| TLet !Range [Declaration] -- ^ Let binding @(let Ds)@ or @(open M args)@.
deriving (Typeable, Functor, Foldable, Traversable)
@@ -239,15 +257,7 @@ data LHSCore
}
deriving (Typeable)
-instance NFData LHSCore
-
-{- TRASH
-lhsCoreToPattern :: LHSCore -> Pattern
-lhsCoreToPattern (LHSHead f args) = OpAppP (fuseRange f args) (unqualify f) args
-lhsCoreToPattern (LHSProj d ps1 lhscore ps2) = OpAppP (fuseRange d ps) (unqualify) ps
- where p = lhsCoreToPattern lhscore
- ps = ps1 ++ p : ps2
--}
+instance NFData LHSCore where rnf x = seq x ()
type RHS = RHS' Expr
data RHS' e
@@ -440,7 +450,7 @@ patternHead p =
AppP p p' -> patternHead p
RawAppP _ [] -> __IMPOSSIBLE__
RawAppP _ (p:_) -> patternHead p
- OpAppP _ name ps -> return $ unqualify name
+ OpAppP _ name _ ps -> return $ unqualify name
HiddenP _ (namedPat) -> patternHead (namedThing namedPat)
ParenP _ p -> patternHead p
WildP _ -> Nothing
@@ -460,7 +470,7 @@ patternNames p =
IdentP x -> [unqualify x]
AppP p p' -> concatMap patternNames [p, namedArg p']
RawAppP _ ps -> concatMap patternNames ps
- OpAppP _ name ps -> unqualify name : concatMap (patternNames . namedArg) ps
+ OpAppP _ name _ ps -> unqualify name : concatMap (patternNames . namedArg) ps
HiddenP _ (namedPat) -> patternNames (namedThing namedPat)
ParenP _ p -> patternNames p
WildP _ -> []
@@ -475,6 +485,26 @@ patternNames p =
Instances
--------------------------------------------------------------------------}
+-- Lenses
+------------------------------------------------------------------------
+
+instance LensRelevance TypedBindings where
+ getRelevance (TypedBindings _ b) = getRelevance b
+ mapRelevance f (TypedBindings r b) = TypedBindings r $ mapRelevance f b
+
+instance LensHiding TypedBindings where
+ getHiding (TypedBindings _ b) = getHiding b
+ mapHiding f (TypedBindings r b) = TypedBindings r $ mapHiding f b
+
+instance LensHiding LamBinding where
+ getHiding (DomainFree ai _) = getHiding ai
+ getHiding (DomainFull a) = getHiding a
+ mapHiding f (DomainFree ai x) = DomainFree (mapHiding f ai) x
+ mapHiding f (DomainFull a) = DomainFull $ mapHiding f a
+
+-- HasRange instances
+------------------------------------------------------------------------
+
instance HasRange e => HasRange (OpApp e) where
getRange e = case e of
Ordinary e -> getRange e
@@ -489,7 +519,7 @@ instance HasRange Expr where
Underscore r _ -> r
App r _ _ -> r
RawApp r _ -> r
- OpApp r _ _ -> r
+ OpApp r _ _ _ -> r
WithApp r _ _ -> r
Lam r _ _ -> r
AbsurdLam r _ -> r
@@ -617,7 +647,7 @@ instance HasRange AsName where
instance HasRange Pattern where
getRange (IdentP x) = getRange x
getRange (AppP p q) = fuseRange p q
- getRange (OpAppP r _ _) = r
+ getRange (OpAppP r _ _ _) = r
getRange (RawAppP r _) = r
getRange (ParenP r _) = r
getRange (WildP r) = r
@@ -629,6 +659,30 @@ instance HasRange Pattern where
getRange (InstanceP r _) = r
getRange (DotP r _) = r
+-- SetRange instances
+------------------------------------------------------------------------
+
+instance SetRange TypedBindings where
+ setRange r (TypedBindings _ b) = TypedBindings r b
+
+instance SetRange Pattern where
+ setRange r (IdentP x) = IdentP (setRange r x)
+ setRange r (AppP p q) = AppP (setRange r p) (setRange r q)
+ setRange r (OpAppP _ x ns ps) = OpAppP r x ns ps
+ setRange r (RawAppP _ ps) = RawAppP r ps
+ setRange r (ParenP _ p) = ParenP r p
+ setRange r (WildP _) = WildP r
+ setRange r (AsP _ x p) = AsP r (setRange r x) p
+ setRange r (AbsurdP _) = AbsurdP r
+ setRange r (LitP l) = LitP (setRange r l)
+ setRange r (QuoteP _) = QuoteP r
+ setRange r (HiddenP _ p) = HiddenP r p
+ setRange r (InstanceP _ p) = InstanceP r p
+ setRange r (DotP _ e) = DotP r e
+
+-- KillRange instances
+------------------------------------------------------------------------
+
instance KillRange AsName where
killRange (AsName n _) = killRange1 (flip AsName noRange) n
@@ -666,7 +720,7 @@ instance KillRange Expr where
killRange (Underscore _ n) = Underscore noRange n
killRange (RawApp _ e) = killRange1 (RawApp noRange) e
killRange (App _ e a) = killRange2 (App noRange) e a
- killRange (OpApp _ n o) = killRange2 (OpApp noRange) n o
+ killRange (OpApp _ n ns o) = killRange3 (OpApp noRange) n ns o
killRange (WithApp _ e es) = killRange2 (WithApp noRange) e es
killRange (HiddenArg _ n) = killRange1 (HiddenArg noRange) n
killRange (InstanceArg _ n) = killRange1 (InstanceArg noRange) n
@@ -720,19 +774,19 @@ instance KillRange e => KillRange (OpApp e) where
killRange (Ordinary e) = killRange1 Ordinary e
instance KillRange Pattern where
- killRange (IdentP q) = killRange1 IdentP q
- killRange (AppP p n) = killRange2 AppP p n
- killRange (RawAppP _ p) = killRange1 (RawAppP noRange) p
- killRange (OpAppP _ n p) = killRange2 (OpAppP noRange) n p
- killRange (HiddenP _ n) = killRange1 (HiddenP noRange) n
- killRange (InstanceP _ n) = killRange1 (InstanceP noRange) n
- killRange (ParenP _ p) = killRange1 (ParenP noRange) p
- killRange (WildP _) = WildP noRange
- killRange (AbsurdP _) = AbsurdP noRange
- killRange (AsP _ n p) = killRange2 (AsP noRange) n p
- killRange (DotP _ e) = killRange1 (DotP noRange) e
- killRange (LitP l) = killRange1 LitP l
- killRange (QuoteP _) = QuoteP noRange
+ killRange (IdentP q) = killRange1 IdentP q
+ killRange (AppP p n) = killRange2 AppP p n
+ killRange (RawAppP _ p) = killRange1 (RawAppP noRange) p
+ killRange (OpAppP _ n ns p) = killRange3 (OpAppP noRange) n ns p
+ killRange (HiddenP _ n) = killRange1 (HiddenP noRange) n
+ killRange (InstanceP _ n) = killRange1 (InstanceP noRange) n
+ killRange (ParenP _ p) = killRange1 (ParenP noRange) p
+ killRange (WildP _) = WildP noRange
+ killRange (AbsurdP _) = AbsurdP noRange
+ killRange (AsP _ n p) = killRange2 (AsP noRange) n p
+ killRange (DotP _ e) = killRange1 (DotP noRange) e
+ killRange (LitP l) = killRange1 LitP l
+ killRange (QuoteP _) = QuoteP noRange
instance KillRange Pragma where
killRange (OptionsPragma _ s) = OptionsPragma noRange s
diff --git a/src/full/Agda/Syntax/Concrete/Definitions.hs b/src/full/Agda/Syntax/Concrete/Definitions.hs
index acc46d1..af11faf 100644
--- a/src/full/Agda/Syntax/Concrete/Definitions.hs
+++ b/src/full/Agda/Syntax/Concrete/Definitions.hs
@@ -1,9 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveDataTypeable,
+ FlexibleInstances,
+ PatternGuards,
+ TupleSections #-}
+
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
-- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.
--
@@ -39,15 +43,28 @@ module Agda.Syntax.Concrete.Definitions
, Measure
) where
+import Prelude hiding (null)
+
import Control.Arrow ((***))
-import Control.Applicative
+import Control.Applicative hiding (empty)
import Control.Monad.State
-import Data.Foldable hiding (concatMap, mapM_, notElem, elem, all)
+import Data.Foldable hiding
+ ( all
+ , concatMap
+ , elem
+ , mapM_
+ , notElem
+#if MIN_VERSION_base(4,8,0)
+ , null
+#endif
+ )
+
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Maybe
import Data.Monoid ( Monoid(mappend, mempty) )
-import Data.List as List
+import Data.List as List hiding (null)
import Data.Traversable (traverse)
import Data.Typeable (Typeable)
@@ -63,6 +80,7 @@ import Agda.Utils.Except ( Error(noMsg, strMsg), MonadError(throwError) )
import Agda.Utils.Lens
import Agda.Utils.List (headMaybe, isSublistOf)
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Pretty
import Agda.Utils.Update
@@ -79,28 +97,32 @@ import Agda.Utils.Impossible
modifiers have been distributed to the individual declarations.
-}
data NiceDeclaration
- = Axiom Range Fixity' Access IsInstance ArgInfo Name Expr
- -- ^ Axioms and functions can be declared irrelevant. (Hiding should be NotHidden)
- | NiceField Range Fixity' Access IsAbstract Name (Arg Expr)
- | PrimitiveFunction Range Fixity' Access IsAbstract Name Expr
- | NiceMutual Range TerminationCheck [NiceDeclaration]
- | NiceModule Range Access IsAbstract QName Telescope [Declaration]
- | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective
- | NiceOpen Range QName ImportDirective
- | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective
- | NicePragma Range Pragma
- | NiceRecSig Range Fixity' Access Name [LamBinding] Expr
- | NiceDataSig Range Fixity' Access Name [LamBinding] Expr
- | NiceFunClause Range Access IsAbstract TerminationCheck Declaration
- -- ^ a uncategorized function clause, could be a function clause
- -- without type signature or a pattern lhs (e.g. for irrefutable let)x
- | FunSig Range Fixity' Access IsInstance ArgInfo TerminationCheck Name Expr
- | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause] -- ^ block of function clauses (we have seen the type signature before)
- | DataDef Range Fixity' IsAbstract Name [LamBinding] [NiceConstructor]
- | RecDef Range Fixity' IsAbstract Name (Maybe (Ranged Induction)) (Maybe (ThingWithFixity Name)) [LamBinding] [NiceDeclaration]
- | NicePatternSyn Range Fixity' Name [Arg Name] Pattern
- | NiceUnquoteDecl Range Fixity' Access IsAbstract TerminationCheck Name Expr
- deriving (Typeable, Show)
+ = Axiom Range Fixity' Access IsInstance ArgInfo Name Expr
+ -- ^ Axioms and functions can be declared irrelevant. (Hiding should be NotHidden)
+ | NiceField Range Fixity' Access IsAbstract Name (Arg Expr)
+ | PrimitiveFunction Range Fixity' Access IsAbstract Name Expr
+ | NiceMutual Range TerminationCheck [NiceDeclaration]
+ | NiceModule Range Access IsAbstract QName Telescope [Declaration]
+ | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective
+ | NiceOpen Range QName ImportDirective
+ | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective
+ | NicePragma Range Pragma
+ | NiceRecSig Range Fixity' Access Name [LamBinding] Expr
+ | NiceDataSig Range Fixity' Access Name [LamBinding] Expr
+ | NiceFunClause Range Access IsAbstract TerminationCheck Declaration
+ -- ^ An uncategorized function clause, could be a function clause
+ -- without type signature or a pattern lhs (e.g. for irrefutable let).
+ -- The 'Declaration' is the actual 'FunClause'.
+ | FunSig Range Fixity' Access IsInstance ArgInfo TerminationCheck Name Expr
+ | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause]
+ -- ^ Block of function clauses (we have seen the type signature before).
+ -- The 'Declaration's are the original declarations that were processed
+ -- into this 'FunDef' and are only used in 'notSoNiceDeclaration'.
+ | DataDef Range Fixity' IsAbstract Name [LamBinding] [NiceConstructor]
+ | RecDef Range Fixity' IsAbstract Name (Maybe (Ranged Induction)) (Maybe (ThingWithFixity Name)) [LamBinding] [NiceDeclaration]
+ | NicePatternSyn Range Fixity' Name [Arg Name] Pattern
+ | NiceUnquoteDecl Range Fixity' Access IsInstance IsAbstract TerminationCheck Name Expr
+ deriving (Typeable, Show)
type TerminationCheck = Common.TerminationCheck Measure
@@ -121,6 +143,8 @@ data Clause = Clause Name LHS RHS WhereClause [Clause]
-- | The exception type.
data DeclarationException
= MultipleFixityDecls [(Name, [Fixity'])]
+ | InvalidName Name
+ | DuplicateDefinition Name
| MissingDefinition Name
| MissingWithClauses Name
| MissingTypeSignature LHS -- Andreas 2012-06-02: currently unused, remove after a while -- Fredrik 2012-09-20: now used, can we keep it?
@@ -147,6 +171,8 @@ data DeclarationException
instance HasRange DeclarationException where
getRange (MultipleFixityDecls xs) = getRange (fst $ head xs)
+ getRange (InvalidName x) = getRange x
+ getRange (DuplicateDefinition x) = getRange x
getRange (MissingDefinition x) = getRange x
getRange (MissingWithClauses x) = getRange x
getRange (MissingTypeSignature x) = getRange x
@@ -184,7 +210,7 @@ instance HasRange NiceDeclaration where
getRange (NiceDataSig r _ _ _ _ _) = r
getRange (NicePatternSyn r _ _ _ _) = r
getRange (NiceFunClause r _ _ _ _) = r
- getRange (NiceUnquoteDecl r _ _ _ _ _ _) = r
+ getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r
instance Error DeclarationException where
noMsg = strMsg ""
@@ -192,46 +218,53 @@ instance Error DeclarationException where
-- These error messages can (should) be terminated by a dot ".",
-- there is no error context printed after them.
-instance Show DeclarationException where
- show (MultipleFixityDecls xs) = show $
+instance Pretty DeclarationException where
+ pretty (MultipleFixityDecls xs) =
sep [ fsep $ pwords "Multiple fixity or syntax declarations for"
, vcat $ map f xs
]
where
f (x, fs) = pretty x <> text ": " <+> fsep (map pretty fs)
- show (MissingDefinition x) = show $ fsep $
+ pretty (InvalidName x) = fsep $
+ pwords "Invalid name:" ++ [pretty x]
+ pretty (DuplicateDefinition x) = fsep $
+ pwords "Duplicate definition of" ++ [pretty x]
+ pretty (MissingDefinition x) = fsep $
pwords "Missing definition for" ++ [pretty x]
- show (MissingWithClauses x) = show $ fsep $
+ pretty (MissingWithClauses x) = fsep $
pwords "Missing with-clauses for function" ++ [pretty x]
- show (MissingTypeSignature x) = show $ fsep $
+ pretty (MissingTypeSignature x) = fsep $
pwords "Missing type signature for left hand side" ++ [pretty x]
- show (MissingDataSignature x) = show $ fsep $
+ pretty (MissingDataSignature x) = fsep $
pwords "Missing type signature for " ++ [pretty x]
- show (WrongDefinition x k k') = show $ fsep $ pretty x :
+ pretty (WrongDefinition x k k') = fsep $ pretty x :
pwords ("has been declared as a " ++ show k ++
", but is being defined as a " ++ show k')
- show (WrongParameters x) = show $ fsep $
+ pretty (WrongParameters x) = fsep $
pwords "List of parameters does not match previous signature for" ++ [pretty x]
- show (AmbiguousFunClauses lhs xs) = show $ fsep $
- pwords "More than one matching type signature for left hand side" ++ [pretty lhs] ++
- pwords "it could belong to any of:" ++ map pretty xs
- show (UnknownNamesInFixityDecl xs) = show $ fsep $
+ pretty (AmbiguousFunClauses lhs xs) = sep
+ [ fsep $
+ pwords "More than one matching type signature for left hand side " ++ [pretty lhs] ++
+ pwords "it could belong to any of:"
+ , vcat $ map (pretty . PrintRange) xs
+ ]
+ pretty (UnknownNamesInFixityDecl xs) = fsep $
pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):" ++ map pretty xs
- show (UselessPrivate _) = show $ fsep $
+ pretty (UselessPrivate _) = fsep $
pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."
- show (UselessAbstract _) = show $ fsep $
+ pretty (UselessAbstract _) = fsep $
pwords "Using abstract here has no effect. Abstract applies only definitions like data definitions, record type definitions and function clauses."
- show (UselessInstance _) = show $ fsep $
+ pretty (UselessInstance _) = fsep $
pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."
- show (WrongContentPostulateBlock _) = show $ fsep $
+ pretty (WrongContentPostulateBlock _) = fsep $
pwords "A postulate block can only contain type signatures or instance blocks"
- show (PragmaNoTerminationCheck _) = show $ fsep $
+ pretty (PragmaNoTerminationCheck _) = fsep $
pwords "Pragma {-# NO_TERMINATION_CHECK #-} has been removed. To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}."
- show (InvalidTerminationCheckPragma _) = show $ fsep $
+ pretty (InvalidTerminationCheckPragma _) = fsep $
pwords "Termination checking pragmas can only precede a mutual block or a function definition."
- show (InvalidMeasureMutual _) = show $ fsep $
+ pretty (InvalidMeasureMutual _) = fsep $
pwords "In a mutual block, either all functions must have the same (or no) termination checking pragma."
- show (NotAllowedInMutual nd) = show $ fsep $
+ pretty (NotAllowedInMutual nd) = fsep $
[text $ decl nd] ++ pwords "are not allowed in mutual blocks"
where
decl Axiom{} = "Postulates"
@@ -252,10 +285,10 @@ instance Show DeclarationException where
decl FunDef{} = __IMPOSSIBLE__
decl RecDef{} = __IMPOSSIBLE__
decl DataDef{} = __IMPOSSIBLE__
- show (Codata _) =
+ pretty (Codata _) = text $
"The codata construction has been removed. " ++
"Use the INFINITY builtin instead."
- show (DeclarationPanic s) = s
+ pretty (DeclarationPanic s) = text s
{--------------------------------------------------------------------------
The niceifier
@@ -336,15 +369,15 @@ data NiceEnv = NiceEnv
, fixs :: Fixities
}
-type LoneSigs = [(DataRecOrFun, Name)]
+type LoneSigs = Map Name DataRecOrFun
type Fixities = Map Name Fixity'
-- | Initial nicifier state.
initNiceEnv :: NiceEnv
initNiceEnv = NiceEnv
- { _loneSigs = []
- , fixs = Map.empty
+ { _loneSigs = empty
+ , fixs = empty
}
-- * Handling the lone signatures, stored to infer mutual blocks.
@@ -356,18 +389,22 @@ loneSigs f e = f (_loneSigs e) <&> \ s -> e { _loneSigs = s }
-- | Adding a lone signature to the state.
-addLoneSig :: DataRecOrFun -> Name -> Nice ()
-addLoneSig k x = loneSigs %= ((k, x) :)
+addLoneSig :: Name -> DataRecOrFun -> Nice ()
+addLoneSig x k = loneSigs %== \ s -> do
+ let (mr, s') = Map.insertLookupWithKey (\ k new old -> new) x k s
+ case mr of
+ Nothing -> return s'
+ Just{} -> throwError $ DuplicateDefinition x
-- | Remove a lone signature from the state.
removeLoneSig :: Name -> Nice ()
-removeLoneSig x = loneSigs %= filter (\ (k', x') -> x /= x')
+removeLoneSig x = loneSigs %= Map.delete x
-- | Search for forward type signature.
getSig :: Name -> Nice (Maybe DataRecOrFun)
-getSig n = fmap fst . List.find (\ (k, x) -> x == n) <$> use loneSigs
+getSig x = Map.lookup x <$> use loneSigs
-- | Check that no lone signatures are left in the state.
@@ -376,15 +413,17 @@ noLoneSigs = null <$> use loneSigs
-- | Ensure that all forward declarations have been given a definition.
-checkLoneSigs :: LoneSigs -> Nice ()
+checkLoneSigs :: [(Name, a)] -> Nice ()
checkLoneSigs xs =
case xs of
[] -> return ()
- (_, x):_ -> throwError $ MissingDefinition x
-
+ (x, _):_ -> throwError $ MissingDefinition x
+-- | Check whether name is not "_" and return its fixity.
getFixity :: Name -> Nice Fixity'
-getFixity x = gets $ Map.findWithDefault defaultFixity' x . fixs
+getFixity x = do
+ when (isUnderscore x) $ throwError $ InvalidName x
+ gets $ Map.findWithDefault defaultFixity' x . fixs
runNice :: Nice a -> Either DeclarationException a
runNice nice = nice `evalStateT` initNiceEnv
@@ -425,7 +464,7 @@ niceDeclarations ds = do
put $ initNiceEnv { fixs = fixs }
ds <- nice ds
-- Check that every signature got its definition.
- checkLoneSigs =<< use loneSigs
+ checkLoneSigs . Map.toList =<< use loneSigs
-- Note that loneSigs is ensured to be empty.
-- (Important, since inferMutualBlocks also uses loneSigs state).
inferMutualBlocks ds
@@ -467,7 +506,7 @@ niceDeclarations ds = do
OtherDecl -> (d :) <$> inferMutualBlocks ds
LoneDef _ x -> __IMPOSSIBLE__
LoneSig k x -> do
- addLoneSig k x
+ addLoneSig x k
(tcs, (ds0, ds1)) <- untilAllDefined [terminationCheck k] ds
tc <- combineTermChecks (getRange d) tcs
@@ -486,9 +525,9 @@ niceDeclarations ds = do
done <- noLoneSigs
if done then return (tc, ([], ds)) else
case ds of
- [] -> __IMPOSSIBLE__ <$ (checkLoneSigs =<< use loneSigs)
+ [] -> __IMPOSSIBLE__ <$ (checkLoneSigs . Map.toList =<< use loneSigs)
d : ds -> case declKind d of
- LoneSig k x -> addLoneSig k x >> cons d (untilAllDefined (terminationCheck k : tc) ds)
+ LoneSig k x -> addLoneSig x k >> cons d (untilAllDefined (terminationCheck k : tc) ds)
LoneDef k x -> removeLoneSig x >> cons d (untilAllDefined (terminationCheck k : tc) ds)
OtherDecl -> cons d (untilAllDefined tc ds)
where
@@ -512,8 +551,8 @@ niceDeclarations ds = do
nice (Pragma (TerminationCheckPragma r tc) : d@FunClause{} : ds) | notMeasure tc =
niceFunClause tc d ds
nice (Pragma (TerminationCheckPragma r tc) : ds@(UnquoteDecl{} : _)) | notMeasure tc = do
- NiceUnquoteDecl r f p a _ x e : ds <- nice ds
- return $ NiceUnquoteDecl r f p a tc x e : ds
+ NiceUnquoteDecl r f p a i _ x e : ds <- nice ds
+ return $ NiceUnquoteDecl r f p a i tc x e : ds
nice (d@TypeSig{} : Pragma (TerminationCheckPragma r (TerminationMeasure _ x)) : ds) =
niceTypeSig (TerminationMeasure r x) d ds
@@ -528,7 +567,7 @@ niceDeclarations ds = do
DataSig r CoInductive x tel t -> throwError (Codata r)
Data r CoInductive x tel t cs -> throwError (Codata r)
DataSig r Inductive x tel t -> do
- addLoneSig (DataName $ parameters tel) x
+ addLoneSig x (DataName $ parameters tel)
(++) <$> dataOrRec DataDef NiceDataSig niceAxioms r x tel (Just t) Nothing
<*> nice ds
Data r Inductive x tel t cs -> do
@@ -536,7 +575,7 @@ niceDeclarations ds = do
(++) <$> dataOrRec DataDef NiceDataSig niceAxioms r x tel t (Just cs)
<*> nice ds
RecordSig r x tel t -> do
- addLoneSig (RecName $ parameters tel) x
+ addLoneSig x (RecName $ parameters tel)
fx <- getFixity x
(NiceRecSig r fx PublicAccess x tel t :) <$> nice ds
Record r x i c tel t cs -> do
@@ -580,7 +619,7 @@ niceDeclarations ds = do
UnquoteDecl r x e -> do
fx <- getFixity x
- (NiceUnquoteDecl r fx PublicAccess ConcreteDef TerminationCheck x e :) <$> nice ds
+ (NiceUnquoteDecl r fx PublicAccess NotInstanceDef ConcreteDef TerminationCheck x e :) <$> nice ds
-- Andreas, AIM XX: do not forbid NO_TERMINATION_CHECK in maintenance version.
-- Pragma (TerminationCheckPragma r NoTerminationCheck) ->
-- throwError $ PragmaNoTerminationCheck r
@@ -590,7 +629,7 @@ niceDeclarations ds = do
niceFunClause :: TerminationCheck -> Declaration -> [Declaration] -> Nice [NiceDeclaration]
niceFunClause termCheck d@(FunClause lhs _ _) ds = do
- xs <- map snd . filter (isFunName . fst) <$> use loneSigs
+ xs <- map fst . filter (isFunName . snd) . Map.toList <$> use loneSigs
-- for each type signature 'x' waiting for clauses, we try
-- if we have some clauses for 'x'
fixs <- gets fixs
@@ -626,14 +665,14 @@ niceDeclarations ds = do
return $ d : ds1
-- case: clauses match more than one sigs (ambiguity)
- l -> throwError $ AmbiguousFunClauses lhs (map fst l) -- "ambiguous function clause; cannot assign it uniquely to one type signature"
+ l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l -- "ambiguous function clause; cannot assign it uniquely to one type signature"
niceFunClause _ _ _ = __IMPOSSIBLE__
niceTypeSig :: TerminationCheck -> Declaration -> [Declaration] -> Nice [NiceDeclaration]
niceTypeSig termCheck d@(TypeSig info x t) ds = do
fx <- getFixity x
-- register x as lone type signature, to recognize clauses later
- addLoneSig (FunName termCheck) x
+ addLoneSig x (FunName termCheck)
ds <- nice ds
return $ FunSig (getRange d) fx PublicAccess NotInstanceDef info termCheck x t : ds
niceTypeSig _ _ _ = __IMPOSSIBLE__
@@ -653,13 +692,15 @@ niceDeclarations ds = do
dataOrRec mkDef mkSig niceD r x tel mt mcs = do
mds <- traverse niceD mcs
f <- getFixity x
- return $
- [mkSig (fuseRange x t) f PublicAccess x tel t | Just t <- [mt] ] ++
- [mkDef (getRange x) f ConcreteDef x (concatMap dropType tel) ds | Just ds <- [mds] ]
+ return $ catMaybes $
+ [ mt <&> \ t -> mkSig (fuseRange x t) f PublicAccess x tel t
+ , mkDef r f ConcreteDef x (concatMap dropType tel) <$> mds
+ ]
where
- dropType (DomainFull (TypedBindings r (Common.Arg i (TBind _ xs _)))) =
- map (DomainFree i) xs
- dropType (DomainFull (TypedBindings _ (Common.Arg _ TLet{}))) = []
+ dropType :: LamBinding -> [LamBinding]
+ dropType (DomainFull (TypedBindings _r (Common.Arg ai (TBind _ xs _)))) =
+ map (mergeHiding . fmap (DomainFree ai)) xs
+ dropType (DomainFull (TypedBindings _r (Common.Arg _ TLet{}))) = []
dropType b@DomainFree{} = [b]
-- Translate axioms
@@ -702,10 +743,10 @@ niceDeclarations ds = do
d : expand p ps ds
where
expand _ _ [] = []
- expand p ps (FunClause (Ellipsis _ ps' eqs []) rhs wh : ds) =
- FunClause (LHS p (ps ++ ps') eqs []) rhs wh : expand p ps ds
- expand p ps (FunClause (Ellipsis _ ps' eqs es) rhs wh : ds) =
- FunClause (LHS p (ps ++ ps') eqs es) rhs wh : expand p (ps ++ ps') ds
+ expand p ps (FunClause (Ellipsis r ps' eqs []) rhs wh : ds) =
+ FunClause (LHS (setRange r p) ((setRange r ps) ++ ps') eqs []) rhs wh : expand p ps ds
+ expand p ps (FunClause (Ellipsis r ps' eqs es) rhs wh : ds) =
+ FunClause (LHS (setRange r p) ((setRange r ps) ++ ps') eqs es) rhs wh : expand p (ps ++ ps') ds
expand p ps (d@(FunClause (LHS _ _ _ []) _ _) : ds) =
d : expand p ps ds
expand _ _ (d@(FunClause (LHS p ps _ (_ : _)) _ _) : ds) =
@@ -807,10 +848,10 @@ niceDeclarations ds = do
isTypeSig d | LoneSig{} <- declKind d = True
isTypeSig _ = False
- sigNames = [ (k, x) | LoneSig k x <- map declKind ds ]
- defNames = [ (k, x) | LoneDef k x <- map declKind ds ]
+ sigNames = [ (x, k) | LoneSig k x <- map declKind ds ]
+ defNames = [ (x, k) | LoneDef k x <- map declKind ds ]
-- compute the set difference with equality just on names
- loneNames = [ (k, x) | (k, x) <- sigNames, List.all ((x /=) . snd) defNames ]
+ loneNames = [ (x, k) | (x, k) <- sigNames, List.all ((x /=) . fst) defNames ]
-- Andreas, 2013-02-28 (issue 804):
-- do not termination check a mutual block if any of its
@@ -818,7 +859,7 @@ niceDeclarations ds = do
termCheck (FunSig _ _ _ _ _ tc _ _) = tc
termCheck (FunDef _ _ _ _ tc _ _) = tc
termCheck (NiceMutual _ tc _) = tc
- termCheck (NiceUnquoteDecl _ _ _ _ tc _ _) = tc
+ termCheck (NiceUnquoteDecl _ _ _ _ _ tc _ _) = tc
termCheck _ = TerminationCheck
-- A mutual block cannot have a measure,
@@ -844,7 +885,7 @@ niceDeclarations ds = do
-- no effect on fields or primitives, the InAbstract field there is unused
NiceField r f p _ x e -> return $ NiceField r f p AbstractDef x e
PrimitiveFunction r f p _ x e -> return $ PrimitiveFunction r f p AbstractDef x e
- NiceUnquoteDecl r f p _ t x e -> return $ NiceUnquoteDecl r f p AbstractDef t x e
+ NiceUnquoteDecl r f p i _ t x e -> return $ NiceUnquoteDecl r f p i AbstractDef t x e
NiceModule{} -> return $ d
NiceModuleMacro{} -> return $ d
Axiom{} -> return $ d
@@ -895,7 +936,7 @@ niceDeclarations ds = do
NiceRecSig r f p x ls t -> (\ p -> NiceRecSig r f p x ls t) <$> setPrivate p
NiceDataSig r f p x ls t -> (\ p -> NiceDataSig r f p x ls t) <$> setPrivate p
NiceFunClause r p a termCheck d -> (\ p -> NiceFunClause r p a termCheck d) <$> setPrivate p
- NiceUnquoteDecl r f p a t x e -> (\ p -> NiceUnquoteDecl r f p a t x e) <$> setPrivate p
+ NiceUnquoteDecl r f p i a t x e -> (\ p -> NiceUnquoteDecl r f p i a t x e) <$> setPrivate p
NicePragma _ _ -> return $ d
NiceOpen _ _ _ -> return $ d
NiceImport _ _ _ _ _ -> return $ d
@@ -933,12 +974,12 @@ niceDeclarations ds = do
case d of
Axiom r f p i rel x e -> (\ i -> Axiom r f p i rel x e) <$> setInstance i
FunSig r f p i rel tc x e -> (\ i -> FunSig r f p i rel tc x e) <$> setInstance i
+ NiceUnquoteDecl r f p i a tc x e -> (\ i -> NiceUnquoteDecl r f p i a tc x e) <$> setInstance i
NiceMutual{} -> return $ d
NiceFunClause{} -> return $ d
FunDef{} -> return $ d
NiceField{} -> return $ d
PrimitiveFunction{} -> return $ d
- NiceUnquoteDecl{} -> return $ d
NiceRecSig{} -> return $ d
NiceDataSig{} -> return $ d
NiceModuleMacro{} -> return $ d
@@ -1055,5 +1096,4 @@ notSoNiceDeclaration d =
RecDef r _ _ x i c bs ds -> Record r x i (unThing <$> c) bs Nothing $ map notSoNiceDeclaration ds
where unThing (ThingWithFixity c _) = c
NicePatternSyn r _ n as p -> PatternSyn r n as p
- NiceUnquoteDecl r _ _ _ _ x e -> UnquoteDecl r x e
-
+ NiceUnquoteDecl r _ _ _ _ _ x e -> UnquoteDecl r x e
diff --git a/src/full/Agda/Syntax/Concrete/Generic.hs b/src/full/Agda/Syntax/Concrete/Generic.hs
index f499b2b..5e0fe80 100644
--- a/src/full/Agda/Syntax/Concrete/Generic.hs
+++ b/src/full/Agda/Syntax/Concrete/Generic.hs
@@ -1,9 +1,8 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
-- | Generic traversal and reduce for concrete syntax,
--- in the style of 'Agda.Syntax.Internal.Generic'.
+-- in the style of "Agda.Syntax.Internal.Generic".
--
-- However, here we use the terminology of 'Data.Traversable'.
@@ -100,7 +99,7 @@ instance ExprLike Expr where
Underscore{} -> f $ e0
RawApp r es -> f $ RawApp r $ mapE es
App r e es -> f $ App r (mapE e) $ mapE es
- OpApp r q es -> f $ OpApp r q $ mapE es
+ OpApp r q ns es -> f $ OpApp r q ns $ mapE es
WithApp r e es -> f $ WithApp r (mapE e) $ mapE es
HiddenArg r e -> f $ HiddenArg r $ mapE e
InstanceArg r e -> f $ InstanceArg r $ mapE e
diff --git a/src/full/Agda/Syntax/Concrete/Name.hs b/src/full/Agda/Syntax/Concrete/Name.hs
index 437b592..9ca524d 100644
--- a/src/full/Agda/Syntax/Concrete/Name.hs
+++ b/src/full/Agda/Syntax/Concrete/Name.hs
@@ -1,8 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-| Names in the concrete syntax are just strings (or lists of strings for
qualified names).
@@ -42,7 +41,7 @@ data Name
| NoName !Range NameId -- ^ @_@.
deriving (Typeable)
-instance NFData Name
+instance NFData Name where rnf x = seq x ()
instance Underscore Name where
underscore = NoName noRange __IMPOSSIBLE__
@@ -249,32 +248,32 @@ instance IsNoName QName where
-- instead. Later, simply derive Show for these types:
instance Show Name where
- show (Name _ xs) = concatMap show xs
- show (NoName _ _) = "_"
+ show (Name _ xs) = concatMap show xs
+ show (NoName _ _) = "_"
instance Show NamePart where
- show Hole = "_"
- show (Id s) = rawNameToString s
+ show Hole = "_"
+ show (Id s) = rawNameToString s
instance Show QName where
- show (Qual m x) = show m ++ "." ++ show x
- show (QName x) = show x
+ show (Qual m x) = show m ++ "." ++ show x
+ show (QName x) = show x
------------------------------------------------------------------------
-- * Printing names
------------------------------------------------------------------------
instance Pretty Name where
- pretty (Name _ xs) = hcat $ map pretty xs
- pretty (NoName _ _) = text $ "_"
+ pretty (Name _ xs) = hcat $ map pretty xs
+ pretty (NoName _ _) = text $ "_"
instance Pretty NamePart where
- pretty Hole = text $ "_"
- pretty (Id s) = text $ rawNameToString s
+ pretty Hole = text $ "_"
+ pretty (Id s) = text $ rawNameToString s
instance Pretty QName where
- pretty (Qual m x) = pretty m <> pretty "." <> pretty x
- pretty (QName x) = pretty x
+ pretty (Qual m x) = pretty m <> pretty "." <> pretty x
+ pretty (QName x) = pretty x
instance Pretty TopLevelModuleName where
pretty (TopLevelModuleName ms) = text $ intercalate "." ms
diff --git a/src/full/Agda/Syntax/Concrete/Operators.hs b/src/full/Agda/Syntax/Concrete/Operators.hs
index 2fa1546..d37ad98 100644
--- a/src/full/Agda/Syntax/Concrete/Operators.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-| The parser doesn't know about operators and parses everything as normal
@@ -45,57 +45,54 @@ import Agda.Syntax.Scope.Base
import Agda.Syntax.Scope.Monad
import Agda.TypeChecking.Monad.Base (typeError, TypeError(..), LHSOrPatSyn(..))
-import Agda.TypeChecking.Monad.Benchmark (billSub)
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TypeChecking.Monad.State (getScope)
import Agda.TypeChecking.Monad.Options
import Agda.Utils.Either
import Agda.Utils.ReadP
+#if MIN_VERSION_base(4,8,0)
+import Agda.Utils.List hiding ( uncons )
+#else
import Agda.Utils.List
+#endif
#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
--- * Building the parser
+-- * Billing
---------------------------------------------------------------------------
-partsInScope :: FlatScope -> ScopeM (Set QName)
-partsInScope flat = do
- (names, ops) <- localNames flat
- let xs = concatMap parts names ++ concatMap notationNames ops
- return $ Set.fromList xs
- where
- qual xs x = foldr Qual (QName x) xs
- parts q = parts' (init $ qnameParts q) (unqualify q)
- parts' ms (NoName _ _) = []
- parts' ms x@(Name _ [_]) = [qual ms x]
- -- The first part should be qualified, but not the rest
- parts' ms x@(Name _ xs) = qual ms x : qual ms (Name noRange [first]) : [ QName $ Name noRange [i] | i <- iparts ]
- where
- first:iparts = [ i | i@(Id {}) <- xs ]
+-- | Bills the operator parser.
+
+billToParser :: ScopeM a -> ScopeM a
+billToParser = Bench.billTo [Bench.Parsing, Bench.Operators]
+
+---------------------------------------------------------------------------
+-- * Building the parser
+---------------------------------------------------------------------------
type FlatScope = Map QName [AbstractName]
--- | Compute all unqualified defined names in scope and their fixities.
--- Note that overloaded names (constructors) can have several fixities.
--- Then we 'chooseFixity'. (See issue 1194.)
-getDefinedNames :: [KindOfName] -> FlatScope -> [(QName, Fixity')]
+-- | Compute all defined names in scope and their fixities/notations.
+-- Note that overloaded names (constructors) can have several
+-- fixities/notations. Then we 'mergeNotations'. (See issue 1194.)
+getDefinedNames :: [KindOfName] -> FlatScope -> [[NewNotation]]
getDefinedNames kinds names =
- [ (x, chooseFixity fixs)
+ [ mergeNotations $
+ map (\d -> namesToNotation x (A.qnameName $ anameName d)) ds
| (x, ds) <- Map.toList names
, any ((`elem` kinds) . anameKind) ds
- , let fixs = map (A.nameFixity . A.qnameName . anameName) ds
- , not (null fixs)
+ , not (null ds)
-- Andreas, 2013-03-21 see Issue 822
-- Names can have different kinds, i.e., 'defined' and 'constructor'.
-- We need to consider all names that have *any* matching kind,
-- not only those whose first appearing kind is matching.
- ]
+ ]
--- | Compute all names (first component) and operators (second component) in
--- scope.
+-- | Compute all names (first component) and operators/notations
+-- (second component) in scope.
localNames :: FlatScope -> ScopeM ([QName], [NewNotation])
localNames flat = do
let defs = getDefinedNames allKindsOfNames flat
@@ -106,17 +103,16 @@ localNames flat = do
, "defs = " ++ show defs
, "locals= " ++ show locals
]
- return $ split $ uniqOn fst $ map localOp locals ++ defs
+ let localNots = map localOp locals
+ localNames = Set.fromList $ map notaName localNots
+ otherNots = filter (\n -> not (Set.member (notaName n) localNames))
+ (concat defs)
+ return $ split $ localNots ++ otherNots
where
- localOp (x, y) = (QName x, A.nameFixity y)
- split ops = partitionEithers $ concatMap opOrNot ops
-
- opOrNot (q, Fixity' fx syn) = Left q : map Right (notaFromName ++ nota)
- where
- notaFromName = case unqualify q of
- Name _ [_] -> []
- x -> [NewNotation q fx $ syntaxOf x]
- nota = if null syn then [] else [NewNotation q fx syn]
+ localOp (x, y) = namesToNotation (QName x) y
+ split ops = partitionEithers $ concatMap opOrNot ops
+ opOrNot n = Left (notaName n) :
+ if null (notation n) then [] else [Right n]
-- | Data structure filled in by @buildParsers@.
-- The top-level parser @pTop@ is of primary interest,
@@ -167,10 +163,10 @@ buildParsers r flat use = do
[ "names = " ++ show names
, "ops = " ++ show ops
, "cons = " ++ show cons ]
- let conparts = Set.fromList $ concatMap notationNames $ map oldToNewNotation cons
- opsparts = Set.fromList $ concatMap notationNames $ ops
+ let conparts = Set.fromList $ concatMap notationNames $ concat cons
+ opsparts = Set.fromList $ concatMap notationNames ops
allParts = Set.union conparts opsparts
- connames = Set.fromList $ map fst cons
+ connames = Set.fromList $ map (notaName . head) cons
(non, fix) = partition nonfix ops
set = Set.fromList names
isAtom x = case use of
@@ -192,23 +188,16 @@ buildParsers r flat use = do
level :: NewNotation -> Integer
level = fixityLevel . notaFixity
- isinfixl, isinfixr, isinfix, nonfix, isprefix, ispostfix :: NewNotation -> Bool
-
- isinfixl (NewNotation _ (LeftAssoc _ _) syn) = isInfix syn
- isinfixl _ = False
-
- isinfixr (NewNotation _ (RightAssoc _ _) syn) = isInfix syn
- isinfixr _ = False
+ nonfix, isprefix, ispostfix :: NewNotation -> Bool
+ nonfix = (== NonfixNotation) . notationKind . notation
+ isprefix = (== PrefixNotation) . notationKind . notation
+ ispostfix = (== PostfixNotation) . notationKind . notation
- isinfix (NewNotation _ (NonAssoc _ _) syn) = isInfix syn
- isinfix _ = False
-
- nonfix (NewNotation _ _ syn) = notationKind syn == NonfixNotation
- isprefix (NewNotation _ _ syn) = notationKind syn == PrefixNotation
- ispostfix (NewNotation _ _ syn) = notationKind syn == PostfixNotation
-
- isInfix :: Notation -> Bool
- isInfix syn = notationKind syn == InfixNotation
+ isinfix :: Associativity -> NewNotation -> Bool
+ isinfix ass syn =
+ notationKind (notation syn) == InfixNotation
+ &&
+ fixityAssoc (notaFixity syn) == ass
-- | Group operators by precedence level
order :: [NewNotation] -> [[NewNotation]]
@@ -221,9 +210,9 @@ buildParsers r flat use = do
[] -> [id]
fs -> fs
where
- inlfx = fixP infixlP isinfixl
- inrfx = fixP infixrP isinfixr
- infx = fixP infixP isinfix
+ inlfx = fixP infixlP (isinfix LeftAssoc)
+ inrfx = fixP infixrP (isinfix RightAssoc)
+ infx = fixP infixP (isinfix NonAssoc)
prefx = fixP prefixP isprefix
postfx = fixP postfixP ispostfix
@@ -242,7 +231,7 @@ instance IsExpr Expr where
exprView e = case e of
Ident x -> LocalV x
App _ e1 e2 -> AppV e1 e2
- OpApp r d es -> OpAppV d es
+ OpApp r d ns es -> OpAppV d ns es
HiddenArg _ e -> HiddenArgV e
InstanceArg _ e -> InstanceArgV e
Paren _ e -> ParenV e
@@ -250,33 +239,33 @@ instance IsExpr Expr where
Underscore{} -> WildV e
_ -> OtherV e
unExprView e = case e of
- LocalV x -> Ident x
- AppV e1 e2 -> App (fuseRange e1 e2) e1 e2
- OpAppV d es -> OpApp (fuseRange d es) d es
- HiddenArgV e -> HiddenArg (getRange e) e
+ LocalV x -> Ident x
+ AppV e1 e2 -> App (fuseRange e1 e2) e1 e2
+ OpAppV d ns es -> OpApp (fuseRange d es) d ns es
+ HiddenArgV e -> HiddenArg (getRange e) e
InstanceArgV e -> InstanceArg (getRange e) e
- ParenV e -> Paren (getRange e) e
- LamV bs e -> Lam (fuseRange bs e) bs e
- WildV e -> e
- OtherV e -> e
+ ParenV e -> Paren (getRange e) e
+ LamV bs e -> Lam (fuseRange bs e) bs e
+ WildV e -> e
+ OtherV e -> e
instance IsExpr Pattern where
exprView e = case e of
- IdentP x -> LocalV x
- AppP e1 e2 -> AppV e1 e2
- OpAppP r d es -> OpAppV d ((map . fmap . fmap) Ordinary es)
- HiddenP _ e -> HiddenArgV e
- InstanceP _ e -> InstanceArgV e
- ParenP _ e -> ParenV e
- WildP{} -> WildV e
- _ -> OtherV e
+ IdentP x -> LocalV x
+ AppP e1 e2 -> AppV e1 e2
+ OpAppP r d ns es -> OpAppV d ns ((map . fmap . fmap) Ordinary es)
+ HiddenP _ e -> HiddenArgV e
+ InstanceP _ e -> InstanceArgV e
+ ParenP _ e -> ParenV e
+ WildP{} -> WildV e
+ _ -> OtherV e
unExprView e = case e of
LocalV x -> IdentP x
AppV e1 e2 -> AppP e1 e2
- OpAppV d es -> let ess :: [NamedArg Pattern]
+ OpAppV d ns es -> let ess :: [NamedArg Pattern]
ess = (map . fmap . fmap) (fromOrdinary __IMPOSSIBLE__) es
- in OpAppP (fuseRange d es) d ess
+ in OpAppP (fuseRange d es) d ns ess
HiddenArgV e -> HiddenP (getRange e) e
InstanceArgV e -> InstanceP (getRange e) e
ParenV e -> ParenP (getRange e) e
@@ -284,46 +273,21 @@ instance IsExpr Pattern where
WildV e -> e
OtherV e -> e
-{- TRASH
-instance IsExpr LHSCore where
- exprView e = case e of
- LHSHead f ps -> foldl AppV (LocalV f) $ map exprView ps
- LHSProj d ps1 e ps2 -> foldl AppV (LocalV d) $
- map exprView ps1 ++ exprView e : map exprView ps2
- unExprView e = LHSHead f ps
- where p :: Pattern
- p = unExprView
- (f, ps) = lhsArgs p
--}
-
---------------------------------------------------------------------------
-- * Helpers for pattern and lhs parsing
---------------------------------------------------------------------------
--- Andreas, 2011-11-24 moved here from ConcreteToAbstract
-lhsArgs :: Pattern -> (Name, [NamedArg Pattern])
-lhsArgs p = case lhsArgs' p of
- Just (x, args) -> (x, args)
- Nothing -> __IMPOSSIBLE__
-
--- | @lhsArgs' p@ splits a lhs @f ps@, given as a pattern @p@,
--- into @(f, ps)@.
-lhsArgs' :: Pattern -> Maybe (Name, [NamedArg Pattern])
-lhsArgs' p = case patternAppView p of
- Common.Arg _ (Named _ (IdentP (QName x))) : ps -> Just (x, ps)
- _ -> Nothing
-
-- | View a pattern @p@ as a list @p0 .. pn@ where @p0@ is the identifier
-- (in most cases a constructor).
--
-- Pattern needs to be parsed already (operators resolved).
patternAppView :: Pattern -> [NamedArg Pattern]
patternAppView p = case p of
- AppP p arg -> patternAppView p ++ [arg]
- OpAppP _ x ps -> defaultNamedArg (IdentP x) : ps
- ParenP _ p -> patternAppView p
- RawAppP _ _ -> __IMPOSSIBLE__
- _ -> [ defaultNamedArg p ]
+ AppP p arg -> patternAppView p ++ [arg]
+ OpAppP _ x _ ps -> defaultNamedArg (IdentP x) : ps
+ ParenP _ p -> patternAppView p
+ RawAppP _ _ -> __IMPOSSIBLE__
+ _ -> [ defaultNamedArg p ]
---------------------------------------------------------------------------
@@ -336,7 +300,7 @@ parsePat prs p = case p of
AppP p (Common.Arg info q) ->
fullParen' <$> (AppP <$> parsePat prs p <*> (Common.Arg info <$> traverse (parsePat prs) q))
RawAppP _ ps -> fullParen' <$> (parsePat prs =<< parse prs ps)
- OpAppP r d ps -> fullParen' . OpAppP r d <$> (mapM . traverse . traverse) (parsePat prs) ps
+ OpAppP r d ns ps -> fullParen' . OpAppP r d ns <$> (mapM . traverse . traverse) (parsePat prs) ps
HiddenP _ _ -> fail "bad hidden argument"
InstanceP _ _ -> fail "bad instance argument"
AsP r x p -> AsP r x <$> parsePat prs p
@@ -402,7 +366,8 @@ parseLHS' lhsOrPatSyn top p = do
rs -> typeError $ AmbiguousParseForLHS lhsOrPatSyn p $
map (fullParen . fst) rs
where
- getNames kinds flat = map fst $ getDefinedNames kinds flat
+ getNames kinds flat =
+ map (notaName . head) $ getDefinedNames kinds flat
-- validPattern returns an empty or singleton list (morally a Maybe)
validPattern :: PatternCheckConfig -> Pattern -> [(Pattern, ParseLHS)]
@@ -461,7 +426,7 @@ classifyPattern conf p =
-- intended _* applied to true, or as true applied to a variable *. If we
-- check arities this problem won't appear.
parseLHS :: Name -> Pattern -> ScopeM LHSCore
-parseLHS top p = do
+parseLHS top p = billToParser $ do
res <- parseLHS' IsLHS (Just top) p
case res of
Right (f, lhs) -> return lhs
@@ -480,7 +445,7 @@ parsePatternSyn :: Pattern -> ScopeM Pattern
parsePatternSyn = parsePatternOrSyn IsPatSyn
parsePatternOrSyn :: LHSOrPatSyn -> Pattern -> ScopeM Pattern
-parsePatternOrSyn lhsOrPatSyn p = do
+parsePatternOrSyn lhsOrPatSyn p = billToParser $ do
res <- parseLHS' lhsOrPatSyn Nothing p
case res of
Left p -> return p
@@ -502,7 +467,7 @@ validConPattern cons p = case appView p of
appView :: Pattern -> [Pattern]
appView p = case p of
AppP p a -> appView p ++ [namedArg a]
- OpAppP _ op ps -> IdentP op : map namedArg ps
+ OpAppP _ op _ ps -> IdentP op : map namedArg ps
ParenP _ p -> appView p
RawAppP _ _ -> __IMPOSSIBLE__
HiddenP _ _ -> __IMPOSSIBLE__
@@ -517,7 +482,7 @@ patternQNames p = case p of
ParenP _ p -> patternQNames p
HiddenP _ p -> patternQNames (namedThing p)
InstanceP _ p -> patternQNames (namedThing p)
- OpAppP r d ps -> __IMPOSSIBLE__
+ OpAppP r d _ ps -> __IMPOSSIBLE__
AppP{} -> __IMPOSSIBLE__
AsP r x p -> patternQNames p
AbsurdP{} -> []
@@ -536,25 +501,16 @@ qualifierModules qs =
-- | Parse a list of expressions into an application.
parseApplication :: [Expr] -> ScopeM Expr
parseApplication [e] = return e
-parseApplication es = do
+parseApplication es = billToParser $ do
-- Build the parser
let ms = qualifierModules [ q | Ident q <- es ]
flat <- flattenScope ms <$> getScope
- -- Andreas, 2014-04-27 Time for building the parser is negligible
- p <- -- billSub [Bench.Parsing, Bench.Operators, Bench.BuildParser] $
- buildParsers (getRange es) flat UseBoundNames
+ p <- buildParsers (getRange es) flat UseBoundNames
-- Parse
case force $ parse (pTop p) es of
[e] -> return e
- [] -> do
- -- When the parser fails and a name is not in scope, it is more
- -- useful to say that to the user rather than just "failed".
- inScope <- partsInScope flat
- case [ x | Ident x <- es, not (Set.member x inScope) ] of
- [] -> typeError $ NoParseForApplication es
- xs -> typeError $ NotInScope xs
-
+ [] -> typeError $ NoParseForApplication es
es' -> typeError $ AmbiguousParseForApplication es $ map fullParen es'
parseModuleIdentifier :: Expr -> ScopeM QName
@@ -562,7 +518,7 @@ parseModuleIdentifier (Ident m) = return m
parseModuleIdentifier e = typeError $ NotAModuleExpr e
parseRawModuleApplication :: [Expr] -> ScopeM (QName, [NamedArg Expr])
-parseRawModuleApplication es = do
+parseRawModuleApplication es = billToParser $ do
let e : es_args = es
m <- parseModuleIdentifier e
@@ -574,12 +530,7 @@ parseRawModuleApplication es = do
-- Parse
case {-force $-} parse (pArgs p) es_args of -- TODO: not sure about forcing
[as] -> return (m, as)
- [] -> do
- inScope <- partsInScope flat
- case [ x | Ident x <- es_args, not (Set.member x inScope) ] of
- [] -> typeError $ NoParseForApplication es
- xs -> typeError $ NotInScope xs
-
+ [] -> typeError $ NoParseForApplication es
ass -> do
let f = fullParen . foldl (App noRange) (Ident m)
typeError $ AmbiguousParseForApplication es
@@ -619,7 +570,7 @@ fullParen' e = case exprView e of
Hidden -> e2
Instance -> e2
NotHidden -> fullParen' <$> e2
- OpAppV x es -> par $ unExprView $ OpAppV x $ (map . fmap . fmap . fmap) fullParen' es
+ OpAppV x ns es -> par $ unExprView $ OpAppV x ns $ (map . fmap . fmap . fmap) fullParen' es
LamV bs e -> par $ unExprView $ LamV bs (fullParen e)
where
par = unExprView . ParenV
diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
index b8e5a55..28ce619 100644
--- a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Syntax.Concrete.Operators.Parser where
@@ -6,15 +6,20 @@ module Agda.Syntax.Concrete.Operators.Parser where
import Control.Exception (throw)
import Data.Maybe
+import Data.Set (Set)
import Agda.Syntax.Position
+import qualified Agda.Syntax.Abstract.Name as A
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)
import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Concrete
+
import Agda.TypeChecking.Monad.Base (TCErr(Exception))
-import Agda.Utils.ReadP
+
import Agda.Utils.Monad
+import Agda.Utils.Pretty
+import Agda.Utils.ReadP
#include "undefined.h"
import Agda.Utils.Impossible
@@ -24,7 +29,9 @@ data ExprView e
| WildV e
| OtherV e
| AppV e (NamedArg e)
- | OpAppV QName [NamedArg (OpApp e)]
+ | OpAppV QName (Set A.Name) [NamedArg (OpApp e)]
+ -- ^ The 'QName' is possibly ambiguous, but it must correspond
+ -- to one of the names in the set.
| HiddenArgV (Named_ e)
| InstanceArgV (Named_ e)
| LamV [LamBinding] e
@@ -79,8 +86,9 @@ postop middleP = do
-- Note: it would be better to take the decision of "postprocessing" at the same
-- place as where the holes are discarded, however that would require a dependently
-- typed function (or duplicated code)
-opP :: IsExpr e => ReadP e e -> NewNotation -> ReadP e (NewNotation,Range,[e])
-opP p nsyn@(NewNotation q _ syn) = do
+opP :: IsExpr e =>
+ ReadP e e -> NewNotation -> ReadP e (NewNotation,Range,[e])
+opP p nsyn@(NewNotation q _ _ syn) = do
(range,es) <- worker (init $ qnameParts q) $ removeExternalHoles syn
return (nsyn,range,es)
where worker ms [IdPart x] = do r <- partP ms x; return (r,[])
@@ -97,7 +105,8 @@ opP p nsyn@(NewNotation q _ syn) = do
-- | Given a name with a syntax spec, and a list of parsed expressions
-- fitting it, rebuild the expression.
rebuild :: forall e. IsExpr e => NewNotation -> Range -> [e] -> e
-rebuild (NewNotation name _ syn) r es = unExprView $ OpAppV (setRange r name) exprs
+rebuild (NewNotation name names _ syn) r es =
+ unExprView $ OpAppV (setRange r name) names exprs
where
exprs = map findExprFor [0..lastHole]
filledHoles = zip es (filter isAHole syn)
@@ -118,7 +127,8 @@ rebuildBinding :: IsExpr e => ExprView e -> LamBinding
rebuildBinding (LocalV (QName name)) = DomainFree defaultArgInfo $ mkBoundName_ name
rebuildBinding (WildV e) =
DomainFree defaultArgInfo $ mkBoundName_ $ Name noRange [Hole]
-rebuildBinding e = throw $ Exception (getRange e) "Expected variable name in binding position"
+rebuildBinding e = throw $ Exception (getRange e) $
+ text "Expected variable name in binding position"
-- | Parse using the appropriate fixity, given a parser parsing the
-- operator part, the name of the operator, and a parser of
diff --git a/src/full/Agda/Syntax/Concrete/Pretty.hs b/src/full/Agda/Syntax/Concrete/Pretty.hs
index c2fe806..aa86a7b 100644
--- a/src/full/Agda/Syntax/Concrete/Pretty.hs
+++ b/src/full/Agda/Syntax/Concrete/Pretty.hs
@@ -1,13 +1,14 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+
{-| Pretty printer for the concrete syntax.
-}
module Agda.Syntax.Concrete.Pretty where
+import Prelude hiding (null)
+
import Data.Char
import Data.Functor
import Data.Maybe
@@ -20,6 +21,8 @@ import Agda.Syntax.Literal
import Agda.Syntax.Notation
import Agda.Syntax.Position
+import Agda.Utils.Functor
+import Agda.Utils.Null
import Agda.Utils.Pretty
import Agda.Utils.String
@@ -64,28 +67,19 @@ arrow, lambda :: Doc
arrow = text "\x2192"
lambda = text "\x03bb"
-pHidden :: Pretty a => ArgInfo -> a -> Doc
-pHidden i = bracks h . pretty
- where bracks Hidden = braces'
- bracks Instance = dbraces
- bracks NotHidden= id
- h = argInfoHiding i
-
-pRelevance :: Pretty a => ArgInfo -> a -> Doc
-pRelevance i a =
- let d = pretty a
- in if render d == "_" then d else pretty (argInfoRelevance i) <> d
-{-
-pRelevance Forced a = pretty a
-pRelevance UnusedArg a = pretty a
-pRelevance Relevant a = pretty a
-pRelevance Irrelevant a =
- let d = pretty a
- in if render d == "_" then d else text "." <> d
-pRelevance NonStrict a =
- let d = pretty a
- in if render d == "_" then d else text ".." <> d
--}
+-- | @prettyHiding info visible doc@ puts the correct braces
+-- around @doc@ according to info @info@ and returns
+-- @visible doc@ if the we deal with a visible thing.
+prettyHiding :: LensHiding a => a -> (Doc -> Doc) -> Doc -> Doc
+prettyHiding a parens =
+ case getHiding a of
+ Hidden -> braces'
+ Instance -> dbraces
+ NotHidden -> parens
+
+prettyRelevance :: LensRelevance a => a -> Doc -> Doc
+prettyRelevance a d =
+ if render d == "_" then d else pretty (getRelevance a) <> d
instance (Pretty a, Pretty b) => Pretty (a, b) where
pretty (a, b) = parens $ pretty a <> comma <+> pretty b
@@ -93,8 +87,11 @@ instance (Pretty a, Pretty b) => Pretty (a, b) where
instance Pretty (ThingWithFixity Name) where
pretty (ThingWithFixity n _) = pretty n
+instance Pretty a => Pretty (WithHiding a) where
+ pretty w = prettyHiding w id $ pretty $ dget w
+
instance Pretty Relevance where
- pretty Forced = empty
+ pretty Forced{} = empty
pretty UnusedArg = empty
pretty Relevant = empty
pretty Irrelevant = text "."
@@ -123,8 +120,8 @@ instance Pretty Expr where
-- sep [ pretty e1
-- , nest 2 $ fsep $ map pretty args
-- ]
- RawApp _ es -> fsep $ map pretty es
- OpApp _ q es -> fsep $ prettyOpApp q es
+ RawApp _ es -> fsep $ map pretty es
+ OpApp _ q _ es -> fsep $ prettyOpApp q es
WithApp _ e es -> fsep $
pretty e : map ((text "|" <+>) . pretty) es
@@ -193,21 +190,18 @@ instance Pretty BoundName where
instance Pretty LamBinding where
-- TODO guilhem: colors are unused (colored syntax disallowed)
- pretty (DomainFree i x) = pRelevance i $ pHidden i $ pretty x
+ pretty (DomainFree i x) = prettyRelevance i $ prettyHiding i id $ pretty x
pretty (DomainFull b) = pretty b
instance Pretty TypedBindings where
- pretty (TypedBindings _ a) =
- pRelevance (argInfo a) $ bracks $ pretty $ WithColors (argColors a) $ unArg a
+ pretty (TypedBindings _ a) = prettyRelevance a $ prettyHiding a p $
+ pretty $ WithColors (argColors a) $ unArg a
where
- bracks = case getHiding a of
- Hidden -> braces'
- Instance -> dbraces
- NotHidden | isMeta (unArg a) -> id
- | otherwise -> parens
+ p | isUnderscore (unArg a) = id
+ | otherwise = parens
- isMeta (TBind _ _ (Underscore _ Nothing)) = True
- isMeta _ = False
+ isUnderscore (TBind _ _ (Underscore _ Nothing)) = True
+ isUnderscore _ = False
newtype Tel = Tel Telescope
@@ -247,7 +241,7 @@ instance Pretty TypedBinding where
smashTel :: Telescope -> Telescope
smashTel (TypedBindings r (Common.Arg i (TBind r' xs e)) :
TypedBindings _ (Common.Arg i' (TBind _ ys e')) : tel)
- | show i == show i' && show e == show e' && all isUnnamed (xs ++ ys) =
+ | show i == show i' && show e == show e' && all (isUnnamed . dget) (xs ++ ys) =
smashTel (TypedBindings r (Common.Arg i (TBind r' (xs ++ ys) e)) : tel)
where
isUnnamed x = boundLabel x == boundName x
@@ -305,13 +299,13 @@ instance Pretty Declaration where
pretty d =
case d of
TypeSig i x e ->
- sep [ pRelevance i $ pretty x <+> pColors ":" (argInfoColors i)
+ sep [ prettyRelevance i $ pretty x <+> pColors ":" (argInfoColors i)
, nest 2 $ pretty e
]
Field x (Common.Arg i e) ->
sep [ text "field"
- , nest 2 $ pRelevance i $ pHidden i $
- TypeSig (i {argInfoRelevance = Relevant}) x e
+ , nest 2 $ prettyRelevance i $ prettyHiding i id $
+ pretty $ TypeSig (i {argInfoRelevance = Relevant}) x e
]
FunClause lhs rhs wh ->
sep [ pretty lhs
@@ -456,9 +450,12 @@ instance Pretty Pragma where
TerminationMeasure _ x -> hsep $ [text "MEASURE", pretty x]
instance Pretty Fixity where
- pretty (LeftAssoc _ n) = text "infixl" <+> text (show n)
- pretty (RightAssoc _ n) = text "infixr" <+> text (show n)
- pretty (NonAssoc _ n) = text "infix" <+> text (show n)
+ pretty (Fixity _ n ass) = text s <+> text (show n)
+ where
+ s = case ass of
+ LeftAssoc -> "infixl"
+ RightAssoc -> "infixr"
+ NonAssoc -> "infix"
instance Pretty GenPart where
pretty (IdPart x) = text x
@@ -478,7 +475,7 @@ instance Pretty e => Pretty (Arg e) where
-- Andreas 2010-09-24: and in record fields
pretty a = -- pRelevance r $
-- TODO guilhem: print colors
- pHidden (argInfo a) $ unArg a
+ prettyHiding (argInfo a) id $ pretty $ unArg a
instance Pretty e => Pretty (Named_ e) where
pretty (Named Nothing e) = pretty e
@@ -490,19 +487,19 @@ instance Pretty [Pattern] where
instance Pretty Pattern where
pretty p =
case p of
- IdentP x -> pretty x
- AppP p1 p2 -> sep [ pretty p1, nest 2 $ pretty p2 ]
- RawAppP _ ps -> fsep $ map pretty ps
- OpAppP _ q ps -> fsep $ prettyOpApp q ps
- HiddenP _ p -> braces' $ pretty p
- InstanceP _ p -> dbraces $ pretty p
- ParenP _ p -> parens $ pretty p
- WildP _ -> underscore
- AsP _ x p -> pretty x <> text "@" <> pretty p
- DotP _ p -> text "." <> pretty p
- AbsurdP _ -> text "()"
- LitP l -> pretty l
- QuoteP _ -> text "quote"
+ IdentP x -> pretty x
+ AppP p1 p2 -> sep [ pretty p1, nest 2 $ pretty p2 ]
+ RawAppP _ ps -> fsep $ map pretty ps
+ OpAppP _ q _ ps -> fsep $ prettyOpApp q ps
+ HiddenP _ p -> braces' $ pretty p
+ InstanceP _ p -> dbraces $ pretty p
+ ParenP _ p -> parens $ pretty p
+ WildP _ -> underscore
+ AsP _ x p -> pretty x <> text "@" <> pretty p
+ DotP _ p -> text "." <> pretty p
+ AbsurdP _ -> text "()"
+ LitP l -> pretty l
+ QuoteP _ -> text "quote"
prettyOpApp :: Pretty a => QName -> [a] -> [Doc]
prettyOpApp q es = prOp ms xs es
diff --git a/src/full/Agda/Syntax/Fixity.hs b/src/full/Agda/Syntax/Fixity.hs
index ddf7947..55d2c82 100644
--- a/src/full/Agda/Syntax/Fixity.hs
+++ b/src/full/Agda/Syntax/Fixity.hs
@@ -1,24 +1,32 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
{-| Definitions for fixity, precedence levels, and declared syntax.
-}
module Agda.Syntax.Fixity where
import Data.Foldable
+import Data.Function
import Data.List as List
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Traversable
import Data.Typeable (Typeable)
import Agda.Syntax.Position
import Agda.Syntax.Common
+import {-# SOURCE #-} qualified Agda.Syntax.Abstract.Name as A
import Agda.Syntax.Concrete.Name
import Agda.Syntax.Notation
import Agda.Utils.List
+#include "undefined.h"
+import Agda.Utils.Impossible
+
-- * Notation coupled with 'Fixity'
-- | The notation is handled as the fixity in the renamer.
@@ -36,27 +44,34 @@ data ThingWithFixity x = ThingWithFixity x Fixity'
-- | All the notation information related to a name.
data NewNotation = NewNotation
{ notaName :: QName
- -- ^ The concrete name the syntax or fixity belongs to.
+ , notaNames :: Set A.Name
+ -- ^ The names the syntax and/or fixity belong to.
+ --
+ -- Invariant: The set is non-empty. Every name in the list matches
+ -- 'notaName'.
, notaFixity :: Fixity
- -- ^ Associativity and precedence (fixity) of the name.
+ -- ^ Associativity and precedence (fixity) of the names.
, notation :: Notation
- -- ^ Syntax associated with the name.
+ -- ^ Syntax associated with the names.
} deriving (Typeable, Show)
--- | If an operator has no specific notation, recover it from its name.
-oldToNewNotation :: (QName, Fixity') -> NewNotation
-oldToNewNotation (name, Fixity' f syn) = NewNotation
- { notaName = name
+-- | If an operator has no specific notation, then it is computed from
+-- its name.
+namesToNotation :: QName -> A.Name -> NewNotation
+namesToNotation q n = NewNotation
+ { notaName = q
+ , notaNames = Set.singleton n
, notaFixity = f
- , notation = if null syn then syntaxOf $ unqualify name else syn
+ , notation = if null syn then syntaxOf $ unqualify q else syn
}
+ where Fixity' f syn = A.nameFixity n
-- | Return the 'IdPart's of a notation, the first part qualified,
-- the other parts unqualified.
-- This allows for qualified use of operators, e.g.,
-- @M.for x ∈ xs return e@, or @x ℕ.+ y@.
notationNames :: NewNotation -> [QName]
-notationNames (NewNotation q _ parts) =
+notationNames (NewNotation q _ _ parts) =
zipWith ($) (reQualify : repeat QName) [Name noRange [Id x] | IdPart x <- parts ]
where
-- The qualification of @q@.
@@ -84,44 +99,59 @@ syntaxOf (Name _ xs) = mkSyn 0 xs
defaultFixity' :: Fixity'
defaultFixity' = Fixity' defaultFixity defaultNotation
--- | Removes copies of @defaultFixity'@ from a list of fixities.
--- Never returns an empty list, though, rather a singleton list
--- consisting of @defaultFixity'@.
-interestingFixities :: [Fixity'] -> [Fixity']
-interestingFixities fixs = if null fixs' then [defaultFixity'] else fixs'
- where fixs' = filter (not . (== defaultFixity')) fixs
+-- | Merges all 'NewNotation's that have the same notation.
+--
+-- If all 'NewNotation's with a given notation have the same fixity,
+-- then this fixity is preserved, and otherwise it is replaced by
+-- 'defaultFixity'.
+--
+-- Precondition: No 'A.Name' may occur in more than one list element.
+-- Every 'NewNotation' must have the same 'notaName'.
+--
+-- Postcondition: No 'A.Name' occurs in more than one list element.
+mergeNotations :: [NewNotation] -> [NewNotation]
+mergeNotations = map (merge . fixFixities) . groupOn notation
+ where
+ fixFixities ns
+ | allEqual (map notaFixity ns) = ns
+ | otherwise =
+ map (\n -> n { notaFixity = defaultFixity }) ns
--- | If different interesting fixities are available for the same symbol,
--- we take none of them.
-chooseFixity :: [Fixity'] -> Fixity'
-chooseFixity fixs = if allEqual fixs' then head fixs' else defaultFixity'
- where fixs' = interestingFixities fixs
+ merge :: [NewNotation] -> NewNotation
+ merge [] = __IMPOSSIBLE__
+ merge ns@(n : _) = n { notaNames = Set.unions $ map notaNames ns }
-- * Fixity
+-- | Associativity.
+
+data Associativity = NonAssoc | LeftAssoc | RightAssoc
+ deriving (Eq, Ord, Show, Typeable)
+
-- | Fixity of operators.
-data Fixity
- = LeftAssoc { fixityRange :: Range, fixityLevel :: Integer }
- | RightAssoc { fixityRange :: Range, fixityLevel :: Integer }
- | NonAssoc { fixityRange :: Range, fixityLevel :: Integer }
+data Fixity =
+ Fixity { fixityRange :: Range
+ , fixityLevel :: Integer
+ , fixityAssoc :: Associativity
+ }
deriving (Typeable, Show)
instance Eq Fixity where
- LeftAssoc _ n == LeftAssoc _ m = n == m
- RightAssoc _ n == RightAssoc _ m = n == m
- NonAssoc _ n == NonAssoc _ m = n == m
- _ == _ = False
+ f1 == f2 = compare f1 f2 == EQ
+
+instance Ord Fixity where
+ compare = compare `on` (\f -> (fixityLevel f, fixityAssoc f))
-- For @instance Pretty Fixity@, see Agda.Syntax.Concrete.Pretty
-- | The default fixity. Currently defined to be @'NonAssoc' 20@.
defaultFixity :: Fixity
-defaultFixity = NonAssoc noRange 20
+defaultFixity = Fixity noRange 20 NonAssoc
-- | Hack used for @syntax@ facility.
noFixity :: Fixity
-noFixity = NonAssoc noRange (negate 666)
+noFixity = Fixity noRange (negate 666) NonAssoc
-- Ts,ts,ts, why the number of the beast? Revelation 13, 18
--
-- It's not the number of the beast, it's the negation of the
@@ -150,10 +180,10 @@ hiddenArgumentCtx Instance = TopCtx
-- | Do we need to bracket an operator application of the given fixity
-- in a context with the given precedence.
opBrackets :: Fixity -> Precedence -> Bool
-opBrackets (LeftAssoc _ n1)
- (LeftOperandCtx (LeftAssoc _ n2)) | n1 >= n2 = False
-opBrackets (RightAssoc _ n1)
- (RightOperandCtx (RightAssoc _ n2)) | n1 >= n2 = False
+opBrackets (Fixity _ n1 LeftAssoc)
+ (LeftOperandCtx (Fixity _ n2 LeftAssoc)) | n1 >= n2 = False
+opBrackets (Fixity _ n1 RightAssoc)
+ (RightOperandCtx (Fixity _ n2 RightAssoc)) | n1 >= n2 = False
opBrackets f1
(LeftOperandCtx f2) | fixityLevel f1 > fixityLevel f2 = False
opBrackets f1
@@ -204,9 +234,7 @@ instance HasRange Fixity where
getRange = fixityRange
instance KillRange Fixity where
- killRange (LeftAssoc _ n) = LeftAssoc noRange n
- killRange (RightAssoc _ n) = RightAssoc noRange n
- killRange (NonAssoc _ n) = NonAssoc noRange n
+ killRange f = f { fixityRange = noRange }
instance KillRange Fixity' where
- killRange (Fixity' f n) = killRange1 (flip Fixity' n) f
+ killRange (Fixity' f n) = killRange2 Fixity' f n
diff --git a/src/full/Agda/Syntax/Fixity.hs-boot b/src/full/Agda/Syntax/Fixity.hs-boot
new file mode 100644
index 0000000..ae7c31c
--- /dev/null
+++ b/src/full/Agda/Syntax/Fixity.hs-boot
@@ -0,0 +1,3 @@
+module Agda.Syntax.Fixity where
+
+data Fixity'
diff --git a/src/full/Agda/Syntax/Info.hs b/src/full/Agda/Syntax/Info.hs
index 5c91955..98d1109 100644
--- a/src/full/Agda/Syntax/Info.hs
+++ b/src/full/Agda/Syntax/Info.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-| An info object contains additional information about a piece of abstract
diff --git a/src/full/Agda/Syntax/Internal.hs b/src/full/Agda/Syntax/Internal.hs
index 5fda241..e586727 100644
--- a/src/full/Agda/Syntax/Internal.hs
+++ b/src/full/Agda/Syntax/Internal.hs
@@ -1,13 +1,14 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveDataTypeable,
+ DeriveFoldable,
+ DeriveFunctor,
+ DeriveTraversable,
+ FlexibleInstances,
+ GeneralizedNewtypeDeriving,
+ MultiParamTypeClasses,
+ StandaloneDeriving,
+ TemplateHaskell #-}
module Agda.Syntax.Internal
( module Agda.Syntax.Internal
@@ -18,15 +19,22 @@ module Agda.Syntax.Internal
import Prelude hiding (foldr, mapM, null)
import Control.Arrow ((***))
-import Control.Applicative
+import Control.Applicative hiding (empty)
import Control.Monad.Identity hiding (mapM)
import Control.Monad.State hiding (mapM)
import Control.Parallel
-import Data.Foldable
+import Data.Foldable ( Foldable, foldMap )
import Data.Function
import qualified Data.List as List
import Data.Maybe
+import Data.Monoid
+
+-- base-4.7 defines the Num instance for Sum
+#if !(MIN_VERSION_base(4,7,0))
+import Data.Orphans ()
+#endif
+
import Data.Traversable
import Data.Typeable (Typeable)
@@ -39,6 +47,7 @@ import Agda.Syntax.Abstract.Name
import Agda.Utils.Empty
import Agda.Utils.Functor
import Agda.Utils.Geniplate
+import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Null
import Agda.Utils.Permutation
@@ -157,9 +166,13 @@ data Abs a = Abs { absName :: ArgName, unAbs :: a }
| NoAbs { absName :: ArgName, unAbs :: a }
deriving (Typeable, Functor, Foldable, Traversable)
+instance Decoration Abs where
+ traverseF f (Abs x a) = Abs x <$> f a
+ traverseF f (NoAbs x a) = NoAbs x <$> f a
+
-- | Types are terms with a sort annotation.
--
-data Type' a = El { getSort :: Sort, unEl :: a }
+data Type' a = El { _getSort :: Sort, unEl :: a }
deriving (Typeable, Show, Functor, Foldable, Traversable)
type Type = Type' Term
@@ -167,6 +180,22 @@ type Type = Type' Term
instance Decoration Type' where
traverseF f (El s a) = El s <$> f a
+class LensSort a where
+ lensSort :: Lens' Sort a
+ getSort :: a -> Sort
+ getSort a = a ^. lensSort
+
+instance LensSort (Type' a) where
+ lensSort f (El s a) = f s <&> \ s' -> El s' a
+
+-- General instance leads to overlapping instances.
+-- instance (Decoration f, LensSort a) => LensSort (f a) where
+instance LensSort a => LensSort (Common.Dom c a) where
+ lensSort = traverseF . lensSort
+
+instance LensSort a => LensSort (Abs a) where
+ lensSort = traverseF . lensSort
+
-- | Sequence of types. An argument of the first type is bound in later types
-- and so on.
data Tele a = EmptyTel
@@ -175,14 +204,10 @@ data Tele a = EmptyTel
type Telescope = Tele (Dom Type)
-instance Null (Tele a) where
- null EmptyTel = True
- null ExtendTel{} = False
- empty = EmptyTel
-
+-- | A traversal for the names in a telescope.
mapAbsNamesM :: Applicative m => (ArgName -> m ArgName) -> Tele a -> m (Tele a)
mapAbsNamesM f EmptyTel = pure EmptyTel
-mapAbsNamesM f (ExtendTel a (Abs x b)) = ExtendTel a <$> (Abs <$> f x <*> mapAbsNamesM f b)
+mapAbsNamesM f (ExtendTel a ( Abs x b)) = ExtendTel a <$> ( Abs <$> f x <*> mapAbsNamesM f b)
mapAbsNamesM f (ExtendTel a (NoAbs x b)) = ExtendTel a <$> (NoAbs <$> f x <*> mapAbsNamesM f b)
-- Ulf, 2013-11-06: Last case is really impossible but I'd rather find out we
-- violated that invariant somewhere other than here.
@@ -203,13 +228,16 @@ replaceEmptyName x = mapAbsNames $ \ y -> if null y then x else y
-- | Sorts.
--
-data Sort = Type Level
- | Prop -- ignore me
- | Inf
- | DLub Sort (Abs Sort)
- -- ^ if the free variable occurs in the second sort
- -- the whole thing should reduce to Inf, otherwise
- -- it's the normal Lub
+data Sort
+ = Type Level -- ^ @Set ℓ@.
+ | Prop -- ^ Dummy sort.
+ | Inf -- ^ @Setω@.
+ | SizeUniv -- ^ @SizeUniv@, a sort inhabited by type @Size@.
+ | DLub Sort (Abs Sort)
+ -- ^ Dependent least upper bound.
+ -- If the free variable occurs in the second sort,
+ -- the whole thing should reduce to Inf,
+ -- otherwise it's the normal lub.
deriving (Typeable, Show)
-- | A level is a maximum expression of 0..n 'PlusLevel' expressions
@@ -219,14 +247,19 @@ data Sort = Type Level
newtype Level = Max [PlusLevel]
deriving (Show, Typeable)
-data PlusLevel = ClosedLevel Integer
- | Plus Integer LevelAtom
+data PlusLevel
+ = ClosedLevel Integer -- ^ @n@, to represent @Setₙ@.
+ | Plus Integer LevelAtom -- ^ @n + ℓ@.
deriving (Show, Typeable)
+-- | An atomic term of type @Level@.
data LevelAtom
= MetaLevel MetaId Elims
+ -- ^ A meta variable targeting @Level@ under some eliminations.
| BlockedLevel MetaId Term
- | NeutralLevel Term
+ -- ^ A term of type @Level@ whose reduction is blocked by a meta.
+ | NeutralLevel NotBlocked Term
+ -- ^ A neutral term of type @Level@.
| UnreducedLevel Term
-- ^ Introduced by 'instantiate', removed by 'reduce'.
deriving (Show, Typeable)
@@ -236,16 +269,112 @@ data LevelAtom
newtype MetaId = MetaId { metaId :: Nat }
deriving (Eq, Ord, Num, Real, Enum, Integral, Typeable)
+-- | Even if we are not stuck on a meta during reduction
+-- we can fail to reduce a definition by pattern matching
+-- for another reason.
+data NotBlocked
+ = StuckOn Elim
+ -- ^ The 'Elim' is neutral and block a pattern match.
+ | Underapplied
+ -- ^ Not enough arguments were supplied to complete the matching.
+ | AbsurdMatch
+ -- ^ We matched an absurd clause, results in a neutral 'Def'.
+ | MissingClauses
+ -- ^ We ran out of clauses, all considered clauses
+ -- produced an actual mismatch.
+ -- This can happen when try to reduce a function application
+ -- but we are still missing some function clauses.
+ -- See "Agda.TypeChecking.Patterns.Match".
+ | ReallyNotBlocked
+ -- ^ Reduction was not blocked, we reached a whnf
+ -- which can be anything but a stuck @'Def'@.
+ deriving (Show, Typeable)
+
+-- | 'ReallyNotBlocked' is the unit.
+-- 'MissingClauses' is dominant.
+-- @'StuckOn'{}@ should be propagated, if tied, we take the left.
+instance Monoid NotBlocked where
+ -- ReallyNotBlocked is neutral
+ mempty = ReallyNotBlocked
+ ReallyNotBlocked `mappend` b = b
+ -- MissingClauses is dominant (absorptive)
+ b@MissingClauses `mappend` _ = b
+ _ `mappend` b@MissingClauses = b
+ -- StuckOn is second strongest
+ b@StuckOn{} `mappend` _ = b
+ _ `mappend` b@StuckOn{} = b
+ b `mappend` _ = b
+
-- | Something where a meta variable may block reduction.
-data Blocked t = Blocked MetaId t
- | NotBlocked t
- deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable)
+data Blocked t
+ = Blocked { theBlockingMeta :: MetaId , ignoreBlocking :: t }
+ | NotBlocked { blockingStatus :: NotBlocked, ignoreBlocking :: t }
+ deriving (Typeable, Show, Functor, Foldable, Traversable)
+ -- deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable)
+-- | Blocking by a meta is dominant.
instance Applicative Blocked where
pure = notBlocked
- Blocked x f <*> e = Blocked x $ f (ignoreBlocking e)
- NotBlocked f <*> e = f <$> e
-
+ f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e)
+
+-- -- | Blocking by a meta is dominant.
+-- instance Applicative Blocked where
+-- pure = notBlocked
+-- Blocked x f <*> e = Blocked x $ f (ignoreBlocking e)
+-- NotBlocked nb f <*> Blocked x e = Blocked x $ f e
+-- NotBlocked nb f <*> NotBlocked nb' e = NotBlocked (nb `mappend` nb') $ f e
+
+-- | @'Blocked' t@ without the @t@.
+type Blocked_ = Blocked ()
+
+instance Monoid Blocked_ where
+ mempty = notBlocked ()
+ -- ReallyNotBlocked is neutral
+ NotBlocked ReallyNotBlocked _ `mappend` b = b
+ b `mappend` NotBlocked ReallyNotBlocked _ = b
+ -- StuckOn is strongest
+ b@(NotBlocked StuckOn{} _) `mappend` _ = b
+ _ `mappend` b@(NotBlocked StuckOn{} _) = b
+ -- Blocked is weakest
+ b@Blocked{} `mappend` Blocked{} = b
+ Blocked{} `mappend` b = b
+ b `mappend` Blocked{} = b
+ -- For the other cases, we take the left
+ b `mappend` _ = b
+
+-- | When trying to reduce @f es@, on match failed on one
+-- elimination @e ∈ es@ that came with info @r :: NotBlocked@.
+-- @stuckOn e r@ produces the new @NotBlocked@ info.
+--
+-- 'MissingClauses' must be propagated, as this is blockage
+-- that can be lifted in the future (as more clauses are added).
+--
+-- @'StuckOn' e0@ is also propagated, since it provides more
+-- precise information as @StuckOn e@ (as @e0@ is the original
+-- reason why reduction got stuck and usually a subterm of @e@).
+-- An information like @StuckOn (Apply (Arg info (Var i [])))@
+-- (stuck on a variable) could be used by the lhs/coverage checker
+-- to trigger a split on that (pattern) variable.
+--
+-- In the remaining cases for @r@, we are terminally stuck
+-- due to @StuckOn e@. Propagating @'AbsurdMatch'@ does not
+-- seem useful.
+--
+-- 'Underapplied' must not be propagated, as this would mean
+-- that @f es@ is underapplied, which is not the case (it is stuck).
+-- Note that 'Underapplied' can only arise when projection patterns were
+-- missing to complete the original match (in @e@).
+-- (Missing ordinary pattern would mean the @e@ is of function type,
+-- but we cannot match against something of function type.)
+stuckOn :: Elim -> NotBlocked -> NotBlocked
+stuckOn e r =
+ case r of
+ MissingClauses -> r
+ StuckOn{} -> r
+ Underapplied -> r'
+ AbsurdMatch -> r'
+ ReallyNotBlocked -> r'
+ where r' = StuckOn e
---------------------------------------------------------------------------
-- * Definitions
@@ -258,7 +387,7 @@ instance Applicative Blocked where
-- the patterns to the order they occur in the telescope. The body
-- binds the variables in the order they appear in the patterns.
--
--- @clauseTel ~ permute clausePerm (patternVars clausPats)@
+-- @clauseTel ~ permute clausePerm (patternVars namedClausePats)@
--
-- Terms in dot patterns are valid in the clause telescope.
--
@@ -266,12 +395,16 @@ instance Applicative Blocked where
-- as variables. TODO: Change this!
data Clause = Clause
{ clauseRange :: Range
- , clauseTel :: Telescope -- ^ The types of the pattern variables.
+ , clauseTel :: Telescope
+ -- ^ @Δ@: The types of the pattern variables.
, clausePerm :: Permutation
+ -- ^ @π@ with @Γ ⊢ renamingR π : Δ@, which means @Δ ⊢ renaming π : Γ@.
, namedClausePats :: [NamedArg Pattern]
+ -- ^ @let Γ = patternVars namedClausePats@
, clauseBody :: ClauseBody
+ -- ^ @λΓ.v@
, clauseType :: Maybe (Arg Type)
- -- ^ The type of the rhs under @clauseTel@.
+ -- ^ @Δ ⊢ t@. The type of the rhs under @clauseTel@.
-- Used, e.g., by @TermCheck@.
-- Can be 'Irrelevant' if we encountered an irrelevant projection
-- pattern on the lhs.
@@ -342,6 +475,8 @@ data Pattern' x
type Pattern = Pattern' PatVarName
-- ^ The @PatVarName@ is a name suggestion.
+-- | Type used when numbering pattern variables.
+type DeBruijnPattern = Pattern' (Int, PatVarName)
namedVarP :: PatVarName -> Named (Ranged PatVarName) Pattern
namedVarP x = Named named $ VarP x
@@ -354,7 +489,23 @@ namedVarP x = Named named $ VarP x
-- The @Type@ is the type of the whole record pattern.
-- The scope used for the type is given by any outer scope
-- plus the clause's telescope ('clauseTel').
-type ConPatternInfo = Maybe (Bool, Arg Type)
+data ConPatternInfo = ConPatternInfo
+ { conPRecord :: Maybe Bool
+ -- ^ @Nothing@ if data constructor.
+ -- @Just@ if record constructor, then @True@ if pattern
+ -- was expanded from an implicit pattern.
+ , conPType :: Maybe (Arg Type)
+ -- ^ The type of the whole constructor pattern.
+ -- Should be present (@Just@) if constructor pattern is
+ -- is generated ordinarily by type-checking.
+ -- Could be absent (@Nothing@) if pattern comes from some
+ -- plugin (like Agsy).
+ -- Needed e.g. for with-clause stripping.
+ }
+ deriving (Typeable, Show)
+
+noConPatternInfo :: ConPatternInfo
+noConPatternInfo = ConPatternInfo Nothing Nothing
-- | Extract pattern variables in left-to-right order.
-- A 'DotP' is also treated as variable (see docu for 'Clause').
@@ -370,7 +521,7 @@ properlyMatching :: Pattern -> Bool
properlyMatching VarP{} = False
properlyMatching DotP{} = False
properlyMatching LitP{} = True
-properlyMatching (ConP _ mt ps) = isNothing mt || -- not a record cons
+properlyMatching (ConP _ ci ps) = isNothing (conPRecord ci) || -- not a record cons
List.any (properlyMatching . namedArg) ps -- or one of subpatterns is a proper m
properlyMatching ProjP{} = True
@@ -380,30 +531,56 @@ properlyMatching ProjP{} = True
-- | Substitutions.
-infixr 4 :#
data Substitution
- = IdS -- Γ ⊢ IdS : Γ
-
- | EmptyS -- Γ ⊢ EmptyS : ()
-
- -- Γ ⊢ ρ : Δ
- | Wk !Int Substitution -- -------------------
- -- Γ, Ψ ⊢ Wk |Ψ| ρ : Δ
-
- -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ
- | Term :# Substitution -- ---------------------
- -- Γ ⊢ u :# ρ : Δ, A
-
- -- First argument is __IMPOSSIBLE__ -- Γ ⊢ ρ : Δ
- | Strengthen Empty Substitution -- ---------------------------
- -- Γ ⊢ Strengthen ρ : Δ, A
-
- -- Γ ⊢ ρ : Δ
- | Lift !Int Substitution -- -------------------------
- -- Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ
+ = IdS
+ -- ^ Identity substitution.
+ -- @Γ ⊢ IdS : Γ@
+
+ | EmptyS
+ -- ^ Empty substitution, lifts from the empty context.
+ -- Apply this to closed terms you want to use in a non-empty context.
+ -- @Γ ⊢ EmptyS : ()@
+
+ | Term :# Substitution
+ -- ^ Substitution extension, ``cons''.
+ -- @
+ -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ
+ -- ----------------------
+ -- Γ ⊢ u :# ρ : Δ, A
+ -- @
+
+ | Strengthen Empty Substitution
+ -- ^ Strengthening substitution. First argument is @__IMPOSSIBLE__@.
+ -- Apply this to a term which does not contain variable 0
+ -- to lower all de Bruijn indices by one.
+ -- @
+ -- Γ ⊢ ρ : Δ
+ -- ---------------------------
+ -- Γ ⊢ Strengthen ρ : Δ, A
+ -- @
+
+ | Wk !Int Substitution
+ -- ^ Weakning substitution, lifts to an extended context.
+ -- @
+ -- Γ ⊢ ρ : Δ
+ -- -------------------
+ -- Γ, Ψ ⊢ Wk |Ψ| ρ : Δ
+ -- @
+
+
+ | Lift !Int Substitution
+ -- ^ Lifting substitution. Use this to go under a binder.
+ -- @Lift 1 ρ == var 0 :# Wk 1 ρ@.
+ -- @
+ -- Γ ⊢ ρ : Δ
+ -- -------------------------
+ -- Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ
+ -- @
deriving (Show)
+infixr 4 :#
+
---------------------------------------------------------------------------
-- * Absurd Lambda
---------------------------------------------------------------------------
@@ -518,12 +695,13 @@ sort :: Sort -> Type
sort s = El (sSuc s) $ Sort s
varSort :: Int -> Sort
-varSort n = Type $ Max [Plus 0 $ NeutralLevel $ Var n []]
+varSort n = Type $ Max [Plus 0 $ NeutralLevel mempty $ Var n []]
-- | Get the next higher sort.
sSuc :: Sort -> Sort
sSuc Prop = mkType 1
sSuc Inf = Inf
+sSuc SizeUniv = SizeUniv
sSuc (DLub a b) = DLub (sSuc a) (fmap sSuc b)
sSuc (Type l) = Type $ levelSuc l
@@ -542,6 +720,7 @@ impossibleTerm file line = Lit $ LitString noRange $ unlines
, "Location of the error: " ++ file ++ ":" ++ show line
]
+-- | Constructing a singleton telescope.
class SgTel a where
sgTel :: a -> Telescope
@@ -564,17 +743,13 @@ isHackReifyToMeta _ = False
blockingMeta :: Blocked t -> Maybe MetaId
blockingMeta (Blocked m _) = Just m
-blockingMeta (NotBlocked _) = Nothing
+blockingMeta NotBlocked{} = Nothing
blocked :: MetaId -> a -> Blocked a
blocked x = Blocked x
notBlocked :: a -> Blocked a
-notBlocked = NotBlocked
-
-ignoreBlocking :: Blocked a -> a
-ignoreBlocking (Blocked _ x) = x
-ignoreBlocking (NotBlocked x) = x
+notBlocked = NotBlocked ReallyNotBlocked
---------------------------------------------------------------------------
-- * Simple operations on terms and types.
@@ -610,6 +785,12 @@ instance Suggest String String where
instance Suggest (Abs a) (Abs b) where
suggest b1 b2 = suggest (absName b1) (absName b2)
+instance Suggest String (Abs b) where
+ suggest x b = suggest x (absName b)
+
+instance Suggest Name (Abs b) where
+ suggest n b = suggest (nameToArgName n) (absName b)
+
---------------------------------------------------------------------------
-- * Eliminations.
---------------------------------------------------------------------------
@@ -703,6 +884,30 @@ swapElimArg (Proj d) = defaultArg (Proj d)
-}
---------------------------------------------------------------------------
+-- * Null instances.
+---------------------------------------------------------------------------
+
+instance Null (Tele a) where
+ empty = EmptyTel
+ null EmptyTel = True
+ null ExtendTel{} = False
+
+instance Null ClauseBody where
+ empty = NoBody
+ null NoBody = True
+ null _ = False
+
+-- | A 'null' clause is one with no patterns and no rhs.
+-- Should not exist in practice.
+instance Null Clause where
+ empty = Clause empty empty empty empty empty empty
+ null (Clause r tel perm pats body t)
+ = null tel
+ && null pats
+ && null body
+
+
+---------------------------------------------------------------------------
-- * Show instances.
---------------------------------------------------------------------------
@@ -712,49 +917,21 @@ instance Show a => Show (Abs a) where
showsPrec p (NoAbs x a) = showParen (p > 0) $
showString "NoAbs " . shows x . showString " " . showsPrec 10 a
+-- | Show non-record version of this newtype.
instance Show MetaId where
- show (MetaId n) = "_" ++ show n
+ showsPrec p (MetaId n) = showParen (p > 0) $
+ showString "MetaId " . shows n
-instance Show t => Show (Blocked t) where
- showsPrec p (Blocked m x) = showParen (p > 0) $
- showString "Blocked " . shows m . showString " " . showsPrec 10 x
- showsPrec p (NotBlocked x) = showsPrec p x
+-- instance Show t => Show (Blocked t) where
+-- showsPrec p (Blocked m x) = showParen (p > 0) $
+-- showString "Blocked " . shows m . showString " " . showsPrec 10 x
+-- showsPrec p (NotBlocked x) = showsPrec p x
---------------------------------------------------------------------------
--- * Sized instances.
+-- * Sized instances and TermSize.
---------------------------------------------------------------------------
-instance Sized Term where
- size v = case v of
- Var _ vs -> 1 + Prelude.sum (map size vs)
- Def _ vs -> 1 + Prelude.sum (map size vs)
- Con _ vs -> 1 + Prelude.sum (map size vs)
- MetaV _ vs -> 1 + Prelude.sum (map size vs)
- Level l -> size l
- Lam _ f -> 1 + size f
- Lit _ -> 1
- Pi a b -> 1 + size a + size b
- Sort s -> 1
- DontCare mv -> size mv
- Shared p -> size (derefPtr p)
- ExtLam{} -> __IMPOSSIBLE__
-
-instance Sized Type where
- size = size . unEl
-
-instance Sized Level where
- size (Max as) = 1 + Prelude.sum (map size as)
-
-instance Sized PlusLevel where
- size (ClosedLevel _) = 1
- size (Plus _ a) = size a
-
-instance Sized LevelAtom where
- size (MetaLevel _ vs) = 1 + Prelude.sum (map size vs)
- size (BlockedLevel _ v) = size v
- size (NeutralLevel v) = size v
- size (UnreducedLevel v) = size v
-
+-- | The size of a telescope is its length (as a list).
instance Sized (Tele a) where
size EmptyTel = 0
size (ExtendTel _ tel) = 1 + size tel
@@ -762,9 +939,68 @@ instance Sized (Tele a) where
instance Sized a => Sized (Abs a) where
size = size . unAbs
-instance Sized a => Sized (Elim' a) where
- size (Apply v) = size v
- size Proj{} = 1
+-- | The size of a term is roughly the number of nodes in its
+-- syntax tree. This number need not be precise for logical
+-- correctness of Agda, it is only used for reporting
+-- (and maybe decisions regarding performance).
+--
+-- Not counting towards the term size are:
+--
+-- * sort and color annotations,
+-- * projections.
+--
+class TermSize a where
+ termSize :: a -> Int
+ termSize = getSum . tsize
+
+ tsize :: a -> Sum Int
+
+instance (Foldable t, TermSize a) => TermSize (t a) where
+ tsize = foldMap tsize
+
+instance TermSize Term where
+ tsize v = case v of
+ Var _ vs -> 1 + tsize vs
+ Def _ vs -> 1 + tsize vs
+ Con _ vs -> 1 + tsize vs
+ MetaV _ vs -> 1 + tsize vs
+ Level l -> tsize l
+ Lam _ f -> 1 + tsize f
+ Lit _ -> 1
+ Pi a b -> 1 + tsize a + tsize b
+ Sort s -> tsize s
+ DontCare mv -> tsize mv
+ Shared p -> tsize (derefPtr p)
+ ExtLam{} -> __IMPOSSIBLE__
+
+instance TermSize Sort where
+ tsize s = case s of
+ Type l -> 1 + tsize l
+ Prop -> 1
+ Inf -> 1
+ SizeUniv -> 1
+ DLub s s' -> 1 + tsize s + tsize s'
+
+instance TermSize Level where
+ tsize (Max as) = 1 + tsize as
+
+instance TermSize PlusLevel where
+ tsize (ClosedLevel _) = 1
+ tsize (Plus _ a) = tsize a
+
+instance TermSize LevelAtom where
+ tsize (MetaLevel _ vs) = 1 + tsize vs
+ tsize (BlockedLevel _ v) = tsize v
+ tsize (NeutralLevel _ v) = tsize v
+ tsize (UnreducedLevel v) = tsize v
+
+instance TermSize Substitution where
+ tsize IdS = 1
+ tsize EmptyS = 1
+ tsize (Wk _ rho) = 1 + tsize rho
+ tsize (t :# rho) = 1 + tsize t + tsize rho
+ tsize (Strengthen _ rho) = 1 + tsize rho
+ tsize (Lift _ rho) = 1 + tsize rho
---------------------------------------------------------------------------
-- * KillRange instances.
@@ -798,7 +1034,7 @@ instance KillRange PlusLevel where
instance KillRange LevelAtom where
killRange (MetaLevel n as) = killRange1 (MetaLevel n) as
killRange (BlockedLevel m v) = killRange1 (BlockedLevel m) v
- killRange (NeutralLevel v) = killRange1 NeutralLevel v
+ killRange (NeutralLevel r v) = killRange1 (NeutralLevel r) v
killRange (UnreducedLevel v) = killRange1 UnreducedLevel v
instance KillRange Type where
@@ -808,9 +1044,21 @@ instance KillRange Sort where
killRange s = case s of
Prop -> Prop
Inf -> Inf
+ SizeUniv -> SizeUniv
Type a -> killRange1 Type a
DLub s1 s2 -> killRange2 DLub s1 s2
+instance KillRange Substitution where
+ killRange IdS = IdS
+ killRange EmptyS = EmptyS
+ killRange (Wk n rho) = killRange1 (Wk n) rho
+ killRange (t :# rho) = killRange2 (:#) t rho
+ killRange (Strengthen err rho) = killRange1 (Strengthen err) rho
+ killRange (Lift n rho) = killRange1 (Lift n) rho
+
+instance KillRange ConPatternInfo where
+ killRange (ConPatternInfo mr mt) = killRange1 (ConPatternInfo mr) mt
+
instance KillRange Pattern where
killRange p =
case p of
@@ -857,8 +1105,19 @@ instanceUniverseBiT' [] [t| ([Term], Term) |]
-- * Simple pretty printing
-----------------------------------------------------------------------------
-showTerm :: Term -> String
-showTerm = show . pretty
+instance Pretty MetaId where
+ pretty (MetaId n) = text $ "_" ++ show n
+
+instance Pretty Substitution where
+ prettyPrec p rho = brackets $ pr rho
+ where
+ pr rho = case rho of
+ IdS -> text "idS"
+ EmptyS -> text "ε"
+ t :# rho -> prettyPrec 1 t <+> text ":#" <+> pr rho
+ Strengthen _ rho -> text "↓" <+> pr rho
+ Wk n rho -> text ("↑" ++ show n) <+> pr rho
+ Lift n rho -> text ("⇑" ++ show n) <+> pr rho
instance Pretty Term where
prettyPrec p v =
@@ -879,7 +1138,7 @@ instance Pretty Term where
, nest 2 $ pretty (unAbs b) ]
Sort s -> pretty s
Level l -> pretty l
- MetaV x els -> text (show x) `pApp` els
+ MetaV x els -> pretty x `pApp` els
DontCare v -> pretty v
Shared{} -> __IMPOSSIBLE__
ExtLam{} -> __IMPOSSIBLE__
@@ -914,7 +1173,7 @@ instance Pretty LevelAtom where
case a of
MetaLevel x els -> prettyPrec p (MetaV x els)
BlockedLevel _ v -> prettyPrec p v
- NeutralLevel v -> prettyPrec p v
+ NeutralLevel _ v -> prettyPrec p v
UnreducedLevel v -> prettyPrec p v
instance Pretty Sort where
@@ -925,6 +1184,7 @@ instance Pretty Sort where
Type l -> mparens (p > 9) $ text "Set" <+> prettyPrec 10 l
Prop -> text "Prop"
Inf -> text "Setω"
+ SizeUniv -> text "SizeUniv"
DLub s b -> mparens (p > 9) $
text "dlub" <+> prettyPrec 10 s
<+> parens (sep [ text ("λ " ++ show (absName b) ++ " ->")
diff --git a/src/full/Agda/Syntax/Internal/Defs.hs b/src/full/Agda/Syntax/Internal/Defs.hs
index dd4fc38..a79b7be 100644
--- a/src/full/Agda/Syntax/Internal/Defs.hs
+++ b/src/full/Agda/Syntax/Internal/Defs.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
-- | Extract used definitions from terms.
module Agda.Syntax.Internal.Defs where
@@ -82,6 +81,7 @@ instance GetDefs Sort where
Type l -> getDefs l
Prop -> return ()
Inf -> return ()
+ SizeUniv -> return ()
DLub s s' -> getDefs s >> getDefs s'
instance GetDefs Level where
@@ -95,7 +95,7 @@ instance GetDefs LevelAtom where
getDefs a = case a of
MetaLevel x vs -> getDefs x >> getDefs vs
BlockedLevel _ v -> getDefs v
- NeutralLevel v -> getDefs v
+ NeutralLevel _ v -> getDefs v
UnreducedLevel v -> getDefs v
-- collection instances
diff --git a/src/full/Agda/Syntax/Internal/Generic.hs b/src/full/Agda/Syntax/Internal/Generic.hs
index 9da57c2..d0e9552 100644
--- a/src/full/Agda/Syntax/Internal/Generic.hs
+++ b/src/full/Agda/Syntax/Internal/Generic.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
module Agda.Syntax.Internal.Generic where
@@ -160,17 +159,17 @@ instance TermLike PlusLevel where
instance TermLike LevelAtom where
traverseTerm f l = case l of
MetaLevel m vs -> MetaLevel m $ traverseTerm f vs
- NeutralLevel v -> NeutralLevel $ traverseTerm f v
+ NeutralLevel r v -> NeutralLevel r $ traverseTerm f v
BlockedLevel m v -> BlockedLevel m $ traverseTerm f v
UnreducedLevel v -> UnreducedLevel $ traverseTerm f v
traverseTermM f l = case l of
MetaLevel m vs -> MetaLevel m <$> traverseTermM f vs
- NeutralLevel v -> NeutralLevel <$> traverseTermM f v
+ NeutralLevel r v -> NeutralLevel r <$> traverseTermM f v
BlockedLevel m v -> BlockedLevel m <$> traverseTermM f v
UnreducedLevel v -> UnreducedLevel <$> traverseTermM f v
foldTerm f l = case l of
MetaLevel m vs -> foldTerm f vs
- NeutralLevel v -> foldTerm f v
+ NeutralLevel _ v -> foldTerm f v
BlockedLevel _ v -> foldTerm f v
UnreducedLevel v -> foldTerm f v
diff --git a/src/full/Agda/Syntax/Internal/Pattern.hs b/src/full/Agda/Syntax/Internal/Pattern.hs
index 7f9ca74..78da0c4 100644
--- a/src/full/Agda/Syntax/Internal/Pattern.hs
+++ b/src/full/Agda/Syntax/Internal/Pattern.hs
@@ -1,12 +1,14 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- because of func. deps.
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-} -- because of func. deps.
+
+#if __GLASGOW_HASKELL__ <= 708
+{-# LANGUAGE OverlappingInstances #-}
+#endif
module Agda.Syntax.Internal.Pattern where
@@ -49,7 +51,12 @@ class FunArity a where
funArity :: a -> Int
-- | Get the number of initial 'Apply' patterns.
+
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPABLE #-} IsProjP p => FunArity [p] where
+#else
instance IsProjP p => FunArity [p] where
+#endif
funArity = length . takeWhile (isNothing . isProjP)
-- | Get the number of initial 'Apply' patterns in a clause.
@@ -57,7 +64,11 @@ instance FunArity Clause where
funArity = funArity . clausePats
-- | Get the number of common initial 'Apply' patterns in a list of clauses.
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPING #-} FunArity [Clause] where
+#else
instance FunArity [Clause] where
+#endif
funArity [] = 0
funArity cls = minimum $ map funArity cls
@@ -90,7 +101,8 @@ instance LabelPatVars (Pattern' x) (Pattern' (i,x)) i where
where next = do (x:xs) <- get; put xs; return x
-- | Augment pattern variables with their de Bruijn index.
-{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg (Pattern' x)] -> [(NamedArg (Pattern' (Int, x)))] #-}
+{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg (Pattern' x)] -> [NamedArg (Pattern' (Int, x))] #-}
+{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg Pattern] -> [NamedArg DeBruijnPattern] #-}
numberPatVars :: LabelPatVars a b Int => Permutation -> a -> b
numberPatVars perm ps = evalState (labelPatVars ps) $
permute (invertP __IMPOSSIBLE__ perm) $ downFrom $ size perm
diff --git a/src/full/Agda/Syntax/Notation.hs b/src/full/Agda/Syntax/Notation.hs
index 71bc525..eee7ec5 100644
--- a/src/full/Agda/Syntax/Notation.hs
+++ b/src/full/Agda/Syntax/Notation.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveDataTypeable,
+ ScopedTypeVariables #-}
{-| As a concrete name, a notation is a non-empty list of alternating 'IdPart's and holes.
In contrast to concrete names, holes can be binders.
@@ -23,6 +24,7 @@ import Data.Maybe
import Data.Typeable (Typeable)
import Agda.Syntax.Common
+import Agda.Syntax.Position
import Agda.Utils.Except ( MonadError(throwError) )
import Agda.Utils.List
@@ -54,7 +56,13 @@ data GenPart
| NormalHole (NamedArg () Int)
-- ^ Argument is where the expression should go.
| IdPart RawName
- deriving (Typeable, Show, Eq)
+ deriving (Typeable, Show, Eq, Ord)
+
+instance KillRange GenPart where
+ killRange p = case p of
+ IdPart x -> IdPart x
+ BindHole i -> BindHole i
+ NormalHole x -> NormalHole $ killRange x
-- | Get a flat list of identifier parts of a notation.
stringParts :: Notation -> [RawName]
@@ -83,7 +91,7 @@ data NotationKind
| PostfixNotation -- ^ Ex: @bla_blub_@.
| NonfixNotation -- ^ Ex: @bla_blub@.
| NoNotation
- deriving (Eq)
+ deriving (Eq, Show)
-- | Classify a notation by presence of leading and/or trailing hole.
notationKind :: Notation -> NotationKind
diff --git a/src/full/Agda/Syntax/Parser/LookAhead.hs b/src/full/Agda/Syntax/Parser/LookAhead.hs
index c683627..da15019 100644
--- a/src/full/Agda/Syntax/Parser/LookAhead.hs
+++ b/src/full/Agda/Syntax/Parser/LookAhead.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE Rank2Types #-}
{-| When lexing by hands (for instance string literals) we need to do some
looking ahead. The 'LookAhead' monad keeps track of the position we are
diff --git a/src/full/Agda/Syntax/Parser/Monad.hs b/src/full/Agda/Syntax/Parser/Monad.hs
index c5cb2d6..3b1015e 100644
--- a/src/full/Agda/Syntax/Parser/Monad.hs
+++ b/src/full/Agda/Syntax/Parser/Monad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Agda.Syntax.Parser.Monad
@@ -32,7 +32,7 @@ module Agda.Syntax.Parser.Monad
import Control.Exception
import Data.Int
-import Data.Typeable
+import Data.Typeable ( Typeable )
import Control.Monad.State
import Control.Applicative
@@ -44,6 +44,8 @@ import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.FileName
import qualified Agda.Utils.IO.UTF8 as UTF8
+import Agda.Utils.Pretty
+
{--------------------------------------------------------------------------
The parse monad
--------------------------------------------------------------------------}
@@ -90,12 +92,11 @@ data ParseFlags = ParseFlags
-- | What you get if parsing fails.
data ParseError = ParseError
- { errPos :: Position -- ^ where the error occured
- , errInput :: String -- ^ the remaining input
- , errPrevToken :: String -- ^ the previous token
- , errMsg :: String -- ^ hopefully an explanation
- -- of what happened
- }
+ { errPos :: Position -- ^ where the error occured
+ , errInput :: String -- ^ the remaining input
+ , errPrevToken :: String -- ^ the previous token
+ , errMsg :: String -- ^ hopefully an explanation of what happened
+ }
deriving (Typeable)
instance Exception ParseError
@@ -109,55 +110,49 @@ data ParseResult a = ParseOk ParseState a
--------------------------------------------------------------------------}
instance Monad Parser where
- return x = P $ \s -> ParseOk s x
- P m >>= f = P $ \s -> case m s of
- ParseFailed e -> ParseFailed e
- ParseOk s' x -> unP (f x) s'
- fail msg = P $ \s -> ParseFailed $
- ParseError { errPos = parseLastPos s
- , errInput = parseInp s
- , errPrevToken = parsePrevToken s
- , errMsg = msg
- }
+ return x = P $ \s -> ParseOk s x
+
+ P m >>= f = P $ \s -> case m s of
+ ParseFailed e -> ParseFailed e
+ ParseOk s' x -> unP (f x) s'
+
+ fail msg = P $ \s -> ParseFailed $
+ ParseError { errPos = parseLastPos s
+ , errInput = parseInp s
+ , errPrevToken = parsePrevToken s
+ , errMsg = msg
+ }
instance Functor Parser where
- fmap = liftM
+ fmap = liftM
instance Applicative Parser where
- pure = return
- (<*>) = ap
+ pure = return
+ (<*>) = ap
instance MonadError ParseError Parser where
- throwError e = P $ \_ -> ParseFailed e
- P m `catchError` h = P $ \s -> case m s of
- ParseFailed err -> unP (h err) s
- m' -> m'
+ throwError e = P $ \_ -> ParseFailed e
+
+ P m `catchError` h = P $ \s -> case m s of
+ ParseFailed err -> unP (h err) s
+ m' -> m'
instance MonadState ParseState Parser where
- get = P $ \s -> ParseOk s s
- put s = P $ \_ -> ParseOk s ()
+ get = P $ \s -> ParseOk s s
+ put s = P $ \_ -> ParseOk s ()
instance Show ParseError where
- show err =
- unlines
- [ pos ++ ": " ++ errMsg err
- --, replicate (length pos + 2) ' ' ++ "on '" ++ errPrevToken err ++ "'"
- , errPrevToken err ++ "<ERROR>\n" ++ take 30 (errInput err) ++ "..."
- ]
- where
- pos = show (errPos err)
-
--- showInp "" = "at end of file"
--- showInp t = "on input " ++ elide 5 t
---
--- elide 3 s
--- | length (take 4 s) < 4 = s
--- | otherwise = "..."
--- elide n (c:s) = c : elide (n - 1) s
--- elide _ "" = ""
+ show = prettyShow
+
+instance Pretty ParseError where
+ pretty err = vcat
+ [ pretty (errPos err) <> colon <+> text (errMsg err)
+ , text $ errPrevToken err ++ "<ERROR>"
+ , text $ take 30 (errInput err) ++ "..."
+ ]
instance HasRange ParseError where
- getRange err = posToRange (errPos err) (errPos err)
+ getRange err = posToRange (errPos err) (errPos err)
{--------------------------------------------------------------------------
Running the parser
diff --git a/src/full/Agda/Syntax/Parser/Parser.y b/src/full/Agda/Syntax/Parser/Parser.y
index 0181719..cf924e6 100644
--- a/src/full/Agda/Syntax/Parser/Parser.y
+++ b/src/full/Agda/Syntax/Parser/Parser.y
@@ -1,4 +1,6 @@
{
+{-# LANGUAGE TupleSections #-}
+
{-| The parser is generated by Happy (<http://www.haskell.org/happy>).
-
- Ideally, ranges should be as precise as possible, to get messages that
@@ -43,6 +45,7 @@ import Agda.Utils.Hash
import Agda.Utils.List (spanJust)
import Agda.Utils.Monad
import Agda.Utils.QuickCheck
+import Agda.Utils.Singleton
import Agda.Utils.TestHelpers
import Agda.Utils.Tuple
@@ -456,33 +459,56 @@ CommaBIds : CommaBIdAndAbsurds {
Left ns -> ns
Right _ -> fail $ "expected sequence of bound identifiers, not absurd pattern"
}
-{-
- let getName (Ident (QName x)) = Just x
+
+CommaBIdAndAbsurds :: { Either [Name] [Expr] }
+CommaBIdAndAbsurds : Application {%
+ let getName :: Expr -> Maybe Name
+ getName (Ident (QName x)) = Just x
getName (Underscore r _) = Just (Name r [Hole])
getName _ = Nothing
+
+ isAbsurd :: Expr -> Bool
+ isAbsurd (Absurd _) = True
+ isAbsurd (HiddenArg _ (Named _ e)) = isAbsurd e
+ isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e
+ isAbsurd (Paren _ expr) = isAbsurd expr
+ isAbsurd (RawApp _ exprs) = any isAbsurd exprs
+ isAbsurd _ = False
in
- case partition isJust $ map getName $1 of
- (good, []) -> return $ map fromJust good
- _ -> fail $ "expected sequence of bound identifiers"
--}
+ if any isAbsurd $1 then return $ Right $1 else
+ case mapM getName $1 of
+ Just good -> return $ Left good
+ Nothing -> fail $ "expected sequence of bound identifiers"
+ }
-CommaBIdAndAbsurds :: { Either [Name] [Expr] }
-CommaBIdAndAbsurds : Application {%
- let getName (Ident (QName x)) = Just x
+-- Parse a sequence of identifiers, including hiding info.
+-- Does not include instance arguments.
+-- E.g. x {y z} _ {v}
+-- To be used in typed bindings, like (x {y z} _ {v} : Nat).
+BIdsWithHiding :: { [WithHiding Name] }
+BIdsWithHiding : Application {%
+ let -- interpret an expression as name
+ getName :: Expr -> Maybe Name
+ getName (Ident (QName x)) = Just x
getName (Underscore r _) = Just (Name r [Hole])
getName _ = Nothing
- containsAbsurd (Absurd _) = True
- containsAbsurd (HiddenArg _ (Named _ e)) = containsAbsurd e
- containsAbsurd (InstanceArg _ (Named _ e)) = containsAbsurd e
- containsAbsurd (Paren _ expr) = containsAbsurd expr
- containsAbsurd (RawApp _ exprs) = any containsAbsurd exprs
- containsAbsurd _ = False
+ getNames :: Expr -> Maybe [Name]
+ getNames (RawApp _ es) = mapM getName es
+ getNames e = singleton `fmap` getName e
+
+ -- interpret an expression as name or list of hidden names
+ getName1 :: Expr -> Maybe [WithHiding Name]
+ getName1 (Ident (QName x)) = Just [WithHiding NotHidden x]
+ getName1 (Underscore r _) = Just [WithHiding NotHidden $ Name r [Hole]]
+ getName1 (HiddenArg _ (Named Nothing e))
+ = map (WithHiding Hidden) `fmap` getNames e
+ getName1 _ = Nothing
+
in
- if isJust $ find containsAbsurd $1 then return $ Right $1 else
- case partition isJust $ map getName $1 of
- (good, []) -> return $ Left $ map fromJust good
- _ -> fail $ "expected sequence of bound identifiers"
+ case mapM getName1 $1 of
+ Just good -> return $ concat good
+ Nothing -> fail $ "expected sequence of possibly hidden bound identifiers"
}
@@ -646,32 +672,41 @@ TypedBindingss
-- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B}
TypedBindings :: { TypedBindings }
TypedBindings
- : '.' '(' TBind ')' { TypedBindings (getRange ($2,$3,$4))
- (setRelevance Irrelevant $ defaultColoredArg $3) }
- | '.' '{' TBind '}' { TypedBindings (getRange ($2,$3,$4))
- (hide $ setRelevance Irrelevant $ defaultColoredArg $3) }
- | '.' '{{' TBind DoubleCloseBrace { TypedBindings (getRange ($2,$3,$4))
- (makeInstance $ setRelevance Irrelevant $ defaultColoredArg $3) }
- | '..' '(' TBind ')' { TypedBindings (getRange ($2,$3,$4))
- (setRelevance NonStrict $ defaultColoredArg $3) }
- | '..' '{' TBind '}' { TypedBindings (getRange ($2,$3,$4))
- (hide $ setRelevance NonStrict $ defaultColoredArg $3) }
- | '..' '{{' TBind DoubleCloseBrace { TypedBindings (getRange ($2,$3,$4))
- (makeInstance $ setRelevance NonStrict $ defaultColoredArg $3) }
- | '(' TBind ')' { TypedBindings (getRange ($1,$2,$3))
- (defaultColoredArg $2) }
- | '{{' TBind DoubleCloseBrace { TypedBindings (getRange ($1,$2,$3))
- (makeInstance $ defaultColoredArg $2) }
- | '{' TBind '}' { TypedBindings (getRange ($1,$2,$3))
- (hide $ defaultColoredArg $2) }
+ : '.' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $
+ setRelevance Irrelevant $3 }
+ | '.' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $
+ setHiding Hidden $
+ setRelevance Irrelevant $3 }
+ | '.' '{{' TBind DoubleCloseBrace
+ { setRange (getRange ($2,$3,$4)) $
+ setHiding Instance $
+ setRelevance Irrelevant $3 }
+ | '..' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $
+ setRelevance NonStrict $3 }
+ | '..' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $
+ setHiding Hidden $
+ setRelevance NonStrict $3 }
+ | '..' '{{' TBind DoubleCloseBrace
+ { setRange (getRange ($2,$3,$4)) $
+ setHiding Instance $
+ setRelevance NonStrict $3 }
+ | '(' TBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $2 }
+ | '{{' TBind DoubleCloseBrace
+ { setRange (getRange ($1,$2,$3)) $
+ setHiding Instance $2 }
+ | '{' TBind '}' { setRange (getRange ($1,$2,$3)) $
+ setHiding Hidden $2 }
| '(' Open ')' { tLet (getRange ($1,$3)) $2 }
| '(' 'let' Declarations ')' { tLet (getRange ($1,$4)) $3 }
-- x1 .. xn : A
-- x1 .. xn :{i1 i2 ..} A
-TBind :: { ( [Color], TypedBinding ) }
-TBind : CommaBIds ':' Expr { ( [], TBind (getRange ($1,$2,$3)) (map mkBoundName_ $1) $3 ) }
+TBind :: { TypedBindings }
+TBind : CommaBIds ':' Expr {
+ let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings
+ in TypedBindings r $ defaultArg $ TBind r (map (pure . mkBoundName_) $1) $3
+ }
-- | Colors are not yet allowed in the syntax.
-- | CommaBIds ':{' Colors '}' Expr { ( $3, TBind (getRange ($1,$2,$3,$4,$5)) (map mkBoundName_ $1) $5 ) }
{-
@@ -679,6 +714,14 @@ Colors :: { [Color] }
Colors : QId Colors { Ident $1 : $2 }
| QId { [Ident $1] }
-}
+
+-- x {y z} _ {v} : A
+TBindWithHiding :: { TypedBindings }
+TBindWithHiding : BIdsWithHiding ':' Expr {
+ let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings
+ in TypedBindings r $ defaultArg $ TBind r (map (fmap mkBoundName_) $1) $3
+ }
+
-- A non-empty sequence of lambda bindings.
LamBindings :: { [LamBinding] }
LamBindings
@@ -696,7 +739,7 @@ AbsurdLamBindings
Left lb -> case reverse lb of
Right _ : _ -> parseError "Missing body for lambda"
Left h : _ -> return $ Left ([ b | Right b <- init lb], h)
- _ -> parsePanic "Empty LamBindsAbsurd"
+ _ -> parseError "Unsupported variant of lambda"
Right es -> return $ Right es
}
@@ -814,13 +857,6 @@ DomainFreeBindingAbsurd
Modules and imports
--------------------------------------------------------------------------}
--- You can rename imports
--- ImportImportDirective :: { (Maybe AsName, ImportDirective) }
--- ImportImportDirective
--- : ImportDirective { (Nothing, $1) }
--- | id Id ImportDirective {% isName "as" $1 >>
--- return (Just (AsName $2 (getRange (fst $1))), $3) }
-
-- Import directives
ImportDirective :: { ImportDirective }
ImportDirective : ImportDirectives {% mergeImportDirectives $1 }
@@ -841,7 +877,6 @@ UsingOrHiding
-- using can have an empty list
| 'hiding' '(' CommaImportNames ')' { (Hiding $3 , getRange ($1,$2,$3,$4)) }
-- if you want to hide nothing that's fine, isn't it?
--- | 'hiding' '(' CommaImportNames1 ')' { (Hiding $3 , getRange ($1,$2,$3,$4)) }
RenamingDir :: { ([Renaming] , Range) }
RenamingDir
@@ -956,13 +991,13 @@ Declaration
-- Type signatures of the form "n1 n2 n3 ... : Type", with at least
-- one bound name.
TypeSigs :: { [Declaration] }
-TypeSigs : SpaceIds ':' Expr { map (flip (TypeSig defaultArgInfo) $3) $1 }
+TypeSigs : SpaceIds ':' Expr { map (\ x -> TypeSig defaultArgInfo x $3) $1 }
-- A variant of TypeSigs where any sub-sequence of names can be marked
-- as hidden or irrelevant using braces and dots:
-- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type.
ArgTypeSigs :: { [Arg Declaration] }
-ArgTypeSigs : ArgIds ':' Expr { map (fmap (flip (TypeSig defaultArgInfo) $3)) $1 }
+ArgTypeSigs : ArgIds ':' Expr { map (fmap (\ x -> TypeSig defaultArgInfo x $3)) $1 }
-- Function declarations. The left hand side is parsed as an expression to allow
-- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'.
@@ -1017,9 +1052,9 @@ RecordConstructorName : 'constructor' Id { $2 }
-- Fixity declarations.
Infix :: { Declaration }
-Infix : 'infix' Int SpaceBIds { Infix (NonAssoc (getRange ($1,$3)) $2) $3 }
- | 'infixl' Int SpaceBIds { Infix (LeftAssoc (getRange ($1,$3)) $2) $3 }
- | 'infixr' Int SpaceBIds { Infix (RightAssoc (getRange ($1,$3)) $2) $3 }
+Infix : 'infix' Int SpaceBIds { Infix (Fixity (getRange ($1,$3)) $2 NonAssoc) $3 }
+ | 'infixl' Int SpaceBIds { Infix (Fixity (getRange ($1,$3)) $2 LeftAssoc) $3 }
+ | 'infixr' Int SpaceBIds { Infix (Fixity (getRange ($1,$3)) $2 RightAssoc) $3 }
-- Field declarations.
Fields :: { [Declaration] }
@@ -1256,6 +1291,7 @@ BuiltinPragma :: { Pragma }
BuiltinPragma
: '{-#' 'BUILTIN' string PragmaQName '#-}'
{ BuiltinPragma (getRange ($1,$2,fst $3,$4,$5)) (snd $3) (Ident $4) }
+ -- Extra rule to accept keword REWRITE also as built-in:
| '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}'
{ BuiltinPragma (getRange ($1,$2,$3,$4,$5)) "REWRITE" (Ident $4) }
@@ -1507,7 +1543,7 @@ tLet r = TypedBindings r . Common.Arg defaultArgInfo . TLet r
-- | Converts lambda bindings to typed bindings.
addType :: LamBinding -> TypedBindings
addType (DomainFull b) = b
-addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [x] $ Underscore r Nothing
+addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [pure x] $ Underscore r Nothing
where r = getRange x
mergeImportDirectives :: [ImportDirective] -> Parser ImportDirective
diff --git a/src/full/Agda/Syntax/Position.hs b/src/full/Agda/Syntax/Position.hs
index 33ac69b..47bf553 100644
--- a/src/full/Agda/Syntax/Position.hs
+++ b/src/full/Agda/Syntax/Position.hs
@@ -1,19 +1,14 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-
-#if __GLASGOW_HASKELL__ <= 700
-{-# LANGUAGE OverlappingInstances #-}
-#endif
-
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveDataTypeable,
+ DeriveFoldable,
+ DeriveFunctor,
+ DeriveTraversable,
+ FlexibleInstances,
+ GeneralizedNewtypeDeriving,
+ NoMonomorphismRestriction,
+ ScopedTypeVariables,
+ TemplateHaskell #-}
{-| Position information for syntax. Crucial for giving good error messages.
-}
@@ -47,6 +42,7 @@ module Agda.Syntax.Position
, rangeToInterval
, continuous
, continuousPerLine
+ , PrintRange(..)
, HasRange(..)
, SetRange(..)
, KillRange(..)
@@ -66,13 +62,15 @@ module Agda.Syntax.Position
import Prelude hiding (null)
-import Control.Applicative
+import Control.Applicative hiding (empty)
import Control.Monad
import Data.Foldable (Foldable)
import Data.Function
import Data.Int
import Data.List hiding (null)
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (Traversable)
@@ -83,7 +81,7 @@ import Test.QuickCheck.All
import Agda.Utils.FileName hiding (tests)
import Agda.Utils.Maybe
import Agda.Utils.Null
-import Agda.Utils.Pretty ( (<>), Pretty(pretty) )
+import Agda.Utils.Pretty
import Agda.Utils.TestHelpers
import Agda.Utils.QuickCheck
@@ -171,6 +169,10 @@ rightMargin r@(Range is) =
if null is then r else
let i = last is in Range [ i { iStart = iEnd i } ]
+-- | Wrapper to indicate that range should be printed.
+newtype PrintRange a = PrintRange a
+ deriving (Eq, Ord, HasRange, SetRange, KillRange)
+
-- | Things that have a range are instances of this class.
class HasRange t where
getRange :: t -> Range
@@ -215,6 +217,9 @@ class HasRange t => SetRange t where
instance SetRange Range where
setRange = const
+instance SetRange a => SetRange [a] where
+ setRange r = fmap $ setRange r
+
-- | Killing the range of an object sets all range information to 'noRange'.
class KillRange a where
killRange :: KillRangeT a
@@ -356,9 +361,30 @@ instance KillRange Bool where
instance KillRange Int where
killRange = id
+instance KillRange Integer where
+ killRange = id
+
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a] where
+#else
instance KillRange a => KillRange [a] where
+#endif
killRange = map killRange
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a) where
+#else
+instance KillRange a => KillRange (Map k a) where
+#endif
+ killRange = fmap killRange
+
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPABLE #-} (Ord a, KillRange a) => KillRange (Set a) where
+#else
+instance (Ord a, KillRange a) => KillRange (Set a) where
+#endif
+ killRange = Set.map killRange
+
instance (KillRange a, KillRange b) => KillRange (a, b) where
killRange (x, y) = (killRange x, killRange y)
@@ -366,6 +392,10 @@ instance (KillRange a, KillRange b, KillRange c) =>
KillRange (a, b, c) where
killRange (x, y, z) = killRange3 (,,) x y z
+instance (KillRange a, KillRange b, KillRange c, KillRange d) =>
+ KillRange (a, b, c, d) where
+ killRange (x, y, z, u) = killRange4 (,,,) x y z u
+
instance KillRange a => KillRange (Maybe a) where
killRange = fmap killRange
@@ -379,27 +409,34 @@ instance (KillRange a, KillRange b) => KillRange (Either a b) where
-- TODO: 'Show' should output Haskell-parseable representations.
-- The following instances are deprecated, and Pretty should be used
--- instead. Later, simply derive Show for these types:
+-- instead. Later, simply derive Show for these types.
+-- ASR (02 December 2014). This instance is not used anymore (module
+-- the test suite) when reporting errors. See Issue 1293.
instance Show a => Show (Position' (Maybe a)) where
- show (Pn Nothing _ l c) = show l ++ "," ++ show c
- show (Pn (Just f) _ l c) = show f ++ ":" ++ show l ++ "," ++ show c
+ show (Pn Nothing _ l c) = show l ++ "," ++ show c
+ show (Pn (Just f) _ l c) = show f ++ ":" ++ show l ++ "," ++ show c
instance Show a => Show (Interval' (Maybe a)) where
- show (Interval s e) = file ++ start ++ "-" ++ end
- where
- f = srcFile s
- sl = posLine s
- el = posLine e
- sc = posCol s
- ec = posCol e
- file = case f of
- Nothing -> ""
- Just f -> show f ++ ":"
- start = show sl ++ "," ++ show sc
- end
- | sl == el = show ec
- | otherwise = show el ++ "," ++ show ec
+ show (Interval s e) = file ++ start ++ "-" ++ end
+ where
+ f = srcFile s
+ sl = posLine s
+ el = posLine e
+ sc = posCol s
+ ec = posCol e
+
+ file :: String
+ file = case f of
+ Nothing -> ""
+ Just f -> show f ++ ":"
+
+ start :: String
+ start = show sl ++ "," ++ show sc
+
+ end :: String
+ end | sl == el = show ec
+ | otherwise = show el ++ "," ++ show ec
instance Show a => Show (Range' (Maybe a)) where
show r = case rangeToInterval r of
@@ -411,9 +448,38 @@ instance Show a => Show (Range' (Maybe a)) where
------------------------------------------------------------------------
instance Pretty a => Pretty (Position' (Maybe a)) where
- pretty (Pn Nothing _ l c) = pretty l <> pretty "," <> pretty c
- pretty (Pn (Just f) _ l c) =
- pretty f <> pretty ":" <> pretty l <> pretty "," <> pretty c
+ pretty (Pn Nothing _ l c) = pretty l <> pretty "," <> pretty c
+ pretty (Pn (Just f) _ l c) =
+ pretty f <> pretty ":" <> pretty l <> pretty "," <> pretty c
+
+instance Pretty a => Pretty (Interval' (Maybe a)) where
+ pretty (Interval s e) = file <> start <> pretty "-" <> end
+ where
+ f = srcFile s
+ sl = posLine s
+ el = posLine e
+ sc = posCol s
+ ec = posCol e
+
+ file :: Doc
+ file = case f of
+ Nothing -> empty
+ Just f -> pretty f <> colon
+
+ start :: Doc
+ start = pretty sl <> comma <> pretty sc
+
+ end :: Doc
+ | sl == el = pretty ec
+ | otherwise = pretty el <> comma <> pretty ec
+
+instance Pretty a => Pretty (Range' (Maybe a)) where
+ pretty r = case rangeToInterval r of
+ Nothing -> empty
+ Just i -> pretty i
+
+instance (Pretty a, HasRange a) => Pretty (PrintRange a) where
+ pretty (PrintRange a) = pretty a <+> parens (text "at" <+> pretty (getRange a))
{--------------------------------------------------------------------------
Functions on postitions and ranges
diff --git a/src/full/Agda/Syntax/Scope/Base.hs b/src/full/Agda/Syntax/Scope/Base.hs
index 34d9e45..184045b 100644
--- a/src/full/Agda/Syntax/Scope/Base.hs
+++ b/src/full/Agda/Syntax/Scope/Base.hs
@@ -1,10 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TupleSections #-}
-
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
{-| This module defines the notion of a scope and operations on scopes.
-}
@@ -113,7 +112,7 @@ data LocalVar
-- (List not empty).
deriving (Typeable)
-instance NFData LocalVar
+instance NFData LocalVar where rnf x = seq x ()
instance Eq LocalVar where
(==) = (==) `on` localVar
diff --git a/src/full/Agda/Syntax/Scope/Monad.hs b/src/full/Agda/Syntax/Scope/Monad.hs
index 0b7f399..c4fb90f 100644
--- a/src/full/Agda/Syntax/Scope/Monad.hs
+++ b/src/full/Agda/Syntax/Scope/Monad.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
{-| The scope monad with operations.
-}
@@ -16,6 +20,8 @@ import Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Traversable
import Agda.Syntax.Common
@@ -197,29 +203,43 @@ data ResolvedName = VarName A.Name
| ConstructorName [AbstractName]
| PatternSynResName AbstractName
| UnknownName
- deriving (Show)
+ deriving (Show, Eq)
-- | Look up the abstract name referred to by a given concrete name.
resolveName :: C.QName -> ScopeM ResolvedName
-resolveName = resolveName' allKindsOfNames
+resolveName = resolveName' allKindsOfNames Nothing
-- | Look up the abstract name corresponding to a concrete name of
--- a certain kind.
+-- a certain kind and/or from a given set of names.
-- Sometimes we know already that we are dealing with a constructor
-- or pattern synonym (e.g. when we have parsed a pattern).
-- Then, we can ignore conflicting definitions of that name
-- of a different kind. (See issue 822.)
-resolveName' :: [KindOfName] -> C.QName -> ScopeM ResolvedName
-resolveName' kinds x = do
+resolveName' ::
+ [KindOfName] -> Maybe (Set A.Name) -> C.QName -> ScopeM ResolvedName
+resolveName' kinds names x = do
scope <- getScope
- let vars = AssocList.mapKeysMonotonic C.QName $ scopeLocals scope
+ let vars = AssocList.mapKeysMonotonic C.QName $ scopeLocals scope
+ retVar y = return $ VarName $ y { nameConcrete = unqualify x }
+ aName = A.qnameName . anameName
case lookup x vars of
-- Case: we have a local variable x.
- Just (LocalVar y) -> return $ VarName $ y { nameConcrete = unqualify x }
- -- Case: ... but is shadowed by some imports.
- Just (ShadowedVar y ys) -> typeError $ AmbiguousName x $ A.qualify_ y : map anameName ys
+ Just (LocalVar y) -> retVar y
+ -- Case: ... but is (perhaps) shadowed by some imports.
+ Just (ShadowedVar y ys) -> case names of
+ Nothing -> shadowed ys
+ Just ns -> case filter (\y -> aName y `Set.member` ns) ys of
+ [] -> retVar y
+ ys -> shadowed ys
+ where
+ shadowed ys =
+ typeError $ AmbiguousName x $ A.qualify_ y : map anameName ys
-- Case: we do not have a local variable x.
- Nothing -> case filter ((`elem` kinds) . anameKind . fst) $ scopeLookup' x scope of
+ Nothing -> case filter (\y -> anameKind (fst y) `elem` kinds
+ &&
+ maybe True (Set.member (aName (fst y)))
+ names)
+ (scopeLookup' x scope) of
[] -> return UnknownName
ds | all ((==ConName) . anameKind . fst) ds ->
return $ ConstructorName
@@ -243,19 +263,25 @@ resolveModule x = do
[] -> typeError $ NoSuchModule x
ms -> typeError $ AmbiguousModule x (map amodName ms)
--- | Get the fixity of a name. The name is assumed to be in scope.
-getFixity :: C.QName -> ScopeM Fixity'
-getFixity x = do
- r <- resolveName x
+-- | Get the notation of a name. The name is assumed to be in scope.
+getNotation
+ :: C.QName
+ -> Set A.Name
+ -- ^ The name must correspond to one of the names in this set.
+ -> ScopeM NewNotation
+getNotation x ns = do
+ r <- resolveName' allKindsOfNames (Just ns) x
case r of
- VarName y -> return $ nameFixity y
- DefinedName _ d -> return $ aFixity d
- FieldName d -> return $ aFixity d
- ConstructorName ds -> return $ chooseFixity $ map aFixity ds
- PatternSynResName n -> return $ aFixity n
+ VarName y -> return $ namesToNotation x y
+ DefinedName _ d -> return $ notation d
+ FieldName d -> return $ notation d
+ ConstructorName ds -> case mergeNotations $ map notation ds of
+ [n] -> return n
+ _ -> __IMPOSSIBLE__
+ PatternSynResName n -> return $ notation n
UnknownName -> __IMPOSSIBLE__
where
- aFixity = nameFixity . qnameName . anameName
+ notation = namesToNotation x . qnameName . anameName
-- * Binding names
@@ -319,7 +345,7 @@ type WSM = StateT Out ScopeM
-- alternative to qualification by their module).
-- (See Issue 836).
copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, (A.Ren A.ModuleName, A.Ren A.QName))
-copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy new s) (Map.empty, Map.empty)
+copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy new s) ([], [])
where
-- | A memoizing algorithm, the renamings serving as memo structure.
copy :: A.ModuleName -> Scope -> StateT (A.Ren A.ModuleName, A.Ren A.QName) ScopeM Scope
@@ -351,35 +377,29 @@ copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy
_ -> lensAnameName f d
-- Adding to memo structure.
- addName x y = modify $ second $ Map.insert x y
- addMod x y = modify $ first $ Map.insert x y
+ addName x y = modify $ second $ ((x, y):)
+ addMod x y = modify $ first $ ((x, y):)
-- Querying the memo structure.
- findName x = Map.lookup x <$> gets snd
- findMod x = Map.lookup x <$> gets fst
+ findName x = lookup x <$> gets snd
+ findMod x = lookup x <$> gets fst
-- Change a binding M.x -> old.M'.y to M.x -> new.M'.y
renName :: A.QName -> WSM A.QName
renName x = do
- lift $ reportSLn "scope.copy" 50 $ " Copying " ++ show x
- -- If we've seen it already, just return its copy.
- (`fromMaybeM` findName x) $ do
- -- We have not processed this name @x@, so copy it to some @y@.
-- Check whether we have already seen a module of the same name.
-- If yes, use its copy as @y@.
y <- ifJustM (findMod $ qnameToMName x) (return . mnameToQName) $ {- else -} do
-- First time, generate a fresh name for it.
i <- lift fresh
return $ A.qualify new' $ (qnameName x) { nameId = i }
+ lift $ reportSLn "scope.copy" 50 $ " Copying " ++ show x ++ " to " ++ show y
addName x y
return y
-- Change a binding M.x -> old.M'.y to M.x -> new.M'.y
renMod :: A.ModuleName -> WSM A.ModuleName
renMod x = do
- -- If we've seen it already, just return its copy.
- (`fromMaybeM` findMod x) $ do
- -- We have not processed this name @x@, so copy it to some @y@.
-- Check whether we have seen it already, yet as name.
-- If yes, use its copy as @y@.
y <- ifJustM (findName $ mnameToQName x) (return . qnameToMName) $ {- else -} do
diff --git a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
index 31e6675..6653721 100644
--- a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
+++ b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
@@ -1,11 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
-- {-# OPTIONS -fwarn-unused-binds #-}
@@ -35,10 +34,11 @@ import Control.Applicative hiding (empty)
import Control.Monad.Reader
import Data.List as List hiding (null)
-import Data.Maybe
import qualified Data.Map as Map
-import qualified Data.Set as Set
+import Data.Maybe
+import Data.Monoid
import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Traversable (traverse)
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)
@@ -58,9 +58,11 @@ import Agda.TypeChecking.Monad.Base (TCM, NamedMeta(..))
import Agda.TypeChecking.Monad.Options
import qualified Agda.Utils.AssocList as AssocList
+import Agda.Utils.Functor
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Tuple
+import Agda.Utils.Pretty (prettyShow)
#include "undefined.h"
import Agda.Utils.Impossible
@@ -77,14 +79,12 @@ defaultEnv = Env { takenNames = Set.empty
}
makeEnv :: ScopeInfo -> Env
-makeEnv scope = Env { takenNames = taken
+makeEnv scope = Env { takenNames = Set.union vars defs
, currentScope = scope
}
where
- ns = everythingInScope scope
- taken = Set.union vars defs
vars = Set.fromList $ map fst $ scopeLocals scope
- defs = Set.fromList [ x | (x, _) <- Map.toList $ nsNames ns ]
+ defs = Map.keysSet $ nsNames $ everythingInScope scope
currentPrecedence :: AbsToCon Precedence
currentPrecedence = asks $ scopePrecedence . currentScope
@@ -121,37 +121,6 @@ abstractToConcreteCtx ctx x = do
abstractToConcrete_ :: ToConcrete a c => a -> TCM c
abstractToConcrete_ = runAbsToCon . toConcrete
-{-
--- | We make the translation monadic for modularity purposes.
-type AbsToCon = Reader Env
-
-runAbsToCon :: AbsToCon a -> TCM a
-runAbsToCon m = do
- scope <- getScope
- return $ runReader m (makeEnv scope)
-
-abstractToConcreteEnv :: ToConcrete a c => Env -> a -> TCM c
-abstractToConcreteEnv flags a = return $ runReader (toConcrete a) flags
-
-{- Andreas, 2013-02-26 discontinue non-monadic version in favor of debug msg.
-abstractToConcrete :: ToConcrete a c => Env -> a -> c
-abstractToConcrete flags a = runReader (toConcrete a) flags
--}
-
-abstractToConcreteCtx :: ToConcrete a c => Precedence -> a -> TCM c
-abstractToConcreteCtx ctx x = do
- scope <- getScope
- let scope' = scope { scopePrecedence = ctx }
- return $ abstractToConcrete (makeEnv scope') x
- where
- scope = (currentScope defaultEnv) { scopePrecedence = ctx }
-
-abstractToConcrete_ :: ToConcrete a c => a -> TCM c
-abstractToConcrete_ x = do
- scope <- getScope
- return $ abstractToConcrete (makeEnv scope) x
--}
-
-- Dealing with names -----------------------------------------------------
-- | Names in abstract syntax are fully qualified, but the concrete syntax
@@ -287,6 +256,30 @@ toConcreteCtx p x = withPrecedence p $ toConcrete x
bindToConcreteCtx :: ToConcrete a c => Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcreteCtx p x ret = withPrecedence p $ bindToConcrete x ret
+-- | Translate something in the top context.
+toConcreteTop :: ToConcrete a c => a -> AbsToCon c
+toConcreteTop = toConcreteCtx TopCtx
+
+-- | Translate something in the top context.
+bindToConcreteTop :: ToConcrete a c => a -> (c -> AbsToCon b) -> AbsToCon b
+bindToConcreteTop = bindToConcreteCtx TopCtx
+
+-- | Translate something in a context indicated by 'Hiding' info.
+toConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> AbsToCon c
+toConcreteHiding h =
+ case getHiding h of
+ NotHidden -> toConcrete
+ Hidden -> toConcreteTop
+ Instance -> toConcreteTop
+
+-- | Translate something in a context indicated by 'Hiding' info.
+bindToConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> (c -> AbsToCon b) -> AbsToCon b
+bindToConcreteHiding h =
+ case getHiding h of
+ NotHidden -> bindToConcrete
+ Hidden -> bindToConcreteTop
+ Instance -> bindToConcreteTop
+
-- General instances ------------------------------------------------------
instance ToConcrete a c => ToConcrete [a] [c] where
@@ -315,15 +308,19 @@ instance ToConcrete (Common.ArgInfo ac) C.ArgInfo where
return $ info { argInfoColors = [] } -- TODO: zapping ignoring colours
instance ToConcrete a c => ToConcrete (Common.Arg ac a) (C.Arg c) where
- toConcrete (Common.Arg info x) = liftM2 Common.Arg (toConcrete info) (f x)
- where f = case getHiding info of
- Hidden -> toConcreteCtx TopCtx
- Instance -> toConcreteCtx TopCtx
- NotHidden -> toConcrete
+ toConcrete (Common.Arg info x) = Common.Arg
+ <$> toConcrete info
+ <*> toConcreteHiding info x
+
+ bindToConcrete (Common.Arg info x) ret = do
+ info <- toConcrete info
+ bindToConcreteCtx (hiddenArgumentCtx $ getHiding info) x $
+ ret . Common.Arg info
- bindToConcrete (Common.Arg info x) ret = do info <- toConcrete info
- bindToConcreteCtx (hiddenArgumentCtx $ getHiding info) x $
- ret . Common.Arg info
+instance ToConcrete a c => ToConcrete (WithHiding a) (WithHiding c) where
+ toConcrete (WithHiding h a) = WithHiding h <$> toConcreteHiding h a
+ bindToConcrete (WithHiding h a) ret = bindToConcreteHiding h a $ \ a ->
+ ret $ WithHiding h a
instance ToConcrete a c => ToConcrete (Named name a) (Named name c) where
toConcrete (Named n x) = Named n <$> toConcrete x
@@ -371,7 +368,7 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.Underscore i) = return $
C.Underscore (getRange i) $
- show . NamedMeta (metaNameSuggestion i) . MetaId <$> metaNumber i
+ prettyShow . NamedMeta (metaNameSuggestion i) . MetaId <$> metaNumber i
toConcrete e@(A.App i e1 e2) =
tryToRecoverOpApp e
@@ -394,7 +391,7 @@ instance ToConcrete A.Expr C.Expr where
$ case lamView e of
(bs, e) ->
bindToConcrete (map makeDomainFree bs) $ \bs -> do
- e <- toConcreteCtx TopCtx e
+ e <- toConcreteTop e
return $ C.Lam (getRange i) (concat bs) e
where
lamView (A.Lam _ b@(A.DomainFree _ _) e) =
@@ -438,7 +435,7 @@ instance ToConcrete A.Expr C.Expr where
(tel, e) ->
bracket piBrackets
$ bindToConcrete tel $ \b' -> do
- e' <- toConcreteCtx TopCtx e
+ e' <- toConcreteTop e
return $ C.Pi (concat b') e'
where
piTel (A.Pi _ tel e) = (tel ++) -*- id $ piTel e
@@ -447,7 +444,7 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.Fun i a b) =
bracket piBrackets
$ do a' <- toConcreteCtx (if irr then DotPatternCtx else FunctionSpaceDomainCtx) a
- b' <- toConcreteCtx TopCtx b
+ b' <- toConcreteTop b
return $ C.Fun (getRange i) (addRel a' $ mkArg a') b'
where
irr = getRelevance a `elem` [Irrelevant, NonStrict]
@@ -468,20 +465,20 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.Let i ds e) =
bracket lamBrackets
$ bindToConcrete ds $ \ds' -> do
- e' <- toConcreteCtx TopCtx e
+ e' <- toConcreteTop e
return $ C.Let (getRange i) (concat ds') e'
toConcrete (A.Rec i fs) =
bracket appBrackets $ do
let (xs, es) = unzip fs
- es <- toConcreteCtx TopCtx es
+ es <- toConcreteTop es
return $ C.Rec (getRange i) $ zip xs es
toConcrete (A.RecUpdate i e fs) =
bracket appBrackets $ do
let (xs, es) = unzip fs
e <- toConcrete e
- es <- toConcreteCtx TopCtx es
+ es <- toConcreteTop es
return $ C.RecUpdate (getRange i) e $ zip xs es
toConcrete (A.ETel tel) = do
@@ -508,7 +505,7 @@ instance ToConcrete A.Expr C.Expr where
-- Andreas, 2010-10-05 print irrelevant things as ordinary things
toConcrete (A.DontCare e) = C.Dot r . C.Paren r <$> toConcrete e
where r = getRange e
--- toConcrete (A.DontCare e) = C.DontCare <$> toConcreteCtx TopCtx e
+-- toConcrete (A.DontCare e) = C.DontCare <$> toConcreteTop e
{-
-- Andreas, 2010-09-21 abuse C.Underscore to print irrelevant things
toConcrete (A.DontCare) = return $ C.Underscore noRange Nothing
@@ -516,9 +513,9 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete n
makeDomainFree :: A.LamBinding -> A.LamBinding
-makeDomainFree b@(A.DomainFull (A.TypedBindings r (Common.Arg info (A.TBind _ [x] t)))) =
+makeDomainFree b@(A.DomainFull (A.TypedBindings r (Common.Arg info (A.TBind _ [WithHiding h x] t)))) =
case unScope t of
- A.Underscore MetaInfo{metaNumber = Nothing} -> A.DomainFree info x
+ A.Underscore MetaInfo{metaNumber = Nothing} -> A.DomainFree (mapHiding (mappend h) info) x
_ -> b
makeDomainFree b = b
@@ -547,20 +544,20 @@ instance ToConcrete A.TypedBindings [C.TypedBindings] where
tbinds r e xs = [ C.TBind r xs e ]
tbind r e xs =
- case span (\x -> boundLabel x == boundName x) xs of
+ case span ((\ x -> boundLabel x == boundName x) . dget) xs of
(xs, x:ys) -> tbinds r e xs ++ [ C.TBind r [x] e ] ++ tbind r e ys
(xs, []) -> tbinds r e xs
- label x y = y { boundLabel = nameConcrete x }
+ label x = fmap $ \ y -> y { boundLabel = nameConcrete $ dget x }
instance ToConcrete A.TypedBinding C.TypedBinding where
bindToConcrete (A.TBind r xs e) ret =
- bindToConcrete xs $ \xs -> do
- e <- toConcreteCtx TopCtx e
- ret (C.TBind r (map mkBoundName_ xs) e)
+ bindToConcrete xs $ \ xs -> do
+ e <- toConcreteTop e
+ ret $ C.TBind r (map (fmap mkBoundName_) xs) e
bindToConcrete (A.TLet r lbs) ret =
- bindToConcrete lbs $ \ds -> do
- ret (C.TLet r (concat ds))
+ bindToConcrete lbs $ \ ds -> do
+ ret $ C.TLet r $ concat ds
instance ToConcrete LetBinding [C.Declaration] where
bindToConcrete (LetBind i info x t e) ret =
@@ -637,12 +634,12 @@ instance ToConcrete A.RHS (C.RHS, [C.Expr], [C.Expr], [C.Declaration]) where
es <- toConcrete es
cs <- concat <$> toConcrete cs
return (C.AbsurdRHS, [], es, cs)
- toConcrete (A.RewriteRHS _ eqs rhs wh) = do
+ toConcrete (A.RewriteRHS xeqs rhs wh) = do
wh <- declsToConcrete wh
(rhs, eqs', es, whs) <- toConcrete rhs
unless (null eqs')
__IMPOSSIBLE__
- eqs <- toConcrete eqs
+ eqs <- toConcrete $ map snd xeqs
return (rhs, eqs, es, wh ++ whs)
instance ToConcrete (Maybe A.QName) (Maybe C.Name) where
@@ -669,7 +666,7 @@ instance ToConcrete (Constr A.Constructor) C.Declaration where
withScope scope $ toConcrete (Constr d)
toConcrete (Constr (A.Axiom _ i info x t)) = do
x' <- unsafeQNameToName <$> toConcrete x
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
info <- toConcrete info
return $ C.TypeSig info x' t'
toConcrete (Constr d) = head <$> toConcrete d
@@ -680,7 +677,7 @@ instance ToConcrete a C.LHS => ToConcrete (A.Clause' a) [C.Declaration] where
case lhs of
C.LHS p wps _ _ -> do
bindToConcrete (AsWhereDecls wh) $ \wh' -> do
- (rhs', eqs, with, wcs) <- toConcreteCtx TopCtx rhs
+ (rhs', eqs, with, wcs) <- toConcreteTop rhs
return $ FunClause (C.LHS p wps eqs with) rhs' wh' : wcs
C.Ellipsis {} -> __IMPOSSIBLE__
-- TODO: Is the case above impossible? Previously there was
@@ -691,9 +688,10 @@ instance ToConcrete A.ModuleApplication C.ModuleApplication where
toConcrete (A.SectionApp tel y es) = do
y <- toConcreteCtx FunctionCtx y
bindToConcrete tel $ \tel -> do
- es <- toConcreteCtx ArgumentCtx es
- let r = fuseRange y es
- return $ C.SectionApp r (concat tel) (foldl (C.App r) (C.Ident y) es)
+ es <- toConcreteCtx ArgumentCtx es
+ let r = fuseRange y es
+ return $ C.SectionApp r (concat tel) (foldl (C.App r) (C.Ident y) es)
+
toConcrete (A.RecordModuleIFS recm) = do
recm <- toConcrete recm
return $ C.RecordModuleIFS (getRange recm) recm
@@ -706,7 +704,7 @@ instance ToConcrete A.Declaration [C.Declaration] where
x' <- unsafeQNameToName <$> toConcrete x
withAbstractPrivate i $
withInfixDecl i x' $ do
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
info <- toConcrete info
return [C.Postulate (getRange i) [C.TypeSig info x' t']]
@@ -714,14 +712,14 @@ instance ToConcrete A.Declaration [C.Declaration] where
x' <- unsafeQNameToName <$> toConcrete x
withAbstractPrivate i $
withInfixDecl i x' $ do
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [C.Field x' t']
toConcrete (A.Primitive i x t) = do
x' <- unsafeQNameToName <$> toConcrete x
withAbstractPrivate i $
withInfixDecl i x' $ do
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [C.Primitive (getRange i) [C.TypeSig defaultArgInfo x' t']]
-- Primitives are always relevant.
@@ -732,7 +730,7 @@ instance ToConcrete A.Declaration [C.Declaration] where
withAbstractPrivate i $
bindToConcrete bs $ \tel' -> do
x' <- unsafeQNameToName <$> toConcrete x
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [ C.DataSig (getRange i) Inductive x' (map C.DomainFull $ concat tel') t' ]
toConcrete (A.DataDef i x bs cs) =
@@ -745,7 +743,7 @@ instance ToConcrete A.Declaration [C.Declaration] where
withAbstractPrivate i $
bindToConcrete bs $ \tel' -> do
x' <- unsafeQNameToName <$> toConcrete x
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [ C.RecordSig (getRange i) x' (map C.DomainFull $ concat tel') t' ]
toConcrete (A.RecDef i x ind c bs t cs) =
@@ -759,8 +757,8 @@ instance ToConcrete A.Declaration [C.Declaration] where
toConcrete (A.Section i x tel ds) = do
x <- toConcrete x
bindToConcrete tel $ \tel -> do
- ds <- declsToConcrete ds
- return [ C.Module (getRange i) x (concat tel) ds ]
+ ds <- declsToConcrete ds
+ return [ C.Module (getRange i) x (concat tel) ds ]
toConcrete (A.Apply i x modapp _ _) = do
x <- unsafeQNameToName <$> toConcrete x
@@ -796,36 +794,32 @@ instance ToConcrete A.Declaration [C.Declaration] where
data RangeAndPragma = RangeAndPragma Range A.Pragma
instance ToConcrete RangeAndPragma C.Pragma where
- toConcrete (RangeAndPragma r p) = case p of
- A.OptionsPragma xs -> return $ C.OptionsPragma r xs
- A.BuiltinPragma b x -> do
- x <- toConcrete x
- return $ C.BuiltinPragma r b x
- A.RewritePragma x -> do
- x <- toConcrete x
- return $ C.RewritePragma r x
- A.CompiledTypePragma x hs -> do
- x <- toConcrete x
- return $ C.CompiledTypePragma r x hs
- A.CompiledDataPragma x hs hcs -> do
- x <- toConcrete x
- return $ C.CompiledDataPragma r x hs hcs
- A.CompiledPragma x hs -> do
- x <- toConcrete x
- return $ C.CompiledPragma r x hs
- A.CompiledExportPragma x hs -> do
- x <- toConcrete x
- return $ C.CompiledExportPragma r x hs
- A.CompiledEpicPragma x e -> do
- x <- toConcrete x
- return $ C.CompiledEpicPragma r x e
- A.CompiledJSPragma x e -> do
- x <- toConcrete x
- return $ C.CompiledJSPragma r x e
- A.StaticPragma x -> do
- x <- toConcrete x
- return $ C.StaticPragma r x
- A.EtaPragma x -> C.EtaPragma r <$> toConcrete x
+ toConcrete (RangeAndPragma r p) = case p of
+ A.OptionsPragma xs -> return $ C.OptionsPragma r xs
+ A.BuiltinPragma b e -> C.BuiltinPragma r b <$> toConcrete e
+ A.BuiltinNoDefPragma b x -> C.BuiltinPragma r b . C.Ident <$>
+ toConcrete x
+ A.RewritePragma x -> C.RewritePragma r <$> toConcrete x
+ A.CompiledTypePragma x hs -> do
+ x <- toConcrete x
+ return $ C.CompiledTypePragma r x hs
+ A.CompiledDataPragma x hs hcs -> do
+ x <- toConcrete x
+ return $ C.CompiledDataPragma r x hs hcs
+ A.CompiledPragma x hs -> do
+ x <- toConcrete x
+ return $ C.CompiledPragma r x hs
+ A.CompiledExportPragma x hs -> do
+ x <- toConcrete x
+ return $ C.CompiledExportPragma r x hs
+ A.CompiledEpicPragma x e -> do
+ x <- toConcrete x
+ return $ C.CompiledEpicPragma r x e
+ A.CompiledJSPragma x e -> do
+ x <- toConcrete x
+ return $ C.CompiledJSPragma r x e
+ A.StaticPragma x -> C.StaticPragma r <$> toConcrete x
+ A.EtaPragma x -> C.EtaPragma r <$> toConcrete x
-- Left hand sides --------------------------------------------------------
@@ -847,28 +841,9 @@ instance ToConcrete A.LHS C.LHS where
bindToConcreteCtx TopCtx lhscore $ \lhs ->
bindToConcreteCtx TopCtx (noImplicitPats wps) $ \wps ->
ret $ C.LHS lhs wps [] []
-{-
- bindToConcrete (A.LHS i (A.LHSHead x args) wps) ret = do
- bindToConcreteCtx TopCtx (A.DefP info x args) $ \lhs ->
- bindToConcreteCtx TopCtx (noImplicitPats wps) $ \wps ->
- ret $ C.LHS lhs wps [] []
- where info = PatRange (getRange i)
--}
instance ToConcrete A.LHSCore C.Pattern where
bindToConcrete = bindToConcrete . lhsCoreToPattern
-{-
- bindToConcrete (A.LHSHead x args) ret = do
- bindToConcreteCtx TopCtx (A.DefP info x args) $ \ lhs ->
- ret $ lhs
- where info = PatRange noRange -- seems to be unused anyway
- bindToConcrete (A.LHSProj d ps1 lhscore ps2) ret = do
- d <- toConcrete d
- bindToConcrete ps1 $ \ ps1 ->
- bindToConcrete lhscore $ \ p ->
- bindToConcrete ps2 $ \ ps2 ->
- ret $ makePattern d ps1 p ps2
- -}
appBrackets' :: [arg] -> Precedence -> Bool
appBrackets' [] _ = False
@@ -912,8 +887,9 @@ instance ToConcrete A.Pattern C.Pattern where
data Hd = HdVar A.Name | HdCon A.QName | HdDef A.QName
-cOpApp :: Range -> C.QName -> [C.Expr] -> C.Expr
-cOpApp r n es = C.OpApp r n (map (defaultNamedArg . Ordinary) es)
+cOpApp :: Range -> C.QName -> A.Name -> [C.Expr] -> C.Expr
+cOpApp r x n es =
+ C.OpApp r x (Set.singleton n) (map (defaultNamedArg . Ordinary) es)
tryToRecoverOpApp :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr
tryToRecoverOpApp e def = recoverOpApp bracket cOpApp view e def
@@ -930,7 +906,9 @@ tryToRecoverOpApp e def = recoverOpApp bracket cOpApp view e def
tryToRecoverOpAppP :: A.Pattern -> AbsToCon C.Pattern -> AbsToCon C.Pattern
tryToRecoverOpAppP p def = recoverOpApp bracketP_ opApp view p def
where
- opApp r x ps = C.OpAppP r x (map defaultNamedArg ps)
+ opApp r x n ps =
+ C.OpAppP r x (Set.singleton n) (map defaultNamedArg ps)
+
view p = case p of
ConP _ (AmbQ (c:_)) ps -> Just (HdCon c, ps)
DefP _ f ps -> Just (HdDef f, ps)
@@ -938,7 +916,7 @@ tryToRecoverOpAppP p def = recoverOpApp bracketP_ opApp view p def
recoverOpApp :: (ToConcrete a c, HasRange c)
=> ((Precedence -> Bool) -> AbsToCon c -> AbsToCon c)
- -> (Range -> C.QName -> [c] -> c)
+ -> (Range -> C.QName -> A.Name -> [c] -> c)
-> (a -> Maybe (Hd, [A.NamedArg a]))
-> a
-> AbsToCon c
@@ -959,19 +937,20 @@ recoverOpApp bracket opApp view e mDefault = case view e of
doQNameHelper fixityHelper conHelper n as = do
x <- toConcrete n
- doQName (theFixity $ nameFixity $ fixityHelper n) (conHelper x) as
+ doQName (theFixity $ nameFixity n') (conHelper x) n' as
+ where n' = fixityHelper n
-- fall-back (wrong number of arguments or no holes)
- doQName _ n es
+ doQName _ x _ es
| length xs == 1 = mDefault
| length es /= numHoles = mDefault
| null es = mDefault
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
numHoles = length (filter (== Hole) xs)
-- binary case
- doQName fixity n as
+ doQName fixity x n as
| Hole <- head xs
, Hole <- last xs = do
let a1 = head as
@@ -983,12 +962,12 @@ recoverOpApp bracket opApp view e mDefault = case view e of
es <- mapM (toConcreteCtx InsideOperandCtx) as'
en <- toConcreteCtx (RightOperandCtx fixity) an
bracket (opBrackets fixity)
- $ return $ opApp (getRange (e1, en)) n ([e1] ++ es ++ [en])
+ $ return $ opApp (getRange (e1, en)) x n ([e1] ++ es ++ [en])
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
-- prefix
- doQName fixity n as
+ doQName fixity x n as
| Hole <- last xs = do
let an = last as
as' = case as of
@@ -997,24 +976,24 @@ recoverOpApp bracket opApp view e mDefault = case view e of
es <- mapM (toConcreteCtx InsideOperandCtx) as'
en <- toConcreteCtx (RightOperandCtx fixity) an
bracket (opBrackets fixity)
- $ return $ opApp (getRange (n, en)) n (es ++ [en])
+ $ return $ opApp (getRange (n, en)) x n (es ++ [en])
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
-- postfix
- doQName fixity n as
+ doQName fixity x n as
| Hole <- head xs = do
let a1 = head as
as' = tail as
e1 <- toConcreteCtx (LeftOperandCtx fixity) a1
es <- mapM (toConcreteCtx InsideOperandCtx) as'
bracket (opBrackets fixity)
- $ return $ opApp (getRange (e1, n)) n ([e1] ++ es)
+ $ return $ opApp (getRange (e1, n)) x n ([e1] ++ es)
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
-- roundfix
- doQName _ n as = do
+ doQName _ x n as = do
es <- mapM (toConcreteCtx InsideOperandCtx) as
bracket roundFixBrackets
- $ return $ opApp (getRange n) n es
+ $ return $ opApp (getRange x) x n es
diff --git a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
index 2c0fd75..16b3f05 100644
--- a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
+++ b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
@@ -1,12 +1,16 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if __GLASGOW_HASKELL__ <= 708
+{-# LANGUAGE OverlappingInstances #-}
+#endif
{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis,
figuring out infix operator precedences and tidying up definitions.
@@ -34,6 +38,8 @@ import Control.Monad.Reader hiding (mapM)
import Data.Foldable (Foldable, traverse_)
import Data.Traversable (mapM, traverse)
import Data.List ((\\), nub, foldl')
+import Data.Set (Set)
+import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe
@@ -41,6 +47,7 @@ import Agda.Syntax.Concrete as C hiding (topLevelModuleName)
import Agda.Syntax.Concrete.Generic
import Agda.Syntax.Concrete.Operators
import Agda.Syntax.Abstract as A
+import Agda.Syntax.Abstract.Pretty
import Agda.Syntax.Position
import Agda.Syntax.Literal
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo)
@@ -52,11 +59,12 @@ import Agda.Syntax.Notation
import Agda.Syntax.Scope.Base
import Agda.Syntax.Scope.Monad
-import Agda.TypeChecking.Monad.Base (TypeError(..), Call(..), typeError,
- TCErr(..), extendedLambdaName, fresh,
- freshName, freshName_, freshNoName)
-import Agda.TypeChecking.Monad.Benchmark (billTo, billTop, reimburseTop)
+import Agda.TypeChecking.Monad.Base
+ ( TypeError(..) , Call(..) , typeError , genericError , TCErr(..)
+ , fresh , freshName , freshName_ , freshNoName , extendedLambdaName
+ )
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
+import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)
import Agda.TypeChecking.Monad.State
import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint)
@@ -124,11 +132,6 @@ annotateExpr m = do
s <- getScope
return $ ScopedExpr s e
-expandEllipsis :: C.Pattern -> [C.Pattern] -> C.Clause -> C.Clause
-expandEllipsis _ _ c@(C.Clause _ C.LHS{} _ _ _) = c
-expandEllipsis p ps (C.Clause x (C.Ellipsis _ ps' eqs es) rhs wh wcs) =
- C.Clause x (C.LHS p (ps ++ ps') eqs es) rhs wh wcs
-
-- | Make sure that each variable occurs only once.
checkPatternLinearity :: [A.Pattern' e] -> ScopeM ()
checkPatternLinearity ps = unlessNull (duplicates xs) $ \ ys -> do
@@ -170,7 +173,7 @@ recordConstructorType fields = build fs
build (NiceModuleMacro r p x modapp open dir{ publicOpen = False } : fs)
build (NiceField r f _ _ x (Common.Arg info e) : fs) =
- C.Pi [C.TypedBindings r $ Common.Arg info (C.TBind r [mkBoundName x f] e)] $ build fs
+ C.Pi [C.TypedBindings r $ Common.Arg info (C.TBind r [pure $ mkBoundName x f] e)] $ build fs
where r = getRange x
build (d : fs) = C.Let (getRange d) [notSoNiceDeclaration d] $
build fs
@@ -302,6 +305,12 @@ toAbstractCtx :: ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx ctx c = withContextPrecedence ctx $ toAbstract c
+toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a
+toAbstractTopCtx = toAbstractCtx TopCtx
+
+toAbstractHiding :: (LensHiding h, ToAbstract c a) => h -> c -> ScopeM a
+toAbstractHiding h = toAbstractCtx $ hiddenArgumentCtx $ getHiding h
+
setContextCPS :: Precedence -> (a -> ScopeM b) ->
((a -> ScopeM b) -> ScopeM b) -> ScopeM b
setContextCPS p ret f = do
@@ -325,8 +334,7 @@ localToAbstract' x ret = do
withScope scope $ ret =<< toAbstract x
instance (ToAbstract c1 a1, ToAbstract c2 a2) => ToAbstract (c1,c2) (a1,a2) where
- toAbstract (x,y) =
- (,) <$> toAbstract x <*> toAbstract y
+ toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y
instance (ToAbstract c1 a1, ToAbstract c2 a2, ToAbstract c3 a3) =>
ToAbstract (c1,c2,c3) (a1,a2,a3) where
@@ -334,19 +342,26 @@ instance (ToAbstract c1 a1, ToAbstract c2 a2, ToAbstract c3 a3) =>
where
flatten (x,(y,z)) = (x,y,z)
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPABLE #-} ToAbstract c a => ToAbstract [c] [a] where
+#else
instance ToAbstract c a => ToAbstract [c] [a] where
- toAbstract = mapM toAbstract
+#endif
+ toAbstract = mapM toAbstract
instance ToAbstract c a => ToAbstract (Maybe c) (Maybe a) where
- toAbstract Nothing = return Nothing
- toAbstract (Just x) = Just <$> toAbstract x
+ toAbstract = traverse toAbstract
-- Names ------------------------------------------------------------------
newtype NewName a = NewName a
-newtype OldQName = OldQName C.QName
+data OldQName = OldQName C.QName (Maybe (Set A.Name))
+ -- ^ If a set is given, then the first name must correspond to one
+ -- of the names in the set.
newtype OldName = OldName C.Name
-newtype PatName = PatName C.QName
+data PatName = PatName C.QName (Maybe (Set A.Name))
+ -- ^ If a set is given, then the first name must correspond to one
+ -- of the names in the set.
instance ToAbstract (NewName C.Name) A.Name where
toAbstract (NewName x) = do
@@ -371,8 +386,8 @@ nameExpr d = mk (anameKind d) $ anameName d
where i = ExprRange (getRange x)
instance ToAbstract OldQName A.Expr where
- toAbstract (OldQName x) = do
- qx <- resolveName x
+ toAbstract (OldQName x ns) = do
+ qx <- resolveName' allKindsOfNames ns x
reportSLn "scope.name" 10 $ "resolved " ++ show x ++ ": " ++ show qx
case qx of
VarName x' -> return $ A.Var x'
@@ -387,9 +402,11 @@ data APatName = VarPatName A.Name
| PatternSynPatName AbstractName
instance ToAbstract PatName APatName where
- toAbstract (PatName x) = do
+ toAbstract (PatName x ns) = do
reportSLn "scope.pat" 10 $ "checking pattern name: " ++ show x
- rx <- resolveName' [ConName, PatternSynName] x -- Andreas, 2013-03-21 ignore conflicting names which cannot be meant since we are in a pattern
+ rx <- resolveName' [ConName, PatternSynName] ns x
+ -- Andreas, 2013-03-21 ignore conflicting names which cannot
+ -- be meant since we are in a pattern
z <- case (rx, x) of
-- TODO: warn about shadowing
(VarName y, C.QName x) -> return $ Left x -- typeError $ RepeatedVariableInPattern y x
@@ -398,9 +415,7 @@ instance ToAbstract PatName APatName where
(UnknownName, C.QName x) -> return $ Left x
(ConstructorName ds, _) -> return $ Right (Left ds)
(PatternSynResName d, _) -> return $ Right (Right d)
- _ ->
- typeError $ GenericError $
- "Cannot pattern match on " ++ show x ++ ", because it is not a constructor"
+ _ -> genericError $ "Cannot pattern match on non-constructor " ++ prettyShow x
case z of
Left x -> do
reportSLn "scope.pat" 10 $ "it was a var: " ++ show x
@@ -436,7 +451,7 @@ checkForModuleClash x = do
ms <- scopeLookup (C.QName x) <$> getScope
unless (null ms) $ do
reportSLn "scope.clash" 20 $ "clashing modules ms = " ++ show ms
- setCurrentRange (getRange x) $
+ setCurrentRange x $
typeError $ ShadowedModule x $
map ((`withRangeOf` x) . amodName) ms
@@ -460,7 +475,8 @@ instance ToAbstract NewModuleQName A.ModuleName where
toAbs m' q
instance ToAbstract OldModuleName A.ModuleName where
- toAbstract (OldModuleName q) = amodName <$> resolveModule q
+ toAbstract (OldModuleName q) = setCurrentRange q $ do
+ amodName <$> resolveModule q
-- Expressions ------------------------------------------------------------
@@ -518,7 +534,7 @@ toAbstractLam r bs e ctx = do
e <- toAbstractCtx ctx e
-- We have at least one binder. Get first @b@ and rest @bs@.
caseList bs __IMPOSSIBLE__ $ \ b bs -> do
- return $ A.Lam (ExprRange r) b $ foldr mkLam e bs
+ return $ A.Lam (ExprRange r) b $ foldr mkLam e bs
where
mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e
@@ -526,7 +542,7 @@ toAbstractLam r bs e ctx = do
scopeCheckExtendedLam :: Range -> [(C.LHS, C.RHS, WhereClause)] -> ScopeM A.Expr
scopeCheckExtendedLam r cs = do
whenM isInsideDotPattern $
- typeError $ GenericError "Extended lambdas are not allowed in dot patterns"
+ genericError "Extended lambdas are not allowed in dot patterns"
-- Find an unused name for the extended lambda definition.
cname <- nextlamname r 0 extendedLambdaName
@@ -570,7 +586,7 @@ instance ToAbstract C.Expr A.Expr where
traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of
-- Names
- Ident x -> toAbstract (OldQName x)
+ Ident x -> toAbstract (OldQName x Nothing)
-- Literals
C.Lit l -> return $ A.Lit l
@@ -598,8 +614,7 @@ instance ToAbstract C.Expr A.Expr where
-- Raw application
C.RawApp r es -> do
- e <- reimburseTop Bench.Scoping $ billTo [Bench.Parsing, Bench.Operators] $
- parseApplication es
+ e <- parseApplication es
toAbstract e
-- Application
@@ -609,7 +624,7 @@ instance ToAbstract C.Expr A.Expr where
return $ A.App (ExprRange r) e1 e2
-- Operator application
- C.OpApp r op es -> toAbstractOpApp op es
+ C.OpApp r op ns es -> toAbstractOpApp op ns es
-- With application
C.WithApp r e es -> do
@@ -652,7 +667,7 @@ instance ToAbstract C.Expr A.Expr where
-- Let
e0@(C.Let _ ds e) ->
- ifM isInsideDotPattern (typeError $ GenericError $ "Let-expressions are not allowed in dot patterns") $
+ ifM isInsideDotPattern (genericError $ "Let-expressions are not allowed in dot patterns") $
localToAbstract (LetDefs ds) $ \ds' -> do
e <- toAbstractCtx TopCtx e
let info = ExprRange (getRange e0)
@@ -681,7 +696,7 @@ instance ToAbstract C.Expr A.Expr where
-- Impossible things
C.ETel _ -> __IMPOSSIBLE__
- C.Equal{} -> typeError $ GenericError "Parse error: unexpected '='"
+ C.Equal{} -> genericError "Parse error: unexpected '='"
-- Quoting
C.QuoteGoal _ x e -> do
@@ -713,7 +728,7 @@ instance ToAbstract C.LamBinding A.LamBinding where
makeDomainFull :: C.LamBinding -> C.TypedBindings
makeDomainFull (C.DomainFull b) = b
makeDomainFull (C.DomainFree info x) =
- C.TypedBindings r $ Common.Arg info $ C.TBind r [x] $ C.Underscore r Nothing
+ C.TypedBindings r $ Common.Arg info $ C.TBind r [pure x] $ C.Underscore r Nothing
where r = getRange x
instance ToAbstract C.TypedBindings A.TypedBindings where
@@ -722,11 +737,9 @@ instance ToAbstract C.TypedBindings A.TypedBindings where
instance ToAbstract C.TypedBinding A.TypedBinding where
toAbstract (C.TBind r xs t) = do
t' <- toAbstractCtx TopCtx t
- xs' <- toAbstract (map NewName xs)
+ xs' <- toAbstract $ map (fmap NewName) xs
return $ A.TBind r xs' t'
- toAbstract (C.TLet r ds) = do
- ds' <- toAbstract (LetDefs ds)
- return $ A.TLet r ds'
+ toAbstract (C.TLet r ds) = A.TLet r <$> toAbstract (LetDefs ds)
-- | Scope check a module (top level function).
--
@@ -915,10 +928,14 @@ instance ToAbstract (TopLevel [C.Declaration]) TopLevelInfo where
-- | runs Syntax.Concrete.Definitions.niceDeclarations on main module
niceDecls :: [C.Declaration] -> ScopeM [NiceDeclaration]
niceDecls ds = case runNice $ niceDeclarations ds of
- Left e -> throwError $ Exception (getRange e) (show e)
+ Left e -> throwError $ Exception (getRange e) $ pretty e
Right ds -> return ds
+#if __GLASGOW_HASKELL__ >= 710
+instance {-# OVERLAPPING #-} ToAbstract [C.Declaration] [A.Declaration] where
+#else
instance ToAbstract [C.Declaration] [A.Declaration] where
+#endif
toAbstract ds = do
-- don't allow to switch off termination checker in --safe mode
ds <- ifM (optSafe <$> commandLineOptions) (mapM noNoTermCheck ds) (return ds)
@@ -944,9 +961,9 @@ instance ToAbstract LetDef [A.LetBinding] where
case d of
NiceMutual _ _ d@[C.FunSig _ fx _ instanc info _ x t, C.FunDef _ _ _ abstract _ _ [cl]] ->
do when (abstract == AbstractDef) $ do
- typeError $ GenericError $ "abstract not allowed in let expressions"
+ genericError $ "abstract not allowed in let expressions"
when (instanc == InstanceDef) $ do
- typeError $ GenericError $ "Using instance is useless here, let expressions are always eligible for instance search."
+ genericError $ "Using instance is useless here, let expressions are always eligible for instance search."
e <- letToAbstract cl
t <- toAbstract t
x <- toAbstract (NewName $ mkBoundName x fx)
@@ -955,7 +972,10 @@ instance ToAbstract LetDef [A.LetBinding] where
-- irrefutable let binding, like (x , y) = rhs
NiceFunClause r PublicAccess ConcreteDef termCheck d@(C.FunClause lhs@(C.LHS p [] [] []) (C.RHS rhs) NoWhere) -> do
- mp <- setCurrentRange (getRange p) $ (Right <$> parsePattern p) `catchError` (return . Left)
+ mp <- setCurrentRange p $
+ (Right <$> parsePattern p)
+ `catchError`
+ (return . Left)
case mp of
Right p -> do
rhs <- toAbstract rhs
@@ -1015,10 +1035,10 @@ instance ToAbstract LetDef [A.LetBinding] where
localToAbstract (snd $ lhsArgs p) $ \args ->
-}
(x, args) <- do
- res <- setCurrentRange (getRange p) $ parseLHS top p
+ res <- setCurrentRange p $ parseLHS top p
case res of
C.LHSHead x args -> return (x, args)
- C.LHSProj{} -> typeError $ GenericError $ "copatterns not allowed in let bindings"
+ C.LHSProj{} -> genericError $ "copatterns not allowed in let bindings"
localToAbstract args $ \args ->
do rhs <- toAbstract rhs
@@ -1060,7 +1080,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
-- Fields
C.NiceField r f p a x t -> do
- unless (p == PublicAccess) $ typeError $ GenericError "Record fields can not be private"
+ unless (p == PublicAccess) $ genericError "Record fields can not be private"
-- Interaction points for record fields have already been introduced
-- when checking the type of the record constructor.
-- To avoid introducing interaction points (IP) twice, we turn
@@ -1121,7 +1141,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
-- Uncategorized function clauses
C.NiceFunClause r acc abs termCheck (C.FunClause lhs rhs wcls) ->
- typeError $ GenericError $
+ genericError $
"Missing type signature for left hand side " ++ show lhs
C.NiceFunClause{} -> __IMPOSSIBLE__
@@ -1134,7 +1154,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
dups = nub $ cs \\ nub cs
bad = filter (`elem` dups) cs
unless (distinct cs) $
- setCurrentRange (getRange bad) $
+ setCurrentRange bad $
typeError $ DuplicateConstructors dups
pars <- toAbstract pars
@@ -1186,7 +1206,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
scopeCheckNiceModule r p name tel $ toAbstract ds
NiceModule _ _ _ m@C.Qual{} _ _ ->
- typeError $ GenericError $ "Local modules cannot have qualified names"
+ genericError $ "Local modules cannot have qualified names"
NiceModuleMacro r p x modapp open dir ->
checkModuleMacro Apply r p x modapp open dir
@@ -1209,7 +1229,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
ps <- toAbstract p
return $ map (A.Pragma r) ps
- NiceImport r x as open dir -> traceCall (SetRange r) $ do
+ NiceImport r x as open dir -> setCurrentRange r $ do
notPublicWithoutOpen open dir
-- First scope check the imported module and return its name and
@@ -1254,13 +1274,13 @@ instance ToAbstract NiceDeclaration A.Declaration where
}
return [ A.Import minfo m ]
- NiceUnquoteDecl r fx p a tc x e -> do
+ NiceUnquoteDecl r fx p i a tc x e -> do
y <- freshAbstractQName fx x
bindName p QuotableName x y
e <- toAbstract e
rebindName p DefName x y
let mi = MutualInfo tc r
- return [A.UnquoteDecl mi (mkDefInfo x fx p a r) y e]
+ return [A.UnquoteDecl mi (mkDefInfoInstance x fx p a i r) y e]
NicePatternSyn r fx n as p -> do
reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ show r
@@ -1328,81 +1348,100 @@ instance ToAbstract C.Pragma [A.Pragma] where
toAbstract (C.ImpossiblePragma _) = impossibleTest
toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]
toAbstract (C.RewritePragma _ x) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
case e of
A.Def x -> return [ A.RewritePragma x ]
A.Proj x -> return [ A.RewritePragma x ]
A.Con (AmbQ [x]) -> return [ A.RewritePragma x ]
- A.Con x -> fail $ "REWRITE used on ambiguous name " ++ show x
+ A.Con x -> genericError $ "REWRITE used on ambiguous name " ++ show x
+ A.Var x -> genericError $ "REWRITE used on parameter " ++ show x ++ " instead of on a defined symbol"
_ -> __IMPOSSIBLE__
toAbstract (C.CompiledTypePragma _ x hs) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
case e of
A.Def x -> return [ A.CompiledTypePragma x hs ]
- _ -> fail $ "Bad compiled type: " ++ show x -- TODO: error message
+ _ -> genericError $ "Bad compiled type: " ++ prettyShow x -- TODO: error message
toAbstract (C.CompiledDataPragma _ x hs hcs) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
case e of
A.Def x -> return [ A.CompiledDataPragma x hs hcs ]
- _ -> fail $ "Not a datatype: " ++ show x -- TODO: error message
+ _ -> genericError $ "Not a datatype: " ++ prettyShow x -- TODO: error message
toAbstract (C.CompiledPragma _ x hs) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
A.Proj x -> return x -- TODO: do we need to do s.th. special for projections? (Andreas, 2014-10-12)
- A.Con _ -> fail "Use COMPILED_DATA for constructors" -- TODO
+ A.Con _ -> genericError "Use COMPILED_DATA for constructors" -- TODO
_ -> __IMPOSSIBLE__
return [ A.CompiledPragma y hs ]
toAbstract (C.CompiledExportPragma _ x hs) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
_ -> __IMPOSSIBLE__
return [ A.CompiledExportPragma y hs ]
toAbstract (C.CompiledEpicPragma _ x ep) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
_ -> __IMPOSSIBLE__
return [ A.CompiledEpicPragma y ep ]
toAbstract (C.CompiledJSPragma _ x ep) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
A.Proj x -> return x
A.Con (AmbQ [x]) -> return x
- A.Con x -> fail ("COMPILED_JS used on ambiguous name " ++ show x)
+ A.Con x -> genericError $
+ "COMPILED_JS used on ambiguous name " ++ prettyShow x
_ -> __IMPOSSIBLE__
return [ A.CompiledJSPragma y ep ]
toAbstract (C.StaticPragma _ x) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
_ -> __IMPOSSIBLE__
return [ A.StaticPragma y ]
toAbstract (C.BuiltinPragma _ b e) = do
+ -- Andreas, 2015-02-14
+ -- Some builtins cannot be given a valid Agda type,
+ -- thus, they do not come with accompanying postulate or definition.
+ if b `elem` builtinsNoDef then do
+ case e of
+ C.Ident q@(C.QName x) -> do
+ unlessM ((UnknownName ==) <$> resolveName q) $ genericError $
+ "BUILTIN " ++ b ++ " declares an identifier " ++
+ "(no longer expects an already defined identifier)"
+ y <- freshAbstractQName defaultFixity' x
+ bindName PublicAccess DefName x y
+ return [ A.BuiltinNoDefPragma b y ]
+ _ -> genericError $
+ "Pragma BUILTIN " ++ b ++ ": expected unqualified identifier, " ++
+ "but found expression " ++ prettyShow e
+ else do
e <- toAbstract e
return [ A.BuiltinPragma b e ]
toAbstract (C.ImportPragma _ i) = do
addHaskellImport i
return []
toAbstract (C.EtaPragma _ x) = do
- e <- toAbstract $ OldQName x
+ e <- toAbstract $ OldQName x Nothing
case e of
A.Def x -> return [ A.EtaPragma x ]
- _ -> fail "Bad ETA pragma"
+ _ -> do
+ e <- showA e
+ genericError $ "Pragma ETA: expected identifier, " ++
+ "but found expression " ++ e
-- Termination checking pragmes are handled by the nicifier
toAbstract C.TerminationCheckPragma{} = __IMPOSSIBLE__
instance ToAbstract C.Clause A.Clause where
- toAbstract (C.Clause top C.Ellipsis{} _ _ _) = fail "bad '...'" -- TODO: errors message
+ toAbstract (C.Clause top C.Ellipsis{} _ _ _) = genericError "bad '...'" -- TODO: error message
toAbstract (C.Clause top lhs@(C.LHS p wps eqs with) rhs wh wcs) = withLocalVars $ do
-- Andreas, 2012-02-14: need to reset local vars before checking subclauses
vars <- getLocalVars
- let wcs' = for wcs $ \ c -> do
- setLocalVars vars
- return $ expandEllipsis p wps c
- lhs' <- toAbstract (LeftHandSide top p wps)
+ let wcs' = for wcs $ \ c -> setLocalVars vars $> c
+ lhs' <- toAbstract $ LeftHandSide top p wps
printLocals 10 "after lhs:"
let (whname, whds) = case wh of
NoWhere -> (Nothing, [])
@@ -1420,16 +1459,12 @@ instance ToAbstract C.Clause A.Clause where
return $ A.Clause lhs' rhs ds
whereToAbstract :: Range -> Maybe C.Name -> [C.Declaration] -> ScopeM a -> ScopeM (a, [A.Declaration])
-whereToAbstract _ _ [] inner = do
- x <- inner
- return (x, [])
+whereToAbstract _ _ [] inner = (,[]) <$> inner
whereToAbstract r whname whds inner = do
- m <- maybe (nameConcrete <$> freshNoName noRange) return whname
- m <- if (maybe False isNoName whname)
- then do
- (i :: NameId) <- fresh
- return (C.NoName (getRange m) i)
- else return m
+ -- Create a fresh concrete name if there isn't (a proper) one.
+ m <- case whname of
+ Just m | not (isNoName m) -> return m
+ _ -> C.NoName (getRange whname) <$> fresh
let acc = maybe PrivateAccess (const PublicAccess) whname -- unnamed where's are private
let tel = []
old <- getCurrentModule
@@ -1440,23 +1475,25 @@ whereToAbstract r whname whds inner = do
setCurrentModule old
bindModule acc m am
-- Issue 848: if the module was anonymous (module _ where) open it public
- when (maybe False isNoName whname) $
+ let anonymous = maybe False isNoName whname
+ when anonymous $
openModule_ (C.QName m) $
defaultImportDir { publicOpen = True }
return (x, ds)
data RightHandSide = RightHandSide
- { rhsRewriteEqn :: [C.RewriteEqn] -- ^ @rewrite e@ (many)
- , rhsWithExpr :: [C.WithExpr] -- ^ @with e@ (many)
+ { rhsRewriteEqn :: [C.RewriteEqn] -- ^ @rewrite e@ (many)
+ , rhsWithExpr :: [C.WithExpr] -- ^ @with e@ (many)
, rhsSubclauses :: [ScopeM C.Clause] -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses)
, rhs :: C.RHS
, rhsWhereDecls :: [C.Declaration]
}
-data AbstractRHS = AbsurdRHS'
- | WithRHS' [A.Expr] [ScopeM C.Clause] -- ^ The with clauses haven't been translated yet
- | RHS' A.Expr
- | RewriteRHS' [A.Expr] AbstractRHS [A.Declaration]
+data AbstractRHS
+ = AbsurdRHS'
+ | WithRHS' [A.Expr] [ScopeM C.Clause] -- ^ The with clauses haven't been translated yet
+ | RHS' A.Expr
+ | RewriteRHS' [A.Expr] AbstractRHS [A.Declaration]
qualifyName_ :: A.Name -> ScopeM A.QName
qualifyName_ x = do
@@ -1474,7 +1511,7 @@ instance ToAbstract AbstractRHS A.RHS where
toAbstract (RewriteRHS' eqs rhs wh) = do
auxs <- replicateM (length eqs) $ withFunctionName "rewrite-"
rhs <- toAbstract rhs
- return $ RewriteRHS auxs eqs rhs wh
+ return $ RewriteRHS (zip auxs eqs) rhs wh
toAbstract (WithRHS' es cs) = do
aux <- withFunctionName "with-"
A.WithRHS aux es <$> do toAbstract =<< sequence cs
@@ -1539,7 +1576,7 @@ instance ToAbstract C.LHSCore (A.LHSCore' C.Expr) where
d <- case qx of
FieldName d -> return $ anameName d
UnknownName -> notInScope d
- _ -> typeError $ GenericError $
+ _ -> genericError $
"head of copattern needs to be a field identifier, but "
++ show d ++ " isn't one"
args1 <- toAbstract ps1
@@ -1547,9 +1584,12 @@ instance ToAbstract C.LHSCore (A.LHSCore' C.Expr) where
args2 <- toAbstract ps2
return $ A.LHSProj d args1 l args2
+instance ToAbstract c a => ToAbstract (WithHiding c) (WithHiding a) where
+ toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a
+
instance ToAbstract c a => ToAbstract (C.Arg c) (A.Arg a) where
toAbstract (Common.Arg info e) =
- Common.Arg <$> toAbstract info <*> toAbstractCtx (hiddenArgumentCtx $ getHiding info) e
+ Common.Arg <$> toAbstract info <*> toAbstractHiding info e
instance ToAbstract c a => ToAbstract (Named name c) (Named name a) where
toAbstract (Named n e) = Named n <$> toAbstract e
@@ -1587,32 +1627,37 @@ instance ToAbstract (A.Pattern' C.Expr) (A.Pattern' A.Expr) where
toAbstract (A.ImplicitP i) = return $ A.ImplicitP i
toAbstract (A.PatternSynP i x as) = A.PatternSynP i x <$> mapM toAbstract as
+resolvePatternIdentifier ::
+ Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)
+resolvePatternIdentifier r x ns = do
+ px <- toAbstract (PatName x ns)
+ case px of
+ VarPatName y -> return $ VarP y
+ ConPatName ds -> return $ ConP (ConPatInfo False $ PatRange r)
+ (AmbQ $ map anameName ds)
+ []
+ PatternSynPatName d -> return $ PatternSynP (PatRange r)
+ (anameName d) []
+
instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
- toAbstract p@(C.IdentP x) = do
- px <- toAbstract (PatName x)
- case px of
- VarPatName y -> return $ VarP y
- ConPatName ds -> return $ ConP (ConPatInfo False $ PatRange (getRange p))
- (AmbQ $ map anameName ds)
- []
- PatternSynPatName d -> return $ PatternSynP (PatRange (getRange p))
- (anameName d) []
+ toAbstract (C.IdentP x) =
+ resolvePatternIdentifier (getRange x) x Nothing
toAbstract (AppP (QuoteP _) p)
| IdentP x <- namedArg p,
getHiding p == NotHidden = do
- e <- toAbstract (OldQName x)
+ e <- toAbstract (OldQName x Nothing)
let quoted (A.Def x) = return x
quoted (A.Proj x) = return x
quoted (A.Con (AmbQ [x])) = return x
- quoted (A.Con (AmbQ xs)) = typeError $ GenericError $ "quote: Ambigous name: " ++ show xs
+ quoted (A.Con (AmbQ xs)) = genericError $ "quote: Ambigous name: " ++ show xs
quoted (A.ScopedExpr _ e) = quoted e
- quoted _ = typeError $ GenericError $ "quote: not a defined name"
+ quoted _ = genericError $ "quote: not a defined name"
A.LitP . LitQName (getRange x) <$> quoted e
toAbstract (QuoteP r) =
- typeError $ GenericError "quote must be applied to an identifier"
+ genericError "quote must be applied to an identifier"
toAbstract p0@(AppP p q) = do
(p', q') <- toAbstract (p,q)
@@ -1625,20 +1670,16 @@ instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
r = getRange p0
info = PatSource r $ \pr -> if appBrackets pr then ParenP r p0 else p0
- toAbstract p0@(OpAppP r op ps) = do
- p <- toAbstract (IdentP op)
+ toAbstract p0@(OpAppP r op ns ps) = do
+ p <- resolvePatternIdentifier (getRange op) op (Just ns)
ps <- toAbstract ps
case p of
- ConP i x as -> return $ ConP (i {patInfo = info}) x
- (as ++ ps)
- DefP _ x as -> return $ DefP info x
- (as ++ ps)
- PatternSynP _ x as -> return $ PatternSynP info x
- (as ++ ps)
+ ConP i x as -> return $ ConP (i {patInfo = info}) x (as ++ ps)
+ DefP _ x as -> return $ DefP info x (as ++ ps)
+ PatternSynP _ x as -> return $ PatternSynP info x (as ++ ps)
_ -> __IMPOSSIBLE__
where
- r = getRange p0
- info = PatSource r $ \pr -> if appBrackets pr then ParenP r p0 else p0
+ info = PatSource r $ \pr -> if appBrackets pr then ParenP r p0 else p0
-- Removed when parsing
toAbstract (HiddenP _ _) = __IMPOSSIBLE__
@@ -1664,11 +1705,11 @@ instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
-- | Turn an operator application into abstract syntax. Make sure to record the
-- right precedences for the various arguments.
-toAbstractOpApp :: C.QName -> [C.NamedArg (OpApp C.Expr)] -> ScopeM A.Expr
-toAbstractOpApp op es = do
+toAbstractOpApp :: C.QName -> Set A.Name -> [C.NamedArg (OpApp C.Expr)] -> ScopeM A.Expr
+toAbstractOpApp op ns es = do
-- Get the notation for the operator.
- f <- getFixity op
- let parts = notation . oldToNewNotation $ (op, f)
+ nota <- getNotation op ns
+ let parts = notation nota
-- We can throw away the @BindingHoles@, since binders
-- have been preprocessed into @OpApp C.Expr@.
let nonBindingParts = filter (not . isBindingHole) parts
@@ -1676,8 +1717,8 @@ toAbstractOpApp op es = do
-- If not, crash.
unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__
-- Translate operator and its arguments (each in the right context).
- op <- toAbstract (OldQName op)
- foldl' app op <$> left (theFixity f) nonBindingParts es
+ op <- toAbstract (OldQName op (Just ns))
+ foldl' app op <$> left (notaFixity nota) nonBindingParts es
where
-- Build an application in the abstract syntax, with correct Range.
app e arg = A.App (ExprRange (fuseRange e arg)) e (setArgColors [] arg)
diff --git a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
index da47b35..1333506 100644
--- a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
+++ b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
@@ -1,12 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
Translating from internal syntax to abstract syntax. Enables nice
@@ -51,6 +50,7 @@ import Agda.Syntax.Internal as I
import qualified Agda.Utils.VarSet as VSet
import Agda.TypeChecking.Monad as M hiding (MetaInfo)
+import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Reduce
import {-# SOURCE #-} Agda.TypeChecking.Records
import Agda.TypeChecking.CompiledClause (CompiledClauses(Fail))
@@ -99,6 +99,22 @@ reifyIArg' e = flip Common.Arg (unArg e) <$> reify (argInfo e)
reifyIArgs' :: [I.Arg e] -> TCM [A.Arg e]
reifyIArgs' = mapM reifyIArg'
+-- Composition of reified eliminations ------------------------------------
+
+elims :: Expr -> [I.Elim' Expr] -> TCM Expr
+elims e [] = return e
+elims e (I.Apply arg : es) = do
+ arg <- reifyIArg' arg
+ elims (A.App exprInfo e $ fmap unnamed arg) es
+elims e (I.Proj d : es) = elims (A.App exprInfo (A.Proj d) $ defaultNamedArg e) es
+
+reifyIElim :: Reify i a => I.Elim' i -> TCM (I.Elim' a)
+reifyIElim (I.Apply i) = I.Apply <$> traverse reify i
+reifyIElim (I.Proj d) = return $ I.Proj d
+
+reifyIElims :: Reify i a => [I.Elim' i] -> TCM [I.Elim' a]
+reifyIElims = mapM reifyIElim
+
-- Omitting information ---------------------------------------------------
exprInfo :: ExprInfo
@@ -146,13 +162,18 @@ instance Reify MetaId Expr where
caseMaybeM (isInteractionMeta x) underscore $ \ ii@InteractionId{} ->
return $ A.QuestionMark (mi' {metaNumber = Just n}) ii
+-- Does not print with-applications correctly:
+-- instance Reify DisplayTerm Expr where
+-- reifyWhen = reifyWhenE
+-- reify d = reifyTerm False $ dtermToTerm d
+
instance Reify DisplayTerm Expr where
reifyWhen = reifyWhenE
reify d = case d of
DTerm v -> reifyTerm False v
DDot v -> reify v
DCon c vs -> apps (A.Con (AmbQ [conName c])) =<< reifyIArgs vs
- DDef f vs -> apps (A.Def f) =<< reifyIArgs vs
+ DDef f es -> elims (A.Def f) =<< reifyIElims es
DWithApp u us vs -> do
(e, es) <- reify (u, us)
reifyApp (if null es then e else A.WithApp exprInfo e es) vs
@@ -164,7 +185,7 @@ instance Reify DisplayTerm Expr where
reifyDisplayForm :: QName -> I.Args -> TCM A.Expr -> TCM A.Expr
reifyDisplayForm f vs fallback = do
ifNotM displayFormsEnabled fallback $ {- else -} do
- caseMaybeM (liftTCM $ displayForm f vs) fallback reify
+ caseMaybeM (liftTCM $ displayForm f vs) fallback reify
-- | @reifyDisplayFormP@ tries to recursively
-- rewrite a lhs with a display form.
@@ -197,10 +218,12 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
reifyDisplayFormP =<< displayLHS (map namedArg ps) wps d
_ -> return lhs
where
+ -- Andreas, 2015-05-03: Ulf, please comment on what
+ -- is the idea behind okDisplayForm.
okDisplayForm (DWithApp d ds []) =
okDisplayForm d && all okDisplayTerm ds
okDisplayForm (DTerm (I.Def f vs)) = all okElim vs
- okDisplayForm (DDef f vs) = all okDArg vs
+ okDisplayForm (DDef f es) = all okDElim es
okDisplayForm DDot{} = False
okDisplayForm DCon{} = False
okDisplayForm DTerm{} = True -- False?
@@ -212,7 +235,8 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
okDisplayTerm DDef{} = False
okDisplayTerm _ = False
- okDArg = okDisplayTerm . unArg
+ okDElim (I.Apply v) = okDisplayTerm $ unArg v
+ okDElim I.Proj{} = True -- True, man, or False? No clue what I am implementing here --Andreas, 2015-05-03
okArg = okTerm . unArg
okElim (I.Apply a) = okArg a
@@ -223,27 +247,27 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
okTerm (I.Def x []) = isNoName $ qnameToConcrete x -- Handling wildcards in display forms
okTerm _ = True -- False
- -- Flatten a dt into (parentName, parentArgs, withArgs).
- flattenWith :: DisplayTerm -> (QName, [I.Arg DisplayTerm], [DisplayTerm])
+ -- Flatten a dt into (parentName, parentElims, withArgs).
+ flattenWith :: DisplayTerm -> (QName, [I.Elim' DisplayTerm], [DisplayTerm])
flattenWith (DWithApp d ds1 ds2) = case flattenWith d of
- (f, vs, ds0) -> (f, vs, ds0 ++ ds1 ++ map (DTerm . unArg) ds2)
- flattenWith (DDef f vs) = (f, vs, []) -- .^ hacky, but we should only hit this when printing debug info
- flattenWith (DTerm (I.Def f es)) =
- let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es
- in (f, map (fmap DTerm) vs, [])
+ (f, es, ds0) -> (f, es, ds0 ++ ds1 ++ map (DTerm . unArg) ds2)
+ flattenWith (DDef f es) = (f, es, []) -- .^ hacky, but we should only hit this when printing debug info
+ flattenWith (DTerm (I.Def f es)) = (f, map (fmap DTerm) es, [])
flattenWith _ = __IMPOSSIBLE__
displayLHS :: [A.Pattern] -> [A.Pattern] -> DisplayTerm -> TCM A.SpineLHS
displayLHS ps wps d = case flattenWith d of
(f, vs, ds) -> do
ds <- mapM termToPat ds
- vs <- mapM argToPat vs
+ vs <- mapM elimToPat vs
vs <- reifyIArgs' vs
return $ SpineLHS i f vs (ds ++ wps)
--- return $ LHS i (LHSHead f vs) (ds ++ wps)
where
ci = ConPatInfo False patNoRange
+
argToPat arg = fmap unnamed <$> traverse termToPat arg
+ elimToPat (I.Apply arg) = argToPat arg
+ elimToPat (I.Proj d) = return $ defaultNamedArg $ A.DefP patNoRange d []
termToPat :: DisplayTerm -> TCM A.Pattern
@@ -302,42 +326,41 @@ instance Reify Term Expr where
reifyTerm :: Bool -> Term -> TCM Expr
reifyTerm expandAnonDefs0 v = do
- hasDisplayForms <- displayFormsEnabled
- -- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled
- -- (i.e. when we don't care about nice printing)
- let expandAnonDefs = expandAnonDefs0 && hasDisplayForms
- v <- unSpine <$> instantiate v
- case v of
- _ | isHackReifyToMeta v -> return $ A.Underscore emptyMetaInfo
- I.Var n es -> do
- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- x <- liftTCM $ nameOfBV n `catchError` \_ -> freshName_ ("@" ++ show n)
- reifyApp (A.Var x) vs
- I.Def x es -> do
+ -- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled
+ -- (i.e. when we don't care about nice printing)
+ expandAnonDefs <- return expandAnonDefs0 `and2M` displayFormsEnabled
+ v <- unSpine <$> instantiate v
+ case v of
+ _ | isHackReifyToMeta v -> return $ A.Underscore emptyMetaInfo
+ I.Var n es -> do
let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- reifyDisplayForm x vs $ reifyDef expandAnonDefs x vs
- I.Con c vs -> do
- let x = conName c
- isR <- isGeneratedRecordConstructor x
- case isR of
- True -> do
- showImp <- showImplicitArguments
- let keep (a, v) = showImp || notHidden a
- r <- getConstructorData x
- xs <- getRecordFieldNames r
- vs <- map unArg <$> reifyIArgs vs
- return $ A.Rec exprInfo $ map (unArg *** id) $ filter keep $ zip xs vs
- False -> reifyDisplayForm x vs $ do
- ci <- getConstInfo x
- let Constructor{conPars = np} = theDef ci
- -- if we are the the module that defines constructor x
- -- then we have to drop at least the n module parameters
- n <- getDefFreeVars x
- -- the number of parameters is greater (if the data decl has
- -- extra parameters) or equal (if not) to n
- when (n > np) __IMPOSSIBLE__
- let h = A.Con (AmbQ [x])
- if null vs then return h else do
+ x <- liftTCM $ nameOfBV n `catchError` \_ -> freshName_ ("@" ++ show n)
+ reifyApp (A.Var x) vs
+ I.Def x es -> do
+ let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
+ reifyDisplayForm x vs $ reifyDef expandAnonDefs x vs
+ I.Con c vs -> do
+ let x = conName c
+ isR <- isGeneratedRecordConstructor x
+ case isR of
+ True -> do
+ showImp <- showImplicitArguments
+ let keep (a, v) = showImp || notHidden a
+ r <- getConstructorData x
+ xs <- getRecordFieldNames r
+ vs <- map unArg <$> reifyIArgs vs
+ return $ A.Rec exprInfo $ map (unArg *** id) $ filter keep $ zip xs vs
+ False -> reifyDisplayForm x vs $ do
+ ci <- getConstInfo x
+ let Constructor{conPars = np} = theDef ci
+ -- if we are the the module that defines constructor x
+ -- then we have to drop at least the n module parameters
+ n <- getDefFreeVars x
+ -- the number of parameters is greater (if the data decl has
+ -- extra parameters) or equal (if not) to n
+ when (n > np) __IMPOSSIBLE__
+ let h = A.Con (AmbQ [x])
+ if null vs then return h else do
es <- reifyIArgs vs
-- Andreas, 2012-04-20: do not reify parameter arguments of constructor
-- if the first regular constructor argument is hidden
@@ -379,86 +402,86 @@ reifyTerm expandAnonDefs0 v = do
]
napps h $ genericDrop (n - np) $ nameFirstIfHidden doms es
-}
--- I.Lam info b | isAbsurdBody b -> return $ A.AbsurdLam exprInfo $ getHiding info
- I.Lam info b -> do
- (x,e) <- reify b
- info <- reify info
- return $ A.Lam exprInfo (DomainFree info x) e
- -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda
- I.Lit l -> reify l
- I.Level l -> reify l
- I.Pi a b -> case b of
- NoAbs _ b'
- | notHidden a -> uncurry (A.Fun $ exprInfo) <$> reify (a, b')
- -- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi
- -- since (a) the syntax {A} -> B or {{A}} -> B is not legal
- -- and (b) the name of the binder might matter.
- -- See issue 951 (a) and 952 (b).
- | otherwise -> mkPi b =<< reify a
- b -> mkPi b =<< do
- ifM (domainFree a (absBody b))
- {- then -} (Common.Arg <$> reify (domInfo a) <*> pure underscore)
- {- else -} (reify a)
- where
- mkPi b (Common.Arg info a) = do
- (x, b) <- reify b
- return $ A.Pi exprInfo [TypedBindings noRange $ Common.Arg info (TBind noRange [x] a)] b
- -- We can omit the domain type if it doesn't have any free variables
- -- and it's mentioned in the target type.
- domainFree a b = do
- df <- asks envPrintDomainFreePi
- return $ and [df, freeIn 0 b, VSet.null $ allVars $ freeVars a]
-
- I.Sort s -> reify s
- I.MetaV x es -> do
- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- x' <- reify x
- apps x' =<< reifyIArgs vs
- I.DontCare v -> A.DontCare <$> reifyTerm expandAnonDefs v
- I.Shared p -> reifyTerm expandAnonDefs $ derefPtr p
- I.ExtLam cls args -> do
- x <- freshName_ "extlam"
- reifyExtLam (qnameFromList [x]) 0 cls (map (fmap unnamed) args)
- where
- -- Andreas, 2012-10-20 expand a copy in an anonymous module
- -- to improve error messages.
- -- Don't do this if we have just expanded into a display form,
- -- otherwise we loop!
- reifyDef :: Bool -> QName -> I.Args -> TCM Expr
- reifyDef True x@(QName m name) vs | A.isAnonymousModuleName m = do
- r <- reduceDefCopy x vs
- case r of
- YesReduction _ v -> do
- reportSLn "reify.anon" 60 $ unlines
- [ "reduction on defined ident. in anonymous module"
- , "x = " ++ show x
- , "v = " ++ show v
- ]
- reify v
- NoReduction () -> do
- reportSLn "reify.anon" 60 $ unlines
- [ "no reduction on defined ident. in anonymous module"
- , "x = " ++ show x
- , "vs = " ++ show vs
- ]
- reifyDef' x vs
- reifyDef _ x vs = reifyDef' x vs
-
- reifyDef' :: QName -> I.Args -> TCM Expr
- reifyDef' x@(QName _ name) vs = do
- -- We should drop this many arguments from the local context.
- n <- getDefFreeVars x
- mdefn <- liftTCM $ (Just <$> getConstInfo x) `catchError` \_ -> return Nothing
- -- check if we have an absurd lambda
- let reifyAbsurdLambda cont =
- case theDef <$> mdefn of
- Just Function{ funCompiled = Just Fail, funClauses = [cl] }
- | isAbsurdLambdaName x -> do
- -- get hiding info from last pattern, which should be ()
- let h = getHiding $ last (clausePats cl)
- apps (A.AbsurdLam exprInfo h) =<< reifyIArgs vs
- _ -> cont
- reifyAbsurdLambda $ do
+-- I.Lam info b | isAbsurdBody b -> return $ A.AbsurdLam exprInfo $ getHiding info
+ I.Lam info b -> do
+ (x,e) <- reify b
+ info <- reify info
+ return $ A.Lam exprInfo (DomainFree info x) e
+ -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda
+ I.Lit l -> reify l
+ I.Level l -> reify l
+ I.Pi a b -> case b of
+ NoAbs _ b'
+ | notHidden a -> uncurry (A.Fun $ exprInfo) <$> reify (a, b')
+ -- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi
+ -- since (a) the syntax {A} -> B or {{A}} -> B is not legal
+ -- and (b) the name of the binder might matter.
+ -- See issue 951 (a) and 952 (b).
+ | otherwise -> mkPi b =<< reify a
+ b -> mkPi b =<< do
+ ifM (domainFree a (absBody b))
+ {- then -} (Common.Arg <$> reify (domInfo a) <*> pure underscore)
+ {- else -} (reify a)
+ where
+ mkPi b (Common.Arg info a) = do
+ (x, b) <- reify b
+ return $ A.Pi exprInfo [TypedBindings noRange $ Common.Arg info (TBind noRange [pure x] a)] b
+ -- We can omit the domain type if it doesn't have any free variables
+ -- and it's mentioned in the target type.
+ domainFree a b = do
+ df <- asks envPrintDomainFreePi
+ return $ and [df, freeIn 0 b, VSet.null $ allVars $ freeVars a]
+
+ I.Sort s -> reify s
+ I.MetaV x es -> do
+ let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
+ x' <- reify x
+ apps x' =<< reifyIArgs vs
+ I.DontCare v -> A.DontCare <$> reifyTerm expandAnonDefs v
+ I.Shared p -> reifyTerm expandAnonDefs $ derefPtr p
+ I.ExtLam cls args -> do
+ x <- freshName_ "extlam"
+ reifyExtLam (qnameFromList [x]) 0 cls (map (fmap unnamed) args)
+ where
+ -- Andreas, 2012-10-20 expand a copy in an anonymous module
+ -- to improve error messages.
+ -- Don't do this if we have just expanded into a display form,
+ -- otherwise we loop!
+ reifyDef :: Bool -> QName -> I.Args -> TCM Expr
+ reifyDef True x@(QName m name) vs | A.isAnonymousModuleName m = do
+ r <- reduceDefCopy x vs
+ case r of
+ YesReduction _ v -> do
+ reportSLn "reify.anon" 60 $ unlines
+ [ "reduction on defined ident. in anonymous module"
+ , "x = " ++ show x
+ , "v = " ++ show v
+ ]
+ reify v
+ NoReduction () -> do
+ reportSLn "reify.anon" 60 $ unlines
+ [ "no reduction on defined ident. in anonymous module"
+ , "x = " ++ show x
+ , "vs = " ++ show vs
+ ]
+ reifyDef' x vs
+ reifyDef _ x vs = reifyDef' x vs
+
+ reifyDef' :: QName -> I.Args -> TCM Expr
+ reifyDef' x@(QName _ name) vs = do
+ -- We should drop this many arguments from the local context.
+ n <- getDefFreeVars x
+ mdefn <- liftTCM $ (Just <$> getConstInfo x) `catchError` \_ -> return Nothing
+ -- check if we have an absurd lambda
+ let reifyAbsurdLambda cont =
+ case theDef <$> mdefn of
+ Just Function{ funCompiled = Just Fail, funClauses = [cl] }
+ | isAbsurdLambdaName x -> do
+ -- get hiding info from last pattern, which should be ()
+ let h = getHiding $ last (clausePats cl)
+ apps (A.AbsurdLam exprInfo h) =<< reifyIArgs vs
+ _ -> cont
+ reifyAbsurdLambda $ do
(pad, vs :: [I.NamedArg Term]) <- do
case mdefn of
Nothing -> return ([], map (fmap unnamed) $ genericDrop n vs)
@@ -475,7 +498,7 @@ reifyTerm expandAnonDefs0 v = do
-- These are the dropped projection arguments
(np, pad, dom) <-
case def of
- Function{ funProjection = Just Projection{ projIndex = np } } -> do
+ Function{ funProjection = Just Projection{ projIndex = np } } | np > 0 -> do
TelV tel _ <- telView (defType defn)
scope <- getScope
let (as, dom:_) = splitAt (np - 1) $ telToList tel
@@ -507,14 +530,14 @@ reifyTerm expandAnonDefs0 v = do
let apps = foldl' (\e a -> A.App exprInfo e (fmap unnamed a))
napps (A.Def x `apps` pad) =<< reifyIArgs vs
- reifyExtLam :: QName -> Int -> [I.Clause] -> [I.NamedArg Term] -> TCM Expr
- reifyExtLam x n cls vs = do
- reportSLn "reify.def" 10 $ "reifying extended lambda with definition: x = " ++ show x
- -- drop lambda lifted arguments
- cls <- mapM (reify . QNamed x . dropArgs n) $ cls
- let cx = nameConcrete $ qnameName x
- dInfo = mkDefInfo cx defaultFixity' PublicAccess ConcreteDef (getRange x)
- napps (A.ExtendedLam exprInfo dInfo x cls) =<< reifyIArgs vs
+ reifyExtLam :: QName -> Int -> [I.Clause] -> [I.NamedArg Term] -> TCM Expr
+ reifyExtLam x n cls vs = do
+ reportSLn "reify.def" 10 $ "reifying extended lambda with definition: x = " ++ show x
+ -- drop lambda lifted arguments
+ cls <- mapM (reify . QNamed x . dropArgs n) $ cls
+ let cx = nameConcrete $ qnameName x
+ dInfo = mkDefInfo cx defaultFixity' PublicAccess ConcreteDef (getRange x)
+ napps (A.ExtendedLam exprInfo dInfo x cls) =<< reifyIArgs vs
-- | @nameFirstIfHidden n (a1->...an->{x:a}->b) ({e} es) = {x = e} es@
nameFirstIfHidden :: [I.Dom (ArgName, t)] -> [I.Arg a] -> [I.NamedArg a]
@@ -647,95 +670,95 @@ stripImplicits :: ([A.NamedArg A.Pattern], [A.Pattern]) ->
TCM ([A.NamedArg A.Pattern], [A.Pattern])
stripImplicits (ps, wps) = do -- v if show-implicit we don't need the names
ifM showImplicitArguments (return (map (unnamed . namedThing <$>) ps, wps)) $ do
- let vars = dotVars (ps, wps)
- reportSLn "reify.implicit" 30 $ unlines
- [ "stripping implicits"
- , " ps = " ++ show ps
- , " wps = " ++ show wps
- , " vars = " ++ show vars
- ]
- let allps = ps ++ map defaultNamedArg wps
- sps = blankDots $ foldl (.) (strip Set.empty) (map rearrangeBinding $ Set.toList vars) $ allps
- (ps', wps') = splitAt (length sps - length wps) sps
- reportSLn "reify.implicit" 30 $ unlines
- [ " ps' = " ++ show ps'
- , " wps' = " ++ show (map namedArg wps')
- ]
- return (ps', map namedArg wps')
- where
- argsVars = Set.unions . map argVars
- argVars = patVars . namedArg
- patVars p = case p of
- A.VarP x -> Set.singleton x
- A.ConP _ _ ps -> argsVars ps
- A.DefP _ _ ps -> Set.empty
- A.DotP _ e -> Set.empty
- A.WildP _ -> Set.empty
- A.AbsurdP _ -> Set.empty
- A.LitP _ -> Set.empty
- A.ImplicitP _ -> Set.empty
- A.AsP _ _ p -> patVars p
- A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- Set.empty
-
- -- Replace dot variables by ._ if they use implicitly bound variables. This
- -- is slightly nicer than making the implicts explicit.
- blankDots ps = (map . fmap . fmap . fmap) blank ps
- where
- bound = argsVars ps
- blank e | Set.null (Set.difference (dotVars e) bound) = e
- | otherwise = A.Underscore emptyMetaInfo
-
- -- Pick the "best" place to bind the variable. Best in this case
- -- is the left-most explicit binding site. But, of course we can't
- -- do this since binding site might be forced by a parent clause.
- -- Why? Because the binding site we pick might not exist in the
- -- generated with function if it corresponds to a dot pattern.
- rearrangeBinding x ps = ps
-
- strip dvs ps = stripArgs True ps
- where
- stripArgs _ [] = []
- stripArgs fixedPos (a : as) =
- case getHiding a of
- Hidden | canStrip a as -> stripArgs False as
- Instance | canStrip a as -> stripArgs False as
- _ -> stripName fixedPos (stripArg a) :
- stripArgs True as
-
- stripName True = fmap (unnamed . namedThing)
- stripName False = id
-
- canStrip a as = and
- [ varOrDot p
- , noInterestingBindings p
- , all (flip canStrip []) $ takeWhile isUnnamedHidden as
- ]
- where p = namedArg a
-
- isUnnamedHidden x = notVisible x && nameOf (unArg x) == Nothing
-
- stripArg a = fmap (fmap stripPat) a
-
- stripPat p = case p of
- A.VarP _ -> p
- A.ConP i c ps -> A.ConP i c $ stripArgs True ps
- A.DefP _ _ _ -> p
- A.DotP _ e -> p
- A.WildP _ -> p
- A.AbsurdP _ -> p
- A.LitP _ -> p
- A.ImplicitP _ -> p
- A.AsP i x p -> A.AsP i x $ stripPat p
- A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- p
-
- noInterestingBindings p =
- Set.null $ dvs `Set.intersection` patVars p
-
- varOrDot A.VarP{} = True
- varOrDot A.WildP{} = True
- varOrDot A.DotP{} = True
- varOrDot A.ImplicitP{} = True
- varOrDot _ = False
+ let vars = dotVars (ps, wps)
+ reportSLn "reify.implicit" 30 $ unlines
+ [ "stripping implicits"
+ , " ps = " ++ show ps
+ , " wps = " ++ show wps
+ , " vars = " ++ show vars
+ ]
+ let allps = ps ++ map defaultNamedArg wps
+ sps = blankDots $ foldl (.) (strip Set.empty) (map rearrangeBinding $ Set.toList vars) $ allps
+ (ps', wps') = splitAt (length sps - length wps) sps
+ reportSLn "reify.implicit" 30 $ unlines
+ [ " ps' = " ++ show ps'
+ , " wps' = " ++ show (map namedArg wps')
+ ]
+ return (ps', map namedArg wps')
+ where
+ argsVars = Set.unions . map argVars
+ argVars = patVars . namedArg
+ patVars p = case p of
+ A.VarP x -> Set.singleton x
+ A.ConP _ _ ps -> argsVars ps
+ A.DefP _ _ ps -> Set.empty
+ A.DotP _ e -> Set.empty
+ A.WildP _ -> Set.empty
+ A.AbsurdP _ -> Set.empty
+ A.LitP _ -> Set.empty
+ A.ImplicitP _ -> Set.empty
+ A.AsP _ _ p -> patVars p
+ A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- Set.empty
+
+ -- Replace dot variables by ._ if they use implicitly bound variables. This
+ -- is slightly nicer than making the implicts explicit.
+ blankDots ps = (map . fmap . fmap . fmap) blank ps
+ where
+ bound = argsVars ps
+ blank e | Set.null (Set.difference (dotVars e) bound) = e
+ | otherwise = A.Underscore emptyMetaInfo
+
+ -- Pick the "best" place to bind the variable. Best in this case
+ -- is the left-most explicit binding site. But, of course we can't
+ -- do this since binding site might be forced by a parent clause.
+ -- Why? Because the binding site we pick might not exist in the
+ -- generated with function if it corresponds to a dot pattern.
+ rearrangeBinding x ps = ps
+
+ strip dvs ps = stripArgs True ps
+ where
+ stripArgs _ [] = []
+ stripArgs fixedPos (a : as) =
+ case getHiding a of
+ Hidden | canStrip a as -> stripArgs False as
+ Instance | canStrip a as -> stripArgs False as
+ _ -> stripName fixedPos (stripArg a) :
+ stripArgs True as
+
+ stripName True = fmap (unnamed . namedThing)
+ stripName False = id
+
+ canStrip a as = and
+ [ varOrDot p
+ , noInterestingBindings p
+ , all (flip canStrip []) $ takeWhile isUnnamedHidden as
+ ]
+ where p = namedArg a
+
+ isUnnamedHidden x = notVisible x && nameOf (unArg x) == Nothing
+
+ stripArg a = fmap (fmap stripPat) a
+
+ stripPat p = case p of
+ A.VarP _ -> p
+ A.ConP i c ps -> A.ConP i c $ stripArgs True ps
+ A.DefP _ _ _ -> p
+ A.DotP _ e -> p
+ A.WildP _ -> p
+ A.AbsurdP _ -> p
+ A.LitP _ -> p
+ A.ImplicitP _ -> p
+ A.AsP i x p -> A.AsP i x $ stripPat p
+ A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- p
+
+ noInterestingBindings p =
+ Set.null $ dvs `Set.intersection` patVars p
+
+ varOrDot A.VarP{} = True
+ varOrDot A.WildP{} = True
+ varOrDot A.DotP{} = True
+ varOrDot A.ImplicitP{} = True
+ varOrDot _ = False
-- | @dotVars ps@ gives all the variables inside of dot patterns of @ps@
-- It is only invoked for patternish things. (Ulf O-tone!)
@@ -820,7 +843,7 @@ instance DotVars RHS where
dotVars (RHS e) = dotVars e
dotVars AbsurdRHS = Set.empty
dotVars (WithRHS _ es clauses) = __IMPOSSIBLE__ -- NZ
- dotVars (RewriteRHS _ es rhs _) = __IMPOSSIBLE__ -- NZ
+ dotVars (RewriteRHS xes rhs _) = __IMPOSSIBLE__ -- NZ
instance DotVars TypedBindings where
dotVars (TypedBindings _ bs) = dotVars bs
@@ -858,14 +881,14 @@ reifyPatterns tel perm ps = evalStateT (reifyArgs ps) 0
lift $ A.VarP <$> nameOfBV (size tel - 1 - j)
I.DotP v -> do
t <- lift $ reify v
- tick
+ _ <- tick
let vars = Set.map show (dotVars t)
t' = if Set.member "()" vars then underscore else t
return $ A.DotP patNoRange t'
I.LitP l -> return $ A.LitP l
I.ProjP d -> return $ A.DefP patNoRange d []
- I.ConP c mt ps -> A.ConP ci (AmbQ [conName c]) <$> reifyArgs ps
- where ci = flip ConPatInfo patNoRange $ maybe False fst mt
+ I.ConP c cpi ps -> A.ConP ci (AmbQ [conName c]) <$> reifyArgs ps
+ where ci = flip ConPatInfo patNoRange $ fromMaybe False $ I.conPRecord cpi
instance Reify NamedClause A.Clause where
reify (QNamed f (I.Clause _ tel perm ps body _)) = addCtxTel tel $ do
@@ -893,21 +916,24 @@ instance Reify Type Expr where
instance Reify Sort Expr where
reifyWhen = reifyWhenE
- reify s =
- do s <- instantiateFull s
- case s of
- I.Type (I.Max []) -> return $ A.Set exprInfo 0
- I.Type (I.Max [I.ClosedLevel n]) -> return $ A.Set exprInfo n
- I.Type a -> do
- a <- reify a
- return $ A.App exprInfo (A.Set exprInfo 0) (defaultNamedArg a)
- I.Prop -> return $ A.Prop exprInfo
- I.Inf -> A.Var <$> freshName_ ("Setω" :: String)
- I.DLub s1 s2 -> do
- lub <- freshName_ ("dLub" :: String) -- TODO: hack
- (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2)
- let app x y = A.App exprInfo x (defaultNamedArg y)
- return $ A.Var lub `app` e1 `app` e2
+ reify s = do
+ s <- instantiateFull s
+ case s of
+ I.Type (I.Max []) -> return $ A.Set exprInfo 0
+ I.Type (I.Max [I.ClosedLevel n]) -> return $ A.Set exprInfo n
+ I.Type a -> do
+ a <- reify a
+ return $ A.App exprInfo (A.Set exprInfo 0) (defaultNamedArg a)
+ I.Prop -> return $ A.Prop exprInfo
+ I.Inf -> A.Var <$> freshName_ ("Setω" :: String)
+ I.SizeUniv -> do
+ I.Def sizeU [] <- primSizeUniv
+ return $ A.Def sizeU
+ I.DLub s1 s2 -> do
+ lub <- freshName_ ("dLub" :: String) -- TODO: hack
+ (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2)
+ let app x y = A.App exprInfo x (defaultNamedArg y)
+ return $ A.Var lub `app` e1 `app` e2
instance Reify Level Expr where
reifyWhen = reifyWhenE
@@ -932,7 +958,7 @@ instance Reify I.Telescope A.Telescope where
Common.Arg info e <- reify arg
(x,bs) <- reify tel
let r = getRange e
- return $ TypedBindings r (Common.Arg info (TBind r [x] e)) : bs
+ return $ TypedBindings r (Common.Arg info (TBind r [pure x] e)) : bs
instance Reify I.ArgInfo A.ArgInfo where
reify i = flip (mapArgInfoColors.const) i <$> reify (argInfoColors i)
@@ -951,8 +977,3 @@ instance (Reify i1 a1, Reify i2 a2, Reify i3 a3) => Reify (i1,i2,i3) (a1,a2,a3)
instance (Reify i1 a1, Reify i2 a2, Reify i3 a3, Reify i4 a4) => Reify (i1,i2,i3,i4) (a1,a2,a3,a4) where
reify (x,y,z,w) = (,,,) <$> reify x <*> reify y <*> reify z <*> reify w
-
-instance (Reify t t', Reify a a')
- => Reify (Judgement t a) (Judgement t' a') where
- reify (HasType i t) = HasType <$> reify i <*> reify t
- reify (IsSort i t) = IsSort <$> reify i <*> reify t
diff --git a/src/full/Agda/Termination/CallGraph.hs b/src/full/Agda/Termination/CallGraph.hs
index 635ea95..4bd5c65 100644
--- a/src/full/Agda/Termination/CallGraph.hs
+++ b/src/full/Agda/Termination/CallGraph.hs
@@ -1,11 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
-- | Call graphs and related concepts, more or less as defined in
-- \"A Predicative Analysis of Structural Recursion\" by
@@ -23,8 +22,6 @@ module Agda.Termination.CallGraph
, targetNodes
, fromList
, toList
- , empty
- , null
, union
, insert
, complete, completionStep
@@ -65,10 +62,11 @@ import Agda.Utils.List hiding (tests)
import Agda.Utils.Map
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.PartialOrd
-import Agda.Utils.Pretty hiding (empty)
-import qualified Agda.Utils.Pretty as P
+import Agda.Utils.Pretty
import Agda.Utils.QuickCheck hiding (label)
+import Agda.Utils.Singleton
import Agda.Utils.TestHelpers
import Agda.Utils.Tuple
@@ -96,7 +94,7 @@ callMatrixSet = label
-- | Make a call with a single matrix.
mkCall :: Node -> Node -> CallMatrix -> cinfo -> Call cinfo
-mkCall s t m cinfo = Edge s t $ CMSet.singleton $ CallMatrixAug m cinfo
+mkCall s t m cinfo = Edge s t $ singleton $ CallMatrixAug m cinfo
-- | Make a call with empty @cinfo@.
mkCall' :: Monoid cinfo => Node -> Node -> CallMatrix -> Call cinfo
@@ -145,15 +143,10 @@ toList = Graph.edges . theCallGraph
fromList :: Monoid cinfo => [Call cinfo] -> CallGraph cinfo
fromList = CallGraph . Graph.fromListWith CMSet.union
--- | Creates an empty call graph.
-
-empty :: CallGraph cinfo
-empty = CallGraph Graph.empty
-
--- | Check whether the call graph is completely disconnected.
-
-null :: CallGraph cinfo -> Bool
-null = List.all (CMSet.null . label) . toList
+-- | 'null' checks whether the call graph is completely disconnected.
+instance Null (CallGraph cinfo) where
+ empty = CallGraph Graph.empty
+ null = List.all (null . label) . toList
-- | Takes the union of two call graphs.
@@ -202,7 +195,7 @@ instance (Monoid a, CombineNewOld a, Ord s, Ord t) => CombineNewOld (Graph s t a
-- -- | otherwise = __IMPOSSIBLE__
-- Filter unlabelled edges from the resulting new graph.
- -- filt = Graph.filterEdges (not . CMSet.null)
+ -- filt = Graph.filterEdges (not . null)
-- | Call graph combination.
--
@@ -263,7 +256,7 @@ completionStep gOrig gThis = combineNewOldCallGraph gOrig gThis
instance Pretty cinfo => Pretty (CallGraph cinfo) where
pretty = vcat . map prettyCall . toList
where
- prettyCall e = if CMSet.null (callMatrixSet e) then P.empty else align 20 $
+ prettyCall e = if null (callMatrixSet e) then empty else align 20 $
[ ("Source:", text $ show $ source e)
, ("Target:", text $ show $ target e)
, ("Matrix:", pretty $ callMatrixSet e)
diff --git a/src/full/Agda/Termination/CallMatrix.hs b/src/full/Agda/Termination/CallMatrix.hs
index 40a30e9..9ce5ed1 100644
--- a/src/full/Agda/Termination/CallMatrix.hs
+++ b/src/full/Agda/Termination/CallMatrix.hs
@@ -1,13 +1,12 @@
--- {-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+-- {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
module Agda.Termination.CallMatrix where
@@ -34,9 +33,11 @@ import qualified Agda.Termination.Semiring as Semiring
import Agda.Utils.Favorites (Favorites)
import qualified Agda.Utils.Favorites as Fav
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.PartialOrd hiding (tests)
import Agda.Utils.Pretty hiding ((<>))
import Agda.Utils.QuickCheck
+import Agda.Utils.Singleton
import Agda.Utils.TestHelpers
------------------------------------------------------------------------
@@ -181,8 +182,11 @@ noAug m = CallMatrixAug m mempty
-- * Sets of incomparable call matrices augmented with path information.
------------------------------------------------------------------------
+-- | Sets of incomparable call matrices augmented with path information.
+-- Use overloaded 'null', 'empty', 'singleton', 'mappend'.
newtype CMSet cinfo = CMSet { cmSet :: Favorites (CallMatrixAug cinfo) }
- deriving (Show, Arbitrary, CoArbitrary, Monoid)
+ deriving ( Show, Arbitrary, CoArbitrary
+ , Monoid, Null, Singleton (CallMatrixAug cinfo) )
-- | Call matrix set product is the Cartesian product.
@@ -190,22 +194,6 @@ instance Monoid cinfo => CallComb (CMSet cinfo) where
CMSet as >*< CMSet bs = CMSet $ Fav.fromList $
[ a >*< b | a <- Fav.toList as, b <- Fav.toList bs ]
--- | An empty call matrix set.
-
-empty :: CMSet cinfo
-empty = mempty
--- empty = CMSet $ Fav.empty
-
--- | Call matrix is empty?
-
-null :: CMSet cinfo -> Bool
-null (CMSet as) = Fav.null as
-
--- | A singleton call matrix set.
-
-singleton :: CallMatrixAug cinfo -> CMSet cinfo
-singleton = CMSet . Fav.singleton
-
-- | Insert into a call matrix set.
insert :: CallMatrixAug cinfo -> CMSet cinfo -> CMSet cinfo
diff --git a/src/full/Agda/Termination/CutOff.hs b/src/full/Agda/Termination/CutOff.hs
index f0bb9fb..97cb823 100644
--- a/src/full/Agda/Termination/CutOff.hs
+++ b/src/full/Agda/Termination/CutOff.hs
@@ -1,6 +1,6 @@
--- | Defines 'CutOff' type which is used in 'Agda.Interaction.Options'.
+-- | Defines 'CutOff' type which is used in "Agda.Interaction.Options".
-- This module's purpose is to eliminate the dependency of
--- 'Agda.TypeChecking.Monad.Base' on the termination checker and
+-- "Agda.TypeChecking.Monad.Base" on the termination checker and
-- everything it imports.
module Agda.Termination.CutOff where
diff --git a/src/full/Agda/Termination/Inlining.hs b/src/full/Agda/Termination/Inlining.hs
index 9cb52a6..97cb3dd 100644
--- a/src/full/Agda/Termination/Inlining.hs
+++ b/src/full/Agda/Termination/Inlining.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
-- Author: Ulf Norell
-- Created: 2013-11-09
@@ -54,7 +58,7 @@ import Data.Foldable (foldMap)
import Data.Traversable (traverse)
import Data.List as List
-import Agda.Syntax.Common hiding (NamedArg)
+import Agda.Syntax.Common as Common hiding (NamedArg)
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import Agda.TypeChecking.Monad
@@ -187,12 +191,11 @@ inline f pcl t wf wcl = inTopContext $ addCtxTel (clauseTel wcl) $ do
where n' = n - 1
dispToPats :: DisplayTerm -> TCM ([NamedArg Pattern], Permutation)
- dispToPats (DWithApp (DDef _ vs) ws zs) = do
- let us = vs ++ map defaultArg ws ++ map (fmap DTerm) zs
- (ps, (j, ren)) <- (`runStateT` (0, [])) $
- map (fmap unnamed) <$> mapM (traverse dtermToPat) us
+ dispToPats (DWithApp (DDef _ es) ws zs) = do
+ let es' = es ++ map Apply (map defaultArg ws ++ map (fmap DTerm) zs)
+ (ps, (j, ren)) <- (`runStateT` (0, [])) $ mapM (traverse dtermToPat) es'
let perm = Perm j (map snd $ List.sort ren)
- return (ps, perm)
+ return (map ePatToPat ps, perm)
dispToPats t = __IMPOSSIBLE__
bindVar i = do
@@ -204,17 +207,26 @@ inline f pcl t wf wcl = inTopContext $ addCtxTel (clauseTel wcl) $ do
skip = modify $ \(j, is) -> (j + 1, is)
+ ePatToPat :: Elim' Pattern -> NamedArg Pattern
+ ePatToPat (Apply p) = fmap unnamed p
+ ePatToPat (Proj d) = defaultNamedArg $ ProjP d
+
+ dtermToPat :: DisplayTerm -> StateT (Int, [(Int, Int)]) TCM Pattern
dtermToPat v =
case v of
DWithApp{} -> __IMPOSSIBLE__ -- I believe
- DCon c vs -> ConP c Nothing . map (fmap unnamed)
+ DCon c vs -> ConP c noConPatternInfo . map (fmap unnamed)
<$> mapM (traverse dtermToPat) vs
- DDef{} -> DotP (dtermToTerm v) <$ skip
+ DDef d es -> do
+ ifM (return (null es) `and2M` do isJust <$> lift (isProjection d))
+ {-then-} (return $ ProjP d)
+ {-else-} (DotP (dtermToTerm v) <$ skip)
DDot v -> DotP v <$ skip
DTerm (Var i []) ->
ifM (bindVar i) (VarP . nameToPatVarName <$> lift (nameOfBV i))
(pure $ DotP (Var i []))
- DTerm (Con c vs) -> ConP c Nothing . map (fmap unnamed) <$> mapM (traverse (dtermToPat . DTerm)) vs
+ DTerm (Con c vs) -> ConP c noConPatternInfo . map (fmap unnamed) <$>
+ mapM (traverse (dtermToPat . DTerm)) vs
DTerm v -> DotP v <$ skip
isWithFunction :: MonadTCM tcm => QName -> tcm (Maybe QName)
@@ -230,11 +242,3 @@ expandWithFunctionCall f es = do
return $ dtermToTerm disp `applyE` es'
where
(vs, es') = splitApplyElims es
-
-dtermToTerm :: DisplayTerm -> Term
-dtermToTerm (DWithApp d ds vs) = dtermToTerm d `apply` (map (defaultArg . dtermToTerm) ds ++ vs)
-dtermToTerm (DCon c args) = Con c $ map (fmap dtermToTerm) args
-dtermToTerm (DDef f args) = Def f $ map (Apply . fmap dtermToTerm) args
-dtermToTerm (DDot v) = v
-dtermToTerm (DTerm v) = v
-
diff --git a/src/full/Agda/Termination/Monad.hs b/src/full/Agda/Termination/Monad.hs
index 91bef83..cd7f687 100644
--- a/src/full/Agda/Termination/Monad.hs
+++ b/src/full/Agda/Termination/Monad.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-- | The monad for the termination checker.
--
@@ -13,17 +14,21 @@
module Agda.Termination.Monad where
-import Control.Applicative
+import Prelude hiding (null)
+
+import Control.Applicative hiding (empty)
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
+import Data.Foldable (Foldable)
import Data.Functor ((<$>))
import qualified Data.List as List
+import Data.Traversable (Traversable)
import Agda.Interaction.Options
-import Agda.Syntax.Abstract (QName,IsProjP(..))
+import Agda.Syntax.Abstract (QName, IsProjP(..), AllNames)
import Agda.Syntax.Common (Delayed(..), Induction(..), Dom(..))
import Agda.Syntax.Internal
import Agda.Syntax.Literal
@@ -37,12 +42,17 @@ import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Records
+import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.Utils.Except ( MonadError(catchError, throwError) )
+import Agda.Utils.Function
+import Agda.Utils.Functor
+import Agda.Utils.Lens
import Agda.Utils.Maybe
import Agda.Utils.Monad
-import Agda.Utils.Pretty (Pretty)
+import Agda.Utils.Null
+import Agda.Utils.Pretty (Pretty, prettyShow)
import qualified Agda.Utils.Pretty as P
import Agda.Utils.VarSet (VarSet)
import qualified Agda.Utils.VarSet as VarSet
@@ -102,10 +112,14 @@ data TerEnv = TerEnv
, terDelayed :: Delayed
-- ^ Are we checking a delayed definition?
, terMaskArgs :: [Bool]
- -- ^ Only consider the 'True' arguments for establishing termination.
+ -- ^ Only consider the 'notMasked' 'False' arguments for establishing termination.
, terMaskResult :: Bool
- -- ^ Only consider guardedness if 'True'.
- , terPatterns :: [DeBruijnPat]
+ -- ^ Only consider guardedness if 'False' (not masked).
+ , _terSizeDepth :: Int -- lazy by intention!
+ -- ^ How many @SIZELT@ relations do we have in the context
+ -- (= clause telescope). Used to approximate termination
+ -- for metas in call args.
+ , terPatterns :: MaskedDeBruijnPats
-- ^ The patterns of the clause we are checking.
, terPatternsRaise :: !Int
-- ^ Number of additional binders we have gone under
@@ -149,8 +163,9 @@ defaultTerEnv = TerEnv
, terCurrent = __IMPOSSIBLE__ -- needs to be set!
, terTarget = Nothing
, terDelayed = NotDelayed
- , terMaskArgs = repeat True -- use all arguments
- , terMaskResult = True -- use result
+ , terMaskArgs = repeat False -- use all arguments (mask none)
+ , terMaskResult = False -- use result (do not mask)
+ , _terSizeDepth = __IMPOSSIBLE__ -- needs to be set!
, terPatterns = __IMPOSSIBLE__ -- needs to be set!
, terPatternsRaise = 0
, terGuarded = le -- not initially guarded
@@ -292,10 +307,13 @@ terGetMaskResult = terAsks terMaskResult
terSetMaskResult :: Bool -> TerM a -> TerM a
terSetMaskResult b = terLocal $ \ e -> e { terMaskResult = b }
-terGetPatterns :: TerM DeBruijnPats
-terGetPatterns = raiseDBP <$> terAsks terPatternsRaise <*> terAsks terPatterns
+terGetPatterns :: TerM (MaskedDeBruijnPats)
+terGetPatterns = do
+ n <- terAsks terPatternsRaise
+ mps <- terAsks terPatterns
+ return $ if n == 0 then mps else map (fmap (fmap (n +))) mps
-terSetPatterns :: DeBruijnPats -> TerM a -> TerM a
+terSetPatterns :: MaskedDeBruijnPats -> TerM a -> TerM a
terSetPatterns ps = terLocal $ \ e -> e { terPatterns = ps }
terRaise :: TerM a -> TerM a
@@ -317,6 +335,11 @@ terUnguarded = terSetGuarded unknown
terPiGuarded :: TerM a -> TerM a
terPiGuarded m = ifM terGetGuardingTypeConstructors m $ terUnguarded m
+-- | Lens for '_terSizeDepth'.
+
+terSizeDepth :: Lens' Int TerEnv
+terSizeDepth f e = f (_terSizeDepth e) <&> \ i -> e { _terSizeDepth = i }
+
-- | Lens for 'terUsableVars'.
terGetUsableVars :: TerM VarSet
@@ -343,6 +366,7 @@ terSetUseSizeLt = terModifyUseSizeLt . const
withUsableVars :: UsableSizeVars a => a -> TerM b -> TerM b
withUsableVars pats m = do
vars <- usableSizeVars pats
+ reportSLn "term.size" 20 $ "usableSizeVars = " ++ show vars
terSetUsableVars vars $ m
-- | Set 'terUseSizeLt' when going under constructor @c@.
@@ -353,12 +377,14 @@ conUseSizeLt c m = do
(const $ terSetUseSizeLt False m)
-- | Set 'terUseSizeLt' for arguments following projection @q@.
+-- We disregard j<i after a non-coinductive projection.
+-- However, the projection need not be recursive (Issue 1470).
projUseSizeLt :: QName -> TerM a -> TerM a
-projUseSizeLt q m = isCoinductiveProjection q >>= (`terSetUseSizeLt` m)
--- projUseSizeLt q m = do
--- ifM (liftTCM $ isProjectionButNotCoinductive q)
--- (terSetUseSizeLt False m)
--- (terSetUseSizeLt True m)
+projUseSizeLt q m = do
+ co <- isCoinductiveProjection False q
+ reportSLn "term.size" 20 $ applyUnless co ("not " ++) $
+ "using SIZELT vars after projection " ++ prettyShow q
+ terSetUseSizeLt co m
-- | For termination checking purposes flat should not be considered a
-- projection. That is, it flat doesn't preserve either structural order
@@ -393,29 +419,44 @@ isProjectionButNotCoinductive qn = liftTCM $ do
--
-- isCoinductiveProjection (Stream.tail) = return True
-- @
-isCoinductiveProjection :: MonadTCM tcm => QName -> tcm Bool
-isCoinductiveProjection q = liftTCM $ do
+isCoinductiveProjection :: MonadTCM tcm => Bool -> QName -> tcm Bool
+isCoinductiveProjection mustBeRecursive q = liftTCM $ do
+ reportSLn "term.guardedness" 40 $ "checking isCoinductiveProjection " ++ prettyShow q
flat <- fmap nameOfFlat <$> coinductionKit
-- yes for ♭
if Just q == flat then return True else do
- pdef <- getConstInfo q
- case isProjection_ (theDef pdef) of
- Just Projection{ projProper = Just{}, projFromType = r, projIndex = n }
- -> caseMaybeM (isRecord r) __IMPOSSIBLE__ $ \ rdef -> do
- -- no for inductive or non-recursive record
- if recInduction rdef /= Just CoInductive then return False else do
- if not (recRecursive rdef) then return False else do
- -- TODO: the following test for recursiveness of a projection should be cached.
- -- E.g., it could be stored in the @Projection@ component.
- -- Now check if type of field mentions mutually recursive symbol.
- -- Get the type of the field by dropping record parameters and record argument.
- let TelV tel core = telView' (defType pdef)
- tel' = drop n $ telToList tel
- -- Check if any recursive symbols appear in the record type.
- -- Q (2014-07-01): Should we normalize the type?
- names <- anyDefs (r : recMutual rdef) (map (snd . unDom) tel', core)
- return $ not $ null names
- _ -> return False
+ pdef <- getConstInfo q
+ case isProjection_ (theDef pdef) of
+ Just Projection{ projProper = Just{}, projFromType = r, projIndex = n } ->
+ caseMaybeM (isRecord r) __IMPOSSIBLE__ $ \ rdef -> do
+ -- no for inductive or non-recursive record
+ if recInduction rdef /= Just CoInductive then return False else do
+ reportSLn "term.guardedness" 40 $ prettyShow q ++ " is coinductive"
+ if not mustBeRecursive then return True else do
+ reportSLn "term.guardedness" 40 $ prettyShow q ++ " must be recursive"
+ if not (recRecursive rdef) then return False else do
+ reportSLn "term.guardedness" 40 $ prettyShow q ++ " has been declared recursive, doing actual check now..."
+ -- TODO: the following test for recursiveness of a projection should be cached.
+ -- E.g., it could be stored in the @Projection@ component.
+ -- Now check if type of field mentions mutually recursive symbol.
+ -- Get the type of the field by dropping record parameters and record argument.
+ let TelV tel core = telView' (defType pdef)
+ tel' = drop n $ telToList tel
+ -- Check if any recursive symbols appear in the record type.
+ -- Q (2014-07-01): Should we normalize the type?
+ reportSDoc "term.guardedness" 40 $ sep
+ [ text "looking for recursive occurrences in"
+ , prettyTCM (telFromList tel')
+ , text "and"
+ , prettyTCM core
+ ]
+ names <- anyDefs (r : recMutual rdef) (map (snd . unDom) tel', core)
+ reportSDoc "term.guardedness" 40 $
+ text "found" <+> sep (map prettyTCM names)
+ return $ not $ null names
+ _ -> do
+ reportSLn "term.guardedness" 40 $ prettyShow q ++ " is not a proper projection"
+ return False
-- * De Bruijn patterns.
@@ -485,21 +526,61 @@ class UsableSizeVars a where
usableSizeVars :: a -> TerM VarSet
instance UsableSizeVars DeBruijnPat where
- usableSizeVars p =
+ usableSizeVars p = do
+ let none = return mempty
case p of
- VarDBP i -> ifM terGetUseSizeLt (return $ VarSet.singleton i) (return $ mempty)
+ VarDBP i -> ifM terGetUseSizeLt (return $ VarSet.singleton i) {- else -} none
ConDBP c ps -> conUseSizeLt c $ usableSizeVars ps
- LitDBP{} -> return mempty
- TermDBP{} -> return mempty
- ProjDBP{} -> return mempty
+ LitDBP{} -> none
+ TermDBP{} -> none
+ ProjDBP{} -> none
-instance UsableSizeVars [DeBruijnPat] where
+instance UsableSizeVars DeBruijnPats where
usableSizeVars ps =
case ps of
[] -> return mempty
(ProjDBP q : ps) -> projUseSizeLt q $ usableSizeVars ps
(p : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps
+instance UsableSizeVars (Masked DeBruijnPat) where
+ usableSizeVars (Masked m p) = do
+ let none = return mempty
+ case p of
+ VarDBP i -> ifM terGetUseSizeLt (return $ VarSet.singleton i) {- else -} none
+ ConDBP c ps -> if m then none else conUseSizeLt c $ usableSizeVars ps
+ LitDBP{} -> none
+ TermDBP{} -> none
+ ProjDBP{} -> none
+
+instance UsableSizeVars MaskedDeBruijnPats where
+ usableSizeVars ps =
+ case ps of
+ [] -> return mempty
+ (Masked _ (ProjDBP q) : ps) -> projUseSizeLt q $ usableSizeVars ps
+ (p : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps
+
+-- * Masked patterns (which are not eligible for structural descent, only for size descent)
+
+type MaskedDeBruijnPats = [Masked DeBruijnPat]
+
+data Masked a = Masked
+ { getMask :: Bool -- ^ True if thing not eligible for structural descent.
+ , getMasked :: a -- ^ Thing.
+ } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+masked :: a -> Masked a
+masked = Masked True
+
+notMasked :: a -> Masked a
+notMasked = Masked False
+
+instance Decoration Masked where
+ traverseF f (Masked m a) = Masked m <$> f a
+
+-- | Print masked things in double parentheses.
+instance PrettyTCM a => PrettyTCM (Masked a) where
+ prettyTCM (Masked m a) = applyWhen m (parens . parens) $ prettyTCM a
+
-- * Call pathes
-- | The call information is stored as free monoid
@@ -513,12 +594,31 @@ instance UsableSizeVars [DeBruijnPat] where
-- Performance-wise, I could not see a difference between Set and list.
newtype CallPath = CallPath { callInfos :: [CallInfo] }
- deriving (Show, Monoid)
+ deriving (Show, Monoid, AllNames)
-- | Only show intermediate nodes. (Drop last 'CallInfo').
instance Pretty CallPath where
- pretty (CallPath cis0) = if List.null cis then P.empty else
+ pretty (CallPath cis0) = if null cis then empty else
P.hsep (map (\ ci -> arrow P.<+> P.pretty ci) cis) P.<+> arrow
where
cis = init cis0
arrow = P.text "-->"
+
+-- * Size depth estimation
+
+-- | A very crude way of estimating the @SIZELT@ chains
+-- @i > j > k@ in context. Returns 3 in this case.
+-- Overapproximates.
+
+-- TODO: more precise analysis, constructing a tree
+-- of relations between size variables.
+terSetSizeDepth :: Telescope -> TerM a -> TerM a
+terSetSizeDepth tel cont = do
+ n <- liftTCM $ sum <$> do
+ forM (telToList tel) $ \ dom -> do
+ a <- reduce $ snd $ unDom dom
+ ifM (isJust <$> isSizeType a) (return 1) {- else -} $ do
+ case ignoreSharing $ unEl a of
+ MetaV{} -> return 1
+ _ -> return 0
+ terLocal (set terSizeDepth n) cont
diff --git a/src/full/Agda/Termination/Order.hs b/src/full/Agda/Termination/Order.hs
index b513927..de59d0d 100644
--- a/src/full/Agda/Termination/Order.hs
+++ b/src/full/Agda/Termination/Order.hs
@@ -1,7 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ImplicitParams #-}
-- | An Abstract domain of relative sizes, i.e., differences
-- between size of formal function parameter and function argument
@@ -31,7 +30,7 @@ import Agda.Termination.Semiring (HasZero(..), Semiring)
import qualified Agda.Termination.Semiring as Semiring
import Agda.Utils.PartialOrd hiding (tests)
-import Agda.Utils.Pretty hiding (empty)
+import Agda.Utils.Pretty
import Agda.Utils.QuickCheck
import Agda.Utils.TestHelpers
diff --git a/src/full/Agda/Termination/SparseMatrix.hs b/src/full/Agda/Termination/SparseMatrix.hs
index b90a538..f3ff6e5 100644
--- a/src/full/Agda/Termination/SparseMatrix.hs
+++ b/src/full/Agda/Termination/SparseMatrix.hs
@@ -1,13 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{- | Sparse matrices.
diff --git a/src/full/Agda/Termination/TermCheck.hs b/src/full/Agda/Termination/TermCheck.hs
index 5139949..18d0af3 100644
--- a/src/full/Agda/Termination/TermCheck.hs
+++ b/src/full/Agda/Termination/TermCheck.hs
@@ -1,12 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
{- Checking for Structural recursion
Authors: Andreas Abel, Nils Anders Danielsson, Ulf Norell,
@@ -22,9 +21,10 @@ module Agda.Termination.TermCheck
import Prelude hiding (null)
-import Control.Applicative
+import Control.Applicative hiding (empty)
import Control.Monad.State
+import Data.Foldable (toList)
import Data.List hiding (null)
import qualified Data.List as List
import Data.Maybe (mapMaybe, isJust, fromMaybe)
@@ -34,7 +34,7 @@ import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (traverse)
-import Agda.Syntax.Abstract (IsProjP(..))
+import Agda.Syntax.Abstract (IsProjP(..), AllNames(..))
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Internal as I
import qualified Agda.Syntax.Info as Info
@@ -44,9 +44,9 @@ import Agda.Syntax.Literal (Literal(LitString))
import Agda.Termination.CutOff
import Agda.Termination.Monad
-import Agda.Termination.CallGraph hiding (null)
+import Agda.Termination.CallGraph hiding (toList)
import qualified Agda.Termination.CallGraph as CallGraph
-import Agda.Termination.CallMatrix hiding (null)
+import Agda.Termination.CallMatrix hiding (toList)
import Agda.Termination.Order as Order
import qualified Agda.Termination.SparseMatrix as Matrix
import Agda.Termination.Termination (endos, idempotent)
@@ -79,8 +79,8 @@ import Agda.Utils.Maybe
import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M)
import Agda.Utils.Null
import Agda.Utils.Permutation
-import Agda.Utils.Pointed
import Agda.Utils.Pretty (render)
+import Agda.Utils.Singleton
import Agda.Utils.VarSet (VarSet)
import qualified Agda.Utils.VarSet as VarSet
@@ -92,14 +92,14 @@ import Agda.Utils.Impossible
type Calls = CallGraph CallPath
-- | The result of termination checking a module.
--- Must be 'Pointed' and a 'Monoid'.
+-- Must be a 'Monoid' and have 'Singleton'.
type Result = [TerminationError]
--- | Termination check a single declaration.
+-- | Entry point: Termination check a single declaration.
termDecl :: A.Declaration -> TCM Result
-termDecl d = ignoreAbstractMode $ termDecl' d
+termDecl d = inTopContext $ ignoreAbstractMode $ termDecl' d
-- | Termination check a sequence of declarations.
@@ -112,28 +112,27 @@ termDecls ds = concat <$> mapM termDecl' ds
-- (without necessarily ignoring @abstract@).
termDecl' :: A.Declaration -> TCM Result
-termDecl' (A.ScopedDecl scope ds) = do
- setScope scope
- termDecls ds
termDecl' d = case d of
A.Axiom {} -> return mempty
A.Field {} -> return mempty
A.Primitive {} -> return mempty
A.Mutual _ ds
- | [A.RecSig{}, A.RecDef _ r _ _ _ _ rds] <- unscopeDefs ds
- -> checkRecDef ds r rds
+ | [A.RecSig{}, A.RecDef _ _ _ _ _ _ rds] <- unscopeDefs ds
+ -> termDecls rds
A.Mutual i ds -> termMutual i ds
- A.Section _ x _ ds -> termSection x ds
+ A.Section _ _ _ ds -> termDecls ds
+ -- section structure can be ignored as we are termination checking
+ -- definitions lifted to the top-level
A.Apply {} -> return mempty
A.Import {} -> return mempty
A.Pragma {} -> return mempty
A.Open {} -> return mempty
A.PatternSynDef {} -> return mempty
-- open and pattern synonym defs are just artifacts from the concrete syntax
- A.ScopedDecl{} -> __IMPOSSIBLE__
- -- taken care of above
+ A.ScopedDecl _ ds -> termDecls ds
+ -- scope is irrelevant as we are termination checking Syntax.Internal
A.RecSig{} -> return mempty
- A.RecDef _ r _ _ _ _ ds -> checkRecDef [] r ds
+ A.RecDef _ r _ _ _ _ ds -> termDecls ds
-- These should all be wrapped in mutual blocks
A.FunDef{} -> __IMPOSSIBLE__
A.DataSig{} -> __IMPOSSIBLE__
@@ -141,32 +140,11 @@ termDecl' d = case d of
-- This should have been expanded to a proper declaration before termination checking
A.UnquoteDecl{} -> __IMPOSSIBLE__
where
- setScopeFromDefs = mapM_ setScopeFromDef
- setScopeFromDef (A.ScopedDecl scope d) = setScope scope
- setScopeFromDef _ = return ()
-
unscopeDefs = concatMap unscopeDef
unscopeDef (A.ScopedDecl _ ds) = unscopeDefs ds
unscopeDef d = [d]
- checkRecDef ds r rds = do
- setScopeFromDefs ds
- termSection (mnameFromList $ qnameToList r) rds
-
-
--- | Termination check a module.
-
-termSection :: ModuleName -> [A.Declaration] -> TCM Result
-termSection x ds = do
- tel <- lookupSection x
- reportSDoc "term.section" 10 $
- sep [ text "termination checking section"
- , prettyTCM x
- , prettyTCM tel
- ]
- withCurrentModule x $ addCtxTel tel $ termDecls ds
-
-- | Termination check a bunch of mutually inductive recursive definitions.
@@ -174,7 +152,7 @@ termMutual :: Info.MutualInfo -> [A.Declaration] -> TCM Result
termMutual i ds = if names == [] then return mempty else
-- We set the range to avoid panics when printing error messages.
- traceCall (SetRange (Info.mutualRange i)) $ do
+ setCurrentRange i $ do
-- Get set of mutually defined names from the TCM.
-- This includes local and auxiliary functions introduced
@@ -226,7 +204,7 @@ termMutual i ds = if names == [] then return mempty else
(runTerm $ termMutual')
-- record result of termination check in signature
- let terminates = List.null res
+ let terminates = null res
forM_ allNames $ \ q -> setTerminates q terminates
return res
@@ -274,16 +252,18 @@ termMutual' = do
-- the names the user has declared. This is for error reporting.
names <- terGetUserNames
case r of
- Left calls -> do
- return $ point $ TerminationError
- { termErrFunctions = names
- , termErrCalls = callInfos calls
- }
+ Left calls -> return $ singleton $ terminationError names $ callInfos calls
Right{} -> do
liftTCM $ reportSLn "term.warn.yes" 2 $
show (names) ++ " does termination check"
return mempty
+-- | Smart constructor for 'TerminationError'.
+-- Removes 'termErrFunctions' that are not mentioned in 'termErrCalls'.
+terminationError :: [QName] -> [CallInfo] -> TerminationError
+terminationError names calls = TerminationError names' calls
+ where names' = names `intersect` toList (allNames calls)
+
-- ASR (08 November 2014). The type of the function could be
--
-- @Either a b -> TerM (Either a b)@.
@@ -296,123 +276,119 @@ billToTerGraph = billPureTo [Benchmark.Termination, Benchmark.Graph]
reportCalls :: String -> Calls -> TerM ()
reportCalls no calls = do
- cutoff <- terGetCutOff
- let ?cutoff = cutoff
+ cutoff <- terGetCutOff
+ let ?cutoff = cutoff
- -- We work in TCM exclusively.
- liftTCM $ do
+ -- We work in TCM exclusively.
+ liftTCM $ do
- reportS "term.lex" 20 $ unlines
- [ "Calls (" ++ no ++ "dot patterns): " ++ show calls
- ]
+ reportS "term.lex" 20 $ unlines
+ [ "Calls (" ++ no ++ "dot patterns): " ++ show calls
+ ]
- -- Print the whole completion phase.
- verboseS "term.matrices" 40 $ do
- let header s = unlines
- [ replicate n '='
- , replicate k '=' ++ s ++ replicate k' '='
- , replicate n '='
- ]
- where n = 70
- r = n - length s
- k = r `div` 2
- k' = r - k
- let report s cs = reportSDoc "term.matrices" 40 $ vcat
- [ text $ header s
- , nest 2 $ pretty cs
- ]
- cs0 = calls
- step cs = do
- let (new, cs') = completionStep cs0 cs
- report " New call matrices " new
- return $ if CallGraph.null new then Left () else Right cs'
- report " Initial call matrices " cs0
- trampolineM step cs0
-
- -- Print the result of completion.
- let calls' = CallGraph.complete calls
- idems = filter idempotent $ endos $ CallGraph.toList calls'
- -- TODO
- -- reportSDoc "term.behaviours" 20 $ vcat
- -- [ text $ "Recursion behaviours (" ++ no ++ "dot patterns):"
- -- , nest 2 $ return $ Term.prettyBehaviour calls'
- -- ]
- reportSDoc "term.matrices" 30 $ vcat
- [ text $ "Idempotent call matrices (" ++ no ++ "dot patterns):\n"
- , nest 2 $ vcat $ punctuate (text "\n") $ map pretty idems
- ]
- -- reportSDoc "term.matrices" 30 $ vcat
- -- [ text $ "Other call matrices (" ++ no ++ "dot patterns):"
- -- , nest 2 $ pretty $ CallGraph.fromList others
- -- ]
- return ()
+ -- Print the whole completion phase.
+ verboseS "term.matrices" 40 $ do
+ let header s = unlines
+ [ replicate n '='
+ , replicate k '=' ++ s ++ replicate k' '='
+ , replicate n '='
+ ]
+ where n = 70
+ r = n - length s
+ k = r `div` 2
+ k' = r - k
+ let report s cs = reportSDoc "term.matrices" 40 $ vcat
+ [ text $ header s
+ , nest 2 $ pretty cs
+ ]
+ cs0 = calls
+ step cs = do
+ let (new, cs') = completionStep cs0 cs
+ report " New call matrices " new
+ return $ if null new then Left () else Right cs'
+ report " Initial call matrices " cs0
+ trampolineM step cs0
+
+ -- Print the result of completion.
+ let calls' = CallGraph.complete calls
+ idems = filter idempotent $ endos $ CallGraph.toList calls'
+ -- TODO
+ -- reportSDoc "term.behaviours" 20 $ vcat
+ -- [ text $ "Recursion behaviours (" ++ no ++ "dot patterns):"
+ -- , nest 2 $ return $ Term.prettyBehaviour calls'
+ -- ]
+ reportSDoc "term.matrices" 30 $ vcat
+ [ text $ "Idempotent call matrices (" ++ no ++ "dot patterns):\n"
+ , nest 2 $ vcat $ punctuate (text "\n") $ map pretty idems
+ ]
+ -- reportSDoc "term.matrices" 30 $ vcat
+ -- [ text $ "Other call matrices (" ++ no ++ "dot patterns):"
+ -- , nest 2 $ pretty $ CallGraph.fromList others
+ -- ]
+ return ()
-- | @termFunction name@ checks @name@ for termination.
termFunction :: QName -> TerM Result
termFunction name = do
- -- Function @name@ is henceforth referred to by its @index@
- -- in the list of @allNames@ of the mutual block.
-
- allNames <- terGetMutual
- let index = fromMaybe __IMPOSSIBLE__ $ List.elemIndex name allNames
-
- -- Retrieve the target type of the function to check.
-
- target <- liftTCM $ do typeEndsInDef =<< typeOfConst name
- reportTarget target
- terSetTarget target $ do
-
- -- Collect the recursive calls in the block which (transitively)
- -- involve @name@,
- -- taking the target of @name@ into account for computing guardedness.
-
- let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do
- if null todo then return $ Left calls else do
- -- Extract calls originating from indices in @todo@.
- new <- forM' todo $ \ i ->
- termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i
- -- Mark those functions as processed and add the calls to the result.
- let done' = done `mappend` todo
- calls' = new `mappend` calls
- -- Compute the new todo list:
- todo' = CallGraph.targetNodes new Set.\\ done'
- -- Jump the trampoline.
- return $ Right (todo', done', calls')
-
- -- First try to termination check ignoring the dot patterns
- calls1 <- terSetUseDotPatterns False $ collect
- reportCalls "no " calls1
-
- r <- do
- cutoff <- terGetCutOff
- let ?cutoff = cutoff
- r <- billToTerGraph $ Term.terminatesFilter (== index) calls1
- case r of
- Right () -> return $ Right ()
- Left{} -> do
- -- Try again, but include the dot patterns this time.
- calls2 <- terSetUseDotPatterns True $ collect
- reportCalls "" calls2
- billToTerGraph $ mapLeft callInfos $ Term.terminatesFilter (== index) calls2
-
- names <- terGetUserNames
+ -- Function @name@ is henceforth referred to by its @index@
+ -- in the list of @allNames@ of the mutual block.
+
+ allNames <- terGetMutual
+ let index = fromMaybe __IMPOSSIBLE__ $ List.elemIndex name allNames
+
+ -- Retrieve the target type of the function to check.
+
+ target <- liftTCM $ do typeEndsInDef =<< typeOfConst name
+ reportTarget target
+ terSetTarget target $ do
+
+ -- Collect the recursive calls in the block which (transitively)
+ -- involve @name@,
+ -- taking the target of @name@ into account for computing guardedness.
+
+ let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do
+ if null todo then return $ Left calls else do
+ -- Extract calls originating from indices in @todo@.
+ new <- forM' todo $ \ i ->
+ termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i
+ -- Mark those functions as processed and add the calls to the result.
+ let done' = done `mappend` todo
+ calls' = new `mappend` calls
+ -- Compute the new todo list:
+ todo' = CallGraph.targetNodes new Set.\\ done'
+ -- Jump the trampoline.
+ return $ Right (todo', done', calls')
+
+ -- First try to termination check ignoring the dot patterns
+ calls1 <- terSetUseDotPatterns False $ collect
+ reportCalls "no " calls1
+
+ r <- do
+ cutoff <- terGetCutOff
+ let ?cutoff = cutoff
+ r <- billToTerGraph $ Term.terminatesFilter (== index) calls1
case r of
- Left calls -> do
- return $ point $ TerminationError
- { termErrFunctions = if name `elem` names then [name] else []
- , termErrCalls = calls
- }
- Right () -> do
- liftTCM $ reportSLn "term.warn.yes" 2 $
- show (name) ++ " does termination check"
- return mempty
- where
- reportTarget r = liftTCM $
- reportSLn "term.target" 20 $ " target type " ++
- caseMaybe r "not recognized" (\ q ->
- "ends in " ++ show q)
+ Right () -> return $ Right ()
+ Left{} -> do
+ -- Try again, but include the dot patterns this time.
+ calls2 <- terSetUseDotPatterns True $ collect
+ reportCalls "" calls2
+ billToTerGraph $ mapLeft callInfos $ Term.terminatesFilter (== index) calls2
+
+ names <- terGetUserNames
+ case r of
+ Left calls -> return $ singleton $ terminationError ([name] `intersect` names) calls
+ Right () -> do
+ liftTCM $ reportSLn "term.warn.yes" 2 $
+ show name ++ " does termination check"
+ return mempty
+ where
+ reportTarget r = liftTCM $
+ reportSLn "term.target" 20 $ " target type " ++
+ caseMaybe r "not recognized" (\ q ->
+ "ends in " ++ show q)
-- | To process the target type.
typeEndsInDef :: MonadTCM tcm => Type -> tcm (Maybe QName)
@@ -451,13 +427,13 @@ termDef name = terSetCurrent name $ do
applyWhen withoutKEnabled (setMasks t) $ do
-- If the result should be disregarded, set all calls to unguarded.
- applyUnlessM terGetMaskResult terUnguarded $ do
+ applyWhenM terGetMaskResult terUnguarded $ do
case theDef def of
Function{ funClauses = cls, funDelayed = delayed } ->
terSetDelayed delayed $ forM' cls $ termClause
- _ -> return CallGraph.empty
+ _ -> return empty
-- | Mask arguments and result for termination checking
-- according to type of function.
@@ -469,13 +445,19 @@ setMasks t cont = do
-- Check argument types
ds <- forM (telToList tel) $ \ t -> do
TelV _ t <- telView $ snd $ unDom t
- (isJust <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)
+ d <- (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)
+ when d $
+ reportSDoc "term.mask" 20 $ do
+ text "argument type "
+ <+> prettyTCM t
+ <+> text " is not data or record type, ignoring structural descent for --without-K"
+ return d
-- Check result types
- d <- isJust <.> isDataOrRecord . unEl $ core
- unless d $
+ d <- isNothing <.> isDataOrRecord . unEl $ core
+ when d $
reportSLn "term.mask" 20 $ "result type is not data or record type, ignoring guardedness for --without-K"
return (ds, d)
- terSetMaskArgs (ds ++ repeat False) $ terSetMaskResult d $ cont
+ terSetMaskArgs (ds ++ repeat True) $ terSetMaskResult d $ cont
{- Termination check clauses:
@@ -560,11 +542,11 @@ stripCoConstructors p = do
ProjDBP{} -> return p
-- | Masks all non-data/record type patterns if --without-K.
-maskNonDataArgs :: [DeBruijnPat] -> TerM [DeBruijnPat]
+maskNonDataArgs :: [DeBruijnPat] -> TerM [Masked DeBruijnPat]
maskNonDataArgs ps = zipWith mask ps <$> terGetMaskArgs
where
- mask p@ProjDBP{} _ = p
- mask p d = if d then p else unusedVar
+ mask p@ProjDBP{} _ = Masked False p
+ mask p d = Masked d p
-- | cf. 'TypeChecking.Coverage.Match.buildMPatterns'
openClause :: Permutation -> [Pattern] -> ClauseBody -> TerM ([DeBruijnPat], Maybe Term)
@@ -595,9 +577,9 @@ openClause perm ps body = do
termClause :: Clause -> TerM Calls
termClause clause = do
ifNotM (terGetInlineWithFunctions) (termClause' clause) $ {- else -} do
- name <- terGetCurrent
- ifM (isJust <$> do isWithFunction name) (return mempty) $ do
- mapM' termClause' =<< do liftTCM $ inlineWithClauses name clause
+ name <- terGetCurrent
+ ifM (isJust <$> do isWithFunction name) (return mempty) $ do
+ mapM' termClause' =<< do liftTCM $ inlineWithClauses name clause
termClause' :: Clause -> TerM Calls
termClause' clause = do
@@ -616,11 +598,12 @@ termClause' clause = do
ps <- liftTCM $ normalise $ map unArg argPats'
(dbpats, res) <- openClause perm ps body
case res of
- Nothing -> return CallGraph.empty
+ Nothing -> return empty
Just v -> do
dbpats <- mapM stripCoConstructors dbpats
- dbpats <- maskNonDataArgs dbpats
- terSetPatterns dbpats $ do
+ mdbpats <- maskNonDataArgs dbpats
+ terSetPatterns mdbpats $ do
+ terSetSizeDepth tel $ do
reportBody v
{-
-- if we are checking a delayed definition, we treat it as if there were
@@ -704,7 +687,7 @@ instance ExtractCalls a => ExtractCalls (I.Dom a) where
extract = extract . unDom
instance ExtractCalls a => ExtractCalls (Elim' a) where
- extract Proj{} = return CallGraph.empty
+ extract Proj{} = return empty
extract (Apply a) = extract $ unArg a
instance ExtractCalls a => ExtractCalls [a] where
@@ -726,8 +709,9 @@ instance ExtractCalls Sort where
reportSDoc "term.sort" 50 $
text ("s = " ++ show s)
case s of
- Prop -> return CallGraph.empty
- Inf -> return CallGraph.empty
+ Prop -> return empty
+ Inf -> return empty
+ SizeUniv -> return empty
Type t -> terUnguarded $ extract t -- no guarded levels
DLub s1 s2 -> extract (s1, s2)
@@ -897,7 +881,10 @@ function g es = ifM (terGetInlineWithFunctions `and2M` do isJust <$> isWithFunct
-- So we build a closure such that we can print the call
-- whenever we really need to.
-- This saves 30s (12%) on the std-lib!
- doc <- liftTCM $ buildClosure gArgs
+ -- Andreas, 2015-01-21 Issue 1410: Go to the module where g is defined
+ -- otherwise its free variables with be prepended to the call
+ -- in the error message.
+ doc <- liftTCM $ withCurrentModule (qnameModule g) $ buildClosure gArgs
let src = fromMaybe __IMPOSSIBLE__ $ List.elemIndex f names
tgt = gInd
@@ -967,14 +954,14 @@ instance ExtractCalls Term where
<*> terPiGuarded (extract b)
-- Literal.
- Lit l -> return CallGraph.empty
+ Lit l -> return empty
-- Sort.
Sort s -> extract s
-- Unsolved metas are not considered termination problems, there
-- will be a warning for them anyway.
- MetaV x args -> return CallGraph.empty
+ MetaV x args -> return empty
-- Erased and not-yet-erased proof.
DontCare t -> extract t
@@ -998,7 +985,7 @@ instance ExtractCalls PlusLevel where
instance ExtractCalls LevelAtom where
extract (MetaLevel x es) = extract es
extract (BlockedLevel x t) = extract t
- extract (NeutralLevel t) = extract t
+ extract (NeutralLevel _ t) = extract t
extract (UnreducedLevel t) = extract t
-- | Rewrite type @tel -> Size< u@ to @tel -> Size@.
@@ -1033,18 +1020,21 @@ compareArgs es = do
-- matrix <- forM es $ \ e -> forM apats $ \ (b, p) -> terSetUseSizeLt b $ compareElim e p
matrix <- withUsableVars pats $ forM es $ \ e -> forM pats $ \ p -> compareElim e p
- -- Count the number of coinductive projection(pattern)s in caller and callee
+ -- Count the number of coinductive projection(pattern)s in caller and callee.
+ -- Only recursive coinductive projections are eligible (Issue 1209).
projsCaller <- genericLength <$> do
- filterM isCoinductiveProjection $ mapMaybe isProjP pats
- -- filterM (not <.> isProjectionButNotCoinductive) $ mapMaybe isProjP pats
+ filterM (isCoinductiveProjection True) $ mapMaybe (isProjP . getMasked) pats
projsCallee <- genericLength <$> do
- filterM isCoinductiveProjection $ mapMaybe isProjElim es
- -- filterM (not <.> isProjectionButNotCoinductive) $ mapMaybe isProjElim es
+ filterM (isCoinductiveProjection True) $ mapMaybe isProjElim es
cutoff <- terGetCutOff
let ?cutoff = cutoff
let guardedness = decr $ projsCaller - projsCallee
- liftTCM $ reportSLn "term.guardedness" 30 $
- "compareArgs: guardedness of call: " ++ show guardedness
+ liftTCM $ reportSDoc "term.guardedness" 30 $ sep
+ [ text "compareArgs:"
+ , nest 2 $ text $ "projsCaller = " ++ show projsCaller
+ , nest 2 $ text $ "projsCallee = " ++ show projsCallee
+ , nest 2 $ text $ "guardedness of call: " ++ show guardedness
+ ]
return $ addGuardedness guardedness (size es) (size pats) matrix
-- | Traverse patterns from left to right.
@@ -1063,7 +1053,7 @@ annotatePatsWithUseSizeLt = loop where
-- | @compareElim e dbpat@
-compareElim :: Elim -> DeBruijnPat -> TerM Order
+compareElim :: Elim -> Masked DeBruijnPat -> TerM Order
compareElim e p = do
liftTCM $ do
reportSDoc "term.compare" 30 $ sep
@@ -1075,11 +1065,11 @@ compareElim e p = do
[ nest 2 $ text $ "e = " ++ show e
, nest 2 $ text $ "p = " ++ show p
]
- case (e, p) of
+ case (e, getMasked p) of
(Proj d, ProjDBP d') -> compareProj d d'
(Proj{}, _ ) -> return Order.unknown
(Apply{}, ProjDBP{}) -> return Order.unknown
- (Apply arg, p) -> compareTerm (unArg arg) p
+ (Apply arg, _) -> compareTerm (unArg arg) p
-- | In dependent records, the types of later fields may depend on the
-- values of earlier fields. Thus when defining an inhabitant of a
@@ -1153,7 +1143,7 @@ subPatterns p = case p of
TermDBP _ -> []
ProjDBP _ -> []
-compareTerm :: Term -> DeBruijnPat -> TerM Order
+compareTerm :: Term -> Masked DeBruijnPat -> TerM Order
compareTerm t p = do
-- reportSDoc "term.compare" 25 $
-- text " comparing term " <+> prettyTCM t <+>
@@ -1215,8 +1205,8 @@ instance StripAllProjections Term where
--
-- Precondition: top meta variable resolved
-compareTerm' :: Term -> DeBruijnPat -> TerM Order
-compareTerm' v p = do
+compareTerm' :: Term -> Masked DeBruijnPat -> TerM Order
+compareTerm' v mp@(Masked m p) = do
suc <- terGetSizeSuc
cutoff <- terGetCutOff
let ?cutoff = cutoff
@@ -1225,21 +1215,47 @@ compareTerm' v p = do
-- Andreas, 2013-11-20 do not drop projections,
-- in any case not coinductive ones!:
- (Var i es, p) | Just{} <- allApplyElims es ->
- compareVar i p
+ (Var i es, _) | Just{} <- allApplyElims es ->
+ compareVar i mp
+
+ (DontCare t, _) ->
+ compareTerm' t mp
+
+ -- Andreas, 2014-09-22, issue 1281:
+ -- For metas, termination checking should be optimistic.
+ -- If there is any instance of the meta making termination
+ -- checking succeed, then we should not fail.
+ -- Thus, we assume the meta will be instantiated with the
+ -- deepest variable in @p@.
+ -- For sized types, the depth is maximally
+ -- the number of SIZELT hypotheses one can have in a context.
+ (MetaV{}, p) -> Order.decr . max (if m then 0 else patternDepth p) . pred <$>
+ terAsks _terSizeDepth
+
+ -- Successor on both sides cancel each other.
+ -- We ignore the mask for sizes.
+ (Def s [Apply t], ConDBP s' [p]) | s == s' && Just s == suc ->
+ compareTerm' (unArg t) (notMasked p)
+
+ -- Register also size increase.
+ (Def s [Apply t], p) | Just s == suc ->
+ -- Andreas, 2012-10-19 do not cut off here
+ increase 1 <$> compareTerm' (unArg t) mp
- (DontCare t, p) ->
- compareTerm' t p
+ -- In all cases that do not concern sizes,
+ -- we cannot continue if pattern is masked.
+
+ _ | m -> return Order.unknown
(Lit l, LitDBP l')
| l == l' -> return Order.le
| otherwise -> return Order.unknown
- (Lit l, p) -> do
+ (Lit l, _) -> do
v <- liftTCM $ constructorForm v
case ignoreSharing v of
Lit{} -> return Order.unknown
- v -> compareTerm' v p
+ v -> compareTerm' v mp
-- Andreas, 2011-04-19 give subterm priority over matrix order
@@ -1249,30 +1265,13 @@ compareTerm' v p = do
(Con c ts, ConDBP c' ps) | conName c == c'->
compareConArgs ts ps
- (Def s [Apply t], ConDBP s' [p]) | s == s' && Just s == suc ->
- compareTerm' (unArg t) p
+ (Con c [], _) -> return Order.le
- -- new cases for counting constructors / projections
+ -- new case for counting constructors / projections
-- register also increase
- (Def s [Apply t], p) | Just s == suc ->
- -- Andreas, 2012-10-19 do not cut off here
- increase 1 <$> compareTerm' (unArg t) p
-
- (Con c [], p) -> return Order.le
-
- (Con c ts, p) -> do
+ (Con c ts, _) -> do
increase <$> offsetFromConstructor (conName c)
- <*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) p) ts)
-
- -- Andreas, 2014-09-22, issue 1281:
- -- For metas, termination checking should be optimistic.
- -- If there is any instance of the meta making termination
- -- checking succeed, then we should not fail.
- -- Thus, we assume the meta will be instantiated with the
- -- deepest variable in @p@.
- -- For sized types, the depth is maximally context length - 1,
- -- which is the number of SIZELT hypotheses one can have in a context.
- (MetaV{}, p) -> Order.decr . max (patternDepth p) . pred <$> getContextSize
+ <*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) mp) ts)
(t, p) -> return $ subTerm t p
@@ -1310,9 +1309,9 @@ compareConArgs ts ps = do
(0,0) -> return Order.le -- c <= c
(0,1) -> return Order.unknown -- c not<= c x
(1,0) -> __IMPOSSIBLE__
- (1,1) -> compareTerm' (unArg (head ts)) (head ps)
+ (1,1) -> compareTerm' (unArg (head ts)) (notMasked (head ps))
(_,_) -> foldl (Order..*.) Order.le <$>
- zipWithM compareTerm' (map unArg ts) ps
+ zipWithM compareTerm' (map unArg ts) (map notMasked ps)
-- corresponds to taking the size, not the height
-- allows examples like (x, y) < (Succ x, y)
{- version which does an "order matrix"
@@ -1329,25 +1328,34 @@ compareConArgs ts ps = do
-- else Order.infimum (zipWith compareTerm' (map unArg ts) ps)
-}
-compareVar :: Nat -> DeBruijnPat -> TerM Order
-compareVar i (VarDBP j) = compareVarVar i j
-compareVar i (ConDBP c ps) = do
+compareVar :: Nat -> Masked DeBruijnPat -> TerM Order
+compareVar i (Masked m p) = do
+ suc <- terGetSizeSuc
cutoff <- terGetCutOff
let ?cutoff = cutoff
- decrease <$> offsetFromConstructor c
- <*> (Order.supremum <$> mapM (compareVar i) ps)
-compareVar i LitDBP{} = return $ Order.unknown
-compareVar i TermDBP{} = return $ Order.unknown
-compareVar i ProjDBP{} = return $ Order.unknown
+ let no = return Order.unknown
+ case p of
+ ProjDBP{} -> no
+ LitDBP{} -> no
+ TermDBP{} -> no
+ VarDBP j -> compareVarVar i (Masked m j)
+ ConDBP s [p] | Just s == suc -> decrease 1 <$> compareVar i (notMasked p)
+ ConDBP c ps -> if m then no else do
+ decrease <$> offsetFromConstructor c
+ <*> (Order.supremum <$> mapM (compareVar i . notMasked) ps)
-- | Compare two variables.
--
-- The first variable comes from a term, the second from a pattern.
-compareVarVar :: Nat -> Nat -> TerM Order
-compareVarVar i j
- | i == j = return Order.le
+compareVarVar :: Nat -> Masked Nat -> TerM Order
+compareVarVar i (Masked m j)
+ | i == j = if not m then return Order.le else liftTCM $
+ -- If j is a size, we ignore the mask.
+ ifM (isJust <$> do isSizeType =<< reduce =<< typeOfBV j)
+ {- then -} (return Order.le)
+ {- else -} (return Order.unknown)
| otherwise = ifNotM ((i `VarSet.member`) <$> terGetUsableVars) (return Order.unknown) $ {- else -} do
res <- isBounded i
case res of
BoundedNo -> return Order.unknown
- BoundedLt v -> decrease 1 <$> compareTerm' v (VarDBP j)
+ BoundedLt v -> decrease 1 <$> compareTerm' v (Masked m (VarDBP j))
diff --git a/src/full/Agda/Tests.hs b/src/full/Agda/Tests.hs
index 627420b..88a6549 100644
--- a/src/full/Agda/Tests.hs
+++ b/src/full/Agda/Tests.hs
@@ -31,6 +31,7 @@ import Agda.Utils.FileName as UtilFile (tests)
import Agda.Utils.Graph.AdjacencyMap as UtilGrap (tests)
import Agda.Utils.Graph.AdjacencyMap.Unidirectional as UtilGraphUni (tests)
import Agda.Utils.List as UtilList (tests)
+import Agda.Utils.ListT.Tests as UtilListT (tests)
import Agda.Utils.PartialOrd as UtilPOrd (tests)
import Agda.Utils.Permutation.Tests as UtilPerm (tests)
import Agda.Utils.Warshall as UtilWarsh (tests)
@@ -40,6 +41,7 @@ testSuite = runTests "QuickCheck test suite:"
[ Irrel.tests
, SizedTypes.tests
, UtilFav.tests
+ , UtilListT.tests
, UtilPerm.tests
, UtilPOrd.tests
, CompEnco.tests
diff --git a/src/full/Agda/TypeChecking/Abstract.hs b/src/full/Agda/TypeChecking/Abstract.hs
index 7f65788..4b12778 100644
--- a/src/full/Agda/TypeChecking/Abstract.hs
+++ b/src/full/Agda/TypeChecking/Abstract.hs
@@ -1,7 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
-- | Functions for abstracting terms over other terms.
module Agda.TypeChecking.Abstract where
@@ -49,14 +48,14 @@ instance IsPrefixOf Term where
(Def f us, Def g vs) | f == g -> 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
- _ -> guard (u == v) >> return []
+ (u, v) -> guard (u == v) >> return []
class AbstractTerm a where
-- | @subst u . abstractTerm u == id@
abstractTerm :: Term -> a -> a
instance AbstractTerm Term where
- abstractTerm u v | Just es <- u `isPrefixOf` v = Var 0 $ raise 1 es
+ abstractTerm u v | Just es <- u `isPrefixOf` v = Var 0 $ absT es
| otherwise =
case v of
-- Andreas, 2013-10-20: the original impl. works only at base types
@@ -87,6 +86,7 @@ instance AbstractTerm Sort where
Type n -> Type $ absS n
Prop -> Prop
Inf -> Inf
+ SizeUniv -> SizeUniv
DLub s1 s2 -> DLub (absS s1) (absS s2)
where absS x = abstractTerm u x
@@ -100,7 +100,7 @@ instance AbstractTerm PlusLevel where
instance AbstractTerm LevelAtom where
abstractTerm u l = case l of
MetaLevel m vs -> MetaLevel m $ abstractTerm u vs
- NeutralLevel v -> NeutralLevel $ abstractTerm u v
+ NeutralLevel r v -> NeutralLevel r $ abstractTerm u v
BlockedLevel _ v -> UnreducedLevel $ abstractTerm u v -- abstracting might remove the blockage
UnreducedLevel v -> UnreducedLevel $ abstractTerm u v
diff --git a/src/full/Agda/TypeChecking/CheckInternal.hs b/src/full/Agda/TypeChecking/CheckInternal.hs
index eedb07a..1563d98 100644
--- a/src/full/Agda/TypeChecking/CheckInternal.hs
+++ b/src/full/Agda/TypeChecking/CheckInternal.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
-- Initially authored by Andreas, 2013-10-22.
@@ -38,28 +37,31 @@ import Agda.Utils.Size
#include "undefined.h"
import Agda.Utils.Impossible
+-- -- | Entry point for e.g. checking WithFunctionType.
+-- checkType :: Type -> TCM ()
+-- checkType t = -- dontAssignMetas $ ignoreSorts $
+-- checkInternal (unEl t) (sort Inf)
+
-- | Entry point for e.g. checking WithFunctionType.
checkType :: Type -> TCM ()
-checkType t = -- dontAssignMetas $ ignoreSorts $
- checkInternal (unEl t) (sort Inf)
+checkType t = void $ checkType' t
-{- Alternative algorithm (does not buy us much)
+-- | Check a type and infer its sort.
+--
+-- Necessary because of PTS rule @(SizeUniv, Set i, Set i)@
+-- but @SizeUniv@ is not included in any @Set i@.
--
-- This algorithm follows
--- Abel, Coquand, Dybjer, MPC 08
+-- Abel, Coquand, Dybjer, MPC 08,
-- Verifying a Semantic βη-Conversion Test for Martin-Löf Type Theory
-
-checkType :: Type -> TCM ()
-checkType t = void $ checkType' t
-
--- | Check a type and infer its sort.
+--
checkType' :: Type -> TCM Sort
checkType' t = do
reportSDoc "tc.check.internal" 20 $ sep
[ text "checking internal type "
, prettyTCM t
]
- v <- elimView $ unEl t -- bring projection-like funs in post-fix form
+ v <- elimView True $ unEl t -- bring projection-like funs in post-fix form
case ignoreSharing v of
Pi a b -> do
s1 <- checkType' $ unDom a
@@ -84,11 +86,11 @@ checkType' t = do
v@Lit{} -> typeError $ InvalidType v
v@Level{} -> typeError $ InvalidType v
DontCare v -> checkType' $ t $> v
+ ExtLam{} -> __IMPOSSIBLE__
Shared{} -> __IMPOSSIBLE__
checkTypeSpine :: Type -> Term -> Elims -> TCM Sort
checkTypeSpine a self es = shouldBeSort =<< inferSpine a self es
--}
-- | Entry point for term checking.
checkInternal :: Term -> Type -> TCM ()
@@ -105,7 +107,7 @@ checkInternal v t = do
case ignoreSharing v of
Var i es -> do
a <- typeOfBV i
- checkSpine a (Var i []) es t
+ checkSpine a (Var i []) es t
Def f es -> do -- f is not projection(-like)!
a <- defType <$> getConstInfo f
checkSpine a (Def f []) es t
@@ -128,8 +130,9 @@ checkInternal v t = do
checkInternal (absBody vb) (absBody b)
Pi a b -> do
s <- shouldBeSort t
+ when (s == SizeUniv) $ typeError $ FunctionTypeInSizeUniv v
let st = sort s
- checkInternal (unEl $ unDom a) st
+ checkInternal (unEl $ unDom a) st -- This does not work with SizeUniv
addContext (absName b, a) $ do
checkInternal (unEl $ absBody b) $ raise 1 st
Sort s -> do
@@ -169,11 +172,11 @@ checkDef' :: QName -> I.Arg Term -> Elims -> Type -> TCM ()
checkDef' f a es t = do
isProj <- isProjection f
case isProj of
- Nothing -> checkDef f (Apply a : es) t
- Just Projection{} -> do
+ Just Projection{ projIndex = n} | n > 0 -> do
let self = unArg a
b <- infer self
checkSpine b self (Proj f : es) t
+ _ -> checkDef f (Apply a : es) t
-}
checkSpine :: Type -> Term -> Elims -> Type -> TCM ()
@@ -209,7 +212,7 @@ checkRelevance r0 r0' = unless (r == r') $ typeError $ RelevanceMismatch r r'
where
r = canon r0
r' = canon r0'
- canon Forced = Relevant
+ canon Forced{} = Relevant
canon UnusedArg = Relevant
canon r = r
@@ -245,11 +248,11 @@ inferDef' :: QName -> I.Arg Term -> Elims -> TCM Type
inferDef' f a es = do
isProj <- isProjection f
case isProj of
- Nothing -> inferDef f (Apply a : es)
- Just Projection{} -> do
+ Just Projection{ projIndex = n } | n > 0 -> do
let self = unArg a
b <- infer self
inferSpine b self (Proj f : es)
+ _ -> inferDef f (Apply a : es)
-}
-- | @inferSpine t self es@ checks that spine @es@ eliminates
@@ -285,6 +288,7 @@ shouldBePi t = do
Pi a b -> return (a, b)
_ -> typeError $ ShouldBePi t
+-- | Result is in reduced form.
shouldBeSort :: Type -> TCM Sort
shouldBeSort t = ifIsSort t return (typeError $ ShouldBeASort t)
@@ -304,6 +308,7 @@ checkSort s =
-- the dummy Prop should not be part of a term we check
Inf -> typeError $ SetOmegaNotValidType
-- we cannot have Setω on the lhs of the colon
+ SizeUniv -> typeError $ InvalidTypeSort s
DLub a b -> do
checkSort a
addContext (absName b, defaultDom (sort a) :: I.Dom Type) $ do
@@ -320,8 +325,8 @@ checkLevel (Max ls) = mapM_ checkPlusLevel ls
lvl <- levelType
case l of
MetaLevel x es -> checkInternal (MetaV x es) lvl
- BlockedLevel x v -> checkInternal v lvl
- NeutralLevel v -> checkInternal v lvl
+ BlockedLevel _ v -> checkInternal v lvl
+ NeutralLevel _ v -> checkInternal v lvl
UnreducedLevel v -> checkInternal v lvl
-- | Type of a term or sort meta.
diff --git a/src/full/Agda/TypeChecking/CompiledClause.hs b/src/full/Agda/TypeChecking/CompiledClause.hs
index eb9ce69..48efa72 100644
--- a/src/full/Agda/TypeChecking/CompiledClause.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE TypeOperators #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveDataTypeable,
+ DeriveFoldable,
+ DeriveFunctor,
+ DeriveTraversable #-}
-- | Case trees.
--
diff --git a/src/full/Agda/TypeChecking/CompiledClause/Match.hs b/src/full/Agda/TypeChecking/CompiledClause/Match.hs
index 7833baa..388a63b 100644
--- a/src/full/Agda/TypeChecking/CompiledClause/Match.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause/Match.hs
@@ -1,16 +1,24 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
module Agda.TypeChecking.CompiledClause.Match where
import Control.Applicative
import Control.Monad.Reader (asks)
-import qualified Data.Map as Map
+
import Data.List
+import Data.Monoid
+import qualified Data.Map as Map
+
import Debug.Trace (trace)
import Agda.Syntax.Internal
import Agda.Syntax.Common
+
import Agda.TypeChecking.CompiledClause
import Agda.TypeChecking.Monad hiding (reportSDoc, reportSLn)
import Agda.TypeChecking.Pretty
@@ -73,116 +81,106 @@ match' ((c, es, patch) : stack) = do
sep $ prettyTCM f : map prettyTCM es
, text $ "trying clause " ++ show c
]
- let no es = return $ NoReduction $ NotBlocked $ patch $ map ignoreReduced es
- noBlocked x es = return $ NoReduction $ Blocked x $ patch $ map ignoreReduced es
- yes t = flip YesReduction t <$> asks envSimplification
+ 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
- case c of
-
- -- impossible case
- Fail -> no es
-
- -- done matching
- Done xs t
- -- if the function was partially applied, return a lambda
- | m < n -> yes $ applySubst (toSubst es) $ foldr lam t (drop m xs)
- -- otherwise, just apply instantiation to body
- -- apply the result to any extra arguments
- | otherwise -> yes $ applySubst (toSubst es0) t `applyE` map ignoreReduced es1
--- | otherwise -> yes $ applySubst (toSubst args0) t `apply` map ignoreReduced args1
- where
- n = length xs
- m = length es
- -- at least the first @n@ elims must be @Apply@s, so we can
- -- turn them into a subsitution
- toSubst = parallelS . reverse . map (unArg . argFromElim . ignoreReduced)
--- (args0, args1) = splitAt n $ map (fmap $ fmap shared) args
--- (args0, es1) = takeArgsFromElims n $ map (fmap $ fmap shared) args
- -- Andreas, 2013-05-21 why introduce sharing only here,
- -- and not in underapplied case also?
- (es0, es1) = splitAt n $ map (fmap $ fmap shared) es
- lam x t = Lam (argInfo x) (Abs (unArg x) t)
-
- -- splitting on the @n@th elimination
- Case n bs -> do
- case genericSplitAt n es of
- -- if the @n@th elimination is not supplied, no match
- (_, []) -> no es
- -- if the @n@th elimination is @e0@
--- (args0, MaybeRed red (Arg info v0) : args1) -> do
- (es0, MaybeRed red e0 : es1) -> do
- -- get the reduced form of @e0@
-{-
- w <- case red of
- Reduced b -> return $ v0 <$ b
- NotReduced -> unfoldCorecursion v0
- let v = ignoreBlocking w
- args' = args0 ++ [MaybeRed red $ Arg info v] ++ args1
--}
- eb :: Blocked Elim <- do
- case red of
- Reduced b -> return $ e0 <$ b
- NotReduced -> unfoldCorecursionE e0
- let e = ignoreBlocking eb
- -- replace the @n@th argument by its reduced form
- es' = es0 ++ [MaybeRed red 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.
- litFrame l stack =
- 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@
- -- we push @conFrame c vs@ onto the stack.
- conFrame c vs stack =
- case Map.lookup (conName c) (conBranches bs) of
+ case c of
+
+ -- impossible case
+ Fail -> no (NotBlocked AbsurdMatch) es
+
+ -- done matching
+ Done xs t
+ -- if the function was partially applied, return a lambda
+ | m < n -> yes $ applySubst (toSubst es) $ foldr lam t (drop m xs)
+ -- otherwise, just apply instantiation to body
+ -- apply the result to any extra arguments
+ | otherwise -> yes $ applySubst (toSubst es0) t `applyE` map ignoreReduced es1
+ where
+ n = length xs
+ m = length es
+ -- at least the first @n@ elims must be @Apply@s, so we can
+ -- turn them into a subsitution
+ toSubst = parallelS . reverse . map (unArg . argFromElim . ignoreReduced)
+ -- Andreas, 2013-05-21 why introduce sharing only here,
+ -- and not in underapplied case also?
+ (es0, es1) = splitAt n $ map (fmap $ fmap shared) es
+ lam x t = Lam (argInfo x) (Abs (unArg x) t)
+
+ -- splitting on the @n@th elimination
+ Case n bs -> do
+ case genericSplitAt 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) -> do
+ -- get the reduced form of @e0@
+ eb :: Blocked Elim <- do
+ case red of
+ Reduced b -> return $ e0 <$ b
+ NotReduced -> unfoldCorecursionE e0
+ let e = ignoreBlocking eb
+ -- replace the @n@th argument by its reduced form
+ es' = es0 ++ [MaybeRed red 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.
+ litFrame l stack =
+ 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@
+ -- we push @conFrame c vs@ onto the stack.
+ conFrame c 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)
) : stack
- -- If our argument is @Proj p@, we push @projFrame p@ onto the stack.
- projFrame p stack =
- case Map.lookup p (conBranches bs) of
- Nothing -> stack
- Just cc -> (content 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 vs@.
- patchCon c m es = patch (es0 ++ [Con c 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:
- case fmap ignoreSharing <$> eb of
- Blocked x _ -> noBlocked x es'
- NotBlocked (Apply (Arg info (MetaV x _))) -> noBlocked x es'
-
- -- In case of a literal, try also its constructor form
- 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
- _ -> 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
-
- -- In case of a projection, push the litFrame
- NotBlocked (Proj p) -> performedSimplification $
- match' $ projFrame p $ stack
-
- NotBlocked _ -> no es'
+ -- If our argument is @Proj p@, we push @projFrame p@ onto the stack.
+ projFrame p stack =
+ case Map.lookup p (conBranches bs) of
+ Nothing -> stack
+ Just cc -> (content 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 vs@.
+ patchCon c m es = patch (es0 ++ [Con c 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:
+ case fmap ignoreSharing <$> eb of
+ Blocked x _ -> no (Blocked x) es'
+ NotBlocked _ (Apply (Arg info (MetaV x _))) -> no (Blocked x) es'
+
+ -- In case of a literal, try also its constructor form
+ 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
+ _ -> 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
+
+ -- In case of a projection, push the litFrame
+ NotBlocked _ (Proj p) -> performedSimplification $
+ match' $ projFrame p $ stack
+
+ -- Otherwise, we are stuck. If we were stuck before,
+ -- we keep the old reason, otherwise we give reason StuckOn here.
+ NotBlocked blocked e -> no (NotBlocked $ stuckOn e blocked) es'
-- If we reach the empty stack, then pattern matching was incomplete
match' [] = do {- new line here since __IMPOSSIBLE__ does not like the ' in match' -}
@@ -193,7 +191,7 @@ match' [] = do {- new line here since __IMPOSSIBLE__ does not like the ' in mat
-- 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 e@(Proj f) = return $ notBlocked e
unfoldCorecursionE (Apply (Arg info v)) = fmap (Apply . Arg info) <$>
unfoldCorecursion v
diff --git a/src/full/Agda/TypeChecking/Constraints.hs b/src/full/Agda/TypeChecking/Constraints.hs
index 8c6f191..712f890 100644
--- a/src/full/Agda/TypeChecking/Constraints.hs
+++ b/src/full/Agda/TypeChecking/Constraints.hs
@@ -16,15 +16,15 @@ import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.LevelConstraints
-import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr, checkArguments')
+import {-# SOURCE #-} Agda.TypeChecking.Rules.Term
import {-# SOURCE #-} Agda.TypeChecking.Conversion
import {-# SOURCE #-} Agda.TypeChecking.MetaVars
import {-# SOURCE #-} Agda.TypeChecking.Empty
--- import {-# SOURCE #-} Agda.TypeChecking.UniversePolymorphism -- RETIRED
import Agda.Utils.Except ( MonadError(throwError) )
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Pretty (prettyShow)
#include "undefined.h"
import Agda.Utils.Impossible
@@ -173,7 +173,7 @@ solveConstraint_ (UnBlock m) =
case inst of
BlockedConst t -> do
reportSDoc "tc.constr.blocked" 15 $
- text ("blocked const " ++ show m ++ " :=") <+> prettyTCM t
+ text ("blocked const " ++ prettyShow m ++ " :=") <+> prettyTCM t
assignTerm m [] t
PostponedTypeCheckingProblem cl unblock -> enterClosure cl $ \prob -> do
ifNotM unblock (addConstraint $ UnBlock m) $ do
@@ -196,3 +196,4 @@ checkTypeCheckingProblem :: TypeCheckingProblem -> TCM Term
checkTypeCheckingProblem p = case p of
CheckExpr e t -> checkExpr e t
CheckArgs eh ei r args t0 t1 k -> checkArguments' eh ei r args t0 t1 k
+ CheckLambda args body target -> checkPostponedLambda args body target
diff --git a/src/full/Agda/TypeChecking/Conversion.hs b/src/full/Agda/TypeChecking/Conversion.hs
index 7955956..a831b90 100644
--- a/src/full/Agda/TypeChecking/Conversion.hs
+++ b/src/full/Agda/TypeChecking/Conversion.hs
@@ -1,7 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Conversion where
@@ -45,7 +44,7 @@ import Agda.TypeChecking.ProjectionLike (elimView)
import Agda.Interaction.Options
import Agda.Utils.Except ( MonadError(catchError, throwError) )
-import Agda.Utils.Functor (($>))
+import Agda.Utils.Functor
import Agda.Utils.Monad
import Agda.Utils.Maybe
import Agda.Utils.Size
@@ -59,11 +58,19 @@ mlevel :: TCM (Maybe Term)
mlevel = liftTCM $ (Just <$> primLevel) `catchError` \_ -> return Nothing
-}
--- | Try whether a computation runs without errors or new constraints.
+-- | Try whether a computation runs without errors or new constraints
+-- (may create new metas, though).
-- Restores state upon failure.
tryConversion :: TCM () -> TCM Bool
-tryConversion m = (noConstraints m $> True)
- `catchError` \ _ -> return False
+tryConversion = isJust <.> tryConversion'
+
+-- | Try whether a computation runs without errors or new constraints
+-- (may create new metas, though).
+-- 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
-- | Check if to lists of arguments are the same (and all variables).
-- Precondition: the lists have the same length.
@@ -168,7 +175,7 @@ compareTerm cmp a u v = do
]
ifM (isInstantiatedMeta x) patternViolation {-else-} $ do
assignE dir x es v $ compareTermDir dir a
- instantiate u
+ _ <- instantiate u
-- () <- seq u' $ return ()
reportSLn "tc.conv.term.shortcut" 50 $
"shortcut successful\n result: " ++ show u
@@ -249,17 +256,17 @@ compareTerm' cmp a m n =
-- isNeutral Blocked{} = False
isNeutral = isNeutral' . fmap ignoreSharing
isMeta = isMeta' . fmap ignoreSharing
- isNeutral' (NotBlocked Con{}) = return False
+ isNeutral' (NotBlocked _ Con{}) = return False
-- Andreas, 2013-09-18: this is expensive:
-- should only do this when copatterns are on
- isNeutral' (NotBlocked (Def q _)) = do
+ isNeutral' (NotBlocked r (Def q _)) = do -- Andreas, 2014-12-06 optimize this using r !!
d <- getConstInfo q
return $ case d of
Defn {theDef = Function {funCopatternLHS = True}} -> False -- a def by copattern can reduce if projected
_ -> True
- isNeutral' _ = return True
- isMeta' (NotBlocked MetaV{}) = True
- isMeta' _ = False
+ isNeutral' _ = return True
+ isMeta' (NotBlocked _ MetaV{}) = True
+ isMeta' _ = False
reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> text "is eta record type"
m <- reduceB m
@@ -398,7 +405,7 @@ compareAtom cmp t m n =
, text ":" <+> prettyTCM t ]
-- Andreas: what happens if I cut out the eta expansion here?
-- Answer: Triggers issue 245, does not resolve 348
- (mb',nb') <- ifM (asks envCompareBlocked) ((NotBlocked -*- NotBlocked) <$> reduce (m,n)) $ do
+ (mb',nb') <- ifM (asks envCompareBlocked) ((notBlocked -*- notBlocked) <$> reduce (m,n)) $ do
mb' <- etaExpandBlocked =<< reduceB m
nb' <- etaExpandBlocked =<< reduceB n
return (mb', nb')
@@ -439,7 +446,7 @@ compareAtom cmp t m n =
case (ignoreSharing <$> mb, ignoreSharing <$> nb) of
-- equate two metas x and y. if y is the younger meta,
-- try first y := x and then x := y
- (NotBlocked (MetaV x xArgs), NotBlocked (MetaV y yArgs))
+ (NotBlocked _ (MetaV x xArgs), NotBlocked _ (MetaV y yArgs))
| x == y ->
case intersectVars xArgs yArgs of
-- all relevant arguments are variables
@@ -473,8 +480,8 @@ compareAtom cmp t m n =
try solve1 solve2
-- one side a meta, the other an unblocked term
- (NotBlocked (MetaV x es), _) -> assign dir x es n
- (_, NotBlocked (MetaV x es)) -> assign rid x es m
+ (NotBlocked _ (MetaV x es), _) -> assign dir x es n
+ (_, NotBlocked _ (MetaV x es)) -> assign rid x es m
(Blocked{}, Blocked{}) -> checkSyntacticEquality
(Blocked{}, _) -> useInjectivity cmp t m n
(_,Blocked{}) -> useInjectivity cmp t m n
@@ -488,6 +495,7 @@ compareAtom cmp t m n =
case (ignoreSharing m, ignoreSharing n) of
(Pi{}, Pi{}) -> equalFun m n
+ (Sort s1, Sort Inf) -> return ()
(Sort s1, Sort s2) -> compareSort CmpEq s1 s2
(Lit l1, Lit l2) | l1 == l2 -> return ()
@@ -646,8 +654,8 @@ compareElims pols0 a v els01 els02 = catchConstraint (ElimCmp pols0 a v els01 el
(Proj{} : _, [] ) -> failure -- could be x.p =?= x for projection p
([] , Apply{} : _) -> failure -- not impossible, see issue 878
(Apply{} : _, [] ) -> failure
- (Apply{} : _, Proj{} : _) -> __IMPOSSIBLE__ -- NB: popped up in issue 889
- (Proj{} : _, Apply{} : _) -> __IMPOSSIBLE__ -- but should be impossible
+ (Apply{} : _, Proj{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- NB: popped up in issue 889
+ (Proj{} : _, Apply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- but should be impossible (but again in issue 1467)
(Apply arg1 : els1, Apply arg2 : els2) ->
verboseBracket "tc.conv.elim" 20 "compare Apply" $ do
reportSDoc "tc.conv.elim" 10 $ nest 2 $ vcat
@@ -683,7 +691,7 @@ compareElims pols0 a v els01 els02 = catchConstraint (ElimCmp pols0 a v els01 el
-- compare arg1 and arg2
pid <- newProblem_ $ applyRelevanceToContext r $
case r of
- Forced -> return ()
+ Forced{} -> return ()
r | irrelevantOrUnused r ->
compareIrrelevant b (unArg arg1) (unArg arg2)
_ -> compareWithPol pol (flip compareTerm b)
@@ -930,6 +938,10 @@ coerceSize v t1 t2 = workOnTypes $ do
let fallback = v <$ leqType t1 t2
caseMaybeM (isSizeType t1) fallback $ \ b1 -> do
caseMaybeM (isSizeType t2) fallback $ \ b2 -> do
+ -- Andreas, 2015-02-11 do not instantiate metas here (triggers issue 1203).
+ ifM (tryConversion $ dontAssignMetas $ leqType t1 t2) (return v) $ {- else -} do
+ -- A (most probably weaker) alternative is to just check syn.eq.
+ -- ifM (snd <$> checkSyntacticEquality t1 t2) (return v) $ {- else -} do
case b2 of
-- @t2 = Size@. We are done!
BoundedNo -> return v
@@ -963,32 +975,41 @@ compareSort CmpEq = equalSort
compareSort CmpLeq = leqSort
-- | Check that the first sort is less or equal to the second.
+--
+-- We can put @SizeUniv@ below @Inf@, but otherwise, it is
+-- unrelated to the other universes.
+--
leqSort :: Sort -> Sort -> TCM ()
-leqSort s1 s2 =
- ifM typeInType (return ()) $
- catchConstraint (SortCmp CmpLeq s1 s2) $
- do (s1,s2) <- reduce (s1,s2)
- let postpone = addConstraint (SortCmp CmpLeq s1 s2)
- reportSDoc "tc.conv.sort" 30 $
- sep [ text "leqSort"
- , nest 2 $ fsep [ prettyTCM s1 <+> text "=<"
- , prettyTCM s2 ]
- ]
- case (s1, s2) of
+leqSort s1 s2 = catchConstraint (SortCmp CmpLeq s1 s2) $ do
+ (s1,s2) <- reduce (s1,s2)
+ let postpone = addConstraint (SortCmp CmpLeq s1 s2)
+ no = typeError $ NotLeqSort s1 s2
+ yes = return ()
+ reportSDoc "tc.conv.sort" 30 $
+ sep [ text "leqSort"
+ , nest 2 $ fsep [ prettyTCM s1 <+> text "=<"
+ , prettyTCM s2 ]
+ ]
+ case (s1, s2) of
- (Type a, Type b) -> leqLevel a b
+ (_ , Inf ) -> yes
- (Prop , Prop ) -> return ()
- (Type _ , Prop ) -> notLeq s1 s2
+ (SizeUniv, _ ) -> equalSort s1 s2
+ (_ , SizeUniv) -> equalSort s1 s2
- (Prop , Type _ ) -> return ()
+ (Type a , Type b ) -> unlessM typeInType $ leqLevel a b
- (_ , Inf ) -> return ()
- (Inf , _ ) -> equalSort s1 s2
- (DLub{} , _ ) -> postpone
- (_ , DLub{} ) -> postpone
- where
- notLeq s1 s2 = typeError $ NotLeqSort s1 s2
+ (Prop , Prop ) -> yes
+ (Prop , Type _ ) -> yes
+ (Type _ , Prop ) -> no
+
+ -- (SizeUniv, SizeUniv) -> yes
+ -- (SizeUniv, _ ) -> no
+ -- (_ , SizeUniv) -> no
+
+ (Inf , _ ) -> unlessM typeInType $ equalSort s1 s2
+ (DLub{} , _ ) -> unlessM typeInType $ postpone
+ (_ , DLub{} ) -> unlessM typeInType $ postpone
leqLevel :: Level -> Level -> TCM ()
leqLevel a b = liftTCM $ do
@@ -1087,7 +1108,7 @@ leqLevel a b = liftTCM $ do
meta (Plus _ MetaLevel{}) = True
meta _ = False
- unneutral (Plus _ (NeutralLevel v)) = v
+ unneutral (Plus _ (NeutralLevel _ v)) = v
unneutral _ = __IMPOSSIBLE__
constant (ClosedLevel n) = n
@@ -1246,7 +1267,7 @@ equalLevel a b = do
hasMeta ClosedLevel{} = False
hasMeta (Plus _ MetaLevel{}) = True
hasMeta (Plus _ (BlockedLevel _ v)) = not $ null $ allMetas v
- hasMeta (Plus _ (NeutralLevel v)) = not $ null $ allMetas v
+ hasMeta (Plus _ (NeutralLevel _ v)) = not $ null $ allMetas v
hasMeta (Plus _ (UnreducedLevel v)) = not $ null $ allMetas v
isThisMeta x (Plus _ (MetaLevel y _)) = x == y
@@ -1263,53 +1284,81 @@ equalLevel a b = do
-- | Check that the first sort equal to the second.
equalSort :: Sort -> Sort -> TCM ()
-equalSort s1 s2 =
+equalSort s1 s2 = do
ifM typeInType (return ()) $
catchConstraint (SortCmp CmpEq s1 s2) $ do
(s1,s2) <- reduce (s1,s2)
let postpone = addConstraint (SortCmp CmpEq s1 s2)
- reportSDoc "tc.conv.sort" 30 $
- sep [ text "equalSort"
- , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> text "=="
- , prettyTCM s2 ]
- , nest 2 $ fsep [ text (show s1) <+> text "=="
- , text (show s2) ]
- ]
- ]
+ yes = return ()
+ no = typeError $ UnequalSorts s1 s2
+
+ -- Test whether a level is infinity.
+ isInf ClosedLevel{} = no
+ isInf (Plus _ l) = case l of
+ MetaLevel x es -> assignE DirEq x es (Sort Inf) $ equalAtom topSort
+ -- Andreas, 2015-02-14
+ -- This seems to be a hack, as a level meta is instantiated
+ -- by a sort.
+ NeutralLevel _ v -> case ignoreSharing v of
+ Sort Inf -> yes
+ _ -> no
+ _ -> no
+
+ -- Equate a level with SizeUniv.
+ eqSizeUniv l0 = case l0 of
+ Plus 0 l -> case l of
+ MetaLevel x es -> assignE DirEq x es (Sort SizeUniv) $ equalAtom topSort
+ NeutralLevel _ v -> case ignoreSharing v of
+ Sort SizeUniv -> yes
+ _ -> no
+ _ -> no
+ _ -> no
+
+ reportSDoc "tc.conv.sort" 30 $ sep
+ [ text "equalSort"
+ , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> text "=="
+ , prettyTCM s2 ]
+ , nest 2 $ fsep [ text (show s1) <+> text "=="
+ , text (show s2) ]
+ ]
+ ]
+
case (s1, s2) of
(Type a , Type b ) -> equalLevel a b
- (Prop , Prop ) -> return ()
- (Type _ , Prop ) -> notEq s1 s2
- (Prop , Type _ ) -> notEq s1 s2
+ (SizeUniv, SizeUniv) -> yes
+ (SizeUniv, Type (Max as@(_:_))) -> mapM_ eqSizeUniv as
+ (Type (Max as@(_:_)), SizeUniv) -> mapM_ eqSizeUniv as
+ (SizeUniv, _ ) -> no
+ (_ , SizeUniv) -> no
+
+ (Prop , Prop ) -> yes
+ (Type _ , Prop ) -> no
+ (Prop , Type _ ) -> no
- (Inf , Inf ) -> return ()
- (Inf , Type (Max as@(_:_))) -> mapM_ (isInf $ notEq s1 s2) as
- (Type (Max as@(_:_)), Inf) -> mapM_ (isInf $ notEq s1 s2) as
+ (Inf , Inf ) -> yes
+ (Inf , Type (Max as@(_:_))) -> mapM_ isInf as
+ (Type (Max as@(_:_)), Inf) -> mapM_ isInf as
-- Andreas, 2014-06-27:
-- @Type (Max [])@ (which is Set0) falls through to error.
- (Inf , _ ) -> notEq s1 s2
- (_ , Inf ) -> notEq s1 s2
+ (Inf , _ ) -> no
+ (_ , Inf ) -> no
-- Andreas, 2014-06-27: Why are there special cases for Set0?
- (DLub s1 s2, s0@(Type (Max []))) -> do
- equalSort s1 s0
- underAbstraction_ s2 $ \s2 -> equalSort s2 s0
- (s0@(Type (Max [])), DLub s1 s2) -> do
- equalSort s0 s1
- underAbstraction_ s2 $ \s2 -> equalSort s0 s2
+ -- Andreas, 2015-02-14: Probably because s ⊔ s' = Set0
+ -- entailed that both s and s' are Set0.
+ -- This is no longer true if SizeUniv ⊔ s = s
+
+ -- (DLub s1 s2, s0@(Type (Max []))) -> do
+ -- equalSort s1 s0
+ -- underAbstraction_ s2 $ \s2 -> equalSort s2 s0
+ -- (s0@(Type (Max [])), DLub s1 s2) -> do
+ -- equalSort s0 s1
+ -- underAbstraction_ s2 $ \s2 -> equalSort s0 s2
+
(DLub{} , _ ) -> postpone
(_ , DLub{} ) -> postpone
- where
- notEq s1 s2 = typeError $ UnequalSorts s1 s2
-
- isInf notok ClosedLevel{} = notok
- isInf notok (Plus _ l) = case l of
- MetaLevel x es -> assignE DirEq x es (Sort Inf) $ equalAtom topSort
- NeutralLevel (Shared p) -> isInf notok (Plus 0 $ NeutralLevel $ derefPtr p)
- NeutralLevel (Sort Inf) -> return ()
- _ -> notok
---------------------------------------------------------------------------
-- * Definitions
diff --git a/src/full/Agda/TypeChecking/Coverage.hs b/src/full/Agda/TypeChecking/Coverage.hs
index e71c431..f110bb8 100644
--- a/src/full/Agda/TypeChecking/Coverage.hs
+++ b/src/full/Agda/TypeChecking/Coverage.hs
@@ -1,9 +1,9 @@
{-# OPTIONS_GHC -fwarn-unused-imports #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
{-| Coverage checking, case splitting, and splitting for refine tactics.
@@ -18,19 +18,22 @@ module Agda.TypeChecking.Coverage
, splitResult
) where
+import Prelude hiding (null)
+
import Control.Monad
import Control.Monad.Trans ( lift )
+
+#if !MIN_VERSION_base(4,8,0)
import Control.Applicative hiding (empty)
+#endif
-import Data.List
-import qualified Data.Set as Set
+import Data.List hiding (null)
import Data.Set (Set)
+import qualified Data.Set as Set
import qualified Data.Traversable as Trav
-import Agda.Syntax.Position
import qualified Agda.Syntax.Common as Common
import Agda.Syntax.Common hiding (Arg,Dom)
-import qualified Agda.Syntax.Common as C
import Agda.Syntax.Internal as I
import Agda.Syntax.Internal.Pattern
@@ -42,7 +45,7 @@ import Agda.TypeChecking.Monad.Options
import Agda.TypeChecking.Monad.Exception
import Agda.TypeChecking.Monad.Context
-import Agda.TypeChecking.Rules.LHS.Problem (FlexibleVar(..),flexibleVarFromHiding)
+import Agda.TypeChecking.Rules.LHS.Problem (flexibleVarFromHiding)
import Agda.TypeChecking.Rules.LHS.Unify
import Agda.TypeChecking.Rules.LHS.Instantiate (instantiateTel)
import Agda.TypeChecking.Rules.LHS (instantiatePattern)
@@ -65,6 +68,7 @@ import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Tuple
@@ -150,14 +154,14 @@ coverageCheck f t cs = do
whenM (optCompletenessCheck <$> pragmaOptions) $
-- report an error if there are uncovered cases
unless (null pss) $
- setCurrentRange (getRange cs) $
+ setCurrentRange cs $
typeError $ CoverageFailure f (map (map $ fmap namedThing) 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 (getRange unreached) $
+ setCurrentRange unreached $
typeError $ UnreachableClauses f (map clausePats unreached)
return splitTree
@@ -209,7 +213,7 @@ cover f cs sc@(SClause tel perm ps _ target) = do
r <- altM1 (split Inductive sc) xs
case r of
Left err -> case err of
- CantSplit c tel us vs _ -> typeError $ CoverageCantSplitOn c tel us vs
+ CantSplit c tel us vs -> typeError $ CoverageCantSplitOn c tel us vs
NotADatatype a -> enterClosure a $ typeError . CoverageCantSplitType
IrrelevantDatatype a -> enterClosure a $ typeError . CoverageCantSplitIrrelevantType
CoinductiveDatatype a -> enterClosure a $ typeError . CoverageCantSplitType
@@ -286,6 +290,7 @@ fixTarget sc@SClause{ scTel = sctel, scPerm = perm, scPats = ps, scSubst = sigma
[ text "split clause telescope: " <+> prettyTCM sctel
, text "old permutation : " <+> prettyTCM perm
, text "old patterns : " <+> sep (map (prettyTCM . namedArg) ps)
+ , text "substitution : " <+> text (show sigma)
]
reportSDoc "tc.cover.target" 30 $ sep
[ text "target type before substitution (variables may be wrong): " <+> do
@@ -314,6 +319,23 @@ fixTarget sc@SClause{ scTel = sctel, scPerm = perm, scPats = ps, scSubst = sigma
, scSubst = liftS n $ sigma
, scTarget = newTarget
}
+ -- Separate debug printing to find cause of crash (Issue 1374)
+ reportSDoc "tc.cover.target" 30 $ sep
+ [ text "new split clause telescope : " <+> prettyTCM sctel'
+ ]
+ reportSDoc "tc.cover.target" 30 $ sep
+ [ text "new split clause permutation : " <+> prettyTCM perm'
+ ]
+ reportSDoc "tc.cover.target" 30 $ sep
+ [ text "new split clause patterns : " <+> sep (map (prettyTCM . namedArg) ps')
+ ]
+ reportSDoc "tc.cover.target" 30 $ sep
+ [ text "new split clause substitution: " <+> text (show $ scSubst sc')
+ ]
+ reportSDoc "tc.cover.target" 30 $ sep
+ [ text "new split clause target : " <+> do
+ addContext sctel' $ prettyTCM $ fromJust newTarget
+ ]
reportSDoc "tc.cover.target" 20 $ sep
[ text "new split clause"
, prettyTCM sc'
@@ -395,14 +417,12 @@ computeNeighbourhood delta1 n delta2 perm d pars ixs hix hps c = do
unifyIndices flex (raise (size gamma) dtype) conIxs givenIxs
case r of
- NoUnify _ _ _ -> do
- debugNoUnify
- return Nothing
- DontKnow _ -> do
+ NoUnify {} -> debugNoUnify $> Nothing
+
+ DontKnow{} -> do
debugCantSplit
throwException $ CantSplit (conName con) (delta1 `abstract` gamma) conIxs givenIxs
- (map (var . flexVar) flex)
- Unifies sub -> do
+ Unifies sub -> do
debugSubst "sub" sub
-- Substitute the constructor for x in Δ₂: Δ₂' = Δ₂[conv/x]
@@ -411,14 +431,16 @@ computeNeighbourhood delta1 n delta2 perm d pars ixs hix hps c = do
debugTel "delta2'" delta2'
-- Compute a substitution ρ : Δ₁ΓΔ₂' → Δ₁(x:D)Δ₂'
- let rho = liftS (size delta2') $ conv :# raiseS (size gamma)
+ let rho = liftS (size delta2') $ consS conv $ raiseS (size gamma)
-- [ Var i [] | i <- [0..size delta2' - 1] ]
-- ++ [ raise (size delta2') conv ]
-- ++ [ Var i [] | i <- [size delta2' + size gamma ..] ]
-- Plug the hole with the constructor and apply ρ
- -- TODO: Is it really correct to use Nothing here?
- let conp = ConP con Nothing $ map (fmap namedVarP) $ teleArgNames gamma
+ -- 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 $ map (fmap namedVarP) $ teleArgNames gamma
ps = plugHole conp hps
ps' = applySubst rho ps -- Δ₁ΓΔ₂' ⊢ ps'
debugPlugged ps ps'
@@ -585,8 +607,8 @@ split' ind sc@(SClause tel perm ps _ target) (BlockingVar x mcons) = liftTCM $ r
-- Split the telescope at the variable
-- t = type of the variable, Δ₁ ⊢ t
(n, t, delta1, delta2) <- do
- let (tel1, C.Dom info (n, t) : tel2) = genericSplitAt (size tel - x - 1) $ telToList tel
- return (n, C.Dom info t, telFromList tel1, telFromList tel2)
+ let (tel1, Common.Dom info (n, t) : tel2) = genericSplitAt (size tel - x - 1) $ telToList tel
+ return (n, Common.Dom info t, telFromList tel1, telFromList tel2)
-- Compute the one hole context of the patterns at the variable
(hps, hix) <- do
@@ -741,8 +763,9 @@ instance PrettyTCM SplitClause where
, text "target = " <+> do
caseMaybe target empty $ \ t -> do
addContext tel $ prettyTCM t
- , text "subst target = " <+> do
- caseMaybe target empty $ \ t -> do
- addContext tel $ prettyTCM $ applySubst sigma t
+ -- Triggers crash (see Issue 1374).
+ -- , text "subst target = " <+> do
+ -- caseMaybe target empty $ \ t -> do
+ -- addContext tel $ prettyTCM $ applySubst sigma t
]
]
diff --git a/src/full/Agda/TypeChecking/Coverage/Match.hs b/src/full/Agda/TypeChecking/Coverage/Match.hs
index d67b442..b9eb19c 100644
--- a/src/full/Agda/TypeChecking/Coverage/Match.hs
+++ b/src/full/Agda/TypeChecking/Coverage/Match.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE PatternGuards #-}
+-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460.
+{-# LANGUAGE CPP,
+ DeriveFunctor,
+ PatternGuards #-}
module Agda.TypeChecking.Coverage.Match where
@@ -38,10 +39,6 @@ instances (via substitutions @rhos@) of the split clause.
In these substitutions, we look for a column that has only constructor patterns.
We try to split on this column first.
-}
-{-
-nonOverlappingCompleteMatches :: [Clause] -> [Arg Pattern] -> Permutation -> Match Nat
-nonOverlappingCompleteMatches cs ps perm
--}
-- | Match the given patterns against a list of clauses
match :: [Clause] -> [Arg Pattern] -> Permutation -> Match Nat
diff --git a/src/full/Agda/TypeChecking/DisplayForm.hs b/src/full/Agda/TypeChecking/DisplayForm.hs
index a61e820..db9ea1d 100644
--- a/src/full/Agda/TypeChecking/DisplayForm.hs
+++ b/src/full/Agda/TypeChecking/DisplayForm.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- | Tools for 'DisplayTerm' and 'DisplayForm'.
module Agda.TypeChecking.DisplayForm where
@@ -23,6 +24,15 @@ import Agda.Utils.Maybe
#include "undefined.h"
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
+ DDef f es -> Def f $ map (fmap dtermToTerm) es
+ DDot v -> v
+ DTerm v -> v
+
-- | Find a matching display form for @q vs@.
-- In essence this tries to reqwrite @q vs@ with any
-- display form @q ps --> dt@ and returns the instantiated
diff --git a/src/full/Agda/TypeChecking/DropArgs.hs b/src/full/Agda/TypeChecking/DropArgs.hs
index b855f8c..2b2681a 100644
--- a/src/full/Agda/TypeChecking/DropArgs.hs
+++ b/src/full/Agda/TypeChecking/DropArgs.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
module Agda.TypeChecking.DropArgs where
diff --git a/src/full/Agda/TypeChecking/Empty.hs b/src/full/Agda/TypeChecking/Empty.hs
index e424a3a..1aaf402 100644
--- a/src/full/Agda/TypeChecking/Empty.hs
+++ b/src/full/Agda/TypeChecking/Empty.hs
@@ -1,4 +1,3 @@
--- {-# LANGUAGE CPP #-}
module Agda.TypeChecking.Empty where
@@ -15,39 +14,26 @@ import Agda.TypeChecking.Constraints
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
-{- UNUSED
--- | Make sure that a type is empty.
-isReallyEmptyType :: Range -> Type -> TCM ()
-isReallyEmptyType r t = noConstraints $ isEmptyType r t
--}
+-- | Check whether a type is empty.
+-- This check may be postponed as emptiness constraint.
--- | Check whether a type is empty. Maybe postponed as emptyness constraint.
isEmptyType :: Range -> Type -> TCM ()
isEmptyType r t = do
- tb <- reduceB t
- let t = ignoreBlocking tb
- postpone = addConstraint (IsEmpty r t)
- case ignoreSharing . unEl <$> tb of
- -- if t is blocked or a meta, we cannot decide emptyness now. postpone
- NotBlocked MetaV{} -> postpone
- Blocked{} -> postpone
- _ -> do
+ let postpone t = addConstraint $ IsEmpty r t
+ -- If t is blocked or a meta, we cannot decide emptiness now. Postpone.
+ ifBlockedType t (\ _ t -> postpone t) $ {- else -} \ t -> do
-- from the current context xs:ts, create a pattern list
-- xs _ : ts t and try to split on _ (the last variable)
- tel0 <- getContextTelescope
- let gamma = telToList tel0 ++ [domFromArg $ defaultArg (underscore, t)]
- ps = [ Arg info $ namedVarP x | Dom info (x, _) <- gamma ]
- tel = telFromList gamma
+ tel0 <- getContextTelescope
+ let gamma = telToList tel0 ++ [domFromArg $ defaultArg (underscore, t)]
+ ps = [ Arg info $ namedVarP x | Dom info (x, _) <- gamma ]
+ tel = telFromList gamma
- dontAssignMetas $ do
+ dontAssignMetas $ do
r <- splitLast Inductive tel ps
-
case r of
- Left err -> case err of
- CantSplit c tel us vs _ -> postpone
- -- Andreas, 2012-03-15: allow postponement of emptyness check
- -- OLD CODE: traceCall (CheckIsEmpty t) $ typeError $ CoverageCantSplitOn c tel us vs
- _ -> typeError $ ShouldBeEmpty t []
+ Left (CantSplit c tel us vs) -> postpone t
+ Left _ -> typeError $ ShouldBeEmpty t []
Right cov -> do
let cs = splitClauses cov
unless (null cs) $
diff --git a/src/full/Agda/TypeChecking/Errors.hs b/src/full/Agda/TypeChecking/Errors.hs
index cdff5ff..d689839 100644
--- a/src/full/Agda/TypeChecking/Errors.hs
+++ b/src/full/Agda/TypeChecking/Errors.hs
@@ -1,15 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Errors
- ( prettyError
- , PrettyTCM(..)
- , tcErrString
- , Warnings(..)
- , warningsToError
- ) where
+ ( prettyError
+ , tcErrString
+ , Warnings(..)
+ , warningsToError
+ ) where
import Prelude hiding (null)
@@ -18,7 +16,6 @@ import Control.Monad.State
import Data.Function
import Data.List (nub, sortBy, intercalate)
import Data.Maybe
-import qualified Data.Map as Map (empty)
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)
import qualified Agda.Syntax.Common as Common
@@ -29,7 +26,7 @@ import qualified Agda.Syntax.Concrete as C
import qualified Agda.Syntax.Concrete.Definitions as D
import Agda.Syntax.Abstract as A
import Agda.Syntax.Internal as I
-import qualified Agda.Syntax.Abstract.Pretty as P
+import qualified Agda.Syntax.Abstract.Pretty as AP
import Agda.Syntax.Translation.InternalToAbstract
import Agda.Syntax.Translation.AbstractToConcrete
import Agda.Syntax.Scope.Monad (isDatatypeModule)
@@ -44,7 +41,8 @@ import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.FileName
import Agda.Utils.Function
import Agda.Utils.Monad
-import Agda.Utils.Null hiding (empty)
+import Agda.Utils.Null
+import Agda.Utils.Size
import qualified Agda.Utils.Pretty as P
#include "undefined.h"
@@ -67,6 +65,7 @@ prettyError err = liftTCM $ show <$> prettyError' err []
| otherwise = applyUnless (null errs) (text "panic: error when printing error!" $$) $ do
(prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs))
`catchError` \ err' -> prettyError' err' (err:errs)
+
---------------------------------------------------------------------------
-- * Warnings
---------------------------------------------------------------------------
@@ -90,7 +89,6 @@ warningsToError (Warnings [] []) = typeError $ SolvedButOpenHoles
warningsToError (Warnings w@(_:_) _) = typeError $ UnsolvedMetas w
warningsToError (Warnings _ w@(_:_)) = typeError $ UnsolvedConstraints w
-
---------------------------------------------------------------------------
-- * Helpers
---------------------------------------------------------------------------
@@ -114,743 +112,913 @@ nameWithBinding q =
tcErrString :: TCErr -> String
tcErrString err = show (getRange err) ++ " " ++ case err of
- TypeError _ cl -> errorString $ clValue cl
- Exception r s -> show r ++ " " ++ s
- IOException r e -> show r ++ " " ++ show e
- PatternErr{} -> "PatternErr"
- {- AbortAssign _ -> "AbortAssign" -- UNUSED -}
+ TypeError _ cl -> errorString $ clValue cl
+ 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
- AmbiguousModule{} -> "AmbiguousModule"
- AmbiguousName{} -> "AmbiguousName"
- AmbiguousParseForApplication{} -> "AmbiguousParseForApplication"
- AmbiguousParseForLHS{} -> "AmbiguousParseForLHS"
--- AmbiguousParseForPatternSynonym{} -> "AmbiguousParseForPatternSynonym"
- AmbiguousTopLevelModuleName {} -> "AmbiguousTopLevelModuleName"
- BadArgumentsToPatternSynonym{} -> "BadArgumentsToPatternSynonym"
- TooFewArgumentsToPatternSynonym{} -> "TooFewArgumentsToPatternSynonym"
- BothWithAndRHS -> "BothWithAndRHS"
- BuiltinInParameterisedModule{} -> "BuiltinInParameterisedModule"
- BuiltinMustBeConstructor{} -> "BuiltinMustBeConstructor"
- ClashingDefinition{} -> "ClashingDefinition"
- ClashingFileNamesFor{} -> "ClashingFileNamesFor"
- ClashingImport{} -> "ClashingImport"
- ClashingModule{} -> "ClashingModule"
- ClashingModuleImport{} -> "ClashingModuleImport"
- CompilationError{} -> "CompilationError"
- ConstructorPatternInWrongDatatype{} -> "ConstructorPatternInWrongDatatype"
- CoverageFailure{} -> "CoverageFailure"
- CoverageCantSplitOn{} -> "CoverageCantSplitOn"
- CoverageCantSplitIrrelevantType{} -> "CoverageCantSplitIrrelevantType"
- CoverageCantSplitType{} -> "CoverageCantSplitType"
- CyclicModuleDependency{} -> "CyclicModuleDependency"
- DataMustEndInSort{} -> "DataMustEndInSort"
+ AmbiguousModule{} -> "AmbiguousModule"
+ AmbiguousName{} -> "AmbiguousName"
+ AmbiguousParseForApplication{} -> "AmbiguousParseForApplication"
+ AmbiguousParseForLHS{} -> "AmbiguousParseForLHS"
+-- AmbiguousParseForPatternSynonym{} -> "AmbiguousParseForPatternSynonym"
+ AmbiguousTopLevelModuleName {} -> "AmbiguousTopLevelModuleName"
+ BadArgumentsToPatternSynonym{} -> "BadArgumentsToPatternSynonym"
+ TooFewArgumentsToPatternSynonym{} -> "TooFewArgumentsToPatternSynonym"
+ BothWithAndRHS -> "BothWithAndRHS"
+ BuiltinInParameterisedModule{} -> "BuiltinInParameterisedModule"
+ BuiltinMustBeConstructor{} -> "BuiltinMustBeConstructor"
+ ClashingDefinition{} -> "ClashingDefinition"
+ ClashingFileNamesFor{} -> "ClashingFileNamesFor"
+ ClashingImport{} -> "ClashingImport"
+ ClashingModule{} -> "ClashingModule"
+ ClashingModuleImport{} -> "ClashingModuleImport"
+ CompilationError{} -> "CompilationError"
+ ConstructorPatternInWrongDatatype{} -> "ConstructorPatternInWrongDatatype"
+ CoverageFailure{} -> "CoverageFailure"
+ CoverageCantSplitOn{} -> "CoverageCantSplitOn"
+ CoverageCantSplitIrrelevantType{} -> "CoverageCantSplitIrrelevantType"
+ CoverageCantSplitType{} -> "CoverageCantSplitType"
+ CyclicModuleDependency{} -> "CyclicModuleDependency"
+ DataMustEndInSort{} -> "DataMustEndInSort"
-- UNUSED: DataTooManyParameters{} -> "DataTooManyParameters"
- CantResolveOverloadedConstructorsTargetingSameDatatype{} -> "CantResolveOverloadedConstructorsTargetingSameDatatype"
- DifferentArities -> "DifferentArities"
- DoesNotConstructAnElementOf{} -> "DoesNotConstructAnElementOf"
- DuplicateBuiltinBinding{} -> "DuplicateBuiltinBinding"
- DuplicateConstructors{} -> "DuplicateConstructors"
- DuplicateFields{} -> "DuplicateFields"
- DuplicateImports{} -> "DuplicateImports"
- FieldOutsideRecord -> "FieldOutsideRecord"
- FileNotFound{} -> "FileNotFound"
- GenericError{} -> "GenericError"
- GenericDocError{} -> "GenericDocError"
- IFSNoCandidateInScope{} -> "IFSNoCandidateInScope"
- IlltypedPattern{} -> "IlltypedPattern"
- IllformedProjectionPattern{} -> "IllformedProjectionPattern"
- CannotEliminateWithPattern{} -> "CannotEliminateWithPattern"
- IllegalLetInTelescope{} -> "IllegalLetInTelescope"
- IncompletePatternMatching{} -> "IncompletePatternMatching"
- IndexVariablesNotDistinct{} -> "IndexVariablesNotDistinct"
- IndicesFreeInParameters{} -> "IndicesFreeInParameters"
- IndicesNotConstructorApplications{} -> "IndicesNotConstructorApplications"
- InternalError{} -> "InternalError"
- InvalidPattern{} -> "InvalidPattern"
- LocalVsImportedModuleClash{} -> "LocalVsImportedModuleClash"
- MetaCannotDependOn{} -> "MetaCannotDependOn"
- MetaOccursInItself{} -> "MetaOccursInItself"
- ModuleArityMismatch{} -> "ModuleArityMismatch"
- ModuleDefinedInOtherFile {} -> "ModuleDefinedInOtherFile"
- ModuleDoesntExport{} -> "ModuleDoesntExport"
- ModuleNameDoesntMatchFileName {} -> "ModuleNameDoesntMatchFileName"
- NeedOptionCopatterns{} -> "NeedOptionCopatterns"
- NoBindingForBuiltin{} -> "NoBindingForBuiltin"
- NoParseForApplication{} -> "NoParseForApplication"
- NoParseForLHS{} -> "NoParseForLHS"
--- NoParseForPatternSynonym{} -> "NoParseForPatternSynonym"
- NoRHSRequiresAbsurdPattern{} -> "NoRHSRequiresAbsurdPattern"
- NotInductive {} -> "NotInductive"
- AbsurdPatternRequiresNoRHS{} -> "AbsurdPatternRequiresNoRHS"
- NoSuchBuiltinName{} -> "NoSuchBuiltinName"
- NoSuchModule{} -> "NoSuchModule"
- NoSuchPrimitiveFunction{} -> "NoSuchPrimitiveFunction"
- NotAModuleExpr{} -> "NotAModuleExpr"
- NotAProperTerm -> "NotAProperTerm"
- SetOmegaNotValidType{} -> "SetOmegaNotValidType"
- InvalidType{} -> "InvalidType"
- NotAValidLetBinding{} -> "NotAValidLetBinding"
- NotAnExpression{} -> "NotAnExpression"
- NotImplemented{} -> "NotImplemented"
- NotSupported{} -> "NotSupported"
- NotInScope{} -> "NotInScope"
- NotLeqSort{} -> "NotLeqSort"
- NotStrictlyPositive{} -> "NotStrictlyPositive"
- NothingAppliedToHiddenArg{} -> "NothingAppliedToHiddenArg"
- NothingAppliedToInstanceArg{} -> "NothingAppliedToInstanceArg"
- OverlappingProjects {} -> "OverlappingProjects"
- PatternShadowsConstructor {} -> "PatternShadowsConstructor"
- PropMustBeSingleton -> "PropMustBeSingleton"
- RepeatedVariablesInPattern{} -> "RepeatedVariablesInPattern"
- SafeFlagPostulate{} -> "SafeFlagPostulate"
- SafeFlagPragma{} -> "SafeFlagPragma"
- SafeFlagNoTerminationCheck{} -> "SafeFlagNoTerminationCheck"
- SafeFlagNonTerminating{} -> "SafeFlagNonTerminating"
- SafeFlagTerminating{} -> "SafeFlagTerminating"
- SafeFlagPrimTrustMe{} -> "SafeFlagPrimTrustMe"
- ShadowedModule{} -> "ShadowedModule"
- ShouldBeASort{} -> "ShouldBeASort"
- ShouldBeApplicationOf{} -> "ShouldBeApplicationOf"
- ShouldBeAppliedToTheDatatypeParameters{} -> "ShouldBeAppliedToTheDatatypeParameters"
- ShouldBeEmpty{} -> "ShouldBeEmpty"
- ShouldBePi{} -> "ShouldBePi"
- ShouldBeRecordType{} -> "ShouldBeRecordType"
- ShouldBeRecordPattern{} -> "ShouldBeRecordPattern"
- NotAProjectionPattern{} -> "NotAProjectionPattern"
- ShouldEndInApplicationOfTheDatatype{} -> "ShouldEndInApplicationOfTheDatatype"
- SplitError{} -> "SplitError"
- TerminationCheckFailed{} -> "TerminationCheckFailed"
- TooFewFields{} -> "TooFewFields"
- TooManyArgumentsInLHS{} -> "TooManyArgumentsInLHS"
- TooManyFields{} -> "TooManyFields"
- SplitOnIrrelevant{} -> "SplitOnIrrelevant"
- DefinitionIsIrrelevant{} -> "DefinitionIsIrrelevant"
- VariableIsIrrelevant{} -> "VariableIsIrrelevant"
- UnequalBecauseOfUniverseConflict{} -> "UnequalBecauseOfUniverseConflict"
- UnequalRelevance{} -> "UnequalRelevance"
- UnequalHiding{} -> "UnequalHiding"
--- UnequalLevel{} -> "UnequalLevel" -- UNUSED
- UnequalSorts{} -> "UnequalSorts"
- UnequalTerms{} -> "UnequalTerms"
- UnequalTypes{} -> "UnequalTypes"
--- UnequalTelescopes{} -> "UnequalTelescopes" -- UNUSED
- UnequalColors{} -> "UnequalTelescopes"
- HeterogeneousEquality{} -> "HeterogeneousEquality"
- WithOnFreeVariable{} -> "WithOnFreeVariable"
- UnexpectedWithPatterns{} -> "UnexpectedWithPatterns"
- UninstantiatedDotPattern{} -> "UninstantiatedDotPattern"
- UninstantiatedModule{} -> "UninstantiatedModule"
- UnreachableClauses{} -> "UnreachableClauses"
- UnsolvedConstraints{} -> "UnsolvedConstraints"
- UnsolvedMetas{} -> "UnsolvedMetas"
- SolvedButOpenHoles{} -> "SolvedButOpenHoles"
- UnusedVariableInPatternSynonym -> "UnusedVariableInPatternSynonym"
- UnquoteFailed{} -> "UnquoteFailed"
- WithClausePatternMismatch{} -> "WithClausePatternMismatch"
- WithoutKError{} -> "WithoutKError"
- WrongHidingInApplication{} -> "WrongHidingInApplication"
- WrongHidingInLHS{} -> "WrongHidingInLHS"
- WrongHidingInLambda{} -> "WrongHidingInLambda"
- WrongIrrelevanceInLambda{} -> "WrongIrrelevanceInLambda"
- WrongNamedArgument{} -> "WrongNamedArgument"
- WrongNumberOfConstructorArguments{} -> "WrongNumberOfConstructorArguments"
- HidingMismatch{} -> "HidingMismatch"
- RelevanceMismatch{} -> "RelevanceMismatch"
- ColorMismatch{} -> "ColorMismatch"
+ CantResolveOverloadedConstructorsTargetingSameDatatype{} -> "CantResolveOverloadedConstructorsTargetingSameDatatype"
+ DifferentArities -> "DifferentArities"
+ DoesNotConstructAnElementOf{} -> "DoesNotConstructAnElementOf"
+ DuplicateBuiltinBinding{} -> "DuplicateBuiltinBinding"
+ DuplicateConstructors{} -> "DuplicateConstructors"
+ DuplicateFields{} -> "DuplicateFields"
+ DuplicateImports{} -> "DuplicateImports"
+ FieldOutsideRecord -> "FieldOutsideRecord"
+ FileNotFound{} -> "FileNotFound"
+ GenericError{} -> "GenericError"
+ GenericDocError{} -> "GenericDocError"
+ IFSNoCandidateInScope{} -> "IFSNoCandidateInScope"
+ IlltypedPattern{} -> "IlltypedPattern"
+ IllformedProjectionPattern{} -> "IllformedProjectionPattern"
+ CannotEliminateWithPattern{} -> "CannotEliminateWithPattern"
+ IllegalLetInTelescope{} -> "IllegalLetInTelescope"
+ IncompletePatternMatching{} -> "IncompletePatternMatching"
+ IndexVariablesNotDistinct{} -> "IndexVariablesNotDistinct"
+ IndicesFreeInParameters{} -> "IndicesFreeInParameters"
+ IndicesNotConstructorApplications{} -> "IndicesNotConstructorApplications"
+ InternalError{} -> "InternalError"
+ InvalidPattern{} -> "InvalidPattern"
+ LocalVsImportedModuleClash{} -> "LocalVsImportedModuleClash"
+ MetaCannotDependOn{} -> "MetaCannotDependOn"
+ MetaOccursInItself{} -> "MetaOccursInItself"
+ ModuleArityMismatch{} -> "ModuleArityMismatch"
+ ModuleDefinedInOtherFile {} -> "ModuleDefinedInOtherFile"
+ ModuleDoesntExport{} -> "ModuleDoesntExport"
+ ModuleNameDoesntMatchFileName {} -> "ModuleNameDoesntMatchFileName"
+ NeedOptionCopatterns{} -> "NeedOptionCopatterns"
+ NoBindingForBuiltin{} -> "NoBindingForBuiltin"
+ NoParseForApplication{} -> "NoParseForApplication"
+ NoParseForLHS{} -> "NoParseForLHS"
+-- NoParseForPatternSynonym{} -> "NoParseForPatternSynonym"
+ NoRHSRequiresAbsurdPattern{} -> "NoRHSRequiresAbsurdPattern"
+ NotInductive {} -> "NotInductive"
+ AbsurdPatternRequiresNoRHS{} -> "AbsurdPatternRequiresNoRHS"
+ NoSuchBuiltinName{} -> "NoSuchBuiltinName"
+ NoSuchModule{} -> "NoSuchModule"
+ NoSuchPrimitiveFunction{} -> "NoSuchPrimitiveFunction"
+ NotAModuleExpr{} -> "NotAModuleExpr"
+ NotAProperTerm -> "NotAProperTerm"
+ SetOmegaNotValidType{} -> "SetOmegaNotValidType"
+ InvalidType{} -> "InvalidType"
+ InvalidTypeSort{} -> "InvalidTypeSort"
+ FunctionTypeInSizeUniv{} -> "FunctionTypeInSizeUniv"
+ NotAValidLetBinding{} -> "NotAValidLetBinding"
+ NotAnExpression{} -> "NotAnExpression"
+ NotImplemented{} -> "NotImplemented"
+ NotSupported{} -> "NotSupported"
+ NotInScope{} -> "NotInScope"
+ NotLeqSort{} -> "NotLeqSort"
+ NotStrictlyPositive{} -> "NotStrictlyPositive"
+ NothingAppliedToHiddenArg{} -> "NothingAppliedToHiddenArg"
+ NothingAppliedToInstanceArg{} -> "NothingAppliedToInstanceArg"
+ OverlappingProjects {} -> "OverlappingProjects"
+ PatternShadowsConstructor {} -> "PatternShadowsConstructor"
+ PropMustBeSingleton -> "PropMustBeSingleton"
+ RepeatedVariablesInPattern{} -> "RepeatedVariablesInPattern"
+ SafeFlagPostulate{} -> "SafeFlagPostulate"
+ SafeFlagPragma{} -> "SafeFlagPragma"
+ SafeFlagNoTerminationCheck{} -> "SafeFlagNoTerminationCheck"
+ SafeFlagNonTerminating{} -> "SafeFlagNonTerminating"
+ SafeFlagTerminating{} -> "SafeFlagTerminating"
+ SafeFlagPrimTrustMe{} -> "SafeFlagPrimTrustMe"
+ ShadowedModule{} -> "ShadowedModule"
+ ShouldBeASort{} -> "ShouldBeASort"
+ ShouldBeApplicationOf{} -> "ShouldBeApplicationOf"
+ ShouldBeAppliedToTheDatatypeParameters{} -> "ShouldBeAppliedToTheDatatypeParameters"
+ ShouldBeEmpty{} -> "ShouldBeEmpty"
+ ShouldBePi{} -> "ShouldBePi"
+ ShouldBeRecordType{} -> "ShouldBeRecordType"
+ ShouldBeRecordPattern{} -> "ShouldBeRecordPattern"
+ NotAProjectionPattern{} -> "NotAProjectionPattern"
+ ShouldEndInApplicationOfTheDatatype{} -> "ShouldEndInApplicationOfTheDatatype"
+ SplitError{} -> "SplitError"
+ TerminationCheckFailed{} -> "TerminationCheckFailed"
+ TooFewFields{} -> "TooFewFields"
+ TooManyArgumentsInLHS{} -> "TooManyArgumentsInLHS"
+ TooManyFields{} -> "TooManyFields"
+ SplitOnIrrelevant{} -> "SplitOnIrrelevant"
+ DefinitionIsIrrelevant{} -> "DefinitionIsIrrelevant"
+ VariableIsIrrelevant{} -> "VariableIsIrrelevant"
+ UnequalBecauseOfUniverseConflict{} -> "UnequalBecauseOfUniverseConflict"
+ UnequalRelevance{} -> "UnequalRelevance"
+ UnequalHiding{} -> "UnequalHiding"
+-- UnequalLevel{} -> "UnequalLevel" -- UNUSED
+ UnequalSorts{} -> "UnequalSorts"
+ UnequalTerms{} -> "UnequalTerms"
+ UnequalTypes{} -> "UnequalTypes"
+-- UnequalTelescopes{} -> "UnequalTelescopes" -- UNUSED
+ UnequalColors{} -> "UnequalTelescopes"
+ HeterogeneousEquality{} -> "HeterogeneousEquality"
+ WithOnFreeVariable{} -> "WithOnFreeVariable"
+ UnexpectedWithPatterns{} -> "UnexpectedWithPatterns"
+ UninstantiatedDotPattern{} -> "UninstantiatedDotPattern"
+ UninstantiatedModule{} -> "UninstantiatedModule"
+ UnreachableClauses{} -> "UnreachableClauses"
+ UnsolvedConstraints{} -> "UnsolvedConstraints"
+ UnsolvedMetas{} -> "UnsolvedMetas"
+ SolvedButOpenHoles{} -> "SolvedButOpenHoles"
+ UnusedVariableInPatternSynonym -> "UnusedVariableInPatternSynonym"
+ UnquoteFailed{} -> "UnquoteFailed"
+ WithClausePatternMismatch{} -> "WithClausePatternMismatch"
+ WithoutKError{} -> "WithoutKError"
+ WrongHidingInApplication{} -> "WrongHidingInApplication"
+ WrongHidingInLHS{} -> "WrongHidingInLHS"
+ WrongHidingInLambda{} -> "WrongHidingInLambda"
+ WrongIrrelevanceInLambda{} -> "WrongIrrelevanceInLambda"
+ WrongNamedArgument{} -> "WrongNamedArgument"
+ WrongNumberOfConstructorArguments{} -> "WrongNumberOfConstructorArguments"
+ HidingMismatch{} -> "HidingMismatch"
+ RelevanceMismatch{} -> "RelevanceMismatch"
+ ColorMismatch{} -> "ColorMismatch"
instance PrettyTCM TCErr where
- prettyTCM err = case err of
- -- Andreas, 2014-03-23
- -- This use of localState seems ok since we do not collect
- -- Benchmark info during printing errors.
- TypeError s e -> localState $ do
- put s
- sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e
- Exception r s -> sayWhere r $ fwords s
- IOException r e -> sayWhere r $ fwords $ show e
- PatternErr{} -> sayWhere err $ panic "uncaught pattern violation"
- {- AbortAssign _ -> sayWhere err $ panic "uncaught aborted assignment" -- UNUSED -}
+ prettyTCM err = case err of
+ -- Andreas, 2014-03-23
+ -- This use of localState seems ok since we do not collect
+ -- Benchmark info during printing errors.
+ TypeError s e -> localState $ do
+ put s
+ sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e
+ 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
let call = prettyTCM $ callInfoCall c
r = callInfoRange c
- case show r of
- "" -> call
- _ -> call $$ nest 2 (text "(at" <+> prettyTCM r <> text ")")
+ if null $ P.pretty r
+ then call
+ else call $$ nest 2 (text "(at" <+> prettyTCM r <> text ")")
--- | Drops the filename component of the qualified name
+-- | Drops the filename component of the qualified name.
dropTopLevelModule :: QName -> QName
dropTopLevelModule (QName (MName ns) n) = QName (MName (drop 1 ns)) n
instance PrettyTCM TypeError where
- prettyTCM err = do
- case err of
- InternalError s -> panic s
- NotImplemented s -> fwords $ "Not implemented: " ++ s
- NotSupported s -> fwords $ "Not supported: " ++ s
- CompilationError s -> sep [fwords "Compilation error:", text s]
- GenericError s -> fwords s
- GenericDocError d -> return d
- TerminationCheckFailed because ->
- 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)
- PropMustBeSingleton -> fwords
- "Datatypes in Prop must have at most one constructor when proof irrelevance is enabled"
- DataMustEndInSort t -> fsep $
- pwords "The type of a datatype must end in a sort."
- ++ [prettyTCM t] ++ pwords "isn't a sort."
+ prettyTCM err = case err of
+ InternalError s -> panic s
+
+ NotImplemented s -> fwords $ "Not implemented: " ++ s
+
+ NotSupported s -> fwords $ "Not supported: " ++ s
+
+ CompilationError s -> sep [fwords "Compilation error:", text s]
+
+ GenericError s -> fwords s
+
+ GenericDocError d -> return d
+
+ TerminationCheckFailed because ->
+ 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)
+
+ PropMustBeSingleton -> fwords
+ "Datatypes in Prop must have at most one constructor when proof irrelevance is enabled"
+
+ DataMustEndInSort t -> fsep $
+ pwords "The type of a datatype must end in a sort."
+ ++ [prettyTCM t] ++ pwords "isn't a sort."
+
{- UNUSED:
- DataTooManyParameters -> fsep $ pwords "Too many parameters given to data type."
+ DataTooManyParameters -> fsep $ pwords "Too many parameters given to data type."
-}
- ShouldEndInApplicationOfTheDatatype t -> fsep $
- pwords "The target of a constructor must be the datatype applied to its parameters,"
- ++ [prettyTCM t] ++ pwords "isn't"
- ShouldBeAppliedToTheDatatypeParameters s t -> fsep $
- pwords "The target of the constructor should be" ++ [prettyTCM s] ++
- pwords "instead of" ++ [prettyTCM t]
- ShouldBeApplicationOf t q -> fsep $
- pwords "The pattern constructs an element of" ++ [prettyTCM q] ++
- pwords "which is not the right datatype"
- ShouldBeRecordType t -> fsep $
- pwords "Expected non-abstract record type, found " ++ [prettyTCM t]
- ShouldBeRecordPattern p -> fsep $
- pwords "Expected record pattern" -- ", found " ++ [prettyTCM p]
- NotAProjectionPattern p -> fsep $
- pwords "Not a valid projection for a copattern: " ++ [ prettyA p ]
- DifferentArities ->
- fwords "The number of arguments in the defining equations differ"
- WrongHidingInLHS -> do
- fwords "Unexpected implicit argument"
- WrongHidingInLambda t -> do
- fwords "Found an implicit lambda where an explicit lambda was expected"
- WrongIrrelevanceInLambda t -> do
- fwords "Found an irrelevant lambda where a relevant lambda was expected"
- WrongNamedArgument a -> fsep $
- pwords "Function does not accept argument " ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"
- WrongHidingInApplication t -> do
- fwords "Found an implicit application where an explicit application was expected"
- HidingMismatch h h' -> fwords $
- "Expected " ++ verbalize (Indefinite h') ++ " argument, but found " ++
- verbalize (Indefinite h) ++ " argument"
- RelevanceMismatch r r' -> fwords $
- "Expected " ++ verbalize (Indefinite r') ++ " argument, but found " ++
- verbalize (Indefinite r) ++ " argument"
- ColorMismatch c c' -> fsep $ -- TODO guilhem
- pwords "Expected argument color to be" ++ [prettyTCM c'] ++
- pwords "but found color" ++ [prettyTCM c]
- NotInductive t -> fsep $
- [prettyTCM t] ++ pwords "is not an inductive data type"
- UninstantiatedDotPattern e -> fsep $
- pwords "Failed to infer the value of dotted pattern"
- IlltypedPattern p a -> fsep $
- pwords "Type mismatch"
- IllformedProjectionPattern p -> fsep $
- pwords "Ill-formed projection pattern " ++ [prettyA p]
- CannotEliminateWithPattern p a -> do
- let isProj = isJust (isProjP p)
- fsep $
- pwords "Cannot eliminate type" ++ prettyTCM a :
- if isProj then
- pwords "with projection pattern" ++ [prettyA p]
- else
- pwords "with pattern" ++ prettyA p :
- pwords "(did you supply too many arguments?)"
- TooManyArgumentsInLHS a -> fsep $
- pwords "Left hand side gives too many arguments to a function of type" ++ [prettyTCM a]
- WrongNumberOfConstructorArguments c expect given -> fsep $
- pwords "The constructor" ++ [prettyTCM c] ++ pwords "expects" ++
- [text (show expect)] ++ pwords "arguments (including hidden ones), but has been given" ++ [text (show given)] ++ pwords "(including hidden ones)"
- CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $
- pwords ("Can't resolve overloaded constructors targeting the same datatype ("
- ++ show (qnameToConcrete d) ++ "):")
- ++ map pretty cs
- DoesNotConstructAnElementOf c t -> fsep $
- pwords "The constructor" ++ [prettyTCM c] ++
- pwords "does not construct an element of" ++ [prettyTCM t]
- ConstructorPatternInWrongDatatype c d -> fsep $
- [prettyTCM c] ++ pwords "is not a constructor of the datatype" ++ [prettyTCM d]
- IndicesNotConstructorApplications [i] ->
- fwords "The index"
- $$ nest 2 (prettyTCM i)
- $$ fsep (pwords "is not a constructor (or literal) applied to variables" ++
- pwords "(note that parameters count as constructor arguments)")
- IndicesNotConstructorApplications is ->
- fwords "The indices"
- $$ nest 2 (vcat $ map prettyTCM is)
- $$ fsep (pwords "are not constructors (or literals) applied to variables" ++
- pwords "(note that parameters count as constructor arguments)")
- IndexVariablesNotDistinct vs is ->
- fwords "The variables"
- $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs)
- $$ fwords "in the indices"
- $$ nest 2 (vcat $ map prettyTCM is)
- $$ fwords "are not distinct (note that parameters count as constructor arguments)"
- IndicesFreeInParameters vs indices pars ->
- fwords "The variables"
- $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs)
- $$ fwords "which are used (perhaps as constructor parameters) in the index expressions"
- $$ nest 2 (vcat $ map prettyTCM indices)
- $$ fwords "are free in the parameters"
- $$ nest 2 (vcat $ map prettyTCM pars)
- ShadowedModule x [] -> __IMPOSSIBLE__
- ShadowedModule x ms@(m : _) -> fsep $
- pwords "Duplicate definition of module" ++ [prettyTCM x <> text "."] ++
- pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] ++
- pwords "at" ++ [prettyTCM r]
- where
- help m = do
- b <- isDatatypeModule m
- if b then text "datatype" else empty
-
- r = case [ r | r <- map (defSiteOfLast . mnameToList) ms
- , r /= noRange ] of
- [] -> noRange
- r : _ -> r
-
- defSiteOfLast [] = noRange
- defSiteOfLast ns = nameBindingSite (last ns)
- ModuleArityMismatch m EmptyTel args -> fsep $
- pwords "The module" ++ [prettyTCM m] ++
- pwords "is not parameterized, but is being applied to arguments"
- ModuleArityMismatch m tel@(ExtendTel _ _) args -> fsep $
- pwords "The arguments to " ++ [prettyTCM m] ++ pwords "does not fit the telescope" ++
- [prettyTCM tel]
- ShouldBeEmpty t [] -> fsep $
- [prettyTCM t] ++ pwords "should be empty, but that's not obvious to me"
- ShouldBeEmpty t ps -> fsep (
- [prettyTCM t] ++
- pwords "should be empty, but the following constructor patterns are valid:"
- ) $$ nest 2 (vcat $ map (showPat 0) ps)
-
- ShouldBeASort t -> fsep $
- [prettyTCM t] ++ pwords "should be a sort, but it isn't"
- ShouldBePi t -> fsep $
- [prettyTCM t] ++ pwords "should be a function type, but it isn't"
- NotAProperTerm ->
- fwords "Found a malformed term"
- SetOmegaNotValidType ->
- fwords "Setω is not a valid type"
- InvalidType v -> fsep $
- [prettyTCM v] ++ pwords "is not a valid type"
- SplitOnIrrelevant p t -> fsep $
- pwords "Cannot pattern match" ++ [prettyA p] ++
- pwords "against irrelevant type" ++ [prettyTCM t]
- DefinitionIsIrrelevant x -> fsep $
- text "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"
- VariableIsIrrelevant x -> fsep $
- text "Variable" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"
- UnequalBecauseOfUniverseConflict cmp s t -> fsep $
- [prettyTCM s, notCmp cmp, prettyTCM t, text "because this would result in an invalid use of Setω" ]
- UnequalTerms cmp s t a -> do
- (d1, d2, d) <- prettyInEqual s t
- fsep $ [return d1, notCmp cmp, return d2] ++ pwords "of type" ++ [prettyTCM a] ++ [return d]
+
+ ShouldEndInApplicationOfTheDatatype t -> fsep $
+ pwords "The target of a constructor must be the datatype applied to its parameters,"
+ ++ [prettyTCM t] ++ pwords "isn't"
+
+ ShouldBeAppliedToTheDatatypeParameters s t -> fsep $
+ pwords "The target of the constructor should be" ++ [prettyTCM s] ++
+ pwords "instead of" ++ [prettyTCM t]
+
+ ShouldBeApplicationOf t q -> fsep $
+ pwords "The pattern constructs an element of" ++ [prettyTCM q] ++
+ pwords "which is not the right datatype"
+
+ ShouldBeRecordType t -> fsep $
+ pwords "Expected non-abstract record type, found " ++ [prettyTCM t]
+
+ ShouldBeRecordPattern p -> fsep $
+ pwords "Expected record pattern" -- ", found " ++ [prettyTCM p]
+
+ NotAProjectionPattern p -> fsep $
+ pwords "Not a valid projection for a copattern: " ++ [ prettyA p ]
+
+ DifferentArities ->
+ fwords "The number of arguments in the defining equations differ"
+
+ WrongHidingInLHS -> fwords "Unexpected implicit argument"
+
+ WrongHidingInLambda t ->
+ fwords "Found an implicit lambda where an explicit lambda was expected"
+
+ WrongIrrelevanceInLambda t ->
+ fwords "Found an irrelevant lambda where a relevant lambda was expected"
+
+ WrongNamedArgument a -> fsep $
+ pwords "Function does not accept argument "
+ ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"
+
+ WrongHidingInApplication t ->
+ fwords "Found an implicit application where an explicit application was expected"
+
+ HidingMismatch h h' -> fwords $
+ "Expected " ++ verbalize (Indefinite h') ++ " argument, but found " ++
+ verbalize (Indefinite h) ++ " argument"
+
+ RelevanceMismatch r r' -> fwords $
+ "Expected " ++ verbalize (Indefinite r') ++ " argument, but found " ++
+ verbalize (Indefinite r) ++ " argument"
+
+ ColorMismatch c c' -> fsep $ -- TODO guilhem
+ pwords "Expected argument color to be" ++ [prettyTCM c'] ++
+ pwords "but found color" ++ [prettyTCM c]
+
+ NotInductive t -> fsep $
+ [prettyTCM t] ++ pwords "is not an inductive data type"
+
+ UninstantiatedDotPattern e -> fsep $
+ pwords "Failed to infer the value of dotted pattern"
+
+ IlltypedPattern p a -> fsep $
+ pwords "Type mismatch"
+
+ IllformedProjectionPattern p -> fsep $
+ pwords "Ill-formed projection pattern " ++ [prettyA p]
+
+ CannotEliminateWithPattern p a -> do
+ let isProj = isJust (isProjP p)
+ fsep $
+ pwords "Cannot eliminate type" ++ prettyTCM a :
+ if isProj then
+ pwords "with projection pattern" ++ [prettyA p]
+ else
+ pwords "with pattern" ++ prettyA p :
+ pwords "(did you supply too many arguments?)"
+
+ TooManyArgumentsInLHS a -> fsep $
+ pwords "Left hand side gives too many arguments to a function of type"
+ ++ [prettyTCM a]
+
+ WrongNumberOfConstructorArguments c expect given -> fsep $
+ pwords "The constructor" ++ [prettyTCM c] ++
+ pwords "expects" ++ [prettyTCM expect] ++
+ pwords "arguments (including hidden ones), but has been given"
+ ++ [prettyTCM given] ++ pwords "(including hidden ones)"
+
+ CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $
+ pwords "Can't resolve overloaded constructors targeting the same datatype"
+ ++ [(parens $ prettyTCM (qnameToConcrete d)) <> colon]
+ ++ map pretty cs
+
+ DoesNotConstructAnElementOf c t -> fsep $
+ pwords "The constructor" ++ [prettyTCM c] ++
+ pwords "does not construct an element of" ++ [prettyTCM t]
+
+ ConstructorPatternInWrongDatatype c d -> fsep $
+ [prettyTCM c] ++ pwords "is not a constructor of the datatype"
+ ++ [prettyTCM d]
+
+ IndicesNotConstructorApplications [i] ->
+ fwords "The index"
+ $$ nest 2 (prettyTCM i)
+ $$ fsep (pwords "is not a constructor (or literal) applied to variables" ++
+ pwords "(note that parameters count as constructor arguments)")
+
+ IndicesNotConstructorApplications is ->
+ fwords "The indices"
+ $$ nest 2 (vcat $ map prettyTCM is)
+ $$ fsep (pwords "are not constructors (or literals) applied to variables" ++
+ pwords "(note that parameters count as constructor arguments)")
+
+ IndexVariablesNotDistinct vs is ->
+ fwords "The variables"
+ $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs)
+ $$ fwords "in the indices"
+ $$ nest 2 (vcat $ map prettyTCM is)
+ $$ fwords "are not distinct (note that parameters count as constructor arguments)"
+
+ IndicesFreeInParameters vs indices pars ->
+ fwords "The variables"
+ $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs)
+ $$ fwords "which are used (perhaps as constructor parameters) in the index expressions"
+ $$ nest 2 (vcat $ map prettyTCM indices)
+ $$ fwords "are free in the parameters"
+ $$ nest 2 (vcat $ map prettyTCM pars)
+
+ ShadowedModule x [] -> __IMPOSSIBLE__
+
+ ShadowedModule x ms@(m : _) -> fsep $
+ pwords "Duplicate definition of module" ++ [prettyTCM x <> text "."] ++
+ pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] ++
+ pwords "at" ++ [prettyTCM r]
+ where
+ help m = do
+ b <- isDatatypeModule m
+ if b then text "datatype" else empty
+
+ r = case [ r | r <- map (defSiteOfLast . mnameToList) ms
+ , r /= noRange ] of
+ [] -> noRange
+ r : _ -> r
+
+ defSiteOfLast [] = noRange
+ defSiteOfLast ns = nameBindingSite (last ns)
+
+ ModuleArityMismatch m EmptyTel args -> fsep $
+ pwords "The module" ++ [prettyTCM m] ++
+ pwords "is not parameterized, but is being applied to arguments"
+
+ ModuleArityMismatch m tel@(ExtendTel _ _) args -> fsep $
+ pwords "The arguments to " ++ [prettyTCM m] ++ pwords "does not fit the telescope" ++
+ [prettyTCM tel]
+
+ ShouldBeEmpty t [] -> fsep $
+ [prettyTCM t] ++ pwords "should be empty, but that's not obvious to me"
+
+ ShouldBeEmpty t ps -> fsep (
+ [prettyTCM t] ++
+ pwords "should be empty, but the following constructor patterns are valid:"
+ ) $$ nest 2 (vcat $ map (prettyPat 0) ps)
+
+ ShouldBeASort t -> fsep $
+ [prettyTCM t] ++ pwords "should be a sort, but it isn't"
+
+ ShouldBePi t -> fsep $
+ [prettyTCM t] ++ pwords "should be a function type, but it isn't"
+
+ NotAProperTerm -> fwords "Found a malformed term"
+
+ SetOmegaNotValidType -> fwords "Setω is not a valid type"
+
+ InvalidTypeSort s -> fsep $ [prettyTCM s] ++ pwords "is not a valid type"
+ InvalidType v -> fsep $ [prettyTCM v] ++ pwords "is not a valid type"
+
+ FunctionTypeInSizeUniv v -> fsep $
+ pwords "Functions may not return sizes, thus, function type " ++
+ [ prettyTCM v ] ++ pwords " is illegal"
+
+ SplitOnIrrelevant p t -> fsep $
+ pwords "Cannot pattern match" ++ [prettyA p] ++
+ pwords "against irrelevant type" ++ [prettyTCM t]
+
+ DefinitionIsIrrelevant x -> fsep $
+ text "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"
+ VariableIsIrrelevant x -> fsep $
+ text "Variable" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"
+ UnequalBecauseOfUniverseConflict cmp s t -> fsep $
+ [prettyTCM s, notCmp cmp, prettyTCM t, text "because this would result in an invalid use of Setω" ]
+
+ UnequalTerms cmp s t a -> do
+ (d1, d2, d) <- prettyInEqual s t
+ fsep $ [return d1, notCmp cmp, return d2] ++ pwords "of type" ++ [prettyTCM a] ++ [return d]
+
-- UnequalLevel is UNUSED
--- UnequalLevel cmp s t -> fsep $
--- [prettyTCM s, notCmp cmp, prettyTCM t]
+-- UnequalLevel cmp s t -> fsep $
+-- [prettyTCM s, notCmp cmp, prettyTCM t]
+
-- UnequalTelescopes is UNUSED
--- UnequalTelescopes cmp a b -> fsep $
--- [prettyTCM a, notCmp cmp, prettyTCM b]
- UnequalTypes cmp a b -> prettyUnequal a (notCmp cmp) b
--- fsep $ [prettyTCM a, notCmp cmp, prettyTCM b]
- UnequalColors a b -> error "TODO guilhem 4"
- HeterogeneousEquality u a v b -> fsep $
- pwords "Refuse to solve heterogeneous constraint" ++
- [prettyTCM u] ++ pwords ":" ++ [prettyTCM a] ++ pwords "=?=" ++
- [prettyTCM v] ++ pwords ":" ++ [prettyTCM b]
- UnequalRelevance cmp a b -> fsep $
- [prettyTCM a, notCmp cmp, prettyTCM b] ++
+-- UnequalTelescopes cmp a b -> fsep $
+-- [prettyTCM a, notCmp cmp, prettyTCM b]
+
+ UnequalTypes cmp a b -> prettyUnequal a (notCmp cmp) b
+-- fsep $ [prettyTCM a, notCmp cmp, prettyTCM b]
+
+ UnequalColors a b -> error "TODO guilhem 4"
+
+ HeterogeneousEquality u a v b -> fsep $
+ pwords "Refuse to solve heterogeneous constraint" ++
+ [prettyTCM u] ++ pwords ":" ++ [prettyTCM a] ++ pwords "=?=" ++
+ [prettyTCM v] ++ pwords ":" ++ [prettyTCM b]
+
+ UnequalRelevance cmp a b -> fsep $
+ [prettyTCM a, notCmp cmp, prettyTCM b] ++
-- Andreas 2010-09-21 to reveal Forced annotations, print also uglily
--- [text $ show a, notCmp cmp, text $ show b] ++
- pwords "because one is a relevant function type and the other is an irrelevant function type"
- UnequalHiding a b -> fsep $
- [prettyTCM a, text "!=", prettyTCM b] ++
- pwords "because one is an implicit function type and the other is an explicit function type"
- UnequalSorts s1 s2 -> fsep $
- [prettyTCM s1, text "!=", prettyTCM s2]
- NotLeqSort s1 s2 -> fsep $
- pwords "The type of the constructor does not fit in the sort of the datatype, since"
- ++ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2]
- TooFewFields r xs -> fsep $
- pwords "Missing fields" ++ punctuate comma (map pretty xs) ++
- pwords "in an element of the record" ++ [prettyTCM r]
- TooManyFields r xs -> fsep $
- pwords "The record type" ++ [prettyTCM r] ++
- pwords "does not have the fields" ++ punctuate comma (map pretty xs)
- DuplicateConstructors xs -> fsep $
- pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) ++
- pwords "in datatype"
- DuplicateFields xs -> fsep $
- 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)"
- UnexpectedWithPatterns ps -> fsep $
- pwords "Unexpected with patterns" ++ (punctuate (text " |") $ map prettyA ps)
- WithClausePatternMismatch p q -> fsep $
- pwords "With clause pattern " ++ [prettyA p] ++
- pwords " is not an instance of its parent pattern " ++ [prettyTCM q]
- -- TODO: prettier printing for internal patterns
- MetaCannotDependOn m ps i -> fsep $
- pwords "The metavariable" ++ [prettyTCM $ MetaV m []] ++ pwords "cannot depend on" ++ [pvar i] ++
- pwords "because it" ++ deps
- where
- pvar = prettyTCM . I.var
- deps = case map pvar ps of
- [] -> pwords "does not depend on any variables"
- [x] -> pwords "only depends on the variable" ++ [x]
- xs -> pwords "only depends on the variables" ++ punctuate comma xs
-
- MetaOccursInItself m -> fsep $
- pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []]
- BuiltinMustBeConstructor s e -> fsep $
- [prettyA e] ++ pwords "must be a constructor in the binding to builtin" ++ [text s]
- NoSuchBuiltinName s -> fsep $
- pwords "There is no built-in thing called" ++ [text s]
- DuplicateBuiltinBinding b x y -> fsep $
- pwords "Duplicate binding for built-in thing" ++ [text b <> comma] ++
- pwords "previous binding to" ++ [prettyTCM x]
- NoBindingForBuiltin x -> fsep $
- pwords "No binding for builtin thing" ++ [text x <> comma] ++
- pwords ("use {-# BUILTIN " ++ x ++ " name #-} to bind it to 'name'")
- NoSuchPrimitiveFunction x -> fsep $
- pwords "There is no primitive function called" ++ [text x]
- BuiltinInParameterisedModule x -> fwords $
- "The BUILTIN pragma cannot appear inside a bound context " ++
- "(for instance, in a parameterised module or as a local declaration)"
- IllegalLetInTelescope tb -> fsep $
- -- pwords "The binding" ++
- [pretty tb] ++
- pwords " is not allowed in a telescope here."
- NoRHSRequiresAbsurdPattern ps -> fwords $
- "The right-hand side can only be omitted if there " ++
- "is an absurd pattern, () or {}, in the left-hand side."
- AbsurdPatternRequiresNoRHS ps -> fwords $
- "The right-hand side must be omitted if there " ++
- "is an absurd pattern, () or {}, in the left-hand side."
- LocalVsImportedModuleClash m -> fsep $
- pwords "The module" ++ [text $ show m] ++
- pwords "can refer to either a local module or an imported module"
- 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 (show 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)
- FileNotFound x files ->
- fsep ( pwords "Failed to find source of module" ++ [pretty x] ++
- pwords "in any of the following locations:"
- ) $$ nest 2 (vcat $ map (text . filePath) files)
- OverlappingProjects f m1 m2 ->
- fsep ( pwords "The file" ++ [text (filePath f)] ++
- pwords "can be accessed via several project roots. Both" ++
- [pretty m1] ++ pwords "and" ++ [pretty m2] ++
- pwords "point to this file."
- )
- AmbiguousTopLevelModuleName x files ->
- fsep ( pwords "Ambiguous module name. The module name" ++
- [pretty x] ++
- pwords "could refer to any of the following files:"
- ) $$ nest 2 (vcat $ map (text . filePath) files)
- ClashingFileNamesFor x files ->
- fsep ( pwords "Multiple possible sources for module" ++ [text $ show x] ++
- pwords "found:"
- ) $$ nest 2 (vcat $ map (text . filePath) files)
- ModuleDefinedInOtherFile mod file file' -> fsep $
- pwords "You tried to load" ++ [text (filePath file)] ++
- pwords "which defines the module" ++ [pretty mod <> text "."] ++
- pwords "However, according to the include path this module should" ++
- pwords "be defined in" ++ [text (filePath file') <> text "."]
- 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:")
- $$ nest 2 (vcat $ map (text . filePath) files)
- BothWithAndRHS -> fsep $
- pwords "Unexpected right hand side"
- NotInScope xs ->
- fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map name xs)
- where
- name x = fsep [ pretty x, text "at" <+> prettyTCM (getRange x), suggestion (show x) ]
- suggestion s
- | elem ':' s = parens $ text "did you forget space around the ':'?"
- | elem "->" two = parens $ text "did you forget space around the '->'?"
- | otherwise = empty
- where
- two = zipWith (\a b -> [a,b]) s (tail s)
- NoSuchModule x -> fsep $
- pwords "No such module" ++ [pretty x]
- AmbiguousName x ys -> vcat
- [ fsep $ pwords "Ambiguous name" ++ [pretty x <> text "."] ++
- pwords "It could refer to any one of"
- , nest 2 $ vcat $ map nameWithBinding ys
- , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"
- ]
- AmbiguousModule x ys -> vcat
- [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> text "."] ++
- pwords "It could refer to any one of"
- , nest 2 $ vcat $ map help ys
- , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"
- ]
- where
- help :: ModuleName -> TCM Doc
- help m = do
- b <- isDatatypeModule m
- sep [prettyTCM m, if b then text "(datatype module)" else empty]
- UninstantiatedModule x -> fsep (
- pwords "Cannot access the contents of the parameterised module" ++ [pretty x <> text "."] ++
- pwords "To do this the module first has to be instantiated. For instance:"
- ) $$ nest 2 (hsep [ text "module", pretty x <> text "'", text "=", pretty x, text "e1 .. en" ])
- ClashingDefinition x y -> fsep $
- pwords "Multiple definitions of" ++ [pretty x <> text "."] ++
- pwords "Previous definition at" ++ [prettyTCM $ nameBindingSite $ qnameName y]
- ClashingModule m1 m2 -> fsep $
- pwords "The modules" ++ [prettyTCM m1, text "and", prettyTCM m2] ++ pwords "clash."
- ClashingImport x y -> fsep $
- pwords "Import clash between" ++ [pretty x, text "and", prettyTCM y]
- ClashingModuleImport x y -> fsep $
- pwords "Module import clash between" ++ [pretty x, text "and", prettyTCM y]
- PatternShadowsConstructor x c -> fsep $
- pwords "The pattern variable" ++ [prettyTCM x] ++
- pwords "has the same name as the constructor" ++ [prettyTCM c]
- DuplicateImports m xs -> fsep $
- pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" ++
- punctuate comma (map pretty xs)
- ModuleDoesntExport m xs -> fsep $
- pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++
- punctuate comma (map pretty xs)
- NotAModuleExpr e -> fsep $
- pwords "The right-hand side of a module definition must have the form 'M e1 .. en'" ++
- pwords "where M is a module name. The expression" ++ [pretty e, text "doesn't."]
- FieldOutsideRecord -> fsep $
- pwords "Field appearing outside record declaration."
- InvalidPattern p -> fsep $
- pretty p : pwords "is not a valid pattern"
- RepeatedVariablesInPattern xs -> fsep $
- pwords "Repeated variables in pattern:" ++ map pretty xs
- NotAnExpression e -> fsep $
- [pretty e] ++ pwords "is not a valid expression."
- NotAValidLetBinding nd -> fwords $
- "Not a valid let-declaration"
- NothingAppliedToHiddenArg e -> fsep $
- [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
- pwords "a function expecting an implicit argument."
- NothingAppliedToInstanceArg e -> fsep $
- [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
- pwords "a function expecting an instance argument."
- NoParseForApplication es -> fsep $
- pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es]
- AmbiguousParseForApplication es es' -> fsep (
- pwords "Don't know how to parse" ++ [pretty_es <> (text ".")] ++
- pwords "Could mean any one of:"
- ) $$ nest 2 (vcat $ map pretty' es')
+-- [text $ show a, notCmp cmp, text $ show b] ++
+ pwords "because one is a relevant function type and the other is an irrelevant function type"
+
+ UnequalHiding a b -> fsep $
+ [prettyTCM a, text "!=", prettyTCM b] ++
+ pwords "because one is an implicit function type and the other is an explicit function type"
+
+ UnequalSorts s1 s2 -> fsep $
+ [prettyTCM s1, text "!=", prettyTCM s2]
+
+ NotLeqSort s1 s2 -> fsep $
+ pwords "The type of the constructor does not fit in the sort of the datatype, since"
+ ++ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2]
+
+ TooFewFields r xs -> fsep $
+ pwords "Missing fields" ++ punctuate comma (map pretty xs) ++
+ pwords "in an element of the record" ++ [prettyTCM r]
+
+ TooManyFields r xs -> fsep $
+ pwords "The record type" ++ [prettyTCM r] ++
+ pwords "does not have the fields" ++ punctuate comma (map pretty xs)
+
+ DuplicateConstructors xs -> fsep $
+ pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) ++
+ pwords "in datatype"
+
+ DuplicateFields xs -> fsep $
+ 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)"
+
+ UnexpectedWithPatterns ps -> fsep $
+ pwords "Unexpected with patterns" ++ (punctuate (text " |") $ map prettyA ps)
+
+ WithClausePatternMismatch p q -> fsep $
+ pwords "With clause pattern " ++ [prettyA p] ++
+ pwords " is not an instance of its parent pattern " ++ [prettyTCM q]
+ -- TODO: prettier printing for internal patterns
+
+ MetaCannotDependOn m ps i -> fsep $
+ pwords "The metavariable" ++ [prettyTCM $ MetaV m []] ++
+ pwords "cannot depend on" ++ [pvar i] ++
+ pwords "because it" ++ deps
+ where
+ pvar = prettyTCM . I.var
+ deps = case map pvar ps of
+ [] -> pwords "does not depend on any variables"
+ [x] -> pwords "only depends on the variable" ++ [x]
+ xs -> pwords "only depends on the variables" ++ punctuate comma xs
+
+ MetaOccursInItself m -> fsep $
+ pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []]
+
+ BuiltinMustBeConstructor s e -> fsep $
+ [prettyA e] ++ pwords "must be a constructor in the binding to builtin" ++ [text s]
+
+ NoSuchBuiltinName s -> fsep $
+ pwords "There is no built-in thing called" ++ [text s]
+
+ DuplicateBuiltinBinding b x y -> fsep $
+ pwords "Duplicate binding for built-in thing" ++ [text b <> comma] ++
+ pwords "previous binding to" ++ [prettyTCM x]
+
+ NoBindingForBuiltin x -> fsep $
+ pwords "No binding for builtin thing" ++ [text x <> comma] ++
+ pwords ("use {-# BUILTIN " ++ x ++ " name #-} to bind it to 'name'")
+
+ NoSuchPrimitiveFunction x -> fsep $
+ pwords "There is no primitive function called" ++ [text x]
+
+ BuiltinInParameterisedModule x -> fwords $
+ "The BUILTIN pragma cannot appear inside a bound context " ++
+ "(for instance, in a parameterised module or as a local declaration)"
+
+ IllegalLetInTelescope tb -> fsep $
+ -- pwords "The binding" ++
+ [pretty tb] ++
+ pwords " is not allowed in a telescope here."
+
+ NoRHSRequiresAbsurdPattern ps -> fwords $
+ "The right-hand side can only be omitted if there " ++
+ "is an absurd pattern, () or {}, in the left-hand side."
+
+ AbsurdPatternRequiresNoRHS ps -> fwords $
+ "The right-hand side must be omitted if there " ++
+ "is an absurd pattern, () or {}, in the left-hand side."
+
+ LocalVsImportedModuleClash m -> fsep $
+ pwords "The module" ++ [prettyTCM m] ++
+ pwords "can refer to either a local module or an imported module"
+
+ 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
- pretty_es :: TCM Doc
- pretty_es = pretty $ C.RawApp noRange es
-
- pretty' :: C.Expr -> TCM Doc
- pretty' e = do
- p1 <- pretty_es
- p2 <- pretty e
- pretty $ if show p1 == show p2 then unambiguous e else e
-
- unambiguous :: C.Expr -> C.Expr
- unambiguous (C.OpApp r op xs) | all (isOrdinary . namedArg) xs
- = foldl (C.App r) (C.Ident op) $ (map . fmap . fmap) fromOrdinary xs
- unambiguous e = e
-
- isOrdinary :: C.OpApp e -> Bool
- isOrdinary (C.Ordinary _) = True
- isOrdinary _ = False
-
- fromOrdinary :: C.OpApp e -> e
- fromOrdinary (C.Ordinary e) = e
- fromOrdinary _ = __IMPOSSIBLE__
- BadArgumentsToPatternSynonym x -> fsep $
- pwords "Bad arguments to pattern synonym " ++ [prettyTCM x]
- TooFewArgumentsToPatternSynonym x -> fsep $
- pwords "Too few arguments to pattern synonym " ++ [prettyTCM x]
- UnusedVariableInPatternSynonym -> fsep $
- pwords "Unused variable in pattern synonym."
- NoParseForLHS IsLHS p -> fsep $
- pwords "Could not parse the left-hand side" ++ [pretty p]
- NoParseForLHS IsPatSyn p -> fsep $
- pwords "Could not parse the pattern synonym" ++ [pretty p]
+ 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)
+
+ FileNotFound x files ->
+ fsep ( pwords "Failed to find source of module" ++ [pretty x] ++
+ pwords "in any of the following locations:"
+ ) $$ nest 2 (vcat $ map (text . filePath) files)
+
+ OverlappingProjects f m1 m2 ->
+ fsep ( pwords "The file" ++ [text (filePath f)] ++
+ pwords "can be accessed via several project roots. Both" ++
+ [pretty m1] ++ pwords "and" ++ [pretty m2] ++
+ pwords "point to this file."
+ )
+
+ AmbiguousTopLevelModuleName x files ->
+ fsep ( pwords "Ambiguous module name. The module name" ++
+ [pretty x] ++
+ pwords "could refer to any of the following files:"
+ ) $$ nest 2 (vcat $ map (text . filePath) files)
+
+ ClashingFileNamesFor x files ->
+ fsep ( pwords "Multiple possible sources for module"
+ ++ [prettyTCM x] ++ pwords "found:"
+ ) $$ nest 2 (vcat $ map (text . filePath) files)
+
+ ModuleDefinedInOtherFile mod file file' -> fsep $
+ pwords "You tried to load" ++ [text (filePath file)] ++
+ pwords "which defines the module" ++ [pretty mod <> text "."] ++
+ pwords "However, according to the include path this module should" ++
+ pwords "be defined in" ++ [text (filePath file') <> text "."]
+
+ 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:")
+ $$ nest 2 (vcat $ map (text . filePath) files)
+
+ BothWithAndRHS -> fsep $ pwords "Unexpected right hand side"
+
+ NotInScope xs ->
+ fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map name xs)
+ where
+ name x = fsep [ pretty x
+ , text "at" <+> prettyTCM (getRange x)
+ , suggestion (P.prettyShow x)
+ ]
+ suggestion s
+ | elem ':' s = parens $ text "did you forget space around the ':'?"
+ | elem "->" two = parens $ text "did you forget space around the '->'?"
+ | otherwise = empty
+ where
+ two = zipWith (\a b -> [a,b]) s (tail s)
+
+ NoSuchModule x -> fsep $ pwords "No such module" ++ [pretty x]
+
+ AmbiguousName x ys -> vcat
+ [ fsep $ pwords "Ambiguous name" ++ [pretty x <> text "."] ++
+ pwords "It could refer to any one of"
+ , nest 2 $ vcat $ map nameWithBinding ys
+ , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"
+ ]
+
+ AmbiguousModule x ys -> vcat
+ [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> text "."] ++
+ pwords "It could refer to any one of"
+ , nest 2 $ vcat $ map help ys
+ , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"
+ ]
+ where
+ help :: ModuleName -> TCM Doc
+ help m = do
+ b <- isDatatypeModule m
+ sep [prettyTCM m, if b then text "(datatype module)" else empty]
+
+ UninstantiatedModule x -> fsep (
+ pwords "Cannot access the contents of the parameterised module"
+ ++ [pretty x <> text "."] ++
+ pwords "To do this the module first has to be instantiated. For instance:"
+ ) $$ nest 2 (hsep [ text "module", pretty x <> text "'", text "=", pretty x, text "e1 .. en" ])
+
+ ClashingDefinition x y -> fsep $
+ pwords "Multiple definitions of" ++ [pretty x <> text "."] ++
+ pwords "Previous definition at"
+ ++ [prettyTCM $ nameBindingSite $ qnameName y]
+
+ ClashingModule m1 m2 -> fsep $
+ pwords "The modules" ++ [prettyTCM m1, text "and", prettyTCM m2]
+ ++ pwords "clash."
+
+ ClashingImport x y -> fsep $
+ pwords "Import clash between" ++ [pretty x, text "and", prettyTCM y]
+
+ ClashingModuleImport x y -> fsep $
+ pwords "Module import clash between" ++ [pretty x, text "and", prettyTCM y]
+
+ PatternShadowsConstructor x c -> fsep $
+ pwords "The pattern variable" ++ [prettyTCM x] ++
+ pwords "has the same name as the constructor" ++ [prettyTCM c]
+
+ DuplicateImports m xs -> fsep $
+ pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" ++
+ punctuate comma (map pretty xs)
+
+ ModuleDoesntExport m xs -> fsep $
+ pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++
+ punctuate comma (map pretty xs)
+
+ NotAModuleExpr e -> fsep $
+ pwords "The right-hand side of a module definition must have the form 'M e1 .. en'" ++
+ pwords "where M is a module name. The expression"
+ ++ [pretty e, text "doesn't."]
+
+ FieldOutsideRecord -> fsep $
+ pwords "Field appearing outside record declaration."
+
+ InvalidPattern p -> fsep $
+ pretty p : pwords "is not a valid pattern"
+
+ RepeatedVariablesInPattern xs -> fsep $
+ pwords "Repeated variables in pattern:" ++ map pretty xs
+
+ NotAnExpression e -> fsep $
+ [pretty e] ++ pwords "is not a valid expression."
+
+ NotAValidLetBinding nd -> fwords $
+ "Not a valid let-declaration"
+
+ NothingAppliedToHiddenArg e -> fsep $
+ [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
+ pwords "a function expecting an implicit argument."
+
+ NothingAppliedToInstanceArg e -> fsep $
+ [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
+ pwords "a function expecting an instance argument."
+
+ NoParseForApplication es -> fsep $
+ pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es]
+
+ AmbiguousParseForApplication es es' -> fsep (
+ pwords "Don't know how to parse" ++ [pretty_es <> (text ".")] ++
+ pwords "Could mean any one of:"
+ ) $$ nest 2 (vcat $ map pretty' es')
+ where
+ pretty_es :: TCM Doc
+ pretty_es = pretty $ C.RawApp noRange es
+
+ pretty' :: C.Expr -> TCM Doc
+ pretty' e = do
+ p1 <- pretty_es
+ p2 <- pretty e
+ pretty $ if show p1 == show p2 then unambiguous e else e
+
+ unambiguous :: C.Expr -> C.Expr
+ unambiguous (C.OpApp r op _ xs) | all (isOrdinary . namedArg) xs
+ = foldl (C.App r) (C.Ident op) $ (map . fmap . fmap) fromOrdinary xs
+ unambiguous e = e
+
+ isOrdinary :: C.OpApp e -> Bool
+ isOrdinary (C.Ordinary _) = True
+ isOrdinary _ = False
+
+ fromOrdinary :: C.OpApp e -> e
+ fromOrdinary (C.Ordinary e) = e
+ fromOrdinary _ = __IMPOSSIBLE__
+
+ BadArgumentsToPatternSynonym x -> fsep $
+ pwords "Bad arguments to pattern synonym " ++ [prettyTCM x]
+
+ TooFewArgumentsToPatternSynonym x -> fsep $
+ pwords "Too few arguments to pattern synonym " ++ [prettyTCM x]
+
+ UnusedVariableInPatternSynonym -> fsep $
+ pwords "Unused variable in pattern synonym."
+
+ NoParseForLHS IsLHS p -> fsep $
+ pwords "Could not parse the left-hand side" ++ [pretty p]
+
+ NoParseForLHS IsPatSyn p -> fsep $
+ pwords "Could not parse the pattern synonym" ++ [pretty p]
+
{- UNUSED
- NoParseForPatternSynonym p -> fsep $
- pwords "Could not parse the pattern synonym" ++ [pretty p]
+ NoParseForPatternSynonym p -> fsep $
+ pwords "Could not parse the pattern synonym" ++ [pretty p]
-}
- AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep (
- pwords "Don't know how to parse" ++ [pretty_p <> text "."] ++
- pwords "Could mean any one of:"
- ) $$ nest 2 (vcat $ map pretty' ps)
- where
- pretty_p :: TCM Doc
- pretty_p = pretty p
-
- pretty' :: C.Pattern -> TCM Doc
- pretty' p' = do
- p1 <- pretty_p
- p2 <- pretty p'
- pretty $ if show p1 == show p2 then unambiguousP p' else p'
-
- -- the entire pattern is shown, not just the ambiguous part,
- -- so we need to dig in order to find the OpAppP's.
- unambiguousP :: C.Pattern -> C.Pattern
- unambiguousP (C.AppP x y) = C.AppP (unambiguousP x) $ (fmap.fmap) unambiguousP y
- unambiguousP (C.HiddenP r x) = C.HiddenP r $ fmap unambiguousP x
- unambiguousP (C.InstanceP r x) = C.InstanceP r $ fmap unambiguousP x
- unambiguousP (C.ParenP r x) = C.ParenP r $ unambiguousP x
- unambiguousP (C.AsP r n x) = C.AsP r n $ unambiguousP x
- unambiguousP (C.OpAppP r op xs) = foldl C.AppP (C.IdentP op) xs
- unambiguousP e = e
+
+ AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep (
+ pwords "Don't know how to parse" ++ [pretty_p <> text "."] ++
+ pwords "Could mean any one of:"
+ ) $$ nest 2 (vcat $ map pretty' ps)
+ where
+ pretty_p :: TCM Doc
+ pretty_p = pretty p
+
+ pretty' :: C.Pattern -> TCM Doc
+ pretty' p' = do
+ p1 <- pretty_p
+ p2 <- pretty p'
+ pretty $ if show p1 == show p2 then unambiguousP p' else p'
+
+ -- the entire pattern is shown, not just the ambiguous part,
+ -- so we need to dig in order to find the OpAppP's.
+ unambiguousP :: C.Pattern -> C.Pattern
+ unambiguousP (C.AppP x y) = C.AppP (unambiguousP x) $ (fmap.fmap) unambiguousP y
+ unambiguousP (C.HiddenP r x) = C.HiddenP r $ fmap unambiguousP x
+ unambiguousP (C.InstanceP r x) = C.InstanceP r $ fmap unambiguousP x
+ unambiguousP (C.ParenP r x) = C.ParenP r $ unambiguousP x
+ unambiguousP (C.AsP r n x) = C.AsP r n $ unambiguousP x
+ unambiguousP (C.OpAppP r op _ xs) = foldl C.AppP (C.IdentP op) xs
+ unambiguousP e = e
+
{- UNUSED
- AmbiguousParseForPatternSynonym p ps -> fsep (
- pwords "Don't know how to parse" ++ [pretty p <> text "."] ++
- pwords "Could mean any one of:"
- ) $$ nest 2 (vcat $ map pretty ps)
+ AmbiguousParseForPatternSynonym p ps -> fsep (
+ pwords "Don't know how to parse" ++ [pretty p <> text "."] ++
+ pwords "Could mean any one of:"
+ ) $$ nest 2 (vcat $ map pretty ps)
-}
- IncompletePatternMatching v args -> fsep $
- pwords "Incomplete pattern matching for" ++ [prettyTCM v <> text "."] ++
- pwords "No match for" ++ map prettyTCM args
- UnreachableClauses f pss -> fsep $
- pwords "Unreachable" ++ pwords (plural (length pss) "clause")
- where
- plural 1 thing = thing
- plural n thing = thing ++ "s"
- CoverageFailure f pss -> fsep (
- pwords "Incomplete pattern matching for" ++ [prettyTCM f <> text "."] ++
- pwords "Missing cases:") $$ nest 2 (vcat $ map display pss)
- where
- display ps = do
- ps <- nicify f ps
- prettyTCM f <+> fsep (map showArg ps)
-
- nicify f ps = do
- showImp <- showImplicitArguments
- if showImp
- then return ps
- else return ps -- TODO: remove implicit arguments which aren't constructors
-
- CoverageCantSplitOn c tel cIxs gIxs
- | length cIxs /= length gIxs -> __IMPOSSIBLE__
- | otherwise -> addCtxTel 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" ++
- pwords "unification problems (inferred index ≟ expected index):"
- ] ++
- zipWith (\c g -> nest 2 $ prettyTCM c <+> text "≟" <+> prettyTCM g) cIxs gIxs)
- CoverageCantSplitIrrelevantType a -> fsep $
- pwords "Cannot split on argument of irrelevant datatype" ++ [prettyTCM a]
-
- CoverageCantSplitType a -> fsep $
- pwords "Cannot split on argument of non-datatype" ++ [prettyTCM a]
-
- SplitError e -> prettyTCM e
-
- WithoutKError a u v -> fsep $
- pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] ++ pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] ++ pwords "because K has been disabled."
-
- 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 = text (show $ n - 1) <> text "th"
-
- com [] = empty
- com (_:_) = comma
- IFSNoCandidateInScope t -> fsep $
- pwords "No variable of type" ++ [prettyTCM t] ++ pwords "was found in scope."
- UnquoteFailed e -> case e of
- (BadVisibility msg arg) -> fsep $
- pwords $ "Unable to unquote the argument. It should be `" ++ msg ++ "'."
- (ConInsteadOfDef x def con) -> do
- fsep $ pwords ("Use " ++ con ++ " instead of " ++ def ++ " for constructor") ++ [prettyTCM x]
- (DefInsteadOfCon x def con) -> do
- fsep $ pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor") ++ [prettyTCM x]
- (NotAConstructor kind t) ->
- fwords "Unable to unquote the term"
- $$ nest 2 (prettyTCM t)
- $$ fwords ("of type " ++ kind ++ ". Reason: not a constructor.")
- (NotALiteral kind t) ->
- fwords "Unable to unquote the term"
- $$ nest 2 (prettyTCM t)
- $$ fwords ("of type " ++ kind ++ ". Reason: not a literal value.")
- (RhsUsesDottedVar ixs t) ->
- fwords "Unable to unquote the term"
- $$ nest 2 (prettyTCM t)
- $$ fwords "of type Clause. Reason: the right-hand side contains variables that are referring to a dot pattern."
- $$ fwords ("Offending De Bruijn indices: " ++ intercalate ", " (map show ixs) ++ ".")
- (BlockedOnMeta m) -> __IMPOSSIBLE__
- (UnquotePanic err) -> __IMPOSSIBLE__
- SafeFlagPostulate e -> fsep $
- pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag"
- SafeFlagPragma xs ->
- let plural | length xs == 1 = ""
- | otherwise = "s"
- in fsep $ [fwords ("Cannot set OPTION pragma" ++ plural)]
- ++ map text xs ++ [fwords "with safe flag."]
- SafeFlagNoTerminationCheck -> fsep (pwords "Cannot use NO_TERMINATION_CHECK pragma with safe flag.")
- SafeFlagNonTerminating -> fsep (pwords "Cannot use NON_TERMINATING pragma with safe flag.")
- SafeFlagTerminating -> fsep (pwords "Cannot use TERMINATING pragma with safe flag.")
- SafeFlagPrimTrustMe -> fsep (pwords "Cannot use primTrustMe with safe flag")
- NeedOptionCopatterns -> fsep (pwords "Option --copatterns needed to enable destructor patterns")
- where
- mpar n args
- | n > 0 && not (null args) = parens
- | otherwise = id
-
- showArg :: I.Arg I.Pattern -> TCM Doc
- showArg (Common.Arg info x) = case getHiding info of
- Hidden -> braces $ showPat 0 x
- Instance -> dbraces $ showPat 0 x
- NotHidden -> showPat 1 x
-
- showPat :: Integer -> I.Pattern -> TCM Doc
- showPat _ (I.VarP _) = text "_"
- showPat _ (I.DotP _) = text "._"
- showPat n (I.ConP c _ args) = mpar n args $ prettyTCM c <+> fsep (map (showArg . fmap namedThing) args)
- showPat _ (I.LitP l) = text (show l)
- showPat _ (I.ProjP p) = text (show p)
+
+ IncompletePatternMatching v args -> fsep $
+ pwords "Incomplete pattern matching for" ++ [prettyTCM v <> text "."] ++
+ pwords "No match for" ++ map prettyTCM args
+
+ UnreachableClauses f pss -> fsep $
+ pwords "Unreachable" ++ pwords (plural (length pss) "clause")
+ where
+ plural 1 thing = thing
+ plural n thing = thing ++ "s"
+
+ CoverageFailure f pss -> fsep (
+ pwords "Incomplete pattern matching for" ++ [prettyTCM f <> text "."] ++
+ pwords "Missing cases:") $$ nest 2 (vcat $ map display pss)
+ where
+ display ps = do
+ ps <- nicify f ps
+ prettyTCM f <+> fsep (map prettyArg ps)
+
+ nicify f ps = do
+ showImp <- showImplicitArguments
+ if showImp
+ then return ps
+ else return ps -- TODO: remove implicit arguments which aren't constructors
+
+ CoverageCantSplitOn c tel cIxs gIxs
+ | length cIxs /= length gIxs -> __IMPOSSIBLE__
+ | otherwise -> addCtxTel 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" ++
+ pwords "unification problems (inferred index ≟ expected index):"
+ ] ++
+ zipWith (\c g -> nest 2 $ prettyTCM c <+> text "≟" <+> prettyTCM g) cIxs gIxs)
+
+ CoverageCantSplitIrrelevantType a -> fsep $
+ pwords "Cannot split on argument of irrelevant datatype" ++ [prettyTCM a]
+
+ CoverageCantSplitType a -> fsep $
+ pwords "Cannot split on argument of non-datatype" ++ [prettyTCM a]
+
+ SplitError e -> prettyTCM e
+
+ WithoutKError a u v -> fsep $
+ pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] ++
+ pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] ++
+ pwords "because K has been disabled."
+
+ 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
+
+ IFSNoCandidateInScope t -> fsep $
+ pwords "No variable of type" ++ [prettyTCM t] ++ pwords "was found in scope."
+
+ UnquoteFailed e -> case e of
+ BadVisibility msg arg -> fsep $
+ pwords $ "Unable to unquote the argument. It should be `" ++ msg ++ "'."
+
+ ConInsteadOfDef x def con -> fsep $
+ pwords ("Use " ++ con ++ " instead of " ++ def ++ " for constructor") ++
+ [prettyTCM x]
+
+ DefInsteadOfCon x def con -> fsep $
+ pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor")
+ ++ [prettyTCM x]
+
+ NotAConstructor kind t ->
+ fwords "Unable to unquote the term"
+ $$ nest 2 (prettyTCM t)
+ $$ fwords ("of type " ++ kind ++ ". Reason: not a constructor.")
+
+ NotALiteral kind t ->
+ fwords "Unable to unquote the term"
+ $$ nest 2 (prettyTCM t)
+ $$ fwords ("of type " ++ kind ++ ". Reason: not a literal value.")
+
+ RhsUsesDottedVar ixs t ->
+ fwords "Unable to unquote the term"
+ $$ nest 2 (prettyTCM t)
+ $$ fwords "of type Clause. Reason: the right-hand side contains variables that are referring to a dot pattern."
+ $$ fwords ("Offending De Bruijn indices: "
+ ++ intercalate ", " (map P.prettyShow ixs) ++ ".")
+
+ BlockedOnMeta m -> __IMPOSSIBLE__
+
+ UnquotePanic err -> __IMPOSSIBLE__
+
+ SafeFlagPostulate e -> fsep $
+ pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag"
+
+ SafeFlagPragma xs ->
+ let plural | length xs == 1 = ""
+ | otherwise = "s"
+ in fsep $ [fwords ("Cannot set OPTION pragma" ++ plural)]
+ ++ map text xs ++ [fwords "with safe flag."]
+
+ SafeFlagNoTerminationCheck -> fsep $
+ pwords "Cannot use NO_TERMINATION_CHECK pragma with safe flag."
+
+ SafeFlagNonTerminating -> fsep $
+ pwords "Cannot use NON_TERMINATING pragma with safe flag."
+
+ SafeFlagTerminating -> fsep $
+ pwords "Cannot use TERMINATING pragma with safe flag."
+
+ SafeFlagPrimTrustMe -> fsep (pwords "Cannot use primTrustMe with safe flag")
+
+ NeedOptionCopatterns -> fsep $
+ pwords "Option --copatterns needed to enable destructor patterns"
+
+ where
+ mpar n args
+ | n > 0 && not (null args) = parens
+ | otherwise = id
+
+ prettyArg :: I.Arg I.Pattern -> TCM Doc
+ prettyArg (Common.Arg info x) = case getHiding info of
+ Hidden -> braces $ prettyPat 0 x
+ Instance -> dbraces $ prettyPat 0 x
+ NotHidden -> prettyPat 1 x
+
+ prettyPat :: Integer -> I.Pattern -> TCM Doc
+ prettyPat _ (I.VarP _) = text "_"
+ prettyPat _ (I.DotP _) = text "._"
+ prettyPat n (I.ConP c _ args) =
+ mpar n args $
+ prettyTCM c <+> fsep (map (prettyArg . fmap namedThing) args)
+ prettyPat _ (I.LitP l) = prettyTCM l
+ prettyPat _ (I.ProjP p) = prettyTCM p
notCmp :: Comparison -> TCM Doc
-notCmp cmp = text $ "!" ++ show cmp
+notCmp cmp = text "!" <> prettyTCM cmp
-- | Print two terms that are supposedly unequal.
-- If they print to the same identifier, add some explanation
@@ -861,7 +1029,7 @@ prettyInEqual t1 t2 = do
d2 <- prettyTCM t2
(d1, d2,) <$> do
-- if printed differently, no extra explanation needed
- if P.render d1 /= P.render d2 then return P.empty else do
+ if P.render d1 /= P.render d2 then empty else do
(v1, v2) <- instantiate (t1, t2)
case (ignoreSharing v1, ignoreSharing v2) of
(I.Var i1 _, I.Var i2 _)
@@ -873,11 +1041,16 @@ prettyInEqual t1 t2 = do
(I.Def{}, I.Var{}) -> varDef
(I.Var{}, I.Con{}) -> varCon
(I.Con{}, I.Var{}) -> varCon
- _ -> return P.empty
+ _ -> empty
where
- varDef = return $ P.parens $ P.fwords "because one is a variable and one a defined identifier"
- varCon = return $ P.parens $ P.fwords "because one is a variable and one a constructor"
- varVar i j = return $ P.parens $ P.fwords $ "because one has deBruijn index " ++ show i ++ " and the other " ++ show j
+ varDef, varCon :: TCM Doc
+ varDef = parens $ fwords "because one is a variable and one a defined identifier"
+ varCon = parens $ fwords "because one is a variable and one a constructor"
+
+ varVar :: Int -> Int -> TCM Doc
+ varVar i j = parens $ fwords $
+ "because one has deBruijn index " ++ show i
+ ++ " and the other " ++ show j
class PrettyUnequal a where
prettyUnequal :: a -> TCM Doc -> a -> TCM Doc
@@ -890,103 +1063,135 @@ instance PrettyUnequal Term where
instance PrettyUnequal Type where
prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2)
-
instance PrettyTCM SplitError where
prettyTCM err = case err of
NotADatatype t -> enterClosure t $ \ t -> fsep $
pwords "Cannot pattern match on non-datatype" ++ [prettyTCM t]
+
IrrelevantDatatype t -> enterClosure t $ \ t -> fsep $
pwords "Cannot pattern match on datatype" ++ [prettyTCM t] ++
pwords "since it is declared irrelevant"
+
CoinductiveDatatype t -> enterClosure t $ \ t -> fsep $
pwords "Cannot pattern match on the coinductive type" ++ [prettyTCM t]
+
{- UNUSED
NoRecordConstructor t -> fsep $
pwords "Cannot pattern match on record" ++ [prettyTCM t] ++
pwords "because it has no constructor"
-}
- CantSplit c tel cIxs gIxs flex -> prettyTCM (CoverageCantSplitOn c tel cIxs gIxs)
- GenericSplitError s -> fsep $
- pwords "Split failed:" ++ pwords s
+
+ CantSplit c tel cIxs gIxs ->
+ prettyTCM $ CoverageCantSplitOn c tel cIxs gIxs
+
+ GenericSplitError s -> fsep $ pwords "Split failed:" ++ pwords s
instance PrettyTCM Call where
- prettyTCM c = case c of
- CheckClause t cl _ -> fsep $
- pwords "when checking that the clause"
- ++ [P.prettyA cl] ++ pwords "has type" ++ [prettyTCM t]
- CheckPattern p tel t _ -> addCtxTel tel $ fsep $
- pwords "when checking that the pattern"
- ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t]
- CheckLetBinding b _ -> fsep $
- pwords "when checking the let binding" ++ [P.prettyA b]
- InferExpr e _ -> fsep $
- pwords "when inferring the type of" ++ [prettyA e]
- CheckExprCall e t _ -> fsep $
- pwords "when checking that the expression"
- ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t]
- IsTypeCall e s _ -> fsep $
- pwords "when checking that the expression"
- ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s]
- IsType_ e _ -> fsep $
- pwords "when checking that the expression"
- ++ [prettyA e] ++ pwords "is a type"
- CheckArguments r es t0 t1 _ -> fsep $
- pwords "when checking that" ++
- map hPretty es ++ pwords "are valid arguments to a function of type" ++ [prettyTCM t0]
- CheckRecDef _ x ps cs _ ->
- fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
- CheckDataDef _ x ps cs _ ->
- fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
- CheckConstructor d _ _ (A.Axiom _ _ _ c _) _ -> fsep $
- pwords "when checking the constructor" ++ [prettyTCM c] ++
- pwords "in the declaration of" ++ [prettyTCM d]
- CheckConstructor _ _ _ _ _ -> __IMPOSSIBLE__
- CheckFunDef _ f _ _ ->
- fsep $ pwords "when checking the definition of" ++ [prettyTCM f]
- CheckPragma _ p _ ->
- fsep $ pwords "when checking the pragma" ++ [prettyA $ RangeAndPragma noRange p]
- CheckPrimitive _ x e _ -> fsep $
- pwords "when checking that the type of the primitive function" ++
- [prettyTCM x] ++ pwords "is" ++ [prettyA e]
- CheckWithFunctionType e _ -> fsep $
- pwords "when checking that the type" ++
- [prettyA e] ++ pwords "of the generated with function is well-formed"
- CheckDotPattern e v _ -> fsep $
- pwords "when checking that the given dot pattern" ++ [prettyA e] ++
- pwords "matches the inferred value" ++ [prettyTCM v]
- CheckPatternShadowing c _ -> fsep $
- pwords "when checking the clause" ++ [P.prettyA c]
- InferVar x _ ->
- fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
- InferDef _ x _ ->
- fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
- CheckIsEmpty r t _ ->
- fsep $ pwords "when checking that" ++ [prettyTCM t] ++ pwords "has no constructors"
- ScopeCheckExpr e _ ->
- fsep $ pwords "when scope checking" ++ [pretty e]
- ScopeCheckDeclaration d _ ->
- fwords "when scope checking the declaration" $$
- nest 2 (pretty $ simpleDecl d)
- ScopeCheckLHS x p _ ->
- fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++
- pwords "in the definition of" ++ [pretty x]
- NoHighlighting _ -> empty
- SetRange r _ ->
- fsep (pwords "when doing something at") <+> prettyTCM r
- CheckSectionApplication _ m1 modapp _ -> fsep $
- pwords "when checking the module application" ++
- [prettyA $ A.Apply info m1 modapp Map.empty Map.empty]
- where
- info = A.ModuleInfo noRange noRange Nothing Nothing Nothing
+ prettyTCM c = case c of
+ CheckClause t cl _ -> fsep $
+ pwords "when checking that the clause"
+ ++ [AP.prettyA cl] ++ pwords "has type" ++ [prettyTCM t]
- where
- hPretty :: I.Arg (Named_ Expr) -> TCM Doc
- hPretty a = do
- info <- reify $ argInfo a
- pretty =<< (abstractToConcreteCtx (hiddenArgumentCtx (getHiding a))
- $ Common.Arg info $ unArg a)
+ CheckPattern p tel t _ -> addCtxTel tel $ fsep $
+ pwords "when checking that the pattern"
+ ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t]
+
+ CheckLetBinding b _ -> fsep $
+ pwords "when checking the let binding" ++ [AP.prettyA b]
- simpleDecl = D.notSoNiceDeclaration
+ InferExpr e _ -> fsep $ pwords "when inferring the type of" ++ [prettyA e]
+
+ CheckExprCall e t _ -> fsep $
+ pwords "when checking that the expression"
+ ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t]
+
+ IsTypeCall e s _ -> fsep $
+ pwords "when checking that the expression"
+ ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s]
+
+ IsType_ e _ -> fsep $
+ pwords "when checking that the expression"
+ ++ [prettyA e] ++ pwords "is a type"
+
+ CheckArguments r es t0 t1 _ -> fsep $
+ pwords "when checking that" ++
+ map hPretty es ++
+ pwords (singPlural es "is a valid argument" "are valid arguments") ++
+ pwords "to a function of type" ++
+ [prettyTCM t0]
+
+ CheckRecDef _ x ps cs _ ->
+ fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
+
+ CheckDataDef _ x ps cs _ ->
+ fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
+
+ CheckConstructor d _ _ (A.Axiom _ _ _ c _) _ -> fsep $
+ pwords "when checking the constructor" ++ [prettyTCM c] ++
+ pwords "in the declaration of" ++ [prettyTCM d]
+
+ CheckConstructor{} -> __IMPOSSIBLE__
+
+ CheckFunDef _ f _ _ ->
+ fsep $ pwords "when checking the definition of" ++ [prettyTCM f]
+
+ CheckPragma _ p _ ->
+ fsep $ pwords "when checking the pragma"
+ ++ [prettyA $ RangeAndPragma noRange p]
+
+ CheckPrimitive _ x e _ -> fsep $
+ pwords "when checking that the type of the primitive function" ++
+ [prettyTCM x] ++ pwords "is" ++ [prettyA e]
+
+ CheckWithFunctionType e _ -> fsep $
+ pwords "when checking that the type" ++
+ [prettyA e] ++ pwords "of the generated with function is well-formed"
+
+ CheckDotPattern e v _ -> fsep $
+ pwords "when checking that the given dot pattern" ++ [prettyA e] ++
+ pwords "matches the inferred value" ++ [prettyTCM v]
+
+ CheckPatternShadowing c _ -> fsep $
+ pwords "when checking the clause" ++ [AP.prettyA c]
+
+ InferVar x _ ->
+ fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
+
+ InferDef _ x _ ->
+ fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
+
+ CheckIsEmpty r t _ ->
+ fsep $ pwords "when checking that" ++ [prettyTCM t] ++
+ pwords "has no constructors"
+
+ ScopeCheckExpr e _ -> fsep $ pwords "when scope checking" ++ [pretty e]
+
+ ScopeCheckDeclaration d _ ->
+ fwords "when scope checking the declaration" $$
+ nest 2 (pretty $ simpleDecl d)
+
+ ScopeCheckLHS x p _ ->
+ fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++
+ pwords "in the definition of" ++ [pretty x]
+
+ NoHighlighting _ -> empty
+
+ SetRange r _ -> fsep (pwords "when doing something at") <+> prettyTCM r
+
+ CheckSectionApplication _ m1 modapp _ -> fsep $
+ pwords "when checking the module application" ++
+ [prettyA $ A.Apply info m1 modapp empty empty]
+ where
+ info = A.ModuleInfo noRange noRange Nothing Nothing Nothing
+
+ where
+ hPretty :: I.Arg (Named_ Expr) -> TCM Doc
+ hPretty a = do
+ info <- reify $ argInfo a
+ pretty =<< abstractToConcreteCtx (hiddenArgumentCtx (getHiding a))
+ (Common.Arg info $ unArg a)
+
+ simpleDecl = D.notSoNiceDeclaration
---------------------------------------------------------------------------
-- * Natural language
@@ -1008,7 +1213,7 @@ instance Verbalize Relevance where
Relevant -> "relevant"
Irrelevant -> "irrelevant"
NonStrict -> "shape-irrelevant"
- Forced -> __IMPOSSIBLE__
+ Forced{} -> __IMPOSSIBLE__
UnusedArg -> __IMPOSSIBLE__
-- | Indefinite article.
@@ -1021,3 +1226,6 @@ instance Verbalize a => Verbalize (Indefinite a) where
w@(c:cs) | c `elem` ['a','e','i','o'] -> "an " ++ w
| otherwise -> "a " ++ w
-- Aarne Ranta would whip me if he saw this.
+
+singPlural :: Sized a => a -> c -> c -> c
+singPlural xs singular plural = if size xs == 1 then singular else plural
diff --git a/src/full/Agda/TypeChecking/EtaContract.hs b/src/full/Agda/TypeChecking/EtaContract.hs
index 52d77df..4256fdd 100644
--- a/src/full/Agda/TypeChecking/EtaContract.hs
+++ b/src/full/Agda/TypeChecking/EtaContract.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards #-}
-- | Compute eta short normal forms.
module Agda.TypeChecking.EtaContract where
@@ -57,7 +57,9 @@ binAppView t = case t of
| otherwise = noApp
-- | Contracts all eta-redexes it sees without reducing.
-etaContract :: TermLike a => a -> TCM a
+{-# SPECIALIZE etaContract :: TermLike a => a -> TCM a #-}
+{-# SPECIALIZE etaContract :: TermLike a => a -> ReduceM a #-}
+etaContract :: (MonadReader TCEnv m, HasConstInfo m, TermLike a) => a -> m a
etaContract = traverseTermM etaOnce
{-# SPECIALIZE etaOnce :: Term -> TCM Term #-}
@@ -81,7 +83,7 @@ etaOnce v = case v of
isVar0 (Shared p) = __IMPOSSIBLE__ -- isVar0 (derefPtr p)
isVar0 (Var 0 []) = True
isVar0 (Level (Max [Plus 0 l])) = case l of
- NeutralLevel v -> isVar0 v
+ NeutralLevel _ v -> isVar0 v
UnreducedLevel v -> isVar0 v
BlockedLevel{} -> False
MetaLevel{} -> False
diff --git a/src/full/Agda/TypeChecking/Forcing.hs b/src/full/Agda/TypeChecking/Forcing.hs
index bd9862c..0a35070 100644
--- a/src/full/Agda/TypeChecking/Forcing.hs
+++ b/src/full/Agda/TypeChecking/Forcing.hs
@@ -1,32 +1,113 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-| A constructor argument is forced if it appears as pattern variable
+in an index of the target.
+
+For instance @x@ is forced in @sing@ and @n@ is forced in @zero@ and @suc@:
+
+@
+ data Sing {a}{A : Set a} : A -> Set where
+ sing : (x : A) -> Sing x
+
+ data Fin : Nat -> Set where
+ zero : (n : Nat) -> Fin (suc n)
+ suc : (n : Nat) (i : Fin n) -> Fin (suc n)
+@
+
+At runtime, forced constructor arguments may be erased as they can be
+recovered from dot patterns. In the epic backend,
+@
+ unsing : {A : Set} (x : A) -> Sing x -> A
+ unsing .x (sing x) = x
+@
+becomes
+@
+ unsing x sing = x
+@
+and
+@
+ proj : (n : Nat) (i : Fin n) -> Nat
+ proj .(suc n) (zero n) = n
+ proj .(suc n) (suc n i) = n
+@
+becomes
+@
+ proj (suc n) zero = n
+ proj (suc n) (suc i) = n
+@
+
+Forcing is a concept from pattern matching and thus builds on the
+concept of equality (I) used there (closed terms, extensional) which is
+different from the equality (II) used in conversion checking and the
+constraint solver (open terms, intensional).
+
+Up to issue 1441 (Feb 2015), the forcing analysis here relied on the
+wrong equality (II), considering type constructors as injective. This is
+unsound for Epic's program extraction, but ok if forcing is only used
+to decide which arguments to skip during conversion checking.
+
+From now on, forcing uses equality (I) and does not search for forced
+variables under type constructors. This may lose some savings during
+conversion checking. If this turns out to be a problem, the old
+forcing could be brought back, using a new modality @Skip@ to indicate
+that this is a relevant argument but still can be skipped during
+conversion checking as it is forced by equality (II).
+
+-}
module Agda.TypeChecking.Forcing where
+import Prelude hiding (elem, maximum)
+
import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+
+import Agda.Interaction.Options
import Agda.Syntax.Common
import Agda.Syntax.Internal
+
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Irrelevance
+import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
-import Agda.Utils.Size
+import Agda.TypeChecking.Conversion
+
+import Agda.Utils.Function
import Agda.Utils.Monad
-import Agda.Interaction.Options
+import Agda.Utils.Size
#include "undefined.h"
import Agda.Utils.Impossible
+-- | Given the type of a constructor (excluding the parameters),
+-- decide which arguments are forced.
+-- Update the relevance info in the domains accordingly.
+-- Precondition: the type is of the form @Γ → D vs@ and the @vs@
+-- are in normal form.
addForcingAnnotations :: Type -> TCM Type
addForcingAnnotations t =
ifM (not . optForcing <$> commandLineOptions)
(return t) $ do
+ -- Andreas, 2015-03-10 Normalization prevents Issue 1454.
-- t <- normalise t
- let TelV tel (El _ a) = telView' t
+ -- Andreas, 2015-03-28 Issue 1469: Normalization too costly.
+ -- Instantiation also fixes Issue 1454.
+ -- Note that normalization of s0 below does not help.
+ t <- instantiateFull t
+ let TelV tel (El s a) = telView' t
+ vs = case ignoreSharing a of
+ Def _ us -> us
+ _ -> __IMPOSSIBLE__
n = size tel
indexToLevel x = n - x - 1
- xs <- filter (>=0) . map indexToLevel <$> forcedVariables a
- let t' = force xs t
- reportSLn "tc.force" 10 $ unlines
+ -- Note: data parameters will be negative levels.
+ let xs = filter (>=0) $ map indexToLevel $ forcedVariables vs
+ let s0 = raise (0 - size tel) s
+ t' <- force s0 xs t
+ reportSLn "tc.force" 60 $ unlines
[ "Forcing analysis"
, " xs = " ++ show xs
, " t = " ++ show t
@@ -34,43 +115,36 @@ addForcingAnnotations t =
]
return t'
-forcedVariables :: Term -> TCM [Nat]
-forcedVariables t = case t of
- Var i [] -> return [i]
- Con _ vs -> forcedArgs vs
- Def d vs ->
- ifM (isInj d)
- (forcedElims vs)
- (return [])
- Pi a (NoAbs _ b) ->
- (++) <$> forcedVariables (unEl $ unDom a)
- <*> forcedVariables (unEl b)
- Pi a b -> (++) <$> forcedVariables (unEl $ unDom a)
- <*> (underBinder <$> forcedVariables (unEl $ absBody b))
- -- Sorts?
- _ -> return []
- where
- underBinder xs = [ x - 1 | x <- xs, x /= 0 ]
- forcedArgs vs = concat <$> mapM (forcedVariables . unArg) vs
- forcedElims es = concat <$> mapM (forcedVariables . unArg) (argsFromElims es)
- isInj d = do
- def <- getConstInfo d
- return $ case theDef def of
- Datatype{} -> True
- Record{} -> True
- -- Axiom{} -> True -- Postulates are not injective in general, right? /Olle 2011-05-05
- _ -> False
-
-force :: [Nat] -> Type -> Type
-force xs t = aux 0 t
+-- | Compute the pattern variables of a term or term-like thing.
+class ForcedVariables a where
+ forcedVariables :: a -> [Nat]
+
+instance (ForcedVariables a, Foldable t) => ForcedVariables (t a) where
+ forcedVariables = foldMap forcedVariables
+
+-- | Assumes that the term is in normal form.
+instance ForcedVariables Term where
+ forcedVariables t = case ignoreSharing t of
+ Var i [] -> [i]
+ 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
+-- @'Forced' 'Small'@.
+-- Counting left-to-right, starting with 0.
+-- Precondition: function type is exposed.
+force :: Sort -> [Nat] -> Type -> TCM Type
+force s0 xs t = loop 0 t
where
- m = maximum (-1:xs)
- aux i t | i > m = t
- aux i t = case ignoreSharingType t of
- El s (Pi a b) -> El s $ Pi (upd a) (fmap (aux (i + 1)) b)
+ m = maximum (-1:xs) -- number of domains to look at
+ loop i t | i > m = return t
+ loop i t = case ignoreSharingType t of
+ El s (Pi a b) -> do
+ a' <- if not (i `elem` xs) then return a else do
+ -- If the sort of the data type is >= the sort of the argument type
+ -- then the index is small, else big.
+ b <- ifM (tryConversion $ leqSort (getSort a) (raise i s0)) (return Small) (return Big)
+ return $ mapRelevance (composeRelevance $ Forced b) a
+ El s . Pi a' <$> traverse (loop $ i + 1) b
_ -> __IMPOSSIBLE__
- where
- upd a | i `elem` xs = a { domInfo = mapRelevance
- (composeRelevance Forced)
- (domInfo a) }
- | otherwise = a
diff --git a/src/full/Agda/TypeChecking/Free.hs b/src/full/Agda/TypeChecking/Free.hs
index 727dbcc..2ef0e98 100644
--- a/src/full/Agda/TypeChecking/Free.hs
+++ b/src/full/Agda/TypeChecking/Free.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
-- | Computing the free variables of a term.
--
@@ -280,6 +279,7 @@ instance Free Sort where
Type a -> freeVars' a
Prop -> mempty
Inf -> mempty
+ SizeUniv -> mempty
DLub s1 s2 -> weakly <$> freeVars' (s1, s2)
instance Free Level where
@@ -292,7 +292,7 @@ instance Free PlusLevel where
instance Free LevelAtom where
freeVars' l = case l of
MetaLevel _ vs -> flexible <$> freeVars' vs
- NeutralLevel v -> freeVars' v
+ NeutralLevel _ v -> freeVars' v
BlockedLevel _ v -> freeVars' v
UnreducedLevel v -> freeVars' v
diff --git a/src/full/Agda/TypeChecking/Implicit.hs b/src/full/Agda/TypeChecking/Implicit.hs
index 19d6473..52e0caf 100644
--- a/src/full/Agda/TypeChecking/Implicit.hs
+++ b/src/full/Agda/TypeChecking/Implicit.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-| Functions for inserting implicit arguments at the right places.
@@ -53,26 +53,6 @@ implicitNamedArgs n expand t0 = do
newMeta Instance = initializeIFSMeta
newMeta _ = __IMPOSSIBLE__
-{- UNUSED, BUT DONT REMOVE (Andreas, 2012-07-31)
-introImplicits :: (Hiding -> Bool) -> Type -> (Int -> Type -> TCM a) -> TCM a
-introImplicits expand t cont = do
- TelV tel t0 <- telViewUpTo' (-1) (expand . domHiding) t
- addCtxTel tel $ cont (size tel) t0
--}
-
-{- POINTLESS, NEEDS TO BE CONTINUATION-PASSING
--- | @introImplicits expand t@ introduces domain types of @t@
--- into the context, as long as @expand@ holds on them.
-introImplicits :: (Hiding -> Bool) -> Type -> TCM (Int, Type)
-introImplicits expand t = do
- t <- reduce t
- case unEl t of
- Pi dom@(Dom h rel a) b | expand h ->
- addCtxString (absName b) dom $ do
- mapFst (+1) <$> introImplicits expand (absBody b)
- _ -> return (0, t)
--}
-
---------------------------------------------------------------------------
data ImplicitInsertion
diff --git a/src/full/Agda/TypeChecking/Injectivity.hs b/src/full/Agda/TypeChecking/Injectivity.hs
index 38e632c..cac2f7f 100644
--- a/src/full/Agda/TypeChecking/Injectivity.hs
+++ b/src/full/Agda/TypeChecking/Injectivity.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Injectivity where
@@ -193,9 +193,9 @@ useInjectivity cmp a u v = do
, text " ps =" <+> prettyList (map (text . show) ps)
]
-- and this is the order the variables occur in the patterns
- let ms' = permute (invertP __IMPOSSIBLE__ $ compactP perm) ms
- let sub = parallelS (reverse ms)
- margs <- runReaderT (evalStateT (mapM metaElim ps) ms') sub
+ let msAux = permute (invertP __IMPOSSIBLE__ $ compactP perm) ms
+ let sub = parallelS (reverse ms)
+ margs <- runReaderT (evalStateT (mapM metaElim ps) msAux) sub
reportSDoc "tc.inj.invert" 20 $ vcat
[ text "inversion"
, nest 2 $ vcat
diff --git a/src/full/Agda/TypeChecking/InstanceArguments.hs b/src/full/Agda/TypeChecking/InstanceArguments.hs
index d689d74..83fca42 100644
--- a/src/full/Agda/TypeChecking/InstanceArguments.hs
+++ b/src/full/Agda/TypeChecking/InstanceArguments.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
module Agda.TypeChecking.InstanceArguments where
import Control.Applicative
@@ -13,11 +17,13 @@ import Agda.Syntax.Position
import Agda.Syntax.Scope.Base
import Agda.Syntax.Internal as I
+import Agda.TypeChecking.Errors ()
+import Agda.TypeChecking.Implicit (implicitArgs)
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Pretty
-import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Reduce
+import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import {-# SOURCE #-} Agda.TypeChecking.Constraints
@@ -29,6 +35,7 @@ import Agda.Utils.Except ( MonadError(catchError, throwError), runExceptT )
import Agda.Utils.Lens
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Pretty (prettyShow)
#include "undefined.h"
import Agda.Utils.Impossible
@@ -120,92 +127,92 @@ initializeIFSMeta s t = do
-- its type again.
findInScope :: MetaId -> Maybe Candidates -> TCM ()
findInScope m Nothing = do
- reportSLn "tc.instance" 20 $ "The type of the FindInScope constraint isn't known, trying to find it again."
- t <- getMetaType m
- cands <- initialIFSCandidates t
- case cands of
- Nothing -> addConstraint $ FindInScope m Nothing
- Just {} -> findInScope m cands
+ -- 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" 20 $ "The type of the FindInScope constraint isn't known, trying to find it again."
+ t <- getMetaType m
+ cands <- initialIFSCandidates t
+ case cands of
+ Nothing -> addConstraint $ FindInScope m Nothing
+ Just {} -> findInScope m cands
findInScope m (Just cands) = whenJustM (findInScope' m cands) $ addConstraint . FindInScope m . Just
-- | Result says whether we need to add constraint, and if so, the set of
-- remaining candidates.
findInScope' :: MetaId -> Candidates -> TCM (Maybe Candidates)
findInScope' m cands = ifM (isFrozen m) (return (Just cands)) $ do
- -- Andreas, 2013-12-28 issue 1003:
- -- If instance meta is already solved, simply discard the constraint.
- ifM (isInstantiatedMeta m) (return Nothing) $ do
- reportSLn "tc.instance" 15 $
- "findInScope 2: constraint: " ++ show m ++ "; candidates left: " ++ show (length cands)
- t <- normalise =<< getMetaTypeInContext m
- reportSDoc "tc.instance" 15 $ text "findInScope 3: t =" <+> prettyTCM t
- reportSLn "tc.instance" 70 $ "findInScope 3: t: " ++ show t
+ -- Andreas, 2013-12-28 issue 1003:
+ -- If instance meta is already solved, simply discard the constraint.
+ ifM (isInstantiatedMeta 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
- -- If there are recursive instances, it's not safe to instantiate
- -- metavariables in the goal, so we freeze them before checking candidates.
- -- Metas that are rigidly constrained need not be frozen.
- isRec <- orM $ map (isRecursive . unEl . snd) cands
- let shouldFreeze rigid m
- | elem m rigid = return False
- | otherwise = not <$> isFrozen m
- metas <- if not isRec then return [] else do
- rigid <- rigidlyConstrainedMetas
- filterM (shouldFreeze rigid) (allMetas t)
- forM_ metas $ \ m -> updateMetaVar m $ \ mv -> mv { mvFrozen = Frozen }
- cands <- checkCandidates m t cands
- reportSLn "tc.instance" 15 $
- "findInScope 4: cands left: " ++ show (length cands)
- unfreezeMeta metas
- case cands of
+ setCurrentRange mv $ do
+ reportSLn "tc.instance" 15 $
+ "findInScope 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)
+ t <- normalise =<< getMetaTypeInContext m
+ reportSDoc "tc.instance" 15 $ text "findInScope 3: t =" <+> prettyTCM t
+ reportSLn "tc.instance" 70 $ "findInScope 3: t: " ++ show t
+ -- If there are recursive instances, it's not safe to instantiate
+ -- metavariables in the goal, so we freeze them before checking candidates.
+ -- Metas that are rigidly constrained need not be frozen.
+ isRec <- orM $ map (isRecursive . unEl . snd) cands
+ let shouldFreeze rigid m
+ | elem m rigid = return False
+ | otherwise = not <$> isFrozen m
+ metas <- if not isRec then return [] else do
+ rigid <- rigidlyConstrainedMetas
+ filterM (shouldFreeze rigid) (allMetas t)
+ forM_ metas $ \ m -> updateMetaVar m $ \ mv -> mv { mvFrozen = Frozen }
+ cands <- checkCandidates m t cands
+ reportSLn "tc.instance" 15 $
+ "findInScope 4: cands left: " ++ show (length cands)
+ unfreezeMeta metas
+ case cands of
- [] -> do
- reportSDoc "tc.instance" 15 $
- text "findInScope 5: not a single candidate found..."
- typeError $ IFSNoCandidateInScope t
+ [] -> do
+ reportSDoc "tc.instance" 15 $
+ text "findInScope 5: not a single candidate found..."
+ typeError $ IFSNoCandidateInScope t
- [(term, t')] -> do
- reportSDoc "tc.instance" 15 $ vcat
- [ text "findInScope 5: found one candidate"
- , nest 2 $ prettyTCM term
- , text "of type " <+> prettyTCM t'
- , text "for type" <+> prettyTCM t
- ]
+ [(term, t')] -> do
+ reportSDoc "tc.instance" 15 $ vcat
+ [ text "findInScope 5: found one candidate"
+ , nest 2 $ prettyTCM term
+ , text "of type " <+> prettyTCM t'
+ , text "for type" <+> prettyTCM t
+ ]
- -- if t' takes initial hidden arguments, apply them
- ca <- liftTCM $ runExceptT $ checkArguments ExpandLast ExpandInstanceArguments (getRange mv) [] t' t
- case ca of
- Left _ -> __IMPOSSIBLE__
- Right (args, t'') -> do
- -- @args@ are the hidden arguments @t'@ takes, @t''@ is @t' `apply` args@
-{- TODO
- (args, t'') <- implicitArgs (...) t'
- do
--}
- leqType t'' t
- ctxArgs <- getContextArgs
- v <- (`applyDroppingParameters` args) =<< reduce term
- assignV DirEq m ctxArgs v
- reportSDoc "tc.instance" 10 $ vcat
- [ text "solved by instance search:"
- , prettyTCM m <+> text ":=" <+> prettyTCM v
- ]
- return Nothing
+ -- If t' takes initial hidden and instance arguments, apply them.
+ -- Taking also instance arguments facilitates recursive instance search.
+ (args, t'') <- implicitArgs (-1) notVisible t'
+ leqType t'' t
+ ctxArgs <- getContextArgs
+ v <- (`applyDroppingParameters` args) =<< reduce term
+ assignV DirEq m ctxArgs v
+ reportSDoc "tc.instance" 10 $ vcat
+ [ text "solved by instance search:"
+ , prettyTCM m <+> text ":=" <+> prettyTCM v
+ ]
+ return Nothing
- cs -> do
- reportSDoc "tc.instance" 15 $
- text ("findInScope 5: more than one candidate found: ") <+>
- prettyTCM (List.map fst cs)
- return (Just cs)
- where
- -- | Check whether a type is a function type with an instance domain.
- isRecursive :: Term -> TCM Bool
- isRecursive v = do
- v <- reduce v
- case ignoreSharing v of
- Pi (Dom info _) t ->
- if getHiding info == Instance then return True else
- isRecursive $ unEl $ unAbs t
- _ -> return False
+ cs -> do
+ reportSDoc "tc.instance" 15 $
+ text ("findInScope 5: more than one candidate found: ") <+>
+ prettyTCM (List.map fst cs)
+ return (Just cs)
+ where
+ -- | Check whether a type is a function type with an instance domain.
+ isRecursive :: Term -> TCM Bool
+ isRecursive v = do
+ v <- reduce v
+ case ignoreSharing v of
+ Pi (Dom info _) t ->
+ if getHiding info == Instance then return True else
+ isRecursive $ unEl $ unAbs t
+ _ -> return False
-- | A meta _M is rigidly constrained if there is a constraint _M us == D vs,
-- for inert D. Such metas can safely be instantiated by recursive instance
@@ -257,48 +264,53 @@ checkCandidates m t cands = localTCState $ disableDestructiveUpdate $ do
dropSameCandidates cands
where
checkCandidateForMeta :: MetaId -> Type -> Term -> Type -> TCM Bool
- checkCandidateForMeta m t term t' =
- verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ show m) $ do
- liftTCM $ flip catchError handle $ do
- reportSLn "tc.instance" 70 $ " t: " ++ show t ++ "\n t':" ++ show t' ++ "\n term: " ++ show term ++ "."
- reportSDoc "tc.instance" 20 $ vcat
- [ text "checkCandidateForMeta"
- , text "t =" <+> prettyTCM t
- , text "t' =" <+> prettyTCM t'
- , text "term =" <+> prettyTCM term
- ]
- localTCState $ do
- -- domi: we assume that nothing below performs direct IO (except
- -- for logging and such, I guess)
- ca <- runExceptT $ checkArguments ExpandLast ExpandInstanceArguments noRange [] t' t
- case ca of
- Left _ -> return False
- Right (args, t'') -> do
+ checkCandidateForMeta m t 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
+ setCurrentRange mv $ do
+ verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ prettyShow m) $ do
+ liftTCM $ flip catchError handle $ do
+ reportSLn "tc.instance" 70 $ " t: " ++ show t ++ "\n t':" ++ show t' ++ "\n term: " ++ show term ++ "."
+ reportSDoc "tc.instance" 20 $ vcat
+ [ text "checkCandidateForMeta"
+ , text "t =" <+> prettyTCM t
+ , text "t' =" <+> prettyTCM t'
+ , text "term =" <+> prettyTCM term
+ ]
+ -- domi: we assume that nothing below performs direct IO
+ -- (except for logging and such, I guess)
+ localTCState $ do
+
+ -- Apply hidden and instance arguments (recursive inst. search!).
+ (args, t'') <- implicitArgs (-1) notVisible t'
+
reportSDoc "tc.instance" 20 $
text "instance search: checking" <+> prettyTCM t''
<+> text "<=" <+> prettyTCM t
-- if constraints remain, we abort, but keep the candidate
flip (ifNoConstraints_ $ leqType t'' t) (const $ return True) $ do
- --tel <- getContextTelescope
- ctxArgs <- getContextArgs
- v <- (`applyDroppingParameters` args) =<< reduce term
- reportSDoc "tc.instance" 15 $ vcat
- [ text "instance search: attempting"
- , nest 2 $ prettyTCM m <+> text ":=" <+> prettyTCM v
- ]
- assign DirEq m ctxArgs v
--- assign m ctxArgs (term `apply` args)
- -- make a pass over constraints, to detect cases where some are made
- -- unsolvable by the assignment, but don't do this for FindInScope's
- -- to prevent loops. We currently also ignore UnBlock constraints
- -- to be on the safe side.
- solveAwakeConstraints' True
- return True
- where
- handle err = do
- reportSDoc "tc.instance" 50 $
- text "assignment failed:" <+> prettyTCM err
- return False
+ ctxArgs <- getContextArgs
+ v <- (`applyDroppingParameters` args) =<< reduce term
+ reportSDoc "tc.instance" 15 $ vcat
+ [ text "instance search: attempting"
+ , nest 2 $ prettyTCM m <+> text ":=" <+> prettyTCM v
+ ]
+ assign DirEq m ctxArgs v
+ -- assign m ctxArgs (term `apply` args)
+ -- make a pass over constraints, to detect cases where some are made
+ -- unsolvable by the assignment, but don't do this for FindInScope's
+ -- to prevent loops. We currently also ignore UnBlock constraints
+ -- to be on the safe side.
+ solveAwakeConstraints' True
+ return True
+ where
+ handle :: TCErr -> TCM Bool
+ handle err = do
+ reportSDoc "tc.instance" 50 $
+ text "assignment failed:" <+> prettyTCM err
+ return False
+
isIFSConstraint :: Constraint -> Bool
isIFSConstraint FindInScope{} = True
isIFSConstraint UnBlock{} = True -- otherwise test/fail/Issue723 loops
diff --git a/src/full/Agda/TypeChecking/Irrelevance.hs b/src/full/Agda/TypeChecking/Irrelevance.hs
index d2d0362..5b5db2d 100644
--- a/src/full/Agda/TypeChecking/Irrelevance.hs
+++ b/src/full/Agda/TypeChecking/Irrelevance.hs
@@ -20,14 +20,14 @@ import Agda.Utils.QuickCheck
import Agda.Utils.TestHelpers
-- | data 'Relevance'
--- see 'Agda.Syntax.Common'
+-- see "Agda.Syntax.Common".
irrelevantOrUnused :: Relevance -> Bool
irrelevantOrUnused Irrelevant = True
irrelevantOrUnused UnusedArg = True
irrelevantOrUnused NonStrict = False
irrelevantOrUnused Relevant = False
-irrelevantOrUnused Forced = False
+irrelevantOrUnused Forced{} = False
-- | @unusableRelevance rel == True@ iff we cannot use a variable of @rel@.
unusableRelevance :: Relevance -> Bool
@@ -42,8 +42,9 @@ composeRelevance r r' =
(_, Irrelevant) -> Irrelevant
(NonStrict, _) -> NonStrict
(_, NonStrict) -> NonStrict
- (Forced, _) -> Forced
- (_, Forced) -> Forced
+ (Forced b, Forced b') -> Forced (max b b') -- prefer Big over Small
+ (Forced b, _) -> Forced b
+ (_, Forced b) -> Forced b
(UnusedArg, _) -> UnusedArg
(_, UnusedArg) -> UnusedArg
(Relevant, Relevant) -> Relevant
@@ -58,16 +59,17 @@ inverseComposeRelevance r x =
case (r, x) of
(Relevant, x) -> x -- going to relevant arg.: nothing changes
_ | r == x -> Relevant -- because Relevant is comp.-neutral
+ (Forced{}, Forced{}) -> Relevant -- same, but (==) does not ignore Big
(UnusedArg, x) -> x
- (Forced, UnusedArg) -> Relevant
- (Forced, x) -> x
+ (Forced{}, UnusedArg) -> Relevant
+ (Forced{}, x) -> x
(Irrelevant, x) -> Relevant -- going irrelevant: every thing usable
(_, Irrelevant) -> Irrelevant -- otherwise: irrelevant things remain unusable
(NonStrict, _) -> Relevant -- but @NonStrict@s become usable
-- | For comparing @Relevance@ ignoring @Forced@ and @UnusedArg@.
ignoreForced :: Relevance -> Relevance
-ignoreForced Forced = Relevant
+ignoreForced Forced{} = Relevant
ignoreForced UnusedArg = Relevant
ignoreForced Relevant = Relevant
ignoreForced NonStrict = NonStrict
@@ -129,7 +131,7 @@ applyRelevanceToContext :: Relevance -> TCM a -> TCM a
applyRelevanceToContext rel =
case rel of
Relevant -> id
- Forced -> id
+ Forced{} -> id
_ -> local $ \ e -> e
{ envContext = modifyContextEntries (inverseApplyRelevance rel) (envContext e)
, envLetBindings = Map.map
diff --git a/src/full/Agda/TypeChecking/Level.hs b/src/full/Agda/TypeChecking/Level.hs
index dc934a2..fa1baa0 100644
--- a/src/full/Agda/TypeChecking/Level.hs
+++ b/src/full/Agda/TypeChecking/Level.hs
@@ -145,9 +145,9 @@ levelView' a = do
mkAtom a = do
b <- reduceB' a
return $ case ignoreSharing <$> b of
- NotBlocked (MetaV m as) -> atom $ MetaLevel m as
- NotBlocked _ -> atom $ NeutralLevel (ignoreBlocking b)
- Blocked m _ -> atom $ BlockedLevel m (ignoreBlocking b)
+ NotBlocked _ (MetaV m as) -> atom $ MetaLevel m as
+ NotBlocked r _ -> atom $ NeutralLevel r $ ignoreBlocking b
+ Blocked m _ -> atom $ BlockedLevel m $ ignoreBlocking b
atom a = Max [Plus 0 a]
diff --git a/src/full/Agda/TypeChecking/MetaVars.hs b/src/full/Agda/TypeChecking/MetaVars.hs
index fbf76e9..223328a 100644
--- a/src/full/Agda/TypeChecking/MetaVars.hs
+++ b/src/full/Agda/TypeChecking/MetaVars.hs
@@ -1,9 +1,8 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RelaxedPolyRec #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RelaxedPolyRec #-}
+{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.MetaVars where
@@ -54,6 +53,7 @@ import Agda.Utils.Monad
import Agda.Utils.Size
import Agda.Utils.Tuple
import Agda.Utils.Permutation
+import Agda.Utils.Pretty (prettyShow)
import qualified Agda.Utils.VarSet as Set
#include "undefined.h"
@@ -70,7 +70,7 @@ findIdx vs v = findIndex (==v) (reverse vs)
-- | Check whether a meta variable is a place holder for a blocked term.
isBlockedTerm :: MetaId -> TCM Bool
isBlockedTerm x = do
- reportSLn "tc.meta.blocked" 12 $ "is " ++ show x ++ " a blocked term? "
+ reportSLn "tc.meta.blocked" 12 $ "is " ++ prettyShow x ++ " a blocked term? "
i <- mvInstantiation <$> lookupMeta x
let r = case i of
BlockedConst{} -> True
@@ -110,7 +110,7 @@ assignTerm x tel v = do
-- | Skip frozen check. Used for eta expanding frozen metas.
assignTerm' :: MetaId -> [I.Arg ArgName] -> Term -> TCM ()
assignTerm' x tel v = do
- reportSLn "tc.meta.assign" 70 $ show x ++ " := " ++ show v ++ "\n in " ++ show tel
+ reportSLn "tc.meta.assign" 70 $ prettyShow x ++ " := " ++ show v ++ "\n in " ++ show tel
-- verify (new) invariants
whenM (not <$> asks envAssignMetas) __IMPOSSIBLE__
@@ -133,7 +133,7 @@ assignTerm' x tel v = do
modifyMetaStore $ ins x i
etaExpandListeners x
wakeupConstraints x
- reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ show x
+ reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ prettyShow x
where
metaInstance tel v = InstV tel v
ins x i store = Map.adjust (inst i) x store
@@ -201,7 +201,7 @@ newIFSMetaCtx s t vs cands = do
let perm = idP (size tel)
x <- newMeta' OpenIFS i normalMetaPriority perm (HasType () t)
reportSDoc "tc.meta.new" 50 $ fsep
- [ nest 2 $ text (show x) <+> text ":" <+> prettyTCM t
+ [ nest 2 $ pretty x <+> text ":" <+> prettyTCM t
]
addConstraint $ FindInScope x cands
return $ MetaV x $ map Apply vs
@@ -241,7 +241,7 @@ newValueMetaCtx' b t vs = do
reportSDoc "tc.meta.new" 50 $ fsep
[ text "new meta:"
, nest 2 $ prettyTCM vs <+> text "|-"
- , nest 2 $ text (show x) <+> text ":" <+> prettyTCM t
+ , nest 2 $ pretty x <+> text ":" <+> prettyTCM t
]
etaExpandMetaSafe x
-- Andreas, 2012-09-24: for Metas X : Size< u add constraint X+1 <= u
@@ -362,7 +362,8 @@ postponeTypeCheckingProblem_ p = do
postponeTypeCheckingProblem p (unblock p)
where
unblock (CheckExpr _ t) = unblockedTester t
- unblock (CheckArgs _ _ _ _ t _ _) = unblockedTester t
+ unblock (CheckArgs _ _ _ _ t _ _) = unblockedTester t -- The type of the head of the application.
+ unblock (CheckLambda _ _ t) = unblockedTester t
-- | Create a postponed type checking problem @e : t@ that waits for conditon
-- @unblock@. A new meta is created in the current context that has as
@@ -393,9 +394,11 @@ postponeTypeCheckingProblem p unblock = do
addConstraint (UnBlock m)
return v
+-- | Type of the term that is produced by solving the 'TypeCheckingProblem'.
problemType :: TypeCheckingProblem -> Type
-problemType (CheckExpr _ t) = t
-problemType (CheckArgs _ _ _ _ _ t _) = t
+problemType (CheckExpr _ t ) = t
+problemType (CheckArgs _ _ _ _ _ t _ ) = t -- The target type of the application.
+problemType (CheckLambda _ _ t ) = t
-- | Eta expand metavariables listening on the current meta.
etaExpandListeners :: MetaId -> TCM ()
@@ -437,7 +440,7 @@ allMetaKinds = [minBound .. maxBound]
-- Don't do anything if the metavariable is a blocked term.
etaExpandMeta :: [MetaKind] -> MetaId -> TCM ()
etaExpandMeta kinds m = whenM (isEtaExpandable m) $ do
- verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ show m) $ do
+ verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ prettyShow m) $ do
let waitFor x = do
reportSDoc "tc.meta.eta" 20 $ do
text "postponing eta-expansion of meta variable" <+>
@@ -466,7 +469,10 @@ etaExpandMeta kinds m = whenM (isEtaExpandable m) $ do
inTopContext $ do
verboseS "tc.meta.eta" 15 $ do
du <- prettyTCM u
- reportSLn "tc.meta.eta" 15 $ "eta expanding: " ++ show m ++ " --> " ++ show du
+ reportSDoc "tc.meta.eta" 15 $ sep
+ [ text "eta expanding: " <+> pretty m <+> text " --> "
+ , nest 2 $ prettyTCM u
+ ]
-- Andreas, 2012-03-29: No need for occurrence check etc.
-- we directly assign the solution for the meta
-- 2012-05-23: We also bypass the check for frozen.
@@ -639,7 +645,7 @@ assign dir x args v = do
reportSLn "tc.meta.assign" 15 "passed occursCheck"
verboseS "tc.meta.assign" 30 $ do
- let n = size v
+ let n = termSize v
when (n > 200) $ reportSDoc "tc.meta.assign" 30 $
sep [ text "size" <+> text (show n)
-- , nest 2 $ text "type" <+> prettyTCM t
@@ -699,6 +705,7 @@ assign dir x args v = do
else "failed"
patternViolation
+{- UNUSED
-- | When faced with @_X us == D vs@ for an inert D we can solve this by
-- @_X xs := D _Ys@ with new constraints @_Yi us == vi@. This is important
-- for instance arguments, where knowing the head D might enable progress.
@@ -786,8 +793,8 @@ attemptInertRHSImprovement m args v = do
patternViolation
| otherwise = return ()
case fmap ignoreSharing b of
- Blocked{} -> notNeutral v
- NotBlocked v ->
+ Blocked{} -> notNeutral v
+ NotBlocked r v -> -- Andrea(s) 2014-12-06 can r be useful?
case v of
Var x _ -> checkRHS (Var x [])
Def f _ -> checkRHS (Def f [])
@@ -801,7 +808,7 @@ attemptInertRHSImprovement m args v = do
Lam{} -> notNeutral v
ExtLam{} -> __IMPOSSIBLE__
Shared{} -> __IMPOSSIBLE__
-
+-- END UNUSED -}
-- | @assignMeta m x t ids u@ solves @x ids = u@ for meta @x@ of type @t@,
-- where term @u@ lives in a context of length @m@.
@@ -1020,38 +1027,13 @@ checkLinearity ids0 = do
(return [p])
(throwError ())
-{- UNNECESSARILY COMPLICATED
--- | Turn non-det substitution into proper substitution, if possible.
--- Writes a list of non-linear variables that need to be pruned.
--- If a non-linear variable is @elemFVs@, hence, not prunable,
--- the error is thrown.
-checkLinearity :: (Nat -> Bool) -> SubstCand -> ErrorT () (WriterT [Nat] TCM) SubstCand
-checkLinearity elemFVs ids0 = do
- let ids = sortBy (compare `on` fst) ids0
- let grps = groupOn fst ids
- concat <$> mapM makeLinear grps
- where
- -- | Non-determinism can be healed if type is singleton. [Issue 593]
- -- (Same as for irrelevance.)
- makeLinear :: SubstCand -> ErrorT () TCM SubstCand
- makeLinear [] = __IMPOSSIBLE__
- makeLinear grp@[_] = return grp
- makeLinear grp@(p@(i,t) : _) = do
- ifM ((Right True ==) <$> do isSingletonTypeModuloRelevance =<< typeOfBV i)
- {- then -} (return [p])
- {- else -} $ do
- ifM (elemFVs i)
- {- then -} (throwError ()) -- non-prunable non-linear var
- {- else -} (tell [i] >> return grp) -- possibly prunable non-lin var
--}
-
-- Intermediate result in the following function
type Res = [(I.Arg Nat, Term)]
-- | Exceptions raised when substitution cannot be inverted.
data InvertExcept
= CantInvert -- ^ Cannot recover.
- | NeutralArg -- ^ A neutral arg: can't invert, but maybe prune.
+ | NeutralArg -- ^ A potentially neutral arg: can't invert, but can try pruning.
| ProjectedVar Int [QName] -- ^ Try to eta-expand var to remove projs.
instance Error InvertExcept where
@@ -1100,20 +1082,13 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
case isRC of
Just (_, Record{ recFields = fs })
| length fs == length vs -> do
- let aux (Arg _ v) (Arg info' f) =
- (Arg (ArgInfo { argInfoColors = argInfoColors info -- TODO guilhem
- , argInfoHiding = min (argInfoHiding info)
- (argInfoHiding info')
- , argInfoRelevance = max (argInfoRelevance info)
- (argInfoRelevance info')
- })
- v,) -- OLD: (stripDontCare v),
- $ t `applyE` [Proj f]
+ let aux (Arg _ v) (Arg info' f) = (Arg ai v,) $ t `applyE` [Proj f] where
+ ai = ArgInfo
+ { argInfoColors = argInfoColors info -- TODO guilhem
+ , argInfoHiding = min (getHiding info) (getHiding info')
+ , argInfoRelevance = max (getRelevance info) (getRelevance info')
+ }
res <- loop $ zipWith aux vs fs
--- Andreas, 2013-09-22, applyDef not needed after all
--- since f (because taken from recFields) is the original record projection.
--- <$> do liftTCM $ applyDef f (defaultArg t)
--- res <- loop =<< zipWithM aux vs fs
return $ res `append` vars
| otherwise -> fallback
Just _ -> __IMPOSSIBLE__
@@ -1127,9 +1102,9 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
Arg _ DontCare{} -> return vars
-- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure
- -- from those that can only put somewhere as a whole ==> return Nothing
+ -- from those that can only put somewhere as a whole ==> neutralArg
Arg _ Var{} -> neutralArg
- Arg _ Def{} -> failure
+ Arg _ Def{} -> neutralArg -- Note that this Def{} is in normal form and might be prunable.
Arg _ Lam{} -> failure
Arg _ Lit{} -> failure
Arg _ MetaV{} -> failure
diff --git a/src/full/Agda/TypeChecking/MetaVars/Mention.hs b/src/full/Agda/TypeChecking/MetaVars/Mention.hs
index f032dbc..b3ae8b7 100644
--- a/src/full/Agda/TypeChecking/MetaVars/Mention.hs
+++ b/src/full/Agda/TypeChecking/MetaVars/Mention.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
module Agda.TypeChecking.MetaVars.Mention where
@@ -43,7 +42,7 @@ instance MentionsMeta LevelAtom where
MetaLevel m vs -> x == m || mentionsMeta x vs
BlockedLevel m _ -> x == m -- if it's blocked on a different meta it doesn't matter if it mentions the meta somewhere else
UnreducedLevel l -> mentionsMeta x l
- NeutralLevel l -> mentionsMeta x l
+ NeutralLevel _ l -> mentionsMeta x l
instance MentionsMeta Type where
mentionsMeta x (El s t) = mentionsMeta x (s, t)
@@ -53,6 +52,7 @@ instance MentionsMeta Sort where
Type l -> mentionsMeta x l
Prop -> False
Inf -> False
+ SizeUniv -> False
DLub s1 s2 -> mentionsMeta x (s1, s2)
instance MentionsMeta t => MentionsMeta (Abs t) where
diff --git a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
index c0ee637..dd34b3d 100644
--- a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
+++ b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
@@ -1,6 +1,18 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+{- | The occurs check for unification. Does pruning on the fly.
+
+ When hitting a meta variable:
+
+ - Compute flex/rigid for its arguments.
+ - Compare to allowed variables.
+ - Mark arguments with rigid occurrences of disallowed variables for deletion.
+ - Attempt to delete marked arguments.
+ - We don't need to check for success, we can just continue occurs checking.
+-}
module Agda.TypeChecking.MetaVars.Occurs where
@@ -9,8 +21,10 @@ import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
+import Data.Foldable (foldMap)
import Data.List
import Data.Maybe
+import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
@@ -38,6 +52,7 @@ import Agda.Utils.List (takeWhileJust)
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Permutation
+import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Size
import qualified Agda.Utils.VarSet as VarSet
@@ -114,7 +129,7 @@ defArgs NoUnfold _ = Flex
defArgs YesUnfold ctx = weakly ctx
unfold :: UnfoldStrategy -> Term -> TCM (Blocked Term)
-unfold NoUnfold v = NotBlocked <$> instantiate v
+unfold NoUnfold v = notBlocked <$> instantiate v
unfold YesUnfold v = reduceB v
-- | Leave the top position.
@@ -166,7 +181,9 @@ class Occurs t where
-- | When assigning @m xs := v@, check that @m@ does not occur in @v@
-- and that the free variables of @v@ are contained in @xs@.
-occursCheck :: MetaId -> Vars -> Term -> TCM Term
+occursCheck
+ :: (Occurs a, InstantiateFull a, PrettyTCM a)
+ => MetaId -> Vars -> a -> TCM a
occursCheck m xs v = liftTCM $ do
mv <- lookupMeta m
initOccursCheck mv
@@ -180,19 +197,19 @@ occursCheck m xs v = liftTCM $ do
TypeError _ cl -> case clValue cl of
MetaOccursInItself{} ->
typeError . GenericError . show =<<
- fsep [ text ("Refuse to construct infinite term by instantiating " ++ show m ++ " to")
+ fsep [ text ("Refuse to construct infinite term by instantiating " ++ prettyShow m ++ " to")
, prettyTCM =<< instantiateFull v
]
MetaCannotDependOn _ _ i ->
ifM (isSortMeta m `and2M` (not <$> hasUniversePolymorphism))
( typeError . GenericError . show =<<
- fsep [ text ("Cannot instantiate the metavariable " ++ show m ++ " to")
+ fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to")
, prettyTCM v
, text "since universe polymorphism is disabled"
]
) {- else -}
( typeError . GenericError . show =<<
- fsep [ text ("Cannot instantiate the metavariable " ++ show m ++ " to solution")
+ fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")
, prettyTCM v
, text "since it contains the variable"
, enterClosure cl $ \_ -> prettyTCM (Var i [])
@@ -208,13 +225,13 @@ instance Occurs Term where
-- occurs' ctx $ ignoreBlocking v -- fails test/succeed/DontPruneBlocked
case v of
-- Don't fail on blocked terms or metas
- NotBlocked v -> occurs' ctx v
+ NotBlocked _ v -> occurs' ctx v
-- Blocked _ v@MetaV{} -> occurs' ctx v -- does not help with issue 856
Blocked _ v -> occurs' Flex v
where
occurs' ctx v = do
reportSDoc "tc.meta.occurs" 45 $
- text ("occursCheck " ++ show m ++ " (" ++ show ctx ++ ") of ") <+> prettyTCM v
+ text ("occursCheck " ++ prettyShow m ++ " (" ++ show ctx ++ ") of ") <+> prettyTCM v
reportSDoc "tc.meta.occurs" 70 $
nest 2 $ text $ show v
case v of
@@ -253,11 +270,10 @@ instance Occurs Term where
-- I guess the error was there from times when occurrence check
-- was done after the "lhs=linear variables" check, but now
-- occurrence check comes first.
- {-
- when (m == m') $ if ctx == Top then patternViolation else
- abort ctx $ MetaOccursInItself m'
- -}
- when (m == m') $ patternViolation' 50 $ "occursCheck failed: Found " ++ show m
+ -- WAS:
+ -- when (m == m') $ if ctx == Top then patternViolation else
+ -- abort ctx $ MetaOccursInItself m'
+ when (m == m') $ patternViolation' 50 $ "occursCheck failed: Found " ++ prettyShow m
-- The arguments of a meta are in a flexible position
(MetaV m' <$> occurs red Flex m xs es) `catchError` \err -> do
@@ -270,10 +286,9 @@ instance Occurs Term where
-- flexible occurrences (if not already in a flexible context)
PatternErr{} | ctx /= Flex -> do
reportSLn "tc.meta.kill" 20 $
- "oops, pattern violation for " ++ show m'
+ "oops, pattern violation for " ++ prettyShow m'
-- Andreas, 2014-03-02, see issue 1070:
-- Do not prune when meta is projected!
- -- WAS: let vs = takeWhileJust isApplyElim es
caseMaybe (allApplyElims es) (throwError err) $ \ vs -> do
killResult <- prune m' vs (takeRelevant xs)
if (killResult == PrunedEverything)
@@ -307,7 +322,7 @@ instance Occurs Term where
Sort s -> metaOccurs m s
Shared p -> metaOccurs m $ derefPtr p
ExtLam{} -> __IMPOSSIBLE__
- MetaV m' vs | m == m' -> patternViolation' 50 $ "Found occurrence of " ++ show m
+ MetaV m' vs | m == m' -> patternViolation' 50 $ "Found occurrence of " ++ prettyShow m
| otherwise -> metaOccurs m vs
instance Occurs QName where
@@ -361,16 +376,16 @@ instance Occurs LevelAtom where
MetaLevel m' args -> do
MetaV m' args <- ignoreSharing <$> occurs red ctx m xs (MetaV m' args)
return $ MetaLevel m' args
- NeutralLevel v -> NeutralLevel <$> occurs red ctx m xs v
+ NeutralLevel r v -> NeutralLevel r <$> occurs red ctx m xs v
BlockedLevel m' v -> BlockedLevel m' <$> occurs red Flex m xs v
UnreducedLevel v -> UnreducedLevel <$> occurs red ctx m xs v
metaOccurs m l = do
l <- instantiate l
case l of
- MetaLevel m' args -> metaOccurs m (MetaV m' args)
- NeutralLevel v -> metaOccurs m v
- BlockedLevel m v -> metaOccurs m v
+ MetaLevel m' args -> metaOccurs m $ MetaV m' args
+ NeutralLevel _ v -> metaOccurs m v
+ BlockedLevel _ v -> metaOccurs m v
UnreducedLevel v -> metaOccurs m v
@@ -389,6 +404,7 @@ instance Occurs Sort where
Type a -> Type <$> occurs red ctx m xs a
Prop -> return s'
Inf -> return s'
+ SizeUniv -> return s'
metaOccurs m s = do
s <- instantiate s
@@ -397,6 +413,7 @@ instance Occurs Sort where
Type a -> metaOccurs m a
Prop -> return ()
Inf -> return ()
+ SizeUniv -> return ()
instance Occurs a => Occurs (Elim' a) where
occurs red ctx m xs e@Proj{} = return e
@@ -452,20 +469,13 @@ prune m' vs xs = do
reportSDoc "tc.meta.kill" 10 $ vcat
[ text "attempting kills"
, nest 2 $ vcat
- [ text "m' =" <+> text (show m')
- , text "xs =" <+> text (show xs)
+ [ text "m' =" <+> pretty m'
+ -- , text "xs =" <+> text (show xs)
+ , text "xs =" <+> prettyList (map (prettyTCM . var) xs)
, text "vs =" <+> prettyList (map prettyTCM vs)
, text "kills =" <+> text (show kills)
]
]
-{- Andreas, 2011-05-11 REDUNDANT CODE
- reportSLn "tc.meta.kill" 20 $
- "attempting to prune meta " ++ show m' ++ "\n" ++
- " kills: " ++ show kills
- if not (or kills)
- then return False -- nothing to kill
- else do
--}
killArgs kills m'
-- | @hasBadRigid xs v = Just True@ iff one of the rigid variables in @v@ is not in @xs@.
@@ -479,7 +489,8 @@ hasBadRigid :: [Nat] -> Term -> ExceptT () TCM Bool
hasBadRigid xs t = do
-- We fail if we encounter a matchable argument.
let failure = throwError ()
- t <- liftTCM $ reduce t
+ tb <- liftTCM $ reduceB t
+ let t = ignoreBlocking tb
case ignoreSharing t of
Var x _ -> return $ notElem x xs
-- Issue 1153: A lambda has to be considered matchable.
@@ -489,13 +500,13 @@ hasBadRigid xs t = do
-- The following types of arguments cannot be eliminated by a pattern
-- match: data, record, Pi, levels, sorts
-- Thus, their offending rigid variables are bad.
- v@(Def f es) -> ifNotM (isNeutral f es) failure $ {- else -} do
- return $ es `rigidVarsNotContainedIn` xs
+ v@(Def f es) -> ifNotM (isNeutral tb f es) failure $ {- else -} do
+ es `rigidVarsNotContainedIn` xs
-- Andreas, 2012-05-03: There is room for further improvement.
-- We could also consider a defined f which is not blocked by a meta.
- Pi a b -> return $ (a,b) `rigidVarsNotContainedIn` xs
- Level v -> return $ v `rigidVarsNotContainedIn` xs
- Sort s -> return $ s `rigidVarsNotContainedIn` xs
+ Pi a b -> (a,b) `rigidVarsNotContainedIn` xs
+ Level v -> v `rigidVarsNotContainedIn` xs
+ Sort s -> s `rigidVarsNotContainedIn` xs
-- Since constructors can be eliminated by pattern-matching,
-- offending variables under a constructor could be removed by
-- the right instantiation of the meta variable.
@@ -513,24 +524,129 @@ hasBadRigid xs t = do
-- | Check whether a term @Def f es@ is finally stuck.
-- Currently, we give only a crude approximation.
-isNeutral :: MonadTCM tcm => QName -> Elims -> tcm Bool
-isNeutral f es = liftTCM $ do
+isNeutral :: MonadTCM tcm => Blocked t -> QName -> Elims -> tcm Bool
+isNeutral b f es = liftTCM $ do
let yes = return True
+ no = return False
def <- getConstInfo f
case theDef def of
Axiom{} -> yes
Datatype{} -> yes
Record{} -> yes
- _ -> return False
- -- TODO: more precise analysis
- -- We need to check whether a function is stuck on a variable
- -- (not meta variable), but the API does not help us...
+ Function{} -> case b of
+ NotBlocked StuckOn{} _ -> yes
+ NotBlocked AbsurdMatch _ -> yes
+ _ -> no
+ _ -> no
+
+-- | Check whether any of the variables (given as de Bruijn indices)
+-- occurs *definitely* in the term in a rigid position.
+-- Reduces the term successively to remove variables in dead subterms.
+-- This fixes issue 1386.
+rigidVarsNotContainedIn :: (MonadTCM tcm, FoldRigid a) => a -> [Nat] -> tcm Bool
+rigidVarsNotContainedIn v is = liftTCM $ do
+ n0 <- getContextSize
+ let -- allowed variables as de Bruijn levels
+ levels = Set.fromList $ map (n0-1 -) is
+ -- test if index is forbidden by converting it to level
+ test i = do
+ n <- getContextSize
+ -- get de Bruijn level for i
+ let l = n-1 - i
+ -- If l >= n0 then it is a bound variable and can be
+ -- ignored. Otherwise, it has to be in the allowed levels.
+ forbidden = l < n0 && not (l `Set.member` levels)
+ when forbidden $
+ reportSLn "tc.meta.kill" 20 $
+ "found forbidden de Bruijn level " ++ show l
+ return $ Any forbidden
+ getAny <$> foldRigid id test v
+
+-- | Short-cutting disjunction forms a monoid.
+instance Monoid (TCM Any) where
+ mempty = return mempty
+ ma `mappend` mb = Any <$> do (getAny <$> ma) `or2M` (getAny <$> mb)
+
+-- | Collect the *definitely* rigid variables in a monoid.
+-- We need to successively reduce the expression to do this.
+
+class FoldRigid a where
+-- foldRigid :: (MonadTCM tcm, Monoid (tcm m)) => (tcm m -> tcm m) -> (Nat -> tcm m) -> a -> tcm m
+ foldRigid :: (Monoid (TCM m)) => (TCM m -> TCM m) -> (Nat -> TCM m) -> a -> TCM m
+
+instance FoldRigid Term where
+ foldRigid abs f t = do
+ b <- liftTCM $ reduceB t
+ case ignoreSharing $ ignoreBlocking b of
+ Var i es -> f i `mappend` fold es
+ Lam _ t -> fold t
+ Lit{} -> mempty
+ Def f es -> case b of
+ Blocked{} -> mempty
+ NotBlocked MissingClauses _ -> mempty
+ _ -> fold es
+ Con _ ts -> fold ts
+ Pi a b -> fold (a,b)
+ Sort s -> fold s
+ Level l -> fold l
+ MetaV{} -> mempty
+ DontCare{} -> mempty
+ Shared{} -> __IMPOSSIBLE__
+ ExtLam{} -> __IMPOSSIBLE__
+ where fold = foldRigid abs f
+
+instance FoldRigid Type where
+ foldRigid abs f (El s t) = foldRigid abs f (s,t)
+
+instance FoldRigid Sort where
+ foldRigid abs f s =
+ case s of
+ Type l -> fold l
+ Prop -> mempty
+ Inf -> mempty
+ SizeUniv -> mempty
+ DLub s1 s2 -> fold (s1, s2)
+ where fold = foldRigid abs f
+
+instance FoldRigid Level where
+ foldRigid abs f (Max ls) = foldRigid abs f ls
+
+instance FoldRigid PlusLevel where
+ foldRigid abs f ClosedLevel{} = mempty
+ foldRigid abs f (Plus _ l) = foldRigid abs f l
+
+instance FoldRigid LevelAtom where
+ foldRigid abs f l =
+ case l of
+ MetaLevel{} -> mempty
+ NeutralLevel MissingClauses _ -> mempty
+ NeutralLevel _ l -> fold l
+ BlockedLevel _ l -> fold l
+ UnreducedLevel l -> fold l
+ where fold = foldRigid abs f
+
+instance (Subst a, FoldRigid a) => FoldRigid (Abs a) where
+ foldRigid abs f b = underAbstraction_ b $ foldRigid abs f
--- This could be optimized, by not computing the whole variable set
--- at once, but allow early failure
-rigidVarsNotContainedIn :: Free a => a -> [Nat] -> Bool
-rigidVarsNotContainedIn v xs =
- not $ rigidVars (freeVars v) `VarSet.isSubsetOf` VarSet.fromList xs
+instance FoldRigid a => FoldRigid (I.Arg a) where
+ foldRigid abs f a =
+ case getRelevance a of
+ Irrelevant -> mempty
+ UnusedArg -> mempty
+ _ -> foldRigid abs f $ unArg a
+
+instance FoldRigid a => FoldRigid (I.Dom a) where
+ foldRigid abs f dom = foldRigid abs f $ unDom dom
+
+instance FoldRigid a => FoldRigid (Elim' a) where
+ foldRigid abs f (Apply a) = foldRigid abs f a
+ foldRigid abs f Proj{} = mempty
+
+instance FoldRigid a => FoldRigid [a] where
+ foldRigid abs f = foldMap $ foldRigid abs f
+
+instance (FoldRigid a, FoldRigid b) => FoldRigid (a,b) where
+ foldRigid abs f (a,b) = foldRigid abs f a `mappend` foldRigid abs f b
data PruneResult
@@ -550,11 +666,7 @@ killArgs kills m = do
mv <- lookupMeta m
allowAssign <- asks envAssignMetas
if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do
-{- Andreas 2011-04-26, allow pruning in MetaS
- case mvJudgement mv of
- IsSort _ -> return False
- HasType _ a -> do
--}
+ -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS
let a = jMetaType $ mvJudgement mv
TelV tel b <- telView' <$> instantiateFull a
let args = zip (telToList tel) (kills ++ repeat False)
@@ -566,7 +678,6 @@ killArgs kills m = do
-- Only successful if all occurrences were killed
-- Andreas, 2011-05-09 more precisely, check that at least
-- the in 'kills' prescribed kills were carried out
- -- OLD CODE: return (map unArg kills' == kills)
return $ if (and $ zipWith implies kills $ map unArg kills')
then PrunedEverything
else PrunedSomething
@@ -594,7 +705,7 @@ killArgs kills m = do
killedType :: [(I.Dom (ArgName, Type), Bool)] -> Type -> ([I.Arg Bool], Type)
killedType [] b = ([], b)
killedType ((arg@(Dom info _), kill) : kills) b
- | dontKill = (Arg info False : args, mkPi arg b') -- OLD: telePi (telFromList [arg]) b')
+ | dontKill = (Arg info False : args, mkPi arg b')
| otherwise = (Arg info True : args, strengthen __IMPOSSIBLE__ b')
where
(args, b') = killedType kills b
@@ -615,32 +726,14 @@ performKill kills m a = do
lam b a = Lam (argInfo a) (Abs "v" b)
tel = map ("v" <$) (reverse kills)
u = MetaV m' $ map Apply vars
-{- OLD CODE
- hs = reverse [ argHiding a | a <- kills ]
- lam h b = Lam h (Abs "v" b)
- u = foldr lam (MetaV m' vars) hs
--}
dbg m' u
assignTerm m tel u
where
dbg m' u = reportSDoc "tc.meta.kill" 10 $ vcat</