From 34735e27ef7c9a8ee929034e8256eaf9c9c2b271 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Jul 2018 19:55:49 +0200 Subject: [PATCH 1/2] Add compat with GHC-8.6 API --- brittany.cabal | 8 +- src/Language/Haskell/Brittany/Internal.hs | 18 + .../Brittany/Internal/ExactPrintUtils.hs | 26 +- .../Brittany/Internal/Layouters/Decl.hs | 128 ++++- .../Brittany/Internal/Layouters/Expr.hs | 440 ++++++++++++------ .../Haskell/Brittany/Internal/Layouters/IE.hs | 26 +- .../Brittany/Internal/Layouters/Import.hs | 4 + .../Brittany/Internal/Layouters/Pattern.hs | 68 ++- .../Brittany/Internal/Layouters/Stmt.hs | 20 + .../Brittany/Internal/Layouters/Type.hs | 119 ++++- .../Brittany/Internal/Transformations/Alt.hs | 4 +- 11 files changed, 678 insertions(+), 183 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index da69f91..9f04fff 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -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 } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 5b6e7ef..9720106 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 7c582f1..0c4f901 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -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, _), _) = diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 2616312..37724f6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3ade42e..cab2baa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 42329cf..0407a3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index fc43ecf..bcce106 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index f409c30..e77856c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -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] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 7a9b922..3fd5f8a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 5e97d5b..5bbbc4c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index b73fc77..b9458fb 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -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 From e7d8f59e93e3b1e7d469d1220580084c9eda86c9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 19 Aug 2018 15:10:24 +0200 Subject: [PATCH 2/2] travis-ci: Add ghc-8.6, Clean up a bit --- .travis.yml | 56 +------------------ .../Haskell/Brittany/Internal/Config.hs | 1 + 2 files changed, 4 insertions(+), 53 deletions(-) diff --git a/.travis.yml b/.travis.yml index fc67cae..ce2e49a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,26 +40,6 @@ before_cache: # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} matrix: include: - # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: - # https://github.com/hvr/multi-ghc-travis - #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.0.4" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.2.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.4.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.6.3" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.8.4" - # addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.10.3" - # addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} ##### OSX test via stack ##### @@ -79,6 +59,9 @@ matrix: - env: BUILD=cabal GHCVER=8.4.3 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.4.3" addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.6.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.6.1" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. @@ -106,18 +89,6 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-2" - # compiler: ": #stack 7.8.4" - # addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-3" - # compiler: ": #stack 7.10.2" - # addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-6" - # compiler: ": #stack 7.10.3" - # addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-7" - # compiler: ": #stack 8.0.1" - # addons: {apt: {packages: [libgmp-dev]}} - env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml" compiler: ": #stack 8.0.2" addons: {apt: {packages: [libgmp-dev]}} @@ -130,27 +101,6 @@ matrix: compiler: ": #stack nightly" addons: {apt: {packages: [libgmp-dev]}} - # Travis includes an macOS which is incompatible with GHC 7.8.4 - #- env: BUILD=stack ARGS="--resolver lts-2" - # compiler: ": #stack 7.8.4 osx" - # os: osx - - #- env: BUILD=stack ARGS="--resolver lts-3" - # compiler: ": #stack 7.10.2 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver lts-6" - # compiler: ": #stack 7.10.3 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver lts-7" - # compiler: ": #stack 8.0.1 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver lts-8" - # compiler: ": #stack 8.0.2 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver nightly" - # compiler: ": #stack nightly osx" - # os: osx - allow_failures: #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=stack ARGS="--resolver nightly" diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 2e63b49..464bd3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -231,6 +231,7 @@ cmdlineConfigParser = do readConfig :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Option)) readConfig path = do + -- TODO: probably should catch IOErrors and then omit the existence check. exists <- liftIO $ System.Directory.doesFileExist path if exists then do