RdrHsSyn.hs 62.5 KB
Newer Older
rodlogic's avatar
rodlogic committed
1 2 3
--
--  (c) The University of Glasgow 2002-2006
--
4

rodlogic's avatar
rodlogic committed
5
-- Functions over HsSyn specialised to RdrName.
6

7
{-# LANGUAGE CPP #-}
8
{-# LANGUAGE FlexibleContexts #-}
9

10
module RdrHsSyn (
11 12
        mkHsOpApp,
        mkHsIntegral, mkHsFractional, mkHsIsString,
13
        mkHsDo, mkSpliceDecl,
14
        mkRoleAnnotDecl,
rodlogic's avatar
rodlogic committed
15 16
        mkClassDecl,
        mkTyData, mkDataFamInst,
17
        mkTySynonym, mkTyFamInstEqn,
rodlogic's avatar
rodlogic committed
18 19
        mkTyFamInst,
        mkFamDecl,
20
        splitCon, mkInlinePragma,
21
        mkPatSynMatchGroup,
22
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
23
        mkTyClD, mkInstD,
24

25
        cvBindGroup,
26
        cvBindsAndSigs,
27
        cvTopDecls,
28
        placeHolderPunRhs,
29

30 31
        -- Stuff to do with Foreign declarations
        mkImport,
32
        parseCImport,
33 34 35 36 37
        mkExport,
        mkExtName,           -- RdrName -> CLabelString
        mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
        mkSimpleConDecl,
        mkDeprecatedGadtRecordDecl,
38
        mkATDefault,
39 40 41 42 43 44

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPattern,         -- HsExp -> P HsPat
batterseapower's avatar
batterseapower committed
45
        bang_RDR,
46 47
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkMonadComp,       -- P (HsStmtContext RdrName)
48
        checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
49 50
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
thomasw's avatar
thomasw committed
51 52 53
        checkPartialTypeSignature,
        checkNoPartialType,
        checkValidPatSynSig,
54
        checkDoAndIfThenElse,
55
        checkRecordSyntax,
thomasw's avatar
thomasw committed
56
        checkValidDefaults,
57
        parseErrorSDoc,
58 59 60

        -- Help with processing exports
        ImpExpSubSpec(..),
61 62
        mkModuleImpExp,
        mkTypeImpExp
63

64 65
    ) where

66
import HsSyn            -- Lots of it
67
import Class            ( FunDep )
68
import CoAxiom          ( Role, fsFromRole )
rodlogic's avatar
rodlogic committed
69
import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
70 71 72
                          isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace,
                          rdrNameSpace )
import OccName          ( tcClsName, isVarNameSpace )
dreixel's avatar
dreixel committed
73
import Name             ( Name )
74
import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
Alan Zimmerman's avatar
Alan Zimmerman committed
75 76
                          InlinePragma(..), InlineSpec(..), Origin(..),
                          SourceText )
77
import TcEvidence       ( idHsWrapper )
78
import Lexer
79
import TysWiredIn       ( unitTyCon, unitDataCon )
80
import ForeignCall
81 82
import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
                          occNameString )
83
import PrelNames        ( forall_tv_RDR, allNameStrings )
84
import DynFlags
85
import SrcLoc
86
import OrdList          ( OrdList, fromOL )
cactus's avatar
cactus committed
87
import Bag              ( emptyBag, consBag )
88 89
import Outputable
import FastString
90
import Maybes
91
import Util
Alan Zimmerman's avatar
Alan Zimmerman committed
92
import ApiAnnotation
93

94
import Control.Applicative ((<$>))
95
import Control.Monad
96

97
import Text.ParserCombinators.ReadP as ReadP
Ian Lynagh's avatar
Ian Lynagh committed
98
import Data.Char
99

100
import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
thomasw's avatar
thomasw committed
101 102
import Data.List       ( partition )
import qualified Data.Set as Set ( fromList, difference, member )
103

104
#include "HsVersions.h"
105

106

rodlogic's avatar
rodlogic committed
107 108 109
{- **********************************************************************

  Construction functions for Rdr stuff
110

rodlogic's avatar
rodlogic committed
111
  ********************************************************************* -}
112

rodlogic's avatar
rodlogic committed
113 114 115 116 117
-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
-- datacon by deriving them from the name of the class.  We fill in the names
-- for the tycon and datacon corresponding to the class, by deriving them
-- from the name of the class itself.  This saves recording the names in the
-- interface file (which would be equally good).
118

rodlogic's avatar
rodlogic committed
119 120 121
-- Similarly for mkConDecl, mkClassOpSig and default-method names.

