{-# LANGUAGE CPP, FlexibleContexts, RelaxedPolyRec #-} -- | Generates data used for precise syntax highlighting. module Agda.Interaction.Highlighting.Generate ( Level(..) , generateAndPrintSyntaxInfo , generateTokenInfo , printErrorInfo , printUnsolvedInfo , printHighlightingInfo , highlightAsTypeChecked , Agda.Interaction.Highlighting.Generate.tests ) where import Agda.Interaction.FindFile import Agda.Interaction.Response (Response(Resp_HighlightingInfo)) import Agda.Interaction.Highlighting.Emacs hiding (tests) import Agda.Interaction.Highlighting.Precise hiding (tests) import Agda.Interaction.Highlighting.Range hiding (tests) import Agda.Interaction.EmacsCommand import qualified Agda.TypeChecking.Errors as E import Agda.TypeChecking.MetaVars (isBlockedTerm) import Agda.TypeChecking.Monad.Options (reportSLn, reportSDoc) import Agda.TypeChecking.Monad hiding (MetaInfo, Primitive, Constructor, Record, Function, Datatype) 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.Concrete as C import qualified Agda.Syntax.Info as SI import qualified Agda.Syntax.Internal as I 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 qualified Agda.Syntax.Scope.Base as S import qualified Agda.Syntax.Translation.ConcreteToAbstract as CA import Agda.Utils.List 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 ((***)) import Data.Monoid import Data.Function import Data.Generics.Geniplate import Agda.Utils.FileName import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.Monad import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.List ((\\), isPrefixOf) import qualified Data.Foldable as Fold (toList, fold, foldMap) import System.Directory import System.IO import Agda.Utils.Impossible #include "../../undefined.h" -- | @highlightAsTypeChecked rPre r m@ runs @m@ and returns its -- result. Some code may additionally be highlighted: -- -- * If @r@ is non-empty and not a sub-range of @rPre@ (after -- 'P.continuousPerLine' has been applied to both): @r@ is -- highlighted as being type-checked while @m@ is running (this -- highlighting is removed if @m@ completes /successfully/). -- -- * Otherwise: Highlighting is removed for @rPre - r@ before @m@ -- runs, and if @m@ completes successfully, then @rPre - r@ is -- highlighted as being type-checked. highlightAsTypeChecked :: MonadTCM tcm => P.Range -> P.Range -> tcm a -> tcm a highlightAsTypeChecked rPre r m | r /= P.noRange && delta == rPre' = wrap r' highlight clear | otherwise = wrap delta clear highlight where rPre' = rToR (P.continuousPerLine rPre) r' = rToR (P.continuousPerLine r) delta = rPre' `minus` r' clear = mempty highlight = mempty { otherAspects = [TypeChecks] } wrap rs x y = do p rs x v <- m p rs y return v where p rs x = printHighlightingInfo (singletonC rs x) -- | Lispify and print the given highlighting information. printHighlightingInfo :: MonadTCM tcm => HighlightingInfo -> tcm () printHighlightingInfo x = do liftTCM $ reportSLn "highlighting" 50 $ "Printing highlighting info:\n" ++ show x unless (null $ ranges x) $ do st <- get liftTCM $ stInteractionOutputCallback st (Resp_HighlightingInfo x (stModuleToSource st)) -- | Highlighting levels. data Level = Full [TerminationError] -- ^ Full highlighting. Should only be used after typechecking has -- completed successfully. -- -- The list of termination problems is also highlighted. -- -- Precondition: The termination problems must be located in the -- module that is highlighted. | Partial -- ^ Highlighting without disambiguation of overloaded -- constructors. -- | Generate syntax highlighting information for the given -- declaration, and (if appropriate) print it. If the -- 'HighlightingLevel' is @'Full' something@, then the state is -- additionally updated with the new highlighting info (in case of a -- conflict new info takes precedence over old info). -- -- The procedure makes use of some of the token highlighting info in -- 'stTokens' (that corresponding to the interval covered by the -- declaration). If the 'HighlightingLevel' is @'Full' something@, -- then this token highlighting info is additionally removed from -- 'stTokens'. generateAndPrintSyntaxInfo :: A.Declaration -> Level -> TCM () generateAndPrintSyntaxInfo decl hlLevel = do file <- envCurrentPath <$> ask reportSLn "import.iface.create" 15 $ "Generating syntax info for " ++ filePath file ++ ' ' : case hlLevel of Full {} -> "(final)" Partial {} -> "(first approximation)" ++ "." M.ignoreAbstractMode $ do modMap <- sourceToModule kinds <- nameKinds hlLevel decl let nameInfo = mconcat $ map (generate modMap file kinds) names -- Constructors are only highlighted after type checking, since they -- can be overloaded. constructorInfo <- case hlLevel of Full _ -> generateConstructorInfo modMap file kinds decl _ -> return mempty let (from, to) = case P.rangeToInterval (P.getRange decl) of Nothing -> __IMPOSSIBLE__ Just i -> let conv = toInteger . P.posPos in (conv $ P.iStart i, conv $ P.iEnd i) (prevTokens, (curTokens, postTokens)) <- (id *** splitAtC to) . splitAtC from . stTokens <$> get -- theRest needs to be placed before nameInfo here since record -- field declarations contain QNames. constructorInfo also needs -- to be placed before nameInfo since, when typechecking is done, -- constructors are included in both lists. Finally the token -- information is placed last since token highlighting is more -- crude than the others. let syntaxInfo = compress (mconcat [ constructorInfo , theRest modMap file , nameInfo , termInfo ]) `mappend` curTokens case hlLevel of Full _ -> modify (\st -> st { stSyntaxInfo = syntaxInfo `mappend` stSyntaxInfo st , stTokens = prevTokens `mappend` postTokens }) _ -> return () ifTopLevelAndHighlightingLevelIs NonInteractive $ printHighlightingInfo syntaxInfo where -- Highlighting of termination problems. termInfo = case hlLevel of Full termErrs -> functionDefs `mappend` callSites where m = mempty { otherAspects = [TerminationProblem] } functionDefs = Fold.foldMap (\x -> singleton (rToR $ bindingSite x) m) $ concatMap M.termErrFunctions termErrs callSites = Fold.foldMap (\r -> singleton (rToR r) m) $ concatMap (map M.callInfoRange . M.termErrCalls) termErrs _ -> mempty -- All names mentioned in the syntax tree (not bound variables). names :: [A.AmbiguousQName] names = (map (A.AmbQ . (:[])) $ filter (not . extendedLambda) $ universeBi decl) ++ universeBi decl where extendedLambda :: A.QName -> Bool extendedLambda n = extendlambdaname `isPrefixOf` show (A.qnameName n) -- Bound variables, dotted patterns, record fields, module names, -- the "as" and "to" symbols. theRest modMap file = mconcat [ Fold.foldMap getFieldDecl $ universeBi decl , Fold.foldMap getVarAndField $ universeBi decl , Fold.foldMap getLet $ universeBi decl , Fold.foldMap getLam $ universeBi decl , Fold.foldMap getTyped $ universeBi decl , Fold.foldMap getPattern $ universeBi decl , Fold.foldMap getModuleName $ universeBi decl , Fold.foldMap getModuleInfo $ universeBi decl ] where bound n = nameToFile modMap file [] (A.nameConcrete n) (\isOp -> mempty { aspect = Just $ Name (Just Bound) isOp }) (Just $ A.nameBindingSite n) field m n = nameToFile modMap file m n (\isOp -> mempty { aspect = Just $ Name (Just Field) isOp }) Nothing asName n = nameToFile modMap file [] n (\isOp -> mempty { aspect = Just $ Name (Just Module) isOp }) Nothing mod isTopLevelModule n = nameToFile modMap file [] (A.nameConcrete n) (\isOp -> mempty { aspect = Just $ Name (Just Module) isOp }) (Just $ (if isTopLevelModule then P.beginningOfFile else id) (A.nameBindingSite n)) getVarAndField :: A.Expr -> File getVarAndField (A.Var x) = bound x getVarAndField (A.Rec _ fs) = mconcat $ map (field [] . fst) fs getVarAndField _ = mempty getLet :: A.LetBinding -> File getLet (A.LetBind _ _ x _ _) = bound x getLet A.LetPatBind{} = mempty getLet A.LetApply{} = mempty getLet A.LetOpen{} = mempty getLam :: A.LamBinding -> File getLam (A.DomainFree _ _ x) = bound x getLam (A.DomainFull {}) = mempty getTyped :: A.TypedBinding -> File getTyped (A.TBind _ xs _) = mconcat $ map bound xs getTyped (A.TNoBind {}) = mempty getPattern :: A.Pattern -> File getPattern (A.VarP x) = bound x getPattern (A.AsP _ x _) = bound x getPattern (A.DotP pi _) = singleton (rToR $ P.getRange pi) (mempty { otherAspects = [DottedPattern] }) getPattern _ = mempty getFieldDecl :: A.Declaration -> File getFieldDecl (A.RecDef _ _ _ _ _ _ fs) = Fold.foldMap extractField fs where extractField (A.ScopedDecl _ ds) = Fold.foldMap extractField ds extractField (A.Field _ x _) = field (concreteQualifier x) (concreteBase x) extractField _ = mempty getFieldDecl _ = mempty getModuleName :: A.ModuleName -> File getModuleName m@(A.MName { A.mnameToList = xs }) = mconcat $ map (mod isTopLevelModule) xs where isTopLevelModule = case catMaybes $ map (join . fmap P.srcFile . P.rStart . A.nameBindingSite) xs of f : _ -> Map.lookup f modMap == Just (C.toTopLevelModuleName $ A.mnameToConcrete m) [] -> False getModuleInfo :: SI.ModuleInfo -> File getModuleInfo (SI.ModuleInfo { SI.minfoAsTo = asTo , SI.minfoAsName = name }) = singleton (rToR asTo) (mempty { aspect = Just Symbol }) `mappend` maybe mempty asName name -- | Generate and return the syntax highlighting information for the -- tokens in the given file. generateTokenInfo :: AbsolutePath -- ^ The module to highlight. -> TCM CompressedFile generateTokenInfo file = do tokens <- liftIO $ Pa.parseFile' Pa.tokensParser file return $ merge $ map tokenToCFile tokens where -- Converts an aspect and a range to a file. aToF a r = singletonC (rToR r) (mempty { aspect = Just a }) -- Merges /sorted, non-overlapping/ compressed files. merge = CompressedFile . concat . map ranges tokenToCFile :: T.Token -> CompressedFile tokenToCFile (T.TokSetN (i, _)) = aToF PrimitiveType (P.getRange i) tokenToCFile (T.TokKeyword T.KwSet i) = aToF PrimitiveType (P.getRange i) tokenToCFile (T.TokKeyword T.KwProp i) = aToF PrimitiveType (P.getRange i) tokenToCFile (T.TokKeyword T.KwForall i) = aToF Symbol (P.getRange i) tokenToCFile (T.TokKeyword _ i) = aToF Keyword (P.getRange i) tokenToCFile (T.TokSymbol _ i) = aToF Symbol (P.getRange i) tokenToCFile (T.TokLiteral (L.LitInt r _)) = aToF Number r tokenToCFile (T.TokLiteral (L.LitFloat r _)) = aToF Number r tokenToCFile (T.TokLiteral (L.LitString r _)) = aToF String r tokenToCFile (T.TokLiteral (L.LitChar r _)) = aToF String r tokenToCFile (T.TokLiteral (L.LitQName r _)) = aToF String r tokenToCFile (T.TokComment (i, _)) = aToF Comment (P.getRange i) tokenToCFile (T.TokTeX (i, _)) = aToF Comment (P.getRange i) tokenToCFile (T.TokId {}) = mempty tokenToCFile (T.TokQId {}) = mempty tokenToCFile (T.TokString {}) = mempty tokenToCFile (T.TokDummy {}) = mempty tokenToCFile (T.TokEOF {}) = mempty -- | A function mapping names to the kind of name they stand for. type NameKinds = A.QName -> Maybe NameKind -- | Builds a 'NameKinds' function. nameKinds :: Level -- ^ This should only be @'Full' something@ if -- type-checking completed successfully (without any -- errors). -> A.Declaration -> TCM NameKinds nameKinds hlLevel decl = do imported <- fix . stImports <$> get local <- case hlLevel of Full _ -> fix . stSignature <$> get _ -> return $ -- Traverses the syntax tree and constructs a map from qualified -- names to name kinds. TODO: Handle open public. foldr ($) HMap.empty $ map declToKind $ universeBi decl let merged = HMap.union local imported return (\n -> HMap.lookup n merged) where fix = HMap.map (defnToKind . theDef) . sigDefinitions -- | The 'M.Axiom' constructor is used to represent various things -- which are not really axioms, so when maps are merged 'Postulate's -- are thrown away whenever possible. The 'declToKind' function -- below can return several explanations for one qualified name; the -- 'Postulate's are bogus. insert = HMap.insertWith dropPostulates where dropPostulates Postulate k = k dropPostulates k _ = k defnToKind :: Defn -> NameKind defnToKind (M.Axiom {}) = Postulate defnToKind (M.Function {}) = Function defnToKind (M.Datatype {}) = Datatype defnToKind (M.Record {}) = Record defnToKind (M.Constructor { M.conInd = i }) = Constructor i defnToKind (M.Primitive {}) = Primitive getAxiomName :: A.Declaration -> A.QName getAxiomName (A.Axiom _ _ q _) = q getAxiomName _ = __IMPOSSIBLE__ declToKind :: A.Declaration -> HashMap A.QName NameKind -> HashMap A.QName NameKind declToKind (A.Axiom _ _ q _) = insert q Postulate declToKind (A.Field _ q _) = insert q Function -- Note that the name q can be used both as a field name and as a -- projection function. Highlighting of field names is taken care -- of by "theRest" above, which does not use NameKinds. declToKind (A.Primitive _ q _) = insert q Primitive declToKind (A.Mutual {}) = id declToKind (A.Section {}) = id declToKind (A.Apply {}) = id declToKind (A.Import {}) = id declToKind (A.Pragma {}) = id declToKind (A.ScopedDecl {}) = id declToKind (A.Open {}) = id declToKind (A.FunDef _ q _ _) = insert q Function declToKind (A.DataSig _ q _ _) = insert q Datatype declToKind (A.DataDef _ q _ cs) = \m -> insert q Datatype $ foldr (\d -> insert (getAxiomName d) (Constructor SC.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) -- | Generates syntax highlighting information for all constructors -- occurring in patterns and expressions in the given declaration. -- -- This function should only be called after type checking. -- Constructors can be overloaded, and the overloading is resolved by -- the type checker. generateConstructorInfo :: SourceToModule -- ^ Maps source file paths to module names. -> AbsolutePath -- ^ The module to highlight. -> NameKinds -> A.Declaration -> TCM File generateConstructorInfo modMap file kinds decl = do -- Extract all defined names from the declaration. let names = Fold.toList (A.allNames decl) -- Look up the corresponding declarations in the internal syntax. defMap <- M.sigDefinitions <$> M.getSignature let defs = catMaybes $ map (flip HMap.lookup defMap) names -- Instantiate meta variables. clauses <- R.instantiateFull $ concatMap M.defClauses defs types <- R.instantiateFull $ map defType defs let -- Find all patterns and terms. patterns = universeBi (types, clauses) terms = universeBi (types, clauses) -- Find all constructors in the patterns and terms. constrs = concatMap getConstructorP patterns ++ concatMap getConstructor terms -- Find all constructors in right-hand sides of delayed definitions. delayed <- evalStateT (getDelayed terms) HSet.empty -- Return suitable syntax highlighting information. return $ Fold.fold $ fmap (generate modMap file kinds . mkAmb) (delayed ++ constrs) where mkAmb q = A.AmbQ [q] -- Finds names corresponding to delayed definitions occurring at the -- top of the given terms, as well as in the found definition's -- right-hand sides. Only definitions from the current file are -- considered. -- -- Constructors occurring in the delayed definitions' right-hand -- sides are returned. -- -- The set is used to avoid inspecting the same definition multiple -- times. getDelayed :: [I.Term] -> StateT (HashSet A.QName) TCM [A.QName] getDelayed ts = concat <$> mapM getT ts where getT t = do lift $ reportSDoc "highlighting.delayed" 50 $ text "Inspecting sub-term:" <+> prettyTCM t seen <- get case t of I.Def q _ | not (q `HSet.member` seen) && fmap P.srcFile (P.rStart (P.getRange q)) == Just (Just file) -> getQ q _ -> return [] getQ q = do lift $ reportSDoc "highlighting.delayed" 30 $ text "Inspecting name:" <+> prettyTCM q def <- lift $ getConstInfo q case defDelayed def of NotDelayed -> return [] Delayed -> do lift $ reportSDoc "highlighting.delayed" 10 $ text "Found delayed definition:" <+> prettyTCM q -- Mark the definition as seen. modify (HSet.insert q) -- All sub-terms in the delayed definition's right-hand -- sides. terms <- universeBi . concat . map (getRHS . I.clauseBody) <$> lift (R.instantiateFull $ defClauses def) -- Find the constructors and continue the search. (concatMap getConstructor terms ++) <$> getDelayed terms getRHS (I.Body v) = [v] getRHS I.NoBody = [] getRHS (I.Bind b) = getRHS (I.unAbs b) getConstructorP :: I.Pattern -> [A.QName] getConstructorP (I.ConP q _ _) = [q] getConstructorP _ = [] getConstructor :: I.Term -> [A.QName] getConstructor (I.Con q _) = [q] getConstructor _ = [] -- | Prints syntax highlighting info for an error. printErrorInfo :: TCErr -> TCM () printErrorInfo e = do file <- envCurrentPath <$> ask let r = P.getRange e case P.rStart r of Just x | P.srcFile x == Just file -> do s <- E.prettyError e -- Erase previous highlighting. p (P.continuousPerLine r) mempty -- Print new highlighting. p r $ mempty { otherAspects = [Error] , note = Just s } _ -> internalError . ("invalid range when printing error: " ++) =<< E.prettyError e where p r x = printHighlightingInfo $ singletonC (rToR r) x -- | Generates and prints syntax highlighting information for unsolved -- meta-variables and certain unsolved constraints. printUnsolvedInfo :: TCM () printUnsolvedInfo = do metaInfo <- computeUnsolvedMetaWarnings constraintInfo <- computeUnsolvedConstraints printHighlightingInfo (compress $ metaInfo `mappend` constraintInfo) -- | Generates syntax highlighting information for unsolved meta -- variables. computeUnsolvedMetaWarnings :: TCM File computeUnsolvedMetaWarnings = do is <- getInteractionMetas -- We don't want to highlight blocked terms, since -- * there is always at least one proper meta responsible for the blocking -- * in many cases the blocked term covers the highlighting for this meta let notBlocked m = not <$> isBlockedTerm m ms <- filterM notBlocked =<< getOpenMetas rs <- mapM getMetaRange (ms \\ is) return $ several (map (rToR . P.continuousPerLine) rs) (mempty { otherAspects = [UnsolvedMeta] }) -- | Generates syntax highlighting information for unsolved constraints -- that are not connected to a meta variable. computeUnsolvedConstraints :: TCM File computeUnsolvedConstraints = do cs <- getAllConstraints -- get ranges of emptyness constraints let rs = [ r | PConstr{ theConstraint = Closure{ clValue = IsEmpty r t }} <- cs ] return $ several (map (rToR . P.continuousPerLine) rs) (mempty { otherAspects = [UnsolvedConstraint] }) -- | Generates a suitable file for a possibly ambiguous name. generate :: SourceToModule -- ^ Maps source file paths to module names. -> AbsolutePath -- ^ The module to highlight. -> NameKinds -> A.AmbiguousQName -> File generate modMap file kinds (A.AmbQ qs) = mconcat $ map (\q -> nameToFileA modMap file q include m) qs where ks = map kinds qs kind = case (allEqual ks, ks) of (True, Just k : _) -> Just k _ -> Nothing -- Note that all names in an AmbiguousQName should have the same -- concrete name, so either they are all operators, or none of -- them are. m isOp = mempty { aspect = Just $ Name kind isOp } include = allEqual (map bindingSite qs) -- | Converts names to suitable 'File's. nameToFile :: SourceToModule -- ^ Maps source file paths to module names. -> AbsolutePath -- ^ The file name of the current module. Used for -- consistency checking. -> [C.Name] -- ^ The name qualifier (may be empty). -> C.Name -- ^ The base name. -> (Bool -> MetaInfo) -- ^ Meta information to be associated with the name. -- The argument is 'True' iff the name is an operator. -> Maybe P.Range -- ^ The definition site of the name. The calculated -- meta information is extended with this information, -- if possible. -> File nameToFile modMap file xs x m mR = -- We don't care if we get any funny ranges. if all (== Just file) fileNames then several (map rToR rs) ((m $ C.isOperator x) { definitionSite = mFilePos }) else mempty where fileNames = catMaybes $ map (fmap P.srcFile . P.rStart . P.getRange) (x : xs) rs = map P.getRange (x : xs) mFilePos = do r <- mR P.Pn { P.srcFile = Just f, P.posPos = p } <- P.rStart r mod <- Map.lookup f modMap return (mod, toInteger p) -- | A variant of 'nameToFile' for qualified abstract names. nameToFileA :: SourceToModule -- ^ Maps source file paths to module names. -> AbsolutePath -- ^ The file name of the current module. Used for -- consistency checking. -> A.QName -- ^ The name. -> Bool -- ^ Should the binding site be included in the file? -> (Bool -> MetaInfo) -- ^ Meta information to be associated with the name. -- ^ The argument is 'True' iff the name is an operator. -> File nameToFileA modMap file x include m = nameToFile modMap file (concreteQualifier x) (concreteBase x) m (if include then Just $ bindingSite x else Nothing) concreteBase = A.nameConcrete . A.qnameName concreteQualifier = map A.nameConcrete . A.mnameToList . A.qnameModule bindingSite = A.nameBindingSite . A.qnameName ------------------------------------------------------------------------ -- All tests -- | All the properties. tests :: IO Bool tests = runTests "Agda.Interaction.Highlighting.Generate" []