summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.lhs25
-rw-r--r--compiler/hsSyn/HsDecls.lhs127
-rw-r--r--compiler/hsSyn/HsDoc.hs2
-rw-r--r--compiler/hsSyn/HsExpr.lhs24
-rw-r--r--compiler/hsSyn/HsLit.lhs4
-rw-r--r--compiler/hsSyn/HsPat.lhs31
-rw-r--r--compiler/hsSyn/HsSyn.lhs12
-rw-r--r--compiler/hsSyn/HsTypes.lhs116
-rw-r--r--compiler/hsSyn/HsUtils.lhs7
9 files changed, 200 insertions, 148 deletions
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index bcea29bea2..e22af3b947 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -6,6 +6,8 @@
This module converts Template Haskell syntax into HsSyn
\begin{code}
+{-# LANGUAGE MagicHash #-}
+
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType,
thRdrNameGuesses ) where
@@ -199,13 +201,20 @@ cvtDec (ClassD ctxt cl tvs fds decs)
; unless (null adts')
(failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
$$ (Outputable.ppr adts'))
+ ; at_defs <- mapM cvt_at_def ats'
; returnL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
- , tcdATs = fams', tcdATDefs = ats', tcdDocs = []
+ , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
, tcdFVs = placeHolderNames }
-- no docs in TH ^^
}
+ where
+ cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)
+ -- Very similar to what happens in RdrHsSyn.mkClassDecl
+ cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
+ Right def -> return def
+ Left (_, msg) -> failWith msg
cvtDec (InstanceD ctxt ty decs)
= do { let doc = ptext (sLit "an instance declaration")
@@ -214,7 +223,7 @@ cvtDec (InstanceD ctxt ty decs)
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
- ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) }
+ ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing)) }
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
@@ -278,9 +287,9 @@ cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
= do { lhs' <- mapM cvtType lhs
; rhs' <- cvtType rhs
- ; returnL $ TyFamInstEqn { tfie_tycon = tc
- , tfie_pats = mkHsWithBndrs lhs'
- , tfie_rhs = rhs' } }
+ ; returnL $ TyFamEqn { tfe_tycon = tc
+ , tfe_pats = mkHsWithBndrs lhs'
+ , tfe_rhs = rhs' } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
@@ -828,8 +837,8 @@ cvtp (TH.LitP l)
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
-cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
-cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
+cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
+cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
@@ -1156,7 +1165,7 @@ Consider this TH term construction:
; x3 <- TH.newName "x"
; let x = mkName "x" -- mkName :: String -> TH.Name
- -- Builds a NameL
+ -- Builds a NameS
; return (LamE (..pattern [x1,x2]..) $
LamE (VarPat x3) $
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index bae804eb07..845c05296c 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -29,7 +29,7 @@ module HsDecls (
InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
- TyFamInstEqn(..), LTyFamInstEqn,
+ TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
@@ -472,7 +472,7 @@ data TyClDecl name
tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods
tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie
- tcdATDefs :: [LTyFamInstDecl name], -- ^ Associated type defaults
+ tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults
tcdDocs :: [LDocDecl], -- ^ Haddock docs
tcdFVs :: NameSet
}
@@ -573,7 +573,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: OutputableBndr name
=> TyFamInstDecl name -> Located name
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
- (L _ (TyFamInstEqn { tfie_tycon = ln })) })
+ (L _ (TyFamEqn { tfe_tycon = ln })) })
= ln
tyClDeclLName :: TyClDecl name -> Located name
@@ -632,7 +632,7 @@ instance OutputableBndr name
| otherwise -- Laid out
= vcat [ top_matter <+> ptext (sLit "where")
, nest 2 $ pprDeclList (map ppr ats ++
- map ppr at_defs ++
+ map ppr_fam_deflt_eqn at_defs ++
pprLHsBindsForUser methods sigs) ]
where
top_matter = ptext (sLit "class")
@@ -657,7 +657,7 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where
ClosedTypeFamily eqns -> ( ptext (sLit "where")
, if null eqns
then ptext (sLit "..")
- else vcat $ map ppr eqns )
+ else vcat $ map ppr_fam_inst_eqn eqns )
_ -> (empty, empty)
pprFlavour :: FamilyInfo name -> SDoc
@@ -678,7 +678,7 @@ pp_vanilla_decl_head thing tyvars context
pp_fam_inst_lhs :: OutputableBndr name
=> Located name
- -> HsWithBndrs [LHsType name]
+ -> HsTyPats name
-> HsContext name
-> SDoc
pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
@@ -686,12 +686,13 @@ pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patt
, hsep (map (pprParendHsType.unLoc) typats)]
pprTyClDeclFlavour :: TyClDecl a -> SDoc
-pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class")
-pprTyClDeclFlavour (FamDecl {}) = ptext (sLit "family")
-pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type")
-pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) })
- = ppr nd
+pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class")
+pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type")
pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
+pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
+ = pprFlavour info
+pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
+ = ppr nd
\end{code}
%************************************************************************
@@ -893,25 +894,49 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
%* *
%************************************************************************
+Note [Type family instance declarations in HsSyn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The data type TyFamEqn represents one equation of a type family instance.
+It is parameterised over its tfe_pats field:
+
+ * An ordinary type family instance declaration looks like this in source Haskell
+ type instance T [a] Int = a -> a
+ (or something similar for a closed family)
+ It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
+
+ * On the other hand, the *default instance* of an associated type looksl like
+ this in source Haskell
+ class C a where
+ type T a b
+ type T a b = a -> b -- The default instance
+ It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field.
+
\begin{code}
----------------- Type synonym family instances -------------
+type LTyFamInstEqn name = Located (TyFamInstEqn name)
+type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
-type LTyFamInstEqn name = Located (TyFamInstEqn name)
-
--- | One equation in a type family instance declaration
-data TyFamInstEqn name
- = TyFamInstEqn
- { tfie_tycon :: Located name
- , tfie_pats :: HsWithBndrs [LHsType name]
+type HsTyPats name = HsWithBndrs [LHsType name]
-- ^ Type patterns (with kind and type bndrs)
-- See Note [Family instance declaration binders]
- , tfie_rhs :: LHsType name }
+
+type TyFamInstEqn name = TyFamEqn name (HsTyPats name)
+type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name)
+ -- See Note [Type family instance declarations in HsSyn]
+
+-- | One equation in a type family instance declaration
+-- See Note [Type family instance declarations in HsSyn]
+data TyFamEqn name pats
+ = TyFamEqn
+ { tfe_tycon :: Located name
+ , tfe_pats :: pats
+ , tfe_rhs :: LHsType name }
deriving( Typeable, Data )
type LTyFamInstDecl name = Located (TyFamInstDecl name)
-data TyFamInstDecl name
+data TyFamInstDecl name
= TyFamInstDecl
- { tfid_eqn :: LTyFamInstEqn name
+ { tfid_eqn :: LTyFamInstEqn name
, tfid_fvs :: NameSet }
deriving( Typeable, Data )
@@ -921,11 +946,9 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name)
data DataFamInstDecl name
= DataFamInstDecl
{ dfid_tycon :: Located name
- , dfid_pats :: HsWithBndrs [LHsType name] -- lhs
- -- ^ Type patterns (with kind and type bndrs)
- -- See Note [Family instance declaration binders]
- , dfid_defn :: HsDataDefn name -- rhs
- , dfid_fvs :: NameSet } -- free vars for dependency analysis
+ , dfid_pats :: HsTyPats name -- LHS
+ , dfid_defn :: HsDataDefn name -- RHS
+ , dfid_fvs :: NameSet } -- Rree vars for dependency analysis
deriving( Typeable, Data )
@@ -937,10 +960,11 @@ data ClsInstDecl name
{ cid_poly_ty :: LHsType name -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
- , cid_binds :: LHsBinds name
- , cid_sigs :: [LSig name] -- User-supplied pragmatic info
- , cid_tyfam_insts :: [LTyFamInstDecl name] -- type family instances
- , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances
+ , cid_binds :: LHsBinds name -- Class methods
+ , cid_sigs :: [LSig name] -- User-supplied pragmatic info
+ , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances
+ , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances
+ , cid_overlap_mode :: Maybe OverlapMode
}
deriving (Data, Typeable)
@@ -983,17 +1007,23 @@ instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
- = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn)
+ = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = ptext (sLit "instance")
ppr_instance_keyword NotTopLevel = empty
-instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where
- ppr (TyFamInstEqn { tfie_tycon = tycon
- , tfie_pats = pats
- , tfie_rhs = rhs })
- = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs)
+ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc
+ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
+ , tfe_pats = pats
+ , tfe_rhs = rhs }))
+ = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs
+
+ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc
+ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
+ , tfe_pats = tvs
+ , tfe_rhs = rhs }))
+ = pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs
instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where
ppr = pprDataFamInstDecl TopLevel
@@ -1013,6 +1043,7 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd })
instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
+ , cid_overlap_mode = mbOverlap
, cid_datafam_insts = adts })
| null sigs, null ats, null adts, isEmptyBag binds -- No "where" part
= top_matter
@@ -1024,7 +1055,19 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
pprLHsBindsForUser binds sigs ]
where
- top_matter = ptext (sLit "instance") <+> ppr inst_ty
+ top_matter = ptext (sLit "instance") <+> ppOveralapPragma mbOverlap
+ <+> ppr inst_ty
+
+ppOveralapPragma :: Maybe OverlapMode -> SDoc
+ppOveralapPragma mb =
+ case mb of
+ Nothing -> empty
+ Just NoOverlap -> ptext (sLit "{-# NO_OVERLAP #-}")
+ Just OverlapOk -> ptext (sLit "{-# OVERLAP #-}")
+ Just Incoherent -> ptext (sLit "{-# INCOHERENT #-}")
+
+
+
instance (OutputableBndr name) => Outputable (InstDecl name) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
@@ -1052,12 +1095,14 @@ instDeclDataFamInsts inst_decls
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
-data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
+data DerivDecl name = DerivDecl { deriv_type :: LHsType name
+ , deriv_overlap_mode :: Maybe OverlapMode
+ }
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
- ppr (DerivDecl ty)
- = hsep [ptext (sLit "deriving instance"), ppr ty]
+ ppr (DerivDecl ty o)
+ = hsep [ptext (sLit "deriving instance"), ppOveralapPragma o, ppr ty]
\end{code}
%************************************************************************
@@ -1236,7 +1281,7 @@ instance OutputableBndr name => Outputable (RuleDecl name) where
nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
where
pp_forall | null ns = empty
- | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
+ | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
instance OutputableBndr name => Outputable (RuleBndr name) where
ppr (RuleBndr name) = ppr name
diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs
index 2cb28540f9..72bf0e56a4 100644
--- a/compiler/hsSyn/HsDoc.hs
+++ b/compiler/hsSyn/HsDoc.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
module HsDoc (
HsDocString(..),
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index f5ba1903ee..69b6df64ec 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -3,7 +3,7 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
-- | Abstract Haskell syntax for expressions.
module HsExpr where
@@ -79,8 +79,6 @@ noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr"))
type CmdSyntaxTable id = [(Name, SyntaxExpr id)]
-- See Note [CmdSyntaxTable]
-noSyntaxTable :: CmdSyntaxTable id
-noSyntaxTable = []
\end{code}
Note [CmdSyntaxtable]
@@ -88,7 +86,7 @@ Note [CmdSyntaxtable]
Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps
track of the methods needed for a Cmd.
-* Before the renamer, this list is 'noSyntaxTable'
+* Before the renamer, this list is an empty list
* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@
For example, for the 'arr' method
@@ -630,13 +628,13 @@ ppr_expr (HsTickPragma externalSrcLoc exp)
ptext (sLit ")")]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
- = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
+ = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
- = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
+ = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
- = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
+ = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
- = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
+ = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
@@ -849,13 +847,13 @@ ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
, ptext (sLit "|>") <+> ppr co ]
ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
- = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
+ = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
- = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
+ = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
- = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
+ = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
- = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
+ = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
@@ -1300,7 +1298,7 @@ instance (OutputableBndr idL, OutputableBndr idR, Outputable body)
pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> (StmtLR idL idR body) -> SDoc
pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr
-pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
+pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
pprStmt (BodyStmt expr _ _ _) = ppr expr
pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss))
diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index 9565acbc8f..a4749dd730 100644
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -5,14 +5,14 @@
\section[HsLit]{Abstract syntax: source-language literals}
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
module HsLit where
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index ef888fe5a8..4b8fcdaae7 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -75,10 +75,13 @@ data Pat id
-- overall type of the pattern, and the toList
-- function to convert the scrutinee to a list value
- | TuplePat [LPat id] -- Tuple
- Boxity -- UnitPat is TuplePat []
- PostTcType
- -- You might think that the PostTcType was redundant, but it's essential
+ | TuplePat [LPat id] -- Tuple sub-patterns
+ Boxity -- UnitPat is TuplePat []
+ [PostTcType] -- [] before typechecker, filled in afterwards with
+ -- the types of the tuple components
+ -- You might think that the PostTcType was redundant, because we can
+ -- get the pattern type by getting the types of the sub-patterns.
+ -- But it's essential
-- data T a where
-- T1 :: Int -> T Int
-- f :: (T a, a) -> Int
@@ -89,6 +92,8 @@ data Pat id
-- Note the (w::a), NOT (w::Int), because we have not yet
-- refined 'a' to Int. So we must know that the second component
-- of the tuple is of type 'a' not Int. See selectMatchVar
+ -- (June 14: I'm not sure this comment is right; the sub-patterns
+ -- will be wrapped in CoPats, no?)
| PArrPat [LPat id] -- Syntactic parallel array
PostTcType -- The type of the elements
@@ -98,14 +103,18 @@ data Pat id
(HsConPatDetails id)
| ConPatOut {
- pat_con :: Located ConLike,
+ pat_con :: Located ConLike,
+ pat_arg_tys :: [Type], -- The univeral arg types, 1-1 with the universal
+ -- tyvars of the constructor/pattern synonym
+ -- Use (conLikeResTy pat_con pat_arg_tys) to get
+ -- the type of the pattern
+
pat_tvs :: [TyVar], -- Existentially bound type variables (tyvars only)
pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries*
-- One reason for putting coercion variable here, I think,
-- is to ensure their kinds are zonked
pat_binds :: TcEvBinds, -- Bindings involving those dictionaries
pat_args :: HsConPatDetails id,
- pat_ty :: Type, -- The type of the pattern
pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher
}
@@ -313,18 +322,18 @@ instance (OutputableBndr id, Outputable arg)
%************************************************************************
\begin{code}
-mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
+mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
-- Make a vanilla Prefix constructor pattern
-mkPrefixConPat dc pats ty
+mkPrefixConPat dc pats tys
= noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
- pat_ty = ty, pat_wrap = idHsWrapper }
+ pat_arg_tys = tys, pat_wrap = idHsWrapper }
mkNilPat :: Type -> OutPat id
-mkNilPat ty = mkPrefixConPat nilDataCon [] ty
+mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
mkCharLitPat :: Char -> OutPat id
-mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
+mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] []
\end{code}
diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs
index e9c3a5eeee..72cbac1487 100644
--- a/compiler/hsSyn/HsSyn.lhs
+++ b/compiler/hsSyn/HsSyn.lhs
@@ -23,7 +23,7 @@ module HsSyn (
module HsDoc,
Fixity,
- HsModule(..), HsExtCore(..),
+ HsModule(..)
) where
-- friends:
@@ -40,10 +40,9 @@ import HsDoc
-- others:
import OccName ( HasOccName )
-import IfaceSyn ( IfaceBinding )
import Outputable
import SrcLoc
-import Module ( Module, ModuleName )
+import Module ( ModuleName )
import FastString
-- libraries:
@@ -77,13 +76,6 @@ data HsModule name
hsmodHaddockModHeader :: Maybe LHsDocString
-- ^ Haddock module info and description, unparsed
} deriving (Data, Typeable)
-
-data HsExtCore name -- Read from Foo.hcr
- = HsExtCore
- Module
- [TyClDecl name] -- Type declarations only; just as in Haskell source,
- -- so that we can infer kinds etc
- [IfaceBinding] -- And the bindings
\end{code}
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 28c6a2b89c..08a0eef498 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -35,7 +35,7 @@ module HsTypes (
splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
-- Printing
- pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ppr_hs_context,
+ pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow,
) where
import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
@@ -45,6 +45,7 @@ import HsLit
import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..) )
+import TysPrim( funTyConName )
import Type
import HsDoc
import BasicTypes
@@ -162,7 +163,7 @@ mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs"
, hswb_tvs = panic "mkHsTyWithBndrs:tvs" }
--- | These names are used eary on to store the names of implicit
+-- | These names are used early on to store the names of implicit
-- parameters. They completely disappear after type-checking.
newtype HsIPName = HsIPName FastString-- ?x
deriving( Eq, Data, Typeable )
@@ -506,15 +507,31 @@ splitLHsClassTy_maybe ty
HsKindSig ty _ -> checkl ty args
_ -> Nothing
--- Splits HsType into the (init, last) parts
+-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
-- Breaks up any parens in the result type:
-- splitHsFunType (a -> (b -> c)) = ([a,b], c)
-splitHsFunType :: LHsType name -> ([LHsType name], LHsType name)
-splitHsFunType (L _ (HsFunTy x y)) = (x:args, res)
- where
- (args, res) = splitHsFunType y
-splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty
-splitHsFunType other = ([], other)
+-- Also deals with (->) t1 t2; that is why it only works on LHsType Name
+-- (see Trac #9096)
+splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name)
+splitHsFunType (L _ (HsParTy ty))
+ = splitHsFunType ty
+
+splitHsFunType (L _ (HsFunTy x y))
+ | (args, res) <- splitHsFunType y
+ = (x:args, res)
+
+splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
+ = go t1 [t2]
+ where -- Look for (->) t1 t2, possibly with parenthesisation
+ go (L _ (HsTyVar fn)) tys | fn == funTyConName
+ , [t1,t2] <- tys
+ , (args, res) <- splitHsFunType t2
+ = (t1:args, res)
+ go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
+ go (L _ (HsParTy ty)) tys = go ty tys
+ go _ _ = ([], orig_ty) -- Failure to match
+
+splitHsFunType other = ([], other)
\end{code}
@@ -550,7 +567,7 @@ pprHsForAll exp qtvs cxt
show_forall = opt_PprStyle_Debug
|| (not (null (hsQTvBndrs qtvs)) && is_explicit)
is_explicit = case exp of {Explicit -> True; Implicit -> False}
- forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot
+ forall_part = forAllLit <+> ppr qtvs <> dot
pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContext [] = empty
@@ -558,12 +575,8 @@ pprHsContext cxt = pprHsContextNoArrow cxt <+> darrow
pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContextNoArrow [] = empty
-pprHsContextNoArrow [L _ pred] = ppr pred
-pprHsContextNoArrow cxt = ppr_hs_context cxt
-
-ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc
-ppr_hs_context [] = empty
-ppr_hs_context cxt = parens (interpp'SP cxt)
+pprHsContextNoArrow [L _ pred] = ppr_mono_ty FunPrec pred
+pprHsContextNoArrow cxt = parens (interpp'SP cxt)
pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
@@ -585,27 +598,12 @@ and the problem doesn't show up; but having the flag on a KindedTyVar
seems like the Right Thing anyway.)
\begin{code}
-pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
-pREC_TOP = 0 -- type in ParseIface.y
-pREC_FUN = 1 -- btype in ParseIface.y
- -- Used for LH arg of (->)
-pREC_OP = 2 -- Used for arg of any infix operator
- -- (we don't keep their fixities around)
-pREC_CON = 3 -- Used for arg of type applicn:
- -- always parenthesise unless atomic
-
-maybeParen :: Int -- Precedence of context
- -> Int -- Precedence of top-level operator
- -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op)
-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
- | otherwise = p
-
--- printing works more-or-less as for Types
+-- Printing works more-or-less as for Types
pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
-pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty pREC_TOP (prepare sty ty)
-pprParendHsType ty = ppr_mono_ty pREC_CON ty
+pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty)
+pprParendHsType ty = ppr_mono_ty TyConPrec ty
-- Before printing a type
-- (a) Remove outermost HsParTy parens
@@ -615,15 +613,15 @@ prepare :: PprStyle -> HsType name -> HsType name
prepare sty (HsParTy ty) = prepare sty (unLoc ty)
prepare _ ty = ty
-ppr_mono_lty :: (OutputableBndr name) => Int -> LHsType name -> SDoc
+ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
-ppr_mono_ty :: (OutputableBndr name) => Int -> HsType name -> SDoc
+ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc
ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
- = maybeParen ctxt_prec pREC_FUN $
- sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
+ = maybeParen ctxt_prec FunPrec $
+ sep [pprHsForAll exp tvs ctxt, ppr_mono_lty TopPrec ty]
-ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty pREC_CON ty
+ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty
ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name
@@ -632,10 +630,10 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
-ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
-ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
-ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty)
-ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind)
+ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty)
+ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty)
+ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)
ppr_mono_ty _ (HsSpliceTy s _) = pprUntypedSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
@@ -651,45 +649,45 @@ ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
where
go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty
go ctxt_prec (ki:kis) ty
- = maybeParen ctxt_prec pREC_CON $
- hsep [ go pREC_FUN kis ty
+ = maybeParen ctxt_prec TyConPrec $
+ hsep [ go FunPrec kis ty
, ptext (sLit "@") <> pprParendKind ki ]
-}
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
- = maybeParen ctxt_prec pREC_OP $
- ppr_mono_lty pREC_OP ty1 <+> char '~' <+> ppr_mono_lty pREC_OP ty2
+ = maybeParen ctxt_prec TyOpPrec $
+ ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
- = maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
+ = maybeParen ctxt_prec TyConPrec $
+ hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]
ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2)
- = maybeParen ctxt_prec pREC_OP $
- sep [ ppr_mono_lty pREC_OP ty1
- , sep [pprInfixOcc op, ppr_mono_lty pREC_OP ty2 ] ]
+ = maybeParen ctxt_prec TyOpPrec $
+ sep [ ppr_mono_lty TyOpPrec ty1
+ , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ]
-- Don't print the wrapper (= kind applications)
-- c.f. HsWrapTy
ppr_mono_ty _ (HsParTy ty)
- = parens (ppr_mono_lty pREC_TOP ty)
+ = parens (ppr_mono_lty TopPrec ty)
-- Put the parens in where the user did
-- But we still use the precedence stuff to add parens because
-- toHsType doesn't put in any HsParTys, so we may still need them
ppr_mono_ty ctxt_prec (HsDocTy ty doc)
- = maybeParen ctxt_prec pREC_OP $
- ppr_mono_lty pREC_OP ty <+> ppr (unLoc doc)
+ = maybeParen ctxt_prec TyOpPrec $
+ ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc)
-- we pretty print Haddock comments on types as if they were
-- postfix operators
--------------------------
-ppr_fun_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc
+ppr_fun_ty :: (OutputableBndr name) => TyPrec -> LHsType name -> LHsType name -> SDoc
ppr_fun_ty ctxt_prec ty1 ty2
- = let p1 = ppr_mono_lty pREC_FUN ty1
- p2 = ppr_mono_lty pREC_TOP ty2
+ = let p1 = ppr_mono_lty FunPrec ty1
+ p2 = ppr_mono_lty TopPrec ty2
in
- maybeParen ctxt_prec pREC_FUN $
+ maybeParen ctxt_prec FunPrec $
sep [p1, ptext (sLit "->") <+> p2]
--------------------------
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index eff67df3cf..42838ef93f 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -4,7 +4,7 @@
Here we collect a variety of helper functions that construct or
analyse HsSyn. All these functions deal with generic HsSyn; functions
-which deal with the intantiated versions are located elsewhere:
+which deal with the instantiated versions are located elsewhere:
Parameterised by Module
---------------- -------------
@@ -13,7 +13,8 @@ which deal with the intantiated versions are located elsewhere:
Id typecheck/TcHsSyn
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
@@ -382,7 +383,7 @@ mkLHsVarTuple :: [a] -> LHsExpr a
mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+nlTuplePat pats box = noLoc (TuplePat pats box [])
missingTupArg :: HsTupArg a
missingTupArg = Missing placeHolderType
View Lorry Controller Status