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         , mkExtName             -- RdrName -> ExtName
  15
  16         , checkPrec             -- String -> P String
  17         , checkContext          -- HsType -> P HsContext
  18         , checkInstType         -- HsType -> P HsType
  19         , checkDataHeader       -- HsQualType -> P (HsContext,HsName,[HsName])
  20         , checkPattern          -- HsExp -> P HsPat
  21         , checkPatterns         -- SrcLoc -> [HsExp] -> P [HsPat]
  22         , checkDo               -- [Stmt] -> P [Stmt]
  23         , checkValDef           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  24         , checkValSig           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  25  ) where
  26
  27 #include "HsVersions.h"
  28
  29 import Lex
  30 import HsSyn            -- Lots of it
  31 import SrcLoc
  32 import RdrHsSyn         ( RdrBinding(..),
  33                           RdrNameHsType, RdrNameBangType, RdrNameContext,
  34                           RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
  35                           RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails,
  36                           mkNPlusKPat
  37                         )
  38 import RdrName
  39 import PrelNames        ( unitTyCon_RDR )
  40 import OccName          ( dataName, varName, tcClsName,
  41                           occNameSpace, setOccNameSpace, occNameUserString )
  42 import CStrings         ( CLabelString )
  43 import FastString       ( unpackFS )
  44 import Outputable
  45
  46 -----------------------------------------------------------------------------
  47 -- Misc utils
  48
  49 parseError :: String -> P a
  50 parseError s =
  51   getSrcLocP `thenP` \ loc ->
  52   failMsgP (hcat [ppr loc, text ": ", text s])
  53
  54
  55 -----------------------------------------------------------------------------
  56 -- mkVanillaCon
  57
  58 -- When parsing data declarations, we sometimes inadvertently parse
  59 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
  60 -- This function splits up the type application, adds any pending
  61 -- arguments, and converts the type constructor back into a data constructor.
  62
  63 mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
  64
  65 mkVanillaCon ty tys
  66  = split ty tys
  67  where
  68    split (HsAppTy t u)  ts = split t (unbangedType u : ts)
  69    split (HsTyVar tc)   ts = tyConToDataCon tc  `thenP` \ data_con ->
  70                              returnP (data_con, VanillaCon ts)
  71    split _               _ = parseError "Illegal data/newtype declaration"
  72
  73 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
  74 mkRecCon con fields
  75   = tyConToDataCon con  `thenP` \ data_con ->
  76     returnP (data_con, RecCon fields)
  77
  78 tyConToDataCon :: RdrName -> P RdrName
  79 tyConToDataCon tc
  80   | occNameSpace tc_occ == tcClsName
  81   = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
  82   | otherwise
  83   = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
  84   where
  85     tc_occ   = rdrNameOcc tc
  86
  87
  88 ----------------------------------------------------------------------------
  89 -- Various Syntactic Checks
  90
  91 checkInstType :: RdrNameHsType -> P RdrNameHsType
  92 checkInstType t
  93   = case t of
  94         HsForAllTy tvs ctxt ty ->
  95                 checkDictTy ty [] `thenP` \ dict_ty ->
  96                 returnP (HsForAllTy tvs ctxt dict_ty)
  97
  98         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
  99                 returnP (HsForAllTy Nothing [] dict_ty)
 100
 101 checkContext :: RdrNameHsType -> P RdrNameContext
 102 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
 103   = mapP (\t -> checkPred t []) ts `thenP` \ps ->
 104     returnP ps
 105
 106 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
 107   | t == unitTyCon_RDR = returnP []
 108
 109 checkContext t
 110   = checkPred t [] `thenP` \p ->
 111     returnP [p]
 112
 113 checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName)
 114 checkPred (HsTyVar t) args | not (isRdrTyVar t)
 115         = returnP (HsClassP t args)
 116 checkPred (HsAppTy l r) args = checkPred l (r:args)
 117 checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
 118 checkPred _ _ = parseError "Illegal class assertion"
 119
 120 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 121 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 122         = returnP (mkHsDictTy t args)
 123 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 124 checkDictTy _ _ = parseError "Malformed context in instance header"
 125
 126 -- Put more comments!
 127 -- Checks that the lhs of a datatype declaration
 128 -- is of the form Context => T a b ... z
 129 checkDataHeader :: String       -- data/newtype/class
 130                 -> RdrNameHsType
 131                 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
 132
 133 checkDataHeader s (HsForAllTy Nothing cs t) =
 134    checkSimple s t []        `thenP` \(c,ts) ->
 135    returnP (cs,c,map UserTyVar ts)
 136 checkDataHeader s t =
 137    checkSimple s t []        `thenP` \(c,ts) ->
 138    returnP ([],c,map UserTyVar ts)
 139
 140 -- Checks the type part of the lhs of
 141 -- a data/newtype/class declaration
 142 checkSimple :: String -> RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
 143 checkSimple s (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
 144    = checkSimple s l (a:xs)
 145 checkSimple s (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
 146
 147 checkSimple s (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
 148   | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
 149   = returnP (tycon,[t1,t2])
 150
 151 checkSimple s t _ = parseError ("Malformed " ++ s ++ " declaration")
 152
 153 ---------------------------------------------------------------------------
 154 -- Checking statements in a do-expression
 155 --      We parse   do { e1 ; e2 ; }
 156 --      as [ExprStmt e1, ExprStmt e2]
 157 -- checkDo (a) checks that the last thing is an ExprStmt
 158 --         (b) transforms it to a ResultStmt
 159
 160 checkDo []               = parseError "Empty 'do' construct"
 161 checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
 162 checkDo [s]              = parseError "The last statement in a 'do' construct must be an expression"
 163 checkDo (s:ss)           = checkDo ss   `thenP` \ ss' ->
 164                            returnP (s:ss')
 165
 166 ---------------------------------------------------------------------------
 167 -- Checking Patterns.
 168
 169 -- We parse patterns as expressions and check for valid patterns below,
 170 -- converting the expression into a pattern at the same time.
 171
 172 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
 173 checkPattern loc e = setSrcLocP loc (checkPat e [])
 174
 175 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
 176 checkPatterns loc es = mapP (checkPattern loc) es
 177
 178 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 179 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
 180 checkPat (HsApp f x) args =
 181         checkPat x [] `thenP` \x ->
 182         checkPat f (x:args)
 183 checkPat e [] = case e of
 184         EWildPat           -> returnP WildPatIn
 185         HsVar x            -> returnP (VarPatIn x)
 186         HsLit l            -> returnP (LitPatIn l)
 187         HsOverLit l        -> returnP (NPatIn l)
 188         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
 189         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
 190         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 191                               -- Pattern signatures are parsed as sigtypes,
 192                               -- but they aren't explicit forall points.  Hence
 193                               -- we have to remove the implicit forall here.
 194                               let t' = case t of
 195                                           HsForAllTy Nothing [] ty -> ty
 196                                           other -> other
 197                               in
 198                               returnP (SigPatIn e t')
 199
 200         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
 201                            | plus == plus_RDR
 202                            -> returnP (mkNPlusKPat n lit)
 203                            where
 204                               plus_RDR = mkUnqual varName SLIT("+")     -- Hack
 205
 206         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 207                               checkPat r [] `thenP` \r ->
 208                               case op of
 209                                  HsVar c -> returnP (ConOpPatIn l c fix r)
 210                                  _ -> patFail
 211
 212         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
 213         ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 214                               returnP (ListPatIn ps)
 215
 216         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 217                               returnP (TuplePatIn ps b)
 218
 219         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 220                               returnP (RecPatIn c fs)
 221 -- Generics
 222         HsType ty          -> returnP (TypePatIn ty)
 223         _ -> patFail
 224
 225 checkPat _ _ = patFail
 226
 227 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
 228         -> P (RdrName, RdrNamePat, Bool)
 229 checkPatField (n,e,b) =
 230         checkPat e [] `thenP` \p ->
 231         returnP (n,p,b)
 232
 233 patFail = parseError "Parse error in pattern"
 234
 235
 236 ---------------------------------------------------------------------------
 237 -- Check Equation Syntax
 238
 239 checkValDef
 240         :: RdrNameHsExpr
 241         -> Maybe RdrNameHsType
 242         -> RdrNameGRHSs
 243         -> SrcLoc
 244         -> P RdrBinding
 245
 246 checkValDef lhs opt_sig grhss loc
 247  = case isFunLhs lhs [] of
 248            Just (f,inf,es) ->
 249                 checkPatterns loc es `thenP` \ps ->
 250                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 251
 252            Nothing ->
 253                 checkPattern loc lhs `thenP` \lhs ->
 254                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 255
 256 checkValSig
 257         :: RdrNameHsExpr
 258         -> RdrNameHsType
 259         -> SrcLoc
 260         -> P RdrBinding
 261 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
 262 checkValSig other     ty loc = parseError "Type signature given for an expression"
 263
 264
 265 -- A variable binding is parsed as an RdrNameFunMonoBind.
 266 -- See comments with HsBinds.MonoBinds
 267
 268 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 269 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 270                                 = Just (op, True, (l:r:es))
 271                                         | otherwise
 272                                 = case isFunLhs l es of
 273                                     Just (op', True, j : k : es') ->
 274                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 275                                     _ -> Nothing
 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 :: RdrName -> CLabelString
 309 mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
 310
 311 -----------------------------------------------------------------------------
 312 -- group function bindings into equation groups
 313
 314 -- we assume the bindings are coming in reverse order, so we take the srcloc
 315 -- from the *last* binding in the group as the srcloc for the whole group.
 316
 317 groupBindings :: [RdrBinding] -> RdrBinding
 318 groupBindings binds = group Nothing binds
 319   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
 320         group (Just bind) [] = RdrValBinding bind
 321         group Nothing [] = RdrNullBind
 322
 323                 -- don't group together FunMonoBinds if they have
 324                 -- no arguments.  This is necessary now that variable bindings
 325                 -- with no arguments are now treated as FunMonoBinds rather
 326                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
 327         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
 328                     (RdrValBinding (FunMonoBind f' _
 329                                         [mtch@(Match (_:_) _ _)] loc)
 330                         : binds)
 331             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
 332
 333         group (Just so_far) binds
 334             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
 335         group Nothing (bind:binds)
 336             = case bind of
 337                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 338                 other -> bind `RdrAndBindings` group Nothing binds
 339 \end{code}