-----------------------------------------------------------------------------
-- |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) ]
}