RdrHsSyn.hs 62.6 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
{-# LANGUAGE TypeFamilies #-}
10

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

28
        cvBindGroup,
29
        cvBindsAndSigs,
30
        cvTopDecls,
31
        placeHolderPunRhs,
32

33 34
        -- Stuff to do with Foreign declarations
        mkImport,
35
        parseCImport,
36 37 38
        mkExport,
        mkExtName,           -- RdrName -> CLabelString
        mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
39
        mkConDeclH98,
40
        mkATDefault,
41 42 43 44 45 46

        -- 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
47
        bang_RDR,
48 49
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkMonadComp,       -- P (HsStmtContext RdrName)
50
        checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
51
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
52
        checkValSigLhs,
53
        checkDoAndIfThenElse,
54
        checkRecordSyntax,
55
        parseErrorSDoc,
56
        splitTilde, splitTildeApps,
57 58 59

        -- Help with processing exports
        ImpExpSubSpec(..),
60
        ImpExpQcSpec(..),
61
        mkModuleImpExp,
62 63
        mkTypeImpExp,
        mkImpExpSubSpec,
64 65 66
        checkImportSpec,

        SumOrTuple (..), mkSumOrTuple
67

68 69
    ) where

70
import HsSyn            -- Lots of it
71
import Class            ( FunDep )
72 73 74
import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon          ( DataCon, dataConTyCon )
import ConLike          ( ConLike(..) )
75
import CoAxiom          ( Role, fsFromRole )
76 77 78
import RdrName
import Name
import BasicTypes
79
import TcEvidence       ( idHsWrapper )
80
import Lexer
Simon Peyton Jones's avatar
Simon Peyton Jones committed
81
import Lexeme           ( isLexCon )
82 83 84
import Type             ( TyThing(..) )
import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
85 86
                          listTyConName, listTyConKey,
                          starKindTyConName, unicodeStarKindTyConName )
87
import ForeignCall
88
import PrelNames        ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
89
import SrcLoc
90
import Unique           ( hasKey )
91
import OrdList          ( OrdList, fromOL )
cactus's avatar
cactus committed
92
import Bag              ( emptyBag, consBag )
93 94
import Outputable
import FastString
95
import Maybes
96
import Util
Alan Zimmerman's avatar
Alan Zimmerman committed
97
import ApiAnnotation
98
import Data.List
99
import qualified GHC.LanguageExtensions as LangExt
100
import MonadUtils
101

102
import Control.Monad
103
import Text.ParserCombinators.ReadP as ReadP
Ian Lynagh's avatar
Ian Lynagh committed
104
import Data.Char
105

106 107
import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )

108
#include "HsVersions.h"
109

110

rodlogic's avatar
rodlogic committed
111 112 113
{- **********************************************************************

  Construction functions for Rdr stuff
114

rodlogic's avatar
rodlogic committed
115
  ********************************************************************* -}
116

rodlogic's avatar
rodlogic committed
117 118 119 120 121
-- | 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).
122

rodlogic's avatar
rodlogic committed
123 124
-- Similarly for mkConDecl, mkClassOpSig and default-method names.

125
--         *** See Note [The Naming story] in HsDecls ****
126

127 128 129 130 131 132
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)

133
mkClassDecl :: SrcSpan
134
            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
Alan Zimmerman's avatar
Alan Zimmerman committed
135
            -> Located (a,[Located (FunDep (Located RdrName))])
136 137
            -> OrdList (LHsDecl GhcPs)
            -> P (LTyClDecl GhcPs)
138

139
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
140 141
  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
       ; let cxt = fromMaybe (noLoc []) mcxt
142
       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
143
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
144
       ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
145
       ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
146
       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars
147
                                  , tcdFixity = fixity
148 149 150 151 152
                                  , tcdFDs = snd (unLoc fds)
                                  , tcdSigs = mkClassOpSigs sigs
                                  , tcdMeths = binds
                                  , tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs
                                  , tcdFVs = placeHolderNames })) }
153

154 155
mkATDefault :: LTyFamInstDecl GhcPs
            -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
156 157 158
-- 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
159 160
--
-- We use the Either monad because this also called
161 162
-- from Convert.hs
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
163 164
      | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity
                 , tfe_rhs = rhs } <- e
