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

Add compat with GHC-8.6 API

remotes/felixonmars/ghc-8.6
Lennart Spitzner 2018-07-05 19:55:49 +02:00
parent 9d915232c0
commit 34735e27ef
11 changed files with 678 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
brittany.cabal
View File

@ -83,12 +83,12 @@ library {
-fno-warn-redundant-constraints
}
build-depends:
{ base >=4.9 && <4.12
, ghc >=8.0.1 && <8.5
{ base >=4.9 && <4.13
, ghc >=8.0.1 && <8.7
, ghc-paths >=0.1.0.9 && <0.2
, ghc-exactprint >=0.5.8 && <0.5.9
, transformers >=0.5.2.0 && <0.6
, containers >=0.5.7.1 && <0.6
, containers >=0.5.7.1 && <0.7
, mtl >=2.2.1 && <2.3
, text >=1.2 && <1.3
, multistate >=0.7.1.1 && <0.9
@ -111,7 +111,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.5
, ghc-boot-th >=8.0.1 && <8.7
, filepath >=1.4.1.0 && <1.5
, random >= 1.1 && <1.2
}

18
src/Language/Haskell/Brittany/Internal.hs
View File

@ -487,10 +487,17 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
getDeclBindingNames :: LHsDecl GhcPs -> [String]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
getDeclBindingNames (L _ decl) = case decl of
SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
ValD _ (FunBind _ (L _ n) _ _ _) -> [Text.unpack $ rdrNameToText n]
_ -> []
#else
getDeclBindingNames (L _ decl) = case decl of
SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n]
_ -> []
#endif
-- Prints the information associated with the module annotation
@ -564,15 +571,26 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
_sigHead :: Sig GhcPs -> String
_sigHead = \case
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
TypeSig _ names _ ->
#else
TypeSig names _ ->
#endif
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
_ -> "unknown sig"
_bindHead :: HsBind GhcPs -> String
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
_bindHead = \case
FunBind _ fId _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind"
#else
_bindHead = \case
FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _pat _ _ _ ([], []) -> "PatBind smth"
_ -> "unknown bind"
#endif

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

@ -197,9 +197,17 @@ commentAnnFixTransform modul = SYB.everything (>>) genF modul
genF = (\_ -> return ()) `SYB.extQ` exprF
exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
exprF lexpr@(L _ expr) = case expr of
RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) ->
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
#else
RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->
#endif
moveTrailingComments lexpr (List.last fs)
RecordUpd _lname fs@(_:_) _ _ _ _ ->
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
RecordUpd _ _e fs@(_:_) ->
#else
RecordUpd _e fs@(_:_) _cons _ _ _ ->
#endif
moveTrailingComments lexpr (List.last fs)
_ -> return ()
@ -280,13 +288,13 @@ withTransformedAnns
=> ast
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
withTransformedAnns ast m = do
-- TODO: implement `local` for MultiReader/MultiRWS
readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR
MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)
x <- m
MultiRWSS.mPutRawR readers
pure x
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS
MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)
x <- m
MultiRWSS.mPutRawR readers
pure x
where
f anns =
let ((), (annsBalanced, _), _) =

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

