hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Adapt to ghc-8.8 (deps are not ready though)

remotes/felixonmars/release
Lennart Spitzner 2019-08-31 23:19:59 +02:00
parent c97f6dd559
commit 91d6e18aba
10 changed files with 155 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
brittany.cabal
View File

@ -84,10 +84,10 @@ library {
-fno-warn-redundant-constraints
}
build-depends:
{ base >=4.9 && <4.13
, ghc >=8.0.1 && <8.7
{ base >=4.9 && <4.14
, ghc >=8.0.1 && <8.9
, ghc-paths >=0.1.0.9 && <0.2
, ghc-exactprint >=0.5.8 && <0.6.2
, ghc-exactprint >=0.5.8 && <0.6.3
, transformers >=0.5.2.0 && <0.6
, containers >=0.5.7.1 && <0.7
, mtl >=2.2.1 && <2.3
@ -112,7 +112,7 @@ library {
, semigroups >=0.18.2 && <0.19
, cmdargs >=0.10.14 && <0.11
, czipwith >=1.0.1.0 && <1.1
, ghc-boot-th >=8.0.1 && <8.7
, ghc-boot-th >=8.0.1 && <8.9
, filepath >=1.4.1.0 && <1.5
, random >= 1.1 && <1.2
}

2
src-literatetests/10-tests.blt
View File

@ -1220,6 +1220,7 @@ type instance MyFam Bool = String
type instance MyFam (Maybe a) = a -> Bool
#test simple-typefam-instance-parens
#pending the parens cause problems since ghc-8.8
type instance (MyFam (String -> Int)) = String
@ -1237,6 +1238,7 @@ type instance MyFam Bool -- This is an odd one
= AnotherType -- Here's another
#test simple-typefam-instance-parens-comment
#pending the parens cause problems since ghc-8.8
-- | A happy family
type instance (MyFam Bool) -- This is an odd one

2
src-literatetests/15-regressions.blt
View File

@ -607,7 +607,7 @@ go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2
go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2
#test issue 89 - type-family-instance
type instance (XPure StageParse) = ()
type instance XPure StageParse = ()
type Pair a = (a, a)
#test issue 144

10
src/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -173,14 +173,10 @@ layoutBriDocM = \case
-- layoutResetSepSpace
priors
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
do
when (not $ comment == "(" || comment == ")") $ do
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
-- ^ evil hack for CPP
"(" -> pure ()
")" -> pure ()
-- ^ these two fix the formatting of parens
-- on the lhs of type alias defs
_ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
@ -217,7 +213,7 @@ layoutBriDocM = \case
Nothing -> pure ()
Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
do
when (not $ comment == "(" || comment == ")") $ do
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
@ -251,7 +247,7 @@ layoutBriDocM = \case
Nothing -> pure ()
Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
do
when (not $ comment == "(" || comment == ")") $ do
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
-- ^ evil hack for CPP

5
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -276,7 +276,10 @@ foldedAnnKeys ast = SYB.everything
Set.singleton
[ SYB.gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l <- SYB.gmapQi 0 SYB.cast x
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
-- for some reason, ghc-8.8 has forgotten how to infer the type of l,
-- even though it is passed to mkAnnKey above, which only accepts
-- SrcSpan.
]
)
ast

45
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -20,6 +20,7 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Layouters.Type
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
@ -743,7 +744,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
let (a : b : rest) = vars
hasOwnParens <- hasAnnKeywordComment a AnnOpenP
-- This isn't quite right, but does give syntactically valid results
let needsParens = not $ null rest || hasOwnParens
let needsParens = not (null rest) || hasOwnParens
docSeq
$ [ docLit $ Text.pack "type"
, docSeparator
@ -800,24 +801,36 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
-- TyFamInstDecl
--------------------------------------------------------------------------------
layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl
layoutTyFamInstDecl inClass (L loc tfid) = do
let
#if MIN_VERSION_ghc(8,6,0)
#if MIN_VERSION_ghc(8,8,0)
linst = L loc (TyFamInstD NoExt tfid)
feqn@(FamEqn _ name bndrsMay pats _fixity typ) = hsib_body $ tfid_eqn tfid
-- bndrsMay isJust e.g. with
-- type instance forall a . MyType (Maybe a) = Either () a
lfeqn = L loc feqn
#elif MIN_VERSION_ghc(8,6,0)
linst = L loc (TyFamInstD NoExt tfid)
feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid
bndrsMay = Nothing
lfeqn = L loc feqn
#elif MIN_VERSION_ghc(8,4,0)
linst = L loc (TyFamInstD tfid)
feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid
bndrsMay = Nothing
lfeqn = L loc feqn
#elif MIN_VERSION_ghc(8,2,0)
linst = L loc (TyFamInstD tfid)
lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid
bndrsMay = Nothing
pats = hsib_body boundPats
#else
linst = L loc (TyFamInstD tfid)
lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid
bndrsMay = Nothing
pats = hsib_body boundPats
#endif
docWrapNodePrior linst $ do
@ -828,15 +841,23 @@ layoutTyFamInstDecl inClass (L loc tfid) = do
then docLit $ Text.pack "type"
else docSeq
[appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]
makeForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered
makeForallDoc bndrs = do
bndrDocs <- layoutTyVarBndrs bndrs
docSeq
( [docLit (Text.pack "forall")]
++ processTyVarBndrsSingleline bndrDocs
)
lhs =
docWrapNode lfeqn
. appSep
. docWrapNodeRest linst
. docSeq
$ (appSep instanceDoc :)
$ [ docParenL | needsParens ]
$ [appSep instanceDoc]
++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ]
++ [ docParenL | needsParens ]
++ [appSep $ docWrapNode name $ docLit nameStr]
++ intersperse docSeparator (layoutType <$> pats)
++ intersperse docSeparator (layoutHsTyPats pats)
++ [ docParenR | needsParens ]
hasComments <- (||)
<$> hasAnyRegularCommentsConnected lfeqn
@ -845,6 +866,20 @@ layoutTyFamInstDecl inClass (L loc tfid) = do
layoutLhsAndType hasComments lhs "=" typeDoc
#if MIN_VERSION_ghc(8,8,0)
layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = pats <&> \case
HsValArg tm -> layoutType tm
HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]
-- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change
-- is a bit strange. Hopefully this does not ignore any important
-- annotations.
HsArgPar _l -> error "brittany internal error: HsArgPar{}"
#else
layoutHsTyPats :: [LHsType GhcPs] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = layoutType <$> pats
#endif
--------------------------------------------------------------------------------
-- ClsInstDecl
--------------------------------------------------------------------------------

