module Development.FileModules where
import Control.Concurrent.Async (mapConcurrently)
import Control.Monad (forM)
import Data.String.Utils (split)
import Language.Haskell.Exts (ImportDecl (..),
ModuleHeadAndImports (..),
ModuleName (..), NonGreedy (..),
ParseResult (..),
#ifdef MIN_VERSION_haskell_src_exts
# if MIN_VERSION_haskell_src_exts(1,18,0)
SrcSpanInfo,
# endif
#else
SrcSpanInfo,
#endif
SrcLoc (..), parse)
import System.Directory
import System.FilePath
import Text.Regex
fileModulesRecur :: FilePath -> IO [String]
fileModulesRecur fname = run fname
where
run f = do
modules <- fileModules f
modules' <- flip mapConcurrently modules $ \m -> do
let pth = takeDirectory fname </> joinPath (split "." m) ++ ".hs"
isLocalModule <- doesFileExist pth
if isLocalModule
then run pth
else return [m]
return (concat modules')
#ifdef MIN_VERSION_haskell_src_exts
# if MIN_VERSION_haskell_src_exts(1,18,0)
getImportsFromHead :: NonGreedy (ModuleHeadAndImports SrcSpanInfo) -> [String]
getImportsFromHead (NonGreedy (ModuleHeadAndImports _ _ _ mimports)) =
map (helper . importModule) mimports
where
helper (ModuleName _ iname) = iname
# else
getImportsFromHead (NonGreedy{..}) =
map (helper . importModule) mimports
where
(ModuleHeadAndImports _ _ mimports) = unNonGreedy
helper (ModuleName iname) = iname
# endif
#else
getImportsFromHead :: NonGreedy (ModuleHeadAndImports SrcSpanInfo) -> [String]
getImportsFromHead (NonGreedy (ModuleHeadAndImports _ _ _ mimports)) =
map (helper . importModule) mimports
where
helper (ModuleName _ iname) = iname
#endif
fileModules :: FilePath -> IO [String]
fileModules fname = do
fcontents <- readFile fname
case parse $ sanitize fcontents of
(ParseOk rheadAndImports) -> return (getImportsFromHead rheadAndImports)
(ParseFailed (SrcLoc _ line col) err) -> error $
"Failed to parse module in " ++ fname ++ ":\n" ++
" (" ++ show line ++ ":" ++ show col ++ ") " ++ err ++ "\n" ++
" " ++ getLineCol fcontents (line, col)
where
sanitize =
unlines . map (removeMagicHash . removeCpp) . lines
removeCpp ('#':_) = ""
removeCpp l = l
removeMagicHash l = subRegex r l o
where
r = mkRegex "#"
o = ""
getLineCol fcontents (line, col) =
ln ++ "\n" ++
" " ++ replicate (col' 3) ' ' ++ "^^^"
where
ln = lines fcontents !! line
col' = let l = length ln
in if col > l then l else col