e70c298...master · hext

git.iko.soy/hext

8 files changed+139−108

since splitsnapshots

unifiedsplit

Setup.hs+2−6 app/Main.hs+2−4 src/Control/Hext/Arguments.hs+37−21 src/Control/Hext/Config.hs+34−24 src/Control/Hext/Processor.hs+47−44 src/Data/Haskell/Parser.hs+3−3 stack.yaml+12 test/Spec.hs+2−6

Setup.hs+2−6

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

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−{-# LANGUAGE TypeApplications #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveAnyClass #-}

6−{-# LANGUAGE RecordWildCards #-}

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

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

84import Distribution.Simple

95main = defaultMain

app/Main.hs+2−4

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

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

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

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

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

44module Main where

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

88import Control.Hext.Arguments

99import Control.Hext.Config

1010import Control.Hext.Processor

11−import Data.Haskell.Parser

12−import Text.Megaparsec

1311

1412main :: IO ()

1513main = do

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

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

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

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

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE NoImplicitPrelude #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE RecordWildCards #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

410module Control.Hext.Arguments

5− ( parseOptions

6− , Options(..)

7− ) where

8−

9−import Relude

11+ ( parseOptions,

12+ Options (..),

13+ )

14+where

1015

1116import Options.Applicative

17+import Relude

1218

1319parseOptions :: IO Options

14−parseOptions = execParser $ info

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

16− (fullDesc

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

20+parseOptions =

21+ execParser $

22+ info

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

24+ ( fullDesc

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

26+ )

1827

19−data Options = Options

20− { activeDirectory :: Maybe FilePath

21− , extensionsPath :: FilePath

22− }

28+data Options

29+ = Options

30+ { activeDirectory :: Maybe FilePath,

31+ extensionsPath :: FilePath

32+ }

2333

2434activeDirectoryArgument :: Parser (Maybe FilePath)

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

35+activeDirectoryArgument =

36+ argument

37+ (maybeReader $ (Just . Just))

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

27− <> value Nothing )

39+ <> value Nothing

40+ )

2841

2942extensionsFilePath :: Parser FilePath

30−extensionsFilePath = option auto

43+extensionsFilePath =

44+ option

45+ auto

3146 ( short 'i'

32− <> long "input"

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

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

47+ <> long "input"

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

49+ <> value ".hext.yaml"

50+ )

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

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

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

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

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE NoImplicitPrelude #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE RecordWildCards #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

410module Control.Hext.Config

5− ( getConfigs

6− , Config(..)

7− , LineLimit(..)

8− ) where

9−

10−import Relude

11+ ( getConfigs,

12+ Config (..),

13+ LineLimit (..),

14+ )

15+where

1116

1217import Data.Aeson as A

1318import Data.Aeson.Casing

1419import Data.Scientific

1520import Data.Yaml

21+import Relude

1622import System.Exit as SE

1723

18−data Config = Config

19− { extensions :: [Text]

20− , src :: [FilePath]

21− , lineLimit :: Maybe LineLimit

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

24+data Config

25+ = Config

26+ { extensions :: [Text],

27+ src :: [FilePath],

28+ lineLimit :: Maybe LineLimit

29+ }

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

2331

2432instance FromJSON Config where

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

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

2634

2735data LineLimit

28− = Limited Int

29− | Unlimited

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

36+ = Limited Int

37+ | Unlimited

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

3139

3240instance FromJSON LineLimit where

33− parseJSON (A.Number n)

34− | Right n' <- floatingOrInteger n

35− , n' > 0

36− = return $ Limited n'

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

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

41+ parseJSON (A.Number n)

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

43+ n' > 0 =

44+ return $ Limited n'

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

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

3947

4048getConfigs :: FilePath -> IO [Config]

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

49+getConfigs f =

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

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 #-}

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

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

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

44module Control.Hext.Processor

5− ( processFiles

6− ) where

7−

8−import Relude

5+ ( processFiles,

6+ )

7+where

109import Control.Hext.Config

1110import Data.Haskell.Parser

1211import Data.List hiding (head, unlines)

1312import qualified Data.Text as T

13+import Relude

1414import System.Directory.Tree

1515

1616getFiles :: FilePath -> IO [FilePath]

1717getFiles dir = do

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

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

20− where

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

22− unwrapDir (Dir _ paths) = paths

23− unwrapDir _ = []

24−

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

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

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

28− getHs _ = []

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

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

20+ where

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

22+ unwrapDir (Dir _ paths) = paths

23+ unwrapDir _ = []

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

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

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

27+ getHs _ = []

2928

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

31−processFile limit extensions file =

32− extensions

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

30+processFile extensions file =

31+ extensions

3332 <> "\n"

3433 <> withoutExtensions file

3534

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

4039baseLength = T.length $ wrapExtension ""

4140

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

43−processFiles limit extensions dir = do

44− files <- getFiles dir

45− forM_ files $ \file -> do

46− contents <- readFileText file

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

48− where

49− wrapExtensions :: [Text] -> Text

50− wrapExtensions [] = ""

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

52− Nothing -> unlines . fmap wrapExtension $ extensions

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

54− Just (Limited n) ->

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

56− ee' = unfoldr (\case

57− Nothing -> Nothing

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

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

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

61− in Just (current, Just thing))

62− (Just emptyExtra)

63− (extraExtensions, eLeft, _) =

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

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

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

42+processFiles limit allExtensions dir = do

43+ files <- getFiles dir

44+ forM_ files $ \file -> do

45+ contents <- readFileText file

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

47+ where

48+ wrapExtensions :: [Text] -> Text

49+ wrapExtensions [] = ""

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

51+ Nothing -> unlines . fmap wrapExtension $ extensions

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

53+ Just (Limited n) ->

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

55+ ee' =

56+ unfoldr

57+ ( \case

58+ Nothing -> Nothing

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

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

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

62+ in Just (current, Just thing)

63+ )

64+ (Just emptyExtra)

65+ (extraExtensions, eLeft, _) =

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

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

68+ <> "\n"

69+ <> wrapExtensions eLeft

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

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

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

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

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

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

44module Data.Haskell.Parser

55 ( withoutExtensions

66 , withoutExtensionsParser

77 ) where

9−import Relude hiding (some, many)

9+import Relude hiding (many, some)

1010

1111import Text.Megaparsec

1212import Text.Megaparsec.Char

stack.yaml+12

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

6464#

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

6666# 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 #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−{-# LANGUAGE TypeApplications #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveAnyClass #-}

6−{-# LANGUAGE RecordWildCards #-}

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

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

84main :: IO ()

95main = putStrLn "Test suite not yet implemented"