14
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

@ -278,7 +278,11 @@ layoutExpr lexpr@(L _ expr) = do
expDoc1
expDoc2
]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */
HsAppType _ _ XHsWildCardBndrs{} ->
error "brittany internal error: HsAppType XHsWildCardBndrs"
HsAppType _ exp1 (HsWC _ ty1) -> do
#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsAppType XHsWildCardBndrs{} _ ->
error "brittany internal error: HsAppType XHsWildCardBndrs"
HsAppType (HsWC _ ty1) exp1 -> do
@ -1034,7 +1038,13 @@ layoutExpr lexpr@(L _ expr) = do
Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
#endif
recordExpression indentPolicy lexpr rExprDoc rFs
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */
ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) ->
error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs"
ExprWithTySig _ _ XHsWildCardBndrs{} ->
error "brittany internal error: ExprWithTySig XHsWildCardBndrs"
ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do
#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ ->
error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs"
ExprWithTySig XHsWildCardBndrs{} _ ->

27
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Haskell.Brittany.Internal.Layouters.Pattern
( layoutPat
@ -13,7 +14,13 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( Located, runGhc, GenLocated(L), moduleNameString, ol_val )
import GHC ( Located
, runGhc
, GenLocated(L)
, moduleNameString
, ol_val
)
import qualified GHC
import HsSyn
import Name
import BasicTypes
@ -33,8 +40,8 @@ import Language.Haskell.Brittany.Internal.Layouters.Type
-- ^^^^^^^^^^ this part
-- We will use `case .. of` as the imagined prefix to the examples used in
-- the different cases below.
layoutPat :: ToBriDocC (Pat GhcPs) (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
@ -51,7 +58,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
#endif
fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */
ParPat _ inner -> do
#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
ParPat _ inner -> do
#else /* ghc-8.0 8.2 8.4 */
ParPat inner -> do
@ -177,7 +186,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
#endif
-- bind@nestedpat -> expr
wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */
SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do
#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do
@ -242,13 +253,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- else
-- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n
-- endif
_ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
_ -> return <$> briDocByExactInlineOnly "some unknown pattern" (ghcDL lpat)
colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend
:: Located (Pat GhcPs)
:: LPat GhcPs
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do
@ -260,7 +271,7 @@ wrapPatPrepend pat prepElem = do
return $ x1' Seq.<| xR
wrapPatListy
:: [Located (Pat GhcPs)]
:: [LPat GhcPs]
-> String
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered

110
src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -2,6 +2,8 @@
module Language.Haskell.Brittany.Internal.Layouters.Type
( layoutType
, layoutTyVarBndrs
, processTyVarBndrsSingleline
)
where
@ -32,21 +34,19 @@ import DataTreePrint
layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
#if MIN_VERSION_ghc(8,2,0)
#if MIN_VERSION_ghc(8,6,0)
HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnn name
case promoted of
Promoted -> docSeq
[ docSeparator
, docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#else /* ghc-8.2 ghc-8.4 */
HsTyVar promoted name -> do
#endif
t <- lrdrNameToTextAnn name
case promoted of
#if MIN_VERSION_ghc(8,8,0)
IsPromoted -> docSeq
#else /* ghc-8.2 8.4 8.6 */
Promoted -> docSeq
#endif
[ docSeparator
, docTick
, docWrapNode name $ docLit t
@ -63,32 +63,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do
#endif
typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- bndrs `forM` \case
#if MIN_VERSION_ghc(8,6,0)
(L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
(L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"
#else
(L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
#endif
tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let
tyVarDocLineList = tyVarDocs >>= \case
(tname, Nothing) -> [docLit $ Text.pack " " <> tname]
(tname, Just doc) -> [ docLit $ Text.pack " ("
<> tname
<> Text.pack " :: "
, docForceSingleline $ doc
, docLit $ Text.pack ")"
]
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt
[ let
open = docLit $ Text.pack "forall"
@ -142,7 +123,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
else let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open]++tyVarDocLineList++[close])
in docSeq ([open, docSeparator]++tyVarDocLineList++[close])
, docForceSingleline contextDoc
, docLit $ Text.pack " => "
, docForceSingleline typeDoc
@ -172,31 +153,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsForAllTy bndrs typ2 -> do
#endif
typeDoc <- layoutType typ2
tyVarDocs <- bndrs `forM` \case
#if MIN_VERSION_ghc(8,6,0)
(L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ lrdrName kind)) -> do
d <- layoutType kind
return $ (lrdrNameToText lrdrName, Just $ return d)
(L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"
#else
(L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar lrdrName kind)) -> do
d <- layoutType kind
return $ (lrdrNameToText lrdrName, Just $ return d)
#endif
tyVarDocs <- layoutTyVarBndrs bndrs
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let
tyVarDocLineList = tyVarDocs >>= \case
(tname, Nothing) -> [docLit $ Text.pack " " <> tname]
(tname, Just doc) -> [ docLit $ Text.pack " ("
<> tname
<> Text.pack " :: "
, docForceSingleline doc
, docLit $ Text.pack ")"
]
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
docAlt
-- forall x . x
[ docSeq
@ -771,3 +732,46 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
else docLit $ Text.pack "*"
XHsType{} -> error "brittany internal error: XHsType"
#endif
#if MIN_VERSION_ghc(8,8,0)
HsAppKindTy _ ty kind -> do
t <- docSharedWrapper layoutType ty
k <- docSharedWrapper layoutType kind
docAlt
[ docSeq
[ docForceSingleline t
, docSeparator
, docLit $ Text.pack "@"
, docForceSingleline k
]
, docPar
t
(docSeq [docLit $ Text.pack "@", k ])
]
#endif
layoutTyVarBndrs
:: [LHsTyVarBndr GhcPs]
-> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]
layoutTyVarBndrs = mapM $ \case
#if MIN_VERSION_ghc(8,6,0)
(L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
(L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"
#else
(L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
#endif
processTyVarBndrsSingleline
:: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]
processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
(tname, Nothing) -> [docLit $ Text.pack " " <> tname]
(tname, Just doc) ->
[ docLit $ Text.pack " (" <> tname <> Text.pack " :: "
, docForceSingleline $ doc
, docLit $ Text.pack ")"
]

14
src/Language/Haskell/Brittany/Internal/Prelude.hs
View File

@ -18,7 +18,10 @@ import HsExtension as E ( GhcPs )
#endif
import RdrName as E ( RdrName )
#if MIN_VERSION_ghc(8,8,0)
import qualified GHC ( dL, HasSrcSpan, SrcSpanLess )
#endif
import qualified GHC ( Located )
-- more general:
@ -410,3 +413,12 @@ type instance IdP GhcPs = RdrName
type GhcPs = RdrName
#endif
#if MIN_VERSION_ghc(8,8,0)
ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a)
ghcDL = GHC.dL
#else /* ghc-8.0 8.2 8.4 8.6 */
ghcDL :: GHC.Located a -> GHC.Located a
ghcDL x = x
#endif