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

Get everything building with (only) GHC 9.0

pull/357/head
Taylor Fausak 2021-10-30 16:20:13 +00:00 committed by GitHub
parent 7bd98ffb1c
commit 116930ac2b
20 changed files with 162 additions and 382 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.vscode/extensions.json vendored Normal file
View File

@ -0,0 +1,5 @@
{
"recommendations": [
"haskell.haskell"
]
}

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

@ -53,21 +53,17 @@ import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC as GHC import qualified GHC as GHC
hiding ( parseModule ) hiding ( parseModule )
import ApiAnnotation ( AnnKeywordId(..) ) import GHC.Parser.Annotation ( AnnKeywordId(..) )
import GHC ( Located import GHC ( Located
, runGhc , runGhc
, GenLocated(L) , GenLocated(L)
, moduleNameString , moduleNameString
) )
import RdrName ( RdrName(..) ) import GHC.Types.Name.Reader ( RdrName(..) )
import SrcLoc ( SrcSpan ) import GHC.Types.SrcLoc ( SrcSpan )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
import Bag import GHC.Data.Bag
#else import qualified GHC.Driver.Session as GHC
import HsSyn
#endif
import qualified DynFlags as GHC
import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.LanguageExtensions.Type as GHC
import Data.Char ( isSpace ) import Data.Char ( isSpace )
@ -226,7 +222,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
getTopLevelDeclNameMap (L _ (HsModule _name _exports _ decls _ _)) = getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
TopLevelDeclNameMap $ Map.fromList TopLevelDeclNameMap $ Map.fromList
[ (ExactPrint.mkAnnKey decl, name) [ (ExactPrint.mkAnnKey decl, name)
| decl <- decls | decl <- decls
@ -385,11 +381,7 @@ parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
case parseResult of case parseResult of
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
#else
Left (_ , s ) -> return $ Left $ "parsing error: " ++ s
#endif
Right (anns, parsedModule) -> runExceptT $ do Right (anns, parsedModule) -> runExceptT $ do
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
@ -460,8 +452,8 @@ toLocal conf anns m = do
MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)
pure x pure x
ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM () ppModule :: GenLocated SrcSpan HsModule -> PPM ()
ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
post <- ppPreamble lmod post <- ppPreamble lmod
decls `forM_` \decl -> do decls `forM_` \decl -> do
let declAnnKey = ExactPrint.mkAnnKey decl let declAnnKey = ExactPrint.mkAnnKey decl
@ -505,10 +497,10 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
(ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
ppmMoveToExactLoc l ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr mTell $ Text.Builder.fromString cmStr
(ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> (ExactPrint.G _, (ExactPrint.DP (eofZ, eofX))) ->
let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
ExactPrint.AnnComment cm ExactPrint.AnnComment cm
| GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm | span <- ExactPrint.commentIdentifier cm
-> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
) )
@ -520,16 +512,16 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames :: LHsDecl GhcPs -> [String]
getDeclBindingNames (L _ decl) = case decl of getDeclBindingNames (L _ decl) = case decl of
SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
ValD _ (FunBind _ (L _ n) _ _ _) -> [Text.unpack $ rdrNameToText n] ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
_ -> [] _ -> []
-- Prints the information associated with the module annotation -- Prints the information associated with the module annotation
-- This includes the imports -- This includes the imports
ppPreamble ppPreamble
:: GenLocated SrcSpan (HsModule GhcPs) :: GenLocated SrcSpan HsModule
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _ _)) = do
filteredAnns <- mAsk <&> \annMap -> filteredAnns <- mAsk <&> \annMap ->
Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
-- Since ghc-exactprint adds annotations following (implicit) -- Since ghc-exactprint adds annotations following (implicit)
@ -550,15 +542,10 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
modAnnsDp = ExactPrint.annsDP mAnn modAnnsDp = ExactPrint.annsDP mAnn
isWhere (ExactPrint.G AnnWhere) = True isWhere (ExactPrint.G AnnWhere) = True
isWhere _ = False isWhere _ = False
isEof (ExactPrint.G AnnEofPos) = True
isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp (pre, post') = case whereInd of
(pre, post') = case (whereInd, eofInd) of Nothing -> ([], modAnnsDp)
(Nothing, Nothing) -> ([], modAnnsDp) Just i -> List.splitAt (i + 1) modAnnsDp
(Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp)
(Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp
mAnn' = mAnn { ExactPrint.annsDP = pre } mAnn' = mAnn { ExactPrint.annsDP = pre }
filteredAnns'' = filteredAnns'' =
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
@ -585,7 +572,7 @@ _sigHead = \case
_bindHead :: HsBind GhcPs -> String _bindHead :: HsBind GhcPs -> String
_bindHead = \case _bindHead = \case
FunBind _ fId _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth" PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind" _ -> "unknown bind"

14
src/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

@ -340,16 +340,16 @@ data ExactPrintFallbackMode
-- A PROGRAM BY TRANSFORMING IT. -- A PROGRAM BY TRANSFORMING IT.
deriving (Show, Generic, Data) deriving (Show, Generic, Data)
instance CFunctor CDebugConfig
instance CFunctor CLayoutConfig
instance CFunctor CErrorHandlingConfig
instance CFunctor CForwardOptions
instance CFunctor CPreProcessorConfig
instance CFunctor CConfig
deriveCZipWith ''CDebugConfig deriveCZipWith ''CDebugConfig
deriveCZipWith ''CLayoutConfig deriveCZipWith ''CLayoutConfig
deriveCZipWith ''CErrorHandlingConfig deriveCZipWith ''CErrorHandlingConfig
deriveCZipWith ''CForwardOptions deriveCZipWith ''CForwardOptions
deriveCZipWith ''CPreProcessorConfig deriveCZipWith ''CPreProcessorConfig
deriveCZipWith ''CConfig deriveCZipWith ''CConfig
instance CFunctor CDebugConfig
instance CFunctor CLayoutConfig
instance CFunctor CErrorHandlingConfig
instance CFunctor CForwardOptions
instance CFunctor CPreProcessorConfig
instance CFunctor CConfig

22
src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs
View File

@ -21,6 +21,7 @@ where
#include "prelude.inc" #include "prelude.inc"
import Data.Yaml import Data.Yaml
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson.Types as Aeson
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
@ -113,18 +114,17 @@ makeToJSONMaybe(CConfig)
-- config file content. -- config file content.
instance FromJSON (CConfig Maybe) where instance FromJSON (CConfig Maybe) where
parseJSON (Object v) = Config parseJSON (Object v) = Config
<$> v .:? Text.pack "conf_version" <$> v .:? Key.fromString "conf_version"
<*> v .:?= Text.pack "conf_debug" <*> v .:?= Key.fromString "conf_debug"
<*> v .:?= Text.pack "conf_layout" <*> v .:?= Key.fromString "conf_layout"
<*> v .:?= Text.pack "conf_errorHandling" <*> v .:?= Key.fromString "conf_errorHandling"
<*> v .:?= Text.pack "conf_forward" <*> v .:?= Key.fromString "conf_forward"
<*> v .:?= Text.pack "conf_preprocessor" <*> v .:?= Key.fromString "conf_preprocessor"
<*> v .:? Text.pack "conf_roundtrip_exactprint_only" <*> v .:? Key.fromString "conf_roundtrip_exactprint_only"
<*> v .:? Text.pack "conf_disable_formatting" <*> v .:? Key.fromString "conf_disable_formatting"
<*> v .:? Text.pack "conf_obfuscate" <*> v .:? Key.fromString "conf_obfuscate"
parseJSON invalid = Aeson.typeMismatch "Config" invalid parseJSON invalid = Aeson.typeMismatch "Config" invalid
-- Pretends that the value is {} when the key is not present. -- Pretends that the value is {} when the key is not present.
(.:?=) :: FromJSON a => Object -> Text -> Parser a (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a
o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure

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

@ -20,27 +20,22 @@ import Language.Haskell.Brittany.Internal.Utils
import Data.Data import Data.Data
import Data.HList.HList import Data.HList.HList
import DynFlags ( getDynFlags ) import GHC.Driver.Session ( getDynFlags )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import qualified DynFlags as GHC import qualified GHC.Driver.Session as GHC
import qualified GHC as GHC hiding (parseModule) import qualified GHC as GHC hiding (parseModule)
import qualified Parser as GHC import qualified GHC.Parser as GHC
import qualified SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import qualified FastString as GHC import qualified GHC.Data.FastString as GHC
import qualified GHC as GHC hiding (parseModule) import qualified GHC.Parser.Lexer as GHC
import qualified Lexer as GHC import qualified GHC.Data.StringBuffer as GHC
import qualified StringBuffer as GHC import qualified GHC.Utils.Outputable as GHC
import qualified Outputable as GHC import qualified GHC.Driver.CmdLine as GHC
import qualified CmdLineParser as GHC
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
import Bag import GHC.Data.Bag
#else
import HsSyn
#endif
import SrcLoc ( SrcSpan, Located ) import GHC.Types.SrcLoc ( SrcSpan, Located )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
@ -96,11 +91,7 @@ parseModuleWithCpp cpp opts args fp dynCheck =
++ show (warnings <&> warnExtractorCompat) ++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err)))
#else
either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
#endif
(\(a, m) -> pure (a, m, x)) (\(a, m) -> pure (a, m, x))
$ ExactPrint.postParseTransform res opts $ ExactPrint.postParseTransform res opts
@ -133,11 +124,7 @@ parseModuleFromString args fp dynCheck str =
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of case res of
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
#else
Left (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err
#endif
Right (a , m ) -> pure (a, m, dynCheckRes) Right (a , m ) -> pure (a, m, dynCheckRes)
@ -153,7 +140,7 @@ commentAnnFixTransformGlob ast = do
annsMap = Map.fromListWith annsMap = Map.fromListWith
(flip const) (flip const)
[ (GHC.realSrcSpanEnd span, annKey) [ (GHC.realSrcSpanEnd span, annKey)
| (GHC.RealSrcSpan span, annKey) <- Foldable.toList nodes | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
] ]
nodes `forM_` (snd .> processComs annsMap) nodes `forM_` (snd .> processComs annsMap)
where where
@ -168,9 +155,8 @@ commentAnnFixTransformGlob ast = do
:: (ExactPrint.Comment, ExactPrint.DeltaPos) :: (ExactPrint.Comment, ExactPrint.DeltaPos)
-> ExactPrint.TransformT Identity Bool -> ExactPrint.TransformT Identity Bool
processCom comPair@(com, _) = processCom comPair@(com, _) =
case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
GHC.UnhelpfulLoc{} -> return True -- retain comment at current node. comLoc -> case Map.lookupLE comLoc annsMap of
GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False move $> False
@ -179,8 +165,8 @@ commentAnnFixTransformGlob ast = do
where where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.srcSpanStart annKeyLoc1 loc1 = GHC.realSrcSpanStart annKeyLoc1
loc2 = GHC.srcSpanStart annKeyLoc2 loc2 = GHC.realSrcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns -> move = ExactPrint.modifyAnnsT $ \anns ->
let let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
@ -271,12 +257,12 @@ moveTrailingComments astFrom astTo = do
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have. -- implementation would have.
extractToplevelAnns extractToplevelAnns
:: Located (HsModule GhcPs) :: Located HsModule
-> ExactPrint.Anns -> ExactPrint.Anns
-> Map ExactPrint.AnnKey ExactPrint.Anns -> Map ExactPrint.AnnKey ExactPrint.Anns
extractToplevelAnns lmod anns = output extractToplevelAnns lmod anns = output
where where
(L _ (HsModule _ _ _ ldecls _ _)) = lmod (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod
declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
declMap1 = Map.unions $ ldecls <&> \ldecl -> declMap1 = Map.unions $ ldecls <&> \ldecl ->
Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)

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

@ -99,13 +99,13 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.ExactPrintUtils
import RdrName ( RdrName(..) ) import GHC.Types.Name.Reader ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
import qualified SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import OccName ( occNameString ) import GHC.Types.Name.Occurrence ( occNameString )
import Name ( getOccString ) import GHC.Types.Name ( getOccString )
import Module ( moduleName ) import GHC ( moduleName )
import ApiAnnotation ( AnnKeywordId(..) ) import GHC.Parser.Annotation ( AnnKeywordId(..) )
import Data.Data import Data.Data
import Data.Generics.Schemes import Data.Generics.Schemes
@ -299,7 +299,7 @@ filterAnns ast =
-- b) after (in source code order) the node. -- b) after (in source code order) the node.
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) = hasAnyCommentsBelow ast@(L l _) =
List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
<$> astConnectedComments ast <$> astConnectedComments ast
hasCommentsBetween hasCommentsBetween

32
src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

@ -16,16 +16,12 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import RdrName ( RdrName(..) ) import GHC.Types.Name.Reader ( RdrName(..) )
import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
import qualified GHC import qualified GHC
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn import GHC.Types.Basic
#endif
import Name
import BasicTypes
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Type
@ -34,7 +30,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Bag ( mapBagM ) import GHC.Data.Bag ( mapBagM )
@ -242,11 +238,11 @@ createContextDoc (t1 : tR) = do
] ]
] ]
createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc :: [LHsTyVarBndr tag GhcPs] -> ToBriDocM BriDocNumbered
createBndrDoc bs = do createBndrDoc bs = do
tyVarDocs <- bs `forM` \case tyVarDocs <- bs `forM` \case
(L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
(L _ (KindedTyVar _ext lrdrName kind)) -> do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d) return $ (lrdrNameToText lrdrName, Just $ d)
(L _ (XTyVarBndr ext)) -> absurdExt ext (L _ (XTyVarBndr ext)) -> absurdExt ext
@ -334,21 +330,21 @@ createDetailsDoc consNameStr details = case details of
, docForceSingleline , docForceSingleline
$ docSeq $ docSeq
$ List.intersperse docSeparator $ List.intersperse docSeparator
$ args <&> layoutType $ fmap hsScaledThing args <&> layoutType
] ]
leftIndented = docSetParSpacing leftIndented = docSetParSpacing
. docAddBaseY BrIndentRegular . docAddBaseY BrIndentRegular
. docPar (docLit consNameStr) . docPar (docLit consNameStr)
. docLines . docLines
$ layoutType <$> args $ layoutType <$> fmap hsScaledThing args
multiAppended = docSeq multiAppended = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
, docSetBaseY $ docLines $ layoutType <$> args , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args
] ]
multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
(docLit consNameStr) (docLit consNameStr)
(docLines $ layoutType <$> args) (docLines $ layoutType <$> fmap hsScaledThing args)
case indentPolicy of case indentPolicy of
IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyLeft -> docAlt [singleLine, leftIndented]
IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]
@ -424,11 +420,11 @@ createDetailsDoc consNameStr details = case details of
] ]
) )
InfixCon arg1 arg2 -> docSeq InfixCon arg1 arg2 -> docSeq
[ layoutType arg1 [ layoutType $ hsScaledThing arg1
, docSeparator , docSeparator
, docLit consNameStr , docLit consNameStr
, docSeparator , docSeparator
, layoutType arg2 , layoutType $ hsScaledThing arg2
] ]
where where
mkFieldDocs mkFieldDocs
@ -438,7 +434,7 @@ createDetailsDoc consNameStr details = case details of
L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
L _ (XConDeclField x) -> absurdExt x L _ (XConDeclField x) -> absurdExt x
createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc :: [LHsTyVarBndr tag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
createForallDoc [] = Nothing createForallDoc [] = Nothing
createForallDoc lhsTyVarBndrs = Just $ docSeq createForallDoc lhsTyVarBndrs = Just $ docSeq
[docLitS "forall ", createBndrDoc lhsTyVarBndrs] [docLitS "forall ", createBndrDoc lhsTyVarBndrs]

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

@ -27,6 +27,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
@ -35,17 +36,12 @@ import GHC ( runGhc
, moduleNameString , moduleNameString
, AnnKeywordId(..) , AnnKeywordId(..)
) )
import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import GHC.Types.SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc )
import qualified FastString import qualified GHC.Data.FastString as FastString
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
import GHC.Hs.Extension (NoExtField (..)) import GHC.Hs.Extension (NoExtField (..))
#else import GHC.Types.Name
import HsSyn import GHC.Types.Basic ( InlinePragma(..)
import HsExtension (NoExt (..))
#endif
import Name
import BasicTypes ( InlinePragma(..)
, Activation(..) , Activation(..)
, InlineSpec(..) , InlineSpec(..)
, RuleMatchInfo(..) , RuleMatchInfo(..)
@ -59,7 +55,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Language.Haskell.Brittany.Internal.Layouters.DataDecl
import Bag ( mapBagM, bagToList, emptyBag ) import GHC.Data.Bag ( mapBagM, bagToList, emptyBag )
import Data.Char (isUpper) import Data.Char (isUpper)
@ -145,7 +141,7 @@ specStringCompat ast = \case
layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BodyStmt _ body _ _ -> layoutExpr body BodyStmt _ body _ _ -> layoutExpr body
BindStmt _ lPat expr _ _ -> do BindStmt _ lPat expr -> do
patDoc <- docSharedWrapper layoutPat lPat patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt docCols ColBindStmt
@ -164,7 +160,7 @@ layoutBind
(HsBindLR GhcPs GhcPs) (HsBindLR GhcPs GhcPs)
(Either [BriDocNumbered] BriDocNumbered) (Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of layoutBind lbind@(L _ bind) = case bind of
FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do
idStr <- lrdrNameToTextAnn fId idStr <- lrdrNameToTextAnn fId
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
funcPatDocs <- funcPatDocs <-
@ -186,11 +182,7 @@ layoutBind lbind@(L _ bind) = case bind of
clauseDocs clauseDocs
mWhereArg mWhereArg
hasComments hasComments
#if MIN_VERSION_ghc(8,8,0)
PatSynBind _ (PSB _ patID lpat rpat dir) -> do PatSynBind _ (PSB _ patID lpat rpat dir) -> do
#else
PatSynBind _ (PSB _ patID lpat rpat dir) -> do
#endif
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID fmap Right $ docWrapNode lbind $ layoutPatSynBind patID
lpat lpat
dir dir
@ -226,7 +218,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
let unordered = let unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ] [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ] ++ [ BagSig s | s <- sigs ]
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered ordered = sortBy (comparing $ ExactPrint.rs . bindOrSigtoSrcSpan) unordered
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s BagSig s -> return <$> layoutSig s
@ -734,7 +726,7 @@ layoutSynDecl
:: Bool :: Bool
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
-> Located (IdP GhcPs) -> Located (IdP GhcPs)
-> [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs -> LHsType GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutSynDecl isInfix wrapNodeRest name vars typ = do layoutSynDecl isInfix wrapNodeRest name vars typ = do
@ -771,14 +763,14 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
hasComments <- hasAnyCommentsConnected typ hasComments <- hasAnyCommentsConnected typ
layoutLhsAndType hasComments sharedLhs "=" typeDoc layoutLhsAndType hasComments sharedLhs "=" typeDoc
layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())
layoutTyVarBndr needsSep lbndr@(L _ bndr) = do layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
docWrapNodePrior lbndr $ case bndr of docWrapNodePrior lbndr $ case bndr of
XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" XTyVarBndr{} -> error "brittany internal error: XTyVarBndr"
UserTyVar _ name -> do UserTyVar _ _ name -> do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] docSeq $ [docSeparator | needsSep] ++ [docLit nameStr]
KindedTyVar _ name kind -> do KindedTyVar _ _ name kind -> do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
docSeq docSeq
$ [ docSeparator | needsSep ] $ [ docSeparator | needsSep ]
@ -804,16 +796,10 @@ layoutTyFamInstDecl
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutTyFamInstDecl inClass outerNode tfid = do layoutTyFamInstDecl inClass outerNode tfid = do
let let
#if MIN_VERSION_ghc(8,8,0)
FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid
-- bndrsMay isJust e.g. with -- bndrsMay isJust e.g. with
-- type instance forall a . MyType (Maybe a) = Either () a -- type instance forall a . MyType (Maybe a) = Either () a
innerNode = outerNode innerNode = outerNode
#else
FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid
bndrsMay = Nothing
innerNode = outerNode
#endif
docWrapNodePrior outerNode $ do docWrapNodePrior outerNode $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
needsParens <- hasAnnKeyword outerNode AnnOpenP needsParens <- hasAnnKeyword outerNode AnnOpenP
@ -822,7 +808,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
then docLit $ Text.pack "type" then docLit $ Text.pack "type"
else docSeq else docSeq
[appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]
makeForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered
makeForallDoc bndrs = do makeForallDoc bndrs = do
bndrDocs <- layoutTyVarBndrs bndrs bndrDocs <- layoutTyVarBndrs bndrs
docSeq docSeq
@ -845,7 +831,6 @@ layoutTyFamInstDecl inClass outerNode tfid = do
layoutLhsAndType hasComments lhs "=" typeDoc layoutLhsAndType hasComments lhs "=" typeDoc
#if MIN_VERSION_ghc(8,8,0)
layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = pats <&> \case layoutHsTyPats pats = pats <&> \case
HsValArg tm -> layoutType tm HsValArg tm -> layoutType tm
@ -854,10 +839,6 @@ layoutHsTyPats pats = pats <&> \case
-- is a bit strange. Hopefully this does not ignore any important -- is a bit strange. Hopefully this does not ignore any important
-- annotations. -- annotations.
HsArgPar _l -> error "brittany internal error: HsArgPar{}" HsArgPar _l -> error "brittany internal error: HsArgPar{}"
#else
layoutHsTyPats :: [LHsType GhcPs] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = layoutType <$> pats
#endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- ClsInstDecl -- ClsInstDecl
@ -881,21 +862,12 @@ layoutClsInst lcid@(L _ cid) = docLines
] ]
where where
layoutInstanceHead :: ToBriDocM BriDocNumbered layoutInstanceHead :: ToBriDocM BriDocNumbered
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
layoutInstanceHead = layoutInstanceHead =
briDocByExactNoComment briDocByExactNoComment
$ InstD NoExtField $ InstD NoExtField
. ClsInstD NoExtField . ClsInstD NoExtField
. removeChildren . removeChildren
<$> lcid <$> lcid
#else
layoutInstanceHead =
briDocByExactNoComment
$ InstD NoExt
. ClsInstD NoExt
. removeChildren
<$> lcid
#endif
removeChildren :: ClsInstDecl p -> ClsInstDecl p removeChildren :: ClsInstDecl p -> ClsInstDecl p
removeChildren c = c removeChildren c = c
@ -909,7 +881,7 @@ layoutClsInst lcid@(L _ cid) = docLines
docSortedLines docSortedLines
:: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
docSortedLines l = docSortedLines l =
allocateNode . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l
layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig

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

