e70c298..master · hext

git.iko.soy/hext

on master help sign in

Setup.hs+2−6

since splitsnapshots

unifiedsplit

@@ -1,9 +1,5 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−{-# LANGUAGE TypeApplications #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveAnyClass #-}

6−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}

8import Distribution.Simple

4import Distribution.Simple

9main = defaultMain

5main = defaultMain

app/Main.hs+2−4

@@ -1,5 +1,5 @@

1−{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}

2−{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}

2+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}

4module Main where

@@ -8,8 +8,6 @@ import Relude

8import Control.Hext.Arguments

9import Control.Hext.Config

10import Control.Hext.Processor

11−import Data.Haskell.Parser

12−import Text.Megaparsec

14main :: IO ()

12main :: IO ()

15main = do

13main = do

src/Control/Hext/Arguments.hs+37−21

@@ -1,34 +1,50 @@

1−{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE NoImplicitPrelude #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE RecordWildCards #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

4module Control.Hext.Arguments

10module Control.Hext.Arguments

5− ( parseOptions

11+ ( parseOptions,

6− , Options(..)

12+ Options (..),

13+ )

7− ) where

14+where

8−

9−import Relude

11import Options.Applicative

16import Options.Applicative

17+import Relude

13parseOptions :: IO Options

19parseOptions :: IO Options

14−parseOptions = execParser $ info

20+parseOptions =

21+ execParser $

22+ info

15− (Options <$> activeDirectoryArgument <*> extensionsFilePath)

23+ (Options <$> activeDirectoryArgument <*> extensionsFilePath)

16− (fullDesc

24+ ( fullDesc

17− <> progDesc "Add GHC extensions to source files automatically.")

25+ <> progDesc "Add GHC extensions to source files automatically."

26+ )

19−data Options = Options

28+data Options

29+ = Options

20− { activeDirectory :: Maybe FilePath

30+ { activeDirectory :: Maybe FilePath,

21− , extensionsPath :: FilePath

31+ extensionsPath :: FilePath

22− }

32+ }

24activeDirectoryArgument :: Parser (Maybe FilePath)

34activeDirectoryArgument :: Parser (Maybe FilePath)

25−activeDirectoryArgument = argument (maybeReader $ (Just . Just))

35+activeDirectoryArgument =

36+ argument

37+ (maybeReader $ (Just . Just))

26 ( help "The directiry to scan for .hs files."

38 ( help "The directiry to scan for .hs files."

27− <> value Nothing )

39+ <> value Nothing

40+ )

29extensionsFilePath :: Parser FilePath

42extensionsFilePath :: Parser FilePath

30−extensionsFilePath = option auto

43+extensionsFilePath =

44+ option

45+ auto

31 ( short 'i'

46 ( short 'i'

32− <> long "input"

47+ <> long "input"

33− <> help "The input yaml filw with extensions."

48+ <> help "The input yaml file with extensions."

34− <> value ".hext.yaml" )

49+ <> value ".hext.yaml"

50+ )

src/Control/Hext/Config.hs+34−24

@@ -1,41 +1,51 @@

1−{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE NoImplicitPrelude #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE RecordWildCards #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

4module Control.Hext.Config

10module Control.Hext.Config

5− ( getConfigs

11+ ( getConfigs,

6− , Config(..)

12+ Config (..),

7− , LineLimit(..)

13+ LineLimit (..),

14+ )

8− ) where

15+where

9−

10−import Relude

12import Data.Aeson as A

17import Data.Aeson as A

13import Data.Aeson.Casing

18import Data.Aeson.Casing

14import Data.Scientific

19import Data.Scientific

15import Data.Yaml

20import Data.Yaml

21+import Relude

16import System.Exit as SE

22import System.Exit as SE

18−data Config = Config

24+data Config

25+ = Config

19− { extensions :: [Text]

26+ { extensions :: [Text],

20− , src :: [FilePath]

27+ src :: [FilePath],

21− , lineLimit :: Maybe LineLimit

28+ lineLimit :: Maybe LineLimit

29+ }

22− } deriving (Show, Eq, Ord, Generic)

30+ deriving (Show, Eq, Ord, Generic)

24instance FromJSON Config where

32instance FromJSON Config where

25− parseJSON = genericParseJSON $ defaultOptions { fieldLabelModifier = snakeCase }

33+ parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = snakeCase}

27data LineLimit

35data LineLimit

28− = Limited Int

36+ = Limited Int

29− | Unlimited

37+ | Unlimited

30− deriving (Show, Generic, Eq, Ord)

38+ deriving (Show, Generic, Eq, Ord)

32instance FromJSON LineLimit where

40instance FromJSON LineLimit where

33− parseJSON (A.Number n)

41+ parseJSON (A.Number n)

34− | Right n' <- floatingOrInteger n

42+ | Right n' <- floatingOrInteger @Double n,

35− , n' > 0

43+ n' > 0 =

36− = return $ Limited n'

44+ return $ Limited n'

37− parseJSON (A.String "none") = return Unlimited

45+ parseJSON (A.String "none") = return Unlimited

38− parseJSON _ = fail "invalid line-limit value"

46+ parseJSON _ = fail "invalid line-limit value"

40getConfigs :: FilePath -> IO [Config]

48getConfigs :: FilePath -> IO [Config]

49+getConfigs f =

50+ (fmap . fmap) (\c@Config {..} -> c {extensions = sort extensions}) $

41−getConfigs f = decodeFileEither f >>= either (SE.die . prettyPrintParseException) return

51+ decodeFileEither f >>= either (SE.die . prettyPrintParseException) return

src/Control/Hext/Processor.hs+47−44

@@ -1,35 +1,34 @@

1−{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}

2−{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}

2+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}