--         *** See "THE NAMING STORY" in HsDecls ****
122

123 124 125 126 127 128
mkTyClD :: LTyClDecl n -> LHsDecl n
mkTyClD (L loc d) = L loc (TyClD d)

mkInstD :: LInstDecl n -> LHsDecl n
mkInstD (L loc d) = L loc (InstD d)

129
mkClassDecl :: SrcSpan
130
            -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
Alan Zimmerman's avatar
Alan Zimmerman committed
131
            -> Located (a,[Located (FunDep (Located RdrName))])
132
            -> OrdList (LHsDecl RdrName)
133
            -> P (LTyClDecl RdrName)
134

135
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
136 137
  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
       ; let cxt = fromMaybe (noLoc []) mcxt
Alan Zimmerman's avatar
Alan Zimmerman committed
138 139
       ; (cls, tparams,ann) <- checkTyClHdr tycl_hdr
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
thomasw's avatar
thomasw committed
140 141
       -- Partial type signatures are not allowed in a class definition
       ; checkNoPartialSigs sigs cls
142 143
       ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
       ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
144
       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
Alan Zimmerman's avatar
Alan Zimmerman committed
145 146
                                    tcdFDs = snd (unLoc fds), tcdSigs = sigs,
                                    tcdMeths = binds,
147 148
                                    tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
                                    tcdFVs = placeHolderNames })) }
149

150 151 152 153 154
mkATDefault :: LTyFamInstDecl RdrName
            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
-- Take a type-family instance declaration and turn it into
-- a type-family default equation for a class declaration
-- We parse things as the former and use this function to convert to the latter
rodlogic's avatar
rodlogic committed
155 156
--
-- We use the Either monad because this also called
157 158 159 160 161 162 163 164
-- from Convert.hs
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
      | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
      = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats)
           ; return (L loc (TyFamEqn { tfe_tycon = tc
                                     , tfe_pats = tvs
                                     , tfe_rhs = rhs })) }

thomasw's avatar
thomasw committed
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
-- | Check that none of the given type signatures of the class definition
-- ('Located RdrName') are partial type signatures. An error will be reported
-- for each wildcard found in a (partial) type signature. We do this check
-- because we want the signatures in a class definition to be fully specified.
checkNoPartialSigs :: [LSig RdrName] -> Located RdrName -> P ()
checkNoPartialSigs sigs cls_name =
  sequence_ [ whenIsJust mb_loc $ \loc -> parseErrorSDoc loc $ err sig
            | L _ sig@(TypeSig _ ty _) <- sigs
            , let mb_loc = maybeLocation $ findWildcards ty ]
  where err sig =
          vcat [ text "The type signature of a class method cannot be partial:"
               , ppr sig
               , text "In the class declaration for " <> quotes (ppr cls_name) ]

-- | Check that none of the given constructors contain a wildcard (like in a
-- partial type signature). An error will be reported for each wildcard found
-- in a (partial) constructor definition. We do this check because we want the
-- type of a constructor to be fully specified.
checkNoPartialCon :: [LConDecl RdrName] -> P ()
checkNoPartialCon con_decls =
  sequence_ [ whenIsJust mb_loc $ \loc -> parseErrorSDoc loc $ err cd
            | L _ cd@(ConDecl { con_cxt = cxt, con_res = res,
                                con_details = details }) <- con_decls
            , let mb_loc = maybeLocation $
                           concatMap findWildcards (unLoc cxt) ++
                           containsWildcardRes res ++
                           concatMap findWildcards
                           (hsConDeclArgTys details) ]
  where err con_decl = text "A constructor cannot have a partial type:" $$
                       ppr con_decl
Alan Zimmerman's avatar
Alan Zimmerman committed
195
        containsWildcardRes (ResTyGADT _ ty) = findWildcards ty
thomasw's avatar
thomasw committed
196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
        containsWildcardRes ResTyH98 = notFound

-- | Check that the given type does not contain wildcards, and is thus not a
-- partial type. If it contains wildcards, report an error with the given
-- message.
checkNoPartialType :: SDoc -> LHsType RdrName -> P ()
checkNoPartialType context_msg ty =
  whenFound (findWildcards ty) $ \loc -> parseErrorSDoc loc err
  where err = text "Wildcard not allowed" $$ context_msg

-- | Represent wildcards found in a type. Used for reporting errors for types
-- that mustn't contain wildcards.
data FoundWildcard = Found      { location :: SrcSpan }
                   | FoundNamed { location :: SrcSpan, _name :: RdrName }

