WarnCheck.hs 42.3 KB
Newer Older
1 2 3
{- |
    Module      :  $Header$
    Description :  Checks for irregular code
4
    Copyright   :  (c) 2006        Martin Engelke
5
                       2011 - 2014 Björn Peemöller
6
                       2014 - 2015 Jan Tikovsky
7 8 9 10 11 12 13 14
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module searches for potentially irregular code and generates
    warning messages.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
15
-}
Björn Peemöller 's avatar
Björn Peemöller committed
16
module Checks.WarnCheck (warnCheck) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
17

18
import           Control.Monad
19
  (filterM, foldM_, guard, liftM, liftM2, when, unless)
20 21 22 23
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)
24
import           Data.Maybe                    (catMaybes, fromMaybe, isJust)
25
import           Data.List
26
  (intersect, intersectBy, nub, sort, unionBy)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
27 28 29

import Curry.Base.Ident
import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
30
import Curry.Base.Pretty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
31
import Curry.Syntax
32
import Curry.Syntax.Pretty (ppPattern, ppExpr, ppIdent)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
33

34
import Base.CurryTypes (ppTypeScheme)
35
import Base.Messages (Message, posMessage, internalError)
36
import qualified Base.ScopeEnv as SE
Björn Peemöller 's avatar
Björn Peemöller committed
37
  ( ScopeEnv, new, beginScope, endScopeUp, insert, lookup, level, modify
38
  , lookupWithLevel, toLevelList, currentLevel)
Björn Peemöller 's avatar
Björn Peemöller committed
39

40
import Base.Types
41
import Base.Utils (findMultiples)
42
import Env.ModuleAlias
43
import Env.TypeConstructor (TCEnv, TypeInfo (..), lookupTC, qualLookupTC)
44
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
45

46 47
import CompilerOpts

48 49 50 51 52 53 54 55
-- 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
56
warnCheck :: WarnOpts -> AliasEnv -> ValueEnv -> TCEnv -> Module -> [Message]
57
warnCheck opts aEnv valEnv tcEnv (Module _ mid es is ds)
58
  = runOn (initWcState mid aEnv valEnv tcEnv (wnWarnFlags opts)) $ do
59 60 61
      checkExports   es
      checkImports   is
      checkDeclGroup ds
62
      checkMissingTypeSignatures ds
63
      checkModuleAlias is
Björn Peemöller 's avatar
Björn Peemöller committed
64

65
type ScopeEnv = SE.ScopeEnv QualIdent IdInfo
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
66

Björn Peemöller 's avatar
Björn Peemöller committed
67
-- Current state of generating warnings
Björn Peemöller 's avatar
Björn Peemöller committed
68
data WcState = WcState
69
  { moduleId    :: ModuleIdent
70
  , scope       :: ScopeEnv
71
  , aliasEnv    :: AliasEnv
Björn Peemöller 's avatar
Björn Peemöller committed
72
  , valueEnv    :: ValueEnv
73
  , tyConsEnv   :: TCEnv
74
  , warnFlags   :: [WarnFlag]
Björn Peemöller 's avatar
Björn Peemöller committed
75
  , warnings    :: [Message]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
76 77
  }

Björn Peemöller 's avatar
Björn Peemöller committed
78 79 80
-- The monadic representation of the state allows the usage of monadic
-- syntax (do expression) for dealing easier and safer with its
-- contents.
Björn Peemöller 's avatar
Björn Peemöller committed
81
type WCM = State WcState
Björn Peemöller 's avatar
Björn Peemöller committed
82

83 84 85
initWcState :: ModuleIdent -> AliasEnv -> ValueEnv -> TCEnv -> [WarnFlag]
            -> WcState
initWcState mid ae ve te wf = WcState mid SE.new ae ve te wf []
86 87 88 89

getModuleIdent :: WCM ModuleIdent
getModuleIdent = gets moduleId

90 91 92
modifyScope :: (ScopeEnv -> ScopeEnv) -> WCM ()
modifyScope f = modify $ \s -> s { scope = f $ scope s }

93 94 95 96 97
warnFor :: WarnFlag -> WCM () -> WCM ()
warnFor f act = do
  warn <- gets $ \s -> f `elem` warnFlags s
  when warn act