165
      = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)
166 167
           ; return (L loc (TyFamEqn { tfe_tycon = tc
                                     , tfe_pats = tvs
168
                                     , tfe_fixity = fixity
169 170
                                     , tfe_rhs = rhs })) }

171 172
mkTyData :: SrcSpan
         -> NewOrData
173
         -> Maybe (Located CType)
174 175 176 177 178
         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
         -> Maybe (LHsKind GhcPs)
         -> [LConDecl GhcPs]
         -> HsDeriving GhcPs
         -> P (LTyClDecl GhcPs)
179
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
180
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
181
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
182
       ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
183
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
184
       ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
185
                                   tcdFixity = fixity,
186
                                   tcdDataDefn = defn,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
187
                                   tcdDataCusk = PlaceHolder,
188
                                   tcdFVs = placeHolderNames })) }
189

190
mkDataDefn :: NewOrData
191
           -> Maybe (Located CType)
192 193 194 195 196
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> [LConDecl GhcPs]
           -> HsDeriving GhcPs
           -> P (HsDataDefn GhcPs)
197 198
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
  = do { checkDatatypeContext mcxt
199
       ; let cxt = fromMaybe (noLoc []) mcxt
200
       ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
rodlogic's avatar
rodlogic committed
201
                            , dd_ctxt = cxt
202 203 204
                            , dd_cons = data_cons
                            , dd_kindSig = ksig
                            , dd_derivs = maybe_deriv }) }
thomasw's avatar
thomasw committed
205

206

207
mkTySynonym :: SrcSpan
208 209 210
            -> LHsType GhcPs  -- LHS
            -> LHsType GhcPs  -- RHS
            -> P (LTyClDecl GhcPs)
211
mkTySynonym loc lhs rhs
212
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
Alan Zimmerman's avatar
Alan Zimmerman committed
213
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
214
       ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
215
       ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
216
                                , tcdFixity = fixity
217
                                , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
218

219 220 221
mkTyFamInstEqn :: LHsType GhcPs
               -> LHsType GhcPs
               -> P (TyFamInstEqn GhcPs,[AddAnn])
222
mkTyFamInstEqn lhs rhs
223
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
224
       ; return (TyFamEqn { tfe_tycon = tc
225
                          , tfe_pats  = mkHsImplicitBndrs tparams
226
                          , tfe_fixity = fixity
Alan Zimmerman's avatar
Alan Zimmerman committed
227 228
                          , tfe_rhs   = rhs },
                 ann) }
229

230
mkDataFamInst :: SrcSpan
Jan Stolarek's avatar
Jan Stolarek committed
231 232
              -> NewOrData
              -> Maybe (Located CType)
233 234 235 236 237
              -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> HsDeriving GhcPs
              -> P (LInstDecl GhcPs)
238
mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
239
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
Alan Zimmerman's avatar
Alan Zimmerman committed
240
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
241 242
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
       ; return (L loc (DataFamInstD (
Adam Gundry's avatar
Adam Gundry committed
243
                  DataFamInstDecl { dfid_tycon = tc
244
                                  , dfid_pats = mkHsImplicitBndrs tparams
245
                                  , dfid_fixity = fixity
246 247
                                  , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }

248
mkTyFamInst :: SrcSpan
249 250
            -> LTyFamInstEqn GhcPs
            -> P (LInstDecl GhcPs)
251
mkTyFamInst loc eqn
252 253
  = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn  = eqn
                                             , tfid_fvs  = placeHolderNames })))
254 255

mkFamDecl :: SrcSpan
256 257 258 259 260
          -> FamilyInfo GhcPs
          -> LHsType GhcPs                   -- LHS
          -> Located (FamilyResultSig GhcPs) -- Optional result signature
          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
          -> P (LTyClDecl GhcPs)
Jan Stolarek's avatar
Jan Stolarek committed
261
mkFamDecl loc info lhs ksig injAnn
262
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
Alan Zimmerman's avatar
Alan Zimmerman committed
263
       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
264
       ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
