compiler/parser/RdrHsSyn.lhs

   1 %
   2 % (c) The University of Glasgow, 1996-2003
   3
   4 Functions over HsSyn specialised to RdrName.
   5
   6 \begin{code}
   7 module RdrHsSyn (
   8         extractHsTyRdrTyVars,
   9         extractHsRhoRdrTyVars, extractGenericPatTyVars,
  10
  11         mkHsOpApp, mkClassDecl,
  12         mkHsNegApp, mkHsIntegral, mkHsFractional,
  13         mkHsDo, mkHsSplice,
  14         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
  15         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  16
  17         cvBindGroup,
  18         cvBindsAndSigs,
  19         cvTopDecls,
  20         findSplice, mkGroup,
  21
  22         -- Stuff to do with Foreign declarations
  23         CallConv(..),
  24         mkImport,            -- CallConv -> Safety
  25                               -- -> (FastString, RdrName, RdrNameHsType)
  26                               -- -> P RdrNameHsDecl
  27         mkExport,            -- CallConv
  28                               -- -> (FastString, RdrName, RdrNameHsType)
  29                               -- -> P RdrNameHsDecl
  30         mkExtName,           -- RdrName -> CLabelString
  31         mkGadtDecl,          -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
  32
  33         -- Bunch of functions in the parser monad for
  34         -- checking and constructing values
  35         checkPrecP,           -- Int -> P Int
  36         checkContext,         -- HsType -> P HsContext
  37         checkPred,            -- HsType -> P HsPred
  38         checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
  39         checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
  40         checkInstType,        -- HsType -> P HsType
  41         checkPattern,         -- HsExp -> P HsPat
  42         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
  43         checkDo,              -- [Stmt] -> P [Stmt]
  44         checkMDo,             -- [Stmt] -> P [Stmt]
  45         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  46         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  47         parseError,           -- String -> Pa
  48     ) where
  49
  50 #include "HsVersions.h"
  51
  52 import HsSyn            -- Lots of it
  53 import RdrName          ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
  54                           isRdrDataCon, isUnqual, getRdrName, isQual,
  55                           setRdrNameSpace )
  56 import BasicTypes       ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
  57 import Lexer            ( P, failSpanMsgP, extension, bangPatEnabled )
  58 import TysWiredIn       ( unitTyCon )
  59 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
  60                           DNCallSpec(..), DNKind(..), CLabelString )
  61 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
  62                           occNameString )
  63 import SrcLoc
  64 import OrdList          ( OrdList, fromOL )
  65 import Bag              ( Bag, emptyBag, snocBag, consBag, foldrBag )
  66 import Outputable
  67 import FastString
  68 import Panic
  69
  70 import List             ( isSuffixOf, nubBy )
  71 \end{code}
  72
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection{A few functions over HsSyn at RdrName}
  77 %*                                                                    *
  78 %************************************************************************
  79
  80 extractHsTyRdrNames finds the free variables of a HsType
  81 It's used when making the for-alls explicit.
  82
  83 \begin{code}
  84 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
  85 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
  86
  87 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
  88 -- This one takes the context and tau-part of a
  89 -- sigma type and returns their free type variables
  90 extractHsRhoRdrTyVars ctxt ty
  91  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
  92
  93 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
  94
  95 extract_pred (HsClassP cls tys) acc     = foldr extract_lty acc tys
  96 extract_pred (HsIParam n ty) acc        = extract_lty ty acc
  97
  98 extract_lty (L loc ty) acc
  99   = case ty of
 100       HsTyVar tv                -> extract_tv loc tv acc
 101       HsBangTy _ ty             -> extract_lty ty acc
 102       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 103       HsListTy ty               -> extract_lty ty acc
 104       HsPArrTy ty               -> extract_lty ty acc
 105       HsTupleTy _ tys           -> foldr extract_lty acc tys
 106       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 107       HsPredTy p                -> extract_pred p acc
 108       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
 109       HsParTy ty                -> extract_lty ty acc
 110       HsNumTy num               -> acc
 111       HsSpliceTy _              -> acc  -- Type splices mention no type variables
 112       HsKindSig ty k            -> extract_lty ty acc
 113       HsForAllTy exp [] cx ty   -> extract_lctxt cx (extract_lty ty acc)
 114       HsForAllTy exp tvs cx ty  -> acc ++ (filter ((`notElem` locals) . unLoc) $
 115                                            extract_lctxt cx (extract_lty ty []))
 116                                 where
 117                                    locals = hsLTyVarNames tvs
 118
 119 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 120 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
 121                       | otherwise     = acc
 122
 123 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 124 -- Get the type variables out of the type patterns in a bunch of
 125 -- possibly-generic bindings in a class declaration
 126 extractGenericPatTyVars binds
 127   = nubBy eqLocated (foldrBag get [] binds)
 128   where
 129     get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
 130     get other                                             acc = acc
 131
 132     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
 133     get_m other                                    acc = acc
 134 \end{code}
 135
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection{Construction functions for Rdr stuff}
 140 %*                                                                    *
 141 %************************************************************************
 142
 143 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 144 by deriving them from the name of the class.  We fill in the names for the
 145 tycon and datacon corresponding to the class, by deriving them from the
 146 name of the class itself.  This saves recording the names in the interface
 147 file (which would be equally good).
 148
 149 Similarly for mkConDecl, mkClassOpSig and default-method names.
 150
 151         *** See "THE NAMING STORY" in HsDecls ****
 152
 153 \begin{code}
 154 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
 155   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
 156                 tcdFDs = fds,
 157                 tcdSigs = sigs,
 158                 tcdMeths = mbinds
 159                 }
 160
 161 mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
 162   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
 163              tcdTyVars = tyvars,  tcdCons = data_cons,
 164              tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 165 \end{code}
 166
 167 \begin{code}
 168 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
 169 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
 170 -- can't take an unboxed arg.  But that is exactly what it will see when
 171 -- we write "-3#".  So we have to do the negation right now!
 172 mkHsNegApp (L loc e) = f e
 173   where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 174         f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 175         f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 176         f expr                     = NegApp (L loc e) noSyntaxExpr
 177 \end{code}
 178
 179 %************************************************************************
 180 %*                                                                      *
 181 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 182 %*                                                                      *
 183 %************************************************************************
 184
 185 Function definitions are restructured here. Each is assumed to be recursive
 186 initially, and non recursive definitions are discovered by the dependency
 187 analyser.
 188
 189
 190 \begin{code}
 191 --  | Groups together bindings for a single function
 192 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 193 cvTopDecls decls = go (fromOL decls)
 194   where
 195     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 196     go []                   = []
 197     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 198                             where (L l' b', ds') = getMonoBind (L l b) ds
 199     go (d : ds)             = d : go ds
 200
 201 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 202 cvBindGroup binding
 203   = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
 204     ValBindsIn mbs sigs
 205     }
 206
 207 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 208   -> (Bag (LHsBind RdrName), [LSig RdrName])
 209 -- Input decls contain just value bindings and signatures
 210 cvBindsAndSigs  fb = go (fromOL fb)
 211   where
 212     go []                  = (emptyBag, [])
 213     go (L l (SigD s) : ds) = (bs, L l s : ss)
 214                             where (bs,ss) = go ds
 215     go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
 216                             where (b',ds') = getMonoBind (L l b) ds
 217                                   (bs,ss)  = go ds'
 218
 219 -----------------------------------------------------------------------------
 220 -- Group function bindings into equation groups
 221
 222 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 223   -> (LHsBind RdrName, [LHsDecl RdrName])
 224 -- Suppose      (b',ds') = getMonoBind b ds
 225 --      ds is a list of parsed bindings
 226 --      b is a MonoBinds that has just been read off the front
 227
 228 -- Then b' is the result of grouping more equations from ds that
 229 -- belong with b into a single MonoBinds, and ds' is the depleted
 230 -- list of parsed bindings.
 231 --
 232 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 233
 234 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
 235                                    fun_matches = MatchGroup mtchs1 _ })) binds
 236   | has_args mtchs1
 237   = go is_infix1 mtchs1 loc1 binds
 238   where
 239     go is_infix mtchs loc
 240        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
 241                                 fun_matches = MatchGroup mtchs2 _ })) : binds)
 242         | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
 243                         (combineSrcSpans loc loc2) binds
 244     go is_infix mtchs loc binds
 245         = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
 246         -- Reverse the final matches, to get it back in the right order
 247
 248 getMonoBind bind binds = (bind, binds)
 249
 250 has_args ((L _ (Match args _ _)) : _) = not (null args)
 251         -- Don't group together FunBinds if they have
 252         -- no arguments.  This is necessary now that variable bindings
 253         -- with no arguments are now treated as FunBinds rather
 254         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 255 \end{code}
 256
 257 \begin{code}
 258 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 259 findSplice ds = addl emptyRdrGroup ds
 260
 261 mkGroup :: [LHsDecl a] -> HsGroup a
 262 mkGroup ds = addImpDecls emptyRdrGroup ds
 263
 264 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 265 -- The decls are imported, and should not have a splice
 266 addImpDecls group decls = case addl group decls of
 267                                 (group', Nothing) -> group'
 268                                 other             -> panic "addImpDecls"
 269
 270 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 271         -- This stuff reverses the declarations (again) but it doesn't matter
 272
 273 -- Base cases
 274 addl gp []           = (gp, Nothing)
 275 addl gp (L l d : ds) = add gp l d ds
 276
 277
 278 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 279   -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 280
 281 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 282
 283 -- Class declarations: pull out the fixity signatures to the top
 284 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
 285         | isClassDecl d =
 286                 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 287                 addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
 288         | otherwise =
 289                 addl (gp { hs_tyclds = L l d : ts }) ds
 290
 291 -- Signatures: fixity sigs go a different place than all others
 292 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 293   = addl (gp {hs_fixds = L l f : ts}) ds
 294 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 295   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 296
 297 -- Value declarations: use add_bind
 298 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 299   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 300
 301 -- The rest are routine
 302 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 303   = addl (gp { hs_instds = L l d : ts }) ds
 304 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 305   = addl (gp { hs_defds = L l d : ts }) ds
 306 add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
 307   = addl (gp { hs_fords = L l d : ts }) ds
 308 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
 309   = addl (gp { hs_depds = L l d : ts }) ds
 310 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 311   = addl (gp { hs_ruleds = L l d : ts }) ds
 312
 313 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 314 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs               (s:sigs)
 315 \end{code}
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection[PrefixToHS-utils]{Utilities for conversion}
 320 %*                                                                      *
 321 %************************************************************************
 322
 323
 324 \begin{code}
 325 -----------------------------------------------------------------------------
 326 -- mkPrefixCon
 327
 328 -- When parsing data declarations, we sometimes inadvertently parse
 329 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 330 -- This function splits up the type application, adds any pending
 331 -- arguments, and converts the type constructor back into a data constructor.
 332
 333 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 334   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 335 mkPrefixCon ty tys
 336  = split ty tys
 337  where
 338    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 339    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 340                                      return (data_con, PrefixCon ts)
 341    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 342
 343 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
 344   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 345 mkRecCon (L loc con) fields
 346   = do data_con <- tyConToDataCon loc con
 347        return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 348
 349 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 350 tyConToDataCon loc tc
 351   | isTcOcc (rdrNameOcc tc)
 352   = return (L loc (setRdrNameSpace tc srcDataName))
 353   | otherwise
 354   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 355
 356 ----------------------------------------------------------------------------
 357 -- Various Syntactic Checks
 358
 359 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 360 checkInstType (L l t)
 361   = case t of
 362         HsForAllTy exp tvs ctxt ty -> do
 363                 dict_ty <- checkDictTy ty
 364                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 365
 366         HsParTy ty -> checkInstType ty
 367
 368         ty ->   do dict_ty <- checkDictTy (L l ty)
 369                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 370
 371 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 372 checkTyVars tvs
 373   = mapM chk tvs
 374   where
 375         --  Check that the name space is correct!
 376     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 377         | isRdrTyVar tv = return (L l (KindedTyVar tv k))
 378     chk (L l (HsTyVar tv))
 379         | isRdrTyVar tv = return (L l (UserTyVar tv))
 380     chk (L l other)
 381         = parseError l "Type found where type variable expected"
 382
 383 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
 384 checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
 385                     ; return (tc, tvs) }
 386
 387 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 388   -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
 389 -- The header of a type or class decl should look like
 390 --      (C a, D b) => T a b
 391 -- or   T a b
 392 -- or   a + b
 393 -- etc
 394 checkTyClHdr (L l cxt) ty
 395   = do (tc, tvs) <- gol ty []
 396        mapM_ chk_pred cxt
 397        return (L l cxt, tc, tvs)
 398   where
 399     gol (L l ty) acc = go l ty acc
 400
 401     go l (HsTyVar tc)    acc
 402         | not (isRdrTyVar tc)   = checkTyVars acc               >>= \ tvs ->
 403                                   return (L l tc, tvs)
 404     go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)       >>= \ tvs ->
 405                                   return (tc, tvs)
 406     go l (HsParTy ty)    acc    = gol ty acc
 407     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 408     go l other           acc    = parseError l "Malformed LHS to type of class declaration"
 409
 410         -- The predicates in a type or class decl must all
 411         -- be HsClassPs.  They need not all be type variables,
 412         -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
 413     chk_pred (L l (HsClassP _ args)) = return ()
 414     chk_pred (L l _)
 415        = parseError l "Malformed context in type or class declaration"
 416
 417
 418 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 419 checkContext (L l t)
 420   = check t
 421  where
 422   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 423     = do ctx <- mapM checkPred ts
 424          return (L l ctx)
 425
 426   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 427     = check (unLoc ty)
 428
 429   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 430     | t == getRdrName unitTyCon = return (L l [])
 431
 432   check t
 433     = do p <- checkPred (L l t)
 434          return (L l [p])
 435
 436
 437 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 438 -- Watch out.. in ...deriving( Show )... we use checkPred on
 439 -- the list of partially applied predicates in the deriving,
 440 -- so there can be zero args.
 441 checkPred (L spn (HsPredTy (HsIParam n ty)))
 442   = return (L spn (HsIParam n ty))
 443 checkPred (L spn ty)
 444   = check spn ty []
 445   where
 446     checkl (L l ty) args = check l ty args
 447
 448     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 449                                             = return (L spn (HsClassP t args))
 450     check _loc (HsAppTy l r)           args = checkl l (r:args)
 451     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 452     check _loc (HsParTy t)             args = checkl t args
 453     check loc _                        _    = parseError loc  "malformed class assertion"
 454
 455 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 456 checkDictTy (L spn ty) = check ty []
 457   where
 458   check (HsTyVar t) args | not (isRdrTyVar t)
 459         = return (L spn (HsPredTy (HsClassP t args)))
 460   check (HsAppTy l r) args = check (unLoc l) (r:args)
 461   check (HsParTy t)   args = check (unLoc t) args
 462   check _ _ = parseError spn "Malformed context in instance header"
 463
 464 ---------------------------------------------------------------------------
 465 -- Checking statements in a do-expression
 466 --      We parse   do { e1 ; e2 ; }
 467 --      as [ExprStmt e1, ExprStmt e2]
 468 -- checkDo (a) checks that the last thing is an ExprStmt
 469 --         (b) returns it separately
 470 -- same comments apply for mdo as well
 471
 472 checkDo  = checkDoMDo "a " "'do'"
 473 checkMDo = checkDoMDo "an " "'mdo'"
 474
 475 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 476 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 477 checkDoMDo pre nm loc ss   = do
 478   check ss
 479   where
 480         check  [L l (ExprStmt e _ _)] = return ([], e)
 481         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 482                                          " construct must be an expression")
 483         check (s:ss) = do
 484           (ss',e') <-  check ss
 485           return ((s:ss'),e')
 486
 487 -- -------------------------------------------------------------------------
 488 -- Checking Patterns.
 489
 490 -- We parse patterns as expressions and check for valid patterns below,
 491 -- converting the expression into a pattern at the same time.
 492
 493 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 494 checkPattern e = checkLPat e
 495
 496 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 497 checkPatterns es = mapM checkPattern es
 498
 499 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 500 checkLPat e@(L l _) = checkPat l e []
 501
 502 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 503 checkPat loc (L l (HsVar c)) args
 504   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 505 checkPat loc e args     -- OK to let this happen even if bang-patterns
 506                         -- are not enabled, because there is no valid
 507                         -- non-bang-pattern parse of (C ! e)
 508   | Just (e', args') <- splitBang e
 509   = do  { args'' <- checkPatterns args'
 510         ; checkPat loc e' (args'' ++ args) }
 511 checkPat loc (L _ (HsApp f x)) args
 512   = do { x <- checkLPat x; checkPat loc f (x:args) }
 513 checkPat loc (L _ e) []
 514   = do { p <- checkAPat loc e; return (L loc p) }
 515 checkPat loc pat _some_args
 516   = patFail loc
 517
 518 checkAPat loc e = case e of
 519    EWildPat            -> return (WildPat placeHolderType)
 520    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 521                                          ++ showRdrName x)
 522            | otherwise -> return (VarPat x)
 523    HsLit l             -> return (LitPat l)
 524
 525    -- Overloaded numeric patterns (e.g. f 0 x = x)
 526    -- Negation is recorded separately, so that the literal is zero or +ve
 527    -- NB. Negative *primitive* literals are already handled by
 528    --     RdrHsSyn.mkHsNegApp
 529    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
 530    NegApp (L _ (HsOverLit pos_lit)) _
 531                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 532
 533    SectionR (L _ (HsVar bang)) e        -- (! x)
 534         | bang == bang_RDR
 535         -> do { bang_on <- extension bangPatEnabled
 536               ; if bang_on then checkLPat e >>= (return . BangPat)
 537                 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
 538
 539    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 540    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 541    ExprWithTySig e t  -> checkLPat e >>= \e ->
 542                          -- Pattern signatures are parsed as sigtypes,
 543                          -- but they aren't explicit forall points.  Hence
 544                          -- we have to remove the implicit forall here.
 545                          let t' = case t of
 546                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 547                                      other -> other
 548                          in
 549                          return (SigPatIn e t')
 550
 551    -- n+k patterns
 552    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 553         (L _ (HsOverLit lit@(HsIntegral _ _)))
 554                       | plus == plus_RDR
 555                       -> return (mkNPlusKPat (L nloc n) lit)
 556
 557    OpApp l op fix r   -> checkLPat l >>= \l ->
 558                          checkLPat r >>= \r ->
 559                          case op of
 560                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 561                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 562                             _ -> patFail loc
 563
 564    HsPar e                 -> checkLPat e >>= (return . ParPat)
 565    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 566                          return (ListPat ps placeHolderType)
 567    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 568                          return (PArrPat ps placeHolderType)
 569
 570    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 571                          return (TuplePat ps b placeHolderType)
 572
 573    RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
 574                          return (ConPatIn c (RecCon fs))
 575 -- Generics
 576    HsType ty          -> return (TypePat ty)
 577    _                  -> patFail loc
 578
 579 plus_RDR, bang_RDR :: RdrName
 580 plus_RDR = mkUnqual varName FSLIT("+")  -- Hack
 581 bang_RDR = mkUnqual varName FSLIT("!")  -- Hack
 582
 583 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 584 checkPatField (n,e) = do
 585   p <- checkLPat e
 586   return (n,p)
 587
 588 patFail loc = parseError loc "Parse error in pattern"
 589
 590
 591 ---------------------------------------------------------------------------
 592 -- Check Equation Syntax
 593
 594 checkValDef :: LHsExpr RdrName
 595             -> Maybe (LHsType RdrName)
 596             -> Located (GRHSs RdrName)
 597             -> P (HsBind RdrName)
 598
 599 checkValDef lhs (Just sig) grhss
 600         -- x :: ty = rhs  parses as a *pattern* binding
 601   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 602
 603 checkValDef lhs opt_sig grhss
 604   = do  { mb_fun <- isFunLhs lhs
 605         ; case mb_fun of
 606             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 607                                                 fun is_infix pats opt_sig grhss
 608             Nothing -> checkPatBind lhs grhss }
 609
 610 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 611   | isQual (unLoc fun)
 612   = parseError (getLoc fun) ("Qualified name in function definition: "  ++
 613                              showRdrName (unLoc fun))
 614   | otherwise
 615   = do  ps <- checkPatterns pats
 616         let match_span = combineSrcSpans lhs_loc rhs_span
 617         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 618         -- The span of the match covers the entire equation.
 619         -- That isn't quite right, but it'll do for now.
 620
 621 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 622 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 623 makeFunBind fn is_infix ms
 624   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 625               fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
 626
 627 checkPatBind lhs (L _ grhss)
 628   = do  { lhs <- checkPattern lhs
 629         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 630
 631 checkValSig
 632         :: LHsExpr RdrName
 633         -> LHsType RdrName
 634         -> P (Sig RdrName)
 635 checkValSig (L l (HsVar v)) ty
 636   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 637   = return (TypeSig (L l v) ty)
 638 checkValSig (L l other)     ty
 639   = parseError l "Invalid type signature"
 640
 641 mkGadtDecl :: Located RdrName
 642            -> LHsType RdrName -- assuming HsType
 643            -> ConDecl RdrName
 644 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
 645 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
 646
 647 mk_gadt_con name qvars cxt ty
 648   = ConDecl { con_name     = name
 649             , con_explicit = Implicit
 650             , con_qvars    = qvars
 651             , con_cxt      = cxt
 652             , con_details  = PrefixCon []
 653             , con_res      = ResTyGADT ty }
 654   -- NB: we put the whole constr type into the ResTyGADT for now;
 655   -- the renamer will unravel it once it has sorted out
 656   -- operator fixities
 657
 658 -- A variable binding is parsed as a FunBind.
 659
 660
 661         -- The parser left-associates, so there should
 662         -- not be any OpApps inside the e's
 663 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 664 -- Splits (f ! g a b) into (f, [(! g), a, g])
 665 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
 666   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 667   where
 668     (arg1,argns) = split_bang r_arg []
 669     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 670     split_bang e                 es = (e,es)
 671 splitBang other = Nothing
 672
 673 isFunLhs :: LHsExpr RdrName
 674          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 675 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 676 isFunLhs e = go e []
 677  where
 678    go (L loc (HsVar f)) es
 679         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 680    go (L _ (HsApp f e)) es       = go f (e:es)
 681    go (L _ (HsPar e))   es@(_:_) = go e es
 682
 683         -- For infix function defns, there should be only one infix *function*
 684         -- (though there may be infix *datacons* involved too).  So we don't
 685         -- need fixity info to figure out which function is being defined.
 686         --      a `K1` b `op` c `K2` d
 687         -- must parse as
 688         --      (a `K1` b) `op` (c `K2` d)
 689         -- The renamer checks later that the precedences would yield such a parse.
 690         --
 691         -- There is a complication to deal with bang patterns.
 692         --
 693         -- ToDo: what about this?
 694         --              x + 1 `op` y = ...
 695
 696    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 697         | Just (e',es') <- splitBang e
 698         = do { bang_on <- extension bangPatEnabled
 699              ; if bang_on then go e' (es' ++ es)
 700                else return (Just (L loc' op, True, (l:r:es))) }
 701                 -- No bangs; behave just like the next case
 702         | not (isRdrDataCon op)         -- We have found the function!
 703         = return (Just (L loc' op, True, (l:r:es)))
 704         | otherwise                     -- Infix data con; keep going
 705         = do { mb_l <- go l es
 706              ; case mb_l of
 707                  Just (op', True, j : k : es')
 708                     -> return (Just (op', True, j : op_app : es'))
 709                     where
 710                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 711                  _ -> return Nothing }
 712    go _ _ = return Nothing
 713
 714 ---------------------------------------------------------------------------
 715 -- Miscellaneous utilities
 716
 717 checkPrecP :: Located Int -> P Int
 718 checkPrecP (L l i)
 719  | 0 <= i && i <= maxPrecedence = return i
 720  | otherwise                    = parseError l "Precedence out of range"
 721
 722 mkRecConstrOrUpdate
 723         :: LHsExpr RdrName
 724         -> SrcSpan
 725         -> HsRecordBinds RdrName
 726         -> P (HsExpr RdrName)
 727
 728 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
 729   = return (RecordCon (L l c) noPostTcExpr fs)
 730 mkRecConstrOrUpdate exp loc fs@(_:_)
 731   = return (RecordUpd exp fs placeHolderType placeHolderType)
 732 mkRecConstrOrUpdate _ loc []
 733   = parseError loc "Empty record update"
 734
 735 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
 736 -- The Maybe is becuase the user can omit the activation spec (and usually does)
 737 mkInlineSpec Nothing    True  = alwaysInlineSpec        -- INLINE
 738 mkInlineSpec Nothing    False = neverInlineSpec         -- NOINLINE
 739 mkInlineSpec (Just act) inl   = Inline act inl
 740
 741
 742 -----------------------------------------------------------------------------
 743 -- utilities for foreign declarations
 744
 745 -- supported calling conventions
 746 --
 747 data CallConv = CCall  CCallConv        -- ccall or stdcall
 748               | DNCall                  -- .NET
 749
 750 -- construct a foreign import declaration
 751 --
 752 mkImport :: CallConv
 753          -> Safety
 754          -> (Located FastString, Located RdrName, LHsType RdrName)
 755          -> P (HsDecl RdrName)
 756 mkImport (CCall  cconv) safety (entity, v, ty) = do
 757   importSpec <- parseCImport entity cconv safety v
 758   return (ForD (ForeignImport v ty importSpec))
 759 mkImport (DNCall      ) _      (entity, v, ty) = do
 760   spec <- parseDImport entity
 761   return $ ForD (ForeignImport v ty (DNImport spec))
 762
 763 -- parse the entity string of a foreign import declaration for the `ccall' or
 764 -- `stdcall' calling convention'
 765 --
 766 parseCImport :: Located FastString
 767              -> CCallConv
 768              -> Safety
 769              -> Located RdrName
 770              -> P ForeignImport
 771 parseCImport (L loc entity) cconv safety v
 772   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 773   | entity == FSLIT ("dynamic") =
 774     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 775   | entity == FSLIT ("wrapper") =
 776     return $ CImport cconv safety nilFS nilFS CWrapper
 777   | otherwise                  = parse0 (unpackFS entity)
 778     where
 779       -- using the static keyword?
 780       parse0 (' ':                    rest) = parse0 rest
 781       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 782       parse0                          rest  = parse1 rest
 783       -- check for header file name
 784       parse1     ""               = parse4 ""    nilFS        False nilFS
 785       parse1     (' ':rest)       = parse1 rest
 786       parse1 str@('&':_   )       = parse2 str   nilFS
 787       parse1 str@('[':_   )       = parse3 str   nilFS        False
 788       parse1 str
 789         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 790         | otherwise               = parse4 str   nilFS        False nilFS
 791         where
 792           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 793       -- check for address operator (indicating a label import)
 794       parse2     ""         header = parse4 ""   header False nilFS
 795       parse2     (' ':rest) header = parse2 rest header
 796       parse2     ('&':rest) header = parse3 rest header True
 797       parse2 str@('[':_   ) header = parse3 str  header False
 798       parse2 str            header = parse4 str  header False nilFS
 799       -- check for library object name
 800       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 801       parse3 ('[':rest) header isLbl =
 802         case break (== ']') rest of
 803           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 804           _                         -> parseError loc "Missing ']' in entity"
 805       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 806       -- check for name of C function
 807       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 808       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 809       parse4 str        header isLbl lib
 810         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 811         | otherwise                      = parseError loc "Malformed entity string"
 812         where
 813           (first, rest) = break (== ' ') str
 814       --
 815       build cid header False lib = return $
 816         CImport cconv safety header lib (CFunction (StaticTarget cid))
 817       build cid header True  lib = return $
 818         CImport cconv safety header lib (CLabel                  cid )
 819
 820 --
 821 -- Unravel a dotnet spec string.
 822 --
 823 parseDImport :: Located FastString -> P DNCallSpec
 824 parseDImport (L loc entity) = parse0 comps
 825  where
 826   comps = words (unpackFS entity)
 827
 828   parse0 [] = d'oh
 829   parse0 (x : xs)
 830     | x == "static" = parse1 True xs
 831     | otherwise     = parse1 False (x:xs)
 832
 833   parse1 _ [] = d'oh
 834   parse1 isStatic (x:xs)
 835     | x == "method" = parse2 isStatic DNMethod xs
 836     | x == "field"  = parse2 isStatic DNField xs
 837     | x == "ctor"   = parse2 isStatic DNConstructor xs
 838   parse1 isStatic xs = parse2 isStatic DNMethod xs
 839
 840   parse2 _ _ [] = d'oh
 841   parse2 isStatic kind (('[':x):xs) =
 842      case x of
 843         [] -> d'oh
 844         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 845   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 846
 847   parse3 isStatic kind assem [x] =
 848     return (DNCallSpec isStatic kind assem x
 849                           -- these will be filled in once known.
 850                         (error "FFI-dotnet-args")
 851                         (error "FFI-dotnet-result"))
 852   parse3 _ _ _ _ = d'oh
 853
 854   d'oh = parseError loc "Malformed entity string"
 855
 856 -- construct a foreign export declaration
 857 --
 858 mkExport :: CallConv
 859          -> (Located FastString, Located RdrName, LHsType RdrName)
 860          -> P (HsDecl RdrName)
 861 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
 862   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
 863   where
 864     entity' | nullFS entity = mkExtName (unLoc v)
 865             | otherwise     = entity
 866 mkExport DNCall (L loc entity, v, ty) =
 867   parseError (getLoc v){-TODO: not quite right-}
 868         "Foreign export is not yet supported for .NET"
 869
 870 -- Supplying the ext_name in a foreign decl is optional; if it
 871 -- isn't there, the Haskell name is assumed. Note that no transformation
 872 -- of the Haskell name is then performed, so if you foreign export (++),
 873 -- it's external name will be "++". Too bad; it's important because we don't
 874 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 875 --
 876 mkExtName :: RdrName -> CLabelString
 877 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
 878 \end{code}
 879
 880
 881 -----------------------------------------------------------------------------
 882 -- Misc utils
 883
 884 \begin{code}
 885 showRdrName :: RdrName -> String
 886 showRdrName r = showSDoc (ppr r)
 887
 888 parseError :: SrcSpan -> String -> P a
 889 parseError span s = failSpanMsgP span s
 890 \end{code}