{- | Module : $Header$ Description : Checks for irregular code Copyright : (c) 2006 Martin Engelke 2011 - 2014 Björn Peemöller 2014 - 2015 Jan Tikovsky 2016 - 2017 Finn Teegen License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module searches for potentially irregular code and generates warning messages. -} {-# LANGUAGE CPP #-} module Checks.WarnCheck (warnCheck) where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif import Control.Monad (filterM, foldM_, guard, liftM, liftM2, when, unless) import Control.Monad.State.Strict (State, execState, gets, modify) import qualified Data.IntSet as IntSet (IntSet, empty, insert, notMember, singleton, union, unions) import qualified Data.Map as Map (empty, insert, lookup) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.List ((\\), intersect, intersectBy, nub, sort, unionBy) import Data.Char (isLower, isUpper, toLower, toUpper, isAlpha) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Base.SpanInfo import Curry.Syntax import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent) import Base.CurryTypes (ppTypeScheme) import Base.Messages (Message, posMessage, internalError) import Base.NestEnv ( NestEnv, emptyEnv, localNestEnv, nestEnv, unnestEnv , qualBindNestEnv, qualInLocalNestEnv, qualLookupNestEnv , qualModifyNestEnv) import Base.Types import Base.Utils (findMultiples) import Env.ModuleAlias import Env.Class (ClassEnv, classMethods, hasDefaultImpl) import Env.TypeConstructor ( TCEnv, TypeInfo (..), lookupTypeInfo , qualLookupTypeInfo, getOrigName ) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) import CompilerOpts -- Find potentially incorrect code in a Curry program and generate warnings -- for the following issues: -- - multiply imported modules, multiply imported/hidden values -- - unreferenced variables -- - shadowing variables -- - idle case alternatives -- - overlapping case alternatives -- - non-adjacent function rules -- - wrong case mode warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv -> Module a -> [Message] warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl = runOn (initWcState mid aEnv valEnv tcEnv clsEnv (wnWarnFlags wOpts) cOpts) $ do checkImports is checkDeclGroup ds checkExports es checkMissingTypeSignatures ds checkModuleAlias is checkCaseMode ds where Module _ _ mid es is ds = fmap (const ()) mdl type ScopeEnv = NestEnv IdInfo -- Current state of generating warnings data WcState = WcState { moduleId :: ModuleIdent , scope :: ScopeEnv , aliasEnv :: AliasEnv , valueEnv :: ValueEnv , tyConsEnv :: TCEnv , classEnv :: ClassEnv , warnFlags :: [WarnFlag] , caseMode :: CaseMode , warnings :: [Message] } -- The monadic representation of the state allows the usage of monadic -- syntax (do expression) for dealing easier and safer with its -- contents. type WCM = State WcState initWcState :: ModuleIdent -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv -> [WarnFlag] -> CaseMode -> WcState initWcState mid ae ve te ce wf cm = WcState mid emptyEnv ae ve te ce wf cm [] getModuleIdent :: WCM ModuleIdent getModuleIdent = gets moduleId modifyScope :: (ScopeEnv -> ScopeEnv) -> WCM () modifyScope f = modify $ \s -> s { scope = f $ scope s } warnFor :: WarnFlag -> WCM () -> WCM () warnFor f act = do warn <- gets $ \s -> f `elem` warnFlags s when warn act report :: Message -> WCM () report w = modify $ \ s -> s { warnings = w : warnings s } unAlias :: QualIdent -> WCM QualIdent unAlias q = do aEnv <- gets aliasEnv case qidModule q of Nothing -> return q Just m -> case Map.lookup m aEnv of Nothing -> return q Just m' -> return $ qualifyWith m' (unqualify q) ok :: WCM () ok = return () -- |Run a 'WCM' action and return the list of messages runOn :: WcState -> WCM a -> [Message] runOn s f = sort $ warnings $ execState f s -- --------------------------------------------------------------------------- -- checkExports -- --------------------------------------------------------------------------- checkExports :: Maybe ExportSpec -> WCM () -- TODO checks checkExports Nothing = ok checkExports (Just (Exporting _ exports)) = do mapM_ visitExport exports reportUnusedGlobalVars where visitExport (Export _ qid) = visitQId qid visitExport _ = ok -- --------------------------------------------------------------------------- -- checkImports -- --------------------------------------------------------------------------- -- Check import declarations for multiply imported modules and multiply -- imported/hidden values. -- The function uses a map of the already imported or hidden entities to -- collect the entities throughout multiple import statements. checkImports :: [ImportDecl] -> WCM () checkImports = warnFor WarnMultipleImports . foldM_ checkImport Map.empty where checkImport env (ImportDecl pos mid _ _ spec) = case Map.lookup mid env of Nothing -> setImportSpec env mid $ fromImpSpec spec Just ishs -> checkImportSpec env pos mid ishs spec checkImportSpec env _ mid (_, _) Nothing = do report $ warnMultiplyImportedModule mid return env checkImportSpec env _ mid (is, hs) (Just (Importing _ is')) | null is && any (`notElem` hs) is' = do report $ warnMultiplyImportedModule mid setImportSpec env mid (is', hs) | null iis = setImportSpec env mid (is' ++ is, hs) | otherwise = do mapM_ (report . (warnMultiplyImportedSymbol mid) . impName) iis setImportSpec env mid (unionBy cmpImport is' is, hs) where iis = intersectBy cmpImport is' is checkImportSpec env _ mid (is, hs) (Just (Hiding _ hs')) | null ihs = setImportSpec env mid (is, hs' ++ hs) | otherwise = do mapM_ (report . (warnMultiplyHiddenSymbol mid) . impName) ihs setImportSpec env mid (is, unionBy cmpImport hs' hs) where ihs = intersectBy cmpImport hs' hs fromImpSpec Nothing = ([], []) fromImpSpec (Just (Importing _ is)) = (is, []) fromImpSpec (Just (Hiding _ hs)) = ([], hs) setImportSpec env mid ishs = return $ Map.insert mid ishs env cmpImport (ImportTypeWith _ id1 cs1) (ImportTypeWith _ id2 cs2) = id1 == id2 && null (intersect cs1 cs2) cmpImport i1 i2 = (impName i1) == (impName i2) impName (Import _ v) = v impName (ImportTypeAll _ t) = t impName (ImportTypeWith _ t _) = t warnMultiplyImportedModule :: ModuleIdent -> Message warnMultiplyImportedModule mid = posMessage mid $ hsep $ map text ["Module", moduleName mid, "is imported more than once"] warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message warnMultiplyImportedSymbol mid ident = posMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is imported more than once" ] warnMultiplyHiddenSymbol :: ModuleIdent -> Ident -> Message warnMultiplyHiddenSymbol mid ident = posMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is hidden more than once" ] -- --------------------------------------------------------------------------- -- checkDeclGroup -- --------------------------------------------------------------------------- checkDeclGroup :: [Decl ()] -> WCM () checkDeclGroup ds = do mapM_ insertDecl ds mapM_ checkDecl ds checkRuleAdjacency ds checkLocalDeclGroup :: [Decl ()] -> WCM () checkLocalDeclGroup ds = do mapM_ checkLocalDecl ds checkDeclGroup ds -- --------------------------------------------------------------------------- -- Find function rules which are disjoined -- --------------------------------------------------------------------------- checkRuleAdjacency :: [Decl a] -> WCM () checkRuleAdjacency decls = warnFor WarnDisjoinedRules $ foldM_ check (mkIdent "", Map.empty) decls where check (prevId, env) (FunctionDecl p _ f _) = do cons <- isConsId f if cons || prevId == f then return (f, env) else case Map.lookup f env of Nothing -> return (f, Map.insert f p env) Just p' -> do report $ warnDisjoinedFunctionRules f (spanInfo2Pos p') return (f, env) check (_ , env) _ = return (mkIdent "", env) warnDisjoinedFunctionRules :: Ident -> Position -> Message warnDisjoinedFunctionRules ident pos = posMessage ident $ hsep (map text [ "Rules for function", escName ident, "are disjoined" ]) <+> parens (text "first occurrence at" <+> text (showLine pos)) checkDecl :: Decl () -> WCM () checkDecl (DataDecl _ _ vs cs _) = inNestedScope $ do mapM_ insertTypeVar vs mapM_ checkConstrDecl cs reportUnusedTypeVars vs checkDecl (NewtypeDecl _ _ vs nc _) = inNestedScope $ do mapM_ insertTypeVar vs checkNewConstrDecl nc reportUnusedTypeVars vs checkDecl (TypeDecl _ _ vs ty) = inNestedScope $ do mapM_ insertTypeVar vs checkTypeExpr ty reportUnusedTypeVars vs checkDecl (FunctionDecl p _ f eqs) = checkFunctionDecl p f eqs checkDecl (PatternDecl _ p rhs) = checkPattern p >> checkRhs rhs checkDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys checkDecl (ClassDecl _ _ _ _ ds) = mapM_ checkDecl ds checkDecl (InstanceDecl p cx cls ty ds) = do checkOrphanInstance p cx cls ty checkMissingMethodImplementations p cls ds mapM_ checkDecl ds checkDecl _ = ok --TODO: shadowing und context etc. checkConstrDecl :: ConstrDecl -> WCM () checkConstrDecl (ConstrDecl _ vs _ c tys) = inNestedScope $ do mapM_ checkTypeShadowing vs mapM_ insertTypeVar vs visitId c mapM_ checkTypeExpr tys reportUnusedTypeVars vs checkConstrDecl (ConOpDecl _ vs _ ty1 op ty2) = inNestedScope $ do mapM_ checkTypeShadowing vs mapM_ insertTypeVar vs visitId op mapM_ checkTypeExpr [ty1, ty2] reportUnusedTypeVars vs checkConstrDecl (RecordDecl _ vs _ c fs) = inNestedScope $ do mapM_ checkTypeShadowing vs mapM_ insertTypeVar vs visitId c mapM_ checkTypeExpr tys reportUnusedTypeVars vs where tys = [ty | FieldDecl _ _ ty <- fs] checkNewConstrDecl :: NewConstrDecl -> WCM () checkNewConstrDecl (NewConstrDecl _ c ty) = do visitId c checkTypeExpr ty checkNewConstrDecl (NewRecordDecl _ c (_, ty)) = do visitId c checkTypeExpr ty checkTypeExpr :: TypeExpr -> WCM () checkTypeExpr (ConstructorType _ qid) = visitQTypeId qid checkTypeExpr (ApplyType _ ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2] checkTypeExpr (VariableType _ v) = visitTypeId v checkTypeExpr (TupleType _ tys) = mapM_ checkTypeExpr tys checkTypeExpr (ListType _ ty) = checkTypeExpr ty checkTypeExpr (ArrowType _ ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2] checkTypeExpr (ParenType _ ty) = checkTypeExpr ty checkTypeExpr (ForallType _ vs ty) = do mapM_ insertTypeVar vs checkTypeExpr ty -- Checks locally declared identifiers (i.e. functions and logic variables) -- for shadowing checkLocalDecl :: Decl a -> WCM () checkLocalDecl (FunctionDecl _ _ f _) = checkShadowing f checkLocalDecl (FreeDecl _ vs) = mapM_ (checkShadowing . varIdent) vs checkLocalDecl (PatternDecl _ p _) = checkPattern p checkLocalDecl _ = ok checkFunctionDecl :: SpanInfo -> Ident -> [Equation ()] -> WCM () checkFunctionDecl _ _ [] = ok checkFunctionDecl p f eqs = inNestedScope $ do mapM_ checkEquation eqs checkFunctionPatternMatch p f eqs checkFunctionPatternMatch :: SpanInfo -> Ident -> [Equation ()] -> WCM () checkFunctionPatternMatch spi f eqs = do let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ warnMissingPattern p ("an equation for " ++ escName f) nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $ warnNondetOverlapping p ("Function " ++ escName f) where p = spanInfo2Pos spi -- Check an equation for warnings. -- This is done in a seperate scope as the left-hand-side may introduce -- new variables. checkEquation :: Equation () -> WCM () checkEquation (Equation _ lhs rhs) = inNestedScope $ do checkLhs lhs checkRhs rhs reportUnusedVars checkLhs :: Lhs a -> WCM () checkLhs (FunLhs _ _ ts) = do mapM_ checkPattern ts mapM_ (insertPattern False) ts checkLhs (OpLhs spi t1 op t2) = checkLhs (FunLhs spi op [t1, t2]) checkLhs (ApLhs _ lhs ts) = do checkLhs lhs mapM_ checkPattern ts mapM_ (insertPattern False) ts checkPattern :: Pattern a -> WCM () checkPattern (VariablePattern _ _ v) = checkShadowing v checkPattern (ConstructorPattern _ _ _ ps) = mapM_ checkPattern ps checkPattern (InfixPattern spi a p1 f p2) = checkPattern (ConstructorPattern spi a f [p1, p2]) checkPattern (ParenPattern _ p) = checkPattern p checkPattern (RecordPattern _ _ _ fs) = mapM_ (checkField checkPattern) fs checkPattern (TuplePattern _ ps) = mapM_ checkPattern ps checkPattern (ListPattern _ _ ps) = mapM_ checkPattern ps checkPattern (AsPattern _ v p) = checkShadowing v >> checkPattern p checkPattern (LazyPattern _ p) = checkPattern p checkPattern (FunctionPattern _ _ _ ps) = mapM_ checkPattern ps checkPattern (InfixFuncPattern spi a p1 f p2) = checkPattern (FunctionPattern spi a f [p1, p2]) checkPattern _ = ok -- Check the right-hand-side of an equation. -- Because local declarations may introduce new variables, we need -- another scope nesting. checkRhs :: Rhs () -> WCM () checkRhs (SimpleRhs _ e ds) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars checkRhs (GuardedRhs _ ce ds) = inNestedScope $ do checkLocalDeclGroup ds mapM_ checkCondExpr ce reportUnusedVars checkCondExpr :: CondExpr () -> WCM () checkCondExpr (CondExpr _ c e) = checkExpr c >> checkExpr e checkExpr :: Expression () -> WCM () checkExpr (Variable _ _ v) = visitQId v checkExpr (Paren _ e) = checkExpr e checkExpr (Typed _ e _) = checkExpr e checkExpr (Record _ _ _ fs) = mapM_ (checkField checkExpr) fs checkExpr (RecordUpdate _ e fs) = do checkExpr e mapM_ (checkField checkExpr) fs checkExpr (Tuple _ es) = mapM_ checkExpr es checkExpr (List _ _ es) = mapM_ checkExpr es checkExpr (ListCompr _ e sts) = checkStatements sts e checkExpr (EnumFrom _ e) = checkExpr e checkExpr (EnumFromThen _ e1 e2) = mapM_ checkExpr [e1, e2] checkExpr (EnumFromTo _ e1 e2) = mapM_ checkExpr [e1, e2] checkExpr (EnumFromThenTo _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3] checkExpr (UnaryMinus _ e) = checkExpr e checkExpr (Apply _ e1 e2) = mapM_ checkExpr [e1, e2] checkExpr (InfixApply _ e1 op e2) = do visitQId (opName op) mapM_ checkExpr [e1, e2] checkExpr (LeftSection _ e _) = checkExpr e checkExpr (RightSection _ _ e) = checkExpr e checkExpr (Lambda _ ps e) = inNestedScope $ do mapM_ checkPattern ps mapM_ (insertPattern False) ps checkExpr e reportUnusedVars checkExpr (Let _ ds e) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars checkExpr (Do _ sts e) = checkStatements sts e checkExpr (IfThenElse _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3] checkExpr (Case _ ct e alts) = do checkExpr e mapM_ checkAlt alts checkCaseAlts ct alts checkExpr _ = ok checkStatements :: [Statement ()] -> Expression () -> WCM () checkStatements [] e = checkExpr e checkStatements (s:ss) e = inNestedScope $ do checkStatement s >> checkStatements ss e reportUnusedVars checkStatement :: Statement () -> WCM () checkStatement (StmtExpr _ e) = checkExpr e checkStatement (StmtDecl _ ds) = checkLocalDeclGroup ds checkStatement (StmtBind _ p e) = do checkPattern p >> insertPattern False p checkExpr e checkAlt :: Alt () -> WCM () checkAlt (Alt _ p rhs) = inNestedScope $ do checkPattern p >> insertPattern False p checkRhs rhs reportUnusedVars checkField :: (a -> WCM ()) -> Field a -> WCM () checkField check (Field _ _ x) = check x -- ----------------------------------------------------------------------------- -- Check for orphan instances -- ----------------------------------------------------------------------------- checkOrphanInstance :: SpanInfo -> Context -> QualIdent -> TypeExpr -> WCM () checkOrphanInstance p cx cls ty = warnFor WarnOrphanInstances $ do m <- getModuleIdent tcEnv <- gets tyConsEnv let ocls = getOrigName m cls tcEnv otc = getOrigName m tc tcEnv unless (isLocalIdent m ocls || isLocalIdent m otc) $ report $ warnOrphanInstance (spanInfo2Pos p) $ ppDecl $ InstanceDecl p cx cls ty [] where tc = typeConstr ty warnOrphanInstance :: Position -> Doc -> Message warnOrphanInstance p doc = posMessage p $ text "Orphan instance:" <+> doc -- ----------------------------------------------------------------------------- -- Check for missing method implementations -- ----------------------------------------------------------------------------- checkMissingMethodImplementations :: SpanInfo -> QualIdent -> [Decl a] -> WCM () checkMissingMethodImplementations p cls ds = warnFor WarnMissingMethods $ do m <- getModuleIdent tcEnv <- gets tyConsEnv clsEnv <- gets classEnv let ocls = getOrigName m cls tcEnv ms = classMethods ocls clsEnv mapM_ (report . warnMissingMethodImplementation (spanInfo2Pos p)) $ filter ((null fs ||) . not . flip (hasDefaultImpl ocls) clsEnv) $ ms \\ fs where fs = map unRenameIdent $ concatMap impls ds warnMissingMethodImplementation :: Position -> Ident -> Message warnMissingMethodImplementation p f = posMessage p $ hsep $ map text ["No explicit implementation for method", escName f] -- ----------------------------------------------------------------------------- -- Check for missing type signatures -- ----------------------------------------------------------------------------- -- |Check if every top-level function has an accompanying type signature. -- For external function declarations, this check is already performed -- during syntax checking. checkMissingTypeSignatures :: [Decl a] -> WCM () checkMissingTypeSignatures ds = warnFor WarnMissingSignatures $ do let typedFs = [f | TypeSig _ fs _ <- ds, f <- fs] untypedFs = [f | FunctionDecl _ _ f _ <- ds, f `notElem` typedFs] unless (null untypedFs) $ do mid <- getModuleIdent tyScs <- mapM getTyScheme untypedFs mapM_ report $ zipWith (warnMissingTypeSignature mid) untypedFs tyScs getTyScheme :: Ident -> WCM TypeScheme getTyScheme q = do m <- getModuleIdent tyEnv <- gets valueEnv return $ case qualLookupValue (qualifyWith m q) tyEnv of [Value _ _ _ tys] -> tys _ -> internalError $ "Checks.WarnCheck.getTyScheme: " ++ show q warnMissingTypeSignature :: ModuleIdent -> Ident -> TypeScheme -> Message warnMissingTypeSignature mid i tys = posMessage i $ fsep [ text "Top-level binding with no type signature:" , nest 2 $ text (showIdent i) <+> text "::" <+> ppTypeScheme mid tys ] -- ----------------------------------------------------------------------------- -- Check for overlapping module alias names -- ----------------------------------------------------------------------------- -- check if module aliases in import declarations overlap with the module name -- or another module alias checkModuleAlias :: [ImportDecl] -> WCM () checkModuleAlias is = do mid <- getModuleIdent let alias = catMaybes [a | ImportDecl _ _ _ a _ <- is] modClash = [a | a <- alias, a == mid] aliasClash = findMultiples alias unless (null modClash) $ mapM_ (report . warnModuleNameClash) modClash unless (null aliasClash) $ mapM_ (report . warnAliasNameClash ) aliasClash warnModuleNameClash :: ModuleIdent -> Message warnModuleNameClash mid = posMessage mid $ hsep $ map text ["The module alias", escModuleName mid , "overlaps with the current module name"] warnAliasNameClash :: [ModuleIdent] -> Message warnAliasNameClash [] = internalError "WarnCheck.warnAliasNameClash: empty list" warnAliasNameClash mids = posMessage (head mids) $ text "Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids)) where myppAlias mid = ppLine (getPosition mid) <> text ":" <+> text (escModuleName mid) -- ----------------------------------------------------------------------------- -- Check for overlapping/unreachable and non-exhaustive case alternatives -- ----------------------------------------------------------------------------- checkCaseAlts :: CaseType -> [Alt ()] -> WCM () checkCaseAlts _ [] = ok checkCaseAlts ct alts@(Alt spi _ _ : _) = do let pats = map (\(Alt _ pat _) -> [pat]) alts (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats case ct of Flex -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ warnMissingPattern p "an fcase alternative" nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $ warnNondetOverlapping p "An fcase expression" Rigid -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ warnMissingPattern p "a case alternative" nonExhaustive unless (null overlapped) $ warnFor WarnOverlapping $ report $ warnUnreachablePattern p overlapped where p = spanInfo2Pos spi -- ----------------------------------------------------------------------------- -- Check for non-exhaustive and overlapping patterns. -- For an example, consider the following function definition: -- @ -- f [True] = 0 -- f (False:_) = 1 -- @ -- In this declaration, the following patterns are not matched: -- @ -- [] _ -- (True:_:_) -- @ -- This is identified and reported by the following code,, both for pattern -- matching in function declarations and (f)case expressions. -- ----------------------------------------------------------------------------- checkPatternMatching :: [[Pattern ()]] -> WCM ([ExhaustivePats], [[Pattern ()]], Bool) checkPatternMatching pats = do -- 1. We simplify the patterns by removing syntactic sugar temporarily -- for a simpler implementation. simplePats <- mapM (mapM simplifyPat) pats -- 2. We compute missing and used pattern matching alternatives (missing, used, nondet) <- processEqs (zip [1..] simplePats) -- 3. If any, we report the missing patterns, whereby we re-add the syntactic -- sugar removed in step (1) for a more precise output. nonExhaustive <- mapM tidyExhaustivePats missing let overlap = [ eqn | (i, eqn) <- zip [1..] pats, i `IntSet.notMember` used] return (nonExhaustive , overlap, nondet) -- |Simplify a 'Pattern' until it only consists of -- * Variables -- * Integer, Float or Char literals -- * Constructors -- All other patterns like as-patterns, list patterns and alike are desugared. simplifyPat :: Pattern () -> WCM (Pattern ()) simplifyPat p@(LiteralPattern _ _ l) = return $ case l of String s -> simplifyListPattern $ map (LiteralPattern NoSpanInfo () . Char) s _ -> p simplifyPat (NegativePattern spi a l) = return $ LiteralPattern spi a (negateLit l) where negateLit (Int n) = Int (-n) negateLit (Float d) = Float (-d) negateLit x = x simplifyPat v@(VariablePattern _ _ _) = return v simplifyPat (ConstructorPattern spi a c ps) = ConstructorPattern spi a c `liftM` mapM simplifyPat ps simplifyPat (InfixPattern spi a p1 c p2) = ConstructorPattern spi a c `liftM` mapM simplifyPat [p1, p2] simplifyPat (ParenPattern _ p) = simplifyPat p simplifyPat (RecordPattern _ _ c fs) = do (_, ls) <- getAllLabels c let ps = map (getPattern (map field2Tuple fs)) ls simplifyPat (ConstructorPattern NoSpanInfo () c ps) where getPattern fs' l' = fromMaybe wildPat (lookup l' [(unqualify l, p) | (l, p) <- fs']) simplifyPat (TuplePattern _ ps) = ConstructorPattern NoSpanInfo () (qTupleId (length ps)) `liftM` mapM simplifyPat ps simplifyPat (ListPattern _ _ ps) = simplifyListPattern `liftM` mapM simplifyPat ps simplifyPat (AsPattern _ _ p) = simplifyPat p simplifyPat (LazyPattern _ _) = return wildPat simplifyPat (FunctionPattern _ _ _ _) = return wildPat simplifyPat (InfixFuncPattern _ _ _ _ _) = return wildPat getAllLabels :: QualIdent -> WCM (QualIdent, [Ident]) getAllLabels c = do tyEnv <- gets valueEnv case qualLookupValue c tyEnv of [DataConstructor qc _ ls _] -> return (qc, ls) _ -> internalError $ "Checks.WarnCheck.getAllLabels: " ++ show c -- |Create a simplified list pattern by applying @:@ and @[]@. simplifyListPattern :: [Pattern ()] -> Pattern () simplifyListPattern = foldr (\p1 p2 -> ConstructorPattern NoSpanInfo () qConsId [p1, p2]) (ConstructorPattern NoSpanInfo () qNilId []) -- |'ExhaustivePats' describes those pattern missing for an exhaustive -- pattern matching, where a value can be thought of as a missing equation. -- The first component contains the unmatched patterns, while the second -- pattern contains an identifier and the literals matched for this identifier. -- -- This is necessary when checking literal patterns because of the sheer -- number of possible patterns. Missing literals are therefore converted -- into the form @ ... x ... with x `notElem` [l1, ..., ln]@. type EqnPats = [Pattern ()] type EqnNo = Int type EqnInfo = (EqnNo, EqnPats) type ExhaustivePats = (EqnPats, [(Ident, [Literal])]) type EqnSet = IntSet.IntSet -- |Compute the missing pattern by inspecting the first patterns and -- categorize them as literal, constructor or variable patterns. processEqs :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processEqs [] = return ([], IntSet.empty, False) processEqs eqs@((n, ps):_) | null ps = return ([], IntSet.singleton n, length eqs > 1) | any isLitPat firstPats = processLits eqs | any isConPat firstPats = processCons eqs | all isVarPat firstPats = processVars eqs | otherwise = internalError "Checks.WarnCheck.processEqs" where firstPats = map firstPat eqs -- |Literal patterns are checked by extracting the matched literals -- and constructing a pattern for any missing case. processLits :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processLits [] = error "WarnCheck.processLits" processLits qs@(q:_) = do -- Check any patterns starting with the literals used (missing1, used1, nd1) <- processUsedLits usedLits qs if null defaults then return $ (defaultPat : missing1, used1, nd1) else do -- Missing patterns for the default alternatives (missing2, used2, nd2) <- processEqs defaults return ( [ (wildPat : ps, cs) | (ps, cs) <- missing2 ] ++ missing1 , IntSet.union used1 used2, nd1 || nd2 ) where -- The literals occurring in the patterns usedLits = nub $ concatMap (getLit . firstPat) qs -- default alternatives (variable pattern) defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for all non-matched literals defaultPat = ( VariablePattern NoSpanInfo () newVar : replicate (length (snd q) - 1) wildPat , [(newVar, usedLits)] ) newVar = mkIdent "x" -- |Construct exhaustive patterns starting with the used literals processUsedLits :: [Literal] -> [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processUsedLits lits qs = do (eps, idxs, nds) <- unzip3 `liftM` mapM process lits return (concat eps, IntSet.unions idxs, or nds) where process lit = do let qs' = [shiftPat q | q <- qs, isVarLit lit (firstPat q)] ovlp = length qs' > 1 (missing, used, nd) <- processEqs qs' return ( map (\(xs, ys) -> (LiteralPattern NoSpanInfo () lit : xs, ys)) missing , used , nd && ovlp ) -- |Constructor patterns are checked by extracting the matched constructors -- and constructing a pattern for any missing case. processCons :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processCons [] = error "WarnCheck.processCons" processCons qs@(q:_) = do -- Compute any missing patterns starting with the used constructors (missing1, used1, nd) <- processUsedCons used_cons qs -- Determine unused constructors unused <- getUnusedCons (map fst used_cons) if null unused then return (missing1, used1, nd) else if null defaults then return $ (map defaultPat unused ++ missing1, used1, nd) else do -- Missing patterns for the default alternatives (missing2, used2, nd2) <- processEqs defaults return ( [ (mkPattern c : ps, cs) | c <- unused, (ps, cs) <- missing2 ] ++ missing1 , IntSet.union used1 used2, nd || nd2) where -- used constructors (occurring in a pattern) used_cons = nub $ concatMap (getCon . firstPat) qs -- default alternatives (variable pattern) defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for a non-matched constructors defaultPat c = (mkPattern c : replicate (length (snd q) - 1) wildPat, []) mkPattern c = ConstructorPattern NoSpanInfo () (qualifyLike (fst $ head used_cons) (constrIdent c)) (replicate (length $ constrTypes c) wildPat) -- |Construct exhaustive patterns starting with the used constructors processUsedCons :: [(QualIdent, Int)] -> [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processUsedCons cons qs = do (eps, idxs, nds) <- unzip3 `liftM` mapM process cons return (concat eps, IntSet.unions idxs, or nds) where process (c, a) = do let qs' = [ removeFirstCon c a q | q <- qs , isVarCon c (firstPat q)] ovlp = length qs' > 1 (missing, used, nd) <- processEqs qs' return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd && ovlp) makeCon c a ps = let (args, rest) = splitAt a ps in ConstructorPattern NoSpanInfo () c args : rest removeFirstCon c a (n, p:ps) | isVarPat p = (n, replicate a wildPat ++ ps) | isCon c p = (n, patArgs p ++ ps) removeFirstCon _ _ _ = internalError "Checks.WarnCheck.removeFirstCon" -- |Variable patterns are exhaustive, so they are checked by simply -- checking the following patterns. processVars :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processVars [] = error "WarnCheck.processVars" processVars eqs@((n, _) : _) = do let ovlp = length eqs > 1 (missing, used, nd) <- processEqs (map shiftPat eqs) return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing , IntSet.insert n used, nd && ovlp) -- |Return the constructors of a type not contained in the list of constructors. getUnusedCons :: [QualIdent] -> WCM [DataConstr] getUnusedCons [] = internalError "Checks.WarnCheck.getUnusedCons" getUnusedCons qs@(q:_) = do allCons <- getConTy q >>= getTyCons . rootOfType . arrowBase return [c | c <- allCons, (constrIdent c) `notElem` map unqualify qs] -- |Retrieve the type of a given constructor. getConTy :: QualIdent -> WCM Type getConTy q = do tyEnv <- gets valueEnv tcEnv <- gets tyConsEnv case qualLookupValue q tyEnv of [DataConstructor _ _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty [NewtypeConstructor _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty _ -> case qualLookupTypeInfo q tcEnv of [AliasType _ _ _ ty] -> return ty _ -> internalError $ "Checks.WarnCheck.getConTy: " ++ show q -- |Retrieve all constructors of a given type. getTyCons :: QualIdent -> WCM [DataConstr] getTyCons tc = do tc' <- unAlias tc tcEnv <- gets tyConsEnv return $ case lookupTypeInfo (unqualify tc) tcEnv of [DataType _ _ cs] -> cs [RenamingType _ _ nc] -> [nc] _ -> case qualLookupTypeInfo tc' tcEnv of [DataType _ _ cs] -> cs [RenamingType _ _ nc] -> [nc] err -> internalError $ "Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv -- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'. tidyExhaustivePats :: ExhaustivePats -> WCM ExhaustivePats tidyExhaustivePats (xs, ys) = mapM tidyPat xs >>= \xs' -> return (xs', ys) -- |Resugar a pattern previously desugared at 'simplifyPat', i.e. -- * Convert a tuple constructor pattern into a tuple pattern -- * Convert a list constructor pattern representing a finite list -- into a list pattern tidyPat :: Pattern () -> WCM (Pattern ()) tidyPat p@(LiteralPattern _ _ _) = return p tidyPat p@(VariablePattern _ _ _) = return p tidyPat p@(ConstructorPattern _ _ c ps) | isQTupleId c = TuplePattern NoSpanInfo `liftM` mapM tidyPat ps | c == qConsId && isFiniteList p = ListPattern NoSpanInfo () `liftM` mapM tidyPat (unwrapFinite p) | c == qConsId = unwrapInfinite p | otherwise = ConstructorPattern NoSpanInfo () c `liftM` mapM tidyPat ps where isFiniteList (ConstructorPattern _ _ d [] ) = d == qNilId isFiniteList (ConstructorPattern _ _ d [_, e2]) | d == qConsId = isFiniteList e2 isFiniteList _ = False unwrapFinite (ConstructorPattern _ _ _ [] ) = [] unwrapFinite (ConstructorPattern _ _ _ [p1,p2]) = p1 : unwrapFinite p2 unwrapFinite pat = internalError $ "WarnCheck.tidyPat.unwrapFinite: " ++ show pat unwrapInfinite (ConstructorPattern _ a d [p1,p2]) = liftM2 (flip (InfixPattern NoSpanInfo a) d) (tidyPat p1) (unwrapInfinite p2) unwrapInfinite p0 = return p0 tidyPat p = internalError $ "Checks.WarnCheck.tidyPat: " ++ show p -- |Get the first pattern of a list. firstPat :: EqnInfo -> Pattern () firstPat (_, [] ) = internalError "Checks.WarnCheck.firstPat: empty list" firstPat (_, (p:_)) = p -- |Drop the first pattern of a list. shiftPat :: EqnInfo -> EqnInfo shiftPat (_, [] ) = internalError "Checks.WarnCheck.shiftPat: empty list" shiftPat (n, (_:ps)) = (n, ps) -- |Wildcard pattern. wildPat :: Pattern () wildPat = VariablePattern NoSpanInfo () anonId -- |Retrieve any literal out of a pattern. getLit :: Pattern a -> [Literal] getLit (LiteralPattern _ _ l) = [l] getLit _ = [] -- |Retrieve the constructor name and its arity for a pattern. getCon :: Pattern a -> [(QualIdent, Int)] getCon (ConstructorPattern _ _ c ps) = [(c, length ps)] getCon _ = [] -- |Is a pattern a variable or literal pattern? isVarLit :: Literal -> Pattern a -> Bool isVarLit l p = isVarPat p || isLit l p -- |Is a pattern a variable or a constructor pattern with the given constructor? isVarCon :: QualIdent -> Pattern a -> Bool isVarCon c p = isVarPat p || isCon c p -- |Is a pattern a pattern matching for the given constructor? isCon :: QualIdent -> Pattern a -> Bool isCon c (ConstructorPattern _ _ d _) = c == d isCon _ _ = False -- |Is a pattern a pattern matching for the given literal? isLit :: Literal -> Pattern a -> Bool isLit l (LiteralPattern _ _ m) = l == m isLit _ _ = False -- |Is a pattern a literal pattern? isLitPat :: Pattern a -> Bool isLitPat (LiteralPattern _ _ _) = True isLitPat _ = False -- |Is a pattern a variable pattern? isVarPat :: Pattern a -> Bool isVarPat (VariablePattern _ _ _) = True isVarPat _ = False -- |Is a pattern a constructor pattern? isConPat :: Pattern a -> Bool isConPat (ConstructorPattern _ _ _ _) = True isConPat _ = False -- |Retrieve the arguments of a pattern. patArgs :: Pattern a -> [Pattern a] patArgs (ConstructorPattern _ _ _ ps) = ps patArgs _ = [] -- |Warning message for non-exhaustive patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots. warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message warnMissingPattern p loc pats = posMessage p $ text "Pattern matches are non-exhaustive" $+$ text "In" <+> text loc <> char ':' $+$ nest 2 (text "Patterns not matched:" $+$ nest 2 (vcat (ppExPats pats))) where ppExPats ps | length ps > maxPattern = ppPats ++ [text "..."] | otherwise = ppPats where ppPats = map ppExPat (take maxPattern ps) ppExPat (ps, cs) | null cs = ppPats | otherwise = ppPats <+> text "with" <+> hsep (map ppCons cs) where ppPats = hsep (map (ppPattern 2) ps) ppCons (i, lits) = ppIdent i <+> text "`notElem`" <+> ppExpr 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits)) -- |Warning message for unreachable patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots. warnUnreachablePattern :: Position -> [[Pattern a]] -> Message warnUnreachablePattern p pats = posMessage p $ text "Pattern matches are potentially unreachable" $+$ text "In a case alternative:" $+$ nest 2 (vcat (ppExPats pats) <+> text "->" <+> text "...") where ppExPats ps | length ps > maxPattern = ppPats ++ [text "..."] | otherwise = ppPats where ppPats = map ppPat (take maxPattern ps) ppPat ps = hsep (map (ppPattern 2) ps) -- |Maximum number of missing patterns to be shown. maxPattern :: Int maxPattern = 4 warnNondetOverlapping :: Position -> String -> Message warnNondetOverlapping p loc = posMessage p $ text loc <+> text "is potentially non-deterministic due to overlapping rules" -- ----------------------------------------------------------------------------- checkShadowing :: Ident -> WCM () checkShadowing x = warnFor WarnNameShadowing $ shadowsVar x >>= maybe ok (report . warnShadowing x) checkTypeShadowing :: Ident -> WCM () checkTypeShadowing x = warnFor WarnNameShadowing $ shadowsTypeVar x >>= maybe ok (report . warnTypeShadowing x) reportUnusedVars :: WCM () reportUnusedVars = reportAllUnusedVars WarnUnusedBindings reportUnusedGlobalVars :: WCM () reportUnusedGlobalVars = reportAllUnusedVars WarnUnusedGlobalBindings reportAllUnusedVars :: WarnFlag -> WCM () reportAllUnusedVars wFlag = warnFor wFlag $ do unused <- returnUnrefVars unless (null unused) $ mapM_ report $ map warnUnrefVar unused reportUnusedTypeVars :: [Ident] -> WCM () reportUnusedTypeVars vs = warnFor WarnUnusedBindings $ do unused <- filterM isUnrefTypeVar vs unless (null unused) $ mapM_ report $ map warnUnrefTypeVar unused -- --------------------------------------------------------------------------- -- For detecting unreferenced variables, the following functions update the -- current check state by adding identifiers occuring in declaration left hand -- sides. insertDecl :: Decl a -> WCM () insertDecl (DataDecl _ d _ cs _) = do insertTypeConsId d mapM_ insertConstrDecl cs insertDecl (ExternalDataDecl _ d _) = insertTypeConsId d insertDecl (NewtypeDecl _ d _ nc _) = do insertTypeConsId d insertNewConstrDecl nc insertDecl (TypeDecl _ t _ ty) = do insertTypeConsId t insertTypeExpr ty insertDecl (FunctionDecl _ _ f _) = do cons <- isConsId f unless cons $ insertVar f insertDecl (ExternalDecl _ vs) = mapM_ (insertVar . varIdent) vs insertDecl (PatternDecl _ p _) = insertPattern False p insertDecl (FreeDecl _ vs) = mapM_ (insertVar . varIdent) vs insertDecl (ClassDecl _ _ cls _ ds) = do insertTypeConsId cls mapM_ insertVar $ concatMap methods ds insertDecl _ = ok insertTypeExpr :: TypeExpr -> WCM () insertTypeExpr (VariableType _ _) = ok insertTypeExpr (ConstructorType _ _) = ok insertTypeExpr (ApplyType _ ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2] insertTypeExpr (TupleType _ tys) = mapM_ insertTypeExpr tys insertTypeExpr (ListType _ ty) = insertTypeExpr ty insertTypeExpr (ArrowType _ ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2] insertTypeExpr (ParenType _ ty) = insertTypeExpr ty insertTypeExpr (ForallType _ _ ty) = insertTypeExpr ty insertConstrDecl :: ConstrDecl -> WCM () insertConstrDecl (ConstrDecl _ _ _ c _) = insertConsId c insertConstrDecl (ConOpDecl _ _ _ _ op _) = insertConsId op insertConstrDecl (RecordDecl _ _ _ c _) = insertConsId c insertNewConstrDecl :: NewConstrDecl -> WCM () insertNewConstrDecl (NewConstrDecl _ c _) = insertConsId c insertNewConstrDecl (NewRecordDecl _ c _) = insertConsId c -- 'fp' indicates whether 'checkPattern' deals with the arguments -- of a function pattern or not. -- Since function patterns are not recognized before syntax check, it is -- necessary to determine whether a constructor pattern represents a -- constructor or a function. insertPattern :: Bool -> Pattern a -> WCM () insertPattern fp (VariablePattern _ _ v) = do cons <- isConsId v unless cons $ do var <- isVarId v if and [fp, var, not (isAnonId v)] then visitId v else insertVar v insertPattern fp (ConstructorPattern _ _ c ps) = do cons <- isQualConsId c mapM_ (insertPattern (not cons || fp)) ps insertPattern fp (InfixPattern spi a p1 c p2) = insertPattern fp (ConstructorPattern spi a c [p1, p2]) insertPattern fp (ParenPattern _ p) = insertPattern fp p insertPattern fp (RecordPattern _ _ _ fs) = mapM_ (insertFieldPattern fp) fs insertPattern fp (TuplePattern _ ps) = mapM_ (insertPattern fp) ps insertPattern fp (ListPattern _ _ ps) = mapM_ (insertPattern fp) ps insertPattern fp (AsPattern _ v p) = insertVar v >> insertPattern fp p insertPattern fp (LazyPattern _ p) = insertPattern fp p insertPattern _ (FunctionPattern _ _ f ps) = do visitQId f mapM_ (insertPattern True) ps insertPattern _ (InfixFuncPattern spi a p1 f p2) = insertPattern True (FunctionPattern spi a f [p1, p2]) insertPattern _ _ = ok insertFieldPattern :: Bool -> Field (Pattern a) -> WCM () insertFieldPattern fp (Field _ _ p) = insertPattern fp p -- --------------------------------------------------------------------------- -- Data type for distinguishing identifiers as either (type) constructors or -- (type) variables (including functions). data IdInfo = ConsInfo -- ^ Constructor | VarInfo Ident Bool -- ^ Variable with original definition (for position) -- and used flag deriving Show isVariable :: IdInfo -> Bool isVariable (VarInfo _ _) = True isVariable _ = False getVariable :: IdInfo -> Maybe Ident getVariable (VarInfo v _) = Just v getVariable _ = Nothing isConstructor :: IdInfo -> Bool isConstructor ConsInfo = True isConstructor _ = False variableVisited :: IdInfo -> Bool variableVisited (VarInfo _ v) = v variableVisited _ = True visitVariable :: IdInfo -> IdInfo visitVariable (VarInfo v _) = VarInfo v True visitVariable info = info insertScope :: QualIdent -> IdInfo -> WCM () insertScope qid info = modifyScope $ qualBindNestEnv qid info insertVar :: Ident -> WCM () insertVar v = unless (isAnonId v) $ do known <- isKnownVar v if known then visitId v else insertScope (commonId v) (VarInfo v False) insertTypeVar :: Ident -> WCM () insertTypeVar v = unless (isAnonId v) $ insertScope (typeId v) (VarInfo v False) insertConsId :: Ident -> WCM () insertConsId c = insertScope (commonId c) ConsInfo insertTypeConsId :: Ident -> WCM () insertTypeConsId c = insertScope (typeId c) ConsInfo isVarId :: Ident -> WCM Bool isVarId v = gets (isVar $ commonId v) isConsId :: Ident -> WCM Bool isConsId c = gets (isCons $ qualify c) isQualConsId :: QualIdent -> WCM Bool isQualConsId qid = gets (isCons qid) shadows :: QualIdent -> WcState -> Maybe Ident shadows qid s = do guard $ not (qualInLocalNestEnv qid sc) info <- listToMaybe $ qualLookupNestEnv qid sc getVariable info where sc = scope s shadowsVar :: Ident -> WCM (Maybe Ident) shadowsVar v = gets (shadows $ commonId v) shadowsTypeVar :: Ident -> WCM (Maybe Ident) shadowsTypeVar v = gets (shadows $ typeId v) visitId :: Ident -> WCM () visitId v = modifyScope (qualModifyNestEnv visitVariable (commonId v)) visitQId :: QualIdent -> WCM () visitQId v = do mid <- getModuleIdent maybe ok visitId (localIdent mid v) visitTypeId :: Ident -> WCM () visitTypeId v = modifyScope (qualModifyNestEnv visitVariable (typeId v)) visitQTypeId :: QualIdent -> WCM () visitQTypeId v = do mid <- getModuleIdent maybe ok visitTypeId (localIdent mid v) isKnownVar :: Ident -> WCM Bool isKnownVar v = gets $ \s -> isKnown s (commonId v) isUnrefTypeVar :: Ident -> WCM Bool isUnrefTypeVar v = gets (\s -> isUnref s (typeId v)) returnUnrefVars :: WCM [Ident] returnUnrefVars = gets (\s -> let ids = map fst (localNestEnv (scope s)) unrefs = filter (isUnref s . qualify) ids in unrefs ) inNestedScope :: WCM a -> WCM () inNestedScope m = beginScope >> m >> endScope beginScope :: WCM () beginScope = modifyScope nestEnv endScope :: WCM () endScope = modifyScope unnestEnv ------------------------------------------------------------------------------ isKnown :: WcState -> QualIdent -> Bool isKnown s qid = qualInLocalNestEnv qid (scope s) isUnref :: WcState -> QualIdent -> Bool isUnref s qid = let sc = scope s in (any (not . variableVisited) (qualLookupNestEnv qid sc)) && qualInLocalNestEnv qid sc isVar :: QualIdent -> WcState -> Bool isVar qid s = maybe (isAnonId (unqualify qid)) isVariable (listToMaybe (qualLookupNestEnv qid (scope s))) isCons :: QualIdent -> WcState -> Bool isCons qid s = maybe (isImportedCons s qid) isConstructor (listToMaybe (qualLookupNestEnv qid (scope s))) where isImportedCons s' qid' = case qualLookupValue qid' (valueEnv s') of (DataConstructor _ _ _ _) : _ -> True (NewtypeConstructor _ _ _) : _ -> True _ -> False -- Since type identifiers and normal identifiers (e.g. functions, variables -- or constructors) don't share the same namespace, it is necessary -- to distinguish them in the scope environment of the check state. -- For this reason type identifiers are annotated with 1 and normal -- identifiers are annotated with 0. commonId :: Ident -> QualIdent commonId = qualify . unRenameIdent typeId :: Ident -> QualIdent typeId = qualify . flip renameIdent 1 -- -------------------------------------------------------------------------- -- Check Case Mode -- -------------------------------------------------------------------------- -- The following functions traverse the AST and search for (defining) -- identifiers and check if their names have the appropriate case mode. checkCaseMode :: [Decl a] -> WCM () checkCaseMode = warnFor WarnIrregularCaseMode . mapM_ checkCaseModeDecl checkCaseModeDecl :: Decl a -> WCM () checkCaseModeDecl (DataDecl _ tc vs cs _) = do checkCaseModeID isDataDeclName tc mapM_ (checkCaseModeID isVarName) vs mapM_ checkCaseModeConstr cs checkCaseModeDecl (NewtypeDecl _ tc vs nc _) = do checkCaseModeID isDataDeclName tc mapM_ (checkCaseModeID isVarName) vs checkCaseModeNewConstr nc checkCaseModeDecl (TypeDecl _ tc vs ty) = do checkCaseModeID isDataDeclName tc mapM_ (checkCaseModeID isVarName) vs checkCaseModeTypeExpr ty checkCaseModeDecl (TypeSig _ fs qty) = do mapM_ (checkCaseModeID isFuncName) fs checkCaseModeQualTypeExpr qty checkCaseModeDecl (FunctionDecl _ _ f eqs) = do checkCaseModeID isFuncName f mapM_ checkCaseModeEquation eqs checkCaseModeDecl (ExternalDecl _ vs) = mapM_ (checkCaseModeID isFuncName . varIdent) vs checkCaseModeDecl (PatternDecl _ t rhs) = do checkCaseModePattern t checkCaseModeRhs rhs checkCaseModeDecl (FreeDecl _ vs) = mapM_ (checkCaseModeID isVarName . varIdent) vs checkCaseModeDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys checkCaseModeDecl (ClassDecl _ cx cls tv ds) = do checkCaseModeContext cx checkCaseModeID isClassDeclName cls checkCaseModeID isVarName tv mapM_ checkCaseModeDecl ds checkCaseModeDecl (InstanceDecl _ cx _ inst ds) = do checkCaseModeContext cx checkCaseModeTypeExpr inst mapM_ checkCaseModeDecl ds checkCaseModeDecl _ = ok checkCaseModeConstr :: ConstrDecl -> WCM () checkCaseModeConstr (ConstrDecl _ evs cx c tys) = do mapM_ (checkCaseModeID isVarName) evs checkCaseModeContext cx checkCaseModeID isConstrName c mapM_ checkCaseModeTypeExpr tys checkCaseModeConstr (ConOpDecl _ evs cx ty1 c ty2) = do mapM_ (checkCaseModeID isVarName) evs checkCaseModeContext cx checkCaseModeTypeExpr ty1 checkCaseModeID isConstrName c checkCaseModeTypeExpr ty2 checkCaseModeConstr (RecordDecl _ evs cx c fs) = do mapM_ (checkCaseModeID isVarName) evs checkCaseModeContext cx checkCaseModeID isConstrName c mapM_ checkCaseModeFieldDecl fs checkCaseModeFieldDecl :: FieldDecl -> WCM () checkCaseModeFieldDecl (FieldDecl _ fs ty) = do mapM_ (checkCaseModeID isFuncName) fs checkCaseModeTypeExpr ty checkCaseModeNewConstr :: NewConstrDecl -> WCM () checkCaseModeNewConstr (NewConstrDecl _ nc ty) = do checkCaseModeID isConstrName nc checkCaseModeTypeExpr ty checkCaseModeNewConstr (NewRecordDecl _ nc (f, ty)) = do checkCaseModeID isConstrName nc checkCaseModeID isFuncName f checkCaseModeTypeExpr ty checkCaseModeContext :: Context -> WCM () checkCaseModeContext = mapM_ checkCaseModeConstraint checkCaseModeConstraint :: Constraint -> WCM () checkCaseModeConstraint (Constraint _ _ ty) = checkCaseModeTypeExpr ty checkCaseModeTypeExpr :: TypeExpr -> WCM () checkCaseModeTypeExpr (ApplyType _ ty1 ty2) = do checkCaseModeTypeExpr ty1 checkCaseModeTypeExpr ty2 checkCaseModeTypeExpr (VariableType _ tv) = checkCaseModeID isVarName tv checkCaseModeTypeExpr (TupleType _ tys) = mapM_ checkCaseModeTypeExpr tys checkCaseModeTypeExpr (ListType _ ty) = checkCaseModeTypeExpr ty checkCaseModeTypeExpr (ArrowType _ ty1 ty2) = do checkCaseModeTypeExpr ty1 checkCaseModeTypeExpr ty2 checkCaseModeTypeExpr (ParenType _ ty) = checkCaseModeTypeExpr ty checkCaseModeTypeExpr (ForallType _ tvs ty) = do mapM_ (checkCaseModeID isVarName) tvs checkCaseModeTypeExpr ty checkCaseModeTypeExpr _ = ok checkCaseModeQualTypeExpr :: QualTypeExpr -> WCM () checkCaseModeQualTypeExpr (QualTypeExpr _ cx ty) = do checkCaseModeContext cx checkCaseModeTypeExpr ty checkCaseModeEquation :: Equation a -> WCM () checkCaseModeEquation (Equation _ lhs rhs) = do checkCaseModeLhs lhs checkCaseModeRhs rhs checkCaseModeLhs :: Lhs a -> WCM () checkCaseModeLhs (FunLhs _ f ts) = do checkCaseModeID isFuncName f mapM_ checkCaseModePattern ts checkCaseModeLhs (OpLhs _ t1 f t2) = do checkCaseModePattern t1 checkCaseModeID isFuncName f checkCaseModePattern t2 checkCaseModeLhs (ApLhs _ lhs ts) = do checkCaseModeLhs lhs mapM_ checkCaseModePattern ts checkCaseModeRhs :: Rhs a -> WCM () checkCaseModeRhs (SimpleRhs _ e ds) = do checkCaseModeExpr e mapM_ checkCaseModeDecl ds checkCaseModeRhs (GuardedRhs _ es ds) = do mapM_ checkCaseModeCondExpr es mapM_ checkCaseModeDecl ds checkCaseModeCondExpr :: CondExpr a -> WCM () checkCaseModeCondExpr (CondExpr _ g e) = do checkCaseModeExpr g checkCaseModeExpr e checkCaseModePattern :: Pattern a -> WCM () checkCaseModePattern (VariablePattern _ _ v) = checkCaseModeID isVarName v checkCaseModePattern (ConstructorPattern _ _ _ ts) = mapM_ checkCaseModePattern ts checkCaseModePattern (InfixPattern _ _ t1 _ t2) = do checkCaseModePattern t1 checkCaseModePattern t2 checkCaseModePattern (ParenPattern _ t) = checkCaseModePattern t checkCaseModePattern (RecordPattern _ _ _ fs) = mapM_ checkCaseModeFieldPattern fs checkCaseModePattern (TuplePattern _ ts) = mapM_ checkCaseModePattern ts checkCaseModePattern (ListPattern _ _ ts) = mapM_ checkCaseModePattern ts checkCaseModePattern (AsPattern _ v t) = do checkCaseModeID isVarName v checkCaseModePattern t checkCaseModePattern (LazyPattern _ t) = checkCaseModePattern t checkCaseModePattern (FunctionPattern _ _ _ ts) = mapM_ checkCaseModePattern ts checkCaseModePattern (InfixFuncPattern _ _ t1 _ t2) = do checkCaseModePattern t1 checkCaseModePattern t2 checkCaseModePattern _ = ok checkCaseModeExpr :: Expression a -> WCM () checkCaseModeExpr (Paren _ e) = checkCaseModeExpr e checkCaseModeExpr (Typed _ e qty) = do checkCaseModeExpr e checkCaseModeQualTypeExpr qty checkCaseModeExpr (Record _ _ _ fs) = mapM_ checkCaseModeFieldExpr fs checkCaseModeExpr (RecordUpdate _ e fs) = do checkCaseModeExpr e mapM_ checkCaseModeFieldExpr fs checkCaseModeExpr (Tuple _ es) = mapM_ checkCaseModeExpr es checkCaseModeExpr (List _ _ es) = mapM_ checkCaseModeExpr es checkCaseModeExpr (ListCompr _ e stms) = do checkCaseModeExpr e mapM_ checkCaseModeStatement stms checkCaseModeExpr (EnumFrom _ e) = checkCaseModeExpr e checkCaseModeExpr (EnumFromThen _ e1 e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr (EnumFromTo _ e1 e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr (EnumFromThenTo _ e1 e2 e3) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr e3 checkCaseModeExpr (UnaryMinus _ e) = checkCaseModeExpr e checkCaseModeExpr (Apply _ e1 e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr (InfixApply _ e1 _ e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr (LeftSection _ e _) = checkCaseModeExpr e checkCaseModeExpr (RightSection _ _ e) = checkCaseModeExpr e checkCaseModeExpr (Lambda _ ts e) = do mapM_ checkCaseModePattern ts checkCaseModeExpr e checkCaseModeExpr (Let _ ds e) = do mapM_ checkCaseModeDecl ds checkCaseModeExpr e checkCaseModeExpr (Do _ stms e) = do mapM_ checkCaseModeStatement stms checkCaseModeExpr e checkCaseModeExpr (IfThenElse _ e1 e2 e3) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr e3 checkCaseModeExpr (Case _ _ e as) = do mapM_ checkCaseModeAlt as checkCaseModeExpr e checkCaseModeExpr _ = ok checkCaseModeStatement :: Statement a -> WCM () checkCaseModeStatement (StmtExpr _ e) = checkCaseModeExpr e checkCaseModeStatement (StmtDecl _ ds) = mapM_ checkCaseModeDecl ds checkCaseModeStatement (StmtBind _ t e) = do checkCaseModePattern t checkCaseModeExpr e checkCaseModeAlt :: Alt a -> WCM () checkCaseModeAlt (Alt _ t rhs) = checkCaseModePattern t >> checkCaseModeRhs rhs checkCaseModeFieldPattern :: Field (Pattern a) -> WCM () checkCaseModeFieldPattern (Field _ _ t) = checkCaseModePattern t checkCaseModeFieldExpr :: Field (Expression a) -> WCM () checkCaseModeFieldExpr (Field _ _ e) = checkCaseModeExpr e checkCaseModeID :: (CaseMode -> String -> Bool) -> Ident -> WCM () checkCaseModeID f i@(Ident _ name _) = do c <- gets caseMode unless (f c name) (report $ warnCaseMode i c) isVarName :: CaseMode -> String -> Bool isVarName CaseModeProlog (x:_) | isAlpha x = isUpper x isVarName CaseModeGoedel (x:_) | isAlpha x = isLower x isVarName CaseModeHaskell (x:_) | isAlpha x = isLower x isVarName _ _ = True isFuncName :: CaseMode -> String -> Bool isFuncName CaseModeHaskell (x:_) | isAlpha x = isLower x isFuncName CaseModeGoedel (x:_) | isAlpha x = isUpper x isFuncName CaseModeProlog (x:_) | isAlpha x = isLower x isFuncName _ _ = True isConstrName :: CaseMode -> String -> Bool isConstrName = isDataDeclName isClassDeclName :: CaseMode -> String -> Bool isClassDeclName = isDataDeclName isDataDeclName :: CaseMode -> String -> Bool isDataDeclName CaseModeProlog (x:_) | isAlpha x = isLower x isDataDeclName CaseModeGoedel (x:_) | isAlpha x = isUpper x isDataDeclName CaseModeHaskell (x:_) | isAlpha x = isUpper x isDataDeclName _ _ = True -- --------------------------------------------------------------------------- -- Warnings messages -- --------------------------------------------------------------------------- warnCaseMode :: Ident -> CaseMode -> Message warnCaseMode i@(Ident _ name _ ) c = posMessage i $ text "Wrong case mode in symbol" <+> text (escName i) <+> text "due to selected case mode" <+> text (escapeCaseMode c) <> comma <+> text "try renaming to" <+> text (caseSuggestion name) <+> text "instead" caseSuggestion :: String -> String caseSuggestion (x:xs) | isLower x = toUpper x : xs | isUpper x = toLower x : xs caseSuggestion _ = internalError "Checks.WarnCheck.caseSuggestion: Identifier starts with illegal Symbol" escapeCaseMode :: CaseMode -> String escapeCaseMode CaseModeFree = "`free`" escapeCaseMode CaseModeHaskell = "`haskell`" escapeCaseMode CaseModeProlog = "`prolog`" escapeCaseMode CaseModeGoedel = "`goedel`" warnUnrefTypeVar :: Ident -> Message warnUnrefTypeVar v = posMessage v $ hsep $ map text [ "Unreferenced type variable", escName v ] warnUnrefVar :: Ident -> Message warnUnrefVar v = posMessage v $ hsep $ map text [ "Unused declaration of variable", escName v ] warnShadowing :: Ident -> Ident -> Message warnShadowing x v = posMessage x $ text "Shadowing symbol" <+> text (escName x) <> comma <+> text "bound at:" <+> ppPosition (getPosition v) warnTypeShadowing :: Ident -> Ident -> Message warnTypeShadowing x v = posMessage x $ text "Shadowing type variable" <+> text (escName x) <> comma <+> text "bound at:" <+> ppPosition (getPosition v)