Jan Stolarek's avatar
Jan Stolarek committed
265 266
       ; return (L loc (FamDecl (FamilyDecl{ fdInfo      = info, fdLName = tc
                                           , fdTyVars    = tyvars
267
                                           , fdFixity    = fixity
Jan Stolarek's avatar
Jan Stolarek committed
268 269
                                           , fdResultSig = ksig
                                           , fdInjectivityAnn = injAnn }))) }
270 271 272 273 274
  where
    equals_or_where = case info of
                        DataFamily          -> empty
                        OpenTypeFamily      -> empty
                        ClosedTypeFamily {} -> whereDots
275

276
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
277
-- If the user wrote
278
--      [pads| ... ]   then return a QuasiQuoteD
279
--      $(e)           then return a SpliceD
280 281
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
282
--                     ie a SpliceD
283 284 285
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
286
mkSpliceDecl lexpr@(L loc expr)
287 288 289 290 291 292 293
  | HsSpliceE splice@(HsUntypedSplice {}) <- expr
  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)

  | HsSpliceE splice@(HsQuasiQuote {}) <- expr
  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)

  | otherwise
Alan Zimmerman's avatar
Alan Zimmerman committed
294
  = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)
295

296
mkRoleAnnotDecl :: SrcSpan
297
                -> Located RdrName                -- type being annotated
298
                -> [Located (Maybe FastString)]      -- roles
299
                -> P (LRoleAnnotDecl GhcPs)
300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322
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)
323

rodlogic's avatar
rodlogic committed
324 325 326
{- **********************************************************************

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

rodlogic's avatar
rodlogic committed
328 329 330 331 332
  ********************************************************************* -}

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


335
--  | Groups together bindings for a single function
336
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
337
cvTopDecls decls = go (fromOL decls)
338
  where
339
    go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
340
    go []                   = []
341
    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
342 343
                            where (L l' b', ds') = getMonoBind (L l b) ds
    go (d : ds)             = d : go ds
344

345
-- Declaration list may only contain value bindings and signatures.
346
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
347
cvBindGroup binding
348 349 350
  = 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 }
351

352 353 354
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
355
-- Input decls contain just value bindings and signatures
356
-- and in case of class or instance declarations also
357
-- associated type declarations. They might also contain Haddock comments.
358
cvBindsAndSigs fb = go (fromOL fb)
359
  where
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384
    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) }
385 386 387 388

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

389 390
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
  -> (LHsBind GhcPs, [LHsDecl GhcPs])
391 392 393
-- 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
394 395 396 397 398

-- 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.
--
399
-- All Haddock comments between equations inside the group are
400 401
-- discarded.
--
402 403
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

404
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
405 406
                               fun_matches
                                 = MG { mg_alts = L _ mtchs1 } })) binds
407
  | has_args mtchs1
408
  = go mtchs1 loc1 binds []
409
  where
410 411
    go mtchs loc
       (L loc2 (ValD (FunBind { fun_id = L _ f2,
412 413
                                fun_matches
                                  = MG { mg_alts = L _ mtchs2 } })) : binds) _
414
        | f1 == f2 = go (mtchs2 ++ mtchs)
415
                        (combineSrcSpans loc loc2) binds []
416
    go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
417
        = let doc_decls' = doc_decl : doc_decls
418 419 420 421
          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go mtchs loc binds doc_decls
        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
          , (reverse doc_decls) ++ binds)
422
        -- Reverse the final matches, to get it back in the right order
423
        -- Do the same thing with the trailing doc comments
424

425 426
getMonoBind bind binds = (bind, binds)

427
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
428 429
has_args []                                    = panic "RdrHsSyn:has_args"
has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
430 431 432 433
        -- 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).
434

rodlogic's avatar
rodlogic committed
435 436 437
{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion
438

rodlogic's avatar
rodlogic committed
439
  ********************************************************************* -}
440

