@@ -1,46 +1,69 @@
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 #-}
73
84module Control.Hext.Processor
9− ( processFiles
10− ) where
5+ ( processFiles,
6+ )
7+where
118
9+import Control.Hext.Config
10+import Data.Haskell.Parser
11+import Data.List hiding (head, unlines)
12+import qualified Data.Text as T
1213import Relude
13−
14−import Data.List hiding (unlines)
1514import System.Directory.Tree
16−import Data.Haskell.Parser
1715
1816getFiles :: FilePath -> IO [FilePath]
1917getFiles dir = do
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 _ = []
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 _ = []
2628
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
29+processFile :: Text -> Text -> Text
3330processFile extensions file =
34− (unlines . fmap wrapExtension) extensions
31+ extensions
3532 <> "\n"
3633 <> withoutExtensions file
37− where
38− wrapExtension :: Text -> Text
39− wrapExtension e = "{-# LANGUAGE " <> e <> " #-}"
4034
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
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