-- | Indicate that no wildcards were found.
notFound :: [FoundWildcard]
notFound = []

-- | Call the function (second argument), accepting the location of the
-- wildcard, on the first wildcard that was found, if any.
whenFound :: [FoundWildcard] -> (SrcSpan -> P ()) -> P ()
whenFound (Found loc:_)        f = f loc
whenFound (FoundNamed loc _:_) f = f loc
whenFound _                    _ = return ()

-- | Extract the location of the first wildcard, if any.
maybeLocation :: [FoundWildcard] -> Maybe SrcSpan
maybeLocation fws = location <$> listToMaybe fws

-- | Extract the named wildcards from the wildcards that were found.
namedWildcards :: [FoundWildcard] -> [RdrName]
namedWildcards fws = [name | FoundNamed _ name <- fws]

-- | Split the found wildcards into a list of found unnamed wildcard and found
-- named wildcards.
splitUnnamedNamed :: [FoundWildcard] -> ([FoundWildcard], [FoundWildcard])
splitUnnamedNamed = partition (\f -> case f of { Found _ -> True ; _ -> False})

-- | Return a list of the wildcards found while traversing the given type.
findWildcards :: LHsType RdrName -> [FoundWildcard]
findWildcards (L l ty) = case ty of
    (HsForAllTy _ xtr _ (L _ ctxt) x) -> (map Found $ maybeToList xtr) ++
                                         concatMap go ctxt ++ go x
    (HsAppTy x y)            -> go x ++ go y
    (HsFunTy x y)            -> go x ++ go y
    (HsListTy x)             -> go x
    (HsPArrTy x)             -> go x
    (HsTupleTy _ xs)         -> concatMap go xs
    (HsOpTy x _ y)           -> go x ++ go y
    (HsParTy x)              -> go x
    (HsIParamTy _ x)         -> go x
    (HsEqTy x y)             -> go x ++ go y
    (HsKindSig x y)          -> go x ++ go y
    (HsDocTy x _)            -> go x
    (HsBangTy _ x)           -> go x
    (HsRecTy xs)             ->
      concatMap (go . getBangType . cd_fld_type . unLoc) xs
    (HsExplicitListTy _ xs)  -> concatMap go xs
    (HsExplicitTupleTy _ xs) -> concatMap go xs
    (HsWrapTy _ x)           -> go (noLoc x)
    HsWildcardTy             -> [Found l]
    (HsNamedWildcardTy n)    -> [FoundNamed l n]
    -- HsTyVar, HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
    _                        -> notFound
  where go = findWildcards

263 264
mkTyData :: SrcSpan
         -> NewOrData
265
         -> Maybe (Located CType)
266
         -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
267
         -> Maybe (LHsKind RdrName)
268
         -> [LConDecl RdrName]
269
         -> Maybe (Located [LHsType RdrName])
270
         -> P (LTyClDecl RdrName)
271
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
Alan Zimmerman's avatar
Alan Zimmerman committed
272 273
  = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
274
       ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
275
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
276
       ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
277 278
                                   tcdDataDefn = defn,
                                   tcdFVs = placeHolderNames })) }
279

280
mkDataDefn :: NewOrData
281
           -> Maybe (Located CType)
282
           -> Maybe (LHsContext RdrName)
283
           -> Maybe (LHsKind RdrName)
284
           -> [LConDecl RdrName]
285
           -> Maybe (Located [LHsType RdrName])
286
           -> P (HsDataDefn RdrName)
287 288
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
  = do { checkDatatypeContext mcxt
thomasw's avatar
thomasw committed
289 290 291
       ; checkNoPartialCon data_cons
       ; whenIsJust maybe_deriv $
         \(L _ deriv) -> mapM_ (checkNoPartialType (errDeriv deriv)) deriv
292
       ; let cxt = fromMaybe (noLoc []) mcxt
293
       ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
rodlogic's avatar
rodlogic committed
294
                            , dd_ctxt = cxt
295 296 297
                            , dd_cons = data_cons
                            , dd_kindSig = ksig
                            , dd_derivs = maybe_deriv }) }
thomasw's avatar
thomasw committed
298 299 300
    where errDeriv deriv = text "In the deriving items:" <+>
                           pprHsContextNoArrow deriv

301

302
mkTySynonym :: SrcSpan
303
            -> LHsType RdrName  -- LHS
304
            -> LHsType RdrName  -- RHS
305
            -> P (LTyClDecl RdrName)
