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 :: [RdrNameHsTyVar] -> P [RdrNameHsType]
 117 checkTyVars tvs = mapP chk tvs
 118                 where
 119                   chk (UserTyVar tv) = returnP (HsTyVar tv)
 120                   chk other          = parseError "Illegal kinded type variable"
 121
 122 checkContext :: RdrNameHsType -> P RdrNameContext
 123 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
 124   = mapP checkPred ts
 125
 126 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
 127   | t == unitTyCon_RDR = returnP []
 128
 129 checkContext t
 130   = checkPred t `thenP` \p ->
 131     returnP [p]
 132
 133 checkPred :: RdrNameHsType -> P (HsPred RdrName)
 134 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
 135 checkPred (HsAppTy l r)
 136   = go l [r]
 137   where
 138     go (HsTyVar t) args   | not (isRdrTyVar t)
 139                           = returnP (HsClassP t args)
 140     go (HsAppTy l r) args = go l (r:args)
 141     go _             _    = parseError "Illegal class assertion"
 142
 143 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 144 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 145         = returnP (mkHsDictTy t args)
 146 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 147 checkDictTy _ _ = parseError "Malformed context in instance header"
 148
 149
 150 ---------------------------------------------------------------------------
 151 -- Checking statements in a do-expression
 152 --      We parse   do { e1 ; e2 ; }
 153 --      as [ExprStmt e1, ExprStmt e2]
 154 -- checkDo (a) checks that the last thing is an ExprStmt
 155 --         (b) transforms it to a ResultStmt
 156
 157 checkDo []               = parseError "Empty 'do' construct"
 158 checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
 159 checkDo [s]              = parseError "The last statement in a 'do' construct must be an expression"
 160 checkDo (s:ss)           = checkDo ss   `thenP` \ ss' ->
 161                            returnP (s:ss')
 162
 163 ---------------------------------------------------------------------------
 164 -- Checking Patterns.
 165
 166 -- We parse patterns as expressions and check for valid patterns below,
 167 -- converting the expression into a pattern at the same time.
 168
 169 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
 170 checkPattern loc e = setSrcLocP loc (checkPat e [])
 171
 172 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
 173 checkPatterns loc es = mapP (checkPattern loc) es
 174
 175 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 176 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
 177 checkPat (HsApp f x) args =
 178         checkPat x [] `thenP` \x ->
 179         checkPat f (x:args)
 180 checkPat e [] = case e of
 181         EWildPat           -> returnP WildPatIn
 182         HsVar x            -> returnP (VarPatIn x)
 183         HsLit l            -> returnP (LitPatIn l)
 184         HsOverLit l        -> returnP (NPatIn l)
 185         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
 186         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
 187         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 188                               -- Pattern signatures are parsed as sigtypes,
 189                               -- but they aren't explicit forall points.  Hence
 190                               -- we have to remove the implicit forall here.
 191                               let t' = case t of
 192                                           HsForAllTy Nothing [] ty -> ty
 193                                           other -> other
 194                               in
 195                               returnP (SigPatIn e t')
 196
 197         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
 198                            | plus == plus_RDR
 199                            -> returnP (mkNPlusKPat n lit)
 200                            where
 201                               plus_RDR = mkUnqual varName SLIT("+")     -- Hack
 202
 203         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 204                               checkPat r [] `thenP` \r ->
 205                               case op of
 206                                  HsVar c -> returnP (ConOpPatIn l c fix r)
 207                                  _ -> patFail
 208
 209         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
 210         ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 211                               returnP (ListPatIn ps)
 212         ExplicitPArr _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 213                               returnP (PArrPatIn ps)
 214
 215         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 216                               returnP (TuplePatIn ps b)
 217
 218         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 219                               returnP (RecPatIn c fs)
 220 -- Generics
 221         HsType ty          -> returnP (TypePatIn ty)
 222         _ -> patFail
 223
 224 checkPat _ _ = patFail
 225
 226 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
 227         -> P (RdrName, RdrNamePat, Bool)
 228 checkPatField (n,e,b) =
 229         checkPat e [] `thenP` \p ->
 230         returnP (n,p,b)
 231
 232 patFail = parseError "Parse error in pattern"
 233
 234
 235 ---------------------------------------------------------------------------
 236 -- Check Equation Syntax
 237
 238 checkValDef
 239         :: RdrNameHsExpr
 240         -> Maybe RdrNameHsType
 241         -> RdrNameGRHSs
 242         -> SrcLoc
 243         -> P RdrBinding
 244
 245 checkValDef lhs opt_sig grhss loc
 246  = case isFunLhs lhs [] of
 247            Just (f,inf,es) ->
 248                 checkPatterns loc es `thenP` \ps ->
 249                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 250
 251            Nothing ->
 252                 checkPattern loc lhs `thenP` \lhs ->
 253                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 254
 255 checkValSig
 256         :: RdrNameHsExpr
 257         -> RdrNameHsType
 258         -> SrcLoc
 259         -> P RdrBinding
 260 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
 261 checkValSig other     ty loc = parseError "Type signature given for an expression"
 262
 263
 264 -- A variable binding is parsed as an RdrNameFunMonoBind.
 265 -- See comments with HsBinds.MonoBinds
 266
 267 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 268 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 269                                 = Just (op, True, (l:r:es))
 270                                         | otherwise
 271                                 = case isFunLhs l es of
 272                                     Just (op', True, j : k : es') ->
 273                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 274                                     _ -> Nothing
 275 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 276                                 = Just (f,False,es)
 277 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 278 isFunLhs (HsPar e)   es@(_:_)   = isFunLhs e es
 279 isFunLhs _ _                    = Nothing
 280
 281 ---------------------------------------------------------------------------
 282 -- Miscellaneous utilities
 283
 284 checkPrec :: Integer -> P ()
 285 checkPrec i | 0 <= i && i <= 9 = returnP ()
 286             | otherwise        = parseError "Precedence out of range"
 287
 288 mkRecConstrOrUpdate
 289         :: RdrNameHsExpr
 290         -> RdrNameHsRecordBinds
 291         -> P RdrNameHsExpr
 292
 293 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 294   = returnP (RecordCon c fs)
 295 mkRecConstrOrUpdate exp fs@(_:_)
 296   = returnP (RecordUpd exp fs)
 297 mkRecConstrOrUpdate _ _
 298   = parseError "Empty record update"
 299
 300 -----------------------------------------------------------------------------
 301 -- utilities for foreign declarations
 302
 303 -- supported calling conventions
 304 --
 305 data CallConv = CCall  CCallConv        -- ccall or stdcall
 306               | DNCall                  -- .NET
 307
 308 -- construct a foreign import declaration
 309 --
 310 mkImport :: CallConv
 311          -> Safety
 312          -> (FAST_STRING, RdrName, RdrNameHsType)
 313          -> SrcLoc
 314          -> P RdrNameHsDecl
 315 mkImport (CCall  cconv) safety (entity, v, ty) loc =
 316   parseCImport entity cconv safety v                     `thenP` \importSpec ->
 317   returnP $ ForD (ForeignImport v ty importSpec                     False loc)
 318 mkImport (DNCall      ) _      (entity, v, ty) loc =
 319   returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
 320
 321 -- parse the entity string of a foreign import declaration for the `ccall' or
 322 -- `stdcall' calling convention'
 323 --
 324 parseCImport :: FAST_STRING
 325              -> CCallConv
 326              -> Safety
 327              -> RdrName
 328              -> P ForeignImport
 329 parseCImport entity cconv safety v
 330   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 331   | entity == SLIT ("dynamic") =
 332     returnP $ CImport cconv safety _NIL_ _NIL_ (CFunction DynamicTarget)
 333   | entity == SLIT ("wrapper") =
 334     returnP $ CImport cconv safety _NIL_ _NIL_ CWrapper
 335   | otherwise                  = parse0 (_UNPK_ entity)
 336     where
 337       -- using the static keyword?
 338       parse0 (' ':                    rest) = parse0 rest
 339       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 340       parse0                          rest  = parse1 rest
 341       -- check for header file name
 342       parse1     ""               = parse4 ""    _NIL_        False _NIL_
 343       parse1     (' ':rest)       = parse1 rest
 344       parse1 str@('&':_   )       = parse2 str   _NIL_
 345       parse1 str@('[':_   )       = parse3 str   _NIL_        False
 346       parse1 str
 347         | ".h" `isSuffixOf` first = parse2 rest  (_PK_ first)
 348         | otherwise               = parse4 str   _NIL_        False _NIL_
 349         where
 350           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 351       -- check for address operator (indicating a label import)
 352       parse2     ""         header = parse4 ""   header False _NIL_
 353       parse2     (' ':rest) header = parse2 rest header
 354       parse2     ('&':rest) header = parse3 rest header True
 355       parse2 str@('[':_   ) header = parse3 str  header False
 356       parse2 str            header = parse4 str  header False _NIL_
 357       -- check for library object name
 358       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 359       parse3 ('[':rest) header isLbl =
 360         case break (== ']') rest of
 361           (lib, ']':rest)           -> parse4 rest header isLbl (_PK_ lib)
 362           _                         -> parseError "Missing ']' in entity"
 363       parse3 str        header isLbl = parse4 str  header isLbl _NIL_
 364       -- check for name of C function
 365       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
 366       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
 367       parse4 str        header isLbl lib
 368         | all (== ' ') rest              = build (_PK_ first)  header isLbl lib
 369         | otherwise                      = parseError "Malformed entity string"
 370         where
 371           (first, rest) = break (== ' ') str
 372       --
 373       build cid header False lib = returnP $
 374         CImport cconv safety header lib (CFunction (StaticTarget cid))
 375       build cid header True  lib = returnP $
 376         CImport cconv safety header lib (CLabel                  cid )
 377
 378 -- construct a foreign export declaration
 379 --
 380 mkExport :: CallConv
 381          -> (FAST_STRING, RdrName, RdrNameHsType)
 382          -> SrcLoc
 383          -> P RdrNameHsDecl
 384 mkExport (CCall  cconv) (entity, v, ty) loc = returnP $
 385   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
 386   where
 387     entity' | nullFastString entity = mkExtName v
 388             | otherwise             = entity
 389 mkExport DNCall (entity, v, ty) loc =
 390   parseError "Foreign export is not yet supported for .NET"
 391
 392 -- Supplying the ext_name in a foreign decl is optional; if it
 393 -- isn't there, the Haskell name is assumed. Note that no transformation
 394 -- of the Haskell name is then performed, so if you foreign export (++),
 395 -- it's external name will be "++". Too bad; it's important because we don't
 396 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 397 -- (This is why we use occNameUserString.)
 398 --
 399 mkExtName :: RdrName -> CLabelString
 400 mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
 401
 402 -----------------------------------------------------------------------------
 403 -- group function bindings into equation groups
 404
 405 -- we assume the bindings are coming in reverse order, so we take the srcloc
 406 -- from the *last* binding in the group as the srcloc for the whole group.
 407
 408 groupBindings :: [RdrBinding] -> RdrBinding
 409 groupBindings binds = group Nothing binds
 410   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
 411         group (Just bind) [] = RdrValBinding bind
 412         group Nothing [] = RdrNullBind
 413
 414                 -- don't group together FunMonoBinds if they have
 415                 -- no arguments.  This is necessary now that variable bindings
 416                 -- with no arguments are now treated as FunMonoBinds rather
 417                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
 418         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
 419                     (RdrValBinding (FunMonoBind f' _
 420                                         [mtch@(Match (_:_) _ _)] loc)
 421                         : binds)
 422             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
 423
 424         group (Just so_far) binds
 425             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
 426         group Nothing (bind:binds)
 427             = case bind of
 428                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 429                 other -> bind `RdrAndBindings` group Nothing binds
 430 \end{code}