module Diagrams.Builder.Modules where
import Control.Lens ((^.))
import Data.Function (on)
import Data.List (foldl', groupBy, isPrefixOf, nub,
sortBy)
import Data.Ord (comparing)
import Language.Haskell.Exts
import Language.Haskell.Exts.SrcLoc (noLoc)
import Diagrams.Builder.Opts
createModule :: Maybe String
-> BuildOpts b v
-> Either String Module
createModule nm opts = do
ms <- mapM doModuleParse (opts ^. snippets)
return
. deleteExports
. maybe id replaceModuleName nm
. addPragmas (opts ^. pragmas)
. addImports (opts ^. imports)
. foldl' combineModules emptyModule
$ ms
emptyModule :: Module
emptyModule = Module noLoc (ModuleName "Main") [] Nothing Nothing [] []
doModuleParse :: String -> Either String Module
doModuleParse src =
case parseFileContentsWithMode parseMode src of
ParseFailed _ err -> Left err
ParseOk m -> return m
where
parseMode
= defaultParseMode
{ baseLanguage = Haskell2010
, fixities = Nothing
}
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 lpLoc ps : rest) = LanguagePragma lpLoc (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