c271871 · hext · git.iko.soy

git.iko.soy/hext

Order is now sorted

commitc27187106e2b612998ed58558388ac44451499e3 authoriko <ilyakooo0@gmail.com> dateTue 15 Oct 2019, 22:07 (7 years ago) parent91010d0

7 files changed+123−102

unifiedsplit

Setup.hs+2−6 app/Main.hs+2−2 src/Control/Hext/Arguments.hs+37−21 src/Control/Hext/Config.hs+34−24 src/Control/Hext/Processor.hs+44−41 src/Data/Haskell/Parser.hs+2−2 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−2

@@ -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

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 @Double 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+44−41

@@ -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

3029processFile :: Text -> Text -> Text

3130processFile extensions file =

32− extensions

31+ extensions

3332 <> "\n"

3433 <> withoutExtensions file

3534

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

4140

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

4342processFiles limit allExtensions dir = do

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

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+2−2

@@ -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 Data.Haskell.Parser

55 ( withoutExtensions

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"