Make language extension prefix configurable

5 files changed, 58 insertions, 47 deletions

diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs
index 46543ec..7d7fb98 100644
--- a/lib/Language/Haskell/Stylish.hs
+++ b/lib/Language/Haskell/Stylish.hs
@@ -58,6 +58,7 @@ languagePragmas :: Int -- ^ columns
                 -> LanguagePragmas.Style
                 -> Bool -- ^ Pad to same length in vertical mode?
                 -> Bool -- ^ remove redundant?
+                -> String -- ^ language prefix
                 -> Step
 languagePragmas = LanguagePragmas.step
 
@@ -75,6 +76,7 @@ trailingWhitespace = TrailingWhitespace.step
 
 --------------------------------------------------------------------------------
 unicodeSyntax :: Bool -- ^ add language pragma?
+              -> String -- ^ language prefix
               -> Step
 unicodeSyntax = UnicodeSyntax.step
 
diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs
index 8f43131..e4adaf5 100644
--- a/lib/Language/Haskell/Stylish/Config.hs
+++ b/lib/Language/Haskell/Stylish/Config.hs
@@ -16,6 +16,7 @@ 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.Char                                        (toLower)
 import qualified Data.FileEmbed                                   as FileEmbed
 import           Data.List                                        (intercalate,
                                                                    nub)
@@ -80,12 +81,10 @@ configFilePath verbose Nothing              = do
     current    <- getCurrentDirectory
     configPath <- getXdgDirectory XdgConfig "stylish-haskell"
     home       <- getHomeDirectory
-    mbConfig   <- search verbose $
+    search verbose $
         [d </> configFileName | d <- ancestors current] ++
         [configPath </> "config.yaml", home </> configFileName]
 
-    return mbConfig
-
 search :: Verbose -> [FilePath] -> IO (Maybe FilePath)
 search _ []             = return Nothing
 search verbose (f : fs) = do
@@ -200,9 +199,9 @@ parseImports config o = Imports.step
         -- Note that padding has to be at least 1. Default is 4.
         <*> (o A..:? "empty_list_align"
             >>= parseEnum emptyListAligns (def Imports.emptyListAlign))
-        <*> o A..:? "list_padding" A..!= (def Imports.listPadding)
-        <*> o A..:? "separate_lists" A..!= (def Imports.separateLists)
-        <*> o A..:? "space_surround" A..!= (def Imports.spaceSurround))
+        <*> o A..:? "list_padding" A..!= def Imports.listPadding
+        <*> o A..:? "separate_lists" A..!= def Imports.separateLists
+        <*> o A..:? "space_surround" A..!= def Imports.spaceSurround)
   where
     def f = f Imports.defaultOptions
 
@@ -237,8 +236,9 @@ parseLanguagePragmas :: Config -> A.Object -> A.Parser Step
 parseLanguagePragmas config o = LanguagePragmas.step
     <$> pure (configColumns config)
     <*> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical)
-    <*> o A..:? "align" A..!= True
+    <*> o A..:? "align"            A..!= True
     <*> o A..:? "remove_redundant" A..!= True
