InterfaceSyntaxCheck.hs 7.54 KB
Newer Older
1 2 3 4
{- |
    Module      :  $Header$
    Description :  Checks interface declarations
    Copyright   :  (c) 2000 - 2007 Wolfgang Lux
5
                       2011 - 2015 Björn Peemöller
6
                       2015        Jan Tikovsky
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   Similar to Curry source files, some post-processing has to be applied
   to parsed interface files. In particular, the compiler must
   disambiguate nullary type constructors and type variables. In
   addition, the compiler also checks that all type constructor
   applications are saturated. Since interface files are closed -- i.e.,
   they include declarations of all entities which are defined in other
   modules -- the compiler can perform this check without reference to
   the global environments.
-}

module Checks.InterfaceSyntaxCheck (intfSyntaxCheck) where

import           Control.Monad            (liftM, liftM2)
import qualified Control.Monad.State as S
import           Data.List                (nub, partition)

import Base.Expr
import Base.Messages (Message, posMessage, internalError)
import Base.TopEnv
import Base.Utils    (findMultiples)
import Env.TypeConstructor

import Curry.Base.Ident
import Curry.Base.Pretty
import Curry.Syntax

data ISCState = ISCState
  { typeEnv :: TypeEnv
  , errors  :: [Message]
  }

type ISC = S.State ISCState

getTypeEnv :: ISC TypeEnv
getTypeEnv = S.gets typeEnv

-- |Report a syntax error
report :: Message -> ISC ()
report msg = S.modify $ \ s -> s { errors = msg : errors s }

intfSyntaxCheck :: Interface -> (Interface, [Message])
intfSyntaxCheck (Interface n is ds) = (Interface n is ds', reverse $ errors s')
  where (ds', s') = S.runState (mapM checkIDecl ds) (ISCState env [])
        env = foldr bindType (fmap typeKind initTCEnv) ds

-- The compiler requires information about the arity of each defined type
-- constructor as well as information whether the type constructor
-- denotes an algebraic data type, a renaming type, or a type synonym.
-- The latter must not occur in type expressions in interfaces.

bindType :: IDecl -> TypeEnv -> TypeEnv
64 65 66 67 68 69 70
bindType (IInfixDecl         _ _ _ _) = id
bindType (HidingDataDecl      _ tc _) = qualBindTopEnv tc (Data tc [])
bindType (IDataDecl      _ tc _ cs _) = qualBindTopEnv tc
                                      (Data tc (map constrId cs))
bindType (INewtypeDecl   _ tc _ nc _) = qualBindTopEnv tc (Data tc [nconstrId nc])
bindType (ITypeDecl         _ tc _ _) = qualBindTopEnv tc (Alias tc)
bindType (IFunctionDecl      _ _ _ _) = id
71 72 73 74 75 76 77 78 79

-- The checks applied to the interface are similar to those performed
-- during syntax checking of type expressions.

checkIDecl :: IDecl -> ISC IDecl
checkIDecl (IInfixDecl  p fix pr op) = return (IInfixDecl p fix pr op)
checkIDecl (HidingDataDecl p tc tvs) = do
  checkTypeLhs tvs
  return (HidingDataDecl p tc tvs)
80
checkIDecl (IDataDecl p tc tvs cs hs) = do
81
  checkTypeLhs tvs
82 83 84 85 86 87
  checkHidden tc (cons ++ labels) hs
  cs' <- mapM (checkConstrDecl tvs) cs
  return $ IDataDecl p tc tvs cs' hs
  where cons   = map constrId cs
        labels = nub $ concatMap recordLabels cs
checkIDecl (INewtypeDecl p tc tvs nc hs) = do
88
  checkTypeLhs tvs
89 90 91 92 93
  checkHidden tc (con : labels) hs
  nc' <- checkNewConstrDecl tvs nc
  return $ INewtypeDecl p tc tvs nc' hs
  where con    = nconstrId nc
        labels = nrecordLabels nc
94 95 96 97 98 99
checkIDecl (ITypeDecl p tc tvs ty) = do
  checkTypeLhs tvs
  liftM (ITypeDecl p tc tvs) (checkClosedType tvs ty)
checkIDecl (IFunctionDecl p f n ty) =
  liftM (IFunctionDecl p f n) (checkType ty)

100 101 102 103
checkHidden :: QualIdent -> [Ident] -> [Ident] -> ISC ()
checkHidden tc csls hs =
  mapM_ (report . errNoElement tc) $ nub $ filter (`notElem` csls) hs

