HsErrors.hs

-- Routines to check for several error and warning conditions which can be
-- locally determined from syntax.
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@HsTyForall {} = do
--    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"
--    hsQualType (hsTypeType x)
--hsType x@HsTyExists {} = do
--    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"
--    hsQualType (hsTypeType x)
hsType x = traverseHsType (\x -> hsType x >> return x) x >> return ()

--hsQualType x  = hsType (hsQualTypeType x)

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'
--        when (null cs) $ warn sl "h98-emptydata" "data types with no constructors are a non-haskell98 feature"
        checkDeriving sl False ds
--        let isEnum = all (\x ->  null (hsConDeclArgs x)) cs
--        when (not isEnum && class_Enum `elem` ds) $ warn sl "derive-enum" "Cannot derive enum from non enumeration type"
--        when (not isEnum && length cs /= 1 && class_Bounded `elem` ds) $ warn sl "derive-bounded" "Cannot derive bounded from non enumeration or unary type"
        return ()
--    f TopLevel HsNewTypeDecl { hsDeclSrcLoc = sl, hsDeclDerives = ds' } = do
--        let ds = map (toName ClassName) ds'
--        checkDeriving sl True 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@(InClass ts) decl@HsTypeDecl { hsDeclTArgs = as }
--        | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context
    --    | length as < length ts || or (zipWith (/=) as ts) = warn (srcLoc decl) "invalid-assoc" $ "arguments to associated type must match class decl" ++ show (as,ts)
    f context@(InInstance ts) decl@HsTypeDecl { hsDeclTArgs = as }
    --    | length as < length ts || or (zipWith (==) as ts) = warn (srcLoc decl) "invalid-assoc" $ "arguments to associated type must match instance head"
        | 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 context decl@HsNewTypeDecl {} = warn (srcLoc decl) InvalidDecl $ "newtype declaration not allowed " ++ show context
--    f TopLevel decl@HsClassDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InClass args)) decls
    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 TopLevel decl@HsInstDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InInstance args)) 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 ()

--fetchQtArgs sl HsQualType { hsQualTypeType = t } | (HsTyCon {},args@(_:_)) <- fromHsTypeApp t = return args
--fetchQtArgs sl _ = warn sl InvalidDecl "invalid head in class or instance decl" >> return []

checkDeriving _ _ xs | all (`elem` derivableClasses) xs = return ()
--checkDeriving sl True _ = warn sl "h98-newtypederiv" "arbitrary newtype derivations are a non-haskell98 feature"
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."

--fromHsTypeApp t = f t [] where
--    f (HsTyApp a b) rs = f a (b:rs)
--    f t rs = (t,rs)