-- Module SrcLoc ModuleName [ModulePragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl]
--
-- Module :: Maybe ModuleHead -> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
-- ModuleHead :: ModuleName -> Maybe WarningText -> Maybe ExportSpecList -> ModuleHead

-- so (Module sl *mn ps *w *exp imp decl)
--
-- -> Module (Just (ModuleHead mn w exp)) ps imp decl

{-# LANGUAGE TupleSections #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Builder.Modules
-- Copyright   :  (c) 2012 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Tools used by diagrams-builder for manipulating Haskell modules.
--
-----------------------------------------------------------------------------

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

------------------------------------------------------------
-- Manipulating modules
------------------------------------------------------------

-- | Extend some snippets of source code into a proper module, by
--   combining them intelligently (preserving imports, pragmas, /etc./),
--   (possibly) giving it a different name, and adding @LANGUAGE@ pragmas
--   and imports if necessary.  Only those pragmas and imports which
--   are not already included in the code will be added.
--
--   Returns the updated module, or an error message if parsing
--   failed.
createModule :: Maybe String -- ^ Module name to use
             -> 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)) [] [] []

-- | Run the haskell-src-exts parser on a @String@ representing some
--   Haskell code, producing a @Module@ or an error message.
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
        }

-- | Remove all the literate comments and bird tracks from a literate
--   Haskell file.  Has no effect on non-literate source.
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

-- | Replace the name of a module.
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

-- | Delete module exports.
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

-- | Add some @LANGUAGE@ pragmas to a module if necessary.
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

-- | Add some imports to a module if necessary.
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

-- | Combine two modules into one, with a left bias in the case of
--   things that can't be sensibly combined (/e.g./ the module name).
--   Note that combining multiple imports of the same module with
--   different import specifications (qualification, hiding, explicit
--   import) is unlikely to work sensibly.
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

-- | Convert a @ModuleName@ to a @String@.
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
  -- GHC warns about incomplete matches because ModuleName is now a
  -- pattern synonym, and the haskell-src-exts-simple package doesn't
  -- use COMPLETE pragmas