module FrontEnd.HsErrors(
hsType,
hsDeclTopLevel,
hsDeclLocal
) where
import FrontEnd.Class
import FrontEnd.HsSyn
import FrontEnd.SrcLoc
import FrontEnd.Syn.Traverse
import FrontEnd.Warning
import Name.Name
hsType :: (MonadSrcLoc m, MonadWarn m) => HsType -> m ()
hsType x = traverseHsType (\x -> hsType x >> return x) x >> return ()
data Context = InClass [HsType] | InInstance [HsType] | TopLevel | Local
deriving(Eq)
instance Show Context where
show InClass {} = "in a class declaration"
show InInstance {} = "in an instance declaration"
show TopLevel = "at the top level"
show Local = "in local declaration block"
hsDeclTopLevel,hsDeclLocal :: MonadWarn m => HsDecl -> m ()
hsDeclTopLevel = hsDecl TopLevel
hsDeclLocal = hsDecl Local
hsDecl :: MonadWarn m => Context -> HsDecl -> m ()
hsDecl cntx decl = f cntx decl where
f _ d@HsTypeFamilyDecl { } = do
warn (srcLoc d) UnsupportedFeature "Type families currently not supported"
f l d@HsTypeDecl { } | l /= TopLevel= do
warn (srcLoc d) UnsupportedFeature "Type families currently not supported"
f TopLevel HsDataDecl { hsDeclSrcLoc = sl, hsDeclCons = cs, hsDeclDerives = ds' } = do
let ds = map (toName ClassName) ds'
checkDeriving sl False ds
return ()
f context@TopLevel decl@HsTypeDecl { hsDeclTArgs = as } | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context
f context@(InInstance ts) decl@HsTypeDecl { hsDeclTArgs = as }
| any (not . isHsTyVar) (drop (length ts) as) = warn (srcLoc decl) InvalidDecl $ "extra complex type arguments not allowed " ++ show context
f context decl@HsDataDecl {} = warn (srcLoc decl) InvalidDecl $ "data declaration not allowed " ++ show context
f TopLevel decl@HsClassDecl { hsDeclClassHead = ch, hsDeclDecls = decls } = do mapM_ (f (InClass (hsClassHeadArgs ch))) decls
f TopLevel decl@HsInstDecl { hsDeclClassHead = ch, hsDeclDecls = decls } = do mapM_ (f (InInstance (hsClassHeadArgs ch))) decls
f context decl@HsClassDecl {} = warn (srcLoc decl) InvalidDecl $ "class declaration not allowed " ++ show context
f context decl@HsInstDecl {} = warn (srcLoc decl) InvalidDecl $ "instance declaration not allowed " ++ show context
f _ _ = return ()
checkDeriving _ _ xs | all (`elem` derivableClasses) xs = return ()
checkDeriving sl False xs
= let nonDerivable = filter (`notElem` derivableClasses) xs
in warn sl (UnknownDeriving nonDerivable) ("attempt to derive from a non-derivable class: " ++ unwords (map show nonDerivable))
checkDeriving _ True _ = error "HsErrors.checkDeriving: bad."