Add import and module support

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

src-literatetests/10-tests.blt

@@ -544,3 +544,165 @@ 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
+  , test1
+  , test2
+  -- Test 3
+  , test3
+  , test4
+  -- Test 5
+  , test5
+  )
+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
+
+#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 instances-only
+import qualified Data.List ()
+
+#test one-element
+import Data.List (nub)
+
+#test several-elements
+import Data.List (nub, foldl', indexElem)
+
+#test with-things
+import Test (T, T2(), T3(..), T4(T4), T5(T5, t5))
+
+#test hiding
+import Test hiding ()
+import Test as T hiding ()
+
+#test horizontal-layout
+import           Data.List (nub)
+import qualified Data.List as L (foldl')
+
+import           Test (test)
+import           Main hiding
+  ( main
+  , test1
+  , test2
+  , test3
+  , test4
+  , test5
+  , test6
+  , test7
+  , test8
+  , test9
+  )
+
+#test import-with-comments
+-- Test
+import           Data.List (nub) -- Test
+{- Test -}
+import qualified Data.List as L (foldl') {- Test -}
+
+-- Test
+import           Test (test)
+
+#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)

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
@@ -243,30 +244,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
+ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
-  let emptyModule = L loc m { hsmodDecls = [] }
+  post <- ppPreamble lmod
-  (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
   decls `forM_` \decl -> do
     filteredAnns <- mAsk <&> \annMap ->
       Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap
@@ -336,6 +315,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 _ ->

src/Language/Haskell/Brittany/Internal/Layouters/IE.hs

@@ -0,0 +1,70 @@
+module Language.Haskell.Brittany.Internal.Layouters.IE
+  ( layoutIE
+  , layoutIEList
+  )
+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(..))
+import           HsSyn
+import           Name
+import           HsImpExp
+import           FieldLabel
+import qualified FastString
+import           BasicTypes
+
+import           Language.Haskell.Brittany.Internal.Utils
+
+
+layoutIE :: ToBriDoc IE
+layoutIE lie@(L _ _ie) =
+  docWrapNode lie
+    $ let
+        ien = docLit $ rdrNameToText $ ieName _ie
+      in
+        case _ie of
+          IEVar      _ -> ien
+          IEThingAbs _ -> ien
+          IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"]
+          IEThingWith _ (IEWildcard _) _ _ ->
+            docSeq [ien, docLit $ Text.pack "(..)"]
+          IEThingWith _ _ ns fs ->
+            let
+              prepareFL =
+                docLit . Text.pack . FastString.unpackFS . flLabel . unLoc
+            in
+              docSeq
+              $  [ien, docLit $ Text.pack "("]
+              ++ (  intersperse docCommaSep (map (docLit . lrdrNameToText) ns)
+                 ++ intersperse docCommaSep (map (prepareFL) fs)
+                 )
+              ++ [docLit $ Text.pack ")"]
+          IEModuleContents n -> docSeq
+            [ docLit $ Text.pack "module"
+            , docSeparator
+            , docLit . Text.pack . moduleNameString $ unLoc n
+            ]
+          _ -> docEmpty
+
+layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered
+layoutIEList lies = do
+  ies <- mapM (docSharedWrapper layoutIE) lies
+  case ies of
+    []     -> docLit $ Text.pack "()"
+    (x:xs) -> docAlt
+      [ docSeq
+      $  [docLit $ Text.pack "(", x]
+      ++ map (\x' -> docSeq [docCommaSep, x']) xs
+      ++ [docLit $ Text.pack ")"]
+      , docLines
+        (  docSeq [docLit $ Text.pack "(", docSeparator, x]
+        :  map (\x' -> docSeq [docCommaSep, x']) xs
+        ++ [docLit $ Text.pack ")"]
+        )
+      ]

src/Language/Haskell/Brittany/Internal/Layouters/Import.hs

@@ -0,0 +1,62 @@
+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, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..))
+import           HsSyn
+import           Name
+import           HsImpExp
+import           FieldLabel
+import qualified FastString
+import           BasicTypes
+
+import           Language.Haskell.Brittany.Internal.Utils
+
+layoutImport :: ToBriDoc ImportDecl
+layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of
+  ImportDecl _ (L _ modName) pkg src safe q False as llies ->
+    let
+      modNameT         = Text.pack $ moduleNameString modName
+      pkgNameT         = Text.pack . sl_st <$> pkg
+      asT              = Text.pack . moduleNameString <$> as
+      sig              = ColBindingLine (Just (Text.pack "import"))
+      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
+        , fromMaybe docEmpty (appSep . docLit <$> pkgNameT)
+        ]
+      makeAs asT' =
+        appSep $ docSeq [docLit (Text.pack "as"), docSeparator, docLit asT']
+      importIds =
+        docSeq $ [appSep $ docLit modNameT, fromMaybe docEmpty (makeAs <$> asT)]
+    in
+      do
+        (hiding, ies) <- case llies of
+          Just (h, L _ lies) -> do
+            sies <- docSharedWrapper layoutIEList lies
+            return (h, sies)
+          Nothing -> return (False, docEmpty)
+        h <- docSharedWrapper
+          ( const
+            ( docSeq
+              [ docCols sig [importQualifiers, importIds]
+              , if hiding
+                then appSep $ docLit $ Text.pack "hiding"
+                else docEmpty
+              ]
+            )
+          )
+          ()
+        docAlt
+          [ docSeq [h, docForceSingleline ies]
+          , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies)
+          ]
+  _ -> docEmpty

src/Language/Haskell/Brittany/Internal/Layouters/Module.hs

@@ -0,0 +1,73 @@
+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') = do
+  case mod' of
+    -- Implicit module Main
+    HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports
+    HsModule (Just n) les imports _ _ _ ->
+      let
+        tn = Text.pack $ moduleNameString $ unLoc n
+      in
+        do
+          cs <- do
+            anns <- mAsk
+            case ExactPrint.Types.mkAnnKey lmod `Map.lookup` anns of
+              Just mAnn -> return $ extractAllComments mAnn
+              Nothing   -> return []
+          (hasComments, es) <- case les of
+            Nothing               -> return (False, docEmpty)
+            Just llies@(L _ lies) -> do
+              hasComments <- hasAnyCommentsBelow llies
+              return (hasComments, docWrapNode llies $ layoutIEList lies)
+          docLines
+            (  [ -- A pseudo node that serves merely to force documentation
+               -- before the node
+                 docWrapNode lmod $ docEmpty
+               | [] /= cs
+               ]
+            ++ [ docAlt
+                   (  [ docSeq
+                          [ appSep $ docLit $ Text.pack "module"
+                          , appSep $ docLit tn
+                          , appSep $ docForceSingleline es
+                          , docLit $ Text.pack "where"
+                          ]
+                      | not hasComments
+                      ]
+                   ++ [ docLines
+                          [ docAddBaseY BrIndentRegular $ docPar
+                            ( docSeq
+                              [ appSep $ docLit $ Text.pack "module"
+                              , docLit tn
+                              ]
+                            )
+                            (docForceMultiline es)
+                          , docLit $ Text.pack "where"
+                          ]
+                      ]
+                   )
+               ]
+            ++ map layoutImport imports
+            )