WarnCheck.hs 40.9 KB
Newer Older
1 2 3
{- |
    Module      :  $Header$
    Description :  Checks for irregular code
4
    Copyright   :  (c) 2006        Martin Engelke
5 6
                       2011 - 2014 Björn Peemöller
                       2014        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, when, unless)
20 21 22 23 24
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, 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 (..), lookupValue, 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]
Björn Peemöller 's avatar
Björn Peemöller committed
247

248
checkTypeExpr :: TypeExpr -> WCM ()
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
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]
checkTypeExpr (RecordType       fs rty) = do
  mapM_ checkTypeExpr (map snd fs)
  maybe ok checkTypeExpr rty

-- 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
267

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

checkFunctionPatternMatch :: Position -> Ident -> [Equation] -> WCM ()
checkFunctionPatternMatch p f eqs = do
  let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs
  let loc  = "an equation for " ++ escName f
  (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats
  unless (null nonExhaustive) $ warnFor WarnNondetPatterns $ report $
    warnMissingPattern p loc nonExhaustive
  unless (null overlapped) $ warnFor WarnNondetPatterns $ report $
    warnOverlapPattern p loc (idName f) "=" overlapped
  when nondet $ 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 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323
checkPattern :: Pattern -> WCM ()
checkPattern (VariablePattern        v) = checkShadowing v
checkPattern (ConstructorPattern  _ ps) = mapM_ checkPattern ps
checkPattern (InfixPattern     p1 f p2)
  = checkPattern (ConstructorPattern f [p1, p2])
checkPattern (ParenPattern           p) = checkPattern p
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 p1 f p2)
  = checkPattern (FunctionPattern f [p1, p2])
checkPattern  (RecordPattern      fs r) = do
  mapM_ (\ (Field _ _ p) -> checkPattern p) fs
  maybe ok checkPattern r
checkPattern _                          = ok

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

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

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

checkStatement :: Statement -> WCM ()
387 388 389 390 391
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
392

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

399
checkFieldExpression :: Field Expression -> WCM ()
400
checkFieldExpression (Field _ _ e) = checkExpr e -- Hier auch "visitId ident" ?
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
401

402 403 404 405 406 407 408 409 410 411
-- -----------------------------------------------------------------------------
-- Check for missing type signatures
-- -----------------------------------------------------------------------------

-- check if a type signature was specified for every top-level function
-- declaration
-- for external function declarations this check is already performed
-- during syntax checking

checkMissingTypeSignatures :: [Decl] -> WCM ()
412
checkMissingTypeSignatures decls = warnFor WarnMissingSignatures $ do
413 414 415
  let typedFs   = [f | TypeSig     _ fs _ <- decls, f <- fs]
      untypedFs = [f | FunctionDecl _ f _ <- decls, f `notElem` typedFs]
  unless (null untypedFs) $ do
416
    mid   <- getModuleIdent
417 418
    tyScs <- mapM getTyScheme untypedFs
    mapM_ report $ zipWith (warnMissingTypeSignature mid) untypedFs tyScs
419 420 421 422 423 424

getTyScheme :: Ident -> WCM TypeScheme
getTyScheme q = do
  tyEnv <- gets valueEnv
  return $ case lookupValue q tyEnv of
    [Value  _ _ tys] -> tys
425
    _                -> internalError $
426 427
      "Checks.WarnCheck.getTyScheme: " ++ show q

428 429 430 431 432
warnMissingTypeSignature :: ModuleIdent -> Ident -> TypeScheme -> Message
warnMissingTypeSignature mid i tys = posMessage i $ hsep (map text
  ["Top-level binding with no type signature:", showIdent i, "::"])
  <+> ppTypeScheme mid tys

433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461
-- -----------------------------------------------------------------------------
-- 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@(ModuleIdent pos _) =
          ppLine pos <> text ":" <+> text (escModuleName mid)