+    <*> mkLanguage o
   where
     styles =
         [ ("vertical",     LanguagePragmas.Vertical)
@@ -248,6 +248,19 @@ parseLanguagePragmas config o = LanguagePragmas.step
 
 
 --------------------------------------------------------------------------------
+-- | Utilities for validating language prefixes
+mkLanguage :: A.Object -> A.Parser String
+mkLanguage o = do
+    lang <- o A..:? "language_prefix"
+    maybe (pure "LANGUAGE") validate lang
+    where 
+        validate :: String -> A.Parser String
+        validate s
+            | fmap toLower s == "language" = pure s
+            | otherwise = fail "please provide a valid language prefix"
+
+
+--------------------------------------------------------------------------------
 parseTabs :: Config -> A.Object -> A.Parser Step
 parseTabs _ o = Tabs.step
     <$> o A..:? "spaces" A..!= 8
@@ -262,3 +275,4 @@ parseTrailingWhitespace _ _ = return TrailingWhitespace.step
 parseUnicodeSyntax :: Config -> A.Object -> A.Parser Step
 parseUnicodeSyntax _ o = UnicodeSyntax.step
     <$> o A..:? "add_language_pragma" A..!= True
+    <*> mkLanguage o
diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs
index cad7e68..f71d1f6 100644
--- a/lib/Language/Haskell/Stylish/Editor.hs
+++ b/lib/Language/Haskell/Stylish/Editor.hs
@@ -1,3 +1,5 @@
+{-# language LambdaCase #-}
+
 --------------------------------------------------------------------------------
 -- | This module provides you with a line-based editor. It's main feature is
 -- that you can specify multiple changes at the same time, e.g.:
@@ -19,8 +21,7 @@ module Language.Haskell.Stylish.Editor
 
 
 --------------------------------------------------------------------------------
-import           Data.List                      (intercalate, sortBy)
-import           Data.Ord                       (comparing)
+import           Data.List                      (intercalate, sortOn)
 
 
 --------------------------------------------------------------------------------
@@ -31,7 +32,7 @@ import           Language.Haskell.Stylish.Block
 -- | Changes the lines indicated by the 'Block' into the given 'Lines'
 data Change a = Change
     { changeBlock :: Block a
-    , changeLines :: ([a] -> [a])
+    , changeLines :: [a] -> [a]
     }
 
 
@@ -49,7 +50,7 @@ applyChanges changes0
         intercalate ", " (map printBlock blocks)
     | otherwise          = go 1 changes1
   where
-    changes1 = sortBy (comparing (blockStart . changeBlock)) changes0
+    changes1 = sortOn (blockStart . changeBlock) changes0
     blocks   = map changeBlock changes1
 
     printBlock b = show (blockStart b) ++ "-" ++ show (blockEnd b)
@@ -87,7 +88,7 @@ change = Change
 --------------------------------------------------------------------------------
 -- | Change a single line for some other lines
 changeLine :: Int -> (a -> [a]) -> Change a
-changeLine start f = change (Block start start) $ \xs -> case xs of
+changeLine start f = change (Block start start) $ \case
     []      -> []
     (x : _) -> f x
 
diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs
index cdedfa8..34d05dc 100644
--- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs
+++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs
@@ -2,7 +2,6 @@
 module Language.Haskell.Stylish.Step.LanguagePragmas
     ( Style (..)
     , step
-
       -- * Utilities
     , addLanguagePragma
     ) where
@@ -42,9 +41,9 @@ firstLocation = minimum . map (blockStart . fst)
 
 
 --------------------------------------------------------------------------------
-verticalPragmas :: Int -> Bool -> [String] -> Lines
-verticalPragmas longest align pragmas' =
-    [ "{-# LANGUAGE " ++ pad pragma ++ " #-}"
+verticalPragmas :: String -> Int -> Bool -> [String] -> Lines
+verticalPragmas lg longest align pragmas' =
+    [ "{-# " ++ lg ++ " " ++ pad pragma ++ " #-}"
     | pragma <- pragmas'
     ]
   where
@@ -54,26 +53,22 @@ verticalPragmas longest align pragmas' =
 
 
 --------------------------------------------------------------------------------
-compactPragmas :: Int -> [String] -> Lines
-compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $
+compactPragmas :: String -> Int -> [String] -> Lines
+compactPragmas lg columns pragmas' = wrap columns ("{-# " ++ lg) 13 $
     map (++ ",") (init pragmas') ++ [last pragmas' ++ " #-}"]
 
 
 --------------------------------------------------------------------------------
-compactLinePragmas :: Int -> Bool -> [String] -> Lines
-compactLinePragmas _ _ [] = []
-compactLinePragmas columns align pragmas' = map (wrapLanguage . pad) prags
+compactLinePragmas :: String -> Int -> Bool -> [String] -> Lines
+compactLinePragmas _  _ _ [] = []
+compactLinePragmas lg columns align pragmas' = map (wrapLanguage . pad) prags
   where
-    wrapLanguage ps = "{-# LANGUAGE" ++ ps ++  " #-}"
-
+    wrapLanguage ps = "{-# " ++ lg ++ ps ++  " #-}"
     maxWidth = columns - 16
-
     longest  = maximum $ map length prags
-
     pad
       | align = padRight longest
       | otherwise = id
-
     prags = map truncateComma $ wrap maxWidth "" 1 $
       map (++ ",") (init pragmas') ++ [last pragmas']
 
@@ -87,10 +82,10 @@ truncateComma xs
 
 
 --------------------------------------------------------------------------------
-prettyPragmas :: Int -> Int -> Bool -> Style -> [String] -> Lines
-prettyPragmas _    longest align Vertical    = verticalPragmas longest align
-prettyPragmas cols _       _     Compact     = compactPragmas cols
-prettyPragmas cols _       align CompactLine = compactLinePragmas cols align
+prettyPragmas :: String -> Int -> Int -> Bool -> Style -> [String] -> Lines
+prettyPragmas lp _    longest align Vertical    = verticalPragmas lp longest align
+prettyPragmas lp cols _       _     Compact     = compactPragmas lp cols
+prettyPragmas lp cols _       align CompactLine = compactLinePragmas lp cols align
 
 
 --------------------------------------------------------------------------------
@@ -110,35 +105,34 @@ filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, [])
         known' = xs' `S.union` known
 
 --------------------------------------------------------------------------------
-step :: Int -> Style -> Bool -> Bool -> Step
-step = (((makeStep "LanguagePragmas" .) .) .) . step'
+step :: Int -> Style -> Bool -> Bool -> String -> Step
+step = ((((makeStep "LanguagePragmas" .) .) .) .) . step'
 
 
 --------------------------------------------------------------------------------
-step' :: Int -> Style -> Bool -> Bool -> Lines -> Module -> Lines
-step' columns style align removeRedundant ls (module', _)
+step' :: Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines
+step' columns style align removeRedundant lngPrefix ls (module', _)
     | null pragmas' = ls
     | otherwise     = applyChanges changes ls
   where
     isRedundant'
         | removeRedundant = isRedundant module'
         | otherwise       = const False
