TopLevelErrors.ag

-----------------------------------------------------------------------------
-- |The Helium Compiler : Static Analysis
-- 
-- Maintainer  :  bastiaan@cs.uu.nl
-- Stability   :  experimental
-- Portability :  unknown
--
-- Collect static errors that are detected at top-level. 
--
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- All Top-Level Errors

SEM Module
  | Module   loc . topLevelErrors = concat [ @typeConstructorErrors  
                                           , @valueConstructorErrors
                                           , @fixityErrors
                                           , @fixityButNoFunDefErrors
                                           , @wrongFlagErrors
                                           , @recursiveTypeSynonymErrors
                                           , @wrongFileNameErrors
                                           ]
                 
------------------------------------------------------------------------------
-- duplicated type constructors

SEM Module 
  | Module   loc . typeConstructorErrors = makeDuplicated TypeConstructor @duplicatedTypeConstructors

------------------------------------------------------------------------------
-- duplicated value constructors

SEM Module
  | Module   loc . valueConstructorErrors = makeDuplicated Constructor @duplicatedValueConstructors
  
------------------------------------------------------------------------------
-- duplicated fixity declarations

SEM Module
  | Module   loc . fixityErrors = makeDuplicated Fixity @duplicatedFixities
                 . (duplicatedFixities,correctFixities) = let (xs,ys) = partition ((>1) . length) . group . sort $ (map fst @body.operatorFixities)
                                                          in (xs,map head ys)

------------------------------------------------------------------------------
-- fixity declarations without a definition

SEM Module
  | Module   loc . fixityButNoFunDefErrors = let list = nub (@body.declVarNames ++ @allValueConstructors)
                                             in makeNoFunDef Fixity (filter (`notElem` list) @correctFixities) list
       
------------------------------------------------------------------------------
-- wrong overloading flag is used (w.r.t. imported functions)

SEM Module
  | Module   loc . wrongFlagErrors = 
       [ WrongOverloadingFlag flag
       | let flag = Overloading `elem` @lhs.options
             imp  = any isOverloaded (concatMap (M.elems . typeEnvironment) @lhs.importEnvironments)
       , flag /= imp
       ]
       
------------------------------------------------------------------------------
-- recursive type synonyms

SEM Module
  | Module   loc . recursiveTypeSynonymErrors = 
                      let converted  = map (\(name, tuple) -> (show name, tuple)) @body.collectTypeSynonyms
                          recursives = snd . getTypeSynonymOrdering . M.fromList $ converted
                          makeError = let f = foldr add (Just [])
                                          add s ml = case (g s, ml) of
                                                        ([n], Just ns) -> Just (n:ns)
                                                        _              -> Nothing
                                          g s = [ n | n <- map fst @body.collectTypeSynonyms, show n == s ] 
                                      in maybe [] (\x -> [RecursiveTypeSynonyms x]) . f
                      in concatMap makeError recursives

------------------------------------------------------------------------------
-- wrong file name (does not match the module name)

SEM Module
  | Module  loc . wrongFileNameErrors = let moduleString = getNameName  @moduleName
                                            moduleRange  = getNameRange @moduleName
                                        in if moduleString == "" || @lhs.baseName == moduleString
                                          then []
                                          else [ WrongFileName @lhs.baseName moduleString moduleRange ]
                . moduleName     = case @name.self of 
                                      MaybeName_Just name -> name 
                                      MaybeName_Nothing   -> Name_Identifier noRange [] ""  -- !!!Name
                . fileName       = Name_Identifier noRange [] @lhs.baseName -- !!!Name