master..91010d0 · hext

git.iko.soy/hext

7 files changed+102−123

unifiedsplit

Setup.hs+6−2 app/Main.hs+2−2 src/Control/Hext/Arguments.hs+21−37 src/Control/Hext/Config.hs+24−34 src/Control/Hext/Processor.hs+41−44 src/Data/Haskell/Parser.hs+2−2 test/Spec.hs+6−2

Setup.hs+6−2

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

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

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

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE NoImplicitPrelude #-}

3+{-# LANGUAGE TypeApplications #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE DeriveAnyClass #-}

6+{-# LANGUAGE RecordWildCards #-}

48import Distribution.Simple

59main = defaultMain

app/Main.hs+2−2

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

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

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

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

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

44module Main where

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

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

1−{-# LANGUAGE DeriveAnyClass #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE LambdaCase #-}

4−{-# LANGUAGE NoImplicitPrelude #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE RecordWildCards #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

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

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

104module Control.Hext.Arguments

11− ( parseOptions,

12− Options (..),

13− )

14−where

5+ ( parseOptions

6+ , Options(..)

7+ ) where

158

16−import Options.Applicative

179import Relude

1810

11+import Options.Applicative

12+

1913parseOptions :: IO Options

20−parseOptions =

21− execParser $

22− info

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

24− ( fullDesc

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

26− )

14+parseOptions = execParser $ info

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

16+ (fullDesc

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

2718

28−data Options

29− = Options

30− { activeDirectory :: Maybe FilePath,

31− extensionsPath :: FilePath

32− }

19+data Options = Options

20+ { activeDirectory :: Maybe FilePath

21+ , extensionsPath :: FilePath

22+ }

3323

3424activeDirectoryArgument :: Parser (Maybe FilePath)

35−activeDirectoryArgument =

36− argument

37− (maybeReader $ (Just . Just))

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

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

39− <> value Nothing

40− )

27+ <> value Nothing )

4128

4229extensionsFilePath :: Parser FilePath

43−extensionsFilePath =

44− option

45− auto

30+extensionsFilePath = option auto

4631 ( short 'i'

47− <> long "input"

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

49− <> value ".hext.yaml"

50− )

32+ <> long "input"

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

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

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

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

1−{-# LANGUAGE DeriveAnyClass #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE LambdaCase #-}

4−{-# LANGUAGE NoImplicitPrelude #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE RecordWildCards #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

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

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

104module Control.Hext.Config

11− ( getConfigs,

12− Config (..),

13− LineLimit (..),

14− )

15−where

5+ ( getConfigs

6+ , Config(..)

7+ , LineLimit(..)

8+ ) where

10+import Relude

1611

1712import Data.Aeson as A

1813import Data.Aeson.Casing

1914import Data.Scientific

2015import Data.Yaml

21−import Relude

2216import System.Exit as SE

2317

24−data Config

25− = Config

26− { extensions :: [Text],

27− src :: [FilePath],

28− lineLimit :: Maybe LineLimit

29− }

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

18+data Config = Config

19+ { extensions :: [Text]

20+ , src :: [FilePath]

21+ , lineLimit :: Maybe LineLimit

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

3123

3224instance FromJSON Config where

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

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

3426

3527data LineLimit

36− = Limited Int

37− | Unlimited

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

28+ = Limited Int

29+ | Unlimited

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

3931

4032instance FromJSON LineLimit where

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"

33+ parseJSON (A.Number n)

34+ | Right n' <- floatingOrInteger @Double n

35+ , n' > 0

36+ = return $ Limited n'

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

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

4739

4840getConfigs :: FilePath -> IO [Config]

49−getConfigs f =

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

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

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

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

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

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

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

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

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

44module Control.Hext.Processor

5− ( processFiles,

6− )

7−where

5+ ( processFiles

6+ ) where

8+import Relude

910import Control.Hext.Config

1011import Data.Haskell.Parser

1112import Data.List hiding (head, unlines)

1213import 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− 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 _ = []

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 _ = []

2829

2930processFile :: Text -> Text -> Text

3031processFile extensions file =

31− extensions

32+ extensions

3233 <> "\n"

3334 <> withoutExtensions file

3435

@@ -40,30 +41,26 @@ baseLength = T.length $ wrapExtension ""

4041

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

4243processFiles 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

44+ files <- getFiles dir

45+ forM_ files $ \file -> do

46+ contents <- readFileText file

47+ writeFileText file . processFile (wrapExtensions allExtensions) $ 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

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

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

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

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

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

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

44module Data.Haskell.Parser

55 ( withoutExtensions

test/Spec.hs+6−2

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

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

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

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE NoImplicitPrelude #-}

3+{-# LANGUAGE TypeApplications #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE DeriveAnyClass #-}

6+{-# LANGUAGE RecordWildCards #-}

48main :: IO ()

59main = putStrLn "Test suite not yet implemented"