Simon Peyton Jones's avatar
Simon Peyton Jones committed
441 442 443 444 445 446 447 448 449 450 451 452 453
{- Note [Parsing data constructors is hard]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We parse the RHS of the constructor declaration
     data T = C t1 t2
as a btype_no_ops (treating C as a type constructor) and then convert C to be
a data constructor.  Reason: it might continue like this:
     data T = C t1 t2 :% D Int
in which case C really /would/ be a type constructor.  We can't resolve this
ambiguity till we come across the constructor oprerator :% (or not, more usually)

So the plan is:

* Parse the data constructor declration as a type (actually btype_no_ops)
454

Simon Peyton Jones's avatar
Simon Peyton Jones committed
455 456 457 458 459 460 461 462 463 464
* Use 'splitCon' to rejig it into the data constructor and the args

* In doing so, we use 'tyConToDataCon' to convert the RdrName for
  the data con, which has been parsed as a tycon, back to a datacon.
  This is more than just adjusting the name space; for operators we
  need to check that it begins with a colon.  E.g.
     data T = (+++)
  will parse ok (since tycons can be operators), but we should reject
  it (Trac #12051).
-}
465

466 467
splitCon :: LHsType GhcPs
      -> P (Located RdrName, HsConDeclDetails GhcPs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
468
-- See Note [Parsing data constructors is hard]
469 470 471 472 473 474
-- 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 []
475
 where
476 477
   -- This is used somewhere where HsAppsTy is not used
   split (L _ (HsAppTy t u)) ts       = split t (u : ts)
Alan Zimmerman's avatar
Alan Zimmerman committed
478 479
   split (L l (HsTyVar _ (L _ tc)))  ts = do data_con <- tyConToDataCon l tc
                                             return (data_con, mk_rest ts)
480 481 482
   split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
      = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
   split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
483

Alan Zimmerman's avatar
Alan Zimmerman committed
484
   mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
485 486
   mk_rest ts                   = PrefixCon ts

Simon Peyton Jones's avatar
Simon Peyton Jones committed
487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
-- See Note [Parsing data constructors is hard]
-- Data constructor RHSs are parsed as types
tyConToDataCon loc tc
  | isTcOcc occ
  , isLexCon (occNameFS occ)
  = return (L loc (setRdrNameSpace tc srcDataName))

  | otherwise
  = parseErrorSDoc loc (msg $$ extra)
  where
    occ = rdrNameOcc tc

    msg = text "Not a data constructor:" <+> quotes (ppr tc)
    extra | tc == forall_tv_RDR
          = text "Perhaps you intended to use ExistentialQuantification"
          | otherwise = empty
504

505
mkPatSynMatchGroup :: Located RdrName
506 507
                   -> Located (OrdList (LHsDecl GhcPs))
                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
508
mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
509
    do { matches <- mapM fromDecl (fromOL decls)
510
       ; when (null matches) (wrongNumberErr loc)
511 512
       ; return $ mkMatchGroup FromSource matches }
  where
513
    fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =
514 515 516
        do { unless (name == patsyn_name) $
               wrongNameBindingErr loc decl
           ; match <- case details of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
517 518 519 520 521 522 523 524 525 526
               PrefixCon pats -> return $ Match { m_ctxt = ctxt, m_pats = pats
                                                , m_type = Nothing, m_grhss = rhs }
                   where
                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }

               InfixCon p1 p2 -> return $ Match { m_ctxt = ctxt, m_pats = [p1, p2]
                                                , m_type = Nothing, m_grhss = rhs }
                   where
                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }

527 528 529 530 531 532 533 534 535 536 537 538 539 540
               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

541 542
    wrongNumberErr loc =
      parseErrorSDoc loc $
543
      text "pattern synonym 'where' clause cannot be empty" $$
544 545
      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)

546
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
547 548 549 550 551
recordPatSynErr loc pat =
    parseErrorSDoc loc $
    text "record syntax not supported for pattern synonym declarations:" $$
    ppr pat

552 553 554
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
                -> LHsContext GhcPs -> HsConDeclDetails GhcPs
                -> ConDecl GhcPs
555

Alan Zimmerman's avatar
Alan Zimmerman committed
556 557 558 559 560 561 562 563
mkConDeclH98 name mb_forall cxt details
  = ConDeclH98 { con_name     = name
               , con_qvars    = fmap mkHsQTvs mb_forall
               , con_cxt      = Just cxt
                             -- AZ:TODO: when can cxt be Nothing?
                             --          remembering that () is a valid context.
               , con_details  = details
               , con_doc      = Nothing }
564

