RdrHsSyn.hs 119 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 FlexibleInstances #-}
10
{-# LANGUAGE TypeFamilies #-}
11
{-# LANGUAGE MagicHash #-}
12
{-# LANGUAGE ViewPatterns #-}
13 14 15 16
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
17
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18

19
module   RdrHsSyn (
20 21
        mkHsOpApp,
        mkHsIntegral, mkHsFractional, mkHsIsString,
22
        mkHsDo, mkSpliceDecl,
23
        mkRoleAnnotDecl,
rodlogic's avatar
rodlogic committed
24 25
        mkClassDecl,
        mkTyData, mkDataFamInst,
26
        mkTySynonym, mkTyFamInstEqn,
27
        mkStandaloneKindSig,
rodlogic's avatar
rodlogic committed
28
        mkTyFamInst,
29
        mkFamDecl, mkLHsSigType,
30
        mkInlinePragma,
31
        mkPatSynMatchGroup,
32
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
33
        mkTyClD, mkInstD,
34
        mkRdrRecordCon, mkRdrRecordUpd,
35
        setRdrNameSpace,
36
        filterCTuple,
37

38
        cvBindGroup,
39
        cvBindsAndSigs,
40
        cvTopDecls,
41
        placeHolderPunRhs,
42

43 44
        -- Stuff to do with Foreign declarations
        mkImport,
45
        parseCImport,
46
        mkExport,
47 48
        mkExtName,    -- RdrName -> CLabelString
        mkGadtDecl,   -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
Alan Zimmerman's avatar
Alan Zimmerman committed
49
        mkConDeclH98,
50 51 52

        -- Bunch of functions in the parser monad for
        -- checking and constructing values
53
        checkImportDecl,
54
        checkExpBlockArguments,
55 56 57
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPattern,         -- HsExp -> P HsPat
58
        checkPattern_msg,
59
        checkMonadComp,       -- P (HsStmtContext GhcPs)
60
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
61
        checkValSigLhs,
62 63 64
        LRuleTyTmVar, RuleTyTmVar(..),
        mkRuleBndrs, mkRuleTyVarBndrs,
        checkRuleTyVarBndrNames,
65
        checkRecordSyntax,
Tao He's avatar
Tao He committed
66
        checkEmptyGADTs,
67
        addFatalError, hintBangPat,
68
        TyEl(..), mergeOps, mergeDataCon,
69
        mkBangTy,
70 71 72

        -- Help with processing exports
        ImpExpSubSpec(..),
73
        ImpExpQcSpec(..),
74
        mkModuleImpExp,
75 76
        mkTypeImpExp,
        mkImpExpSubSpec,
77 78
        checkImportSpec,

79 80 81 82
        -- Token symbols
        forallSym,
        starSym,

83 84
        -- Warnings and errors
        warnStarIsType,
85
        warnPrepositiveQualifiedModule,
86
        failOpFewArgs,
87 88
        failOpNotEnabledImportQualifiedPost,
        failOpImportQualifiedTwice,
89

90
        SumOrTuple (..),
91

92
        -- Expression/command/pattern ambiguity resolution
93
        PV,
94
        runPV,
95 96 97 98 99 100 101
        ECP(ECP, runECP_PV),
        runECP_P,
        DisambInfixOp(..),
        DisambECP(..),
        ecpFromExp,
        ecpFromCmd,
        PatBuilder,
102

103 104
    ) where

105
import GhcPrelude
Sylvain Henry's avatar
Sylvain Henry committed
106
import GHC.Hs           -- Lots of it
107 108 109
import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon          ( DataCon, dataConTyCon )
import ConLike          ( ConLike(..) )
110
import CoAxiom          ( Role, fsFromRole )
111 112 113
import RdrName
import Name
import BasicTypes
114
import Lexer
Simon Peyton Jones's avatar
Simon Peyton Jones committed
115
import Lexeme           ( isLexCon )
Alec Theriault's avatar
Alec Theriault committed
116
import Type             ( TyThing(..), funTyCon )
117 118
import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                          nilDataConName, nilDataConKey,
119 120
                          listTyConName, listTyConKey, eqTyCon_RDR,
                          tupleTyConName, cTupleTyConNameArity_maybe )
121
import ForeignCall
122
import PrelNames        ( allNameStrings )
123
import SrcLoc
124
import Unique           ( hasKey )
125
import OrdList          ( OrdList, fromOL )
cactus's avatar
cactus committed
126
import Bag              ( emptyBag, consBag )
127 128
import Outputable
import FastString
129
import Maybes
130
import Util
Alan Zimmerman's avatar
Alan Zimmerman committed
131
import ApiAnnotation
132
import Data.List
Vladislav Zavialov's avatar
Vladislav Zavialov committed
133 134
import DynFlags ( WarningFlag(..), DynFlags )
import ErrUtils ( Messages )
135

136
import Control.Monad
137
import Text.ParserCombinators.ReadP as ReadP
Ian Lynagh's avatar
Ian Lynagh committed
138
import Data.Char
My Nguyen's avatar
My Nguyen committed
139
import qualified Data.Monoid as Monoid
140
import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
Ben Gamari's avatar
Ben Gamari committed
141
import Data.Kind       ( Type )
142

143
#include "HsVersions.h"
144

145

rodlogic's avatar
rodlogic committed
146 147 148
{- **********************************************************************

  Construction functions for Rdr stuff
149

rodlogic's avatar
rodlogic committed
150
  ********************************************************************* -}
151

rodlogic's avatar
rodlogic committed
152 153 154 155 156
-- | 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).
157

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

Sylvain Henry's avatar
Sylvain Henry committed
160
--         *** See Note [The Naming story] in GHC.Hs.Decls ****
161

162
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
163
mkTyClD (L loc d) = L loc (TyClD noExtField d)
164

165
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
166
mkInstD (L loc d) = L loc (InstD noExtField d)
167

168
mkClassDecl :: SrcSpan
169
            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
170
            -> Located (a,[LHsFunDep GhcPs])
171 172
            -> OrdList (LHsDecl GhcPs)
            -> P (LTyClDecl GhcPs)
173

174
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
175
  = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
176
       ; let cxt = fromMaybe (noLoc []) mcxt
177
       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
178
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
179
       ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
180
       ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
181 182 183 184 185 186 187 188
       ; return (L loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt
                                  , tcdLName = cls, tcdTyVars = tyvars
                                  , tcdFixity = fixity
                                  , tcdFDs = snd (unLoc fds)
                                  , tcdSigs = mkClassOpSigs sigs
                                  , tcdMeths = binds
                                  , tcdATs = ats, tcdATDefs = at_defs
                                  , tcdDocs  = docs })) }