306
mkTySynonym loc lhs rhs
Alan Zimmerman's avatar
Alan Zimmerman committed
307 308
  = do { (tc, tparams,ann) <- checkTyClHdr lhs
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
309
       ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams
thomasw's avatar
thomasw committed
310 311 312
       ; let err = text "In type synonym" <+> quotes (ppr tc) <>
                   colon <+> ppr rhs
       ; checkNoPartialType err rhs
313
       ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
314
                                , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
315

316
mkTyFamInstEqn :: LHsType RdrName
317
               -> LHsType RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
318
               -> P (TyFamInstEqn RdrName,[AddAnn])
319
mkTyFamInstEqn lhs rhs
Alan Zimmerman's avatar
Alan Zimmerman committed
320
  = do { (tc, tparams,ann) <- checkTyClHdr lhs
thomasw's avatar
thomasw committed
321 322 323 324 325
       ; let err xhs = hang (text "In type family instance equation of" <+>
                             quotes (ppr tc) <> colon)
                       2 (ppr xhs)
       ; checkNoPartialType (err lhs) lhs
       ; checkNoPartialType (err rhs) rhs
326 327
       ; return (TyFamEqn { tfe_tycon = tc
                          , tfe_pats  = mkHsWithBndrs tparams
Alan Zimmerman's avatar
Alan Zimmerman committed
328 329
                          , tfe_rhs   = rhs },
                 ann) }
330

331 332
mkDataFamInst :: SrcSpan
         -> NewOrData
333
         -> Maybe (Located CType)
334 335 336
         -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
         -> Maybe (LHsKind RdrName)
         -> [LConDecl RdrName]
337
         -> Maybe (Located [LHsType RdrName])
338 339
         -> P (LInstDecl RdrName)
mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
Alan Zimmerman's avatar
Alan Zimmerman committed
340 341
  = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
342 343 344 345 346
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
       ; return (L loc (DataFamInstD (
                  DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
                                  , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }

347 348
mkTyFamInst :: SrcSpan
            -> LTyFamInstEqn RdrName
349
            -> P (LInstDecl RdrName)
350
mkTyFamInst loc eqn
351 352
  = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn  = eqn
                                             , tfid_fvs  = placeHolderNames })))
353 354

mkFamDecl :: SrcSpan
355
          -> FamilyInfo RdrName
356 357
          -> LHsType RdrName   -- LHS
          -> Maybe (LHsKind RdrName) -- Optional kind signature
358
          -> P (LTyClDecl RdrName)
359
mkFamDecl loc info lhs ksig
Alan Zimmerman's avatar
Alan Zimmerman committed
360 361
  = do { (tc, tparams,ann) <- checkTyClHdr lhs
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
362
       ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
363
       ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc
364 365 366 367 368 369
                                            , fdTyVars = tyvars, fdKindSig = ksig }))) }
  where
    equals_or_where = case info of
                        DataFamily          -> empty
                        OpenTypeFamily      -> empty
                        ClosedTypeFamily {} -> whereDots
370

371
mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
372
-- If the user wrote
373
--      [pads| ... ]   then return a QuasiQuoteD
374
--      $(e)           then return a SpliceD
375 376
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
377
--                     ie a SpliceD
378
mkSpliceDecl lexpr@(L loc expr)
379 380
  | HsSpliceE splice <- expr = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
  | otherwise                = SpliceD (SpliceDecl (L loc splice) ImplicitSplice)
381
  where
382
    splice = mkUntypedSplice lexpr
383

384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410
mkRoleAnnotDecl :: SrcSpan
                -> Located RdrName                   -- type being annotated
                -> [Located (Maybe FastString)]      -- roles
                -> P (LRoleAnnotDecl RdrName)
mkRoleAnnotDecl loc tycon roles
  = do { roles' <- mapM parse_role roles
       ; return $ L loc $ RoleAnnotDecl tycon roles' }
  where
    role_data_type = dataTypeOf (undefined :: Role)
    all_roles = map fromConstr $ dataTypeConstrs role_data_type
    possible_roles = [(fsFromRole role, role) | role <- all_roles]

    parse_role (L loc_role Nothing) = return $ L loc_role Nothing
    parse_role (L loc_role (Just role))
      = case lookup role possible_roles of
          Just found_role -> return $ L loc_role $ Just found_role
          Nothing         ->
            let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
            parseErrorSDoc loc_role
              (text "Illegal role name" <+> quotes (ppr role) $$
               suggestions nearby)

    suggestions []   = empty
    suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)
      -- will this last case ever happen??
    suggestions list = hang (text "Perhaps you meant one of these:")
                       2 (pprWithCommas (quotes . ppr) list)
411

