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