98 99
report :: Message -> WCM ()
report w = modify $ \ s -> s { warnings = w : warnings s }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
100

101 102 103 104 105 106 107 108 109
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)

Björn Peemöller 's avatar
Björn Peemöller committed
110 111
ok :: WCM ()
ok = return ()
Björn Peemöller 's avatar
Björn Peemöller committed
112

Björn Peemöller 's avatar
Björn Peemöller committed
113 114
-- |Run a 'WCM' action and return the list of messages
runOn :: WcState -> WCM a -> [Message]
115
runOn s f = sort $ warnings $ execState f s
Björn Peemöller 's avatar
Björn Peemöller committed
116 117 118 119 120 121 122

-- ---------------------------------------------------------------------------
-- checkExports
-- ---------------------------------------------------------------------------

checkExports :: Maybe ExportSpec -> WCM ()
checkExports _ = ok -- TODO
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
123

124
-- ---------------------------------------------------------------------------
Björn Peemöller 's avatar
Björn Peemöller committed
125
-- checkImports
126 127
-- ---------------------------------------------------------------------------

128
-- Check import declarations for multiply imported modules and multiply
Björn Peemöller 's avatar
Björn Peemöller committed
129
-- imported/hidden values.
130 131
-- The function uses a map of the already imported or hidden entities to
-- collect the entities throughout multiple import statements.
Björn Peemöller 's avatar
Björn Peemöller committed
132
checkImports :: [ImportDecl] -> WCM ()
133
checkImports = warnFor WarnMultipleImports . foldM_ checkImport Map.empty
134 135 136 137 138
  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

Björn Peemöller 's avatar
Björn Peemöller committed
139 140
  checkImportSpec env _ mid (_, _)    Nothing = do
    report $ warnMultiplyImportedModule mid
