Commit ad56c5de authored by Björn Peemöller 's avatar Björn Peemöller

Fixed bug in check for non-exhaustive pattern matching

parent d185f867
......@@ -4,6 +4,9 @@ Change log for curry-frontend
Version 0.3.9
=============
* Fixed bug in non-exhaustive pattern matching check which occured
when retrieving the siblings of a constructor imported using an alias.
* Fixed bug when using functional patterns in `case`-expressions.
Functional patterns are only allowed in the patterns of a function
definition and forbidden elsewhere, i.e., in `case`-expressions,
......
......@@ -87,8 +87,7 @@ exportCheck _ env (Module ps m es is ds)
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
(tyConsEnv env) (valueEnv env) es
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck :: Options -> CompilerEnv -> Module -> [Message]
warnCheck opts env mdl = WC.warnCheck opts (valueEnv env) (tyConsEnv env) mdl
warnCheck opts env mdl
= WC.warnCheck opts (aliasEnv env) (valueEnv env) (tyConsEnv env) mdl
......@@ -34,11 +34,14 @@ import qualified Base.ScopeEnv as SE
, lookupWithLevel, toLevelList, currentLevel)
import Base.Types
import Env.ModuleAlias
import Env.TypeConstructor (TCEnv, TypeInfo (..), lookupTC, qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import CompilerOpts
import Debug.Trace
-- Find potentially incorrect code in a Curry program and generate warnings
-- for the following issues:
-- - multiply imported modules, multiply imported/hidden values
......@@ -47,9 +50,9 @@ import CompilerOpts
-- - idle case alternatives
-- - overlapping case alternatives
-- - non-adjacent function rules
warnCheck :: Options -> ValueEnv -> TCEnv -> Module -> [Message]
warnCheck opts valEnv tcEnv (Module _ mid es is ds)
= runOn (initWcState mid valEnv tcEnv (optWarnFlags opts)) $ do
warnCheck :: Options -> AliasEnv -> ValueEnv -> TCEnv -> Module -> [Message]
warnCheck opts aEnv valEnv tcEnv (Module _ mid es is ds)
= runOn (initWcState mid aEnv valEnv tcEnv (optWarnFlags opts)) $ do
checkExports es
checkImports is
checkDeclGroup ds
......@@ -60,6 +63,7 @@ type ScopeEnv = SE.ScopeEnv QualIdent IdInfo
data WcState = WcState
{ moduleId :: ModuleIdent
, scope :: ScopeEnv
, aliasEnv :: AliasEnv
, valueEnv :: ValueEnv
, tyConsEnv :: TCEnv
, warnFlags :: [WarnFlag]
......@@ -71,8 +75,9 @@ data WcState = WcState
-- contents.
type WCM = State WcState
initWcState :: ModuleIdent -> ValueEnv -> TCEnv -> [WarnFlag] -> WcState
initWcState mid ve te wf = WcState mid SE.new ve te wf []
initWcState :: ModuleIdent -> AliasEnv -> ValueEnv -> TCEnv -> [WarnFlag]
-> WcState
initWcState mid ae ve te wf = WcState mid SE.new ae ve te wf []
getModuleIdent :: WCM ModuleIdent
getModuleIdent = gets moduleId
......@@ -88,6 +93,15 @@ warnFor f act = do
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 ()
......@@ -549,23 +563,24 @@ getUnusedCons qs@(q:_) = do
getConTy :: QualIdent -> WCM Type
getConTy q = do
tyEnv <- gets valueEnv
return $ case qualLookupValue q tyEnv of
[DataConstructor _ _ (ForAllExist _ _ ty)] -> ty
[NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty
return $ trace ("getConTy: " ++ show q) $ case qualLookupValue q tyEnv of
[DataConstructor _ _ (ForAllExist _ _ ty)] -> trace (show ty) ty
[NewtypeConstructor _ (ForAllExist _ _ ty)] -> trace (show ty) ty
_ -> internalError $
"Checks.WarnCheck.getConTy: " ++ show q
getTyCons :: Type -> WCM [DataConstr]
getTyCons (TypeConstructor tc _) = do
tc' <- unAlias tc
tcEnv <- gets tyConsEnv
return $ case lookupTC (unqualify tc) tcEnv of
[DataType _ _ cs] -> catMaybes cs
[RenamingType _ _ nc] -> [nc]
_ -> case qualLookupTC tc tcEnv of
[DataType _ _ cs] -> catMaybes cs
[RenamingType _ _ nc] -> [nc]
err -> internalError $
"Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv
_ -> case qualLookupTC tc' tcEnv of
[DataType _ _ cs] -> catMaybes cs
[RenamingType _ _ nc] -> [nc]
err -> internalError $
"Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv
getTyCons _ = internalError "Checks.WarnCheck.getTyCons"
firstPat :: [Pattern] -> Pattern
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment