module Autoexporter ( autoexporter ) where
import qualified Control.Exception as Exception
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Distribution.ModuleName as Cabal
import qualified Distribution.Text as Cabal
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.FilePath as FilePath
autoexporter :: IO ()
autoexporter :: IO ()
autoexporter = do
[String]
arguments <- IO [String]
Environment.getArgs
(String
input, String
output, Depth
depth) <- case [String]
arguments of
[String
input, String
_, String
output] -> (String, String, Depth) -> IO (String, String, Depth)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
input, String
output, Depth
DepthShallow)
[String
input, String
_, String
output, String
"--deep"] -> (String, String, Depth) -> IO (String, String, Depth)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
input, String
output, Depth
DepthDeep)
[String]
_ -> InvalidArguments -> IO (String, String, Depth)
forall e a. Exception e => e -> IO a
Exception.throwIO ([String] -> InvalidArguments
InvalidArguments [String]
arguments)
ModuleName
moduleName <- case String -> Maybe ModuleName
toModuleName String
input of
Just ModuleName
moduleName -> ModuleName -> IO ModuleName
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleName
moduleName
Maybe ModuleName
Nothing -> InvalidModuleName -> IO ModuleName
forall e a. Exception e => e -> IO a
Exception.throwIO (String -> InvalidModuleName
InvalidModuleName String
input)
[String]
entries <- Depth -> String -> IO [String]
listDirectory Depth
depth (String -> String
FilePath.dropExtension String
input)
let moduleNames :: [ModuleName]
moduleNames = [String] -> [ModuleName]
getModuleNames [String]
entries
let content :: String
content = ModuleName -> [ModuleName] -> String
renderModule ModuleName
moduleName [ModuleName]
moduleNames
String -> String -> IO ()
writeFile String
output String
content
data Depth
= DepthShallow
| DepthDeep
deriving (Depth -> Depth -> Bool
(Depth -> Depth -> Bool) -> (Depth -> Depth -> Bool) -> Eq Depth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Depth -> Depth -> Bool
$c/= :: Depth -> Depth -> Bool
== :: Depth -> Depth -> Bool
$c== :: Depth -> Depth -> Bool
Eq, Int -> Depth -> String -> String
[Depth] -> String -> String
Depth -> String
(Int -> Depth -> String -> String)
-> (Depth -> String) -> ([Depth] -> String -> String) -> Show Depth
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Depth] -> String -> String
$cshowList :: [Depth] -> String -> String
show :: Depth -> String
$cshow :: Depth -> String
showsPrec :: Int -> Depth -> String -> String
$cshowsPrec :: Int -> Depth -> String -> String
Show)
newtype InvalidArguments
= InvalidArguments [String]
deriving (InvalidArguments -> InvalidArguments -> Bool
(InvalidArguments -> InvalidArguments -> Bool)
-> (InvalidArguments -> InvalidArguments -> Bool)
-> Eq InvalidArguments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidArguments -> InvalidArguments -> Bool
$c/= :: InvalidArguments -> InvalidArguments -> Bool
== :: InvalidArguments -> InvalidArguments -> Bool
$c== :: InvalidArguments -> InvalidArguments -> Bool
Eq, Int -> InvalidArguments -> String -> String
[InvalidArguments] -> String -> String
InvalidArguments -> String
(Int -> InvalidArguments -> String -> String)
-> (InvalidArguments -> String)
-> ([InvalidArguments] -> String -> String)
-> Show InvalidArguments
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [InvalidArguments] -> String -> String
$cshowList :: [InvalidArguments] -> String -> String
show :: InvalidArguments -> String
$cshow :: InvalidArguments -> String
showsPrec :: Int -> InvalidArguments -> String -> String
$cshowsPrec :: Int -> InvalidArguments -> String -> String
Show)
instance Exception.Exception InvalidArguments
toModuleName :: FilePath -> Maybe Cabal.ModuleName
toModuleName :: String -> Maybe ModuleName
toModuleName
= [ModuleName] -> Maybe ModuleName
forall a. [a] -> Maybe a
Maybe.listToMaybe
([ModuleName] -> Maybe ModuleName)
-> (String -> [ModuleName]) -> String -> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe ModuleName) -> [String] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe String -> Maybe ModuleName
forall a. Parsec a => String -> Maybe a
Cabal.simpleParse
([String] -> [ModuleName])
-> (String -> [String]) -> String -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String) -> [[String]] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
".")
([[String]] -> [String])
-> (String -> [[String]]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]]
forall a. [a] -> [[a]]
List.tails
([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
FilePath.splitDirectories
(String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.dropExtensions
newtype InvalidModuleName
= InvalidModuleName FilePath
deriving (InvalidModuleName -> InvalidModuleName -> Bool
(InvalidModuleName -> InvalidModuleName -> Bool)
-> (InvalidModuleName -> InvalidModuleName -> Bool)
-> Eq InvalidModuleName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidModuleName -> InvalidModuleName -> Bool
$c/= :: InvalidModuleName -> InvalidModuleName -> Bool
== :: InvalidModuleName -> InvalidModuleName -> Bool
$c== :: InvalidModuleName -> InvalidModuleName -> Bool
Eq, Int -> InvalidModuleName -> String -> String
[InvalidModuleName] -> String -> String
InvalidModuleName -> String
(Int -> InvalidModuleName -> String -> String)
-> (InvalidModuleName -> String)
-> ([InvalidModuleName] -> String -> String)
-> Show InvalidModuleName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [InvalidModuleName] -> String -> String
$cshowList :: [InvalidModuleName] -> String -> String
show :: InvalidModuleName -> String
$cshow :: InvalidModuleName -> String
showsPrec :: Int -> InvalidModuleName -> String -> String
$cshowsPrec :: Int -> InvalidModuleName -> String -> String
Show)
instance Exception.Exception InvalidModuleName
listDirectory :: Depth -> FilePath -> IO [FilePath]
listDirectory :: Depth -> String -> IO [String]
listDirectory Depth
depth = case Depth
depth of
Depth
DepthShallow -> String -> IO [String]
listDirectoryShallow
Depth
DepthDeep -> String -> IO [String]
listDirectoryDeep
listDirectoryShallow :: FilePath -> IO [FilePath]
listDirectoryShallow :: String -> IO [String]
listDirectoryShallow String
directory = do
[String]
entries <- String -> IO [String]
Directory.listDirectory String
directory
[String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
FilePath.combine String
directory) [String]
entries)
listDirectoryDeep :: FilePath -> IO [FilePath]
listDirectoryDeep :: String -> IO [String]
listDirectoryDeep String
directory = do
[String]
entries <- String -> IO [String]
listDirectoryShallow String
directory
let
listEntry :: String -> IO [String]
listEntry String
entry = do
Bool
isDirectory <- String -> IO Bool
Directory.doesDirectoryExist String
entry
if Bool
isDirectory
then String -> IO [String]
listDirectoryDeep String
entry
else [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
entry]
([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
listEntry [String]
entries)
getModuleNames :: [FilePath] -> [Cabal.ModuleName]
getModuleNames :: [String] -> [ModuleName]
getModuleNames = [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a]
List.sort ([ModuleName] -> [ModuleName])
-> ([String] -> [ModuleName]) -> [String] -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe ModuleName) -> [String] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe String -> Maybe ModuleName
toModuleName ([String] -> [ModuleName])
-> ([String] -> [String]) -> [String] -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isHaskellFile
isHaskellFile :: FilePath -> Bool
isHaskellFile :: String -> Bool
isHaskellFile = (String -> [String] -> Bool) -> [String] -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [String]
haskellExtensions (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.takeExtensions
haskellExtensions :: [String]
haskellExtensions :: [String]
haskellExtensions = [String
".hs", String
".lhs"]
renderModule :: Cabal.ModuleName -> [Cabal.ModuleName] -> String
renderModule :: ModuleName -> [ModuleName] -> String
renderModule ModuleName
moduleName [ModuleName]
moduleNames = [String] -> String
unlines
[ String
"{-# OPTIONS_GHC -fno-warn-dodgy-exports -fno-warn-unused-imports #-}"
, String
"module " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ModuleName -> String
forall a. Pretty a => a -> String
Cabal.display ModuleName
moduleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" ((ModuleName -> String) -> [ModuleName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModuleName -> String
renderExport [ModuleName]
moduleNames)
, String
") where"
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" ((ModuleName -> String) -> [ModuleName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModuleName -> String
renderImport [ModuleName]
moduleNames)
]
renderExport :: Cabal.ModuleName -> String
renderExport :: ModuleName -> String
renderExport ModuleName
moduleName = String
"module " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ModuleName -> String
forall a. Pretty a => a -> String
Cabal.display ModuleName
moduleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
","
renderImport :: Cabal.ModuleName -> String
renderImport :: ModuleName -> String
renderImport ModuleName
moduleName = String
"import " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ModuleName -> String
forall a. Pretty a => a -> String
Cabal.display ModuleName
moduleName