141 142 143 144
    return env

  checkImportSpec env _ mid (is, hs) (Just (Importing _ is'))
    | null is && any (`notElem` hs) is' = do
Björn Peemöller 's avatar
Björn Peemöller committed
145
        report $ warnMultiplyImportedModule mid
146 147 148
        setImportSpec env mid (is', hs)
    | null iis  = setImportSpec env mid (is' ++ is, hs)
    | otherwise = do
Björn Peemöller 's avatar
Björn Peemöller committed
149
        mapM_ (report . (warnMultiplyImportedSymbol mid) . impName) iis
150 151 152 153 154 155
        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
Björn Peemöller 's avatar
Björn Peemöller committed
156 157
        mapM_ (report . (warnMultiplyHiddenSymbol mid) . impName) ihs
        setImportSpec env mid (is, unionBy cmpImport hs' hs)
158 159 160 161 162 163 164 165 166 167 168 169
    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)

170 171 172
  impName (Import           v) = v
  impName (ImportTypeAll    t) = t
  impName (ImportTypeWith t _) = t
173

174 175 176 177 178 179 180 181 182 183 184 185 186 187
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" ]

188
-- ---------------------------------------------------------------------------
189
-- checkDeclGroup
190 191
-- ---------------------------------------------------------------------------

192 193 194 195 196 197
checkDeclGroup :: [Decl] -> WCM ()
checkDeclGroup ds = do
  mapM_ insertDecl   ds
  mapM_ checkDecl    ds
  checkRuleAdjacency ds

198 199 200 201 202 203 204 205 206
checkLocalDeclGroup :: [Decl] -> WCM ()
checkLocalDeclGroup ds = do
  mapM_ checkLocalDecl ds
  checkDeclGroup       ds

-- ---------------------------------------------------------------------------
-- Find function rules which are disjoined
-- ---------------------------------------------------------------------------

207
checkRuleAdjacency :: [Decl] -> WCM ()
208 209
checkRuleAdjacency decls = warnFor WarnDisjoinedRules
                         $ foldM_ check (mkIdent "", Map.empty) decls
210
  where
211 212 213 214 215 216 217 218 219 220 221
  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 p'
          return (f, env)
  check (_    , env) _                     = return (mkIdent "", env)

222 223 224 225
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))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
226

227
checkDecl :: Decl -> WCM ()
228 229
checkDecl (DataDecl   _ _ vs cs) = inNestedScope $ do
  mapM_ insertTypeVar   vs
230
  mapM_ checkConstrDecl cs
231 232 233
  reportUnusedTypeVars  vs
checkDecl (TypeDecl   _ _ vs ty) = inNestedScope $ do
  mapM_ insertTypeVar  vs
234
  checkTypeExpr ty
235
  reportUnusedTypeVars vs
236
checkDecl (FunctionDecl p f eqs) = checkFunctionDecl p f eqs
237 238
checkDecl (PatternDecl  _ p rhs) = checkPattern p >> checkRhs rhs
checkDecl _                      = ok
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
239

240
checkConstrDecl :: ConstrDecl -> WCM ()
241 242 243 244 245
checkConstrDecl (ConstrDecl     _ _ c tys) = do
  visitId c
  mapM_ checkTypeExpr tys
checkConstrDecl (ConOpDecl _ _ ty1 op ty2) = do
  visitId op
246
  mapM_ checkTypeExpr [ty1, ty2]
247 248 249 250 251
checkConstrDecl (RecordDecl _ _ c fs) = do
  visitId c
  mapM_ checkTypeExpr tys
  where
    tys = [ty | FieldDecl _ _ ty <- fs]
Björn Peemöller 's avatar
Björn Peemöller committed
252

253
checkTypeExpr :: TypeExpr -> WCM ()
254 255 256 257 258 259 260
checkTypeExpr (ConstructorType qid tys) = do
  visitQTypeId qid
  mapM_ checkTypeExpr tys
checkTypeExpr (VariableType          v) = visitTypeId v
checkTypeExpr (TupleType           tys) = mapM_ checkTypeExpr tys
checkTypeExpr (ListType             ty) = checkTypeExpr ty
checkTypeExpr (ArrowType       ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]
261
checkTypeExpr (ParenType            ty) = checkTypeExpr ty
262 263 264 265 266 267 268 269

-- Checks locally declared identifiers (i.e. functions and logic variables)
-- for shadowing
checkLocalDecl :: Decl -> WCM ()
checkLocalDecl (FunctionDecl _ f _) = checkShadowing f
checkLocalDecl (FreeDecl      _ vs) = mapM_ checkShadowing vs
checkLocalDecl (PatternDecl  _ p _) = checkPattern p
checkLocalDecl _                    = ok
270

271 272 273
checkFunctionDecl :: Position -> Ident -> [Equation] -> WCM ()
checkFunctionDecl _ _ []  = ok
checkFunctionDecl p f eqs = inNestedScope $ do
274
  mapM_ checkEquation eqs
275 276 277 278 279
  checkFunctionPatternMatch p f eqs

checkFunctionPatternMatch :: Position -> Ident -> [Equation] -> WCM ()
checkFunctionPatternMatch p f eqs = do
  let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs
280 281 282 283 284
  (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)
285

286 287 288
-- Check an equation for warnings.
-- This is done in a seperate scope as the left-hand-side may introduce
-- new variables.
289
checkEquation :: Equation -> WCM ()
290 291 292 293
checkEquation (Equation _ lhs rhs) = inNestedScope $ do
  checkLhs lhs
  checkRhs rhs
  reportUnusedVars
294 295

checkLhs :: Lhs -> WCM ()
296 297
checkLhs (FunLhs    f ts) = do
  visitId f
298 299
  mapM_ checkPattern ts
  mapM_ (insertPattern False) ts
300 301
checkLhs (OpLhs t1 op t2) = checkLhs (FunLhs op [t1, t2])
checkLhs (ApLhs   lhs ts) = do
302
  checkLhs lhs
303 304
  mapM_ checkPattern ts
  mapM_ (insertPattern False) ts
Björn Peemöller 's avatar
Björn Peemöller committed
305

306 307 308
checkPattern :: Pattern -> WCM ()
checkPattern (VariablePattern        v) = checkShadowing v
checkPattern (ConstructorPattern  _ ps) = mapM_ checkPattern ps
309 310
checkPattern (InfixPattern     p1 f p2) = checkPattern
                                          (ConstructorPattern f [p1, p2])
311
checkPattern (ParenPattern           p) = checkPattern p
312
checkPattern (RecordPattern       _ fs) = mapM_ (checkField checkPattern) fs
313 314 315 316 317
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
318 319
checkPattern (InfixFuncPattern p1 f p2) = checkPattern
                                          (FunctionPattern f [p1, p2])
320 321
checkPattern _                          = ok

322 323 324
-- Check the right-hand-side of an equation.
-- Because local declarations may introduce new variables, we need
-- another scope nesting.
325
checkRhs :: Rhs -> WCM ()
326 327 328
checkRhs (SimpleRhs _ e ds) = inNestedScope $ do
  checkLocalDeclGroup ds
  checkExpr e
329
  reportUnusedVars
330 331 332
checkRhs (GuardedRhs ce ds) = inNestedScope $ do
  checkLocalDeclGroup ds
  mapM_ checkCondExpr ce
333
  reportUnusedVars
Björn Peemöller 's avatar
Björn Peemöller committed
334

335
checkCondExpr :: CondExpr -> WCM ()
336 337 338 339 340 341
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
342 343 344 345
checkExpr (Record             _ fs) = mapM_ (checkField checkExpr) fs
checkExpr (RecordUpdate       e fs) = do
  checkExpr e
  mapM_ (checkField checkExpr) fs
346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363
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
364
  reportUnusedVars
365 366 367
checkExpr (Let                ds e) = inNestedScope $ do
  checkLocalDeclGroup ds
  checkExpr e
368
  reportUnusedVars
369 370
checkExpr (Do                sts e) = checkStatements sts e
checkExpr (IfThenElse   _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]
371
checkExpr (Case        _ ct e alts) = do
372
  checkExpr e
373
  mapM_ checkAlt alts
374
  checkCaseAlts ct alts
375 376 377 378 379 380 381
checkExpr _                       = ok

checkStatements :: [Statement] -> Expression -> WCM ()
checkStatements []     e = checkExpr e
checkStatements (s:ss) e = inNestedScope $ do
  checkStatement s >> checkStatements ss e
  reportUnusedVars
382 383

checkStatement :: Statement -> WCM ()
384 385 386 387 388
checkStatement (StmtExpr   _ e) = checkExpr e
checkStatement (StmtDecl    ds) = checkLocalDeclGroup ds
checkStatement (StmtBind _ p e) = do
  checkPattern p >> insertPattern False p
  checkExpr e
Björn Peemöller 's avatar
Björn Peemöller committed
389

390
checkAlt :: Alt -> WCM ()
391 392
checkAlt (Alt _ p rhs) = inNestedScope $ do
  checkPattern p >> insertPattern False p
393
  checkRhs rhs
394
  reportUnusedVars
Björn Peemöller 's avatar
Björn Peemöller committed
395

396 397
checkField :: (a -> WCM ()) -> Field a -> WCM ()
checkField check (Field _ _ x) = check x
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
398

399 400 401 402
-- -----------------------------------------------------------------------------
-- Check for missing type signatures
-- -----------------------------------------------------------------------------

403 404 405
-- |Check if every top-level function has an accompanying type signature.
-- For external function declarations, this check is already performed
-- during syntax checking.
406
checkMissingTypeSignatures :: [Decl] -> WCM ()
Björn Peemöller 's avatar
Björn Peemöller committed
407 408 409
checkMissingTypeSignatures ds = warnFor WarnMissingSignatures $ do
  let typedFs   = [f | TypeSig     _ fs _ <- ds, f <- fs]
      untypedFs = [f | FunctionDecl _ f _ <- ds, f `notElem` typedFs]
410
  unless (null untypedFs) $ do
411
    mid   <- getModuleIdent
412 413
    tyScs <- mapM getTyScheme untypedFs
    mapM_ report $ zipWith (warnMissingTypeSignature mid) untypedFs tyScs
414 415 416

getTyScheme :: Ident -> WCM TypeScheme
getTyScheme q = do
417
  m     <- getModuleIdent
418
  tyEnv <- gets valueEnv
419
  return $ case qualLookupValue (qualifyWith m q) tyEnv of
420
    [Value  _ _ tys] -> tys
421
    _                -> internalError $
422 423
      "Checks.WarnCheck.getTyScheme: " ++ show q

424
warnMissingTypeSignature :: ModuleIdent -> Ident -> TypeScheme -> Message
425 426
warnMissingTypeSignature mid i tys = posMessage i $ fsep
  [ text "Top-level binding with no type signature:"
427
  , nest 2 $ text (showIdent i) <+> text "::" <+> ppTypeScheme mid tys
428
  ]
429

430 431 432 433 434 435 436 437 438 439 440 441 442
-- -----------------------------------------------------------------------------
-- 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
443 444
  unless (null   modClash) $ mapM_ (report . warnModuleNameClash) modClash
  unless (null aliasClash) $ mapM_ (report . warnAliasNameClash ) aliasClash
445 446 447 448 449 450 451 452 453 454 455 456 457 458

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@(ModuleIdent pos _) =
          ppLine pos <> text ":" <+> text (escModuleName mid)

459
-- -----------------------------------------------------------------------------
460
-- Check for overlapping/unreachable and non-exhaustive case alternatives
461
-- -----------------------------------------------------------------------------
462

463 464 465 466
checkCaseAlts :: CaseType -> [Alt] -> WCM ()
checkCaseAlts _  []                   = ok
checkCaseAlts ct alts@(Alt p _ _ : _) = do
  let pats = map (\(Alt _ pat _) -> [pat]) alts
467
  (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats
468 469
  case ct of
    Flex -> do
470 471 472 473
      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"
474 475
    Rigid -> do
      unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
476
        warnMissingPattern p "a case alternative" nonExhaustive
477
      unless (null overlapped) $ warnFor WarnOverlapping $ report $
478
        warnUnreachablePattern p overlapped
479

480 481 482 483 484 485 486 487 488 489 490 491 492 493 494
-- -----------------------------------------------------------------------------
-- 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.
-- -----------------------------------------------------------------------------
495

496 497 498 499
checkPatternMatching :: [[Pattern]] -> WCM ([ExhaustivePats], [[Pattern]], Bool)
checkPatternMatching pats = do
  -- 1. We simplify the patterns by removing syntactic sugar temporarily
  --    for a simpler implementation.
500
  simplePats <- mapM (mapM simplifyPat) pats
501 502 503 504
  -- 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.
505
  nonExhaustive <- mapM tidyExhaustivePats missing
506 507 508 509 510 511 512 513
  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.
514 515
simplifyPat :: Pattern -> WCM Pattern
simplifyPat p@(LiteralPattern      l) = return $ case l of
516 517
  String r s -> simplifyListPattern $ map (LiteralPattern . Char r) s
  _          -> p
518
simplifyPat (NegativePattern     _ l) = return $ LiteralPattern (negateLit l)
519 520 521 522
  where
  negateLit (Int   i n) = Int   i (-n)
  negateLit (Float r d) = Float r (-d)
  negateLit x           = x
523 524 525 526 527
simplifyPat v@(VariablePattern     _) = return v
simplifyPat (ConstructorPattern c ps) = ConstructorPattern c `liftM`
                                        mapM simplifyPat ps
simplifyPat (InfixPattern    p1 c p2) = ConstructorPattern c `liftM`
                                        mapM simplifyPat [p1, p2]
528
simplifyPat (ParenPattern          p) = simplifyPat p
529
simplifyPat (RecordPattern      c fs) = do
530
  (_, ls) <- getAllLabels c
531
  let ps = map (getPattern (map field2Tuple fs)) ls
532
  simplifyPat (ConstructorPattern c ps)
533
  where
534 535
    getPattern fs' l' = fromMaybe (VariablePattern anonId)
                                  (lookup l' [(unqualify l, p) | (l, p) <- fs'])
536 537 538 539
simplifyPat (TuplePattern       _ ps)
  | null ps   = return $ ConstructorPattern qUnitId []
  | otherwise = ConstructorPattern (qTupleId (length ps))
                `liftM` mapM simplifyPat ps
540 541
simplifyPat (ListPattern        _ ps) = simplifyListPattern `liftM`
                                        mapM simplifyPat ps
542
simplifyPat (AsPattern           _ p) = simplifyPat p
543 544 545
simplifyPat (LazyPattern         _ _) = return $ VariablePattern anonId
simplifyPat (FunctionPattern     _ _) = return $ VariablePattern anonId
simplifyPat (InfixFuncPattern  _ _ _) = return $ VariablePattern anonId
546 547 548

getAllLabels :: QualIdent -> WCM (QualIdent, [Ident])
getAllLabels c = do
549
  tyEnv <- gets valueEnv
550
  case qualLookupValue c tyEnv of
551 552 553
    [DataConstructor qc _ ls _] -> return (qc, ls)
    _                           -> internalError $
          "Checks.WarnCheck.getAllLabels: " ++ show c
554

555 556 557 558
-- |Create a simplified list pattern by applying @:@ and @[]@.
simplifyListPattern :: [Pattern] -> Pattern
simplifyListPattern = foldr (\p1 p2 -> ConstructorPattern qConsId [p1, p2])
                                      (ConstructorPattern qNilId [])
559

560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
-- |'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):_)
580
  | null ps                    = return ([], IntSet.singleton n, length eqs > 1)
581 582 583
  | any isLitPat firstPats     = processLits eqs
  | any isConPat firstPats     = processCons eqs
  | all isVarPat firstPats     = processVars eqs
584
  | otherwise                  = internalError "Checks.WarnCheck.processEqs"
585
  where firstPats = map firstPat eqs
586

587 588 589 590 591 592 593
-- |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
594
  if null defaults
595
    then return $ (defaultPat : missing1, used1, nd1)
596
    else do
597
      -- Missing patterns for the default alternatives
598
      (missing2, used2, nd2) <- processEqs defaults
599
      return ( [ (wildPat : ps, cs) | (ps, cs) <- missing2 ] ++ missing1
600
             , IntSet.union used1 used2, nd1 || nd2 )
601
  where
602 603 604 605 606 607 608 609 610 611 612 613 614 615 616
  -- 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 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)
617 618
  where
  process lit = do
619 620 621 622
    let qs' = [shiftPat q | q <- qs, isVarLit lit (firstPat q)]
        ovlp = length qs' > 1
    (missing, used, nd) <- processEqs qs'
    return (map (\(xs, ys) -> (LiteralPattern lit : xs, ys)) missing, used, nd && ovlp)
623 624 625 626 627

-- |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"
628
processCons qs@(q:_) = do
629 630 631
  -- Compute any missing patterns starting with the used constructors
  (missing1, used1, nd) <- processUsedCons used_cons qs
  -- Determine unused constructors
632 633
  unused   <- getUnusedCons (map fst used_cons)
  if null unused
634
    then return (missing1, used1, nd)
635
    else if null defaults
636
      then return $ (map defaultPat unused ++ missing1, used1, nd)
637
      else do
638
        -- Missing patterns for the default alternatives
639
        (missing2, used2, nd2) <- processEqs defaults
640
        return ( [ (mkPattern c : ps, cs) | c <- unused, (ps, cs) <- missing2 ]
641
                  ++ missing1
642
               , IntSet.union used1 used2, nd || nd2)
643
  where
644 645 646
  -- used constructors (occurring in a pattern)
  used_cons    = nub $ concatMap (getCon . firstPat) qs
  -- default alternatives (variable pattern)
647
  defaults     = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ]