rodlogic's avatar
rodlogic committed
412 413 414
{- **********************************************************************

  #cvBinds-etc# Converting to @HsBinds@, etc.
415

rodlogic's avatar
rodlogic committed
416 417 418 419 420
  ********************************************************************* -}

-- | Function definitions are restructured here. Each is assumed to be recursive
-- initially, and non recursive definitions are discovered by the dependency
-- analyser.
421 422


423
--  | Groups together bindings for a single function
424 425
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
426
  where
427
    go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
428
    go []                   = []
429
    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
430 431
                            where (L l' b', ds') = getMonoBind (L l b) ds
    go (d : ds)             = d : go ds
432

433
-- Declaration list may only contain value bindings and signatures.
434
cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName)
435
cvBindGroup binding
436 437 438
  = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
         return $ ValBindsIn mbs sigs }
439

440
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
441
  -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
442
          , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
443
-- Input decls contain just value bindings and signatures
444
-- and in case of class or instance declarations also
445
-- associated type declarations. They might also contain Haddock comments.
446
cvBindsAndSigs fb = go (fromOL fb)
447
  where
448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472
    go []              = return (emptyBag, [], [], [], [], [])
    go (L l (ValD b) : ds)
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
           ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
      where
        (b', ds') = getMonoBind (L l b) ds
    go (L l decl : ds)
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
           ; case decl of
               SigD s
                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
               TyClD (FamDecl t)
                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
               InstD (TyFamInstD { tfid_inst = tfi })
                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
               InstD (DataFamInstD { dfid_inst = dfi })
                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
               DocD d
                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
               SpliceD d
                 -> parseErrorSDoc l $
                    hang (text "Declaration splices are allowed only" <+>
                          text "at the top level:")
                       2 (ppr d)
               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
473 474 475 476

-----------------------------------------------------------------------------
-- Group function bindings into equation groups

477 478
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
  -> (LHsBind RdrName, [LHsDecl RdrName])
479 480 481
-- Suppose      (b',ds') = getMonoBind b ds
--      ds is a list of parsed bindings
--      b is a MonoBinds that has just been read off the front
482 483 484 485 486

-- Then b' is the result of grouping more equations from ds that
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
487
-- All Haddock comments between equations inside the group are
488 489
-- discarded.
--
490 491
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

492
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
493
                               fun_matches = MG { mg_alts = mtchs1 } })) binds
494
  | has_args mtchs1
495
  = go is_infix1 mtchs1 loc1 binds []
496
  where
497
    go is_infix mtchs loc
498
       (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
499
                                fun_matches = MG { mg_alts = mtchs2 } })) : binds) _
500 501 502 503
        | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
                        (combineSrcSpans loc loc2) binds []
    go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
        = let doc_decls' = doc_decl : doc_decls
504 505
          in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go is_infix mtchs loc binds doc_decls
506 507
        = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
        -- Reverse the final matches, to get it back in the right order
508
        -- Do the same thing with the trailing doc comments
509

510 511
getMonoBind bind binds = (bind, binds)

512
has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool
513
has_args []                           = panic "RdrHsSyn:has_args"
Alan Zimmerman's avatar
Alan Zimmerman committed
514
has_args ((L _ (Match _ args _ _)) : _) = not (null args)
515 516 517 518
        -- Don't group together FunBinds if they have
        -- no arguments.  This is necessary now that variable bindings
        -- with no arguments are now treated as FunBinds rather
        -- than pattern bindings (tests/rename/should_fail/rnfail002).
519

rodlogic's avatar
rodlogic committed
520 521 522
{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion
523

rodlogic's avatar
rodlogic committed
524
  ********************************************************************* -}
525

526
-----------------------------------------------------------------------------
527
-- splitCon
528 529 530 531 532 533

-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.

534 535 536 537 538 539 540 541
splitCon :: LHsType RdrName
      -> P (Located RdrName, HsConDeclDetails RdrName)
-- This gets given a "type" that should look like
--      C Int Bool
-- or   C { x::Int, y::Bool }
-- and returns the pieces
splitCon ty
 = split ty []
542
 where
543 544 545 546 547
   split (L _ (HsAppTy t u)) ts    = split t (u : ts)
   split (L l (HsTyVar tc))  ts    = do data_con <- tyConToDataCon l tc
                                        return (data_con, mk_rest ts)
   split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon [])
                                         -- See Note [Unit tuples] in HsTypes
548
   split (L l _) _                 = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
549

Alan Zimmerman's avatar
Alan Zimmerman committed
550
   mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