462
-- -----------------------------------------------------------------------------
463
-- Check for overlapping and non-exhaustive case alternatives
464
-- -----------------------------------------------------------------------------
465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483
checkCaseAlts :: CaseType -> [Alt] -> WCM ()
checkCaseAlts _  []                   = ok
checkCaseAlts ct alts@(Alt p _ _ : _) = do
  let pats = map (\(Alt _ pat _) -> [pat]) alts
  let loc  = "a fcase alternative"
  (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats
  case ct of
    Flex -> do
      unless (null nonExhaustive) $ warnFor WarnNondetPatterns $ report $
        warnMissingPattern p loc nonExhaustive
      unless (null overlapped) $ warnFor WarnNondetPatterns $ report $
        warnOverlapPattern p loc "" "->" overlapped
      when nondet $ warnFor WarnOverlapping $ report $
        warnNondetOverlapping p ("A fcase expression")
    Rigid -> do
      unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
        warnMissingPattern p loc nonExhaustive
      unless (null overlapped) $ warnFor WarnOverlapping $ report $
        warnOverlapPattern p loc "" "->" overlapped
484

485 486 487 488 489 490 491 492 493 494 495 496 497 498 499
-- -----------------------------------------------------------------------------
-- 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.
-- -----------------------------------------------------------------------------
500

501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517
checkPatternMatching :: [[Pattern]] -> WCM ([ExhaustivePats], [[Pattern]], Bool)
checkPatternMatching pats = do
  -- 1. We simplify the patterns by removing syntactic sugar temporarily
  --    for a simpler implementation.
  let simplePats = map (map 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.
  let nonExhaustive = 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
518
--   * record pattern (currently ignored)
519
-- All other patterns like as-patterns, list patterns and alike are desugared.
520
simplifyPat :: Pattern -> Pattern
521 522 523
simplifyPat p@(LiteralPattern      l) = case l of
  String r s -> simplifyListPattern $ map (LiteralPattern . Char r) s
  _          -> p
524 525 526 527 528 529 530 531 532 533 534 535 536
simplifyPat (NegativePattern     _ l) = LiteralPattern (negateLit l)
  where
  negateLit (Int   i n) = Int   i (-n)
  negateLit (Float r d) = Float r (-d)
  negateLit x           = x
simplifyPat v@(VariablePattern     _) = v
simplifyPat (ConstructorPattern c ps)
  = ConstructorPattern c (map simplifyPat ps)
simplifyPat (InfixPattern    p1 c p2)
  = ConstructorPattern c (map simplifyPat [p1, p2])
simplifyPat (ParenPattern          p) = simplifyPat p
simplifyPat (TuplePattern       _ ps)
  = ConstructorPattern (qTupleId (length ps)) (map simplifyPat ps)
537
simplifyPat (ListPattern        _ ps) = simplifyListPattern (map simplifyPat ps)
538 539 540 541
simplifyPat (AsPattern           _ p) = simplifyPat p
simplifyPat (LazyPattern         _ _) = VariablePattern anonId
simplifyPat p                         = p

542 543 544 545
-- |Create a simplified list pattern by applying @:@ and @[]@.
simplifyListPattern :: [Pattern] -> Pattern
simplifyListPattern = foldr (\p1 p2 -> ConstructorPattern qConsId [p1, p2])
                                      (ConstructorPattern qNilId [])
546

547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571
-- |'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, False)
  | any isLitPat firstPats     = processLits eqs
  | any isConPat firstPats     = processCons eqs
  | all isVarPat firstPats     = processVars eqs
  | otherwise                  = error "WarnCheck.processEqs"
572
  where firstPats = map firstPat eqs
573

574 575 576 577 578 579 580
-- |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
581
  if null defaults
582
    then return $ (defaultPat : missing1, used1, nd1)
583
    else do
584 585 586 587
      -- Missing patterns for the default alternatives
      (missing2, used2, _) <- processEqs defaults
      return ( [ (wildPat : ps, cs) | (ps, cs) <- missing2 ] ++ missing1
             , IntSet.union used1 used2, True )
588
  where
589 590 591 592 593 594 595 596 597 598 599 600 601 602 603
  -- 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)
604 605
  where
  process lit = do
606 607 608 609 610 611 612 613
    (missing, used, nd) <- processEqs
                       [shiftPat q | q <- qs, isVarLit lit (firstPat q)]
    return (map (\(xs, ys) -> (LiteralPattern lit : xs, ys)) missing, used, nd)

-- |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"
614
processCons qs@(q:_) = do
615 616 617
  -- Compute any missing patterns starting with the used constructors
  (missing1, used1, nd) <- processUsedCons used_cons qs
  -- Determine unused constructors
618 619
  unused   <- getUnusedCons (map fst used_cons)
  if null unused
620
    then return (missing1, used1, nd || not (null defaults))
621
    else if null defaults
622
      then return $ (map defaultPat unused ++ missing1, used1, nd)
623
      else do
624 625 626
        -- Missing patterns for the default alternatives
        (missing2, used2, _) <- processEqs defaults
        return ( [ (mkPattern c : ps, cs) | c <- unused, (ps, cs) <- missing2 ]
627
                  ++ missing1
628
               , IntSet.union used1 used2, True)
629
  where
630 631 632
  -- used constructors (occurring in a pattern)
  used_cons    = nub $ concatMap (getCon . firstPat) qs
  -- default alternatives (variable pattern)
633
  defaults     = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ]