@ -55,28 +55,43 @@ import Data.Char (isUpper)
layoutDecl :: ToBriDoc HsDecl
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
layoutDecl d@(L loc decl) = case decl of
SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig)
ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
Left ns -> docLines $ return <$> ns
Right n -> return n
TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl)
InstD _ (TyFamInstD{}) -> layoutTyFamInstDWorkaround d
InstD _ (ClsInstD _ inst) ->
withTransformedAnns d $ layoutClsInst (L loc inst)
_ -> briDocByExactNoComment d
#else
layoutDecl d@(L loc decl) = case decl of
SigD sig -> withTransformedAnns d $ layoutSig (L loc sig)
ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
Left ns -> docLines $ return <$> ns
Right n -> return n
TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl)
InstD (TyFamInstD{}) -> do
-- this is a (temporary (..)) workaround for "type instance" decls
-- that do not round-trip through exactprint properly.
let fixer s = case List.stripPrefix "type " s of
Just rest | not ("instance" `isPrefixOf` rest) ->
"type instance " ++ rest
_ -> s
str <- mAsk <&> \anns ->
intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns
allocateNode $ BDFExternal (ExactPrint.mkAnnKey d)
(foldedAnnKeys d)
False
(Text.pack str)
InstD (TyFamInstD{}) -> layoutTyFamInstDWorkaround d
InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst)
_ -> briDocByExactNoComment d
_ -> briDocByExactNoComment d
#endif
layoutTyFamInstDWorkaround :: ToBriDoc HsDecl
layoutTyFamInstDWorkaround d = do
-- this is a (temporary (..)) workaround for "type instance" decls
-- that do not round-trip through exactprint properly.
let fixer s = case List.stripPrefix "type " s of
Just rest | not ("instance" `isPrefixOf` rest) ->
"type instance " ++ rest
_ -> s
str <- mAsk <&> \anns ->
intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns
allocateNode $ BDFExternal (ExactPrint.mkAnnKey d)
(foldedAnnKeys d)
False
(Text.pack str)
--------------------------------------------------------------------------------
-- Sig
@ -84,12 +99,18 @@ layoutDecl d@(L loc decl) = case decl of
layoutSig :: ToBriDoc Sig
layoutSig lsig@(L _loc sig) = case sig of
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ
#else /* ghc-8.0 */
TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ
#endif
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
#else
InlineSig name (InlinePragma _ spec _arity phaseAct conlike) ->
#endif
docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name
specStr <- specStringCompat lsig spec
@ -106,7 +127,9 @@ layoutSig lsig@(L _loc sig) = case sig of
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr
<> Text.pack " #-}"
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ
#else /* ghc-8.0 */
ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ
@ -152,7 +175,6 @@ layoutSig lsig@(L _loc sig) = case sig of
)
]
specStringCompat
:: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
#if MIN_VERSION_ghc(8,4,0)
@ -171,8 +193,16 @@ specStringCompat _ = \case
layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
BodyStmt _ body _ _ -> layoutExpr body
#else
BodyStmt body _ _ _ -> layoutExpr body
#endif
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
BindStmt _ lPat expr _ _ -> do
#else
BindStmt lPat expr _ _ _ -> do
#endif
patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt
@ -191,7 +221,11 @@ layoutBind
(HsBindLR GhcPs GhcPs)
(Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do
#else
FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do
#endif
idStr <- lrdrNameToTextAnn fId
binderDoc <- docLit $ Text.pack "="
funcPatDocs <-
@ -200,7 +234,11 @@ layoutBind lbind@(L _ bind) = case bind of
$ layoutPatternBind (Just idStr) binderDoc
`mapM` matches
return $ Left $ funcPatDocs
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do
#else
PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do
#endif
patDocs <- colsWrapPat =<< layoutPat pat
clauseDocs <- layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds
@ -229,7 +267,11 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
-- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsValBinds _ (ValBinds _ bindlrs sigs) -> do
#else
HsValBinds (ValBindsIn bindlrs sigs) -> do
#endif
let unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
@ -238,23 +280,36 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s
return $ Just $ docs
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
-- x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"
XHsLocalBindsLR{} -> error "brittany internal error: XHsLocalBindsLR"
#else
x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
-- i _think_ this case never occurs in non-processed ast
Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}"
(L noSrcSpan x)
x@(HsIPBinds _ipBinds) ->
#endif
x@(HsIPBinds{}) ->
Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x)
EmptyLocalBinds -> return $ Nothing
EmptyLocalBinds{} -> return $ Nothing
-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is
-- parSpacing stuff.B
layoutGrhs
:: LGRHS GhcPs (LHsExpr GhcPs)
-> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do
#else
layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
#endif
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body
return (guardDocs, bodyDoc, body)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
layoutGrhs (L _ (XGRHS{})) = error "brittany internal error: XGRHS"
#endif
layoutPatternBind
:: Maybe Text
@ -263,7 +318,11 @@ layoutPatternBind
-> ToBriDocM BriDocNumbered
layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do
let pats = m_pats match
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let (GRHSs _ grhss whereBinds) = m_grhss match
#else
let (GRHSs grhss whereBinds) = m_grhss match
#endif
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
let mIdStr' = fixPatternBindIdentifier match <$> mIdStr
@ -629,7 +688,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
layoutTyCl :: ToBriDoc TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of
#if MIN_VERSION_ghc(8,2,0)
#if MIN_VERSION_ghc(8,6,0)
SynDecl _ name vars fixity typ -> do
let isInfix = case fixity of
Prefix -> False
Infix -> True
#elif MIN_VERSION_ghc(8,2,0)
SynDecl name vars fixity typ _ -> do
let isInfix = case fixity of
Prefix -> False
@ -700,10 +764,19 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr
layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
docWrapNodePrior lbndr $ case bndr of
#if MIN_VERSION_ghc(8,6,0) /* 8.6 */
XTyVarBndr{} -> error "brittany internal error: XTyVarBndr"
UserTyVar _ name -> do
#else /* 8.0 8.2 8.4 */
UserTyVar name -> do
#endif
nameStr <- lrdrNameToTextAnn name
docSeq $ [docSeparator | needsSep] ++ [docLit nameStr]
#if MIN_VERSION_ghc(8,6,0) /* 8.6 */
KindedTyVar _ name kind -> do
#else /* 8.0 8.2 8.4 */
KindedTyVar name kind -> do
#endif
nameStr <- lrdrNameToTextAnn name
docSeq
$ [ docSeparator | needsSep ]
@ -736,8 +809,21 @@ layoutClsInst lcid@(L _ cid) = docLines
]
where
layoutInstanceHead :: ToBriDocM BriDocNumbered
#if MIN_VERSION_ghc(8,6,0) /* 8.6 */
layoutInstanceHead =
briDocByExactNoComment $ InstD . ClsInstD . removeChildren <$> lcid
briDocByExactNoComment
$ InstD NoExt
. ClsInstD NoExt
. removeChildren
<$> lcid
#else
layoutInstanceHead =
briDocByExactNoComment
$ InstD
. ClsInstD
. removeChildren
<$> lcid
#endif
removeChildren :: ClsInstDecl p -> ClsInstDecl p
removeChildren c = c

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