4module Control.Hext.Processor

5− ( processFiles

5+ ( processFiles,

6+ )

6− ) where

7+where

7−

8−import Relude

10import Control.Hext.Config

9import Control.Hext.Config

11import Data.Haskell.Parser

10import Data.Haskell.Parser

12import Data.List hiding (head, unlines)

11import Data.List hiding (head, unlines)

13import qualified Data.Text as T

12import qualified Data.Text as T

13+import Relude

14import System.Directory.Tree

16getFiles :: FilePath -> IO [FilePath]

17getFiles dir = do

18− (_ :/ tree) <- readDirectoryWith return dir

18+ (_ :/ tree) <- readDirectoryWith return dir

19− return . (>>= getHs) . unwrapDir $ tree

19+ return . (>>= getHs) . unwrapDir $ tree

20− where

20+ where

21− unwrapDir :: DirTree a -> [DirTree a]

21+ unwrapDir :: DirTree a -> [DirTree a]

22− unwrapDir (Dir _ paths) = paths

22+ unwrapDir (Dir _ paths) = paths

23− unwrapDir _ = []

23+ unwrapDir _ = []

24−

25− getHs :: DirTree FilePath -> [FilePath]

24+ getHs :: DirTree FilePath -> [FilePath]

26− getHs (File _ path) | ".hs" `isSuffixOf` path = pure path

25+ getHs (File _ path) | ".hs" `isSuffixOf` path = pure path

27− getHs (Dir name paths) | not $ "." `isPrefixOf` name = paths >>= getHs

26+ getHs (Dir name paths) | not $ "." `isPrefixOf` name = paths >>= getHs

28− getHs _ = []

27+ getHs _ = []

30−processFile :: Maybe LineLimit -> Text -> Text -> Text

29+processFile :: Text -> Text -> Text

31−processFile limit extensions file =

30+processFile extensions file =

32− extensions

31+ extensions

33 <> "\n"

32 <> "\n"

34 <> withoutExtensions file

33 <> withoutExtensions file

@@ -40,27 +39,31 @@ baseLength :: Int

40baseLength = T.length $ wrapExtension ""

39baseLength = T.length $ wrapExtension ""

42processFiles :: Maybe LineLimit -> [Text] -> FilePath -> IO ()

41processFiles :: Maybe LineLimit -> [Text] -> FilePath -> IO ()

