helium-1.8: src/Helium/StaticAnalysis/StaticChecks/Warnings.ag
-----------------------------------------------------------------------------
-- |The Helium Compiler : Static Analysis
--
-- Maintainer : bastiaan@cs.uu.nl
-- Stability : experimental
-- Portability : unknown
--
-- The warnings that are collected are the following:
-- 1) Suspicious function bindings (two groups of function bindings are next to each
-- other in the program; the names are similar, but only one has an
-- explicit type signature. Perhaps only one group of function bindings was intended?)
-- 2) Suspicious type variable (a type variable with at least length two that resembles a
-- known type constant)
-------------------------------------------------------------------------------
ATTR Expression Expressions MaybeExpression Pattern Patterns Alternative Alternatives
Statement Statements Declaration Declarations MaybeDeclarations LeftHandSide RightHandSide
FunctionBinding FunctionBindings Body Qualifier Qualifiers
GuardedExpression GuardedExpressions
Type Types AnnotatedType AnnotatedTypes Constructor Constructors ContextItem ContextItems
[ | warnings : {[Warning]} | ]
SEM Module
| Module body . warnings = []
loc . warnings = @body.warnings
SEM Body
| Body
lhs . warnings = @declarations.warnings ++
@suspiciousErrors
SEM Expression
| Let lhs . warnings = @expression.warnings ++
@suspiciousErrors
SEM Statement
| Let lhs . warnings = @declarations.warnings ++
@suspiciousErrors
SEM Qualifier
| Let lhs . warnings = @declarations.warnings ++
@suspiciousErrors
SEM MaybeDeclarations
| Just
lhs . warnings = @declarations.warnings ++
@suspiciousErrors
SEM Declaration
| Data
lhs . warnings = map (Unused TypeVariable) @unused ++ @lhs.warnings
| Type
lhs . warnings = map (Unused TypeVariable) @unused ++ @lhs.warnings
-------------------------------------------
-- Suspicious Function Bindings
ATTR Declarations Declaration [ | previousWasAlsoFB:{Maybe Name} suspiciousFBs : {[(Name,Name)]} | ]
SEM Body
| Body declarations . previousWasAlsoFB = Nothing
. suspiciousFBs = []
loc . suspiciousErrors = findSimilarFunctionBindings @declarations.typeSignatures @declarations.suspiciousFBs
SEM MaybeDeclarations
| Just declarations . previousWasAlsoFB = Nothing
. suspiciousFBs = []
loc . suspiciousErrors = findSimilarFunctionBindings @declarations.typeSignatures @declarations.suspiciousFBs
SEM Expression
| Let declarations . previousWasAlsoFB = Nothing
. suspiciousFBs = []
loc . suspiciousErrors = findSimilarFunctionBindings @declarations.typeSignatures @declarations.suspiciousFBs
SEM Statement
| Let declarations . previousWasAlsoFB = Nothing
. suspiciousFBs = []
loc . suspiciousErrors = findSimilarFunctionBindings @declarations.typeSignatures @declarations.suspiciousFBs
SEM Qualifier
| Let declarations . previousWasAlsoFB = Nothing
. suspiciousFBs = []
loc . suspiciousErrors = findSimilarFunctionBindings @declarations.typeSignatures @declarations.suspiciousFBs
SEM Declaration
| Type lhs . previousWasAlsoFB = Nothing
| Data lhs . previousWasAlsoFB = Nothing
| Newtype lhs . previousWasAlsoFB = Nothing
| Class lhs . previousWasAlsoFB = Nothing
| Instance lhs . previousWasAlsoFB = Nothing
| Default lhs . previousWasAlsoFB = Nothing
| PatternBinding lhs . previousWasAlsoFB = Nothing
| TypeSignature lhs . previousWasAlsoFB = Nothing
| Fixity lhs . previousWasAlsoFB = Nothing
| FunctionBindings lhs . previousWasAlsoFB = Just @bindings.name
. suspiciousFBs = case @lhs.previousWasAlsoFB of
Just name | show name `similar` show @bindings.name
-> (name,@bindings.name) : @lhs.suspiciousFBs
_ -> @lhs.suspiciousFBs
{
findSimilarFunctionBindings :: [(Name, TpScheme)] -> [(Name,Name)] -> [Warning]
findSimilarFunctionBindings environment candidates =
let namesWithTypeDef = map fst environment
in [ uncurry SimilarFunctionBindings pair
| (n1,n2) <- candidates
, let bool1 = n1 `elem` namesWithTypeDef
bool2 = n2 `elem` namesWithTypeDef
pair = if bool1 then (n2,n1) else (n1,n2)
, bool1 `xor` bool2
]
xor :: Bool -> Bool -> Bool
xor b1 b2 = not (b1 == b2)
}
-------------------------------------------
-- Suspicious Type Variables
SEM Type
| Variable lhs . warnings = let xs = [ SuspiciousTypeVariable @name.self tc
| length (show @name.self) > 1
, tc <- @lhs.allTypeConstructors
, capitalize (show @name.self) == (show tc)
]
in xs ++ @lhs.warnings
----------------------------------------------
-- Context in type signature can be simplified
SEM ContextItem [ | | contextRanges:{[Range]} ]
| ContextItem lhs.contextRanges = [@range.self]
SEM ContextItems [ | | contextRanges:{[Range]} ]
| Cons lhs.contextRanges = @hd.contextRanges ++ @tl.contextRanges
| Nil lhs.contextRanges = []
SEM Type [ | | contextRange:Range ]
| Qualified lhs.contextRange = if null @context.contextRanges
then noRange
else foldr1 mergeRanges @context.contextRanges
| Constructor lhs.contextRange = noRange
| Variable lhs.contextRange = noRange
SEM Declaration
| TypeSignature
lhs . warnings = simplifyContext @lhs.orderedTypeSynonyms @type.contextRange @intMap @typeScheme ++ @type.warnings
{
simplifyContext :: OrderedTypeSynonyms -> Range -> [(Int, Name)] -> TpScheme -> Warnings
simplifyContext synonyms range intMap typescheme =
let predicates = qualifiers (unquantify typescheme)
reduced = f predicates []
where f [] as = reverse as -- reverse to original order
f (p:ps) as
| entail synonyms standardClasses (ps++as) p = f ps as
| otherwise = f ps (p:as)
sub = listToSubstitution [ (i, TCon (show n)) | (i, n) <- intMap ]
in if length reduced == length predicates
then []
else [ ReduceContext range (sub |-> predicates) (sub |-> reduced) ]
}