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         , cbot                  -- a
  10         , splitForConApp        -- RdrNameHsType -> [RdrNameBangType]
  11                                 --     -> P (RdrName, [RdrNameBangType])
  12
  13         , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
  14         , groupBindings
  15
  16         , mkExtName             -- Maybe ExtName -> RdrName -> ExtName
  17
  18         , checkPrec             -- String -> P String
  19         , checkContext          -- HsType -> P HsContext
  20         , checkInstType         -- HsType -> P HsType
  21         , checkDataHeader       -- HsQualType -> P (HsContext,HsName,[HsName])
  22         , checkSimple           -- HsType -> [HsName] -> P ((HsName,[HsName]))
  23         , checkPattern          -- HsExp -> P HsPat
  24         , checkPatterns         -- [HsExp] -> P [HsPat]
  25         -- , checkExpr          -- HsExp -> P HsExp
  26         , checkValDef           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  27         , checkValSig           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  28  ) where
  29
  30 #include "HsVersions.h"
  31
  32 import Lex
  33 import HsSyn            -- Lots of it
  34 import SrcLoc
  35 import RdrHsSyn         ( mkNPlusKPatIn, unitTyCon_RDR,
  36                           RdrBinding(..),
  37                           RdrNameHsType, RdrNameBangType, RdrNameContext,
  38                           RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
  39                           RdrNameHsRecordBinds, RdrNameMonoBinds
  40                         )
  41 import RdrName
  42 import CallConv
  43 import OccName          ( dataName, varName, tcClsName,
  44                           occNameSpace, setOccNameSpace, occNameUserString )
  45 import FastString       ( unpackFS )
  46 import UniqFM           ( UniqFM, listToUFM, lookupUFM )
  47 import Outputable
  48
  49 -----------------------------------------------------------------------------
  50 -- Misc utils
  51
  52 parseError :: String -> P a
  53 parseError s =
  54   getSrcLocP `thenP` \ loc ->
  55   failMsgP (hcat [ppr loc, text ": ", text s])
  56
  57 cbot = panic "CCall:result_ty"
  58
  59 -----------------------------------------------------------------------------
  60 -- splitForConApp
  61
  62 -- When parsing data declarations, we sometimes inadvertently parse
  63 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
  64 -- This function splits up the type application, adds any pending
  65 -- arguments, and converts the type constructor back into a data constructor.
  66
  67 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
  68         -> P (RdrName, [RdrNameBangType])
  69
  70 splitForConApp  t ts = split t ts
  71  where
  72         split (HsAppTy t u) ts = split t (Unbanged u : ts)
  73 {-      split (HsOpTy t1 t ty2) ts =
  74                 -- check that we've got a type constructor at the head
  75            if occNameSpace t_occ /= tcClsName
  76                 then parseError
  77                         (showSDoc (text "not a constructor: (type pattern)`" <>
  78                                         ppr t <> char '\''))
  79                 else returnP (con, ts)
  80            where t_occ = rdrNameOcc t
  81                  con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
  82 -}
  83         split (HsTyVar t)   ts  =
  84                 -- check that we've got a type constructor at the head
  85            if occNameSpace t_occ /= tcClsName
  86                 then parseError
  87                         (showSDoc (text "not a constructor: `" <>
  88                                         ppr t <> char '\''))
  89                 else returnP (con, ts)
  90            where t_occ = rdrNameOcc t
  91                  con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
  92
  93         split _ _ = parseError "Illegal data/newtype declaration"
  94
  95 ----------------------------------------------------------------------------
  96 -- Various Syntactic Checks
  97
  98 callConvFM :: UniqFM CallConv
  99 callConvFM = listToUFM $
 100       map (\ (x,y) -> (_PK_ x,y))
 101      [  ("stdcall",  stdCallConv),
 102         ("ccall",    cCallConv)
 103 --      ("pascal",   pascalCallConv),
 104 --      ("fastcall", fastCallConv)
 105      ]
 106
 107 checkCallConv :: FAST_STRING -> P CallConv
 108 checkCallConv s =
 109   case lookupUFM callConvFM s of
 110         Nothing -> parseError ("unknown calling convention: `"
 111                                  ++ unpackFS s ++ "'")
 112         Just conv -> returnP conv
 113
 114 checkInstType :: RdrNameHsType -> P RdrNameHsType
 115 checkInstType t
 116   = case t of
 117         HsForAllTy tvs ctxt ty ->
 118                 checkDictTy ty [] `thenP` \ dict_ty ->
 119                 returnP (HsForAllTy tvs ctxt dict_ty)
 120
 121         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
 122                 returnP (HsForAllTy Nothing [] dict_ty)
 123
 124 checkContext :: RdrNameHsType -> P RdrNameContext
 125 checkContext (HsTupleTy _ ts)
 126   = mapP (\t -> checkPred t []) ts `thenP` \ps ->
 127     returnP ps
 128 checkContext (HsTyVar t) -- empty contexts are allowed
 129   | t == unitTyCon_RDR = returnP []
 130 checkContext t
 131   = checkPred t [] `thenP` \p ->
 132     returnP [p]
 133
 134 checkPred :: RdrNameHsType -> [RdrNameHsType]
 135         -> P (HsPred RdrName)
 136 checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 137         = returnP (HsPClass t args)
 138 checkPred (HsAppTy l r) args = checkPred l (r:args)
 139 checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
 140 checkPred _ _ = parseError "Illegal class assertion"
 141
 142 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 143 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 144         = returnP (mkHsDictTy t args)
 145 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 146 checkDictTy _ _ = parseError "Illegal class assertion"
 147
 148 -- Put more comments!
 149 -- Checks that the lhs of a datatype declaration
 150 -- is of the form Context => T a b ... z
 151 checkDataHeader :: RdrNameHsType
 152         -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
 153
 154 checkDataHeader (HsForAllTy Nothing cs t) =
 155    checkSimple t []          `thenP` \(c,ts) ->
 156    returnP (cs,c,map UserTyVar ts)
 157 checkDataHeader t =
 158    checkSimple t []          `thenP` \(c,ts) ->
 159    returnP ([],c,map UserTyVar ts)
 160
 161 -- Checks the type part of the lhs of a datatype declaration
 162 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
 163 checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
 164    = checkSimple l (a:xs)
 165 checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
 166
 167 checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
 168   | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
 169   = returnP (tycon,[t1,t2])
 170
 171 checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
 172
 173 ---------------------------------------------------------------------------
 174 -- Checking Patterns.
 175
 176 -- We parse patterns as expressions and check for valid patterns below,
 177 -- converting the expression into a pattern at the same time.
 178
 179 checkPattern :: RdrNameHsExpr -> P RdrNamePat
 180 checkPattern e = checkPat e []
 181
 182 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
 183 checkPatterns es = mapP checkPattern es
 184
 185 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 186 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
 187 checkPat (HsApp f x) args =
 188         checkPat x [] `thenP` \x ->
 189         checkPat f (x:args)
 190 checkPat e [] = case e of
 191         EWildPat           -> returnP WildPatIn
 192         HsVar x            -> returnP (VarPatIn x)
 193         HsLit l            -> returnP (LitPatIn l)
 194         HsOverLit l        -> returnP (NPatIn l)
 195         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
 196         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
 197         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 198                               -- Pattern signatures are parsed as sigtypes,
 199                               -- but they aren't explicit forall points.  Hence
 200                               -- we have to remove the implicit forall here.
 201                               let t' = case t of
 202                                           HsForAllTy Nothing [] ty -> ty
 203                                           other -> other
 204                               in
 205                               returnP (SigPatIn e t')
 206
 207         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
 208                            | plus == plus_RDR
 209                            -> returnP (mkNPlusKPatIn n lit)
 210
 211         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 212                               checkPat r [] `thenP` \r ->
 213                               case op of
 214                                  HsVar c -> returnP (ConOpPatIn l c fix r)
 215                                  _ -> patFail
 216
 217         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
 218         ExplicitList es    -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 219                               returnP (ListPatIn ps)
 220
 221         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 222                               returnP (TuplePatIn ps b)
 223
 224         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 225                               returnP (RecPatIn c fs)
 226 -- Generics
 227         HsType ty          -> returnP (TypePatIn ty)
 228         _ -> patFail
 229
 230 checkPat _ _ = patFail
 231
 232 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
 233         -> P (RdrName, RdrNamePat, Bool)
 234 checkPatField (n,e,b) =
 235         checkPat e [] `thenP` \p ->
 236         returnP (n,p,b)
 237
 238 patFail = parseError "Parse error in pattern"
 239
 240
 241 ---------------------------------------------------------------------------
 242 -- Check Equation Syntax
 243
 244 checkValDef
 245         :: RdrNameHsExpr
 246         -> Maybe RdrNameHsType
 247         -> RdrNameGRHSs
 248         -> SrcLoc
 249         -> P RdrBinding
 250
 251 checkValDef lhs opt_sig grhss loc
 252  = case isFunLhs lhs [] of
 253            Just (f,inf,es) ->
 254                 checkPatterns es `thenP` \ps ->
 255                 returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
 256
 257            Nothing ->
 258                 checkPattern lhs `thenP` \lhs ->
 259                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 260
 261 checkValSig
 262         :: RdrNameHsExpr
 263         -> RdrNameHsType
 264         -> SrcLoc
 265         -> P RdrBinding
 266 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
 267 checkValSig other     ty loc = parseError "Type signature given for an expression"
 268
 269
 270 -- A variable binding is parsed as an RdrNameFunMonoBind.
 271 -- See comments with HsBinds.MonoBinds
 272
 273 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 274 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 275                                 = Just (op, True, (l:r:es))
 276 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 277                                 = Just (f,False,es)
 278 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 279 isFunLhs (HsPar e)   es         = isFunLhs e es
 280 isFunLhs _ _                    = Nothing
 281
 282 ---------------------------------------------------------------------------
 283 -- Miscellaneous utilities
 284
 285 checkPrec :: Integer -> P ()
 286 checkPrec i | 0 <= i && i <= 9 = returnP ()
 287             | otherwise        = parseError "precedence out of range"
 288
 289 mkRecConstrOrUpdate
 290         :: RdrNameHsExpr
 291         -> RdrNameHsRecordBinds
 292         -> P RdrNameHsExpr
 293
 294 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 295   = returnP (RecordCon c fs)
 296 mkRecConstrOrUpdate exp fs@(_:_)
 297   = returnP (RecordUpd exp fs)
 298 mkRecConstrOrUpdate _ _
 299   = parseError "Empty record update"
 300
 301 -- Supplying the ext_name in a foreign decl is optional ; if it
 302 -- isn't there, the Haskell name is assumed. Note that no transformation
 303 -- of the Haskell name is then performed, so if you foreign export (++),
 304 -- it's external name will be "++". Too bad; it's important because we don't
 305 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 306 -- (This is why we use occNameUserString.)
 307
 308 mkExtName :: Maybe ExtName -> RdrName -> ExtName
 309 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
 310                                   Nothing
 311 mkExtName (Just x) _    = x
 312
 313 -----------------------------------------------------------------------------
 314 -- group function bindings into equation groups
 315
 316 -- we assume the bindings are coming in reverse order, so we take the srcloc
 317 -- from the *last* binding in the group as the srcloc for the whole group.
 318
 319 groupBindings :: [RdrBinding] -> RdrBinding
 320 groupBindings binds = group Nothing binds
 321   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
 322         group (Just bind) [] = RdrValBinding bind
 323         group Nothing [] = RdrNullBind
 324
 325                 -- don't group together FunMonoBinds if they have
 326                 -- no arguments.  This is necessary now that variable bindings
 327                 -- with no arguments are now treated as FunMonoBinds rather
 328                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
 329         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
 330                     (RdrValBinding (FunMonoBind f' _
 331                                         [mtch@(Match _ (_:_) _ _)] loc)
 332                         : binds)
 333             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
 334
 335         group (Just so_far) binds
 336             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
 337         group Nothing (bind:binds)
 338             = case bind of
 339                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 340                 other -> bind `RdrAndBindings` group Nothing binds
 341
 342 plus_RDR = mkSrcUnqual varName SLIT("+")
 343 \end{code}