summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.hs24
-rw-r--r--compiler/hsSyn/HsDecls.hs9
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot12
-rw-r--r--compiler/hsSyn/HsPat.hs-boot8
-rw-r--r--compiler/hsSyn/HsTypes.hs9
5 files changed, 33 insertions, 29 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index da7fcdeae1..4a0e013cf9 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -473,16 +473,25 @@ noExistentials = []
cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
+ -- the prim and javascript calling conventions do not support headers
+ -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
+ | callconv == TH.Prim || callconv == TH.JavaScript
+ = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
+ (CFunction (StaticTarget from (mkFastString from) Nothing
+ True))
+ (noLoc from))
| Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
(mkFastString (TH.nameBase nm))
from (noLoc from)
- = do { nm' <- vNameL nm
- ; ty' <- cvtType ty
- ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
- }
+ = mk_imp impspec
| otherwise
= failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
where
+ mk_imp impspec
+ = do { nm' <- vNameL nm
+ ; ty' <- cvtType ty
+ ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
+ }
safety' = case safety of
Unsafe -> PlayRisky
Safe -> PlaySafe
@@ -880,6 +889,7 @@ cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w }
cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar (show c) c }
+cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
; return $ HsString s s' }
@@ -1029,6 +1039,12 @@ cvtTypeKind ty_str ty
LitT lit
-> returnL (HsTyLit (cvtTyLit lit))
+ WildCardT Nothing
+ -> mk_apps mkAnonWildCardTy tys'
+
+ WildCardT (Just nm)
+ -> do { nm' <- tName nm; mk_apps (mkNamedWildCardTy nm') tys' }
+
PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' }
-- Promoted data constructor; hence cName
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 9233f4fde1..79b0deeb16 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -981,16 +981,17 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
- , con_res = ResTyGADT _ res_ty })
- = ppr_con_names cons <+> dcolon <+>
+ , con_res = ResTyGADT _ res_ty, con_doc = doc })
+ = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+>
sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
where
mk_fun_ty a b = noLoc (HsFunTy a b)
pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = RecCon fields
- , con_res = ResTyGADT _ res_ty })
- = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt,
+ , con_res = ResTyGADT _ res_ty, con_doc = doc })
+ = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
+ <+> pprHsForAll expl tvs cxt,
pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty]
pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index 4b9f968ebf..eb9d23a9ed 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -3,9 +3,7 @@
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
-#if __GLASGOW_HASKELL__ > 706
{-# LANGUAGE RoleAnnotations #-}
-#endif
module HsExpr where
@@ -15,31 +13,21 @@ import {-# SOURCE #-} HsPat ( LPat )
import PlaceHolder ( DataId )
import Data.Data hiding ( Fixity )
-#if __GLASGOW_HASKELL__ > 706
type role HsExpr nominal
type role HsCmd nominal
type role MatchGroup nominal representational
type role GRHSs nominal representational
type role HsSplice nominal
-#endif
data HsExpr (i :: *)
data HsCmd (i :: *)
data HsSplice (i :: *)
data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
-#if __GLASGOW_HASKELL__ > 706
instance Typeable HsSplice
instance Typeable HsExpr
instance Typeable MatchGroup
instance Typeable GRHSs
-#else
-instance Typeable1 HsSplice
-instance Typeable1 HsExpr
-instance Typeable1 HsCmd
-instance Typeable2 MatchGroup
-instance Typeable2 GRHSs
-#endif
instance (DataId id) => Data (HsSplice id)
instance (DataId id) => Data (HsExpr id)
diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot
index 114425b526..c6ab5a5b35 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -3,9 +3,7 @@
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
-#if __GLASGOW_HASKELL__ > 706
{-# LANGUAGE RoleAnnotations #-}
-#endif
module HsPat where
import SrcLoc( Located )
@@ -14,17 +12,11 @@ import Data.Data hiding (Fixity)
import Outputable
import PlaceHolder ( DataId )
-#if __GLASGOW_HASKELL__ > 706
type role Pat nominal
-#endif
data Pat (i :: *)
type LPat i = Located (Pat i)
-#if __GLASGOW_HASKELL__ > 706
instance Typeable Pat
-#else
-instance Typeable1 Pat
-#endif
instance (DataId id) => Data (Pat id)
instance (OutputableBndr name) => Outputable (Pat name)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 9b8639369c..9526a8cce3 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -34,7 +34,8 @@ module HsTypes (
ConDeclField(..), LConDeclField, pprConDeclFields,
HsWildCardInfo(..), mkAnonWildCardTy, mkNamedWildCardTy,
- wildCardName, sameWildCard, isAnonWildCard, isNamedWildCard,
+ wildCardName, sameWildCard, sameNamedWildCard,
+ isAnonWildCard, isNamedWildCard,
mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
@@ -682,6 +683,12 @@ sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2
sameWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2
sameWildCard _ _ = False
+sameNamedWildCard :: Eq name
+ => Located (HsWildCardInfo name)
+ -> Located (HsWildCardInfo name) -> Bool
+sameNamedWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2
+sameNamedWildCard _ _ = False
+
splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as
View Lorry Controller Status