module Language.Haskell.Modules.Split
( splitModule
, splitModuleDecls
, defaultSymbolToModule
) where
import Control.Exception (throw)
import Control.Monad as List (mapM, mapM_)
import Data.Char (isAlpha, isAlphaNum, toUpper)
import Data.Default (Default(def))
import Data.Foldable as Foldable (fold)
import Data.List as List (filter, group, intercalate, map, nub, sort)
import Data.Map as Map (delete, elems, empty, filter, fromSet, insertWith, lookup, Map, mapWithKey)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import Data.Sequence ((<|), (|>))
import Data.Set as Set (empty, filter, fold, insert, intersection, map, member, null, Set, singleton, toList, union, unions)
import Data.Set.Extra as Set (gFind)
import qualified Language.Haskell.Exts.Annotated as A (Decl, ImportDecl(..), ImportSpecList(..), Module(..), ModuleHead(ModuleHead), Name)
import Language.Haskell.Exts.Annotated.Simplify (sExportSpec, sImportDecl, sImportSpec, sModule, sModuleName, sName)
import Language.Haskell.Exts.Pretty (defaultMode, prettyPrint, prettyPrintWithMode)
import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpanInfo(..))
import qualified Language.Haskell.Exts.Syntax as S (ExportSpec(..), ImportDecl(..), Module(..), ModuleName(..), Name(..))
import Language.Haskell.Modules.Common (doResult, ModuleResult(..), reportResult)
import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2)
import Language.Haskell.Modules.Imports (cleanResults)
import Language.Haskell.Modules.ModuVerse (findModule, getNames, ModuleInfo(..), moduleName, parseModule)
import Language.Haskell.Modules.Params (MonadClean(getParams), Params(extraImports))
import Language.Haskell.Modules.SourceDirs (modulePathBase, APath(..), pathKey)
import Language.Haskell.Modules.Util.QIO (qLnPutStr, quietly)
import Language.Haskell.Modules.Util.Symbols (exports, imports, symbols, members)
import Prelude hiding (writeFile)
import System.FilePath ((<.>))
splitModule :: MonadClean m =>
(Maybe S.Name -> S.ModuleName)
-> FilePath
-> m [ModuleResult]
splitModule symToModule path =
do info <- pathKey (APath path) >>= parseModule
splitModuleBy symToModule info
splitModuleDecls :: MonadClean m =>
FilePath
-> m [ModuleResult]
splitModuleDecls path =
do info <- pathKey (APath path) >>= parseModule
splitModuleBy (defaultSymbolToModule info) info
splitModuleBy :: MonadClean m =>
(Maybe S.Name -> S.ModuleName)
-> ModuleInfo
-> m [ModuleResult]
splitModuleBy _ (ModuleInfo (A.XmlPage {}) _ _ _) = error "XmlPage"
splitModuleBy _ (ModuleInfo (A.XmlHybrid {}) _ _ _) = error "XmlPage"
splitModuleBy _ m@(ModuleInfo (A.Module _ _ _ _ []) _ _ key) = return [Unchanged (moduleName m) key]
splitModuleBy _ m@(ModuleInfo (A.Module _ _ _ _ [_]) _ _ key) = return [Unchanged (moduleName m) key]
splitModuleBy _ (ModuleInfo (A.Module _ Nothing _ _ _) _ _ _) = throw $ userError $ "splitModule: no explicit header"
splitModuleBy symToModule inInfo =
do qLnPutStr ("Splitting module " ++ prettyPrint (moduleName inInfo))
quietly $
do eiMap <- getParams >>= return . extraImports
let inName = moduleName inInfo
allNames <- getNames >>= return . Set.union outNames
changes <- List.mapM (doModule symToModule eiMap inInfo inName outNames) (toList allNames)
changes' <- List.mapM doResult changes
List.mapM_ (\ x -> qLnPutStr ("splitModule: " ++ reportResult x)) changes'
cleanResults changes'
where
outNames = Set.map symToModule (union (declared inInfo) (exported inInfo))
doModule :: MonadClean m =>
(Maybe S.Name -> S.ModuleName)
-> Map S.ModuleName (Set S.ImportDecl)
-> ModuleInfo -> S.ModuleName
-> Set S.ModuleName -> S.ModuleName -> m ModuleResult
doModule symToModule eiMap inInfo inName outNames thisName =
case () of
_ | member thisName outNames ->
findModule thisName >>= \ thisInfo ->
return $ if thisName == inName
then ToBeModified thisName (key_ inInfo) newModule
else case thisInfo of
Just (ModuleInfo {key_ = key}) ->
error $ "splitModule: output module already exists: " ++ show key
_ -> ToBeCreated thisName newModule
| thisName == inName -> return (ToBeRemoved thisName (key_ inInfo))
| True ->
pathKey (modulePathBase "hs" thisName) >>= parseModule >>= \ oldInfo@(ModuleInfo _ oldText _ _) ->
let newText = updateImports oldInfo in
return $ if newText /= oldText then ToBeModified thisName (key_ oldInfo) newText else Unchanged thisName (key_ oldInfo)
where
newModule :: String
newModule = newHeader <> newExports <> newImports <> newDecls
newHeader =
Foldable.fold (foldHeader echo2 echo (\ _n pref _ suff r -> r |> pref <> prettyPrint thisName <> suff) echo inInfo mempty)
newExports =
maybe "\n ( " (\ _ -> Foldable.fold $ foldExports (<|) ignore ignore2 inInfo mempty) (moduleExports inInfo) <>
case Map.lookup thisName moduleDeclMap of
Nothing ->
doSeps (Foldable.fold (foldExports ignore2
(\ e pref s suff r ->
if setAny isReExported (Set.map (declClass inInfo) (symbols e))
then r |> [(pref, s <> suff)]
else r)
(\ s r -> r |> [("", s)]) inInfo mempty))
Just _ ->
intercalate sep (nub (List.map (prettyPrintWithMode defaultMode) newExports')) <> "\n" <>
maybe " ) where\n" (\ _ -> Foldable.fold $ foldExports ignore2 ignore (<|) inInfo mempty) (moduleExports inInfo)
where
newExports' :: [S.ExportSpec]
newExports' = nub (concatMap (exports . fst) modDecls)
doSeps :: [(String, String)] -> String
doSeps [] = ""
doSeps ((_, hd) : tl) = hd <> concatMap (\ (a, b) -> a <> b) tl
sep = exportSep "\n , " inInfo
newImports =
case (oldImportText, newImports'') of
([], "") -> "\n"
([], s) -> s
((pref, s, suff) : more, i) -> pref <> i <> s <> suff ++ concatMap (\ (pref', s', suff') -> pref' <> s' <> suff') more
where
oldImportText = foldImports (\ _ pref s suff r -> r ++ [(pref, s, suff)]) inInfo []
newImports'' =
case Map.lookup thisName moduleDeclMap of
Nothing -> ""
Just _ -> unlines (List.map (prettyPrintWithMode defaultMode) (newImports' ++ instanceImports thisName eiMap))
newImports' :: [S.ImportDecl]
newImports' =
elems $
mapWithKey toImportDecl $
Map.delete thisName $
Map.filter imported moduleDeclMap
where
imported pairs =
let declared' = justs (Set.unions (List.map (symbols . fst) pairs ++
List.map (members . fst) pairs)) in
not (Set.null (Set.intersection declared' referenced))
newDecls = concatMap snd modDecls
modDecls :: [(A.Decl SrcSpanInfo, String)]
modDecls = fromMaybe [] (Map.lookup thisName moduleDeclMap)
moduleExports (ModuleInfo (A.Module _ Nothing _ _ _) _ _ _) = Nothing
moduleExports (ModuleInfo (A.Module _ (Just (A.ModuleHead _ _ _ x)) _ _ _) _ _ _) = x
moduleExports (ModuleInfo _ _ _ _) = error "Unsupported module type"
updateImports :: ModuleInfo -> String
updateImports oldInfo =
Foldable.fold (foldModule echo2 echo echo echo echo2
(\ e pref s suff r -> r |> pref <> fixExport s (sExportSpec e) <> suff) echo2
(\ i pref s suff r -> r |> pref <> updateImportDecl s i <> suff)
echo echo2 oldInfo mempty)
where
fixExport :: String -> S.ExportSpec -> String
fixExport _ (S.EModuleContents m) | m == inName = intercalate sep (List.map (prettyPrint . S.EModuleContents) (toList outNames))
fixExport s _ = s
sep = exportSep "\n , " oldInfo
referenced :: Set S.Name
referenced = Set.map sName (gFind modDecls :: Set (A.Name SrcSpanInfo))
moduleDeclMap :: Map S.ModuleName [(A.Decl SrcSpanInfo, String)]
moduleDeclMap = foldDecls (\ d pref s suff r -> Set.fold (\ sym mp -> insertWith (\ a b -> b ++ a) (symToModule sym) [(d, pref <> s <> suff)] mp) r (symbols d)) ignore2 inInfo Map.empty
updateImportDecl :: String -> A.ImportDecl SrcSpanInfo -> String
updateImportDecl s i =
if sModuleName (A.importModule i) == inName
then intercalate "\n" (List.map prettyPrint (updateImportSpecs i (A.importSpecs i) ++ instanceImports thisName eiMap))
else s
updateImportSpecs :: A.ImportDecl SrcSpanInfo -> Maybe (A.ImportSpecList SrcSpanInfo) -> [S.ImportDecl]
updateImportSpecs i Nothing = List.map (\ x -> (sImportDecl i) {S.importModule = x}) (Set.toList moduleNames)
updateImportSpecs i (Just (A.ImportSpecList _ flag specs)) =
concatMap (\ spec -> let xs = List.map symToModule (toList (symbols spec)) in
List.map (\ x -> (sImportDecl i) {S.importModule = x, S.importSpecs = Just (flag, [sImportSpec spec])}) xs) specs
moduleNames :: Set S.ModuleName
moduleNames =
s
where
s = foldExports ignore2 (\ e _ _ _ r -> Set.fold (Set.insert . symToModule) r (symbols e)) ignore2 inInfo s'
s' = foldDecls (\ d _ _ _ r -> Set.fold (Set.insert . symToModule) r (symbols d)) ignore2 inInfo Set.empty
exportSep :: String -> ModuleInfo -> String
exportSep defsep info =
case seps of
[] -> defsep
(_ : xs) -> case (group . sort) xs of
[[x]] -> x
_ -> defsep
where
seps = foldModule ignore2 ignore ignore ignore ignore2
(\ _ pref _ suff r -> case r of
[] -> [suff]
(suff' : xs) -> suff : (pref ++ suff') : xs)
ignore2 ignore ignore ignore2 info []
declared :: ModuleInfo -> Set (Maybe S.Name)
declared m = foldDecls (\ d _pref _s _suff r -> Set.union (symbols d) r) ignore2 m Set.empty
exported :: ModuleInfo -> Set (Maybe S.Name)
exported m =
case hasExportList m of
False -> declared m
True -> union (foldExports ignore2 (\ e _pref _s _suff r -> Set.union (symbols e) r) ignore2 m Set.empty)
(if member Nothing (declared m) then singleton Nothing else Set.empty)
where
hasExportList :: ModuleInfo -> Bool
hasExportList (ModuleInfo (A.Module _ Nothing _ _ _) _ _ _) = False
hasExportList (ModuleInfo (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _) _ _ _) = False
hasExportList _ = True
instanceImports :: S.ModuleName -> Map S.ModuleName (Set S.ImportDecl) -> [S.ImportDecl]
instanceImports name eiMap = maybe [] toList (Map.lookup name eiMap)
data DeclClass
= Exported S.Name
| Internal S.Name
| ReExported S.Name
| Instance
| Unknown S.Name
deriving (Eq, Ord, Show)
declClass :: ModuleInfo -> Maybe S.Name -> DeclClass
declClass info@(ModuleInfo m _ _ _) mName =
unknown mName $ Map.lookup mName mp
where
unknown :: Maybe S.Name -> Maybe DeclClass -> DeclClass
unknown _ (Just x) = x
unknown Nothing _ = error "declClass Nothing"
unknown (Just x) _ = Unknown x
mp = Map.fromSet declClass' (union declaredSymbols exportedSymbols)
declClass' Nothing = Instance
declClass' x@(Just name) =
if member x exportedSymbols
then if member x declaredSymbols
then Exported name
else ReExported name
else Internal name
declaredSymbols = foldDecls (\ d _pref _s _suff r -> Set.union (symbols d) r) ignore2 info Set.empty
exportedSymbols =
case hasExportList (sModule m) of
False -> declaredSymbols
True -> union (foldExports ignore2 (\ e _pref _s _suff r -> Set.union (symbols e) r) ignore2 info Set.empty)
(if member Nothing declaredSymbols then singleton Nothing else Set.empty)
where
hasExportList :: S.Module -> Bool
hasExportList (S.Module _ _ _ _ Nothing _ _) = False
hasExportList _ = True
isReExported :: DeclClass -> Bool
isReExported (ReExported _) = True
isReExported _ = False
defaultSymbolToModule :: ModuleInfo
-> Maybe S.Name
-> S.ModuleName
defaultSymbolToModule info name =
S.ModuleName (parentModuleName <.>
case declClass info name of
Instance -> "Instances"
ReExported _ -> "ReExported"
Internal x -> "Internal" <.> f x
Unknown x -> "Unknown" <.> f x
Exported x -> f x)
where
S.ModuleName parentModuleName = moduleName info
f (S.Symbol s) = g s
f (S.Ident s) = g s
g (c : s) | isAlpha c = toUpper c : List.filter isAlphaNum s
g _ = "OtherSymbols"
instance Default S.ImportDecl where
def = S.ImportDecl {S.importLoc = SrcLoc "<unknown>.hs" 1 1,
S.importModule = S.ModuleName "Main",
S.importQualified = False,
S.importSrc = False,
S.importPkg = Nothing,
S.importAs = Nothing,
S.importSpecs = Just (False, [])}
toImportDecl :: S.ModuleName -> [(A.Decl SrcSpanInfo, String)] -> S.ImportDecl
toImportDecl (S.ModuleName modName) decls =
def { S.importModule = S.ModuleName modName
, S.importSpecs = Just (False, nub (concatMap (imports . fst) decls)) }
justs :: Ord a => Set (Maybe a) -> Set a
justs = Set.fold (\ mx s -> maybe s (`Set.insert` s) mx) Set.empty
setAny :: Ord a => (a -> Bool) -> Set a -> Bool
setAny f s = not (Set.null (Set.filter f s))