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