648 649
  -- Pattern for a non-matched constructors
  defaultPat c = (mkPattern c : replicate (length (snd q) - 1) wildPat, [])
650 651 652
  mkPattern  c = ConstructorPattern
                  (qualifyLike (fst $ head used_cons) (constrIdent c))
                  (replicate (length $ constrTypes c) wildPat)
653

654 655 656 657 658 659
-- |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)
660 661
  where
  process (c, a) = do
662
    let qs' = [ removeFirstCon c a q | q <- qs , isVarCon c (firstPat q)]
663
        ovlp = length qs' > 1
664
    (missing, used, nd) <- processEqs qs'
665
    return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd && ovlp)
666 667 668 669

  makeCon c a ps = let (args, rest) = splitAt a ps
                   in ConstructorPattern c args : rest

670 671 672
  removeFirstCon c a (n, p:ps)
    | isVarPat p = (n, replicate a wildPat ++ ps)
    | isCon c  p = (n, patArgs p           ++ ps)
673 674
  removeFirstCon _ _ _ = internalError "Checks.WarnCheck.removeFirstCon"

675 676 677 678 679
-- |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
680
  let ovlp = length eqs > 1
681 682
  (missing, used, nd) <- processEqs (map shiftPat eqs)
  return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing
683
         , IntSet.insert n used, nd && ovlp)