189 190 191

mkTyData :: SrcSpan
         -> NewOrData
192
         -> Maybe (Located CType)
193 194 195 196 197
         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
         -> Maybe (LHsKind GhcPs)
         -> [LConDecl GhcPs]
         -> HsDeriving GhcPs
         -> P (LTyClDecl GhcPs)
198
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
199
         ksig data_cons maybe_deriv
200
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
201
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
202
       ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
203
       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
204
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
205 206 207 208
       ; return (L loc (DataDecl { tcdDExt = noExtField,
                                   tcdLName = tc, tcdTyVars = tyvars,
                                   tcdFixity = fixity,
                                   tcdDataDefn = defn })) }
209

210
mkDataDefn :: NewOrData
211
           -> Maybe (Located CType)
212 213 214 215 216
           -> Maybe (LHsContext GhcPs)
           -> Maybe (LHsKind GhcPs)
           -> [LConDecl GhcPs]
           -> HsDeriving GhcPs
           -> P (HsDataDefn GhcPs)
217 218
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
  = do { checkDatatypeContext mcxt
219
       ; let cxt = fromMaybe (noLoc []) mcxt
220
       ; return (HsDataDefn { dd_ext = noExtField
221
                            , dd_ND = new_or_data, dd_cType = cType
rodlogic's avatar
rodlogic committed
222
                            , dd_ctxt = cxt
223 224 225
                            , dd_cons = data_cons
                            , dd_kindSig = ksig
                            , dd_derivs = maybe_deriv }) }
thomasw's avatar
thomasw committed
226

227

228
mkTySynonym :: SrcSpan
229 230 231
            -> LHsType GhcPs  -- LHS
            -> LHsType GhcPs  -- RHS
            -> P (LTyClDecl GhcPs)
232
mkTySynonym loc lhs rhs
233
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
234
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
235
       ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
236
       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
