module Diagrams.Builder.Modules where
import Data.Function (on)
import Data.List (foldl1', isPrefixOf, groupBy, sortBy, nub)
import Data.Ord (comparing)
import Language.Haskell.Exts
import Language.Haskell.Exts.SrcLoc (noLoc)
createModule :: Maybe String
-> [String]
-> [String]
-> [String]
-> Either String Module
createModule _ _ _ [] = Left "createModule: no source code given"
createModule nm langs imps srcs = do
ms <- mapM doModuleParse srcs
return
. deleteExports
. maybe id replaceModuleName nm
. addPragmas langs
. addImports imps
. foldl1' combineModules
$ ms
doModuleParse :: String -> Either String Module
doModuleParse src =
case parseFileContents src of
ParseFailed _ err -> Left err
ParseOk m -> return m
unLit :: String -> String
unLit src
| any ("> " `isPrefixOf`) ls = unlines . map (drop 2) . filter ("> " `isPrefixOf`) $ ls
| otherwise = src
where ls = lines src
replaceModuleName :: String -> Module -> Module
replaceModuleName m (Module l _ p w e i d) = Module l (ModuleName m) p w e i d
deleteExports :: Module -> Module
deleteExports (Module l n p w _ i d) = Module l n p w Nothing i d
addPragmas :: [String] -> Module -> Module
addPragmas langs (Module l n p w e i d) = Module l n (f p) w e i d
where f [] = [LanguagePragma noLoc (map Ident langs)]
f (LanguagePragma loc ps : rest) = LanguagePragma loc (ps ++ map Ident langs) : rest
f (x : rest) = x : f rest
addImports :: [String] -> Module -> Module
addImports imps (Module l n p w e i d) = Module l n p w e (foldr addImport i imps) d
where addImport imp is
| any ((==imp) . getModuleName . importModule) is = is
| otherwise = ImportDecl noLoc (ModuleName imp) False False Nothing Nothing Nothing : is
combineModules :: Module -> Module -> Module
combineModules (Module l1 n1 ps1 w1 e1 i1 d1)
(Module _ _ ps2 _ _ i2 d2) =
Module l1 n1 combinedPragmas w1 e1 combinedImports (d1 ++ d2)
where
combinedPragmas = combinedLangPragmas ++ otherPragmas ps1 ++ otherPragmas ps2
combinedImports = map head
. groupBy ((==) `on` importModule)
. sortBy (comparing importModule)
$ i1 ++ i2
combinedLangPragmas
= [LanguagePragma noLoc (nub (getLangPragmas ps1 ++ getLangPragmas ps2))]
getLangPragmas = concatMap getLangPragma
getLangPragma (LanguagePragma _ ns) = ns
getLangPragma _ = []
otherPragmas = filter (not . isLangPragma)
isLangPragma (LanguagePragma {}) = True
isLangPragma _ = False
getModuleName :: ModuleName -> String
getModuleName (ModuleName n) = n