diff --git a/CHANGELOG.md b/CHANGELOG.md index fcc38fe722c364730f98a2b4e50a9f6316f9e5d1..28e4005f2d9e7e193c593721c7942e7b2e45f977 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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, diff --git a/src/Checks.hs b/src/Checks.hs index 8b8d3c658938566d9cc1ab91b4d5b03dffee3dba..9beb6cfe56dfccad94b14e6592c4a394e5220b20 100644 --- a/src/Checks.hs +++ b/src/Checks.hs @@ -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 diff --git a/src/Checks/WarnCheck.hs b/src/Checks/WarnCheck.hs index bcadd3cc32e4899a32880590946b50f497ffebf9..f6ffe4e187b69f4c39358f73edb8f20ca08c344a 100644 --- a/src/Checks/WarnCheck.hs +++ b/src/Checks/WarnCheck.hs @@ -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