@@ -1,69 +1,46 @@
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 #-}
37
48module Control.Hext.Processor
5− ( processFiles,
6− )
7−where
9+ ( processFiles
10+ ) where
811
9−import Control.Hext.Config
10−import Data.Haskell.Parser
11−import Data.List hiding (head, unlines)
12−import qualified Data.Text as T
1312import Relude
13+
14+import Data.List hiding (unlines)
1415import System.Directory.Tree
16+import Data.Haskell.Parser
1517
1618getFiles :: FilePath -> IO [FilePath]
1719getFiles 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 _ = []
20+ (_ :/ tree) <- readDirectoryWith return dir
21+ return . (>>= getHs) . unwrapDir $ tree
22+ where
23+ unwrapDir :: DirTree a -> [DirTree a]
24+ unwrapDir (Dir _ paths) = paths
25+ unwrapDir _ = []
2826
29−processFile :: Text -> Text -> Text
27+ getHs :: DirTree FilePath -> [FilePath]
28+ getHs (File _ path) | ".hs" `isSuffixOf` path = pure path
29+ getHs (Dir name paths) | not $ "." `isPrefixOf` name = paths >>= getHs
30+ getHs _ = []
31+
32+processFile :: [Text] -> Text -> Text
3033processFile extensions file =
31− extensions
34+ (unlines . fmap wrapExtension) extensions
3235 <> "\n"
3336 <> withoutExtensions file
37+ where
38+ wrapExtension :: Text -> Text
39+ wrapExtension e = "{-# LANGUAGE " <> e <> " #-}"
3440
35−wrapExtension :: Text -> Text
36−wrapExtension ee = "{-# LANGUAGE " <> ee <> " #-}"
37−
38−baseLength :: Int
39−baseLength = T.length $ wrapExtension ""
40−
41−processFiles :: Maybe LineLimit -> [Text] -> FilePath -> IO ()
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
41+processFiles :: [Text] -> FilePath -> IO ()
42+processFiles extensions dir = do
43+ files <- getFiles dir
44+ forM_ files $ \file -> do
45+ contents <- readFileText file
46+ writeFileText file . processFile extensions $ contents