{-# LANGUAGE TupleSections #-}
module Diagrams.Builder.Modules where
import Control.Arrow (second)
import Control.Lens ((^.))
import Data.Function (on)
import Data.List (foldl', groupBy, isPrefixOf, nub,
sortBy)
import Data.Maybe (isJust)
import Data.Ord (comparing)
import Language.Haskell.Exts.Simple
import Diagrams.Builder.Opts
createModule :: Maybe String
-> BuildOpts b v n
-> Either String Module
createModule :: forall b (v :: * -> *) n.
Maybe String -> BuildOpts b v n -> Either String Module
createModule Maybe String
nm BuildOpts b v n
opts = do
[Module]
ms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Either String Module
doModuleParse (BuildOpts b v n
opts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
snippets)
forall (m :: * -> *) a. Monad m => a -> m a
return
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Module
deleteExports
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id String -> Module -> Module
replaceModuleName Maybe String
nm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Module -> Module
addPragmas (BuildOpts b v n
opts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
pragmas)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Maybe String)] -> Module -> Module
addImports (forall a b. (a -> b) -> [a] -> [b]
map (,forall a. Maybe a
Nothing) (BuildOpts b v n
opts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
imports) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just) (BuildOpts b v n
opts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n.
Lens' (BuildOpts b v n) [(String, String)]
qimports))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Module -> Module -> Module
combineModules Module
emptyModule
forall a b. (a -> b) -> a -> b
$ [Module]
ms
emptyModule :: Module
emptyModule :: Module
emptyModule = Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module (forall a. a -> Maybe a
Just (ModuleName
-> Maybe WarningText -> Maybe ExportSpecList -> ModuleHead
ModuleHead (String -> ModuleName
ModuleName String
"Main") forall a. Maybe a
Nothing forall a. Maybe a
Nothing)) [] [] []
doModuleParse :: String -> Either String Module
doModuleParse :: String -> Either String Module
doModuleParse String
src =
case ParseMode -> String -> ParseResult Module
parseFileContentsWithMode ParseMode
parseMode String
src of
ParseFailed SrcLoc
sloc String
err -> forall a b. a -> Either a b
Left (forall a. Pretty a => a -> String
prettyPrint SrcLoc
sloc forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
err)
ParseOk Module
m -> forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
where
parseMode :: ParseMode
parseMode
= ParseMode
defaultParseMode
{ baseLanguage :: Language
baseLanguage = Language
Haskell2010
, fixities :: Maybe [Fixity]
fixities = forall a. Maybe a
Nothing
}
unLit :: String -> String
unLit :: String -> String
unLit String
src
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
"> " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
ls = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (String
"> " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall a b. (a -> b) -> a -> b
$ [String]
ls
| Bool
otherwise = String
src
where ls :: [String]
ls = String -> [String]
lines String
src
replaceModuleName :: String -> Module -> Module
replaceModuleName :: String -> Module -> Module
replaceModuleName String
m (Module Maybe ModuleHead
Nothing [ModulePragma]
p [ImportDecl]
i [Decl]
d)
= Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module (forall a. a -> Maybe a
Just (ModuleName
-> Maybe WarningText -> Maybe ExportSpecList -> ModuleHead
ModuleHead (String -> ModuleName
ModuleName String
m) forall a. Maybe a
Nothing forall a. Maybe a
Nothing)) [ModulePragma]
p [ImportDecl]
i [Decl]
d
replaceModuleName String
m (Module (Just (ModuleHead ModuleName
_ Maybe WarningText
w Maybe ExportSpecList
e)) [ModulePragma]
p [ImportDecl]
i [Decl]
d)
= Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module (forall a. a -> Maybe a
Just (ModuleName
-> Maybe WarningText -> Maybe ExportSpecList -> ModuleHead
ModuleHead (String -> ModuleName
ModuleName String
m) Maybe WarningText
w Maybe ExportSpecList
e)) [ModulePragma]
p [ImportDecl]
i [Decl]
d
replaceModuleName String
_ Module
m = Module
m
deleteExports :: Module -> Module
deleteExports :: Module -> Module
deleteExports (Module (Just (ModuleHead ModuleName
n Maybe WarningText
w Maybe ExportSpecList
_)) [ModulePragma]
p [ImportDecl]
i [Decl]
d)
= Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module (forall a. a -> Maybe a
Just (ModuleName
-> Maybe WarningText -> Maybe ExportSpecList -> ModuleHead
ModuleHead ModuleName
n Maybe WarningText
w forall a. Maybe a
Nothing)) [ModulePragma]
p [ImportDecl]
i [Decl]
d
deleteExports Module
m = Module
m
addPragmas :: [String] -> Module -> Module
addPragmas :: [String] -> Module -> Module
addPragmas [String]
langs (Module Maybe ModuleHead
h [ModulePragma]
p [ImportDecl]
i [Decl]
d) = Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module Maybe ModuleHead
h ([ModulePragma] -> [ModulePragma]
f [ModulePragma]
p) [ImportDecl]
i [Decl]
d
where f :: [ModulePragma] -> [ModulePragma]
f [] = [[Name] -> ModulePragma
LanguagePragma (forall a b. (a -> b) -> [a] -> [b]
map String -> Name
Ident [String]
langs)]
f (LanguagePragma [Name]
ps : [ModulePragma]
rest) = [Name] -> ModulePragma
LanguagePragma ([Name]
ps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Name
Ident [String]
langs) forall a. a -> [a] -> [a]
: [ModulePragma]
rest
f (ModulePragma
x : [ModulePragma]
rest) = ModulePragma
x forall a. a -> [a] -> [a]
: [ModulePragma] -> [ModulePragma]
f [ModulePragma]
rest
addPragmas [String]
_ Module
m = Module
m
addImports :: [(String, Maybe String)] -> Module -> Module
addImports :: [(String, Maybe String)] -> Module -> Module
addImports [(String, Maybe String)]
imps (Module Maybe ModuleHead
h [ModulePragma]
p [ImportDecl]
i [Decl]
d) = Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module Maybe ModuleHead
h [ModulePragma]
p (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, Maybe String) -> [ImportDecl] -> [ImportDecl]
addImport [ImportDecl]
i [(String, Maybe String)]
imps) [Decl]
d
where addImport :: (String, Maybe String) -> [ImportDecl] -> [ImportDecl]
addImport (String
imp, Maybe String
mq) [ImportDecl]
is
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> Maybe String -> ImportDecl -> Bool
sameImport String
imp Maybe String
mq) [ImportDecl]
is = [ImportDecl]
is
| Bool
otherwise = ModuleName
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe ModuleName
-> Maybe (ImportSpecList ())
-> ImportDecl
ImportDecl (String -> ModuleName
ModuleName String
imp) (forall a. Maybe a -> Bool
isJust Maybe String
mq) Bool
False Bool
False
forall a. Maybe a
Nothing (String -> ModuleName
ModuleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mq) forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: [ImportDecl]
is
sameImport :: String -> Maybe String -> ImportDecl -> Bool
sameImport String
imp Maybe String
mq ImportDecl
imp' =
((forall a. Eq a => a -> a -> Bool
==String
imp) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl -> ModuleName
importModule) ImportDecl
imp'
Bool -> Bool -> Bool
&& (forall a. Maybe a -> Bool
isJust Maybe String
mq forall a. Eq a => a -> a -> Bool
== ImportDecl -> Bool
importQualified ImportDecl
imp')
Bool -> Bool -> Bool
&& ((String -> ModuleName
ModuleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mq) forall a. Eq a => a -> a -> Bool
== ImportDecl -> Maybe ModuleName
importAs ImportDecl
imp')
addImports [(String, Maybe String)]
_ Module
m = Module
m
combineModules :: Module -> Module -> Module
combineModules :: Module -> Module -> Module
combineModules (Module Maybe ModuleHead
h [ModulePragma]
ps1 [ImportDecl]
i1 [Decl]
d1)
(Module Maybe ModuleHead
_ [ModulePragma]
ps2 [ImportDecl]
i2 [Decl]
d2) =
Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module Maybe ModuleHead
h [ModulePragma]
combinedPragmas [ImportDecl]
combinedImports ([Decl]
d1 forall a. [a] -> [a] -> [a]
++ [Decl]
d2)
where
combinedPragmas :: [ModulePragma]
combinedPragmas = [ModulePragma]
combinedLangPragmas forall a. [a] -> [a] -> [a]
++ [ModulePragma] -> [ModulePragma]
otherPragmas [ModulePragma]
ps1 forall a. [a] -> [a] -> [a]
++ [ModulePragma] -> [ModulePragma]
otherPragmas [ModulePragma]
ps2
combinedImports :: [ImportDecl]
combinedImports = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl -> ModuleName
importModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ImportDecl -> ModuleName
importModule)
forall a b. (a -> b) -> a -> b
$ [ImportDecl]
i1 forall a. [a] -> [a] -> [a]
++ [ImportDecl]
i2
combinedLangPragmas :: [ModulePragma]
combinedLangPragmas
= [[Name] -> ModulePragma
LanguagePragma (forall a. Eq a => [a] -> [a]
nub ([ModulePragma] -> [Name]
getLangPragmas [ModulePragma]
ps1 forall a. [a] -> [a] -> [a]
++ [ModulePragma] -> [Name]
getLangPragmas [ModulePragma]
ps2))]
getLangPragmas :: [ModulePragma] -> [Name]
getLangPragmas = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModulePragma -> [Name]
getLangPragma
getLangPragma :: ModulePragma -> [Name]
getLangPragma (LanguagePragma [Name]
ns) = [Name]
ns
getLangPragma ModulePragma
_ = []
otherPragmas :: [ModulePragma] -> [ModulePragma]
otherPragmas = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModulePragma -> Bool
isLangPragma)
isLangPragma :: ModulePragma -> Bool
isLangPragma (LanguagePragma {}) = Bool
True
isLangPragma ModulePragma
_ = Bool
False
combineModules Module
m1 Module
m2 = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Diagrams.Builder.Modules: weird modules " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Module
m1 forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Module
m2
getModuleName :: ModuleName -> String
getModuleName :: ModuleName -> String
getModuleName (ModuleName String
n) = String
n
getModuleName ModuleName
m = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Diagrams.Builder.Modules.getModuleName: got a ModuleName that isn't! " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ModuleName
m