helium-1.8: src/Helium/StaticAnalysis/Inferencers/PatternMatchWarnings.ag
-----------------------------------------------------------------------------
-- |The Helium Compiler : Static Analysis
--
-- Maintainer : bastiaan@cs.uu.nl
-- Stability : experimental
-- Portability : unknown
--
-- Generates warnings for incomplete and overlapping pattern matches
-- (PatternMatchWarnings.ag by Maarten Loffler)
--
-----------------------------------------------------------------------------
imports {
import Helium.Syntax.UHA_Utils
}
{
pmError :: String -> String -> a
pmError = internalError "PatternMatchWarnings"
}
-- substitution is needed for the type of a pattern
-- new warnings attribute to avoid problems with other warnings
-- warnings are merged in "TypeInferencing.ag"
ATTR Expression Expressions MaybeExpression Pattern Patterns Alternative Alternatives
Statement Statements Declaration Declarations MaybeDeclarations LeftHandSide RightHandSide
FunctionBinding FunctionBindings Body Qualifier Qualifiers
GuardedExpression GuardedExpressions
RecordExpressionBinding RecordExpressionBindings
RecordPatternBinding RecordPatternBindings
[ | patternMatchWarnings : {[Warning]} | ]
SEM Module
| Module body . patternMatchWarnings = []
-- attributes to convert a Pattern to a [PatternElement]
ATTR LeftHandSide Pattern Literal [ || elements : { [PatternElement] }]
ATTR Patterns [ || elementss : {[ [PatternElement] ]}]
ATTR FunctionBinding Alternative [ || elements : { ([PatternElement], Bool) }]
ATTR FunctionBindings Alternatives [ || elementss : {[([PatternElement], Bool)]}]
ATTR FunctionBinding Alternative [ || unrwar : Warning ]
ATTR FunctionBindings Alternatives [ || unrwars : {[Warning]}]
ATTR FunctionBinding FunctionBindings LeftHandSide [ || argcount : Int]
SEM FunctionBindings
| Nil lhs . elementss = []
lhs . unrwars = []
lhs . argcount = pmError "FunctionBindings_Nil.argcount" "?empty list of function bindings?"
| Cons lhs . elementss = @hd.elements : @tl.elementss
lhs . unrwars = @hd.unrwar : @tl.unrwars
lhs . argcount = @hd.argcount
SEM FunctionBinding
| Hole lhs . argcount = 0
. elements = ([], False)
. unrwar = pmError "FunctionBinding_Hole.unrwar" "hole unrwar"
| FunctionBinding lhs . unrwar = UnreachablePatternLHS @lefthandside.self
lhs . elements = (@lefthandside.elements, @righthandside.fallthrough)
SEM LeftHandSide
| Function lhs . elements = concat @patterns.elementss
lhs . argcount = length @patterns.self
| Infix lhs . elements = @leftPattern.elements ++ @rightPattern.elements
lhs . argcount = 2
SEM Alternatives
| Nil lhs . elementss = []
lhs . unrwars = []
| Cons lhs . elementss = @hd.elements : @tl.elementss
lhs . unrwars = @hd.unrwar : @tl.unrwars
SEM Alternative
| Hole lhs . elements = ([], False)
lhs . unrwar = pmError "Alternative_Empty.unrwar" "empty alternative"
| Alternative lhs . elements = (@pattern.elements, @righthandside.fallthrough)
lhs . unrwar = UnreachablePatternCase @range.self @pattern.self
| Empty lhs . elements = ([], False)
lhs . unrwar = pmError "Alternative_Empty.unrwar" "empty alternative"
SEM Patterns
| Nil lhs . elementss = []
| Cons lhs . elementss = @hd.elements : @tl.elementss
SEM Pattern
| Hole lhs . elements = [FiniteElement hole]
| Variable lhs . elements = [WildcardElement]
| Wildcard lhs . elements = [WildcardElement]
| Constructor lhs . elements = FiniteElement (getNameName @name.self) : concat @patterns.elementss
| InfixConstructor lhs . elements = FiniteElement (getNameName @constructorOperator.self) : @leftPattern.elements ++ @rightPattern.elements
| Record lhs . elements = pmError "Pattern_Record.elements" "Records are not supported"
| Successor lhs . elements = pmError "Pattern_Successor.elements" "Successors are not supported"
| Tuple lhs . elements = FiniteElement ("(" ++ replicate (length $ tail @patterns.self) ',' ++ ")") : concat @patterns.elementss
| List lhs . elements = listPat @patterns.elementss
SEM Literal
| Int lhs . elements = [InfiniteElement @value]
| Char lhs . elements = [InfiniteElement @value]
| Float lhs . elements = [InfiniteElement @value]
| String lhs . elements = stringPat @value
-- putting everything together
{
expandTypeFromImportEnvironment :: ImportEnvironment -> Tp -> Tp
expandTypeFromImportEnvironment env = expandType (snd $ getOrderedTypeSynonyms env)
patternMatchWarnings :: Substitution substitution
=> ImportEnvironment -- the importenvironment
-> substitution -- substitution that contains the real types
-> Tp -- type of the patterns, unsubstituted
-> (Tp -> Tps) -- how should the type be interpreted?
-> [([PatternElement], Bool)] -- the patterns to be processed
-> Range -- range for the missing-warnings
-> Maybe Name -- maybe the name of the function
-> Bool -- should there be parentheses around the patterns?
-> [Warning] -- list of overlap-warnings for all of the patterns
-> String -- description of the place where the patterns are
-> String -- symbol after the patterns
-> [Warning] -- returns: list of warnings
patternMatchWarnings impenv sub tp strip elementss rng name parens unrwars place sym
= unreachablewarnings ++ missingwarnings
where
env = importEnvironmentToEnv impenv
exprtype = expandTypeFromImportEnvironment impenv $ sub |-> tp
types = strip exprtype
unreachables = unreachable impenv types $ map (\((a, _), c) -> (a, c)) $ filter (not.snd.fst) $ zip elementss [0..]
missing = complement impenv types $ map fst elementss
unreachablewarnings = map (unrwars !!) unreachables
missingwarnings
| null $ unMissing missing = []
| otherwise = [MissingPatterns rng name exprtype (map (nicePattern parens env) $ missingList missing) place sym]
}
SEM Expression
| Case lhs . patternMatchWarnings = patternMatchWarnings @lhs.importEnvironment
@lhs.substitution
@expression.beta
(:[])
@alternatives.elementss
@range.self
Nothing
False
@alternatives.unrwars
"case expression"
"->"
++ @alternatives.patternMatchWarnings
| Lambda lhs . patternMatchWarnings = patternMatchWarnings @lhs.importEnvironment
@lhs.substitution
@loc.beta
(take (length @patterns.self) . fst . functionSpine)
[(concat @patterns.elementss, False)]
@range.self
(Just $ Name_Special noRange [] "\\") -- !!!Name
True
[]
"lambda expression"
"->"
++ @expression.patternMatchWarnings
SEM Declaration
| FunctionBindings lhs . patternMatchWarnings = patternMatchWarnings @lhs.importEnvironment
@lhs.substitution
@loc.beta
(take @bindings.argcount . fst . functionSpine)
@bindings.elementss
@range.self
(Just @bindings.name)
True
@bindings.unrwars
"function bindings"
"="
++ @bindings.patternMatchWarnings
| PatternBinding lhs . patternMatchWarnings = patternMatchWarnings @lhs.importEnvironment
@lhs.substitution
@pattern.beta
(:[])
[(@pattern.elements, @righthandside.fallthrough)]
@range.self
Nothing
False
[]
"pattern binding"
"="
++ @righthandside.patternMatchWarnings
SEM Statement
| Generator lhs . patternMatchWarnings = patternMatchWarnings @lhs.importEnvironment
@lhs.substitution
@pattern.beta
(:[])
[(@pattern.elements, False)]
@range.self
Nothing
False
[]
"generator"
"<-"
++ @expression.patternMatchWarnings
SEM Qualifier
| Generator lhs . patternMatchWarnings = patternMatchWarnings @lhs.importEnvironment
@lhs.substitution
@pattern.beta
(:[])
[(@pattern.elements, False)]
@range.self
Nothing
False
[]
"generator"
"<-"
++ @expression.patternMatchWarnings
ATTR RightHandSide GuardedExpression GuardedExpressions [ || fallthrough : Bool ]
ATTR GuardedExpressions [ open : Bool || ]
ATTR GuardedExpression [ || range : Range ]
ATTR GuardedExpression [ || unrwar : Warning ]
SEM RightHandSide
| Expression lhs . fallthrough = False
| Guarded lhs . fallthrough = @guardedexpressions.fallthrough
guardedexpressions . open = True
lhs . patternMatchWarnings = (if @guardedexpressions.fallthrough then [FallThrough @range.self] else [])
++ @where.patternMatchWarnings
SEM GuardedExpressions
| Nil lhs . fallthrough = True
| Cons lhs . fallthrough = @hd.fallthrough && @tl.fallthrough
tl . open = @hd.fallthrough && @lhs.open
lhs . patternMatchWarnings = (if not @lhs.open then [@hd.unrwar] else [])
++ @tl.patternMatchWarnings
SEM GuardedExpression
| GuardedExpression lhs . fallthrough = case @guard.self
of Expression_Variable _ (Name_Identifier _ _ "otherwise") -> False -- !!!Name
Expression_Constructor _ (Name_Identifier _ _ "True" ) -> False -- !!!Name
_ -> True
lhs . unrwar = UnreachableGuard @range.self @guard.self
SEM GuardedExpression
| GuardedExpression lhs . range = @range.self
{
----------
-- misc --
----------
-- lifted or
(|^|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
(|^|) f g x = f x || g x
----------------------------------------------
--- environments and substitution of types ---
----------------------------------------------
-- environment of constructors [(type, (constructorname, arguments))]
type Env = [(Tp, (Name, [Tp]))]
importEnvironmentToEnv :: ImportEnvironment -> [(Tp, (Name, [Tp]))]
importEnvironmentToEnv = map rearrange . M.assocs . valueConstructors
-- return the number of arguments of a constructor
-- tuples ar not in the Env so they require special treatment
nrOfArguments :: Env -> String -> Int
nrOfArguments env con | isTupleConstructor con = length con - 1
| otherwise = case lookup (nameFromString con) $ map snd env
of Just args -> length args
Nothing -> 0
-- convert constructor to fit in an Env
rearrange :: (Name, TpScheme) -> (Tp, (Name, [Tp]))
rearrange (name, tpscheme) = let (args, res) = functionSpine $ unqualify $ unquantify tpscheme
in (res, (name, args))
-- get the constructors of a given type out of an Env
-- tuples ar not in the Env so they require special treatment
constructors :: ImportEnvironment -> Tp -> [(Name, [Tp])]
constructors _ (TVar _) = []
constructors impenv tp | isTupleConstructor name = [tupleconstructor]
| otherwise = map expand $ concatMap (substitute tp) $ importEnvironmentToEnv impenv
where
name :: String
name = unTCon $ fst $ leftSpine tp
tupleconstructor :: (Name, [Tp])
tupleconstructor = (nameFromString name, snd $ leftSpine tp)
unTCon :: Tp -> String
unTCon (TCon c) = c
unTCon tp' = pmError "unTCon" $ "type " ++ show tp' ++ " is not a TCon"
expand :: (Name, [Tp]) -> (Name, [Tp])
expand (n, ts) = (n, map (expandTypeFromImportEnvironment impenv) ts)
-- check of an entry in an Env is a constructor for the given type
-- if so, return this constructor, but with variables substituted for whatever is in the given type
-- the list returns zero or one elements
-- for example: substitute (Maybe Int) (Maybe a, (Just, [a])) will return [(Just, [Int])]
substitute :: Tp -> (Tp, (Name, [Tp])) -> [(Name, [Tp])]
substitute t1 (t2, (con, args)) = let (c1, ts1) = leftSpine t1
(c2, ts2) = leftSpine t2
sub = listToSubstitution $ zip (map unTVar ts2) ts1
in if c1 == c2
then [(con, map (sub |->) args)]
else []
where
unTVar :: Tp -> Int
unTVar (TVar v) = v
unTVar _ = pmError "unTVar" "type is not a TVar"
---------------------------------------------------------------
--- datastructures and functions for the solution structure ---
---------------------------------------------------------------
-- a pattern is a list of patternelements
data PatternElement = WildcardElement | InfiniteElement String | FiniteElement String deriving Eq
isInfiniteElement :: PatternElement -> Bool
isInfiniteElement (InfiniteElement _) = True
isInfiniteElement _ = False
elementString :: PatternElement -> String
elementString (InfiniteElement s) = s
elementString ( FiniteElement s) = s
elementString _ = []
-- needed for Pattern_List and Literal_String occurences
listPat :: [[PatternElement]] -> [PatternElement]
listPat [] = [FiniteElement "[]"]
listPat (ps:pss) = FiniteElement ":" : ps ++ listPat pss
stringPat :: String -> [PatternElement]
stringPat [] = [FiniteElement "[]"]
stringPat (c:cs) = FiniteElement ":" : InfiniteElement [c] : stringPat cs
-- tree of missing patterns
data PatternsMissing = PatternsMissing [(PatternElement, PatternsMissing)]
unMissing :: PatternsMissing -> [(PatternElement, PatternsMissing)]
unMissing (PatternsMissing l) = l
-- create a branch consisting of only wildcards
wildMissing :: Int -> PatternsMissing
wildMissing 0 = PatternsMissing []
wildMissing n = PatternsMissing [(WildcardElement, wildMissing $ n - 1)]
-- convert a missing patterns tree to a list of seperated missing patterns
missingList :: PatternsMissing -> [[PatternElement]]
missingList (PatternsMissing []) = [[]]
missingList (PatternsMissing [(d,t)]) = map (d:) $ missingList t
missingList (PatternsMissing (d:ds)) = (missingList $ PatternsMissing [d]) ++ (missingList $ PatternsMissing ds)
-------------------------------------------------------------------
--- functions to create a UHA_Pattern out of a [PatternElement] ---
-------------------------------------------------------------------
-- nice creates the actual pattern without parentheses
-- [Just, True, True, (,), Just, Nothing, False] -> [Just True, True, (Just Nothing, False)]
nicePattern :: Bool -> Env -> [PatternElement] -> [Pattern]
nicePattern b env = map (parensPattern b) . nice
where
nice :: [PatternElement] -> [Pattern]
nice [] = []
nice (WildcardElement :ps) = Pattern_Wildcard noRange : nice ps
nice (InfiniteElement _ :_) = pmError "nicePattern" "InfiniteElement in pattern!"
nice (FiniteElement con:ps) =
let rest = nice ps
name = nameFromString con
n = nrOfArguments env con
in case name
of Name_Identifier _ _ _ -> Pattern_Constructor noRange name (take n rest) : drop n rest -- !!!Name
Name_Operator _ _ _ | con == ":" -> case head $ tail rest -- !!!Name
of Pattern_List _ pats -> Pattern_List noRange (head rest:pats) : (tail $ tail rest)
_ -> Pattern_InfixConstructor noRange (head rest) name (head $ tail rest) : (tail $ tail rest)
| otherwise -> Pattern_InfixConstructor noRange (head rest) name (head $ tail rest) : (tail $ tail rest)
Name_Special _ _ _ | isTupleConstructor con -> Pattern_Tuple noRange (take n rest) : drop n rest -- !!!Name
| con == "[]" -> Pattern_List noRange [] : rest
| otherwise -> Pattern_Constructor noRange name (take n rest) : drop n rest
-- add parentheses to a pattern in the correct places
-- bool means: if needed, should there be parenthesis around the complete pattern?
parensPattern :: Bool -> Pattern -> Pattern
parensPattern b = if b then rap . par else fst . par
where
par :: Pattern -> (Pattern, Bool) -- Bool means: are parentheses needed around this pattern, shoud it be used in a more complex pattern
par p@(Pattern_Literal _ _ ) = (p, False)
par p@(Pattern_Variable _ _ ) = (p, False)
par (Pattern_Constructor r n ps ) = (Pattern_Constructor r n $ map (rap.par) ps, length ps > 0)
par (Pattern_Parenthesized _ p ) = par p
par (Pattern_InfixConstructor r l n k) = (Pattern_InfixConstructor r (rap $ par l) n (rap $ par k), True)
par (Pattern_List r ps ) = (Pattern_List r $ map (fst.par) ps, False)
par (Pattern_Tuple r ps ) = (Pattern_Tuple r $ map (fst.par) ps, False)
par (Pattern_Record _ _ _ ) = pmError "parensPattern" "Records are not supported"
par p@(Pattern_Negate _ _ ) = (p, True)
par p@(Pattern_NegateFloat _ _ ) = (p, True)
par (Pattern_As r n p ) = (Pattern_As r n (rap $ par p), False)
par p@(Pattern_Wildcard _ ) = (p, False)
par (Pattern_Irrefutable _ _ ) = pmError "parensPattern" "Irrefutable patterns are not supported"
par (Pattern_Successor _ _ _ ) = pmError "parensPattern" "Successors are not supported"
par (Pattern_Hole _ _ ) = error "not supported"
rap :: (Pattern, Bool) -> Pattern
rap (p, False) = p
rap (p, True ) = Pattern_Parenthesized noRange p
--------------------------------------
--- finally, the algorithm itself! ---
--------------------------------------
-- returns the tree of missing patterns for a given list of patterns
complement :: ImportEnvironment -> [Tp] -> [[PatternElement]] -> PatternsMissing
complement _ [] _ = PatternsMissing []
complement _ _ ([]:_) = PatternsMissing []
complement env (tp:tps) pss | null $ unMissing anyComplement = PatternsMissing []
| all (((== WildcardElement) |^| isInfiniteElement).head) pss = anyComplement
| otherwise = finComplement
where
patComplement :: [[PatternElement]] -> PatternElement -> [Tp] -> PatternsMissing
patComplement [] current typs = PatternsMissing [(current, wildMissing $ length typs)]
patComplement patss current typs = case unMissing $ complement env typs $ map tail $ patss
of [] -> PatternsMissing []
tegs -> PatternsMissing [(current, PatternsMissing tegs)]
anyComplement :: PatternsMissing
anyComplement = patComplement (filter ((== WildcardElement).head) pss) WildcardElement tps
conComplement :: (Name, [Tp]) -> PatternsMissing
conComplement (con, args) = patComplement ( filter ((== FiniteElement (getNameName con)).head) pss
++ map (\ps -> FiniteElement (getNameName con) : replicate (length args) WildcardElement ++ tail ps)
(filter ((== WildcardElement).head) pss)
)
(FiniteElement (getNameName con)) (args ++ tps)
finComplement :: PatternsMissing
finComplement = case constructors env tp
of [] -> wildMissing $ 1 + length tps
cons -> PatternsMissing $ concatMap (unMissing.conComplement) cons
----------------------------
--- unreachable patterns ---
----------------------------
-- complements the list of reachable patterns
unreachable :: ImportEnvironment -> [Tp] -> [([PatternElement], Int)] -> [Int]
unreachable env tps ps = let reach = reachable env tps ps
in filter (not . flip elem reach) (map snd ps)
-- determines which patterns are reachable
-- possibly multiple occurances of indices
reachable :: ImportEnvironment -> [Tp] -> [([PatternElement], Int)] -> [Int]
reachable _ [] _ = pmError "reachable" "empty type list!"
reachable env (tp:tps) ps
| all ((== WildcardElement).head.fst) ps = conReachable ps
| otherwise = concat $ map (conReachable.conPats) $ stop cons
where
cons :: [PatternElement]
cons = thin $ map (head.fst) ps
conPats :: PatternElement -> [([PatternElement], Int)]
conPats con = map (\(es, i) -> (fill con es, i)) $ filter (((== con) |^| (== WildcardElement)).head.fst) ps
fill :: PatternElement -> [PatternElement] -> [PatternElement]
fill e@(FiniteElement c) (WildcardElement : es) = e : replicate (nrOfArguments (importEnvironmentToEnv env) c) WildcardElement ++ es
fill e (_ : es) = e : es
fill _ [] = error "Pattern match failure in StaticAnalysis.Inferencers.reachable"
stop :: [PatternElement] -> [PatternElement]
stop es | length (constructors env tp) > length es = FiniteElement "[*]" : es
| length (constructors env tp) == 0 = FiniteElement "[*]" : es
| otherwise = es
conReachable :: [([PatternElement], Int)] -> [Int]
conReachable [] = []
conReachable pats
| null.tail.fst.head $ pats = [snd.head $ pats]
| otherwise = reachable env (arguments (elementString.head.fst.head $ pats) ++ tps)
$ map (\(es, i) -> (tail es, i)) pats
arguments :: String -> [Tp]
arguments c = maybe [] id $ lookup c $ map (\(n, typs) -> (getNameName n, typs)) $ constructors env tp
-- remove double occurances and wildcards
thin :: [PatternElement] -> [PatternElement]
thin [] = []
thin (WildcardElement : es) = thin es
thin (e : es) | elem e thines = thines
| otherwise = e : thines
where thines = thin es
}