diff --git a/brittany.cabal b/brittany.cabal index bfba1dc..173345e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -67,6 +67,9 @@ library { Language.Haskell.Brittany.Internal.Layouters.Expr Language.Haskell.Brittany.Internal.Layouters.Stmt Language.Haskell.Brittany.Internal.Layouters.Pattern + Language.Haskell.Brittany.Internal.Layouters.IE + Language.Haskell.Brittany.Internal.Layouters.Import + Language.Haskell.Brittany.Internal.Layouters.Module Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index a3d8591..680d6f1 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -558,3 +558,282 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] + +############################################################################### +############################################################################### +############################################################################### +#group module +############################################################################### +############################################################################### +############################################################################### + +#test simple +module Main where + +#test no-exports +module Main () where + +#test one-export +module Main (main) where + +#test several-exports +module Main (main, test1, test2) where + +#test many-exports +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) +where + +#test exports-with-comments +module Main + ( main + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) +where + +#test simple-export-with-things +module Main (Test(..)) where + +#test simple-export-with-module-contents +module Main (module Main) where + +#test export-with-things +module Main (Test(Test, a, b)) where + +#test export-with-empty-thing +module Main (Test()) where + +#test empty-with-comment +-- Intentionally left empty + +############################################################################### +############################################################################### +############################################################################### +#group module.import +############################################################################### +############################################################################### +############################################################################### + +#test simple-import +import Data.List + +#test simple-import-alias +import Data.List as L + +#test simple-qualified-import +import qualified Data.List + +#test simple-qualified-import-alias +import qualified Data.List as L + +#test simple-safe +import safe Data.List as L + +#test simple-source +import {-# SOURCE #-} Data.List ( ) + +#test simple-safe-qualified +import safe qualified Data.List + +#test simple-safe-qualified-source +import {-# SOURCE #-} safe qualified Data.List + +#test simple-qualified-package +import qualified "base" Data.List + +#test qualifier-effect +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List ( ) +import {-# SOURCE #-} safe qualified Data.List hiding ( ) + +#test instances-only +import qualified Data.List ( ) + +#test one-element +import Data.List ( nub ) + +#test several-elements +import Data.List ( nub + , foldl' + , indexElem + ) + +#test a-ridiculous-amount-of-elements +import Test ( Long + , list + , with + , items + , that + , will + , not + , quite + , fit + , onA + , single + , line + , anymore + ) + +#test with-things +import Test ( T + , T2() + , T3(..) + , T4(T4) + , T5(T5, t5) + , T6((<|>)) + , (+) + ) + +#test hiding +import Test hiding ( ) +import Test as T + hiding ( ) + +#test long-module-name +import TestJustShortEnoughModuleNameLikeThisOne ( ) +import TestJustAbitToLongModuleNameLikeThisOneIs + ( ) + +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI + as T + +import TestJustShortEnoughModuleNameLike hiding ( ) +import TestJustAbitToLongModuleNameLikeTh + hiding ( ) + +import MoreThanSufficientlyLongModuleNameWithSome + ( items + , that + , will + , not + , fit + , inA + , compact + , layout + ) + +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe + ( ) + +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff + as T +import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" A + hiding ( ) + +#test import-with-comments +-- Test +import Data.List ( nub ) -- Test +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} + +-- Test +import Test ( test ) + +#test import-with-comments-2 + +import Test ( abc + , def + -- comment + ) + +#test import-with-comments-3 + +import Test ( abc + -- comment + ) + +#test import-with-comments-4 +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) + +#test import-with-comments-5 +import Test ( -- comment + ) + +#test long-bindings +import Test ( longbindingNameThatoverflowsColum ) +import Test ( Long( List + , Of + , Things + ) ) + +#test things-with-with-comments +import Test ( Thing( -- Comments + ) + ) +import Test ( Thing( Item + -- and Comment + ) + ) +import Test ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +#test prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + ( ) + +#test preamble full-preamble +{-# LANGUAGE BangPatterns #-} + +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + -- Test 10 + ) +where + +-- Test +import Data.List ( nub ) -- Test +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} + +-- Test +import Test ( test ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 7700adb..f4c4d6d 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -593,6 +593,256 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] +############################################################################### +############################################################################### +############################################################################### +#group module +############################################################################### +############################################################################### +############################################################################### + +#test simple +module Main where + +#test no-exports +module Main () where + +#test one-export +module Main (main) where + +#test several-exports +module Main (main, test1, test2) where + +#test many-exports +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) +where + +#test exports-with-comments +module Main + ( main + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) +where + +#test simple-export-with-things +module Main (Test(..)) where + +#test simple-export-with-module-contents +module Main (module Main) where + +#test export-with-things +module Main (Test(Test, a, b)) where + +#test export-with-empty-thing +module Main (Test()) where + +#test empty-with-comment +-- Intentionally left empty + +############################################################################### +############################################################################### +############################################################################### +#group import +############################################################################### +############################################################################### +############################################################################### + +#test simple-import +import Data.List + +#test simple-import-alias +import Data.List as L + +#test simple-qualified-import +import qualified Data.List + +#test simple-qualified-import-alias +import qualified Data.List as L + +#test simple-safe +import safe Data.List as L + +#test simple-source +import {-# SOURCE #-} Data.List () + +#test simple-safe-qualified +import safe qualified Data.List hiding (nub) + +#test simple-safe-qualified-source +import {-# SOURCE #-} safe qualified Data.List + +#test simple-qualified-package +import qualified "base" Data.List + +#test qualifier-effect +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List () +import {-# SOURCE #-} safe qualified Data.List hiding () + +#test instances-only +import qualified Data.List () + +#test one-element +import Data.List (nub) + +#test several-elements +import Data.List (nub, foldl', indexElem) + +#test a-ridiculous-amount-of-elements +import Test + ( Long + , list + , with + , items + , that + , will + , not + , quite + , fit + , onA + , single + , line + , anymore + ) + +#test with-things +import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) + +#test hiding +import Test hiding () +import Test as T hiding () + +#test long-module-name +import TestJustShortEnoughModuleNameLikeThisOne () +import TestJustAbitToLongModuleNameLikeThisOneIs () +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLike hiding () +import TestJustAbitToLongModuleNameLikeTh hiding () +import MoreThanSufficientlyLongModuleNameWithSome + (items, that, will, not, fit, inA, compact, layout) + +#test import-with-comments +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +#test import-with-comments-2 + +import Test + ( abc + , def + -- comment + ) + +#test import-with-comments-3 + +import Test + ( abc + -- comment + ) + +#test import-with-comments-4 +import Test + ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) + +-- Test +import Test (test) + +#test import-with-comments-5 +import Test + ( -- comment + ) + +#test long-bindings +import Test (longbindingNameThatoverflowsColum) +import Test (Long(List, Of, Things)) + +#test things-with-with-comments +import Test + ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +import Test + ( Thing( Item + -- and Comment + ) + ) +import Test + ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) + +#test prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + () + +#test preamble full-preamble +{-# LANGUAGE BangPatterns #-} + +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ) +where + +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) ############################################################################### ############################################################################### @@ -1128,4 +1378,3 @@ foo = ## ] ## where ## role = stringProperty "WM_WINDOW_ROLE" - diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index b6987b5..25b7b9a 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -33,6 +33,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils @@ -160,7 +161,7 @@ pPrintModule conf anns parsedModule = in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do - -- + -- -- debugStrings `forM_` \s -> -- trace s $ return () @@ -248,30 +249,8 @@ parsePrintModuleTests conf filename input = do -- else return $ TextL.toStrict $ Text.Builder.toLazyText out ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () -ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do - let emptyModule = L loc m { hsmodDecls = [] } - (anns', post) <- do - anns <- mAsk - -- evil partiality. but rather unlikely. - return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of - Nothing -> (anns, []) - Just mAnn -> - let modAnnsDp = ExactPrint.Types.annsDP mAnn - isWhere (ExactPrint.Types.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.Types.G AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post) = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], 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.Types.annsDP = pre } - anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns - in (anns', post) - MultiRWSS.withMultiReader anns' $ processDefault emptyModule +ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do + post <- ppPreamble lmod decls `forM_` \decl -> do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap @@ -341,6 +320,51 @@ ppDecl d@(L loc decl) = case decl of layoutBriDoc briDoc _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc +-- Prints the information associated with the module annotation +-- This includes the imports +ppPreamble :: GenLocated SrcSpan (HsModule RdrName) + -> PPM [(ExactPrint.Types.KeywordId, ExactPrint.Types.DeltaPos)] +ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do + filteredAnns <- mAsk <&> \annMap -> + Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey lmod) annMap + -- Since ghc-exactprint adds annotations following (implicit) + -- modules to both HsModule and the elements in the module + -- this can cause duplication of comments. So strip + -- attached annotations that come after the module's where + -- from the module node + let (filteredAnns', post) = + case (ExactPrint.Types.mkAnnKey lmod) `Map.lookup` filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let modAnnsDp = ExactPrint.Types.annsDP mAnn + isWhere (ExactPrint.Types.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.Types.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], 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.Types.annsDP = pre } + filteredAnns'' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' filteredAnns + in (filteredAnns'', post') + in do + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' + + config <- mAsk + + MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil + withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + return post + _sigHead :: Sig RdrName -> String _sigHead = \case TypeSig names _ -> diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 52c9e08..151dd65 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -42,6 +42,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , appSep , docCommaSep , docParenLSep + , docParenR , docTick , spacifyDocs , briDocMToPPM @@ -465,6 +466,9 @@ docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered docParenLSep = appSep $ docLit $ Text.pack "(" +docParenR :: ToBriDocM BriDocNumbered +docParenR = docLit $ Text.pack ")" + docTick :: ToBriDocM BriDocNumbered docTick = docLit $ Text.pack "'" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs new file mode 100644 index 0000000..ebf9b36 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -0,0 +1,133 @@ +module Language.Haskell.Brittany.Internal.Layouters.IE + ( layoutIE + , layoutLLIEs + , layoutAnnAndSepLLIEs + ) +where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC ( unLoc + , runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + ) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils + + + +#if MIN_VERSION_ghc(8,2,0) +prepareName :: LIEWrappedName name -> Located name +prepareName = ieLWrappedName +#else +prepareName :: Located name -> Located name +prepareName = id +#endif + +layoutIE :: ToBriDoc IE +layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of + IEVar _ -> ien + IEThingAbs _ -> ien + IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ _ ns _ -> do + hasComments <- hasAnyCommentsBelow lie + docAltFilter + [(not hasComments, docSeq $ [ien, docLit $ Text.pack "("] + ++ intersperse docCommaSep (map nameDoc ns) + ++ [docParenR]) + ,(otherwise, docSeq [ien, layoutItems (splitFirstLast ns)]) + ] + where + nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName + layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] + layoutItems FirstLastEmpty = + docSetBaseY $ + docLines [docSeq [docParenLSep, docWrapNodeRest lie docEmpty] + ,docParenR + ] + layoutItems (FirstLastSingleton n) = + docSetBaseY $ docLines + [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR] + layoutItems (FirstLast n1 nMs nN) = + docSetBaseY $ docLines $ + [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + ++ map layoutItem nMs + ++ [ docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN] + , docParenR + ] + IEModuleContents n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) + +-- Helper function to deal with Located lists of LIEs. +-- In particular this will also associate documentation +-- from the located list that actually belongs to the last IE. +-- It also adds docCommaSep to all but the first element +-- This configuration allows both vertical and horizontal +-- handling of the resulting list. Adding parens is +-- left to the caller since that is context sensitive +layoutAnnAndSepLLIEs + :: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs llies@(L _ lies) = do + let makeIENode ie = docSeq [docCommaSep, ie] + let ieDocs = layoutIE <$> lies + ieCommaDocs <- + docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of + FirstLastEmpty -> [] + FirstLastSingleton ie -> [ie] + FirstLast ie1 ieMs ieN -> + [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] + pure $ fmap pure ieCommaDocs -- returned shared nodes + +-- Builds a complete layout for the given located +-- list of LIEs. The layout provides two alternatives: +-- (item, item, ..., item) +-- ( item +-- , item +-- ... +-- , item +-- ) +-- If the llies contains comments the list will +-- always expand over multiple lines, even when empty: +-- () -- no comments +-- ( -- a comment +-- ) +layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs llies = do + ieDs <- layoutAnnAndSepLLIEs llies + hasComments <- hasAnyCommentsBelow llies + case ieDs of + [] -> docAltFilter + [ (not hasComments, docLit $ Text.pack "()") + , ( hasComments + , docPar + (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + ) + ] + (ieDsH:ieDsT) -> + docAltFilter + [ (not hasComments, docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR]) + , (otherwise, docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ + docLines $ ieDsT + ++ [docParenR]) + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs new file mode 100644 index 0000000..5fa05a2 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -0,0 +1,134 @@ +module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName ( RdrName(..) ) +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , Located + ) +import HsSyn +import Name +import FieldLabel +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils + + + +#if MIN_VERSION_ghc(8,2,0) +prepPkg :: SourceText -> String +prepPkg rawN = case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" +#else +prepPkg :: String -> String +prepPkg = id +#endif +#if MIN_VERSION_ghc(8,2,0) +prepModName :: Located e -> e +prepModName = unLoc +#else +prepModName :: e -> e +prepModName = id +#endif + +layoutImport :: ToBriDoc ImportDecl +layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of + ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do + importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + compact = indentPolicy == IndentPolicyLeft + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies + minQLength = length "import qualified " + qLengthReal = + let qualifiedPart = if q then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = if src then length "{-# SOURCE #-} " else 0 + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal + -- Cost in columns of importColumn + asCost = length "as " + bindingCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength + importQualifiers = docSeq + [ appSep $ docLit $ Text.pack "import" + , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty + , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty + , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty + , maybe docEmpty (appSep . docLit) pkgNameT + ] + indentName = + if compact then id else docEnsureIndent (BrIndentSpecial qLength) + modNameD = + indentName $ appSep $ docLit modNameT + hidDoc = + if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + importHead = docSeq [importQualifiers, modNameD] + bindingsD = case mllies of + Nothing -> docEmpty + Just (_, llies) -> do + hasComments <- hasAnyCommentsBelow llies + if compact + then docSeq [hidDoc, layoutLLIEs llies] + else do + ieDs <- layoutAnnAndSepLLIEs llies + docWrapNodeRest llies $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + docParenR + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> if hasComments + then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR + else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + $ docLines + $ ieDs' + ++ [docParenR] + bindingLine = + docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD + makeAsDoc asT = + docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] + if compact + then + let asDoc = maybe docEmpty makeAsDoc masT + in docAlt + [ docForceSingleline $ + docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + , docAddBaseY BrIndentRegular $ + docPar (docSeq [importHead, asDoc]) bindingsD + ] + else + case masT of + Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] + | otherwise -> docLines [importHead, asDoc, bindingLine] + where + enoughRoom = nameCost < importCol - asCost + asDoc = + docEnsureIndent (BrIndentSpecial (importCol - asCost)) + $ makeAsDoc n + Nothing | enoughRoom -> docSeq [importHead, bindingLine] + | otherwise -> docLines [importHead, bindingLine] + where enoughRoom = nameCost < importCol - bindingCost + _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs new file mode 100644 index 0000000..db2e2af --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -0,0 +1,58 @@ +module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + +import Language.Haskell.Brittany.Internal.Utils + + + +layoutModule :: ToBriDoc HsModule +layoutModule lmod@(L _ mod') = + case mod' of + -- Implicit module Main + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> do + let tn = Text.pack $ moduleNameString $ unLoc n + exportsDoc = maybe docEmpty layoutLLIEs les + docLines + $ docSeq + [ docWrapNode lmod docEmpty + -- A pseudo node that serves merely to force documentation + -- before the node + , docAlt + ( [ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , appSep exportsDoc + , docLit $ Text.pack "where" + ] + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + ( docSeq + [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docForceMultiline exportsDoc) + , docLit $ Text.pack "where" + ] + ] + ) + ] + : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 557f9b3..2784c1d 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -178,6 +178,7 @@ data ColSig | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? + | ColImport -- TODO deriving (Eq, Ord, Data.Data.Data, Show)