@ -37,9 +37,17 @@ layoutExpr lexpr@(L _ expr) = do
.> confUnpack
let allowFreeIndent = indentPolicy == IndentPolicyFree
docWrapNode lexpr $ case expr of
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsVar _ vname -> do
#else
HsVar vname -> do
#endif
docLit =<< lrdrNameToTextAnn vname
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsUnboundVar _ var -> case var of
#else
HsUnboundVar var -> case var of
#endif
OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname
TrueExprHole oname -> docLit $ Text.pack $ occNameString oname
HsRecFld{} -> do
@ -51,15 +59,35 @@ layoutExpr lexpr@(L _ expr) = do
HsIPVar{} -> do
-- TODO
briDocByExactInlineOnly "HsOverLabel{}" lexpr
HsOverLit (OverLit olit _ _ _) -> do
allocateNode $ overLitValBriDoc olit
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsOverLit _ olit -> do
#else
HsOverLit olit -> do
#endif
allocateNode $ overLitValBriDoc $ ol_val olit
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsLit _ lit -> do
#else
HsLit lit -> do
#endif
allocateNode $ litBriDoc lit
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _)
#else
HsLam (MG (L _ [lmatch@(L _ match)]) _ _ _)
#endif
| pats <- m_pats match
, GRHSs [lgrhs] llocals <- m_grhss match
, L _ EmptyLocalBinds <- llocals
, L _ (GRHS [] body) <- lgrhs
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
, GRHSs _ [lgrhs] llocals <- m_grhss match
#else
, GRHSs [lgrhs] llocals <- m_grhss match
#endif
, L _ EmptyLocalBinds {} <- llocals
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
, L _ (GRHS _ [] body) <- lgrhs
#else
, L _ (GRHS [] body) <- lgrhs
#endif
-> do
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body
@ -105,9 +133,13 @@ layoutExpr lexpr@(L _ expr) = do
]
HsLam{} ->
unknownNodeError "HsLam too complex" lexpr
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsLamCase _ XMatchGroup{} ->
error "brittany internal error: HsLamCase XMatchGroup"
HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/
HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do
#else /* ghc-8.0 */
#else /* ghc-8.0 */
HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do
#endif
binderDoc <- docLit $ Text.pack "->"
@ -116,14 +148,26 @@ layoutExpr lexpr@(L _ expr) = do
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "\\case")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsApp _ exp1@(L _ HsApp{}) exp2 -> do
#else
HsApp exp1@(L _ HsApp{}) exp2 -> do
#endif
let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs])
gather list = \case
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
L _ (HsApp _ l r) -> gather (r:list) l
#else
L _ (HsApp l r) -> gather (r:list) l
#endif
x -> (x, list)
let (headE, paramEs) = gather [exp2] exp1
let colsOrSequence = case headE of
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
L _ (HsVar _ (L _ (Unqual occname))) ->
#else
L _ (HsVar (L _ (Unqual occname))) ->
#endif
docCols (ColApp $ Text.pack $ occNameString occname)
_ -> docSeq
headDoc <- docSharedWrapper layoutExpr headE
@ -168,7 +212,11 @@ layoutExpr lexpr@(L _ expr) = do
( docNonBottomSpacing
$ docLines paramDocs
)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsApp _ exp1 exp2 -> do
#else
HsApp exp1 exp2 -> do
#endif
-- TODO: if expDoc1 is some literal, we may want to create a docCols here.
expDoc1 <- docSharedWrapper layoutExpr exp1
expDoc2 <- docSharedWrapper layoutExpr exp2
@ -206,9 +254,13 @@ layoutExpr lexpr@(L _ expr) = do
expDoc1
expDoc2
]
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsAppType XHsWildCardBndrs{} _ ->
error "brittany internal error: HsAppType XHsWildCardBndrs"
HsAppType (HsWC _ ty1) exp1 -> do
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
HsAppType exp1 (HsWC _ ty1) -> do
#else /* ghc-8.0 */
#else /* ghc-8.0 */
HsAppType exp1 (HsWC _ _ ty1) -> do
#endif
t <- docSharedWrapper layoutType ty1
@ -224,13 +276,23 @@ layoutExpr lexpr@(L _ expr) = do
e
(docSeq [docLit $ Text.pack "@", t ])
]
#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */
HsAppTypeOut{} -> do
-- TODO
briDocByExactInlineOnly "HsAppTypeOut{}" lexpr
#endif
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do
#else
OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do
#endif
let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)])
gather opExprList = \case
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
(L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1
#else
(L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1
#endif
final -> (final, opExprList)
(leftOperand, appList) = gather [] expLeft
leftOperandDoc <- docSharedWrapper layoutExpr leftOperand
@ -244,11 +306,19 @@ layoutExpr lexpr@(L _ expr) = do
hasComLeft <- hasAnyCommentsConnected expLeft
hasComOp <- hasAnyCommentsConnected expOp
pure $ not hasComLeft && not hasComOp
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let allowPar = case (expOp, expRight) of
(L _ (HsVar _ (L _ (Unqual occname))), _)
| occNameString occname == "$" -> True
(_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
_ -> True
#else
let allowPar = case (expOp, expRight) of
(L _ (HsVar (L _ (Unqual occname))), _)
| occNameString occname == "$" -> True
(_, L _ (HsApp _ (L _ HsVar{}))) -> False
_ -> True
#endif
runFilteredAlternative $ do
-- > one + two + three
-- or
@ -286,15 +356,27 @@ layoutExpr lexpr@(L _ expr) = do
$ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
OpApp _ expLeft expOp expRight -> do
#else
OpApp expLeft expOp _ expRight -> do
#endif
expDocLeft <- docSharedWrapper layoutExpr expLeft
expDocOp <- docSharedWrapper layoutExpr expOp
expDocRight <- docSharedWrapper layoutExpr expRight
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let allowPar = case (expOp, expRight) of
(L _ (HsVar _ (L _ (Unqual occname))), _)
| occNameString occname == "$" -> True
(_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
_ -> True
#else
let allowPar = case (expOp, expRight) of
(L _ (HsVar (L _ (Unqual occname))), _)
| occNameString occname == "$" -> True
(_, L _ (HsApp _ (L _ HsVar{}))) -> False
_ -> True
#endif
runFilteredAlternative $ do
-- one-line
addAlternative
@ -334,12 +416,20 @@ layoutExpr lexpr@(L _ expr) = do
$ docPar
expDocLeft
(docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight])
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
NegApp _ op _ -> do
#else
NegApp op _ -> do
#endif
opDoc <- docSharedWrapper layoutExpr op
docSeq [ docLit $ Text.pack "-"
, opDoc
]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsPar _ innerExp -> do
#else
HsPar innerExp -> do
#endif
innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp
docAlt
[ docSeq
@ -355,18 +445,37 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack ")"
]
]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
SectionL _ left op -> do -- TODO: add to testsuite
#else
SectionL left op -> do -- TODO: add to testsuite
#endif
leftDoc <- docSharedWrapper layoutExpr left
opDoc <- docSharedWrapper layoutExpr op
docSeq [leftDoc, docSeparator, opDoc]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
SectionR _ op right -> do -- TODO: add to testsuite
#else
SectionR op right -> do -- TODO: add to testsuite
#endif
opDoc <- docSharedWrapper layoutExpr op
rightDoc <- docSharedWrapper layoutExpr right
docSeq [opDoc, docSeparator, rightDoc]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
ExplicitTuple _ args boxity -> do
#else
ExplicitTuple args boxity -> do
#endif
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let argExprs = args <&> \arg -> case arg of
(L _ (Present _ e)) -> (arg, Just e);
(L _ (Missing NoExt)) -> (arg, Nothing)
(L _ XTupArg{}) -> error "brittany internal error: XTupArg"
#else
let argExprs = args <&> \arg -> case arg of
(L _ (Present e)) -> (arg, Just e);
(L _ (Missing PlaceHolder)) -> (arg, Nothing)
#endif
argDocs <- forM argExprs
$ docSharedWrapper
$ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM
@ -408,7 +517,13 @@ layoutExpr lexpr@(L _ expr) = do
lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN]
end = closeLit
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsCase _ _ XMatchGroup{} ->
error "brittany internal error: HsCase XMatchGroup"
HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do
#else
HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do
#endif
cExpDoc <- docSharedWrapper layoutExpr cExp
binderDoc <- docLit $ Text.pack "->"
funcPatDocs <- docWrapNode lmatches
@ -432,7 +547,11 @@ layoutExpr lexpr@(L _ expr) = do
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
)
]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsIf _ _ ifExpr thenExpr elseExpr -> do
#else
HsIf _ ifExpr thenExpr elseExpr -> do
#endif
ifExprDoc <- docSharedWrapper layoutExpr ifExpr
thenExprDoc <- docSharedWrapper layoutExpr thenExpr
elseExprDoc <- docSharedWrapper layoutExpr elseExpr
@ -552,7 +671,11 @@ layoutExpr lexpr@(L _ expr) = do
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "if")
(layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsLet _ binds exp1 -> do
#else
HsLet binds exp1 -> do
#endif
expDoc1 <- docSharedWrapper layoutExpr exp1
-- We jump through some ugly hoops here to ensure proper sharing.
mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return)
@ -655,60 +778,65 @@ layoutExpr lexpr@(L _ expr) = do
]
_ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]
-- docSeq [appSep $ docLit "let in", expDoc1]
HsDo DoExpr (L _ stmts) _ -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "do")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)
HsDo MDoExpr (L _ stmts) _ -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "mdo")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)
HsDo x (L _ stmts) _ | case x of { ListComp -> True
; MonadComp -> True
; _ -> False } -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
hasComments <- hasAnyCommentsBelow lexpr
runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
[ docNodeAnnKW lexpr Nothing
$ appSep
$ docLit
$ Text.pack "["
, docNodeAnnKW lexpr (Just AnnOpenS)
$ appSep
$ docForceSingleline
$ List.last stmtDocs
, appSep $ docLit $ Text.pack "|"
, docSeq $ List.intersperse docCommaSep
$ docForceSingleline <$> List.init stmtDocs
, docLit $ Text.pack " ]"
]
addAlternative $
let
start = docCols ColListComp
[ docNodeAnnKW lexpr Nothing
$ appSep $ docLit $ Text.pack "["
, docSetBaseY
$ docNodeAnnKW lexpr (Just AnnOpenS)
$ List.last stmtDocs
]
(s1:sM) = List.init stmtDocs
line1 = docCols ColListComp
[appSep $ docLit $ Text.pack "|", s1]
lineM = sM <&> \d ->
docCols ColListComp [docCommaSep, d]
end = docLit $ Text.pack "]"
in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]
HsDo{} -> do
-- TODO
unknownNodeError "HsDo{} no comp" lexpr
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of
#else
HsDo stmtCtx (L _ stmts) _ -> case stmtCtx of
#endif
DoExpr -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "do")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)
MDoExpr -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "mdo")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)
x | case x of { ListComp -> True
; MonadComp -> True
; _ -> False } -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
hasComments <- hasAnyCommentsBelow lexpr
runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
[ docNodeAnnKW lexpr Nothing
$ appSep
$ docLit
$ Text.pack "["
, docNodeAnnKW lexpr (Just AnnOpenS)
$ appSep
$ docForceSingleline
$ List.last stmtDocs
, appSep $ docLit $ Text.pack "|"
, docSeq $ List.intersperse docCommaSep
$ docForceSingleline <$> List.init stmtDocs
, docLit $ Text.pack " ]"
]
addAlternative $
let
start = docCols ColListComp
[ docNodeAnnKW lexpr Nothing
$ appSep $ docLit $ Text.pack "["
, docSetBaseY
$ docNodeAnnKW lexpr (Just AnnOpenS)
$ List.last stmtDocs
]
(s1:sM) = List.init stmtDocs
line1 = docCols ColListComp
[appSep $ docLit $ Text.pack "|", s1]
lineM = sM <&> \d ->
docCols ColListComp [docCommaSep, d]
end = docLit $ Text.pack "]"
in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]
_ -> do
-- TODO
unknownNodeError "HsDo{} unknown stmtCtx" lexpr
ExplicitList _ _ elems@(_:_) -> do
elemDocs <- elems `forM` docSharedWrapper layoutExpr
hasComments <- hasAnyCommentsBelow lexpr
@ -749,80 +877,101 @@ layoutExpr lexpr@(L _ expr) = do
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
ExplicitList _ _ [] ->
docLit $ Text.pack "[]"
#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */
ExplicitPArr{} -> do
-- TODO
briDocByExactInlineOnly "ExplicitPArr{}" lexpr
RecordCon lname _ _ (HsRecFields fields Nothing) -> do
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
rFs <- fields
`forM` \lfield@(L _ (HsRecField (L _ (FieldOcc lnameF _)) rFExpr pun)) -> do
rFExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutExpr rFExpr
return $ (lfield, lrdrNameToText lnameF, rFExpDoc)
recordExpression indentPolicy lexpr nameDoc rFs
RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do
let t = lrdrNameToText lname
docWrapNode lname $ docLit $ t <> Text.pack " { .. }"
RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do
-- TODO this should be consolidated into `recordExpression`
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutExpr fExpr
return (fieldl, lrdrNameToText lnameF, fExpDoc)
let line1 wrapper =
[ appSep $ docLit $ Text.pack "{"
, docWrapNodePrior fd1l $ appSep $ docLit fd1n
, case fd1e of
Just x -> docSeq
[ appSep $ docLit $ Text.pack "="
, docWrapNodeRest fd1l $ wrapper x
]
Nothing -> docEmpty
#endif
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
RecordCon _ lname fields ->
#else
RecordCon lname _ _ fields ->
#endif
case fields of
HsRecFields fs Nothing -> do
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
rFs <- fs
`forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let FieldOcc _ lnameF = fieldOcc
#else
let FieldOcc lnameF _ = fieldOcc
#endif
rFExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutExpr rFExpr
return $ (lfield, lrdrNameToText lnameF, rFExpDoc)
recordExpression indentPolicy lexpr nameDoc rFs
HsRecFields [] (Just 0) -> do
let t = lrdrNameToText lname
docWrapNode lname $ docLit $ t <> Text.pack " { .. }"
HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do
-- TODO this should be consolidated into `recordExpression`
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let FieldOcc _ lnameF = fieldOcc
#else
let FieldOcc lnameF _ = fieldOcc
#endif
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutExpr fExpr
return (fieldl, lrdrNameToText lnameF, fExpDoc)
let ((fd1l, fd1n, fd1e):fdr) = fieldDocs
let line1 wrapper =
[ appSep $ docLit $ Text.pack "{"
, docWrapNodePrior fd1l $ appSep $ docLit fd1n
, case fd1e of
Just x -> docSeq
[ appSep $ docLit $ Text.pack "="
, docWrapNodeRest fd1l $ wrapper x
]
Nothing -> docEmpty
]
let lineR wrapper = fdr <&> \(lfield, fText, fDoc) ->
[ docCommaSep
, appSep $ docLit fText
, case fDoc of
Just x -> docWrapNode lfield $ docSeq
[ appSep $ docLit $ Text.pack "="
, wrapper x
]
Nothing -> docEmpty
]
let lineDot =
[ docCommaSep
, docLit $ Text.pack ".."
]
let lineN =
[ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
, docLit $ Text.pack "}"
]
docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free
[ docSeq
$ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator]
++ line1 docForceSingleline
++ join (lineR docForceSingleline)
++ lineDot
++ [docSeparator]
++ lineN
, docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docNodeAnnKW lexpr Nothing nameDoc)
( docNonBottomSpacing
$ docLines
$ [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)]
++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular))
++ [docSeq lineDot, docSeq lineN]
)
]
let lineR wrapper = fdr <&> \(lfield, fText, fDoc) ->
[ docCommaSep
, appSep $ docLit fText
, case fDoc of
Just x -> docWrapNode lfield $ docSeq
[ appSep $ docLit $ Text.pack "="
, wrapper x
]
Nothing -> docEmpty
]
let lineDot =
[ docCommaSep
, docLit $ Text.pack ".."
]
let lineN =
[ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
, docLit $ Text.pack "}"
]
docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free
[ docSeq
$ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator]
++ line1 docForceSingleline
++ join (lineR docForceSingleline)
++ lineDot
++ [docSeparator]
++ lineN
, docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docNodeAnnKW lexpr Nothing nameDoc)
( docNonBottomSpacing
$ docLines
$ [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)]
++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular))
++ [docSeq lineDot, docSeq lineN]
)
]
RecordCon{} ->
unknownNodeError "RecordCon with puns" lexpr
_ -> unknownNodeError "RecordCon with puns" lexpr
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
RecordUpd _ rExpr fields -> do
#else
RecordUpd rExpr fields _ _ _ _ -> do
#endif
rExprDoc <- docSharedWrapper layoutExpr rExpr
rFs <- fields
`forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do
@ -830,10 +979,23 @@ layoutExpr lexpr@(L _ expr) = do
then return Nothing
else Just <$> docSharedWrapper layoutExpr rFExpr
return $ case ambName of
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
XAmbiguousFieldOcc{} ->
error "brittany internal error: XAmbiguousFieldOcc"
#else
Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
#endif
recordExpression indentPolicy lexpr rExprDoc rFs
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ ->
error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs"
ExprWithTySig XHsWildCardBndrs{} _ ->
error "brittany internal error: ExprWithTySig XHsWildCardBndrs"
ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8,4 */
ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do
#else /* ghc-8.0 */
ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do
@ -845,9 +1007,11 @@ layoutExpr lexpr@(L _ expr) = do
, appSep $ docLit $ Text.pack "::"
, typDoc
]
#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */
ExprWithTySigOut{} -> do
-- TODO
briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr
#endif
ArithSeq _ Nothing info ->
case info of
From e1 -> do
@ -892,9 +1056,11 @@ layoutExpr lexpr@(L _ expr) = do
]
ArithSeq{} ->
briDocByExactInlineOnly "ArithSeq" lexpr
#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */
PArrSeq{} -> do
-- TODO
briDocByExactInlineOnly "PArrSeq{}" lexpr
#endif
HsSCC{} -> do
-- TODO
briDocByExactInlineOnly "HsSCC{}" lexpr
@ -936,7 +1102,11 @@ layoutExpr lexpr@(L _ expr) = do
briDocByExactInlineOnly "HsTickPragma{}" lexpr
EWildPat{} -> do
docLit $ Text.pack "_"
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
EAsPat _ asName asExpr -> do
#else
EAsPat asName asExpr -> do
#endif
docSeq
[ docLit $ lrdrNameToText asName <> Text.pack "@"
, layoutExpr asExpr
@ -958,6 +1128,9 @@ layoutExpr lexpr@(L _ expr) = do
-- TODO
briDocByExactInlineOnly "ExplicitSum{}" lexpr
#endif
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
XExpr{} -> error "brittany internal error: XExpr"
#endif
recordExpression
:: (Data.Data.Data lExpr, Data.Data.Data name)
@ -1073,7 +1246,6 @@ recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) =
in [line1] ++ lineR ++ [lineN]
)
#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */
litBriDoc :: HsLit GhcPs -> BriDocFInt
litBriDoc = \case