104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
checkTypeLhs :: [Ident] -> ISC ()
checkTypeLhs tvs = do
  tyEnv <- getTypeEnv
  let (tcs, tvs') = partition isTypeConstr tvs
      isTypeConstr tv = not (null (lookupTopEnv tv tyEnv))
  mapM_ (report . errNoVariable)       (nub tcs)
  mapM_ (report . errNonLinear . head) (findMultiples tvs')

checkConstrDecl :: [Ident] -> ConstrDecl -> ISC ConstrDecl
checkConstrDecl tvs (ConstrDecl p evs c tys) = do
  checkTypeLhs evs
  liftM (ConstrDecl p evs c) (mapM (checkClosedType tvs') tys)
  where tvs' = evs ++ tvs
checkConstrDecl tvs (ConOpDecl p evs ty1 op ty2) = do
  checkTypeLhs evs
  liftM2 (\t1 t2 -> ConOpDecl p evs t1 op t2)
         (checkClosedType tvs' ty1)
         (checkClosedType tvs' ty2)
  where tvs' = evs ++ tvs
123 124 125 126 127 128 129
checkConstrDecl tvs (RecordDecl p evs c fs) = do
  checkTypeLhs evs
  liftM (RecordDecl p evs c) (mapM (checkFieldDecl tvs') fs)
  where tvs' = evs ++ tvs

checkFieldDecl :: [Ident] -> FieldDecl -> ISC FieldDecl
checkFieldDecl tvs (FieldDecl p ls ty) =
130
  liftM (FieldDecl p ls) (checkClosedType tvs ty)
131 132 133 134 135 136

checkNewConstrDecl :: [Ident] -> NewConstrDecl -> ISC NewConstrDecl
checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
  checkTypeLhs evs
  liftM (NewConstrDecl p evs c) (checkClosedType tvs' ty)
  where tvs' = evs ++ tvs
137 138 139 140 141
checkNewConstrDecl tvs (NewRecordDecl p evs c (l,ty)) = do
  checkTypeLhs evs
  ty' <- checkClosedType tvs' ty
  return $ NewRecordDecl p evs c (l,ty')
  where tvs' = evs ++ tvs
142 143 144 145 146 147 148 149 150 151 152 153 154

checkClosedType :: [Ident] -> TypeExpr -> ISC TypeExpr
checkClosedType tvs ty = do
  ty' <- checkType ty
  mapM_ (report . errUnboundVariable) (nub (filter (`notElem` tvs) (fv ty')))
  return ty'

checkType :: TypeExpr -> ISC TypeExpr
checkType (ConstructorType tc tys) = checkTypeConstructor tc tys
checkType (VariableType        tv) = checkType (ConstructorType (qualify tv) [])
checkType (TupleType          tys) = liftM TupleType (mapM checkType tys)
checkType (ListType            ty) = liftM ListType (checkType ty)
checkType (ArrowType      ty1 ty2) = liftM2 ArrowType (checkType ty1) (checkType ty2)
155
checkType (ParenType           ty) = liftM ParenType (checkType ty)
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197

checkTypeConstructor :: QualIdent -> [TypeExpr] -> ISC TypeExpr
checkTypeConstructor tc tys = do
  tyEnv <- getTypeEnv
  case qualLookupTopEnv tc tyEnv of
    [] | not (isQualified tc) && null tys -> return (VariableType (unqualify tc))
       | otherwise                        -> do
          report (errUndefinedType tc)
          ConstructorType tc `liftM` mapM checkType tys
    [Data _ _] -> ConstructorType tc `liftM` mapM checkType tys
    [Alias  _] -> do
                  report (errBadTypeSynonym tc)
                  ConstructorType tc `liftM` mapM checkType tys
    _          -> internalError "checkTypeConstructor"

-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------

errUndefinedType :: QualIdent -> Message
errUndefinedType tc = posMessage tc
                    $ text "Undefined type" <+> text (qualName tc)

errNonLinear :: Ident -> Message
errNonLinear tv = posMessage tv $ hsep $ map text
  [ "Type variable", escName tv
  , "occurs more than once on left hand side of type declaration"
  ]

errNoVariable :: Ident -> Message
errNoVariable tv = posMessage tv $ hsep $ map text
  [ "Type constructor", escName tv
  , "used in left hand side of type declaration"
  ]

errUnboundVariable :: Ident -> Message
errUnboundVariable tv = posMessage tv $
  text "Undefined type variable" <+> text (escName tv)

errBadTypeSynonym :: QualIdent -> Message
errBadTypeSynonym tc = posMessage tc $ text "Synonym type"
                    <+> text (qualName tc) <+> text "in interface"
198 199 200 201 202

errNoElement :: QualIdent -> Ident -> Message
errNoElement tc x = posMessage tc $ hsep $ map text
  [ "Hidden constructor or label ", escName x
  , " is not defined for type ", qualName tc
203
  ]