237 238 239 240
       ; return (L loc (SynDecl { tcdSExt = noExtField
                                , tcdLName = tc, tcdTyVars = tyvars
                                , tcdFixity = fixity
                                , tcdRhs = rhs })) }
241

242 243 244 245 246 247 248 249
mkStandaloneKindSig
  :: SrcSpan
  -> Located [Located RdrName] -- LHS
  -> LHsKind GhcPs             -- RHS
  -> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig loc lhs rhs =
  do { vs <- mapM check_lhs_name (unLoc lhs)
     ; v <- check_singular_lhs (reverse vs)
250
     ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
  where
    check_lhs_name v@(unLoc->name) =
      if isUnqual name && isTcOcc (rdrNameOcc name)
      then return v
      else addFatalError (getLoc v) $
           hang (text "Expected an unqualified type constructor:") 2 (ppr v)
    check_singular_lhs vs =
      case vs of
        [] -> panic "mkStandaloneKindSig: empty left-hand side"
        [v] -> return v
        _ -> addFatalError (getLoc lhs) $
             vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")
                       2 (pprWithCommas ppr vs)
                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]

266 267
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
               -> LHsType GhcPs
268 269
               -> LHsType GhcPs
               -> P (TyFamInstEqn GhcPs,[AddAnn])
270
mkTyFamInstEqn bndrs lhs rhs
271
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
272
       ; return (mkHsImplicitBndrs
273
                  (FamEqn { feqn_ext    = noExtField
274
                          , feqn_tycon  = tc
275
                          , feqn_bndrs  = bndrs
276 277 278
                          , feqn_pats   = tparams
                          , feqn_fixity = fixity
                          , feqn_rhs    = rhs }),
Alan Zimmerman's avatar
Alan Zimmerman committed
279
                 ann) }
280

281
mkDataFamInst :: SrcSpan
Jan Stolarek's avatar
Jan Stolarek committed
282 283
              -> NewOrData
              -> Maybe (Located CType)
284 285
              -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
                        , LHsType GhcPs)
286 287 288 289
              -> Maybe (LHsKind GhcPs)
              -> [LConDecl GhcPs]
              -> HsDeriving GhcPs
              -> P (LInstDecl GhcPs)
290
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
291
              ksig data_cons maybe_deriv
292
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
Vladislav Zavialov's avatar
Vladislav Zavialov committed
293
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
294
       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
295
       ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
296
                  (FamEqn { feqn_ext    = noExtField
297
                          , feqn_tycon  = tc
298
                          , feqn_bndrs  = bndrs
299
                          , feqn_pats   = tparams
300
                          , feqn_fixity = fixity
301
                          , feqn_rhs    = defn }))))) }
302

303
mkTyFamInst :: SrcSpan
304
            -> TyFamInstEqn GhcPs
305
            -> P (LInstDecl GhcPs)
306
mkTyFamInst loc eqn
307
  = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
308 309

mkFamDecl :: SrcSpan
310 311 312 313 314
          -> 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
315
mkFamDecl loc info lhs ksig injAnn
316
  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
317
       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
318
       ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
319
       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
320
       ; return (L loc (FamDecl noExtField (FamilyDecl
321
                                           { fdExt       = noExtField
322
                                           , fdInfo      = info, fdLName = tc
Jan Stolarek's avatar
Jan Stolarek committed
323
                                           , fdTyVars    = tyvars
324
                                           , fdFixity    = fixity
Jan Stolarek's avatar
Jan Stolarek committed
325 326
                                           , fdResultSig = ksig
                                           , fdInjectivityAnn = injAnn }))) }
327 328 329 330 331
  where
    equals_or_where = case info of
                        DataFamily          -> empty
                        OpenTypeFamily      -> empty
                        ClosedTypeFamily {} -> whereDots
332

333
mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
334
-- If the user wrote
335
--      [pads| ... ]   then return a QuasiQuoteD
336
--      $(e)           then return a SpliceD
337 338
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
339
--                     ie a SpliceD
340 341 342
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration.  See #10945
343
mkSpliceDecl lexpr@(L loc expr)
344
  | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
345
  = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
346

347
  | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
348
  = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
349 350

  | otherwise
351
  = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr))
352
                              ImplicitSplice)
353

354
mkRoleAnnotDecl :: SrcSpan
355
                -> Located RdrName                -- type being annotated
356
                -> [Located (Maybe FastString)]      -- roles