26
src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -39,12 +39,32 @@ prepareName = id
layoutIE :: ToBriDoc IE
layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
IEVar x -> layoutWrapped lie x
#if MIN_VERSION_ghc(8,6,0)
IEVar _ x -> layoutWrapped lie x
#else
IEVar x -> layoutWrapped lie x
#endif
#if MIN_VERSION_ghc(8,6,0)
IEThingAbs _ x -> layoutWrapped lie x
#else
IEThingAbs x -> layoutWrapped lie x
#endif
#if MIN_VERSION_ghc(8,6,0)
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
#else
IEThingAll x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
#endif
#if MIN_VERSION_ghc(8,6,0)
IEThingWith _ x (IEWildcard _) _ _ ->
#else
IEThingWith x (IEWildcard _) _ _ ->
#endif
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
#if MIN_VERSION_ghc(8,6,0)
IEThingWith _ x _ ns _ -> do
#else
IEThingWith x _ ns _ -> do
#endif
hasComments <- hasAnyCommentsBelow lie
runFilteredAlternative $ do
addAlternativeCond (not hasComments)
@ -68,7 +88,11 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs
++ [docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN], docParenR]
#if MIN_VERSION_ghc(8,6,0)
IEModuleContents _ n -> docSeq
#else
IEModuleContents n -> docSeq
#endif
[ docLit $ Text.pack "module"
, docSeparator
, docLit . Text.pack . moduleNameString $ unLoc n

4
src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
View File

@ -43,7 +43,11 @@ prepModName = id
layoutImport :: ToBriDoc ImportDecl
layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of
#if MIN_VERSION_ghc(8,6,0)
ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do
#else
ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do
#endif
importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack
importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack

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

@ -13,7 +13,7 @@ where
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString, ol_val )
import HsSyn
import Name
import BasicTypes
@ -37,11 +37,25 @@ layoutPat :: ToBriDocC (Pat GhcPs) (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr
VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
VarPat _ n ->
#else /* ghc-8.0 8.2 8.4 */
VarPat n ->
#endif
fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr
LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
LitPat _ lit ->
#else /* ghc-8.0 8.2 8.4 */
LitPat lit ->
#endif
fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
ParPat _ inner -> do
#else /* ghc-8.0 8.2 8.4 */
ParPat inner -> do
#endif
-- (nestedpat) -> expr
left <- docLit $ Text.pack "("
right <- docLit $ Text.pack ")"
@ -89,7 +103,12 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let FieldOcc _ lnameF = fieldOcc
#else
let FieldOcc lnameF _ = fieldOcc
#endif
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutPat fPat
@ -118,7 +137,12 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do
-- Abc { a = locA, .. }
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
let FieldOcc _ lnameF = fieldOcc
#else
let FieldOcc lnameF _ = fieldOcc
#endif
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutPat fPat
@ -136,18 +160,28 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
(fieldName, Nothing) -> [docLit fieldName, docCommaSep]
, docLit $ Text.pack "..}"
]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
TuplePat _ args boxity -> do
#else
TuplePat args boxity _ -> do
#endif
-- (nestedpat1, nestedpat2, nestedpat3) -> expr
-- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
case boxity of
Boxed -> wrapPatListy args "()" docParenL docParenR
Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
AsPat _ asName asPat -> do
#else
AsPat asName asPat -> do
#endif
-- bind@nestedpat -> expr
wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#if 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
#else /* ghc-8.0 */
#else /* ghc-8.0 */
SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do
#endif
-- i :: Int -> expr
@ -169,19 +203,35 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
, docForceSingleline tyDoc
]
return $ xR Seq.|> xN'
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
ListPat _ elems ->
#else
ListPat elems _ _ ->
#endif
-- [] -> expr1
-- [nestedpat1, nestedpat2, nestedpat3] -> expr2
wrapPatListy elems "[]" docBracketL docBracketR
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
BangPat _ pat1 -> do
#else
BangPat pat1 -> do
#endif
-- !nestedpat -> expr
wrapPatPrepend pat1 (docLit $ Text.pack "!")
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
LazyPat _ pat1 -> do
#else
LazyPat pat1 -> do
#endif
-- ~nestedpat -> expr
wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
NPat _ llit@(L _ ol) mNegative _ -> do
#else
NPat llit@(L _ ol) mNegative _ _ -> do
#endif
-- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc]

