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