* Added `line' style for pretty language pragma.

Conflicts:
	src/Language/Haskell/Stylish/Step/LanguagePragmas.hs

6 files changed, 117 insertions, 89 deletions

diff --git a/src/Language/Haskell/Stylish/Block.hs b/src/Language/Haskell/Stylish/Block.hs
index bc47d18..fd680a8 100644
--- a/src/Language/Haskell/Stylish/Block.hs
+++ b/src/Language/Haskell/Stylish/Block.hs
@@ -10,6 +10,7 @@ module Language.Haskell.Stylish.Block
     , adjacent
     , merge
     , overlapping
+    , groupAdjacent
     ) where
 
 
@@ -76,3 +77,15 @@ overlapping blocks =
     any (uncurry overlapping') $ zip blocks (drop 1 blocks)
   where
     overlapping' (Block _ e1) (Block s2 _) = e1 >= s2
+
+
+--------------------------------------------------------------------------------
+-- | Groups adjacent blocks into larger blocks
+groupAdjacent :: [(Block a, b)]
+              -> [(Block a, [b])]
+groupAdjacent = foldr go []
+  where
+    -- This code is ugly and not optimal, and no fucks were given.
+    go (b1, x) gs = case break (adjacent b1 . fst) gs of
+        (_, [])               -> (b1, [x]) : gs
+        (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs)
diff --git a/src/Language/Haskell/Stylish/Config.hs b/src/Language/Haskell/Stylish/Config.hs
index 07b89e0..32eb55d 100644
--- a/src/Language/Haskell/Stylish/Config.hs
+++ b/src/Language/Haskell/Stylish/Config.hs
@@ -11,17 +11,18 @@ module Language.Haskell.Stylish.Config
 
 --------------------------------------------------------------------------------
 import           Control.Applicative                    (pure, (<$>), (<*>))
-import           Control.Monad                          (forM, msum, mzero)
+import           Control.Monad                          (forM, 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.List                              (inits, intercalate)
 import           Data.Map                               (Map)
 import qualified Data.Map                               as M
 import           Data.Yaml                              (decodeEither)
 import           System.Directory
-import           System.FilePath                        ((</>))
+import           System.FilePath                        (joinPath, splitPath,
+                                                         (</>))
 
 
 --------------------------------------------------------------------------------
@@ -70,22 +71,26 @@ defaultConfigFilePath = getDataFileName "data/stylish-haskell.yaml"
 
 --------------------------------------------------------------------------------
 configFilePath :: Verbose -> Maybe FilePath -> IO (Maybe FilePath)
-configFilePath verbose userSpecified = do
-    (current, currentE) <- check $ (</> configFileName) <$> getCurrentDirectory
-    (home, homeE)       <- check $ (</> configFileName) <$> getHomeDirectory
-    (def, defE)         <- check defaultConfigFilePath
-    return $ msum
-        [ userSpecified
-        , if currentE then Just current else Nothing
-        , if homeE then Just home else Nothing
-        , if defE then Just def else Nothing
-        ]
+configFilePath _       (Just userSpecified) = return $ Just userSpecified
+configFilePath verbose Nothing              = do
+    current <- getCurrentDirectory
+    home    <- getHomeDirectory
+    def     <- defaultConfigFilePath
+    search $
+        [d </> configFileName | d <- ancestors current] ++
+        [home </> configFileName, def]
   where
-    check fp = do
-        fp' <- fp
-        ex  <- doesFileExist fp'
-        verbose $ fp' ++ if ex then " exists" else " does not exist"
-        return (fp', ex)
+    -- All ancestors of a dir (including that dir)
+    ancestors :: FilePath -> [FilePath]
+    ancestors = init . map joinPath . reverse . inits . splitPath
+
+    search :: [FilePath] -> IO (Maybe FilePath)
+    search []       = return Nothing
+    search (f : fs) = do
+        -- TODO Maybe catch an error here, dir might be unreadable
+        exists <- doesFileExist f
+        verbose $ f ++ if exists then " exists" else " does not exist"
+        if exists then return (Just f) else search fs
 
 
 --------------------------------------------------------------------------------
@@ -159,6 +164,7 @@ parseImports config o = Imports.step
   where
     aligns =
         [ ("global", Imports.Global)
+        , ("file",   Imports.File)
         , ("group",  Imports.Group)
         , ("none",   Imports.None)
         ]
diff --git a/src/Language/Haskell/Stylish/Parse.hs b/src/Language/Haskell/Stylish/Parse.hs
index 84b47c2..36422d1 100644
--- a/src/Language/Haskell/Stylish/Parse.hs
+++ b/src/Language/Haskell/Stylish/Parse.hs
@@ -6,7 +6,7 @@ module Language.Haskell.Stylish.Parse
 
 --------------------------------------------------------------------------------
 import           Control.Monad.Error             (throwError)
-import           Data.Maybe                      (fromMaybe)
+import           Data.Maybe                      (fromMaybe, listToMaybe)
 import qualified Language.Haskell.Exts.Annotated as H
 
 
@@ -18,10 +18,13 @@ import           Language.Haskell.Stylish.Step
 --------------------------------------------------------------------------------
 -- | Filter out lines which use CPP macros
 unCpp :: String -> String
-unCpp = unlines . map unCpp' . lines
+unCpp = unlines . go False . lines
   where
-    unCpp' ('#' : _) = ""
-    unCpp' xs        = xs
+    go _           []       = []
+    go isMultiline (x : xs) =
+        let isCpp         = isMultiline || listToMaybe x == Just '#'
+            nextMultiline = isCpp && not (null x) && last x == '\\'
+        in (if isCpp then "" else x) : go nextMultiline xs
 
 
 --------------------------------------------------------------------------------
@@ -33,21 +36,13 @@ dropBom str              = str
 
 
 --------------------------------------------------------------------------------
--- | Read an extension name from a string
-parseExtension :: String -> Either String H.Extension
-parseExtension str = case reads str of
-    [(x, "")] -> return x
-    _         -> throwError $ "Unknown extension: " ++ str
-
-
---------------------------------------------------------------------------------
 -- | Abstraction over HSE's parsing
 parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module
 parseModule extraExts mfp string = do
-    -- Determine the extensions: those specified in the file and the extra ones 
-    extraExts' <- mapM parseExtension extraExts
-    let fileExts = fromMaybe [] $ H.readExtensions string
-        exts     = fileExts ++ extraExts'
+    -- Determine the extensions: those specified in the file and the extra ones
+    let extraExts' = map H.classifyExtension extraExts
+        fileExts   = fromMaybe [] $ H.readExtensions string
+        exts       = fileExts ++ extraExts'
 
         -- Parsing options...
         fp       = fromMaybe "<unknown>" mfp
diff --git a/src/Language/Haskell/Stylish/Step/Imports.hs b/src/Language/Haskell/Stylish/Step/Imports.hs
index 9699627..e27a946 100644
--- a/src/Language/Haskell/Stylish/Step/Imports.hs
+++ b/src/Language/Haskell/Stylish/Step/Imports.hs
@@ -24,6 +24,7 @@ import           Language.Haskell.Stylish.Util
 --------------------------------------------------------------------------------
 data Align
     = Global
+    | File
     | Group
     | None
     deriving (Eq, Show)
@@ -46,20 +47,6 @@ longestImport = maximum . map (length . importName)
 
 
 --------------------------------------------------------------------------------
--- | Groups adjacent imports into larger import blocks
-groupAdjacent :: [H.ImportDecl LineBlock]
-              -> [(LineBlock, [H.ImportDecl LineBlock])]
-groupAdjacent = foldr go []
-  where
-    -- This code is ugly and not optimal, and no fucks were given.
-    go imp is = case break (adjacent b1 . fst) is of
-        (_, [])                 -> (b1, [imp]) : is
-        (xs, ((b2, imps) : ys)) -> (merge b1 b2, imp : imps) : (xs ++ ys)
-      where
-        b1 = H.ann imp
-
-
---------------------------------------------------------------------------------
 -- | Compare imports for ordering
 compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering
 compareImports = comparing (map toLower . importName &&& H.importQualified)
@@ -108,28 +95,32 @@ prettyImportSpec x                      = H.prettyPrint x
 
 
 --------------------------------------------------------------------------------
-prettyImport :: Int -> Bool -> Bool -> Int -> H.ImportDecl l -> String
+prettyImport :: Int -> Bool -> Bool -> Int -> H.ImportDecl l -> [String]
 prettyImport columns padQualified padName longest imp =
-    intercalate "\n" $
     wrap columns base (length base + 2) $
     (if hiding then ("hiding" :) else id) $
-    withInit (++ ",") $
-    withHead ("(" ++) $
-    withLast (++ ")") $
-    map prettyImportSpec $
-    importSpecs
+    case importSpecs of
+        Nothing -> []     -- Import everything
+        Just [] -> ["()"] -- Instance only imports
+        Just is ->
+            withInit (++ ",") $
+            withHead ("(" ++) $
+            withLast (++ ")") $
+            map prettyImportSpec $
+            is
   where
     base = unwords $ concat
          [ ["import"]
          , qualified
+         , (fmap show $ maybeToList $ H.importPkg imp)
          , [(if hasExtras && padName then padRight longest else id)
             (importName imp)]
          , ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp]
          ]
 
     (hiding, importSpecs) = case H.importSpecs imp of
-        Just (H.ImportSpecList _ h l) -> (h, l)
-        _                             -> (False, [])
+        Just (H.ImportSpecList _ h l) -> (h, Just l)
+        _                             -> (False, Nothing)
 
     hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp)
 
@@ -140,9 +131,10 @@ prettyImport columns padQualified padName longest imp =
 
 
 --------------------------------------------------------------------------------
-prettyImportGroup :: Int -> Align -> Int -> [H.ImportDecl LineBlock] -> Lines
-prettyImportGroup columns align longest imps =
-    map (prettyImport columns padQual padName longest') $
+prettyImportGroup :: Int -> Align -> Bool -> Int -> [H.ImportDecl LineBlock]
+                  -> Lines
+prettyImportGroup columns align fileAlign longest imps =
+    concatMap (prettyImport columns padQual padName longest') $
     sortBy compareImports imps
   where
     longest' = case align of
@@ -153,6 +145,7 @@ prettyImportGroup columns align longest imps =
 
     padQual = case align of
         Global -> True
+        File   -> fileAlign
         Group  -> any H.importQualified imps
         None   -> False
 
@@ -165,10 +158,15 @@ step columns = makeStep "Imports" . step' columns
 --------------------------------------------------------------------------------
 step' :: Int -> Align -> Lines -> Module -> Lines
 step' columns align ls (module', _) = flip applyChanges ls
-    [ change block (const $ prettyImportGroup columns align longest importGroup)
+    [ change block $ const $
+        prettyImportGroup columns align fileAlign longest importGroup
     | (block, importGroup) <- groups
     ]
   where
     imps    = map sortImportSpecs $ imports $ fmap linesFromSrcSpan module'
     longest = longestImport imps
-    groups  = groupAdjacent imps
+    groups  = groupAdjacent [(H.ann i, i) | i <- imps]
+
+    fileAlign = case align of
+        File -> any H.importQualified imps
+        _    -> False
diff --git a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs
index 53657e0..c147ade 100644
--- a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs
+++ b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs
@@ -9,15 +9,15 @@ module Language.Haskell.Stylish.Step.LanguagePragmas
 
 
 --------------------------------------------------------------------------------
-import           Data.List                       (nub, sort)
+import qualified Data.Set                        as S
 import qualified Language.Haskell.Exts.Annotated as H
 
 
 --------------------------------------------------------------------------------
-import           Language.Haskell.Stylish.Block
-import           Language.Haskell.Stylish.Editor
-import           Language.Haskell.Stylish.Step
-import           Language.Haskell.Stylish.Util
+import Language.Haskell.Stylish.Block
+import Language.Haskell.Stylish.Editor
+import Language.Haskell.Stylish.Step
+import Language.Haskell.Stylish.Util
 
 
 --------------------------------------------------------------------------------
@@ -42,13 +42,11 @@ firstLocation = minimum . map (blockStart . fst)
 
 
 --------------------------------------------------------------------------------
-verticalPragmas :: [String] -> Lines
-verticalPragmas pragmas' =
+verticalPragmas :: Int -> [String] -> Lines
+verticalPragmas longest pragmas' =
     [ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}"
     | pragma <- pragmas'
     ]
-  where
-    longest = maximum $ map length pragmas'
 
 
 --------------------------------------------------------------------------------
@@ -61,13 +59,13 @@ compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $
 linePragmas :: Int -> [String] -> Lines
 linePragmas _ [] = []
 linePragmas columns (p:pragmas') =
-  let (ls, curr, _) = foldl step ([], p, length p) pragmas'
+  let (ls, curr, _) = foldl stp ([], p, length p) pragmas'
       ps = ls ++ [curr]
       longest = maximum $ map length ps
   in map (wrapLANGUAGE . padRight longest) ps
   where
     maxWidth = columns - 17
-    step (ls, curr, width) str
+    stp (ls, curr, width) str
       | width' > maxWidth = (ls ++ [curr], str, len)
       | otherwise         = (ls, curr ++ ", " ++ str, width')
       where
@@ -75,13 +73,26 @@ linePragmas columns (p:pragmas') =
         width' = width + 2 + len
     wrapLANGUAGE ps = "{-# LANGUAGE " ++ ps ++  " #-}"
 
+prettyPragmas :: Int -> Int -> Style -> [String] -> Lines
+prettyPragmas _       longest Vertical = verticalPragmas longest
+prettyPragmas columns _       Compact  = compactPragmas columns
+prettyPragmas columns _       Line     = linePragmas columns
 
 --------------------------------------------------------------------------------
-prettyPragmas :: Int -> Style -> [String] -> Lines
-prettyPragmas _       Vertical = verticalPragmas
-prettyPragmas columns Compact  = compactPragmas columns
-prettyPragmas columns Line     = linePragmas    columns
-
+-- | Filter redundant (and duplicate) pragmas out of the groups. As a side
+-- effect, we also sort the pragmas in their group...
+filterRedundant :: (String -> Bool)
+                -> [(l, [String])]
+                -> [(l, [String])]
+filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, [])
+  where
+    filterRedundant' (l, xs) (known, zs)
+        | S.null xs' = (known', zs)
+        | otherwise  = (known', (l, S.toAscList xs') : zs)
+      where
+        fxs    = filter (not . isRedundant') xs
+        xs'    = S.fromList fxs `S.difference` known
+        known' = xs' `S.union` known
 
 --------------------------------------------------------------------------------
 step :: Int -> Style -> Bool -> Step
@@ -94,15 +105,17 @@ step' columns style removeRedundant ls (module', _)
     | null pragmas' = ls
     | otherwise     = applyChanges changes ls
   where
-    filterRedundant
-        | removeRedundant = filter (not . isRedundant module')
-        | otherwise       = id
+    isRedundant'
+        | removeRedundant = isRedundant module'
+        | otherwise       = const False
 
     pragmas' = pragmas $ fmap linesFromSrcSpan module'
-    uniques  = filterRedundant $ nub $ sort $ snd =<< pragmas'
-    loc      = firstLocation pragmas'
-    deletes  = map (delete . fst) pragmas'
-    changes  = insert loc (prettyPragmas columns style uniques) : deletes
+    longest  = maximum $ map length $ snd =<< pragmas'
+    groups   = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas']
+    changes  =
+        [ change b (const $ prettyPragmas columns longest style pg)
+        | (b, pg) <- filterRedundant isRedundant' groups
+        ]
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Language/Haskell/Stylish/Util.hs b/src/Language/Haskell/Stylish/Util.hs
index bd0a466..004c3f1 100644
--- a/src/Language/Haskell/Stylish/Util.hs
+++ b/src/Language/Haskell/Stylish/Util.hs
@@ -65,11 +65,14 @@ wrap maxWidth leading ind strs =
     -- TODO: In order to optimize this, use a difference list instead of a
     -- regular list for 'ls'.
     step (ls, curr, width) str
-        | width' > maxWidth = (ls ++ [curr], indent ind str, ind + len)
-        | otherwise         = (ls, curr ++ " " ++ str, width')
+        | nextLine  = (ls ++ [curr], indent ind str, ind + len)
+        | otherwise = (ls, curr ++ " " ++ str, width')
       where
-        len    = length str
-        width' = width + 1 + len
+        -- Put it on the next line if it would make the current line too long,
+        -- AND if it doesn't make the next line too long.
+        nextLine = width' > maxWidth && ind + len <= maxWidth
+        len      = length str
+        width'   = width + 1 + len
 
 
 --------------------------------------------------------------------------------