20
src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
View File

@ -34,9 +34,17 @@ layoutStmt lstmt@(L _ stmt) = do
indentAmount :: Int <-
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
docWrapNode lstmt $ case stmt of
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
LastStmt _ body False _ -> do
#else
LastStmt body False _ -> do
#endif
layoutExpr body
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
BindStmt _ lPat expr _ _ -> do
#else
BindStmt lPat expr _ _ _ -> do
#endif
patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
docAlt
@ -52,7 +60,11 @@ layoutStmt lstmt@(L _ stmt) = do
$ docPar (docLit $ Text.pack "<-") (expDoc)
]
]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
LetStmt _ binds -> do
#else
LetStmt binds -> do
#endif
let isFree = indentPolicy == IndentPolicyFree
let indentFourPlus = indentAmount >= 4
layoutLocalBinds binds >>= \case
@ -97,7 +109,11 @@ layoutStmt lstmt@(L _ stmt) = do
$ docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
#else
RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do
#endif
-- rec stmt1
-- stmt2
-- stmt3
@ -113,7 +129,11 @@ layoutStmt lstmt@(L _ stmt) = do
addAlternative $ docAddBaseY BrIndentRegular $ docPar
(docLit (Text.pack "rec"))
(docLines $ layoutStmt <$> stmts)
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
BodyStmt _ expr _ _ -> do
#else
BodyStmt expr _ _ _ -> do
#endif
expDoc <- docSharedWrapper layoutExpr expr
docAddBaseY BrIndentRegular $ expDoc
_ -> briDocByExactInlineOnly "some unknown statement" lstmt

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