551 552
   mk_rest ts                   = PrefixCon ts

553 554 555 556 557 558
recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
recordPatSynErr loc pat =
    parseErrorSDoc loc $
    text "record syntax not supported for pattern synonym declarations:" $$
    ppr pat

559 560 561 562
mkPatSynMatchGroup :: Located RdrName
                   -> Located (OrdList (LHsDecl RdrName))
                   -> P (MatchGroup RdrName (LHsExpr RdrName))
mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
563 564 565 566 567 568 569
    do { matches <- mapM fromDecl (fromOL decls)
       ; return $ mkMatchGroup FromSource matches }
  where
    fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) =
        do { unless (name == patsyn_name) $
               wrongNameBindingErr loc decl
           ; match <- case details of
Alan Zimmerman's avatar
Alan Zimmerman committed
570 571 572
               PrefixCon pats -> return $ Match Nothing pats Nothing rhs
               InfixCon pat1 pat2 ->
                         return $ Match Nothing [pat1, pat2] Nothing rhs
573 574 575 576 577 578 579 580 581 582 583 584 585 586
               RecCon{} -> recordPatSynErr loc pat
           ; return $ L loc match }
    fromDecl (L loc decl) = extraDeclErr loc decl

    extraDeclErr loc decl =
        parseErrorSDoc loc $
        text "pattern synonym 'where' clause must contain a single binding:" $$
        ppr decl

    wrongNameBindingErr loc decl =
        parseErrorSDoc loc $
        text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
        quotes (ppr patsyn_name) $$ ppr decl

587 588
mkDeprecatedGadtRecordDecl :: SrcSpan
                           -> Located RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
589
                           -> Located [LConDeclField RdrName]
590 591
                           -> LHsType RdrName
                           ->  P (LConDecl  RdrName)
592 593 594 595 596 597
-- This one uses the deprecated syntax
--    C { x,y ::Int } :: T a b
-- We give it a RecCon details right away
mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
  = do { data_con <- tyConToDataCon con_loc con
       ; return (L loc (ConDecl { con_old_rec  = True
598
                                , con_names    = [data_con]
599
                                , con_explicit = Implicit
600
                                , con_qvars    = mkHsQTvs []
601 602
                                , con_cxt      = noLoc []
                                , con_details  = RecCon flds
Alan Zimmerman's avatar
Alan Zimmerman committed
603
                                , con_res      = ResTyGADT loc res_ty
604
                                , con_doc      = Nothing })) }
605 606

mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
607 608
                -> LHsContext RdrName -> HsConDeclDetails RdrName
                -> ConDecl RdrName
609 610 611

mkSimpleConDecl name qvars cxt details
  = ConDecl { con_old_rec  = False
612
            , con_names    = [name]
613
            , con_explicit = Explicit
614
            , con_qvars    = mkHsQTvs qvars
615 616 617
            , con_cxt      = cxt
            , con_details  = details
            , con_res      = ResTyH98
618
            , con_doc      = Nothing }
619

620 621
mkGadtDecl :: [Located RdrName]
           -> LHsType RdrName     -- Always a HsForAllTy
thomasw's avatar
thomasw committed
622
           -> P (ConDecl RdrName)
623
-- We allow C,D :: ty
624
-- and expand it as if it had been
625 626
--    C :: ty; D :: ty
-- (Just like type signatures in general.)
thomasw's avatar
thomasw committed
627 628 629 630
mkGadtDecl _ ty@(L _ (HsForAllTy _ (Just l) _ _ _))
  = parseErrorSDoc l $
    text "A constructor cannot have a partial type:" $$
    ppr ty
Alan Zimmerman's avatar
Alan Zimmerman committed
631
mkGadtDecl names (L ls (HsForAllTy imp Nothing qvars cxt tau))
thomasw's avatar
thomasw committed
632
  = return $ mk_gadt_con names
633
  where
634
    (details, res_ty)           -- See Note [Sorting out the result type]
635
      = case tau of
Alan Zimmerman's avatar
Alan Zimmerman committed
636 637
          L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
                                            -> (RecCon (L l flds), res_ty)
638
          _other                                    -> (PrefixCon [], tau)
639

640
    mk_gadt_con names
641
       = ConDecl { con_old_rec  = False
642
                 , con_names    = names
643 644 645 646
                 , con_explicit = imp
                 , con_qvars    = qvars
                 , con_cxt      = cxt
                 , con_details  = details
Alan Zimmerman's avatar
Alan Zimmerman committed
647
                 , con_res      = ResTyGADT ls res_ty
648
                 , con_doc      = Nothing }
