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         ExplicitPArr _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 230                               returnP (PArrPatIn ps)
 231
 232         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 233                               returnP (TuplePatIn ps b)
 234
 235         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 236                               returnP (RecPatIn c fs)
 237 -- Generics
 238         HsType ty          -> returnP (TypePatIn ty)
 239         _ -> patFail
 240
 241 checkPat _ _ = patFail
 242
 243 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
 244         -> P (RdrName, RdrNamePat, Bool)
 245 checkPatField (n,e,b) =
 246         checkPat e [] `thenP` \p ->
 247         returnP (n,p,b)
 248
 249 patFail = parseError "Parse error in pattern"
 250
 251
 252 ---------------------------------------------------------------------------
 253 -- Check Equation Syntax
 254
 255 checkValDef
 256         :: RdrNameHsExpr
 257         -> Maybe RdrNameHsType
 258         -> RdrNameGRHSs
 259         -> SrcLoc
 260         -> P RdrBinding
 261
 262 checkValDef lhs opt_sig grhss loc
 263  = case isFunLhs lhs [] of
 264            Just (f,inf,es) ->
 265                 checkPatterns loc es `thenP` \ps ->
 266                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 267
 268            Nothing ->
 269                 checkPattern loc lhs `thenP` \lhs ->
 270                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 271
 272 checkValSig
 273         :: RdrNameHsExpr
 274         -> RdrNameHsType
 275         -> SrcLoc
 276         -> P RdrBinding
 277 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
 278 checkValSig other     ty loc = parseError "Type signature given for an expression"
 279
 280
 281 -- A variable binding is parsed as an RdrNameFunMonoBind.
 282 -- See comments with HsBinds.MonoBinds
 283
 284 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 285 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 286                                 = Just (op, True, (l:r:es))
 287                                         | otherwise
 288                                 = case isFunLhs l es of
 289                                     Just (op', True, j : k : es') ->
 290                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 291                                     _ -> Nothing
 292 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 293                                 = Just (f,False,es)
 294 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 295 isFunLhs (HsPar e)   es@(_:_)   = isFunLhs e es
 296 isFunLhs _ _                    = Nothing
 297
 298 ---------------------------------------------------------------------------
 299 -- Miscellaneous utilities
 300
 301 checkPrec :: Integer -> P ()
 302 checkPrec i | 0 <= i && i <= 9 = returnP ()
 303             | otherwise        = parseError "Precedence out of range"
 304
 305 mkRecConstrOrUpdate
 306         :: RdrNameHsExpr
 307         -> RdrNameHsRecordBinds
 308         -> P RdrNameHsExpr
 309
 310 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 311   = returnP (RecordCon c fs)
 312 mkRecConstrOrUpdate exp fs@(_:_)
 313   = returnP (RecordUpd exp fs)
 314 mkRecConstrOrUpdate _ _
 315   = parseError "Empty record update"
 316
 317 -----------------------------------------------------------------------------
 318 -- utilities for foreign declarations
 319
 320 -- supported calling conventions
 321 --
 322 data CallConv = CCall  CCallConv        -- ccall or stdcall
 323               | DNCall                  -- .NET
 324
 325 -- construct a foreign import declaration
 326 --
 327 mkImport :: CallConv
 328          -> Safety
 329          -> (FAST_STRING, RdrName, RdrNameHsType)
 330          -> SrcLoc
 331          -> P RdrNameHsDecl
 332 mkImport (CCall  cconv) safety (entity, v, ty) loc =
 333   parseCImport entity cconv safety v                     `thenP` \importSpec ->
 334   returnP $ ForD (ForeignImport v ty importSpec                     False loc)
 335 mkImport (DNCall      ) _      (entity, v, ty) loc =
 336   returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
 337
 338 -- parse the entity string of a foreign import declaration for the `ccall' or
 339 -- `stdcall' calling convention'
 340 --
 341 parseCImport :: FAST_STRING
 342              -> CCallConv
 343              -> Safety
 344              -> RdrName
 345              -> P ForeignImport
 346 parseCImport entity cconv safety v
 347   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 348   | entity == SLIT ("dynamic") =
 349     returnP $ CImport cconv safety _NIL_ _NIL_ (CFunction DynamicTarget)
 350   | entity == SLIT ("wrapper") =
 351     returnP $ CImport cconv safety _NIL_ _NIL_ CWrapper
 352   | otherwise                  = parse0 (_UNPK_ entity)
 353     where
 354       -- using the static keyword?
 355       parse0 (' ':                    rest) = parse0 rest
 356       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 357       parse0                          rest  = parse1 rest
 358       -- check for header file name
 359       parse1     ""               = parse4 ""    _NIL_        False _NIL_
 360       parse1     (' ':rest)       = parse1 rest
 361       parse1 str@('&':_   )       = parse2 str   _NIL_
 362       parse1 str@('[':_   )       = parse3 str   _NIL_        False
 363       parse1 str
 364         | ".h" `isSuffixOf` first = parse2 rest  (_PK_ first)
 365         | otherwise               = parse4 str   _NIL_        False _NIL_
 366         where
 367           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 368       -- check for address operator (indicating a label import)
 369       parse2     ""         header = parse4 ""   header False _NIL_
 370       parse2     (' ':rest) header = parse2 rest header
 371       parse2     ('&':rest) header = parse3 rest header True
 372       parse2 str@('[':_   ) header = parse3 str  header False
 373       parse2 str            header = parse4 str  header False _NIL_
 374       -- check for library object name
 375       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 376       parse3 ('[':rest) header isLbl =
 377         case break (== ']') rest of
 378           (lib, ']':rest)           -> parse4 rest header isLbl (_PK_ lib)
 379           _                         -> parseError "Missing ']' in entity"
 380       parse3 str        header isLbl = parse4 str  header isLbl _NIL_
 381       -- check for name of C function
 382       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
 383       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
 384       parse4 str        header isLbl lib
 385         | all (== ' ') rest              = build (_PK_ first)  header isLbl lib
 386         | otherwise                      = parseError "Malformed entity string"
 387         where
 388           (first, rest) = break (== ' ') str
 389       --
 390       build cid header False lib = returnP $
 391         CImport cconv safety header lib (CFunction (StaticTarget cid))
 392       build cid header True  lib = returnP $
 393         CImport cconv safety header lib (CLabel                  cid )
 394
 395 -- construct a foreign export declaration
 396 --
 397 mkExport :: CallConv
 398          -> (FAST_STRING, RdrName, RdrNameHsType)
 399          -> SrcLoc
 400          -> P RdrNameHsDecl
 401 mkExport (CCall  cconv) (entity, v, ty) loc = returnP $
 402   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
 403   where
 404     entity' | nullFastString entity = mkExtName v
 405             | otherwise             = entity
 406 mkExport DNCall (entity, v, ty) loc =
 407   parseError "Foreign export is not yet supported for .NET"
 408
 409 -- Supplying the ext_name in a foreign decl is optional; if it
 410 -- isn't there, the Haskell name is assumed. Note that no transformation
 411 -- of the Haskell name is then performed, so if you foreign export (++),
 412 -- it's external name will be "++". Too bad; it's important because we don't
 413 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 414 -- (This is why we use occNameUserString.)
 415 --
 416 mkExtName :: RdrName -> CLabelString
 417 mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
 418
 419 -----------------------------------------------------------------------------
 420 -- group function bindings into equation groups
 421
 422 -- we assume the bindings are coming in reverse order, so we take the srcloc
 423 -- from the *last* binding in the group as the srcloc for the whole group.
 424
 425 groupBindings :: [RdrBinding] -> RdrBinding
 426 groupBindings binds = group Nothing binds
 427   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
 428         group (Just bind) [] = RdrValBinding bind
 429         group Nothing [] = RdrNullBind
 430
 431                 -- don't group together FunMonoBinds if they have
 432                 -- no arguments.  This is necessary now that variable bindings
 433                 -- with no arguments are now treated as FunMonoBinds rather
 434                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
 435         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
 436                     (RdrValBinding (FunMonoBind f' _
 437                                         [mtch@(Match (_:_) _ _)] loc)
 438                         : binds)
 439             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
 440
 441         group (Just so_far) binds
 442             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
 443         group Nothing (bind:binds)
 444             = case bind of
 445                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 446                 other -> bind `RdrAndBindings` group Nothing binds
 447 \end{code}