565
mkGadtDecl :: [Located RdrName]
566 567
           -> LHsSigType GhcPs     -- Always a HsForAllTy
           -> ConDecl GhcPs
Alan Zimmerman's avatar
Alan Zimmerman committed
568 569 570
mkGadtDecl names ty = ConDeclGADT { con_names = names
                                  , con_type  = ty
                                  , con_doc   = Nothing }
571

572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
--
-- > data T a = T | T1 Int
--
-- we parse the data constructors as /types/ because of parser ambiguities,
-- so then we need to change the /type constr/ to a /data constr/
--
-- The exact-name case /can/ occur when parsing:
--
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace (Exact n)    ns
  | Just thing <- wiredInNameTyThing_maybe n
  = setWiredInNameSpace thing ns
    -- Preserve Exact Names for wired-in things,
    -- notably tuples and lists

  | isExternalName n
  = Orig (nameModule n) occ

  | otherwise   -- This can happen when quoting and then
                -- splicing a fixity declaration for a type
  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
  where
    occ = setOccNameSpace ns (nameOccName n)

setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
setWiredInNameSpace (ATyCon tc) ns
  | isDataConNameSpace ns
  = ty_con_data_con tc
  | isTcClsNameSpace ns
  = Exact (getName tc)      -- No-op

setWiredInNameSpace (AConLike (RealDataCon dc)) ns
  | isTcClsNameSpace ns
  = data_con_ty_con dc
  | isDataConNameSpace ns
  = Exact (getName dc)      -- No-op

setWiredInNameSpace thing ns
  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)

ty_con_data_con :: TyCon -> RdrName
ty_con_data_con tc
  | isTupleTyCon tc
  , Just dc <- tyConSingleDataCon_maybe tc
  = Exact (getName dc)

  | tc `hasKey` listTyConKey
  = Exact nilDataConName

  | otherwise  -- See Note [setRdrNameSpace for wired-in names]
  = Unqual (setOccNameSpace srcDataName (getOccName tc))

data_con_ty_con :: DataCon -> RdrName
data_con_ty_con dc
  | let tc = dataConTyCon dc
  , isTupleTyCon tc
  = Exact (getName tc)

  | dc `hasKey` nilDataConKey
  = Exact listTyConName

  | otherwise  -- See Note [setRdrNameSpace for wired-in names]
  = Unqual (setOccNameSpace tcClsName (getOccName dc))