649
mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
650 651 652

tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
653
  | isTcOcc (rdrNameOcc tc)
654
  = return (L loc (setRdrNameSpace tc srcDataName))
655
  | otherwise
656 657 658 659
  = parseErrorSDoc loc (msg $$ extra)
  where
    msg = text "Not a data constructor:" <+> quotes (ppr tc)
    extra | tc == forall_tv_RDR
660
          = text "Perhaps you intended to use ExistentialQuantification"
661
          | otherwise = empty
rodlogic's avatar
rodlogic committed
662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679

-- | Note [Sorting out the result type]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In a GADT declaration which is not a record, we put the whole constr
-- type into the ResTyGADT for now; the renamer will unravel it once it
-- has sorted out operator fixities. Consider for example
--      C :: a :*: b -> a :*: b -> a :+: b
-- Initially this type will parse as
--       a :*: (b -> (a :*: (b -> (a :+: b))))

-- so it's hard to split up the arguments until we've done the precedence
-- resolution (in the renamer) On the other hand, for a record
--         { x,y :: Int } -> a :*: b
-- there is no doubt.  AND we need to sort records out so that
-- we can bring x,y into scope.  So:
--    * For PrefixCon we keep all the args in the ResTyGADT
--    * For RecCon we do not

680 681
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
-- Same as checkTyVars, but in the P monad
rodlogic's avatar
rodlogic committed
682 683
checkTyVarsP pp_what equals_or_where tc tparms
  = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
684 685 686 687 688

eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
eitherToP (Right thing)     = return thing
rodlogic's avatar
rodlogic committed
689
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
690
            -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName)
691
-- Check whether the given list of type parameters are all type variables
692 693 694
-- (possibly with a kind signature)
-- We use the Either monad because it's also called (via mkATDefault) from
-- Convert.hs
rodlogic's avatar
rodlogic committed
695
checkTyVars pp_what equals_or_where tc tparms
696 697
  = do { tvs <- mapM chk tparms
       ; return (mkHsQTvs tvs) }
698
  where
rodlogic's avatar
rodlogic committed
699

700
        -- Check that the name space is correct!
Alan Zimmerman's avatar
Alan Zimmerman committed
701 702
    chk (L l (HsKindSig (L lv (HsTyVar tv)) k))
        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
703
    chk (L l (HsTyVar tv))
704
        | isRdrTyVar tv    = return (L l (UserTyVar tv))
705
    chk t@(L loc _)
rodlogic's avatar
rodlogic committed
706
        = Left (loc,
707 708 709
                vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
                     , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
                     , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
rodlogic's avatar
rodlogic committed
710
                     , nest 2 (pp_what <+> ppr tc
711 712
                                       <+> hsep (map text (takeList tparms allNameStrings))
                                       <+> equals_or_where) ] ])
713

714
whereDots, equalsDots :: SDoc
715
-- Second argument to checkTyVars
716 717
whereDots  = ptext (sLit "where ...")
equalsDots = ptext (sLit "= ...")
718

719 720
checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
checkDatatypeContext Nothing = return ()
721
checkDatatypeContext (Just (L loc c))
722 723
    = do allowed <- extension datatypeContextsEnabled
         unless allowed $
724
             parseErrorSDoc loc
725
                 (text "Illegal datatype context (use DatatypeContexts):" <+>
726
                  pprHsContext c)
thomasw's avatar
thomasw committed
727 728
         mapM_ (checkNoPartialType err) c
      where err = text "In the context:" <+> pprHsContextNoArrow c
729

730 731 732 733 734 735
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(L loc r)
    = do allowed <- extension traditionalRecordSyntaxEnabled
         if allowed
             then return lr
             else parseErrorSDoc loc
736
                      (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
737 738
                       ppr r)

739
checkTyClHdr :: LHsType RdrName
740
             -> P (Located RdrName,          -- the head symbol (type or class name)
Alan Zimmerman's avatar
Alan Zimmerman committed
741 742
                   [LHsType RdrName],        -- parameters of head symbol
                   [AddAnn]) -- API Annotation for HsParTy when stripping parens
743
-- Well-formedness check and decomposition of type and class heads.
744
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
745
--              Int :*: Bool   into    (:*:, [Int, Bool])
746 747
-- returning the pieces
checkTyClHdr ty
Alan Zimmerman's avatar
Alan Zimmerman committed
748
  = goL ty [] []