-
     pragmas' = pragmas $ fmap linesFromSrcSpan module'
     longest  = maximum $ map length $ snd =<< pragmas'
     groups   = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas']
     changes  =
-        [ change b (const $ prettyPragmas columns longest align style pg)
+        [ change b (const $ prettyPragmas lngPrefix columns longest align style pg)
         | (b, pg) <- filterRedundant isRedundant' groups
         ]
 
 
 --------------------------------------------------------------------------------
 -- | Add a LANGUAGE pragma to a module if it is not present already.
-addLanguagePragma :: String -> H.Module H.SrcSpanInfo -> [Change String]
-addLanguagePragma prag modu
+addLanguagePragma :: String -> String -> H.Module H.SrcSpanInfo -> [Change String]
+addLanguagePragma lg prag modu
     | prag `elem` present = []
-    | otherwise           = [insert line ["{-# LANGUAGE " ++ prag ++ " #-}"]]
+    | otherwise           = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]]
   where
     pragmas' = pragmas (fmap linesFromSrcSpan modu)
     present  = concatMap snd pragmas'
@@ -158,7 +152,7 @@ isRedundant _ _              = False
 -- | Check if the ViewPatterns language pragma is redundant.
 isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool
 isRedundantViewPatterns m = null
-    [() | H.PViewPat _ _ _ <- everything m :: [H.Pat H.SrcSpanInfo]]
+    [() | H.PViewPat {} <- everything m :: [H.Pat H.SrcSpanInfo]]
 
 
 --------------------------------------------------------------------------------
diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs
index 01e29e8..266e8e5 100644
--- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs
+++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs
@@ -39,12 +39,12 @@ replaceAll :: [(Int, [(Int, String)])] -> [Change String]
 replaceAll = map changeLine'
   where
     changeLine' (r, ns) = changeLine r $ \str -> return $
-        flip applyChanges str
+        applyChanges 
             [ change (Block c ec) (const repl)
             | (c, needle) <- sort ns
             , let ec = c + length needle - 1
             , repl <- maybeToList $ M.lookup needle unicodeReplacements
-            ]
+            ] str
 
 
 --------------------------------------------------------------------------------
@@ -104,15 +104,15 @@ between (startRow, startCol) (endRow, endCol) needle =
 
 
 --------------------------------------------------------------------------------
-step :: Bool -> Step
-step = makeStep "UnicodeSyntax" . step'
+step :: Bool -> String -> Step
+step = (makeStep "UnicodeSyntax" .) . step'
 
 
 --------------------------------------------------------------------------------
-step' :: Bool -> Lines -> Module -> Lines
-step' alp ls (module', _) = applyChanges changes ls
+step' :: Bool -> String -> Lines -> Module -> Lines
+step' alp lg ls (module', _) = applyChanges changes ls
   where
-    changes = (if alp then addLanguagePragma "UnicodeSyntax" module' else []) ++
+    changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++
         replaceAll perLine
     perLine = sort $ groupPerLine $
         typeSigs module' ls ++