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

Fixed bug in check for non-exhaustive pattern matching

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