diff options
author | Flavio Corpa <flavio.corpa@47deg.com> | 2019-11-20 19:21:51 +0100 |
---|---|---|
committer | Jasper Van der Jeugt <m@jaspervdj.be> | 2019-11-20 12:21:51 -0600 |
commit | 9e34f3e162a89f0df56132daf6caf1154ea180c8 (patch) | |
tree | 194a9dff5abc709ceee261c083c5dd94284d8bc9 | |
parent | 9958a5253a9498c29508895450c4ac47542d5f2a (diff) | |
download | stylish-haskell-9e34f3e162a89f0df56132daf6caf1154ea180c8.tar.gz |
Make language extension prefix configurable
-rw-r--r-- | data/stylish-haskell.yaml | 5 | ||||
-rw-r--r-- | lib/Language/Haskell/Stylish.hs | 2 | ||||
-rw-r--r-- | lib/Language/Haskell/Stylish/Config.hs | 28 | ||||
-rw-r--r-- | lib/Language/Haskell/Stylish/Editor.hs | 11 | ||||
-rw-r--r-- | lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs | 50 | ||||
-rw-r--r-- | lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 14 | ||||
-rw-r--r-- | stack.yaml | 2 | ||||
-rw-r--r-- | stack.yaml.lock | 26 | ||||
-rw-r--r-- | tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs | 42 | ||||
-rw-r--r-- | tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs | 19 |
10 files changed, 140 insertions, 59 deletions
diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 401d384..5200299 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -203,6 +203,11 @@ steps: # is set to true, it will remove those redundant pragmas. Default: true. remove_redundant: true + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + # Replace tabs by spaces. This is disabled by default. # - tabs: # # Number of spaces to use for each tab. Default: 8, as specified by the 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 ++ @@ -1,4 +1,4 @@ -resolver: lts-14.6 +resolver: lts-14.13 packages: - '.' diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..d3b719d --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,26 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Cabal-3.0.0.0@sha256:1ba37b8d80e89213b17db7b8b9ea0108da55ca65f8c0cbb7433881a284c5cf67,26027 + pantry-tree: + size: 71616 + sha256: 4f16f0a65304ab22f01cb7f6d25db2f15a168f4cefacde7864cb1e02eb3ea867 + original: + hackage: Cabal-3.0.0.0 +- completed: + hackage: haskell-src-exts-1.22.0@sha256:f558923a9c8f57402c33a8cc871b934027a5c65414404c87239f6cbd7357d54e,4541 + pantry-tree: + size: 96940 + sha256: 597b6f48bd409a4d0da013c4e356945c42e0d098966035d3aa68cd4a3ccd66c9 + original: + hackage: haskell-src-exts-1.22.0 +snapshots: +- completed: + size: 525876 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/13.yaml + sha256: 4a0e79eb194c937cc2a1852ff84d983c63ac348dc6bad5f38d20cab697036eef + original: lts-14.13 diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index 2d74813..7afbdfc 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -28,12 +28,15 @@ tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" , testCase "case 08" case08 , testCase "case 09" case09 , testCase "case 10" case10 + , testCase "case 11" case11 ] +lANG :: String +lANG = "LANGUAGE" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step 80 Vertical True False) input +case01 = expected @=? testStep (step 80 Vertical True False lANG) input where input = unlines [ "{-# LANGUAGE ViewPatterns #-}" @@ -52,7 +55,7 @@ case01 = expected @=? testStep (step 80 Vertical True False) input -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step 80 Vertical True True) input +case02 = expected @=? testStep (step 80 Vertical True True lANG) input where input = unlines [ "{-# LANGUAGE BangPatterns #-}" @@ -68,7 +71,7 @@ case02 = expected @=? testStep (step 80 Vertical True True) input -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step 80 Vertical True True) input +case03 = expected @=? testStep (step 80 Vertical True True lANG) input where input = unlines [ "{-# LANGUAGE BangPatterns #-}" @@ -84,7 +87,7 @@ case03 = expected @=? testStep (step 80 Vertical True True) input -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step 80 Compact True False) input +case04 = expected @=? testStep (step 80 Compact True False lANG) input where input = unlines [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," @@ -101,7 +104,7 @@ case04 = expected @=? testStep (step 80 Compact True False) input -------------------------------------------------------------------------------- case05 :: Assertion -case05 = expected @=? testStep (step 80 Vertical True False) input +case05 = expected @=? testStep (step 80 Vertical True False lANG) input where input = unlines [ "{-# LANGUAGE CPP #-}" @@ -122,7 +125,7 @@ case05 = expected @=? testStep (step 80 Vertical True False) input -------------------------------------------------------------------------------- case06 :: Assertion -case06 = expected @=? testStep (step 80 CompactLine True False) input +case06 = expected @=? testStep (step 80 CompactLine True False lANG) input where input = unlines [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," @@ -137,7 +140,7 @@ case06 = expected @=? testStep (step 80 CompactLine True False) input -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step 80 Vertical False False) input +case07 = expected @=? testStep (step 80 Vertical False False lANG) input where input = unlines [ "{-# LANGUAGE ViewPatterns #-}" @@ -157,7 +160,7 @@ case07 = expected @=? testStep (step 80 Vertical False False) input -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected @=? testStep (step 80 CompactLine False False) input +case08 = expected @=? testStep (step 80 CompactLine False False lANG) input where input = unlines [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," @@ -173,7 +176,7 @@ case08 = expected @=? testStep (step 80 CompactLine False False) input -------------------------------------------------------------------------------- case09 :: Assertion -case09 = expected @=? testStep (step 80 Compact True False) input +case09 = expected @=? testStep (step 80 Compact True False lANG) input where input = unlines [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++ @@ -187,7 +190,7 @@ case09 = expected @=? testStep (step 80 Compact True False) input -------------------------------------------------------------------------------- case10 :: Assertion -case10 = expected @=? testStep (step 80 Compact True False) input +case10 = expected @=? testStep (step 80 Compact True False lANG) input where input = unlines [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables," @@ -197,3 +200,22 @@ case10 = expected @=? testStep (step 80 Compact True False) input [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++ "TypeApplications #-}" ] + +-------------------------------------------------------------------------------- +case11 :: Assertion +case11 = expected @=? testStep (step 80 Vertical False False "language") input + where + input = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + + expected = unlines + [ "{-# language NoImplicitPrelude #-}" + , "{-# language ScopedTypeVariables #-}" + , "{-# language TemplateHaskell #-}" + , "{-# language ViewPatterns #-}" + , "module Main where" + ] diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index 9652350..e2ba34f 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -19,12 +19,13 @@ import Language.Haskell.Stylish.Tests.Util tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" [ testCase "case 01" case01 + , testCase "case 02" case02 ] -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step True) input +case01 = expected @=? testStep (step True "LANGUAGE") input where input = unlines [ "sort :: Ord a => [a] -> [a]" @@ -36,3 +37,19 @@ case01 = expected @=? testStep (step True) input , "sort ∷ Ord a ⇒ [a] → [a]" , "sort _ = []" ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = expected @=? testStep (step True "LaNgUaGe") input + where + input = unlines + [ "sort :: Ord a => [a] -> [a]" + , "sort _ = []" + ] + + expected = unlines + [ "{-# LaNgUaGe UnicodeSyntax #-}" + , "sort ∷ Ord a ⇒ [a] → [a]" + , "sort _ = []" + ]
\ No newline at end of file |