Björn Peemöller 's avatar
Björn Peemöller committed
684

685
-- |Return the constructors of a type not contained in the list of constructors.
686 687 688
getUnusedCons :: [QualIdent] -> WCM [DataConstr]
getUnusedCons []       = internalError "Checks.WarnCheck.getUnusedCons"
getUnusedCons qs@(q:_) = do
689
  allCons <- getConTy q >>= getTyCons q . arrowBase
690
  return [ c | c <- allCons, (constrIdent c) `notElem` map unqualify qs]
691

692
-- |Retrieve the type of a given constructor.
693 694 695
getConTy :: QualIdent -> WCM Type
getConTy q = do
  tyEnv <- gets valueEnv
696
  tcEnv <- gets tyConsEnv
697 698 699
  case qualLookupValue q tyEnv of
    [DataConstructor  _ _ _ (ForAllExist _ _ ty)] -> return ty
    [NewtypeConstructor _ _ (ForAllExist _ _ ty)] -> return ty
700
    _                                           -> case qualLookupTC q tcEnv of
701
      [AliasType _ _ ty] -> return ty
Björn Peemöller 's avatar
Björn Peemöller committed
702 703
      _                  -> internalError $
        "Checks.WarnCheck.getConTy: " ++ show q
704

705
-- |Retrieve all constructors of a given type.
706 707
getTyCons :: QualIdent -> Type -> WCM [DataConstr]
getTyCons _ (TypeConstructor tc _) = do
708
  tc'   <- unAlias tc