@ -23,6 +23,7 @@ import HsSyn
import Name
import Outputable ( ftext, showSDocUnsafe )
import BasicTypes
import qualified SrcLoc
import DataTreePrint
@ -31,7 +32,17 @@ 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) /* ghc-8.2 */
#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 */
HsTyVar promoted name -> do
t <- lrdrNameToTextAnn name
case promoted of
@ -46,13 +57,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
t <- lrdrNameToTextAnn name
docWrapNode name $ docLit t
#endif
#if MIN_VERSION_ghc(8,6,0)
HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
#else
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
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
@ -143,13 +166,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsForAllTy _ bndrs typ2 -> do
#else
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
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
@ -210,7 +245,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
#else
HsQualTy lcntxts@(L _ cntxts) typ1 -> do
#endif
typeDoc <- docSharedWrapper layoutType typ1
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let
@ -260,7 +299,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsFunTy _ typ1 typ2 -> do
#else
HsFunTy typ1 typ2 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
let maybeForceML = case typ2 of
@ -284,7 +327,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsParTy _ typ1 -> do
#else
HsParTy typ1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
@ -299,6 +346,35 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
])
(docLit $ Text.pack ")")
]
#if MIN_VERSION_ghc(8,6,0)
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1
docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead : (docRest >>= \d ->
[ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
HsAppTy _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
docAlt
[ docSeq
[ docForceSingleline typeDoc1
, docSeparator
, docForceSingleline typeDoc2
]
, docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
]
#else
HsAppTy typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
@ -351,7 +427,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
layoutAppType (L _ (HsAppPrefix t)) = layoutType t
layoutAppType lt@(L _ (HsAppInfix t)) =
docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t
#endif
#if MIN_VERSION_ghc(8,6,0)
HsListTy _ typ1 -> do
#else
HsListTy typ1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
@ -366,6 +447,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
])
(docLit $ Text.pack "]")
]
#if MIN_VERSION_ghc(8,6,0)
#else
HsPArrTy typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
@ -381,13 +464,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
])
(docLit $ Text.pack ":]")
]
#endif
#if MIN_VERSION_ghc(8,6,0)
HsTupleTy _ tupleSort typs -> case tupleSort of
#else
HsTupleTy tupleSort typs -> case tupleSort of
#endif
HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple
HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple
where
unboxed = if null typs then error "unboxed unit?" else unboxedL
unboxed = if null typs then error "brittany internal error: unboxed unit"
else unboxedL
simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()"
simpleL = do
@ -480,9 +569,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- }
-- , _layouter_ast = ltype
-- }
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
HsIParamTy (L _ (HsIPName ipName)) typ1 -> do
#else /* ghc-8.0 */
#else /* ghc-8.0 */
HsIParamTy (HsIPName ipName) typ1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
@ -503,6 +594,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docAddBaseY (BrIndentSpecial 2) typeDoc1
])
]
#if MIN_VERSION_ghc(8,6,0)
#else
HsEqTy typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
@ -521,8 +614,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docAddBaseY (BrIndentSpecial 2) typeDoc2
])
]
#endif
-- TODO: test KindSig
#if MIN_VERSION_ghc(8,6,0)
HsKindSig _ typ1 kind1 -> do
#else
HsKindSig typ1 kind1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
kindDoc1 <- docSharedWrapper layoutType kind1
hasParens <- hasAnnKeyword ltype AnnOpenP
@ -640,7 +738,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
#if MIN_VERSION_ghc(8,6,0)
HsTyLit _ lit -> case lit of
#else
HsTyLit lit -> case lit of
#endif
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsNumTy NoSourceText _ ->
@ -652,11 +754,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsNumTy srctext _ -> docLit $ Text.pack srctext
HsStrTy srctext _ -> docLit $ Text.pack srctext
#endif
#if !MIN_VERSION_ghc(8,6,0)
HsCoreTy{} -> -- TODO
briDocByExactInlineOnly "HsCoreTy{}" ltype
#endif
HsWildCardTy _ ->
docLit $ Text.pack "_"
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype
#endif
#if MIN_VERSION_ghc(8,6,0)
HsStarTy _ isUnicode -> do
if isUnicode
then docLit $ Text.pack "\x2605" -- Unicode star
else docLit $ Text.pack "*"
XHsType{} -> error "brittany internal error: XHsType"
#endif

4
src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
View File

@ -203,6 +203,7 @@ transformAlts =
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False
-- TODO: use COMPLETE pragma instead?
lineCheck _ = error "ghc exhaustive check is insufficient"
lconf <- _conf_layout <$> mAsk
#if INSERTTRACESALT
@ -462,7 +463,8 @@ getSpacing !bridoc = rec bridoc
$ LineModeValid
$ VerticalSpacing 0 VerticalSpacingParNone False
BDFLines ls@(_:_) -> do
lSps@(mVs:_) <- rec `mapM` ls
lSps <- rec `mapM` ls
let (mVs:_) = lSps -- separated into let to avoid MonadFail
return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
| VerticalSpacing lsp _ _ <- mVs
, lineMax <- getMaxVS $ maxVs $ lSps