749
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
750 751 752 753 754 755 756 757 758
    goL (L l ty) acc ann = go l ty acc ann

    go l (HsTyVar tc) acc ann
        | isRdrTc tc             = return (L l tc, acc, ann)
    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann
        | isRdrTc tc             = return (ltc, t1:t2:acc, ann)
    go l (HsParTy ty)    acc ann = goL ty acc (ann ++ mkParensApiAnn l)
    go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann
    go l (HsTupleTy _ []) [] ann = return (L l (getRdrName unitTyCon), [],ann)
759
                                   -- See Note [Unit tuples] in HsTypes
Alan Zimmerman's avatar
Alan Zimmerman committed
760 761 762
    go l _               _   _
         = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                             <+> ppr ty)
763

764
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
batterseapower's avatar
batterseapower committed
765 766
checkContext (L l orig_t)
  = check orig_t
767
 where
768
  check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
769
    = return (L l ts)           -- Ditto ()
770

771
  check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
772
    = check (unLoc ty)
773

batterseapower's avatar
batterseapower committed
774 775
  check _
    = return (L l [L l orig_t])
776

777
-- -------------------------------------------------------------------------
778 779 780 781 782
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

783 784
checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
checkPattern msg e = checkLPat msg e
785

786 787
checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
checkPatterns msg es = mapM (checkPattern msg) es
788

789 790
checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
checkLPat msg e@(L l _) = checkPat msg l e []
791

792 793 794
checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
         -> P (LPat RdrName)
checkPat _ loc (L l (HsVar c)) args
795
  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
796
checkPat msg loc e args     -- OK to let this happen even if bang-patterns
797 798
                        -- are not enabled, because there is no valid
                        -- non-bang-pattern parse of (C ! e)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
799
  | Just (e', args') <- splitBang e
800 801 802 803 804 805 806
  = do  { args'' <- checkPatterns msg args'
        ; checkPat msg loc e' (args'' ++ args) }
checkPat msg loc (L _ (HsApp f e)) args
  = do p <- checkLPat msg e
       checkPat msg loc f (p : args)
checkPat msg loc (L _ e) []
  = do p <- checkAPat msg loc e
807
       return (L loc p)
808 809
checkPat msg loc e _
  = patFail msg loc (unLoc e)
810

811 812
checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat msg loc e0 = do
813 814 815
 pState <- getPState
 let dynflags = dflags pState
 case e0 of
816 817 818
   EWildPat -> return (WildPat placeHolderType)
   HsVar x  -> return (VarPat x)
   HsLit l  -> return (LitPat l)
819 820 821

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- Negation is recorded separately, so that the literal is zero or +ve
822
   -- NB. Negative *primitive* literals are already handled by the lexer
Alan Zimmerman's avatar
Alan Zimmerman committed
823 824 825
   HsOverLit pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
   NegApp (L l (HsOverLit pos_lit)) _
                        -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
826

Alan Zimmerman's avatar
Alan Zimmerman committed
827
   SectionR (L lb (HsVar bang)) e        -- (! x)
828 829
        | bang == bang_RDR
        -> do { bang_on <- extension bangPatEnabled
Alan Zimmerman's avatar
Alan Zimmerman committed
830 831 832
              ; if bang_on then do { e' <- checkLPat msg e
                                   ; addAnnotation loc AnnBang lb
                                   ; return  (BangPat e') }
833
                else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
834

835 836
   ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
   EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
837
   -- view pattern is well-formed if the pattern is
thomasw's avatar
thomasw committed
838
   EViewPat expr patE  -> checkLPat msg patE >>=
839
                            (return . (\p -> ViewPat expr p placeHolderType))
thomasw's avatar
thomasw committed
840 841 842 843 844 845 846 847 848
   ExprWithTySig e t _ -> do e <- checkLPat msg e
                             -- Pattern signatures are parsed as sigtypes,
                             -- but they aren't explicit forall points.  Hence
                             -- we have to remove the implicit forall here.
                             let t' = case t of
                                        L _ (HsForAllTy Implicit _ _
                                             (L _ []) ty) -> ty
                                        other -> other
                             return (SigPatIn e (mkHsWithBndrs t'))
849

850
   -- n+k patterns
851
   OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
Alan Zimmerman's avatar
Alan Zimmerman committed
852
         (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
853
                      | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
Alan Zimmerman's avatar
Alan Zimmerman committed
854
                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))
855

856 857
   OpApp l op _fix r  -> do l <- checkLPat msg l
                            r <- checkLPat msg r
858 859 860
                            case op of
                               L cl (HsVar c) | isDataOcc (rdrNameOcc c)
                                      -> return (ConPatIn (L cl c) (InfixCon l r))