@ -19,14 +19,10 @@ import Language.Haskell.Brittany.Internal.Config.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn import qualified GHC.Data.FastString as FastString
#endif import GHC.Types.Basic
import Name
import qualified FastString
import BasicTypes
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.Pattern
@ -46,9 +42,8 @@ layoutExpr lexpr@(L _ expr) = do
docWrapNode lexpr $ case expr of docWrapNode lexpr $ case expr of
HsVar _ vname -> do HsVar _ vname -> do
docLit =<< lrdrNameToTextAnn vname docLit =<< lrdrNameToTextAnn vname
HsUnboundVar _ var -> case var of HsUnboundVar _ oname ->
OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname docLit $ Text.pack $ occNameString oname
TrueExprHole oname -> docLit $ Text.pack $ occNameString oname
HsRecFld{} -> do HsRecFld{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsRecFld" lexpr briDocByExactInlineOnly "HsRecFld" lexpr
@ -79,8 +74,8 @@ layoutExpr lexpr@(L _ expr) = do
-- by wrapping it in docSeq below. We _could_ add alignments for -- by wrapping it in docSeq below. We _could_ add alignments for
-- stuff like lists-of-lambdas. Nothing terribly important..) -- stuff like lists-of-lambdas. Nothing terribly important..)
let shouldPrefixSeparator = case p of let shouldPrefixSeparator = case p of
(ghcDL -> L _ LazyPat{}) -> isFirst L _ LazyPat{} -> isFirst
(ghcDL -> L _ BangPat{}) -> isFirst L _ BangPat{} -> isFirst
_ -> False _ -> False
patDocSeq <- layoutPat p patDocSeq <- layoutPat p
fixed <- case Seq.viewl patDocSeq of fixed <- case Seq.viewl patDocSeq of
@ -235,15 +230,9 @@ layoutExpr lexpr@(L _ expr) = do
expDoc1 expDoc1
expDoc2 expDoc2
] ]
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */
HsAppType _ _ XHsWildCardBndrs{} -> HsAppType _ _ XHsWildCardBndrs{} ->
error "brittany internal error: HsAppType XHsWildCardBndrs" error "brittany internal error: HsAppType XHsWildCardBndrs"
HsAppType _ exp1 (HsWC _ ty1) -> do HsAppType _ exp1 (HsWC _ ty1) -> do
#else
HsAppType XHsWildCardBndrs{} _ ->
error "brittany internal error: HsAppType XHsWildCardBndrs"
HsAppType (HsWC _ ty1) exp1 -> do
#endif
t <- docSharedWrapper layoutType ty1 t <- docSharedWrapper layoutType ty1
e <- docSharedWrapper layoutExpr exp1 e <- docSharedWrapper layoutExpr exp1
docAlt docAlt
@ -400,17 +389,10 @@ layoutExpr lexpr@(L _ expr) = do
rightDoc <- docSharedWrapper layoutExpr right rightDoc <- docSharedWrapper layoutExpr right
docSeq [opDoc, docSeparator, rightDoc] docSeq [opDoc, docSeparator, rightDoc]
ExplicitTuple _ args boxity -> do ExplicitTuple _ args boxity -> do
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
let argExprs = args <&> \arg -> case arg of let argExprs = args <&> \arg -> case arg of
(L _ (Present _ e)) -> (arg, Just e); (L _ (Present _ e)) -> (arg, Just e);
(L _ (Missing NoExtField)) -> (arg, Nothing) (L _ (Missing NoExtField)) -> (arg, Nothing)
(L _ XTupArg{}) -> error "brittany internal error: XTupArg" (L _ XTupArg{}) -> error "brittany internal error: XTupArg"
#else
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"
#endif
argDocs <- forM argExprs argDocs <- forM argExprs
$ docSharedWrapper $ docSharedWrapper
$ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM
@ -496,7 +478,7 @@ layoutExpr lexpr@(L _ expr) = do
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
) )
] ]
HsIf _ _ ifExpr thenExpr elseExpr -> do HsIf _ ifExpr thenExpr elseExpr -> do
ifExprDoc <- docSharedWrapper layoutExpr ifExpr ifExprDoc <- docSharedWrapper layoutExpr ifExpr
thenExprDoc <- docSharedWrapper layoutExpr thenExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr
elseExprDoc <- docSharedWrapper layoutExpr elseExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr
@ -723,14 +705,14 @@ layoutExpr lexpr@(L _ expr) = do
_ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]
-- docSeq [appSep $ docLit "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1]
HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of
DoExpr -> do DoExpr _ -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
docSetParSpacing docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar
(docLit $ Text.pack "do") (docLit $ Text.pack "do")
(docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)
MDoExpr -> do MDoExpr _ -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
docSetParSpacing docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
@ -829,18 +811,10 @@ layoutExpr lexpr@(L _ expr) = do
else Just <$> docSharedWrapper layoutExpr rFExpr else Just <$> docSharedWrapper layoutExpr rFExpr
return $ (lfield, lrdrNameToText lnameF, rFExpDoc) return $ (lfield, lrdrNameToText lnameF, rFExpDoc)
recordExpression False indentPolicy lexpr nameDoc rFs recordExpression False indentPolicy lexpr nameDoc rFs
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
HsRecFields [] (Just (L _ 0)) -> do HsRecFields [] (Just (L _ 0)) -> do
#else
HsRecFields [] (Just 0) -> do
#endif
let t = lrdrNameToText lname let t = lrdrNameToText lname
docWrapNode lname $ docLit $ t <> Text.pack " { .. }" docWrapNode lname $ docLit $ t <> Text.pack " { .. }"
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do
#else
HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do
#endif
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do
let FieldOcc _ lnameF = fieldOcc let FieldOcc _ lnameF = fieldOcc
@ -863,19 +837,11 @@ layoutExpr lexpr@(L _ expr) = do
XAmbiguousFieldOcc{} -> XAmbiguousFieldOcc{} ->
error "brittany internal error: XAmbiguousFieldOcc" error "brittany internal error: XAmbiguousFieldOcc"
recordExpression False indentPolicy lexpr rExprDoc rFs recordExpression False indentPolicy lexpr rExprDoc rFs
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */
ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) -> ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) ->
error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs"
ExprWithTySig _ _ XHsWildCardBndrs{} -> ExprWithTySig _ _ XHsWildCardBndrs{} ->
error "brittany internal error: ExprWithTySig XHsWildCardBndrs" error "brittany internal error: ExprWithTySig XHsWildCardBndrs"
ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do
#else
ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ ->
error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs"
ExprWithTySig XHsWildCardBndrs{} _ ->
error "brittany internal error: ExprWithTySig XHsWildCardBndrs"
ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do
#endif
expDoc <- docSharedWrapper layoutExpr exp1 expDoc <- docSharedWrapper layoutExpr exp1
typDoc <- docSharedWrapper layoutType typ1 typDoc <- docSharedWrapper layoutType typ1
docSeq docSeq
@ -927,12 +893,6 @@ layoutExpr lexpr@(L _ expr) = do
] ]
ArithSeq{} -> ArithSeq{} ->
briDocByExactInlineOnly "ArithSeq" lexpr briDocByExactInlineOnly "ArithSeq" lexpr
HsSCC{} -> do
-- TODO
briDocByExactInlineOnly "HsSCC{}" lexpr
HsCoreAnn{} -> do
-- TODO
briDocByExactInlineOnly "HsCoreAnn{}" lexpr
HsBracket{} -> do HsBracket{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsBracket{}" lexpr briDocByExactInlineOnly "HsBracket{}" lexpr
@ -959,43 +919,12 @@ layoutExpr lexpr@(L _ expr) = do
HsStatic{} -> do HsStatic{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsStatic{}" lexpr briDocByExactInlineOnly "HsStatic{}" lexpr
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
#else
HsArrApp{} -> do
-- TODO
briDocByExactInlineOnly "HsArrApp{}" lexpr
HsArrForm{} -> do
-- TODO
briDocByExactInlineOnly "HsArrForm{}" lexpr
#endif
HsTick{} -> do HsTick{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsTick{}" lexpr briDocByExactInlineOnly "HsTick{}" lexpr
HsBinTick{} -> do HsBinTick{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsBinTick{}" lexpr briDocByExactInlineOnly "HsBinTick{}" lexpr
HsTickPragma{} -> do
-- TODO
briDocByExactInlineOnly "HsTickPragma{}" lexpr
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
#else
EWildPat{} -> do
docLit $ Text.pack "_"
EAsPat _ asName asExpr -> do
docSeq
[ docLit $ lrdrNameToText asName <> Text.pack "@"
, layoutExpr asExpr
]
EViewPat{} -> do
-- TODO
briDocByExactInlineOnly "EViewPat{}" lexpr
ELazyPat{} -> do
-- TODO
briDocByExactInlineOnly "ELazyPat{}" lexpr
#endif
HsWrap{} -> do
-- TODO
briDocByExactInlineOnly "HsWrap{}" lexpr
HsConLikeOut{} -> do HsConLikeOut{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsWrap{}" lexpr briDocByExactInlineOnly "HsWrap{}" lexpr

6
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
View File

@ -15,12 +15,8 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn
#endif
import Name

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

@ -20,17 +20,12 @@ import GHC ( unLoc
, Located , Located
, ModuleName , ModuleName
) )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
import GHC.Hs.ImpExp import GHC.Hs.ImpExp
#else import GHC.Types.Name
import HsSyn import GHC.Types.FieldLabel
import HsImpExp import qualified GHC.Data.FastString
#endif import GHC.Types.Basic
import Name
import FieldLabel
import qualified FastString
import BasicTypes
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils

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

@ -12,15 +12,12 @@ import GHC ( unLoc
, moduleNameString , moduleNameString
, Located , Located
) )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn import GHC.Types.FieldLabel
#endif import qualified GHC.Data.FastString
import Name import GHC.Types.Basic
import FieldLabel import GHC.Unit.Types (IsBootInterface(..))
import qualified FastString
import BasicTypes
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
@ -50,14 +47,10 @@ layoutImport importD = case importD of
hiding = maybe False fst mllies hiding = maybe False fst mllies
minQLength = length "import qualified " minQLength = length "import qualified "
qLengthReal = qLengthReal =
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
let qualifiedPart = if q /= NotQualified then length "qualified " else 0 let qualifiedPart = if q /= NotQualified then length "qualified " else 0
#else
let qualifiedPart = if q then length "qualified " else 0
#endif
safePart = if safe then length "safe " else 0 safePart = if safe then length "safe " else 0
pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT
srcPart = if src then length "{-# SOURCE #-} " else 0 srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 }
in length "import " + srcPart + safePart + qualifiedPart + pkgPart in length "import " + srcPart + safePart + qualifiedPart + pkgPart
qLength = max minQLength qLengthReal qLength = max minQLength qLengthReal
-- Cost in columns of importColumn -- Cost in columns of importColumn
@ -66,13 +59,9 @@ layoutImport importD = case importD of
nameCost = Text.length modNameT + qLength nameCost = Text.length modNameT + qLength
importQualifiers = docSeq importQualifiers = docSeq
[ appSep $ docLit $ Text.pack "import" [ appSep $ docLit $ Text.pack "import"
, if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty }
, if safe then appSep $ docLit $ Text.pack "safe" else docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
, if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty
#else
, if q then appSep $ docLit $ Text.pack "qualified" else docEmpty
#endif
, maybe docEmpty (appSep . docLit) pkgNameT , maybe docEmpty (appSep . docLit) pkgNameT
] ]
indentName = indentName =

19
src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -11,17 +11,12 @@ import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..))
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
import GHC.Hs.ImpExp import GHC.Hs.ImpExp
#else import GHC.Types.Name
import HsSyn import GHC.Types.FieldLabel
import HsImpExp import qualified GHC.Data.FastString
#endif import GHC.Types.Basic
import Name
import FieldLabel
import qualified FastString
import BasicTypes
import Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types
@ -34,16 +29,16 @@ import Language.Haskell.Brittany.Internal.Utils
layoutModule :: ToBriDoc HsModule layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of layoutModule lmod@(L _ mod') = case mod' of
-- Implicit module Main -- Implicit module Main
HsModule Nothing _ imports _ _ _ -> do HsModule _ Nothing _ imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
-- sortedImports <- sortImports imports -- sortedImports <- sortImports imports
-- docLines $ [layoutImport y i | (y, i) <- sortedImports] -- docLines $ [layoutImport y i | (y, i) <- sortedImports]
HsModule (Just n) les imports _ _ _ -> do HsModule _ (Just n) les imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports -- sortedImports <- sortImports imports

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

@ -21,13 +21,9 @@ import GHC ( Located
, ol_val , ol_val
) )
import qualified GHC import qualified GHC
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn import GHC.Types.Basic
#endif
import Name
import BasicTypes
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Type
@ -45,7 +41,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type
-- We will use `case .. of` as the imagined prefix to the examples used in -- We will use `case .. of` as the imagined prefix to the examples used in
-- the different cases below. -- the different cases below.
layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr -- _ -> expr
VarPat _ n -> VarPat _ n ->
@ -54,11 +50,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of
LitPat _ lit -> LitPat _ lit ->
fmap Seq.singleton $ allocateNode $ litBriDoc lit fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr -- 0 -> expr
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */
ParPat _ inner -> do ParPat _ inner -> do
#else
ParPat _ inner -> do
#endif
-- (nestedpat) -> expr -- (nestedpat) -> expr
left <- docLit $ Text.pack "(" left <- docLit $ Text.pack "("
right <- docLit $ Text.pack ")" right <- docLit $ Text.pack ")"
@ -78,7 +70,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of
-- x1' <- docSeq [docLit $ Text.pack "(", return x1] -- x1' <- docSeq [docLit $ Text.pack "(", return x1]
-- xN' <- docSeq [return xN, docLit $ Text.pack ")"] -- xN' <- docSeq [return xN, docLit $ Text.pack ")"]
-- return $ (x1' Seq.<| middle) Seq.|> xN' -- return $ (x1' Seq.<| middle) Seq.|> xN'
ConPatIn lname (PrefixCon args) -> do ConPat _ lname (PrefixCon args) -> do
-- Abc a b c -> expr -- Abc a b c -> expr
nameDoc <- lrdrNameToTextAnn lname nameDoc <- lrdrNameToTextAnn lname
argDocs <- layoutPat `mapM` args argDocs <- layoutPat `mapM` args
@ -91,18 +83,18 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of
$ spacifyDocs $ spacifyDocs
$ fmap colsWrapPat argDocs $ fmap colsWrapPat argDocs
return $ x1 Seq.<| xR return $ x1 Seq.<| xR
ConPatIn lname (InfixCon left right) -> do ConPat _ lname (InfixCon left right) -> do
-- a :< b -> expr -- a :< b -> expr
nameDoc <- lrdrNameToTextAnn lname nameDoc <- lrdrNameToTextAnn lname
leftDoc <- appSep . colsWrapPat =<< layoutPat left leftDoc <- appSep . colsWrapPat =<< layoutPat left
rightDoc <- colsWrapPat =<< layoutPat right rightDoc <- colsWrapPat =<< layoutPat right
middle <- appSep $ docLit nameDoc middle <- appSep $ docLit nameDoc
return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do
-- Abc{} -> expr -- Abc{} -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
fmap Seq.singleton $ docLit $ t <> Text.pack "{}" fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
-- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2 -- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname let t = lrdrNameToText lname
@ -126,22 +118,14 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of
, docSeparator , docSeparator
, docLit $ Text.pack "}" , docLit $ Text.pack "}"
] ]
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
ConPatIn lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
#else
ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do
#endif
-- Abc { .. } -> expr -- Abc { .. } -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
Seq.singleton <$> docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, docLit $ Text.pack "{..}" , docLit $ Text.pack "{..}"
] ]
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do
ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do
#else
ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do
#endif
-- Abc { a = locA, .. } -- Abc { a = locA, .. }
let t = lrdrNameToText lname let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
@ -172,11 +156,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of
AsPat _ asName asPat -> do AsPat _ asName asPat -> do
-- bind@nestedpat -> expr -- bind@nestedpat -> expr
wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ SigPat _ pat1 (HsPS _ ty1) -> do
SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do
#else
SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do
#endif
-- i :: Int -> expr -- i :: Int -> expr
patDocs <- layoutPat pat1 patDocs <- layoutPat pat1
tyDoc <- docSharedWrapper layoutType ty1 tyDoc <- docSharedWrapper layoutType ty1
@ -214,7 +194,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of
Just{} -> Seq.fromList [negDoc, litDoc] Just{} -> Seq.fromList [negDoc, litDoc]
Nothing -> Seq.singleton litDoc Nothing -> Seq.singleton litDoc
_ -> return <$> briDocByExactInlineOnly "some unknown pattern" (ghcDL lpat) _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList

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

