Add an option for compact language pragmas

4 files changed, 83 insertions, 23 deletions

diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml
index 661c516..f4ea63f 100644
--- a/.stylish-haskell.yaml
+++ b/.stylish-haskell.yaml
@@ -9,6 +9,14 @@ stylish:
 
   # Language pragmas
   - languages_pragmas:
+      # We can generate different styles of language pragma lists.
+      #
+      # - vertical: Vertical-spaced language pragmas, one per line.
+      # - compact: A more compact style.
+      #
+      # Default: vertical.
+      style: vertical
+
       # stylish-haskell can detect redundancy of some language pragmas. If this
       # is set to true, it will remove those redundant pragmas. Default: true.
       remove_redundant: true
diff --git a/src/StylishHaskell/Config.hs b/src/StylishHaskell/Config.hs
index 4b1add8..056adf6 100644
--- a/src/StylishHaskell/Config.hs
+++ b/src/StylishHaskell/Config.hs
@@ -8,12 +8,13 @@ module StylishHaskell.Config
 
 
 --------------------------------------------------------------------------------
-import           Control.Applicative                       ((<$>))
+import           Control.Applicative                       ((<$>), (<*>))
 import           Control.Monad                             (forM, msum, mzero)
 import           Data.Aeson                                (FromJSON(..))
 import qualified Data.Aeson                                as A
 import qualified Data.Aeson.Types                          as A
 import qualified Data.ByteString                           as B
+import           Data.List                                 (intercalate)
 import           Data.Map                                  (Map)
 import qualified Data.Map                                  as M
 import           Data.Yaml                                 (decodeEither)
@@ -23,11 +24,11 @@ import           System.FilePath                           ((</>))
 
 --------------------------------------------------------------------------------
 import           StylishHaskell.Stylish
-import qualified StylishHaskell.Stylish.Imports
-import qualified StylishHaskell.Stylish.LanguagePragmas
-import qualified StylishHaskell.Stylish.Tabs
-import qualified StylishHaskell.Stylish.TrailingWhitespace
-import qualified StylishHaskell.Stylish.UnicodeSyntax
+import qualified StylishHaskell.Stylish.Imports            as Imports
+import qualified StylishHaskell.Stylish.LanguagePragmas    as LanguagePragmas
+import qualified StylishHaskell.Stylish.Tabs               as Tabs
+import qualified StylishHaskell.Stylish.TrailingWhitespace as TrailingWhitespace
+import qualified StylishHaskell.Stylish.UnicodeSyntax      as UnicodeSyntax
 
 
 --------------------------------------------------------------------------------
@@ -44,9 +45,9 @@ instance FromJSON Config where
 --------------------------------------------------------------------------------
 defaultConfig :: Config
 defaultConfig = Config $
-    [ StylishHaskell.Stylish.Imports.stylish True
-    , StylishHaskell.Stylish.LanguagePragmas.stylish True
-    , StylishHaskell.Stylish.TrailingWhitespace.stylish
+    [ Imports.stylish True
+    , LanguagePragmas.stylish LanguagePragmas.Vertical True
+    , TrailingWhitespace.stylish
     ]
 
 
@@ -112,29 +113,44 @@ parseStylish val = do
 
 
 --------------------------------------------------------------------------------
+-- | Utility for enum-like options
+parseEnum :: [(String, a)] -> a -> Maybe String -> A.Parser a
+parseEnum _    def Nothing  = return def
+parseEnum strs _   (Just k) = case lookup k strs of
+    Just v  -> return v
+    Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++
+        intercalate ", " (map fst strs)
+
+
+--------------------------------------------------------------------------------
 parseImports :: A.Object -> A.Parser Stylish
-parseImports o = StylishHaskell.Stylish.Imports.stylish
+parseImports o = Imports.stylish
     <$> o A..:? "align" A..!= True
 
 
 --------------------------------------------------------------------------------
 parseLanguagePragmas :: A.Object -> A.Parser Stylish
-parseLanguagePragmas o = StylishHaskell.Stylish.LanguagePragmas.stylish
-    <$> o A..:? "remove_redundant" A..!= True
+parseLanguagePragmas o = LanguagePragmas.stylish
+    <$> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical)
+    <*> o A..:? "remove_redundant" A..!= True
+  where
+    styles =
+        [ ("vertical", LanguagePragmas.Vertical)
+        , ("compact",  LanguagePragmas.Compact)
+        ]
 
 
 --------------------------------------------------------------------------------
 parseTabs :: A.Object -> A.Parser Stylish
-parseTabs o = StylishHaskell.Stylish.Tabs.stylish
+parseTabs o = Tabs.stylish
     <$> o A..:? "spaces" A..!= 8
 
 
 --------------------------------------------------------------------------------
 parseTrailingWhitespace :: A.Object -> A.Parser Stylish