{- Note [setRdrNameSpace for wired-in names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In GHC.Types, which declares (:), we have
  infixr 5 :
The ambiguity about which ":" is meant is resolved by parsing it as a
data constructor, but then using dataTcOccs to try the type constructor too;
and that in turn calls setRdrNameSpace to change the name-space of ":" to
tcClsName.  There isn't a corresponding ":" type constructor, but it's painful
to make setRdrNameSpace partial, so we just make an Unqual name instead. It
really doesn't matter!
-}

rodlogic's avatar
rodlogic committed
657
-- | Note [Sorting out the result type]
658
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Alan Zimmerman's avatar
Alan Zimmerman committed
659 660 661
-- In a GADT declaration which is not a record, we put the whole constr type
-- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
-- it has sorted out operator fixities. Consider for example
rodlogic's avatar
rodlogic committed
662 663 664
--      C :: a :*: b -> a :*: b -> a :+: b
-- Initially this type will parse as
--       a :*: (b -> (a :*: (b -> (a :+: b))))
Alan Zimmerman's avatar
Alan Zimmerman committed
665
--
rodlogic's avatar
rodlogic committed
666
-- so it's hard to split up the arguments until we've done the precedence
667
-- resolution (in the renamer). On the other hand, for a record
rodlogic's avatar
rodlogic committed
668 669 670
--         { 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:
Alan Zimmerman's avatar
Alan Zimmerman committed
671
--    * For PrefixCon we keep all the args in the res_ty
rodlogic's avatar
rodlogic committed
672 673
--    * For RecCon we do not

674 675
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
             -> P (LHsQTyVars GhcPs)
676
-- Same as checkTyVars, but in the P monad
rodlogic's avatar
rodlogic committed
677 678
checkTyVarsP pp_what equals_or_where tc tparms
  = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
679 680 681 682 683

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
684

685 686
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
            -> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs)
687
-- Check whether the given list of type parameters are all type variables
688 689 690
-- (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
691
checkTyVars pp_what equals_or_where tc tparms
692 693
  = do { tvs <- mapM chk tparms
       ; return (mkHsQTvs tvs) }
694
  where
rodlogic's avatar
rodlogic committed
695

696
    chk (L _ (HsParTy ty)) = chk ty
697
    chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
698

699
        -- Check that the name space is correct!
700
    chk (L l (HsKindSig
Alan Zimmerman's avatar
Alan Zimmerman committed
701
            (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
Alan Zimmerman's avatar
Alan Zimmerman committed
702
        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
Alan Zimmerman's avatar
Alan Zimmerman committed
703
    chk (L l (HsTyVar _ (L ltv tv)))
704
        | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))
705
    chk t@(L loc _)
rodlogic's avatar
rodlogic committed
706
        = Left (loc,
707 708 709
                vcat [ text "Unexpected type" <+> quotes (ppr t)
                     , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
                     , vcat[ (text "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  = text "where ..."
equalsDots = text "= ..."
718

719
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
720
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)
727

728 729 730 731 732 733
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
734
                      (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
735 736
                       ppr r)

737 738
checkTyClHdr :: Bool               -- True  <=> class header
                                   -- False <=> type header
739 740 741 742
             -> LHsType GhcPs
             -> P (Located RdrName,      -- the head symbol (type or class name)
                   [LHsType GhcPs],      -- parameters of head symbol
                   LexicalFixity,        -- the declaration is in infix format
Alan Zimmerman's avatar
Alan Zimmerman committed
743
                   [AddAnn]) -- API Annotation for HsParTy when stripping parens
744
-- Well-formedness check and decomposition of type and class heads.
745
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
746
--              Int :*: Bool   into    (:*:, [Int, Bool])
747
-- returning the pieces
748
checkTyClHdr is_cls ty
749
  = goL ty [] [] Prefix
750
  where
751 752 753 754 755 756 757 758 759 760 761 762 763
    goL (L l ty) acc ann fix = go l ty acc ann fix

    go l (HsTyVar _ (L _ tc)) acc ann fix
      | isRdrTc tc               = return (L l tc, acc, fix, ann)
    go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix
      | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
    go l (HsParTy ty)    acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix
    go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
    go _ (HsAppsTy ts)   acc ann _fix
      | Just (head, args, fixity) <- getAppsTyHead_maybe ts
      = goL head (args ++ acc) ann fixity

    go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix
Matthew Pickering's avatar
Matthew Pickering committed
764
      | isStar star
765
      = return (L loc (nameRdrName starKindTyConName), [], fix, ann)
Matthew Pickering's avatar
Matthew Pickering committed
766
      | isUniStar star
767
      = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
768

769 770
    go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix
      = return (L l (nameRdrName tup_name), ts, fix, ann)
771 772 773 774 775
      where
        arity = length ts
        tup_name | is_cls    = cTupleTyConName arity
                 | otherwise = getName (tupleTyCon Boxed arity)
                 -- See Note [Unit tuples] in HsTypes  (TODO: is this still relevant?)
776
    go l _ _ _ _
777 778
      = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                          <+> ppr ty)
779

780
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
batterseapower's avatar
batterseapower committed
781
checkContext (L l orig_t)
782
  = check [] (L l orig_t)
783
 where
784 785
  check anns (L lp (HsTupleTy _ ts))   -- (Eq a, Ord b) shows up as a tuple type
    = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
786

787
    -- don't let HsAppsTy get in the way
788
  check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
789 790
    = check anns ty

791 792 793 794
  check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
       = check anns' ty
         where anns' = if l == lp1 then anns
                                   else (anns ++ mkParensApiAnn lp1)
795

796 797
  check _anns _
    = return ([],L l [L l orig_t]) -- no need for anns, returning original
798

799
-- -------------------------------------------------------------------------
800 801 802 803 804
-- Checking Patterns.

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

805
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
806
checkPattern msg e = checkLPat msg e
807

808
checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
809
checkPatterns msg es = mapM (checkPattern msg) es
810

811