709
  tcEnv <- gets tyConsEnv
710
  return $ case lookupTC (unqualify tc) tcEnv of
711
    [DataType     _ _ cs] -> cs
712
    [RenamingType _ _ nc] -> [nc]
713
    _ -> case qualLookupTC tc' tcEnv of
714
      [DataType     _ _ cs] -> cs
715 716 717
      [RenamingType _ _ nc] -> [nc]
      err                   -> internalError $ "Checks.WarnCheck.getTyCons: "
                            ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv
718
getTyCons _ _ = internalError "Checks.WarnCheck.getTyCons"
719

720
-- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'.
721 722
tidyExhaustivePats :: ExhaustivePats -> WCM ExhaustivePats
tidyExhaustivePats (xs, ys) = mapM tidyPat xs >>= \xs' -> return (xs', ys)
723 724 725 726 727

-- |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
728 729 730
tidyPat :: Pattern -> WCM Pattern
tidyPat p@(LiteralPattern        _) = return p
tidyPat p@(VariablePattern       _) = return p
731
tidyPat p@(ConstructorPattern c ps)
732
  | c == qUnitId && null ps         = return $ TuplePattern noRef []
733 734 735 736
  | isQTupleId c                    = TuplePattern noRef `liftM` mapM tidyPat ps
  | c == qConsId && isFiniteList p  = ListPattern []     `liftM`
                                      mapM tidyPat (unwrapFinite p)
  | c == qConsId                    = unwrapInfinite p
