-- | This package isn't really meant to be used as a library. It's typically
-- used as a GHC preprocessor, like so:
--
-- > {-# OPTIONS_GHC -F -pgmF autoexporter #-}
--
-- For more information, please see the README on GitHub:
-- <https://github.com/tfausak/autoexporter#readme>.
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
  -- Start by getting the command line arguments. We expect three positional
  -- arguments from GHC: the path to the original source file, the path to the
  -- actual input file, and the path to the output file. The source and input
  -- files could be different if another preprocessor is involved. Since we
  -- don't consider the file's contents, we can ignore the input file.
  --
  -- After GHC's arguments, we have to check for anything passed in by the user
  -- with @-optF@.
  [String]
arguments <- IO [String]
Environment.getArgs
  (String
input, String
output, Depth
depth) <- case [String]
arguments of
    [String
input, String
_, String
output] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
input, String
output, Depth
DepthShallow)
    [String
input, String
_, String
output, String
"--deep"] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
input, String
output, Depth
DepthDeep)
    [String]
_ -> forall e a. Exception e => e -> IO a
Exception.throwIO ([String] -> InvalidArguments
InvalidArguments [String]
arguments)

  -- Next we convert the original source file path into a module name. If we
  -- aren't able to do this then something weird is going on and we should
  -- crash.
  ModuleName
moduleName <- case String -> Maybe ModuleName
toModuleName String
input of
    Just ModuleName
moduleName -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleName
moduleName
    Maybe ModuleName
Nothing -> forall e a. Exception e => e -> IO a
Exception.throwIO (String -> InvalidModuleName
InvalidModuleName String
input)

  -- Then we want to find all of the relevant modules to re-export. Note that
  -- we simply ignore non-Haskell files and files that don't form valid module
  -- names. Also we sort the module names so that the output is deterministic.
  [String]
entries <- Depth -> String -> IO [String]
listDirectory Depth
depth (String -> String
FilePath.dropExtension String
input)
  let moduleNames :: [ModuleName]
moduleNames = [String] -> [ModuleName]
getModuleNames [String]
entries

  -- Finally we render the module and write it to the output file.
  let content :: String
content = ModuleName -> [ModuleName] -> String
renderModule ModuleName
moduleName [ModuleName]
moduleNames
  String -> String -> IO ()
writeFile String
output String
content


-- | This type describes how to search for modules to export. A shallow search
-- only considers files in one directory. A deep search considers all files in
-- the directory tree.
data Depth
  = DepthShallow
  | DepthDeep
  deriving (Depth -> Depth -> Bool
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
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)


-- | This exception type is thrown when we don't know how to interpret the
-- arguments passed to the program.
newtype InvalidArguments
  = InvalidArguments [String]
  deriving (InvalidArguments -> InvalidArguments -> Bool
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
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


-- | This function attempts to convert an arbitrary file path into a valid
-- Haskell module name. Any extensions are ignored.
--
-- >>> toModuleName "invalid/module.name"
-- Nothing
-- >>> toModuleName "valid/Module.name"
-- Just (ModuleName ["Module"])
-- >>> toModuleName "Qualified/Module.name"
-- Just (ModuleName ["Qualified","Module"])
toModuleName :: FilePath -> Maybe Cabal.ModuleName
toModuleName :: String -> Maybe ModuleName
toModuleName =
  forall a. [a] -> Maybe a
Maybe.listToMaybe
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (forall a. Parsec a => String -> Maybe a
Cabal.simpleParse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
List.intercalate String
".")
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
List.tails
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
FilePath.splitDirectories
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.dropExtensions


-- | This exception type is thrown when we can't create a valid module name
-- from the source file path.
newtype InvalidModuleName
  = InvalidModuleName FilePath
  deriving (InvalidModuleName -> InvalidModuleName -> Bool
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
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


-- | Lists all of the entries in the given directory. Note that unlike
-- 'Directory.listDirectory' the results of calling this function will include
-- the original directory name.
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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
entry]
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
listEntry [String]
entries)


-- | Given a list of file paths, returns a sorted list of module names from the
-- entries that were Haskell files.
getModuleNames :: [FilePath] -> [Cabal.ModuleName]
getModuleNames :: [String] -> [ModuleName]
getModuleNames =
  forall a. Ord a => [a] -> [a]
List.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe String -> Maybe ModuleName
toModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isHaskellFile


-- | This predicate tells you if the given file path is a Haskell source file.
isHaskellFile :: FilePath -> Bool
isHaskellFile :: String -> Bool
isHaskellFile = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [String]
haskellExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.takeExtensions


-- | These are the extensions that we consider to be Haskell source files.
haskellExtensions :: [String]
haskellExtensions :: [String]
haskellExtensions = [String
".hs", String
".lhs"]


-- | Given a module name and a list of module names to re-export, renders a
-- module with all the appropriate imports and exports.
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 " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
Cabal.display ModuleName
moduleName forall a. Semigroup a => a -> a -> a
<> String
" ("
  , forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModuleName -> String
renderExport [ModuleName]
moduleNames)
  , String
") where"
  , forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (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 " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
Cabal.display ModuleName
moduleName forall a. Semigroup a => a -> a -> a
<> String
","


renderImport :: Cabal.ModuleName -> String
renderImport :: ModuleName -> String
renderImport ModuleName
moduleName = String
"import " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
Cabal.display ModuleName
moduleName