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

Completely refactored warnings for non-eshaustive and overlapping patterns

Fixed #1048
parent a37fcbd5
This diff is collapsed.
...@@ -157,15 +157,14 @@ data WarnFlag ...@@ -157,15 +157,14 @@ data WarnFlag
| WarnNameShadowing -- ^ Warn for name shadowing | WarnNameShadowing -- ^ Warn for name shadowing
| WarnOverlapping -- ^ Warn for overlapping rules/alternatives | WarnOverlapping -- ^ Warn for overlapping rules/alternatives
| WarnIncompletePatterns -- ^ Warn for incomplete pattern matching | WarnIncompletePatterns -- ^ Warn for incomplete pattern matching
| WarnIdleAlternatives -- ^ Warn for idle case alternatives | WarnNondetPatterns -- ^ Warn for non-deterministic pattern matching
deriving (Eq, Bounded, Enum, Show) deriving (Eq, Bounded, Enum, Show)
-- |Warning flags enabled by default -- |Warning flags enabled by default
stdWarnFlags :: [WarnFlag] stdWarnFlags :: [WarnFlag]
stdWarnFlags = stdWarnFlags =
[ WarnMultipleImports , WarnDisjoinedRules, WarnUnusedBindings [ WarnMultipleImports , WarnDisjoinedRules, WarnUnusedBindings
, WarnNameShadowing , WarnOverlapping -- , WarnIncompletePatterns , WarnNameShadowing , WarnOverlapping , WarnIncompletePatterns
, WarnIdleAlternatives
] ]
-- |Description and flag of warnings flags -- |Description and flag of warnings flags
...@@ -183,8 +182,8 @@ warnFlags = ...@@ -183,8 +182,8 @@ warnFlags =
, "overlapping function rules" ) , "overlapping function rules" )
, ( WarnIncompletePatterns, "incomplete-patterns" , ( WarnIncompletePatterns, "incomplete-patterns"
, "incomplete pattern matching") , "incomplete pattern matching")
, ( WarnIdleAlternatives , "idle-alternatives" , ( WarnNondetPatterns , "nondet-patterns"
, "idle case alternatives" ) , "Nondeterministic patterns" )
] ]
-- |Dump level -- |Dump level
......
...@@ -12,17 +12,14 @@ ...@@ -12,17 +12,14 @@
-} -}
module Generators where module Generators where
import Curry.Base.Message (Message) import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.ExtendedFlat.Type as EF (Prog)
import qualified Curry.AbstractCurry as AC (CurryProg) import qualified Curry.Syntax as CS (Module)
import qualified Curry.ExtendedFlat.Type as EF (Prog)
import qualified Curry.Syntax as CS (Module)
import qualified Generators.GenAbstractCurry as GAC import qualified Generators.GenAbstractCurry as GAC
import qualified Generators.GenFlatCurry as GFC import qualified Generators.GenFlatCurry as GFC
import CompilerEnv import CompilerEnv
import CompilerOpts
import IL (Module) import IL (Module)
import ModuleSummary import ModuleSummary
...@@ -35,13 +32,11 @@ genUntypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg ...@@ -35,13 +32,11 @@ genUntypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genUntypedAbstractCurry = GAC.genUntypedAbstract genUntypedAbstractCurry = GAC.genUntypedAbstract
-- |Generate FlatCurry -- |Generate FlatCurry
genFlatCurry :: Options -> ModuleSummary -> CompilerEnv -> IL.Module genFlatCurry :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
-> (EF.Prog, [Message]) genFlatCurry ms env = GFC.genFlatCurry ms
genFlatCurry opts ms env = GFC.genFlatCurry opts ms
(interfaceEnv env) (valueEnv env) (tyConsEnv env) (interfaceEnv env) (valueEnv env) (tyConsEnv env)
-- |Generate a FlatCurry interface -- |Generate a FlatCurry interface
genFlatInterface :: Options -> ModuleSummary -> CompilerEnv -> IL.Module genFlatInterface :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
-> (EF.Prog, [Message]) genFlatInterface ms env = GFC.genFlatInterface ms
genFlatInterface opts ms env = GFC.genFlatInterface opts ms
(interfaceEnv env) (valueEnv env) (tyConsEnv env) (interfaceEnv env) (valueEnv env) (tyConsEnv env)
...@@ -10,16 +10,14 @@ ...@@ -10,16 +10,14 @@
module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where
-- Haskell libraries -- Haskell libraries
import Control.Monad (filterM, liftM, liftM2, liftM3, mplus, when) import Control.Monad (filterM, liftM, liftM2, liftM3, mplus)
import Control.Monad.State (State, runState, gets, modify) import Control.Monad.State (State, evalState, gets, modify)
import Data.List (mapAccumL, nub) import Data.List (mapAccumL, nub)
import qualified Data.Map as Map (Map, empty, insert, lookup, fromList, toList) import qualified Data.Map as Map (Map, empty, insert, lookup, fromList, toList)
import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust) import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust)
-- curry-base -- curry-base
import Curry.Base.Ident as Id import Curry.Base.Ident as Id
import Curry.Base.Message
import Curry.Base.Pretty
import Curry.ExtendedFlat.Type import Curry.ExtendedFlat.Type
import qualified Curry.Syntax as CS import qualified Curry.Syntax as CS
...@@ -39,7 +37,6 @@ import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC) ...@@ -39,7 +37,6 @@ import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
-- other -- other
import CompilerOpts (Options (..), WarnOpts (..), WarnFlag (..))
import qualified IL as IL import qualified IL as IL
import qualified ModuleSummary import qualified ModuleSummary
import Transformations (transType) import Transformations (transType)
...@@ -50,20 +47,16 @@ trace' _ x = x ...@@ -50,20 +47,16 @@ trace' _ x = x
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- transforms intermediate language code (IL) to FlatCurry code -- transforms intermediate language code (IL) to FlatCurry code
genFlatCurry :: Options -> ModuleSummary.ModuleSummary -> InterfaceEnv genFlatCurry :: ModuleSummary.ModuleSummary -> InterfaceEnv
-> ValueEnv -> TCEnv -> IL.Module -> (Prog, [Message]) -> ValueEnv -> TCEnv -> IL.Module -> Prog
genFlatCurry opts modSum mEnv tyEnv tcEnv mdl = (prog', messages) genFlatCurry modSum mEnv tyEnv tcEnv mdl = patchPrelude $
where run modSum mEnv tyEnv tcEnv False (visitModule mdl)
(prog, messages) = run opts modSum mEnv tyEnv tcEnv False (visitModule mdl)
prog' = patchPrelude prog -- eraseTypes $ adjustTypeInfo $
-- transforms intermediate language code (IL) to FlatCurry interfaces -- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface :: Options -> ModuleSummary.ModuleSummary -> InterfaceEnv genFlatInterface :: ModuleSummary.ModuleSummary -> InterfaceEnv
-> ValueEnv -> TCEnv -> IL.Module -> (Prog, [Message]) -> ValueEnv -> TCEnv -> IL.Module -> Prog
genFlatInterface opts modSum mEnv tyEnv tcEnv mdl = (intf' , messages) genFlatInterface modSum mEnv tyEnv tcEnv mdl = patchPrelude $
where run modSum mEnv tyEnv tcEnv True (visitModule mdl)
(intf, messages) = run opts modSum mEnv tyEnv tcEnv True (visitModule mdl)
intf' = patchPrelude intf
patchPrelude :: Prog -> Prog patchPrelude :: Prog -> Prog
patchPrelude p@(Prog n _ types funcs ops) patchPrelude p@(Prog n _ types funcs ops)
...@@ -108,7 +101,6 @@ type FlatState a = State FlatEnv a ...@@ -108,7 +101,6 @@ type FlatState a = State FlatEnv a
data FlatEnv = FlatEnv data FlatEnv = FlatEnv
{ moduleIdE :: ModuleIdent { moduleIdE :: ModuleIdent
, functionIdE :: (QualIdent, [(Ident, IL.Type)]) , functionIdE :: (QualIdent, [(Ident, IL.Type)])
, compilerOptsE :: Options
, interfaceEnvE :: InterfaceEnv , interfaceEnvE :: InterfaceEnv
, typeEnvE :: ValueEnv -- types of defined values , typeEnvE :: ValueEnv -- types of defined values
, tConsEnvE :: TCEnv , tConsEnvE :: TCEnv
...@@ -121,7 +113,6 @@ data FlatEnv = FlatEnv ...@@ -121,7 +113,6 @@ data FlatEnv = FlatEnv
, varIndexE :: Int , varIndexE :: Int
, varIdsE :: ScopeEnv Ident VarIndex , varIdsE :: ScopeEnv Ident VarIndex
, tvarIndexE :: Int , tvarIndexE :: Int
, messagesE :: [Message]
, genInterfaceE :: Bool , genInterfaceE :: Bool
, localTypes :: Map.Map QualIdent IL.Type , localTypes :: Map.Map QualIdent IL.Type
, constrTypes :: Map.Map QualIdent IL.Type , constrTypes :: Map.Map QualIdent IL.Type
...@@ -133,15 +124,13 @@ data IdentExport ...@@ -133,15 +124,13 @@ data IdentExport
| NotOnlyConstr -- constructor, function, type-constructor | NotOnlyConstr -- constructor, function, type-constructor
-- Runs a 'FlatState' action and returns the result -- Runs a 'FlatState' action and returns the result
run :: Options -> ModuleSummary.ModuleSummary -> InterfaceEnv -> ValueEnv -> TCEnv run :: ModuleSummary.ModuleSummary -> InterfaceEnv -> ValueEnv -> TCEnv
-> Bool -> FlatState a -> (a, [Message]) -> Bool -> FlatState a -> a
run opts modSum mEnv tyEnv tcEnv genIntf f = (result, reverse $ messagesE env) run modSum mEnv tyEnv tcEnv genIntf f = evalState f env0
where where
(result, env) = runState f env0
env0 = FlatEnv env0 = FlatEnv
{ moduleIdE = ModuleSummary.moduleId modSum { moduleIdE = ModuleSummary.moduleId modSum
, functionIdE = (qualify (mkIdent ""), []) , functionIdE = (qualify (mkIdent ""), [])
, compilerOptsE = opts
, interfaceEnvE = mEnv , interfaceEnvE = mEnv
, typeEnvE = tyEnv , typeEnvE = tyEnv
, tConsEnvE = tcEnv , tConsEnvE = tcEnv
...@@ -155,7 +144,6 @@ run opts modSum mEnv tyEnv tcEnv genIntf f = (result, reverse $ messagesE env) ...@@ -155,7 +144,6 @@ run opts modSum mEnv tyEnv tcEnv genIntf f = (result, reverse $ messagesE env)
, varIndexE = 0 , varIndexE = 0
, varIdsE = ScopeEnv.new , varIdsE = ScopeEnv.new
, tvarIndexE = 0 , tvarIndexE = 0
, messagesE = []
, genInterfaceE = genIntf , genInterfaceE = genIntf
, localTypes = Map.empty , localTypes = Map.empty
, constrTypes = Map.fromList $ getConstrTypes tcEnv tyEnv , constrTypes = Map.fromList $ getConstrTypes tcEnv tyEnv
...@@ -297,7 +285,7 @@ visitExpression (IL.Case r ea e bs) = ...@@ -297,7 +285,7 @@ visitExpression (IL.Case r ea e bs) =
visitExpression (IL.Or e1 e2) = do visitExpression (IL.Or e1 e2) = do
e1' <- visitExpression e1 e1' <- visitExpression e1
e2' <- visitExpression e2 e2' <- visitExpression e2
checkOverlapping e1' e2' -- checkOverlapping e1' e2'
return $ Or e1' e2' return $ Or e1' e2'
visitExpression (IL.Exist v e) = do visitExpression (IL.Exist v e) = do
idx <- newVarIndex v idx <- newVarIndex v
...@@ -758,15 +746,6 @@ matchTypeVars fs ms (l,ty) = maybe ms (match ms ty) (lookup l fs) ...@@ -758,15 +746,6 @@ matchTypeVars fs ms (l,ty) = maybe ms (match ms ty) (lookup l fs)
flattenRecordTypeFields :: [([Ident], CS.TypeExpr)] -> [(Ident, CS.TypeExpr)] flattenRecordTypeFields :: [([Ident], CS.TypeExpr)] -> [(Ident, CS.TypeExpr)]
flattenRecordTypeFields = concatMap (\ (ls, ty) -> map (\l -> (l, ty)) ls) flattenRecordTypeFields = concatMap (\ (ls, ty) -> map (\l -> (l, ty)) ls)
checkOverlapping :: Expr -> Expr -> FlatState ()
checkOverlapping e1 e2 = do
warnOpts <- optWarnOpts `liftM` compilerOpts
when (WarnOverlapping `elem` wnWarnFlags warnOpts) $ checkOverlap e1 e2
where
checkOverlap (Case _ _ _ _) _ = functionId >>= genWarning . overlappingRules
checkOverlap _ (Case _ _ _ _) = functionId >>= genWarning . overlappingRules
checkOverlap _ _ = return ()
cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> ([(Ident,Int)], IL.Type) cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> ([(Ident,Int)], IL.Type)
cs2ilType ids (CS.ConstructorType qident typeexprs) cs2ilType ids (CS.ConstructorType qident typeexprs)
= let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs = let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs
...@@ -806,11 +785,6 @@ consArity qid = "GenFlatCurry: missing arity for constructor \"" ...@@ -806,11 +785,6 @@ consArity qid = "GenFlatCurry: missing arity for constructor \""
missingVarIndex :: Show a => a -> [Char] missingVarIndex :: Show a => a -> [Char]
missingVarIndex ident = "GenFlatCurry: missing index for \"" ++ show ident ++ "\"" missingVarIndex ident = "GenFlatCurry: missing index for \"" ++ show ident ++ "\""
overlappingRules :: QualIdent -> Message
overlappingRules qid = posMessage qid $ hsep $ map text
[ "Function", '"' : qualName qid ++ "\""
, "is non-deterministic due to non-trivial overlapping rules" ]
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- --
...@@ -866,18 +840,10 @@ bindingIdent (IL.Binding ident _) = ident ...@@ -866,18 +840,10 @@ bindingIdent (IL.Binding ident _) = ident
moduleId :: FlatState ModuleIdent moduleId :: FlatState ModuleIdent
moduleId = gets moduleIdE moduleId = gets moduleIdE
--
functionId :: FlatState QualIdent
functionId = gets (fst . functionIdE)
-- --
setFunctionId :: (QualIdent, [(Ident, IL.Type)]) -> FlatState () setFunctionId :: (QualIdent, [(Ident, IL.Type)]) -> FlatState ()
setFunctionId qid = modify $ \ s -> s { functionIdE = qid } setFunctionId qid = modify $ \ s -> s { functionIdE = qid }
--
compilerOpts :: FlatState Options
compilerOpts = gets compilerOptsE
-- --
exports :: FlatState [CS.Export] exports :: FlatState [CS.Export]
exports = gets exportsE exports = gets exportsE
...@@ -1017,10 +983,6 @@ lookupVarIndex ident = do ...@@ -1017,10 +983,6 @@ lookupVarIndex ident = do
clearVarIndices :: FlatState () clearVarIndices :: FlatState ()
clearVarIndices = modify $ \ s -> s { varIndexE = 0, varIdsE = ScopeEnv.new } clearVarIndices = modify $ \ s -> s { varIndexE = 0, varIdsE = ScopeEnv.new }
--
genWarning :: Message -> FlatState ()
genWarning msg = modify $ \ s -> s { messagesE = msg : messagesE s }
-- --
genInterface :: FlatState Bool genInterface :: FlatState Bool
genInterface = gets genInterfaceE genInterface = gets genInterfaceE
......
...@@ -319,14 +319,13 @@ writeFlat opts fn env modSum il = do ...@@ -319,14 +319,13 @@ writeFlat opts fn env modSum il = do
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
-> IL.Module -> IO () -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do writeFlatCurry opts fn env modSum il = do
warn (optWarnOpts opts) msgs
when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
when fcyTarget $ EF.writeFlatCurry useSubDir (flatName fn) prog when fcyTarget $ EF.writeFlatCurry useSubDir (flatName fn) prog
where where
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts fcyTarget = FlatCurry `elem` optTargetTypes opts
useSubDir = optUseSubdir opts useSubDir = optUseSubdir opts
(prog, msgs) = genFlatCurry opts modSum env il prog = genFlatCurry modSum env il
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
-> IL.Module -> IO () -> IL.Module -> IO ()
...@@ -337,14 +336,12 @@ writeFlatIntf opts fn env modSum il ...@@ -337,14 +336,12 @@ writeFlatIntf opts fn env modSum il
mfint <- EF.readFlatInterface targetFile mfint <- EF.readFlatInterface targetFile
let oldInterface = fromMaybe emptyIntf mfint let oldInterface = fromMaybe emptyIntf mfint
when (mfint == mfint) $ return () -- necessary to close file -- TODO when (mfint == mfint) $ return () -- necessary to close file -- TODO
unless (oldInterface `eqInterface` newInterface) $ outputInterface unless (oldInterface `eqInterface` intf) $ outputInterface
where where
targetFile = flatIntName fn targetFile = flatIntName fn
emptyIntf = EF.Prog "" [] [] [] [] emptyIntf = EF.Prog "" [] [] [] []
(newInterface, intMsgs) = genFlatInterface opts modSum env il intf = genFlatInterface modSum env il
outputInterface = do outputInterface = EF.writeFlatCurry (optUseSubdir opts) targetFile intf
warn (optWarnOpts opts) intMsgs
EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
writeAbstractCurry :: Options -> FilePath -> CompilerEnv -> CS.Module -> IO () writeAbstractCurry :: Options -> FilePath -> CompilerEnv -> CS.Module -> IO ()
writeAbstractCurry opts fname env modul = do writeAbstractCurry opts fname env modul = do
......
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