737
  | otherwise                       = ConstructorPattern c `liftM` mapM tidyPat ps
738 739 740 741 742 743
  where
  isFiniteList (ConstructorPattern d []     )                = d == qNilId
  isFiniteList (ConstructorPattern d [_, e2]) | d == qConsId = isFiniteList e2
  isFiniteList _                                             = False

  unwrapFinite (ConstructorPattern _ []     ) = []
744 745 746
  unwrapFinite (ConstructorPattern _ [p1,p2]) = p1 : unwrapFinite p2
  unwrapFinite pat
    = internalError $ "WarnCheck.tidyPat.unwrapFinite: " ++ show pat
747

748 749
  unwrapInfinite (ConstructorPattern d [p1,p2]) = liftM2 (flip InfixPattern d)
                                                  (tidyPat p1)
750
                                                  (unwrapInfinite p2)
751 752 753
  unwrapInfinite p0                             = return p0

tidyPat p = internalError $ "Checks.WarnCheck.tidyPat: " ++ show p
754 755 756 757 758

-- |Get the first pattern of a list.
firstPat :: EqnInfo -> Pattern
firstPat (_, []   ) = internalError "Checks.WarnCheck.firstPat: empty list"
firstPat (_, (p:_)) = p
759

760 761 762 763
-- |Drop the first pattern of a list.
shiftPat :: EqnInfo -> EqnInfo
shiftPat (_, []    ) = internalError "Checks.WarnCheck.shiftPat: empty list"
shiftPat (n, (_:ps)) = (n, ps)
764

