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