634 635
  -- Pattern for a non-matched constructors
  defaultPat c = (mkPattern c : replicate (length (snd q) - 1) wildPat, [])
636 637 638
  mkPattern (DataConstr c _ tys)
    = ConstructorPattern (qualifyLike (fst $ head used_cons) c)
                         (replicate (length tys) wildPat)
639

640 641 642 643 644 645
-- |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)
646 647
  where
  process (c, a) = do
648 649 650
    let qs' = [ removeFirstCon c a q | q <- qs , isVarCon c (firstPat q)]
    (missing, used, nd) <- processEqs qs'
    return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd)
651 652 653 654

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

655 656 657
  removeFirstCon c a (n, p:ps)
    | isVarPat p = (n, replicate a wildPat ++ ps)
    | isCon c  p = (n, patArgs p           ++ ps)
658 659
  removeFirstCon _ _ _ = internalError "Checks.WarnCheck.removeFirstCon"

660 661 662 663 664 665 666 667
-- |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
  (missing, used, nd) <- processEqs (map shiftPat eqs)
  return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing
         , IntSet.insert n used, nd)
Björn Peemöller 's avatar
Björn Peemöller committed
668

669
-- |Return the constructors of a type not contained in the list of constructors.
670 671 672 673 674 675
getUnusedCons :: [QualIdent] -> WCM [DataConstr]
getUnusedCons []       = internalError "Checks.WarnCheck.getUnusedCons"
getUnusedCons qs@(q:_) = do
  allCons <- getConTy q >>= getTyCons . arrowBase
  return [ c | c@(DataConstr q' _ _) <- allCons, q' `notElem` map unqualify qs]

676
-- |Retrieve the type of a given constructor.
677 678 679
getConTy :: QualIdent -> WCM Type
getConTy q = do
  tyEnv <- gets valueEnv
680 681 682
  return $ case qualLookupValue q tyEnv of
    [DataConstructor  _ _ (ForAllExist _ _ ty)] -> ty
    [NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty
683 684
    _                                           ->
      internalError $ "Checks.WarnCheck.getConTy: " ++ show q
685

686
-- |Retrieve all constructors of a given type.
687 688
getTyCons :: Type -> WCM [DataConstr]
getTyCons (TypeConstructor tc _) = do
689
  tc'   <- unAlias tc
690
  tcEnv <- gets tyConsEnv
691
  return $ case lookupTC (unqualify tc) tcEnv of
692 693
    [DataType     _ _ cs] -> catMaybes cs
    [RenamingType _ _ nc] -> [nc]
694
    _ -> case qualLookupTC tc' tcEnv of
695 696 697 698
      [DataType     _ _ cs] -> catMaybes cs
      [RenamingType _ _ nc] -> [nc]
      err                   -> internalError $ "Checks.WarnCheck.getTyCons: "
                            ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv
699 700
getTyCons _ = internalError "Checks.WarnCheck.getTyCons"

701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732
-- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'.
tidyExhaustivePats :: [ExhaustivePats] -> [ExhaustivePats]
tidyExhaustivePats = map (\(xs, ys) -> (map tidyPat 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 -> Pattern
tidyPat p@(ConstructorPattern c ps)
  | isQTupleId c                   = TuplePattern noRef (map tidyPat ps)
  | c == qConsId && isFiniteList p = ListPattern [] (unwrapFinite p)
  | c == qConsId                   = unwrapInfinite p
  where
  isFiniteList (ConstructorPattern d []     )                = d == qNilId
  isFiniteList (ConstructorPattern d [_, e2]) | d == qConsId = isFiniteList e2
  isFiniteList _                                             = False

  unwrapFinite (ConstructorPattern _ []     ) = []
  unwrapFinite (ConstructorPattern _ [p1,p2]) = tidyPat p1 : unwrapFinite p2
  unwrapFinite _
    = internalError "WarnCheck.tidyPat.unwrapFinite"

  unwrapInfinite (ConstructorPattern d [p1,p2]) = InfixPattern (tidyPat p1) d
                                                  (unwrapInfinite p2)
  unwrapInfinite p0                             = p0
tidyPat p = p

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

734 735 736 737
-- |Drop the first pattern of a list.
shiftPat :: EqnInfo -> EqnInfo
shiftPat (_, []    ) = internalError "Checks.WarnCheck.shiftPat: empty list"
shiftPat (n, (_:ps)) = (n, ps)
738

739
-- |Wildcard pattern.
740 741 742
wildPat :: Pattern
wildPat = VariablePattern anonId

743
-- |Retrieve any literal out of a pattern.
744 745 746 747
getLit :: Pattern -> [Literal]
getLit (LiteralPattern l) = [l]
getLit _                  = []

748
-- |Retrieve the constructor name and its arity for a pattern.
749 750 751 752
getCon :: Pattern -> [(QualIdent, Int)]
getCon (ConstructorPattern c ps) = [(c, length ps)]
getCon _                         = []

753
-- |Is a pattern a variable or literal pattern?
754 755 756
isVarLit :: Literal -> Pattern -> Bool
isVarLit l p = isVarPat p || isLit l p

757
-- |Is a pattern a variable or a constructor pattern with the given constructor?
758 759 760
isVarCon :: QualIdent -> Pattern -> Bool
isVarCon c p = isVarPat p || isCon c p

761
-- |Is a pattern a pattern matching for the given constructor?
762 763 764 765
isCon :: QualIdent -> Pattern -> Bool
isCon c (ConstructorPattern d _) = c == d
isCon _ _                        = False

766
-- |Is a pattern a pattern matching for the given literal?
767 768 769 770
isLit :: Literal -> Pattern -> Bool
isLit l (LiteralPattern m) = l == m
isLit _ _                  = False

771
-- |Is a pattern a literal pattern?
772 773 774 775
isLitPat :: Pattern -> Bool
isLitPat (LiteralPattern  _) = True
isLitPat _                   = False

776
-- |Is a pattern a variable pattern?
777 778 779 780
isVarPat :: Pattern -> Bool
isVarPat (VariablePattern _) = True
isVarPat _                   = False

781
-- |Is a pattern a constructor pattern?
782 783 784 785
isConPat :: Pattern -> Bool
isConPat (ConstructorPattern _ _) = True
isConPat      _                   = False

786
-- |Retrieve the arguments of a pattern.
787 788 789 790
patArgs :: Pattern -> [Pattern]
patArgs (ConstructorPattern _ ps) = ps
patArgs _                         = []

791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834
-- |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 a" <+> 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 [] (map Literal lits))

-- |Warning message for non-exhaustive patterns.
-- To shorten the output only the first 'maxPattern' are printed,
-- additional pattern are abbreviated by dots.
warnOverlapPattern :: Position -> String -> String -> String
                   -> [[Pattern]] -> Message
warnOverlapPattern p loc pre post pats = posMessage p
  $   text "Pattern matches are overlapped"
  $+$ text "In a" <+> text loc <> char ':'
  $+$ nest 2 (text pre <+> vcat (ppExPats pats) <+> text post <+> 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 non-deterministic due to non-trivial overlapping rules"

835
-- -----------------------------------------------------------------------------
836

837
checkShadowing :: Ident -> WCM ()
838 839
checkShadowing x = warnFor WarnNameShadowing $
  shadowsVar x >>= maybe ok (report . warnShadowing x)
840 841

reportUnusedVars :: WCM ()
842
reportUnusedVars = warnFor WarnUnusedBindings $ do
843
  unused <- returnUnrefVars
844 845 846
  unless (null unused) $ mapM_ report $ map warnUnrefVar unused

reportUnusedTypeVars :: [Ident] -> WCM ()
847
reportUnusedTypeVars vs = warnFor WarnUnusedBindings $ do
848 849
  unused <- filterM isUnrefTypeVar vs
  unless (null unused) $ mapM_ report $ map warnUnrefTypeVar unused
850

851 852
-- ---------------------------------------------------------------------------
-- For detecting unreferenced variables, the following functions update the
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
853 854 855
-- current check state by adding identifiers occuring in declaration left hand
-- sides.

Björn Peemöller 's avatar
Björn Peemöller committed
856
insertDecl :: Decl -> WCM ()
857 858 859 860 861 862 863 864 865 866 867 868 869 870
insertDecl (DataDecl     _ d _ cs) = do
  insertTypeConsId d
  mapM_ insertConstrDecl cs
insertDecl (TypeDecl     _ t _ ty) = do
  insertTypeConsId t
  insertTypeExpr ty
insertDecl (FunctionDecl    _ f _) = do
  cons <- isConsId f
  unless cons $ insertVar f
insertDecl (ForeignDecl _ _ _ f _) = insertVar f
insertDecl (ExternalDecl     _ vs) = mapM_ insertVar vs
insertDecl (PatternDecl     _ p _) = insertPattern False p
insertDecl (FreeDecl         _ vs) = mapM_ insertVar vs
insertDecl _                       = ok
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
871

Björn Peemöller 's avatar
Björn Peemöller committed
872
insertTypeExpr :: TypeExpr -> WCM ()
873 874 875 876 877 878 879 880
insertTypeExpr (VariableType        _) = ok
insertTypeExpr (ConstructorType _ tys) = mapM_ insertTypeExpr tys
insertTypeExpr (TupleType         tys) = mapM_ insertTypeExpr tys
insertTypeExpr (ListType           ty) = insertTypeExpr ty
insertTypeExpr (ArrowType     ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]
insertTypeExpr (RecordType      _ rty) = do
  --mapM_ insertVar (concatMap fst fs)
  maybe (return ()) insertTypeExpr rty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
881

Björn Peemöller 's avatar
Björn Peemöller committed
882
insertConstrDecl :: ConstrDecl -> WCM ()
883 884 885 886 887 888
insertConstrDecl (ConstrDecl _ _    c _) = insertConsId c
insertConstrDecl (ConOpDecl  _ _ _ op _) = insertConsId op

-- '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
889
-- necessary to determine whether a constructor pattern represents a
890
-- constructor or a function.
891
insertPattern :: Bool -> Pattern -> WCM ()
892 893 894
insertPattern fp (VariablePattern        v) = do
  cons <- isConsId v
  unless cons $ do
895
    var <- isVarId v
896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912
    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 p1 c p2)
  = insertPattern fp (ConstructorPattern c [p1, p2])
insertPattern fp (ParenPattern           p) = insertPattern fp p
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     _ ps) = mapM_ (insertPattern True) ps
insertPattern _  (InfixFuncPattern p1 f p2)
  = insertPattern True (FunctionPattern f [p1, p2])
insertPattern fp (RecordPattern      fs r) = do
  mapM_ (insertFieldPattern fp) fs
  maybe (return ()) (insertPattern fp) r
913
insertPattern _ _ = ok
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
914

915
insertFieldPattern :: Bool -> Field Pattern -> WCM ()
916
insertFieldPattern fp (Field _ _ p) = insertPattern fp p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
917

918
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
919 920 921

-- Data type for distinguishing identifiers as either (type) constructors or
-- (type) variables (including functions).
922 923 924 925 926
data IdInfo
  = ConsInfo           -- ^ Constructor
  | VarInfo Ident Bool -- ^ Variable with original definition (for position)
                       --   and used flag
  deriving Show
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
927 928

isVariable :: IdInfo -> Bool
929 930 931 932 933 934
isVariable (VarInfo _ _) = True
isVariable _             = False

getVariable :: IdInfo -> Maybe Ident
getVariable (VarInfo v _) = Just v
getVariable _             = Nothing
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
935 936 937 938 939 940

isConstructor :: IdInfo -> Bool
isConstructor ConsInfo = True
isConstructor _        = False

variableVisited :: IdInfo -> Bool
941 942
variableVisited (VarInfo _ v) = v
variableVisited _             = True
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
943 944

visitVariable :: IdInfo -> IdInfo
945 946
visitVariable (VarInfo v _) = VarInfo v True
visitVariable  info         = info
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
947

948
insertScope :: QualIdent -> IdInfo -> WCM ()
949
insertScope qid info = modifyScope $ SE.insert qid info
950

Björn Peemöller 's avatar
Björn Peemöller committed
951
insertVar :: Ident -> WCM ()
952 953 954
insertVar v = unless (isAnonId v) $ do
  known <- isKnownVar v
  if known then visitId v else insertScope (commonId v) (VarInfo v False)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
955

Björn Peemöller 's avatar
Björn Peemöller committed
956
insertTypeVar :: Ident -> WCM ()
957 958
insertTypeVar v = unless (isAnonId v)
                $ insertScope (typeId v) (VarInfo v False)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
959

Björn Peemöller 's avatar
Björn Peemöller committed
960
insertConsId :: Ident -> WCM ()
961
insertConsId c = insertScope (commonId c) ConsInfo
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
962

Björn Peemöller 's avatar
Björn Peemöller committed
963
insertTypeConsId :: Ident -> WCM ()
964
insertTypeConsId c = insertScope (typeId c) ConsInfo
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
965

Björn Peemöller 's avatar
Björn Peemöller committed
966
isVarId :: Ident -> WCM Bool
967
isVarId v = gets (isVar $ commonId v)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
968

Björn Peemöller 's avatar
Björn Peemöller committed
969
isConsId :: Ident -> WCM Bool
970
isConsId c = gets (isCons $ qualify c)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
971

Björn Peemöller 's avatar
Björn Peemöller committed
972
isQualConsId :: QualIdent -> WCM Bool
973
isQualConsId qid = gets (isCons qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
974