765
-- |Wildcard pattern.
766 767 768
wildPat :: Pattern
wildPat = VariablePattern anonId

769
-- |Retrieve any literal out of a pattern.
770 771 772 773
getLit :: Pattern -> [Literal]
getLit (LiteralPattern l) = [l]
getLit _                  = []

774
-- |Retrieve the constructor name and its arity for a pattern.
775 776 777 778
getCon :: Pattern -> [(QualIdent, Int)]
getCon (ConstructorPattern c ps) = [(c, length ps)]
getCon _                         = []

779
-- |Is a pattern a variable or literal pattern?
780 781 782
isVarLit :: Literal -> Pattern -> Bool
isVarLit l p = isVarPat p || isLit l p

783
-- |Is a pattern a variable or a constructor pattern with the given constructor?
784 785 786
isVarCon :: QualIdent -> Pattern -> Bool
isVarCon c p = isVarPat p || isCon c p

787
-- |Is a pattern a pattern matching for the given constructor?
788 789 790 791
isCon :: QualIdent -> Pattern -> Bool
isCon c (ConstructorPattern d _) = c == d
isCon _ _                        = False

792
-- |Is a pattern a pattern matching for the given literal?
793 794 795 796
isLit :: Literal -> Pattern -> Bool
isLit l (LiteralPattern m) = l == m
isLit _ _                  = False

797
-- |Is a pattern a literal pattern?
798 799 800 801
isLitPat :: Pattern -> Bool
isLitPat (LiteralPattern  _) = True
isLitPat _                   = False

802
-- |Is a pattern a variable pattern?
803 804 805 806
isVarPat :: Pattern -> Bool
isVarPat (VariablePattern _) = True
isVarPat _                   = False

807
-- |Is a pattern a constructor pattern?
808 809 810 811
isConPat :: Pattern -> Bool
isConPat (ConstructorPattern _ _) = True
isConPat      _                   = False

812
-- |Retrieve the arguments of a pattern.
813 814 815 816
patArgs :: Pattern -> [Pattern]
patArgs (ConstructorPattern _ ps) = ps
patArgs _                         = []

817 818 819 820 821 822
-- |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"
823
  $+$ text "In" <+> text loc <> char ':'
824 825 826 827 828 829 830 831 832 833 834 835 836
  $+$ 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 [] (map Literal lits))

837
-- |Warning message for unreachable patterns.
838 839
-- To shorten the output only the first 'maxPattern' are printed,
-- additional pattern are abbreviated by dots.
840 841 842 843 844
warnUnreachablePattern :: Position  -> [[Pattern]] -> Message
warnUnreachablePattern p pats = posMessage p
  $   text "Pattern matches are unreachable"
  $+$ text "In a case alternative:"
  $+$ nest 2 (vcat (ppExPats pats) <+> text "->" <+> text "...")
845 846 847 848 849 850 851 852 853 854 855
  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

856 857 858
warnNondetOverlapping :: Position -> String -> Message
warnNondetOverlapping p loc = posMessage p $
  text loc <+> text "is non-deterministic due to overlapping rules"