@ -17,14 +17,10 @@ import GHC ( runGhc
, GenLocated(L) , GenLocated(L)
, moduleNameString , moduleNameString
) )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn import qualified GHC.Data.FastString as FastString
#endif import GHC.Types.Basic
import Name
import qualified FastString
import BasicTypes
import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Decl
@ -38,9 +34,9 @@ layoutStmt lstmt@(L _ stmt) = do
indentAmount :: Int <- indentAmount :: Int <-
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
docWrapNode lstmt $ case stmt of docWrapNode lstmt $ case stmt of
LastStmt _ body False _ -> do LastStmt _ body (Just False) _ -> do
layoutExpr body layoutExpr body
BindStmt _ lPat expr _ _ -> do BindStmt _ lPat expr -> do
patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docAlt docAlt

10
src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
View File

@ -13,14 +13,10 @@ import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn import qualified GHC.Data.FastString
#endif import GHC.Types.Basic
import Name
import qualified FastString
import BasicTypes

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

@ -25,15 +25,11 @@ import GHC ( runGhc
, AnnKeywordId (..) , AnnKeywordId (..)
) )
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs import GHC.Hs
#else import GHC.Types.Name
import HsSyn import GHC.Utils.Outputable ( ftext, showSDocUnsafe )
#endif import GHC.Types.Basic
import Name import qualified GHC.Types.SrcLoc
import Outputable ( ftext, showSDocUnsafe )
import BasicTypes
import qualified SrcLoc
import DataTreePrint import DataTreePrint
@ -45,21 +41,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsTyVar _ promoted name -> do HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of case promoted of
#if MIN_VERSION_ghc(8,8,0)
IsPromoted -> docSeq IsPromoted -> docSeq
#else /* ghc-8.6 */
Promoted -> docSeq
#endif
[ docSeparator [ docSeparator
, docTick , docTick
, docWrapNode name $ docLit t , docWrapNode name $ docLit t
] ]
NotPromoted -> docWrapNode name $ docLit t NotPromoted -> docWrapNode name $ docLit t
#if MIN_VERSION_ghc(8,10,1) HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
HsForAllTy _ _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do let bndrs = hsf_vis_bndrs hsf
#else
HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
#endif
typeDoc <- docSharedWrapper layoutType typ2 typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
@ -145,11 +134,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
) )
] ]
#if MIN_VERSION_ghc(8,10,1) HsForAllTy _ hsf typ2 -> do
HsForAllTy _ _ bndrs typ2 -> do let bndrs = hsf_vis_bndrs hsf
#else
HsForAllTy _ bndrs typ2 -> do
#endif
typeDoc <- layoutType typ2 typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
let maybeForceML = case typ2 of let maybeForceML = case typ2 of
@ -254,7 +240,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
) )
] ]
HsFunTy _ typ1 typ2 -> do HsFunTy _ _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2 typeDoc2 <- docSharedWrapper layoutType typ2
let maybeForceML = case typ2 of let maybeForceML = case typ2 of
@ -624,7 +610,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
then docLit $ Text.pack "\x2605" -- Unicode star then docLit $ Text.pack "\x2605" -- Unicode star
else docLit $ Text.pack "*" else docLit $ Text.pack "*"
XHsType{} -> error "brittany internal error: XHsType" XHsType{} -> error "brittany internal error: XHsType"
#if MIN_VERSION_ghc(8,8,0)
HsAppKindTy _ ty kind -> do HsAppKindTy _ ty kind -> do
t <- docSharedWrapper layoutType ty t <- docSharedWrapper layoutType ty
k <- docSharedWrapper layoutType kind k <- docSharedWrapper layoutType kind
@ -639,14 +624,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
t t
(docSeq [docLit $ Text.pack "@", k ]) (docSeq [docLit $ Text.pack "@", k ])
] ]
#endif
layoutTyVarBndrs layoutTyVarBndrs
:: [LHsTyVarBndr GhcPs] :: [LHsTyVarBndr () GhcPs]
-> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]
layoutTyVarBndrs = mapM $ \case layoutTyVarBndrs = mapM $ \case
(L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ lrdrName kind)) -> do (L _ (KindedTyVar _ _ lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d) return $ (lrdrNameToText lrdrName, Just $ d)
(L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"

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

@ -8,16 +8,9 @@ where
-- rather project-specific stuff: -- rather project-specific stuff:
--------------------------------- ---------------------------------
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import GHC.Hs.Extension as E ( GhcPs ) import GHC.Hs.Extension as E ( GhcPs )
#else
import HsExtension as E ( GhcPs )
#endif /* ghc-8.10.1 */
import RdrName as E ( RdrName ) import GHC.Types.Name.Reader as E ( RdrName )
#if MIN_VERSION_ghc(8,8,0)
import qualified GHC ( dL, HasSrcSpan, SrcSpanLess )
#endif
import qualified GHC ( Located ) import qualified GHC ( Located )
@ -402,12 +395,3 @@ import Data.Data as E ( toConstr
todo :: a todo :: a
todo = error "todo" todo = error "todo"
#if MIN_VERSION_ghc(8,8,0)
ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a)
ghcDL = GHC.dL
#else /* ghc-8.6 */
ghcDL :: GHC.Located a -> GHC.Located a
ghcDL x = x
#endif

20
src/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -46,11 +46,11 @@ import Data.Generics.Aliases
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import Text.PrettyPrint ( ($+$), (<+>) ) import Text.PrettyPrint ( ($+$), (<+>) )
import qualified Outputable as GHC import qualified GHC.Utils.Outputable as GHC
import qualified DynFlags as GHC import qualified GHC.Driver.Session as GHC
import qualified FastString as GHC import qualified GHC.Data.FastString as GHC
import qualified SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import OccName ( occNameString ) import GHC.Types.Name.Occurrence as OccName ( occNameString )
import qualified Data.ByteString as B import qualified Data.ByteString as B
import DataTreePrint import DataTreePrint
@ -59,11 +59,7 @@ import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Generics.Uniplate.Direct as Uniplate
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
import qualified GHC.Hs.Extension as HsExtension import qualified GHC.Hs.Extension as HsExtension
#else
import qualified HsExtension
#endif /* ghc-8.10.1 */
@ -301,11 +297,5 @@ lines' s = case break (== '\n') s of
(s1, [_]) -> [s1, ""] (s1, [_]) -> [s1, ""]
(s1, (_:r)) -> s1 : lines' r (s1, (_:r)) -> s1 : lines' r
#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */
absurdExt :: HsExtension.NoExtCon -> a absurdExt :: HsExtension.NoExtCon -> a
absurdExt = HsExtension.noExtCon absurdExt = HsExtension.noExtCon
#else
-- | A method to dismiss NoExt patterns for total matches
absurdExt :: HsExtension.NoExt -> a
absurdExt = error "cannot construct NoExt"
#endif

4
src/Language/Haskell/Brittany/Main.hs
View File

@ -16,7 +16,7 @@ import qualified Data.Map as Map
import qualified Data.Monoid import qualified Data.Monoid
import GHC ( GenLocated(L) ) import GHC ( GenLocated(L) )
import Outputable ( Outputable(..) import GHC.Utils.Outputable ( Outputable(..)
, showSDocUnsafe , showSDocUnsafe
) )
@ -46,7 +46,7 @@ import qualified System.Exit
import qualified System.Directory as Directory import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath import qualified System.FilePath.Posix as FilePath
import qualified DynFlags as GHC import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany import Paths_brittany