43−processFiles limit extensions dir = do

42+processFiles limit allExtensions dir = do

44− files <- getFiles dir

43+ files <- getFiles dir

45− forM_ files $ \file -> do

44+ forM_ files $ \file -> do

46− contents <- readFileText file

45+ contents <- readFileText file

47− writeFileText file . processFile limit (wrapExtensions extensions) $ contents

46+ writeFileText file . processFile (wrapExtensions allExtensions) $ contents

48− where

47+ where

49− wrapExtensions :: [Text] -> Text

48+ wrapExtensions :: [Text] -> Text

50− wrapExtensions [] = ""

49+ wrapExtensions [] = ""

51− wrapExtensions extensions@(e:ee) = case limit of

50+ wrapExtensions extensions@(e : ee) = case limit of

52− Nothing -> unlines . fmap wrapExtension $ extensions

51+ Nothing -> unlines . fmap wrapExtension $ extensions

53− Just Unlimited -> unlines . pure . wrapExtension . mconcat . intersperse ", " $ extensions

52+ Just Unlimited -> unlines . pure . wrapExtension . mconcat . intersperse ", " $ extensions

54− Just (Limited n) ->

53+ Just (Limited n) ->

55− let emptyExtra = ([], ee, baseLength + T.length e)

54+ let emptyExtra = ([], ee, baseLength + T.length e)

55+ ee' =

56− ee' = unfoldr (\case

56+ unfoldr

57+ ( \case

57− Nothing -> Nothing

58+ Nothing -> Nothing

58− (Just current@(_, [], _)) -> Just (current, Nothing)

59+ (Just current@(_, [], _)) -> Just (current, Nothing)

59− (Just current@(soFar, ne:next, l)) ->

60+ (Just current@(soFar, ne : next, l)) ->

60− let thing = (ne:soFar, next, l + T.length ne + 2)

61+ let thing = (ne : soFar, next, l + T.length ne + 2)

61− in Just (current, Just thing))

62+ in Just (current, Just thing)

63+ )

62− (Just emptyExtra)

64+ (Just emptyExtra)

63− (extraExtensions, eLeft, _) =

65+ (extraExtensions, eLeft, _) =

64− fromMaybe emptyExtra . viaNonEmpty head . reverse . filter (\(_, _, n') -> n' <= n) $ ee'

66+ fromMaybe emptyExtra . viaNonEmpty head . reverse . filter (\(_, _, n') -> n' <= n) $ ee'

65− in (wrapExtension . mconcat . intersperse ", " $ e:extraExtensions)

67+ in (wrapExtension . mconcat . intersperse ", " $ e : reverse extraExtensions)

68+ <> "\n"

66− <> "\n" <> wrapExtensions eLeft

69+ <> wrapExtensions eLeft

src/Data/Haskell/Parser.hs+3−3

@@ -1,12 +1,12 @@

1−{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}

2−{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}

2+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}

4module Data.Haskell.Parser

5 ( withoutExtensions

6 , withoutExtensionsParser

7 ) where

9−import Relude hiding (some, many)

9+import Relude hiding (many, some)

11import Text.Megaparsec

12import Text.Megaparsec.Char

stack.yaml+12

@@ -64,3 +64,15 @@ packages:

64#

65# Allow a newer minor version of GHC than the snapshot specifies

66# compiler-check: newer-minor

67+

68+ghc-options:

69+ "$locals":

70+ -Wall

71+ -Wincomplete-uni-patterns

72+ -Wincomplete-record-updates

73+ -Wmissing-exported-signatures

74+ -Wmissing-home-modules

75+ -Widentities

76+ -Wmissed-specialisations

77+ -Wall-missed-specialisations

78+ -Wno-unused-do-bind

test/Spec.hs+2−6

@@ -1,9 +1,5 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−{-# LANGUAGE TypeApplications #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveAnyClass #-}

6−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}

8main :: IO ()

4main :: IO ()

9main = putStrLn "Test suite not yet implemented"

5main = putStrLn "Test suite not yet implemented"