357
                -> P (LRoleAnnotDecl GhcPs)
358 359
mkRoleAnnotDecl loc tycon roles
  = do { roles' <- mapM parse_role roles
360
       ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' }
361 362 363 364 365
  where
    role_data_type = dataTypeOf (undefined :: Role)
    all_roles = map fromConstr $ dataTypeConstrs role_data_type
    possible_roles = [(fsFromRole role, role) | role <- all_roles]

366 367
    parse_role (L loc_role Nothing) = return $ L loc_role Nothing
    parse_role (L loc_role (Just role))
368
      = case lookup role possible_roles of
369
          Just found_role -> return $ L loc_role $ Just found_role
370
          Nothing         ->
371 372 373
            let nearby = fuzzyLookup (unpackFS role)
                  (mapFst unpackFS possible_roles)
            in
374
            addFatalError loc_role
375 376 377 378 379 380 381 382
              (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)
383

rodlogic's avatar
rodlogic committed
384 385 386
{- **********************************************************************

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

rodlogic's avatar
rodlogic committed
388 389 390 391 392
  ********************************************************************* -}

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


395
--  | Groups together bindings for a single function
396
cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
397
cvTopDecls decls = go (fromOL decls)
398
  where
399
    go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
400
    go []                     = []
401 402 403
    go ((L l (ValD x b)) : ds)
      = L l' (ValD x b') : go ds'
        where (L l' b', ds') = getMonoBind (L l b) ds
404
    go (d : ds)                    = d : go ds
405

406
-- Declaration list may only contain value bindings and signatures.
407
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
408
cvBindGroup binding
409 410
  = do { (mbs, sigs, fam_ds, tfam_insts
         , dfam_insts, _) <- cvBindsAndSigs binding
411
       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
412
         return $ ValBinds noExtField mbs sigs }
413

414 415 416
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
417
-- Input decls contain just value bindings and signatures
418
-- and in case of class or instance declarations also
419
-- associated type declarations. They might also contain Haddock comments.
420
cvBindsAndSigs fb = go (fromOL fb)
421
  where
422
    go []              = return (emptyBag, [], [], [], [], [])
423
    go ((L l (ValD _ b)) : ds)
424 425 426
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
           ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
      where
427 428
        (b', ds') = getMonoBind (L l b) ds
    go ((L l decl) : ds)
429 430
      = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
           ; case decl of
431
               SigD _ s
432
                 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
433
               TyClD _ (FamDecl _ t)
434
                 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
435
               InstD _ (TyFamInstD { tfid_inst = tfi })
436
                 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
437
               InstD _ (DataFamInstD { dfid_inst = dfi })
438
                 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
439
               DocD _ d
440
                 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
441
               SpliceD _ d
442
                 -> addFatalError l $
443 444 445 446
                    hang (text "Declaration splices are allowed only" <+>
                          text "at the top level:")
                       2 (ppr d)
               _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
447 448 449 450

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

451 452
getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
  -> (LHsBind GhcPs, [LHsDecl GhcPs])
453 454 455
-- 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
456 457 458 459 460

-- 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.
--
461
-- All Haddock comments between equations inside the group are
462 463
-- discarded.
--
464 465
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

466 467 468
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
                             , fun_matches =
                               MG { mg_alts = (L _ mtchs1) } }))
469
            binds
470
  | has_args mtchs1
471
  = go mtchs1 loc1 binds []
472
  where
473
    go mtchs loc
474 475 476
       ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
                                 , fun_matches =
                                    MG { mg_alts = (L _ mtchs2) } })))
477
         : binds) _
478
        | f1 == f2 = go (mtchs2 ++ mtchs)
479
                        (combineSrcSpans loc loc2) binds []
480
    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
481
        = let doc_decls' = doc_decl : doc_decls
482 483
          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go mtchs loc binds doc_decls
484
        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
485
          , (reverse doc_decls) ++ binds)
486
        -- Reverse the final matches, to get it back in the right order
487
        -- Do the same thing with the trailing doc comments
488

489 490
getMonoBind bind binds = (bind, binds)

491
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
492 493
has_args []                                  = panic "RdrHsSyn:has_args"
has_args (L _ (Match { m_pats = args }) : _) = not (null args)
494 495 496 497
        -- 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).
498
has_args (L _ (XMatch nec) : _) = noExtCon nec
499

