ghc/compiler/parser/ParseUtil.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
   3 %
   4 \section[ParseUtil]{Parser Utilities}
   5
   6 \begin{code}
   7 module ParseUtil (
   8           parseError          -- String -> Pa
   9         , mkVanillaCon, mkRecCon,
  10
  11         , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
  12         , groupBindings
  13
  14         , CallConv(..)
  15         , mkImport            -- CallConv -> Safety
  16                               -- -> (FAST_STRING, RdrName, RdrNameHsType)
  17                               -- -> SrcLoc
  18                               -- -> P RdrNameHsDecl
  19         , mkExport            -- CallConv
  20                               -- -> (FAST_STRING, RdrName, RdrNameHsType)
  21                               -- -> SrcLoc
  22                               -- -> P RdrNameHsDecl
  23         , mkExtName           -- RdrName -> CLabelString
  24
  25         , checkPrec           -- String -> P String
  26         , checkContext        -- HsType -> P HsContext
  27         , checkInstType       -- HsType -> P HsType
  28         , checkDataHeader     -- HsQualType -> P (HsContext,HsName,[HsName])
  29         , checkPattern        -- HsExp -> P HsPat
  30         , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
  31         , checkDo             -- [Stmt] -> P [Stmt]
  32         , checkValDef         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  33         , checkValSig         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  34  ) where
  35
  36 #include "HsVersions.h"
  37
  38 import List             ( isSuffixOf )
  39
  40 import Lex
  41 import HsSyn            -- Lots of it
  42 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
  43                           DNCallSpec(..))
  44 import SrcLoc
  45 import RdrHsSyn         ( RdrBinding(..),
  46                           RdrNameHsType, RdrNameBangType, RdrNameContext,
  47                           RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr,
  48                           RdrNameGRHSs, RdrNameHsRecordBinds,
  49                           RdrNameMonoBinds, RdrNameConDetails, RdrNameHsDecl,
  50                           mkNPlusKPat
  51                         )
  52 import RdrName
  53 import PrelNames        ( unitTyCon_RDR )
  54 import OccName          ( dataName, varName, tcClsName,
  55                           occNameSpace, setOccNameSpace, occNameUserString )
  56 import CStrings         ( CLabelString )
  57 import FastString       ( nullFastString )
  58 import Outputable
  59
  60 -----------------------------------------------------------------------------
  61 -- Misc utils
  62
  63 parseError :: String -> P a
  64 parseError s =
  65   getSrcLocP `thenP` \ loc ->
  66   failMsgP (hcat [ppr loc, text ": ", text s])
  67
  68
  69 -----------------------------------------------------------------------------
  70 -- mkVanillaCon
  71
  72 -- When parsing data declarations, we sometimes inadvertently parse
  73 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
  74 -- This function splits up the type application, adds any pending
  75 -- arguments, and converts the type constructor back into a data constructor.
  76
  77 mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
  78
  79 mkVanillaCon ty tys
  80  = split ty tys
  81  where
  82    split (HsAppTy t u)  ts = split t (unbangedType u : ts)
  83    split (HsTyVar tc)   ts = tyConToDataCon tc  `thenP` \ data_con ->
  84                              returnP (data_con, VanillaCon ts)
  85    split _               _ = parseError "Illegal data/newtype declaration"
  86
  87 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
  88 mkRecCon con fields
  89   = tyConToDataCon con  `thenP` \ data_con ->
  90     returnP (data_con, RecCon fields)
  91
  92 tyConToDataCon :: RdrName -> P RdrName
  93 tyConToDataCon tc
  94   | occNameSpace tc_occ == tcClsName
  95   = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
  96   | otherwise
  97   = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
  98   where
  99     tc_occ   = rdrNameOcc tc
 100
 101
 102 ----------------------------------------------------------------------------
 103 -- Various Syntactic Checks
 104
 105 checkInstType :: RdrNameHsType -> P RdrNameHsType
 106 checkInstType t
 107   = case t of
 108         HsForAllTy tvs ctxt ty ->
 109                 checkDictTy ty [] `thenP` \ dict_ty ->
 110                 returnP (HsForAllTy tvs ctxt dict_ty)
 111
 112         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
 113                 returnP (HsForAllTy Nothing [] dict_ty)
 114
 115 checkContext :: RdrNameHsType -> P RdrNameContext
 116 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
 117   = mapP (\t -> checkPred t []) ts `thenP` \ps ->
 118     returnP ps
 119
 120 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
 121   | t == unitTyCon_RDR = returnP []
 122
 123 checkContext t
 124   = checkPred t [] `thenP` \p ->
 125     returnP [p]
 126
 127 checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName)
 128 checkPred (HsTyVar t) args | not (isRdrTyVar t)
 129         = returnP (HsClassP t args)
 130 checkPred (HsAppTy l r) args = checkPred l (r:args)
 131 checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
 132 checkPred _ _ = parseError "Illegal class assertion"
 133
 134 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 135 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 136         = returnP (mkHsDictTy t args)
 137 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 138 checkDictTy _ _ = parseError "Malformed context in instance header"
 139
 140 -- Put more comments!
 141 -- Checks that the lhs of a datatype declaration
 142 -- is of the form Context => T a b ... z
 143 checkDataHeader :: String       -- data/newtype/class
 144                 -> RdrNameHsType
 145                 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
 146
 147 checkDataHeader s (HsForAllTy Nothing cs t) =
 148    checkSimple s t []        `thenP` \(c,ts) ->
 149    returnP (cs,c,map UserTyVar ts)
 150 checkDataHeader s t =
 151    checkSimple s t []        `thenP` \(c,ts) ->
 152    returnP ([],c,map UserTyVar ts)
 153
 154 -- Checks the type part of the lhs of
 155 -- a data/newtype/class declaration
 156 checkSimple :: String -> RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
 157 checkSimple s (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
 158    = checkSimple s l (a:xs)
 159 checkSimple s (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
 160
 161 checkSimple s (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
 162   | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
 163   = returnP (tycon,[t1,t2])
 164
 165 checkSimple s t _ = parseError ("Malformed " ++ s ++ " declaration")
 166
 167 ---------------------------------------------------------------------------
 168 -- Checking statements in a do-expression
 169 --      We parse   do { e1 ; e2 ; }
 170 --      as [ExprStmt e1, ExprStmt e2]
 171 -- checkDo (a) checks that the last thing is an ExprStmt
 172 --         (b) transforms it to a ResultStmt
 173
 174 checkDo []               = parseError "Empty 'do' construct"
 175 checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
 176 checkDo [s]              = parseError "The last statement in a 'do' construct must be an expression"
 177 checkDo (s:ss)           = checkDo ss   `thenP` \ ss' ->
 178                            returnP (s:ss')
 179
 180 ---------------------------------------------------------------------------
 181 -- Checking Patterns.
 182
 183 -- We parse patterns as expressions and check for valid patterns below,
 184 -- converting the expression into a pattern at the same time.
 185
 186 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
 187 checkPattern loc e = setSrcLocP loc (checkPat e [])
 188
 189 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
 190 checkPatterns loc es = mapP (checkPattern loc) es
 191
 192 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 193 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
 194 checkPat (HsApp f x) args =
 195         checkPat x [] `thenP` \x ->
 196         checkPat f (x:args)
 197 checkPat e [] = case e of
 198         EWildPat           -> returnP WildPatIn
 199         HsVar x            -> returnP (VarPatIn x)
 200         HsLit l            -> returnP (LitPatIn l)
 201         HsOverLit l        -> returnP (NPatIn l)
 202         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
 203         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
 204         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 205                               -- Pattern signatures are parsed as sigtypes,
 206                               -- but they aren't explicit forall points.  Hence
 207                               -- we have to remove the implicit forall here.
 208                               let t' = case t of
 209                                           HsForAllTy Nothing [] ty -> ty
 210                                           other -> other
 211                               in
 212                               returnP (SigPatIn e t')
 213
 214         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
 215                            | plus == plus_RDR
 216                            -> returnP (mkNPlusKPat n lit)
 217                            where
 218                               plus_RDR = mkUnqual varName SLIT("+")     -- Hack
 219
 220         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 221                               checkPat r [] `thenP` \r ->
 222                               case op of
 223                                  HsVar c -> returnP (ConOpPatIn l c fix r)
 224                                  _ -> patFail
 225
 226         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
 227         ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 228                               returnP (ListPatIn ps)
 229
 230         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 231                               returnP (TuplePatIn ps b)
 232
 233         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 234                               returnP (RecPatIn c fs)
 235 -- Generics
 236         HsType ty          -> returnP (TypePatIn ty)
 237         _ -> patFail
 238
 239 checkPat _ _ = patFail
 240
 241 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
 242         -> P (RdrName, RdrNamePat, Bool)
 243 checkPatField (n,e,b) =
 244         checkPat e [] `thenP` \p ->
 245         returnP (n,p,b)
 246
 247 patFail = parseError "Parse error in pattern"
 248
 249
 250 ---------------------------------------------------------------------------
 251 -- Check Equation Syntax
 252
 253 checkValDef
 254         :: RdrNameHsExpr
 255         -> Maybe RdrNameHsType
 256         -> RdrNameGRHSs
 257         -> SrcLoc
 258         -> P RdrBinding
 259
 260 checkValDef lhs opt_sig grhss loc
 261  = case isFunLhs lhs [] of
 262            Just (f,inf,es) ->
 263                 checkPatterns loc es `thenP` \ps ->
 264                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 265
 266            Nothing ->
 267                 checkPattern loc lhs `thenP` \lhs ->
 268                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 269
 270 checkValSig
 271         :: RdrNameHsExpr
 272         -> RdrNameHsType
 273         -> SrcLoc
 274         -> P RdrBinding
 275 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
 276 checkValSig other     ty loc = parseError "Type signature given for an expression"
 277
 278
 279 -- A variable binding is parsed as an RdrNameFunMonoBind.
 280 -- See comments with HsBinds.MonoBinds
 281
 282 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 283 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 284                                 = Just (op, True, (l:r:es))
 285                                         | otherwise
 286                                 = case isFunLhs l es of
 287                                     Just (op', True, j : k : es') ->
 288                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 289                                     _ -> Nothing
 290 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 291                                 = Just (f,False,es)
 292 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 293 isFunLhs (HsPar e)   es         = isFunLhs e es
 294 isFunLhs _ _                    = Nothing
 295
 296 ---------------------------------------------------------------------------
 297 -- Miscellaneous utilities
 298
 299 checkPrec :: Integer -> P ()
 300 checkPrec i | 0 <= i && i <= 9 = returnP ()
 301             | otherwise        = parseError "Precedence out of range"
 302
 303 mkRecConstrOrUpdate
 304         :: RdrNameHsExpr
 305         -> RdrNameHsRecordBinds
 306         -> P RdrNameHsExpr
 307
 308 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 309   = returnP (RecordCon c fs)
 310 mkRecConstrOrUpdate exp fs@(_:_)
 311   = returnP (RecordUpd exp fs)
 312 mkRecConstrOrUpdate _ _
 313   = parseError "Empty record update"
 314
 315 -----------------------------------------------------------------------------
 316 -- utilities for foreign declarations
 317
 318 -- supported calling conventions
 319 --
 320 data CallConv = CCall  CCallConv        -- ccall or stdcall
 321               | DNCall                  -- .NET
 322
 323 -- construct a foreign import declaration
 324 --
 325 mkImport :: CallConv
 326          -> Safety
 327          -> (FAST_STRING, RdrName, RdrNameHsType)
 328          -> SrcLoc
 329          -> P RdrNameHsDecl
 330 mkImport (CCall  cconv) safety (entity, v, ty) loc =
 331   parseCImport entity cconv safety v                     `thenP` \importSpec ->
 332   returnP $ ForD (ForeignImport v ty importSpec                     False loc)
 333 mkImport (DNCall      ) _      (entity, v, ty) loc =
 334   returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
 335
 336 -- parse the entity string of a foreign import declaration for the `ccall' or
 337 -- `stdcall' calling convention'
 338 --
 339 parseCImport :: FAST_STRING
 340              -> CCallConv
 341              -> Safety
 342              -> RdrName
 343              -> P ForeignImport
 344 parseCImport entity cconv safety v
 345   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 346   | entity == SLIT ("dynamic") =
 347     returnP $ CImport cconv safety _NIL_ _NIL_ (CFunction DynamicTarget)
 348   | entity == SLIT ("wrapper") =
 349     returnP $ CImport cconv safety _NIL_ _NIL_ CWrapper
 350   | otherwise                  = parse0 (_UNPK_ entity)
 351     where
 352       -- using the static keyword?
 353       parse0 (' ':                    rest) = parse0 rest
 354       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 355       parse0                          rest  = parse1 rest
 356       -- check for header file name
 357       parse1     ""               = parse4 ""    _NIL_        False _NIL_
 358       parse1     (' ':rest)       = parse1 rest
 359       parse1 str@('&':_   )       = parse2 str   _NIL_
 360       parse1 str@('[':_   )       = parse3 str   _NIL_        False
 361       parse1 str
 362         | ".h" `isSuffixOf` first = parse2 rest  (_PK_ first)
 363         | otherwise               = parse4 str   _NIL_        False _NIL_
 364         where
 365           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 366       -- check for address operator (indicating a label import)
 367       parse2     ""         header = parse4 ""   header False _NIL_
 368       parse2     (' ':rest) header = parse2 rest header
 369       parse2     ('&':rest) header = parse3 rest header True
 370       parse2 str@('[':_   ) header = parse3 str  header False
 371       parse2 str            header = parse4 str  header False _NIL_
 372       -- check for library object name
 373       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 374       parse3 ('[':rest) header isLbl =
 375         case break (== ']') rest of
 376           (lib, ']':rest)           -> parse4 rest header isLbl (_PK_ lib)
 377           _                         -> parseError "Missing ']' in entity"
 378       parse3 str        header isLbl = parse4 str  header isLbl _NIL_
 379       -- check for name of C function
 380       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
 381       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
 382       parse4 str        header isLbl lib
 383         | all (== ' ') rest              = build (_PK_ first)  header isLbl lib
 384         | otherwise                      = parseError "Malformed entity string"
 385         where
 386           (first, rest) = break (== ' ') str
 387       --
 388       build cid header False lib = returnP $
 389         CImport cconv safety header lib (CFunction (StaticTarget cid))
 390       build cid header True  lib = returnP $
 391         CImport cconv safety header lib (CLabel                  cid )
 392
 393 -- construct a foreign export declaration
 394 --
 395 mkExport :: CallConv
 396          -> (FAST_STRING, RdrName, RdrNameHsType)
 397          -> SrcLoc
 398          -> P RdrNameHsDecl
 399 mkExport (CCall  cconv) (entity, v, ty) loc = returnP $
 400   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
 401   where
 402     entity' | nullFastString entity = mkExtName v
 403             | otherwise             = entity
 404 mkExport DNCall (entity, v, ty) loc =
 405   parseError "Foreign export is not yet supported for .NET"
 406
 407 -- Supplying the ext_name in a foreign decl is optional; if it
 408 -- isn't there, the Haskell name is assumed. Note that no transformation
 409 -- of the Haskell name is then performed, so if you foreign export (++),
 410 -- it's external name will be "++". Too bad; it's important because we don't
 411 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 412 -- (This is why we use occNameUserString.)
 413 --
 414 mkExtName :: RdrName -> CLabelString
 415 mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
 416
 417 -----------------------------------------------------------------------------
 418 -- group function bindings into equation groups
 419
 420 -- we assume the bindings are coming in reverse order, so we take the srcloc
 421 -- from the *last* binding in the group as the srcloc for the whole group.
 422
 423 groupBindings :: [RdrBinding] -> RdrBinding
 424 groupBindings binds = group Nothing binds
 425   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
 426         group (Just bind) [] = RdrValBinding bind
 427         group Nothing [] = RdrNullBind
 428
 429                 -- don't group together FunMonoBinds if they have
 430                 -- no arguments.  This is necessary now that variable bindings
 431                 -- with no arguments are now treated as FunMonoBinds rather
 432                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
 433         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
 434                     (RdrValBinding (FunMonoBind f' _
 435                                         [mtch@(Match (_:_) _ _)] loc)
 436                         : binds)
 437             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
 438
 439         group (Just so_far) binds
 440             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
 441         group Nothing (bind:binds)
 442             = case bind of
 443                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 444                 other -> bind `RdrAndBindings` group Nothing binds
 445 \end{code}