git.iko.soy/hext
on e70c298 help sign in
c271871
swap
0 ahead, 2 behind
Setup.hs+6−2
since splitsnapshots
unifiedsplit
@@ -1,5 +1,9 @@
1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}
2+{-# LANGUAGE NoImplicitPrelude #-}
3+{-# LANGUAGE TypeApplications #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE DeriveAnyClass #-}
6+{-# LANGUAGE RecordWildCards #-}
3
7
4import Distribution.Simple
8import Distribution.Simple
5main = defaultMain
9main = defaultMain
app/Main.hs+4−2
@@ -1,5 +1,5 @@
1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}
2−{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}
2+{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}
3
3
4module Main where
4module Main where
5
5
@@ -8,6 +8,8 @@ import Relude
8import Control.Hext.Arguments
8import Control.Hext.Arguments
9import Control.Hext.Config
9import Control.Hext.Config
10import Control.Hext.Processor
10import Control.Hext.Processor
11+import Data.Haskell.Parser
12+import Text.Megaparsec
11
13
12main :: IO ()
14main :: IO ()
13main = do
15main = do
src/Control/Hext/Arguments.hs+21−37
@@ -1,50 +1,34 @@
1−{-# LANGUAGE DeriveAnyClass #-}
1+{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE NoImplicitPrelude #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE RecordWildCards #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}
8−{-# LANGUAGE TypeApplications #-}
9
3
10module Control.Hext.Arguments
4module Control.Hext.Arguments
11− ( parseOptions,
5+ ( parseOptions
12− Options (..),
6+ , Options(..)
13− )
14−where
7+ ) where
15
8
16−import Options.Applicative
17import Relude
9import Relude
18
10
11+import Options.Applicative
12+
19parseOptions :: IO Options
13parseOptions :: IO Options
20−parseOptions =
14+parseOptions = execParser $ info
21− execParser $
22− info
23− (Options <$> activeDirectoryArgument <*> extensionsFilePath)
15+ (Options <$> activeDirectoryArgument <*> extensionsFilePath)
24− ( fullDesc
16+ (fullDesc
25− <> progDesc "Add GHC extensions to source files automatically."
17+ <> progDesc "Add GHC extensions to source files automatically.")
26− )
27
18
28−data Options
19+data Options = Options
29− = Options
30− { activeDirectory :: Maybe FilePath,
20+ { activeDirectory :: Maybe FilePath
31− extensionsPath :: FilePath
21+ , extensionsPath :: FilePath
32− }
22+ }
33
23
34activeDirectoryArgument :: Parser (Maybe FilePath)
24activeDirectoryArgument :: Parser (Maybe FilePath)
35−activeDirectoryArgument =
25+activeDirectoryArgument = argument (maybeReader $ (Just . Just))
36− argument
37− (maybeReader $ (Just . Just))
38 ( help "The directiry to scan for .hs files."
26 ( help "The directiry to scan for .hs files."
39− <> value Nothing
27+ <> value Nothing )
40− )
41
28
42extensionsFilePath :: Parser FilePath
29extensionsFilePath :: Parser FilePath
43−extensionsFilePath =
30+extensionsFilePath = option auto
44− option
45− auto
46 ( short 'i'
31 ( short 'i'
47− <> long "input"
32+ <> long "input"
48− <> help "The input yaml file with extensions."
33+ <> help "The input yaml filw with extensions."
49− <> value ".hext.yaml"
34+ <> value ".hext.yaml" )
50− )
src/Control/Hext/Config.hs+24−34
@@ -1,51 +1,41 @@
1−{-# LANGUAGE DeriveAnyClass #-}
1+{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE NoImplicitPrelude #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE RecordWildCards #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}
8−{-# LANGUAGE TypeApplications #-}
9
3
10module Control.Hext.Config
4module Control.Hext.Config
11− ( getConfigs,
5+ ( getConfigs
12− Config (..),
6+ , Config(..)
13− LineLimit (..),
7+ , LineLimit(..)
14− )
15−where
8+ ) where
9+
10+import Relude
16
11
17import Data.Aeson as A
12import Data.Aeson as A
18import Data.Aeson.Casing
13import Data.Aeson.Casing
19import Data.Scientific
14import Data.Scientific
20import Data.Yaml
15import Data.Yaml
21−import Relude
22import System.Exit as SE
16import System.Exit as SE
23
17
24−data Config
18+data Config = Config
25− = Config
26− { extensions :: [Text],
19+ { extensions :: [Text]
27− src :: [FilePath],
20+ , src :: [FilePath]
28− lineLimit :: Maybe LineLimit
21+ , lineLimit :: Maybe LineLimit
29− }
30− deriving (Show, Eq, Ord, Generic)
22+ } deriving (Show, Eq, Ord, Generic)
31
23
32instance FromJSON Config where
24instance FromJSON Config where
33− parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = snakeCase}
25+ parseJSON = genericParseJSON $ defaultOptions { fieldLabelModifier = snakeCase }
34
26
35data LineLimit
27data LineLimit
36− = Limited Int
28+ = Limited Int
37− | Unlimited
29+ | Unlimited
38− deriving (Show, Generic, Eq, Ord)
30+ deriving (Show, Generic, Eq, Ord)
39
31
40instance FromJSON LineLimit where
32instance FromJSON LineLimit where
41− parseJSON (A.Number n)
33+ parseJSON (A.Number n)
42− | Right n' <- floatingOrInteger @Double n,
34+ | Right n' <- floatingOrInteger n
43− n' > 0 =
35+ , n' > 0
44− return $ Limited n'
36+ = return $ Limited n'
45− parseJSON (A.String "none") = return Unlimited
37+ parseJSON (A.String "none") = return Unlimited
46− parseJSON _ = fail "invalid line-limit value"
38+ parseJSON _ = fail "invalid line-limit value"
47
39
48getConfigs :: FilePath -> IO [Config]
40getConfigs :: 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+44−47
@@ -1,34 +1,35 @@
1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}
2−{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}
2+{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}
3
3
4module Control.Hext.Processor
4module Control.Hext.Processor
5− ( processFiles,
5+ ( processFiles
6− )
7−where
6+ ) where
7+
8+import Relude
8
9
9import Control.Hext.Config
10import Control.Hext.Config
10import Data.Haskell.Parser
11import Data.Haskell.Parser
11import Data.List hiding (head, unlines)
12import Data.List hiding (head, unlines)
12import qualified Data.Text as T
13import qualified Data.Text as T
13−import Relude
14import System.Directory.Tree
14import System.Directory.Tree
15
15
16getFiles :: FilePath -> IO [FilePath]
16getFiles :: FilePath -> IO [FilePath]
17getFiles dir = do
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+
24− getHs :: DirTree FilePath -> [FilePath]
25+ getHs :: DirTree FilePath -> [FilePath]
25− getHs (File _ path) | ".hs" `isSuffixOf` path = pure path
26+ getHs (File _ path) | ".hs" `isSuffixOf` path = pure path
26− getHs (Dir name paths) | not $ "." `isPrefixOf` name = paths >>= getHs
27+ getHs (Dir name paths) | not $ "." `isPrefixOf` name = paths >>= getHs
27− getHs _ = []
28+ getHs _ = []
28
29
29−processFile :: Text -> Text -> Text
30+processFile :: Maybe LineLimit -> Text -> Text -> Text
30−processFile extensions file =
31+processFile limit extensions file =
31− extensions
32+ extensions
32 <> "\n"
33 <> "\n"
33 <> withoutExtensions file
34 <> withoutExtensions file
34
35
@@ -39,31 +40,27 @@ baseLength :: Int
39baseLength = T.length $ wrapExtension ""
40baseLength = T.length $ wrapExtension ""
40
41
41processFiles :: Maybe LineLimit -> [Text] -> FilePath -> IO ()
42processFiles :: Maybe LineLimit -> [Text] -> FilePath -> IO ()
42−processFiles limit allExtensions dir = do
43+processFiles limit extensions dir = do
43− files <- getFiles dir
44+ files <- getFiles dir
44− forM_ files $ \file -> do
45+ forM_ files $ \file -> do
45− contents <- readFileText file
46+ contents <- readFileText file
46− writeFileText file . processFile (wrapExtensions allExtensions) $ contents
47+ writeFileText file . processFile limit (wrapExtensions extensions) $ contents
47− where
48+ where
48− wrapExtensions :: [Text] -> Text
49+ wrapExtensions :: [Text] -> Text
49− wrapExtensions [] = ""
50+ wrapExtensions [] = ""
50− wrapExtensions extensions@(e : ee) = case limit of
51+ wrapExtensions extensions@(e:ee) = case limit of
51− Nothing -> unlines . fmap wrapExtension $ extensions
52+ Nothing -> unlines . fmap wrapExtension $ extensions
52− Just Unlimited -> unlines . pure . wrapExtension . mconcat . intersperse ", " $ extensions
53+ Just Unlimited -> unlines . pure . wrapExtension . mconcat . intersperse ", " $ extensions
53− Just (Limited n) ->
54+ Just (Limited n) ->
54− let emptyExtra = ([], ee, baseLength + T.length e)
55+ let emptyExtra = ([], ee, baseLength + T.length e)
55− ee' =
56− unfoldr
56+ ee' = unfoldr (\case
57− ( \case
58− Nothing -> Nothing
57+ Nothing -> Nothing
59− (Just current@(_, [], _)) -> Just (current, Nothing)
58+ (Just current@(_, [], _)) -> Just (current, Nothing)
60− (Just current@(soFar, ne : next, l)) ->
59+ (Just current@(soFar, ne:next, l)) ->
61− let thing = (ne : soFar, next, l + T.length ne + 2)
60+ let thing = (ne:soFar, next, l + T.length ne + 2)
62− in Just (current, Just thing)
61+ in Just (current, Just thing))
63− )
64− (Just emptyExtra)
62+ (Just emptyExtra)
65− (extraExtensions, eLeft, _) =
63+ (extraExtensions, eLeft, _) =
66− fromMaybe emptyExtra . viaNonEmpty head . reverse . filter (\(_, _, n') -> n' <= n) $ ee'
64+ fromMaybe emptyExtra . viaNonEmpty head . reverse . filter (\(_, _, n') -> n' <= n) $ ee'
67− in (wrapExtension . mconcat . intersperse ", " $ e : reverse extraExtensions)
65+ in (wrapExtension . mconcat . intersperse ", " $ e:extraExtensions)
68− <> "\n"
69− <> wrapExtensions eLeft
66+ <> "\n" <> wrapExtensions eLeft
src/Data/Haskell/Parser.hs+3−3
@@ -1,12 +1,12 @@
1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeApplications, NoImplicitPrelude #-}
2−{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}
2+{-# LANGUAGE DeriveAnyClass, LambdaCase, ScopedTypeVariables, RecordWildCards #-}
3
3
4module Data.Haskell.Parser
4module Data.Haskell.Parser
5 ( withoutExtensions
5 ( withoutExtensions
6 , withoutExtensionsParser
6 , withoutExtensionsParser
7 ) where
7 ) where
8
8
9−import Relude hiding (many, some)
9+import Relude hiding (some, many)
10
10
11import Text.Megaparsec
11import Text.Megaparsec
12import Text.Megaparsec.Char
12import Text.Megaparsec.Char
stack.yaml−12
@@ -64,15 +64,3 @@ packages:
64#
64#
65# Allow a newer minor version of GHC than the snapshot specifies
65# Allow a newer minor version of GHC than the snapshot specifies
66# compiler-check: newer-minor
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+6−2
@@ -1,5 +1,9 @@
1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, NoImplicitPrelude, OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeApplications #-}
2+{-# LANGUAGE NoImplicitPrelude #-}
3+{-# LANGUAGE TypeApplications #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE DeriveAnyClass #-}
6+{-# LANGUAGE RecordWildCards #-}
3
7
4main :: IO ()
8main :: IO ()
5main = putStrLn "Test suite not yet implemented"
9main = putStrLn "Test suite not yet implemented"