-parseTrailingWhitespace _ =
-    return StylishHaskell.Stylish.TrailingWhitespace.stylish
+parseTrailingWhitespace _ = return TrailingWhitespace.stylish
 
 
 --------------------------------------------------------------------------------
 parseUnicodeSyntax :: A.Object -> A.Parser Stylish
-parseUnicodeSyntax _ = return StylishHaskell.Stylish.UnicodeSyntax.stylish
+parseUnicodeSyntax _ = return UnicodeSyntax.stylish
diff --git a/src/StylishHaskell/Stylish/LanguagePragmas.hs b/src/StylishHaskell/Stylish/LanguagePragmas.hs
index 5b6adde..5b82f8d 100644
--- a/src/StylishHaskell/Stylish/LanguagePragmas.hs
+++ b/src/StylishHaskell/Stylish/LanguagePragmas.hs
@@ -1,6 +1,7 @@
 --------------------------------------------------------------------------------
 module StylishHaskell.Stylish.LanguagePragmas
-    ( stylish
+    ( Style (..)
+    , stylish
 
       -- * Utilities
     , addLanguagePragma
@@ -20,6 +21,13 @@ import           StylishHaskell.Util
 
 
 --------------------------------------------------------------------------------
+data Style
+    = Vertical
+    | Compact
+    deriving (Eq, Show)
+
+
+--------------------------------------------------------------------------------
 pragmas :: H.Module l -> [(l, [String])]
 pragmas (H.Module _ _ ps _ _) =
     [(l, map nameToString names) | H.LanguagePragma l names <- ps]
@@ -50,8 +58,14 @@ compactPragmas pragmas' = wrap 80 "{-# LANGUAGE" 13 $
 
 
 --------------------------------------------------------------------------------
-stylish :: Bool -> Stylish
-stylish removeRedundant ls (module', _)
+prettyPragmas :: Style -> [String] -> Lines
+prettyPragmas Vertical = verticalPragmas
+prettyPragmas Compact  = compactPragmas
+
+
+--------------------------------------------------------------------------------
+stylish :: Style -> Bool -> Stylish
+stylish style removeRedundant ls (module', _)
     | null pragmas' = ls
     | otherwise     = applyChanges changes ls
   where
@@ -63,7 +77,7 @@ stylish removeRedundant ls (module', _)
     uniques  = filterRedundant $ nub $ sort $ snd =<< pragmas'
     loc      = firstLocation pragmas'
     deletes  = map (delete . fst) pragmas'
-    changes  = insert loc (compactPragmas uniques) : deletes
+    changes  = insert loc (prettyPragmas style uniques) : deletes
 
 
 --------------------------------------------------------------------------------
diff --git a/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs b/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs
index 74181ee..459575f 100644
--- a/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs
+++ b/tests/StylishHaskell/Stylish/LanguagePragmas/Tests.hs
@@ -21,12 +21,14 @@ tests = testGroup "StylishHaskell.Stylish.LanguagePragmas.Tests"
     [ case01
     , case02
     , case03
+    , case04
     ]
 
 
 --------------------------------------------------------------------------------
 case01 :: Test
-case01 = testCase "case 01" $ expected @=? testStylish (stylish False) input
+case01 = testCase "case 01" $
+    expected @=? testStylish (stylish Vertical False) input
   where
     input = unlines
         [ "{-# LANGUAGE ViewPatterns #-}"
@@ -45,7 +47,8 @@ case01 = testCase "case 01" $ expected @=? testStylish (stylish False) input
 
 --------------------------------------------------------------------------------
 case02 :: Test
-case02 = testCase "case 02" $ expected @=? testStylish (stylish True) input
+case02 = testCase "case 02" $
+    expected @=? testStylish (stylish Vertical True) input
   where
     input = unlines
         [ "{-# LANGUAGE BangPatterns #-}"
@@ -61,7 +64,8 @@ case02 = testCase "case 02" $ expected @=? testStylish (stylish True) input
 
 --------------------------------------------------------------------------------
 case03 :: Test
-case03 = testCase "case 03" $ expected @=? testStylish (stylish True) input
+case03 = testCase "case 03" $
+    expected @=? testStylish (stylish Vertical True) input
   where
     input = unlines
         [ "{-# LANGUAGE BangPatterns #-}"
@@ -73,3 +77,21 @@ case03 = testCase "case 03" $ expected @=? testStylish (stylish True) input
         [ "{-# LANGUAGE BangPatterns #-}"
         , "increment x = case x of !_ -> x + 1"
         ]
+
+
+--------------------------------------------------------------------------------
+case04 :: Test
+case04 = testCase "case 04" $
+    expected @=? testStylish (stylish Compact False) input
+  where
+    input = unlines
+        [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"
+        , "    TemplateHaskell #-}"
+        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"
+        ]
+
+    expected = unlines
+        [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++
+            "TemplateHaskell,"
+        , "             TypeOperators, ViewPatterns #-}"
+        ]