rodlogic's avatar
rodlogic committed
500 501 502
{- **********************************************************************

  #PrefixToHS-utils# Utilities for conversion
503

rodlogic's avatar
rodlogic committed
504
  ********************************************************************* -}
505

Simon Peyton Jones's avatar
Simon Peyton Jones committed
506 507
{- Note [Parsing data constructors is hard]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563

The problem with parsing data constructors is that they look a lot like types.
Compare:

  (s1)   data T = C t1 t2
  (s2)   type T = C t1 t2

Syntactically, there's little difference between these declarations, except in
(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.

This similarity would pose no problem if we knew ahead of time if we are
parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple
(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing
data constructors, and in other contexts (e.g. 'type' declarations) assume we
are parsing type constructors.

This simple rule does not work because of two problematic cases:

  (p1)   data T = C t1 t2 :+ t3
  (p2)   data T = C t1 t2 => t3

In (p1) we encounter (:+) and it turns out we are parsing an infix data
declaration, so (C t1 t2) is a type and 'C' is a type constructor.
In (p2) we encounter (=>) and it turns out we are parsing an existential
context, so (C t1 t2) is a constraint and 'C' is a type constructor.

As the result, in order to determine whether (C t1 t2) declares a data
constructor, a type, or a context, we would need unlimited lookahead which
'happy' is not so happy with.

To further complicate matters, the interpretation of (!) and (~) is different
in constructors and types:

  (b1)   type T = C ! D
  (b2)   data T = C ! D
  (b3)   data T = C ! D => E

In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At
the same time, in (b2) it is a strictness annotation: 'C' is a data constructor
with a single strict argument 'D'. For the programmer, these cases are usually
easy to tell apart due to whitespace conventions:

  (b2)   data T = C !D         -- no space after the bang hints that
                               -- it is a strictness annotation

For the parser, on the other hand, this whitespace does not matter. We cannot
tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited
lookahead.

The solution that accounts for all of these issues is to initially parse data
declarations and types as a reversed list of TyEl:

  data TyEl = TyElOpr RdrName
            | TyElOpd (HsType GhcPs)
            | ...

564
For example, both occurrences of (C ! D) in the following example are parsed
565 566 567
into equal lists of TyEl:

  data T = C ! D => C ! D   results in   [ TyElOpd (HsTyVar "D")
568
                                         , TyElOpr "!"
569 570 571 572 573 574 575 576 577 578
                                         , TyElOpd (HsTyVar "C") ]

Note that elements are in reverse order. Also, 'C' is parsed as a type
constructor (HsTyVar) even when it is a data constructor. We fix this in
`tyConToDataCon`.

By the time the list of TyEl is assembled, we have looked ahead enough to
decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for
data constructors). These functions are where the actual job of parsing is
done.
579

Simon Peyton Jones's avatar
Simon Peyton Jones committed
580
-}
581

582 583
-- | Reinterpret a type constructor, including type operators, as a data
--   constructor.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
584
-- See Note [Parsing data constructors is hard]
585
tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
586
tyConToDataCon loc tc
587
  | isTcOcc occ || isDataOcc occ
Simon Peyton Jones's avatar
Simon Peyton Jones committed
588
  , isLexCon (occNameFS occ)
589
  = return (L loc (setRdrNameSpace tc srcDataName))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
590 591

  | otherwise
592
  = Left (loc, msg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
593 594 595
  where
    occ = rdrNameOcc tc
    msg = text "Not a data constructor:" <+> quotes (ppr tc)
596

597
mkPatSynMatchGroup :: Located RdrName
598 599
                   -> Located (OrdList (LHsDecl GhcPs))
                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
600
mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
601
    do { matches <- mapM fromDecl (fromOL decls)
602
       ; when (null matches) (wrongNumberErr loc)
603 604
       ; return $ mkMatchGroup FromSource matches }
  where
605 606 607
    fromDecl (L loc decl@(ValD _ (PatBind _
                         pat@(L _ (ConPatIn ln@(L _ name) details))
                               rhs _))) =
608 609 610
        do { unless (name == patsyn_name) $
               wrongNameBindingErr loc decl
           ; match <- case details of
611
               PrefixCon pats -> return $ Match { m_ext = noExtField
612
                                                , m_ctxt = ctxt, m_pats = pats
613
                                                , m_grhss = rhs }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
614
                   where
615 616 617
                     ctxt = FunRhs { mc_fun = ln
                                   , mc_fixity = Prefix
                                   , mc_strictness = NoSrcStrict }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
618

619
               InfixCon p1 p2 -> return $ Match { m_ext = noExtField
620 621
                                                , m_ctxt = ctxt
                                                , m_pats = [p1, p2]
622
                                                , m_grhss = rhs }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
623
                   where
624 625 626
                     ctxt = FunRhs { mc_fun = ln
                                   , mc_fixity = Infix
                                   , mc_strictness = NoSrcStrict }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
627

628
               RecCon{} -> recordPatSynErr loc pat
629 630
           ; return $ L loc match }
    fromDecl (L loc decl) = extraDeclErr loc decl
631 632

    extraDeclErr loc decl =
633
        addFatalError loc $
634 635 636 637
        text "pattern synonym 'where' clause must contain a single binding:" $$
        ppr decl

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

642
    wrongNumberErr loc =
643
      addFatalError loc $
644
      text "pattern synonym 'where' clause cannot be empty" $$
645 646
      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)

647
recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
648
recordPatSynErr loc pat =
649
    addFatalError loc $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
650 651 652
    text "record syntax not supported for pattern synonym declarations:" $$
    ppr pat

653
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
654
                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
655
                -> ConDecl GhcPs
656

657
mkConDeclH98 name mb_forall mb_cxt args
658
  = ConDeclH98 { con_ext    = noExtField
659
               , con_name   = name
660
               , con_forall = noLoc $ isJust mb_forall
661 662
               , con_ex_tvs = mb_forall `orElse` []
               , con_mb_cxt = mb_cxt
663
               , con_args   = args
664
               , con_doc    = Nothing }
665

666
mkGadtDecl :: [Located RdrName]
667
           -> LHsType GhcPs     -- Always a HsForAllTy
668
           -> (ConDecl GhcPs, [AddAnn])
669
mkGadtDecl names ty
670
  = (ConDeclGADT { con_g_ext  = noExtField
671
                 , con_names  = names
672
                 , con_forall = L l $ isLHsForAllTy ty'
673 674
                 , con_qvars  = mkHsQTvs tvs
                 , con_mb_cxt = mcxt
675
                 , con_args   = args
676 677
                 , con_res_ty = res_ty
                 , con_doc    = Nothing }
678
    , anns1 ++ anns2)
679
  where
680
    (ty'@(L l _),anns1) = peel_parens ty []
Ryan Scott's avatar
Ryan Scott committed
681
    (tvs, rho) = splitLHsForAllTyInvis ty'
682
    (mcxt, tau, anns2) = split_rho rho []
683

684
    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
685
      = (Just cxt, tau, ann)
686
    split_rho (L l (HsParTy _ ty)) ann
687 688 689
      = split_rho ty (ann++mkParensApiAnn l)
    split_rho tau                  ann
      = (Nothing, tau, ann)
690

691
    (args, res_ty) = split_tau tau
692

Sylvain Henry's avatar
Sylvain Henry committed
693
    -- See Note [GADT abstract syntax] in GHC.Hs.Decls
694 695
    split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
      = (RecCon (L loc rf), res_ty)
696 697
    split_tau tau
      = (PrefixCon [], tau)
698

699
    peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
700 701
                                                       (ann++mkParensApiAnn l)
    peel_parens ty                   ann = (ty, ann)
702

703

704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775
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))

776 777 778 779 780 781 782
-- | Replaces constraint tuple names with corresponding boxed ones.
filterCTuple :: RdrName -> RdrName
filterCTuple (Exact n)
  | Just arity <- cTupleTyConNameArity_maybe n
  = Exact $ tupleTyConName BoxedTuple arity
filterCTuple rdr = rdr

783 784 785 786 787 788 789 790 791 792 793 794 795

{- 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!
-}

796 797
eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
798
eitherToP (Left (loc, doc)) = addFatalError loc doc
799
eitherToP (Right thing)     = return thing
800

My Nguyen's avatar
My Nguyen committed
801
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
802 803
            -> P ( LHsQTyVars GhcPs  -- the synthesized type variables
                 , [AddAnn] )        -- action which adds annotations
804 805
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
rodlogic's avatar
rodlogic committed
806
checkTyVars pp_what equals_or_where tc tparms
My Nguyen's avatar