InterfaceSyntaxCheck.hs 7.47 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
155
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

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)

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"
197
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
  ]