{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.GI.CodeGen.Code
    ( Code
    , ModuleInfo(moduleCode, sectionDocs)
    , ModuleFlag(..)
    , CodeGen
    , ExcCodeGen
    , CGError
    , genCode
    , evalCodeGen

    , writeModuleTree
    , listModuleTree
    , codeToText
    , transitiveModuleDeps
    , minBaseVersion
    , BaseVersion(..)
    , showBaseVersion

    , registerNSDependency
    , qualified
    , getDeps
    , recurseWithAPIs

    , handleCGExc
    , printCGError
    , notImplementedError
    , badIntroError
    , missingInfoError

    , indent
    , increaseIndent
    , bline
    , line
    , blank
    , group
    , comment
    , cppIf
    , CPPGuard(..)
    , hsBoot
    , submodule
    , setLanguagePragmas
    , addLanguagePragma
    , setGHCOptions
    , setModuleFlags
    , setModuleMinBase

    , getFreshTypeVariable
    , resetTypeVariableScope

    , exportModule
    , exportDecl
    , export
    , HaddockSection(..)
    , NamedSection(..)

    , addSectionFormattedDocs
    , prependSectionFormattedDocs

    , findAPI
    , getAPI
    , findAPIByName
    , getAPIs
    , getC2HMap

    , config
    , currentModule
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid (Monoid(..))
#endif
import Control.Monad (forM, unless, when)
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Except
import qualified Data.Foldable as F
import Data.Maybe (fromMaybe, catMaybes)
#if !MIN_VERSION_base(4,13,0)
import Data.Monoid ((<>), mempty)
#endif
import qualified Data.Map.Strict as M
import Data.Sequence (ViewL ((:<)), viewl, (|>))
import qualified Data.Sequence as Seq
import qualified Data.Semigroup as Sem
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy as LT

import GHC.Stack (HasCallStack)

import System.Directory (createDirectoryIfMissing)
import System.FilePath (joinPath, takeDirectory)

import Data.GI.CodeGen.API (API, Name(..))
import Data.GI.CodeGen.Config (Config(..))
import {-# SOURCE #-} Data.GI.CodeGen.CtoHaskellMap (cToHaskellMap,
                                                     Hyperlink)
import Data.GI.CodeGen.GtkDoc (CRef)
import Data.GI.CodeGen.ModulePath (ModulePath(..), dotModulePath, (/.))
import Data.GI.CodeGen.Type (Type(..))
import Data.GI.CodeGen.Util (tshow, terror, padTo, utf8WriteFile)
import Data.GI.CodeGen.ProjectInfo (authors, license, maintainers)

-- | Set of CPP conditionals understood by the code generator.
data CPPConditional = CPPIf Text -- ^ #if Foo
  deriving (CPPConditional -> CPPConditional -> Bool
(CPPConditional -> CPPConditional -> Bool)
-> (CPPConditional -> CPPConditional -> Bool) -> Eq CPPConditional
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CPPConditional -> CPPConditional -> Bool
== :: CPPConditional -> CPPConditional -> Bool
$c/= :: CPPConditional -> CPPConditional -> Bool
/= :: CPPConditional -> CPPConditional -> Bool
Eq, Int -> CPPConditional -> ShowS
[CPPConditional] -> ShowS
CPPConditional -> FilePath
(Int -> CPPConditional -> ShowS)
-> (CPPConditional -> FilePath)
-> ([CPPConditional] -> ShowS)
-> Show CPPConditional
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CPPConditional -> ShowS
showsPrec :: Int -> CPPConditional -> ShowS
$cshow :: CPPConditional -> FilePath
show :: CPPConditional -> FilePath
$cshowList :: [CPPConditional] -> ShowS
showList :: [CPPConditional] -> ShowS
Show, Eq CPPConditional
Eq CPPConditional
-> (CPPConditional -> CPPConditional -> Ordering)
-> (CPPConditional -> CPPConditional -> Bool)
-> (CPPConditional -> CPPConditional -> Bool)
-> (CPPConditional -> CPPConditional -> Bool)
-> (CPPConditional -> CPPConditional -> Bool)
-> (CPPConditional -> CPPConditional -> CPPConditional)
-> (CPPConditional -> CPPConditional -> CPPConditional)
-> Ord CPPConditional
CPPConditional -> CPPConditional -> Bool
CPPConditional -> CPPConditional -> Ordering
CPPConditional -> CPPConditional -> CPPConditional
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CPPConditional -> CPPConditional -> Ordering
compare :: CPPConditional -> CPPConditional -> Ordering
$c< :: CPPConditional -> CPPConditional -> Bool
< :: CPPConditional -> CPPConditional -> Bool
$c<= :: CPPConditional -> CPPConditional -> Bool
<= :: CPPConditional -> CPPConditional -> Bool
$c> :: CPPConditional -> CPPConditional -> Bool
> :: CPPConditional -> CPPConditional -> Bool
$c>= :: CPPConditional -> CPPConditional -> Bool
>= :: CPPConditional -> CPPConditional -> Bool
$cmax :: CPPConditional -> CPPConditional -> CPPConditional
max :: CPPConditional -> CPPConditional -> CPPConditional
$cmin :: CPPConditional -> CPPConditional -> CPPConditional
min :: CPPConditional -> CPPConditional -> CPPConditional
Ord)

-- | The generated `Code` is a sequence of `CodeToken`s.
newtype Code = Code (Seq.Seq CodeToken)
  deriving (NonEmpty Code -> Code
Code -> Code -> Code
(Code -> Code -> Code)
-> (NonEmpty Code -> Code)
-> (forall b. Integral b => b -> Code -> Code)
-> Semigroup Code
forall b. Integral b => b -> Code -> Code
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Code -> Code -> Code
<> :: Code -> Code -> Code
$csconcat :: NonEmpty Code -> Code
sconcat :: NonEmpty Code -> Code
$cstimes :: forall b. Integral b => b -> Code -> Code
stimes :: forall b. Integral b => b -> Code -> Code
Sem.Semigroup, Semigroup Code
Code
Semigroup Code
-> Code
-> (Code -> Code -> Code)
-> ([Code] -> Code)
-> Monoid Code
[Code] -> Code
Code -> Code -> Code
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Code
mempty :: Code
$cmappend :: Code -> Code -> Code
mappend :: Code -> Code -> Code
$cmconcat :: [Code] -> Code
mconcat :: [Code] -> Code
Monoid, Code -> Code -> Bool
(Code -> Code -> Bool) -> (Code -> Code -> Bool) -> Eq Code
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Code -> Code -> Bool
== :: Code -> Code -> Bool
$c/= :: Code -> Code -> Bool
/= :: Code -> Code -> Bool
Eq, Int -> Code -> ShowS
[Code] -> ShowS
Code -> FilePath
(Int -> Code -> ShowS)
-> (Code -> FilePath) -> ([Code] -> ShowS) -> Show Code
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Code -> ShowS
showsPrec :: Int -> Code -> ShowS
$cshow :: Code -> FilePath
show :: Code -> FilePath
$cshowList :: [Code] -> ShowS
showList :: [Code] -> ShowS
Show, Eq Code
Eq Code
-> (Code -> Code -> Ordering)
-> (Code -> Code -> Bool)
-> (Code -> Code -> Bool)
-> (Code -> Code -> Bool)
-> (Code -> Code -> Bool)
-> (Code -> Code -> Code)
-> (Code -> Code -> Code)
-> Ord Code
Code -> Code -> Bool
Code -> Code -> Ordering
Code -> Code -> Code
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Code -> Code -> Ordering
compare :: Code -> Code -> Ordering
$c< :: Code -> Code -> Bool
< :: Code -> Code -> Bool
$c<= :: Code -> Code -> Bool
<= :: Code -> Code -> Bool
$c> :: Code -> Code -> Bool
> :: Code -> Code -> Bool
$c>= :: Code -> Code -> Bool
>= :: Code -> Code -> Bool
$cmax :: Code -> Code -> Code
max :: Code -> Code -> Code
$cmin :: Code -> Code -> Code
min :: Code -> Code -> Code
Ord)

-- | Initializes a code block to the empty sequence.
emptyCode :: Code
emptyCode :: Code
emptyCode = Seq CodeToken -> Code
Code Seq CodeToken
forall a. Seq a
Seq.empty

-- | Checks whether the given code block is empty.
isCodeEmpty :: Code -> Bool
isCodeEmpty :: Code -> Bool
isCodeEmpty (Code Seq CodeToken
seq) = Seq CodeToken -> Bool
forall a. Seq a -> Bool
Seq.null Seq CodeToken
seq

-- | A block of code consisting of a single token.
codeSingleton :: CodeToken -> Code
codeSingleton :: CodeToken -> Code
codeSingleton CodeToken
t = Seq CodeToken -> Code
Code (CodeToken -> Seq CodeToken
forall a. a -> Seq a
Seq.singleton CodeToken
t)

-- | Possible code tokens.
data CodeToken
    = Line Text           -- ^ A single line, indented to current indentation.
    | Indent Code         -- ^ Indented region.
    | Group Code          -- ^ A grouped set of lines
    | Comment [Text]      -- ^ A (possibly multi line) comment
    | IncreaseIndent      -- ^ Increase the indentation for the rest
                          -- of the lines in the group.
    | CPPBlock CPPConditional Code -- ^ A block of code guarded by the
                                   -- given CPP conditional
    deriving (CodeToken -> CodeToken -> Bool
(CodeToken -> CodeToken -> Bool)
-> (CodeToken -> CodeToken -> Bool) -> Eq CodeToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodeToken -> CodeToken -> Bool
== :: CodeToken -> CodeToken -> Bool
$c/= :: CodeToken -> CodeToken -> Bool
/= :: CodeToken -> CodeToken -> Bool
Eq, Eq CodeToken
Eq CodeToken
-> (CodeToken -> CodeToken -> Ordering)
-> (CodeToken -> CodeToken -> Bool)
-> (CodeToken -> CodeToken -> Bool)
-> (CodeToken -> CodeToken -> Bool)
-> (CodeToken -> CodeToken -> Bool)
-> (CodeToken -> CodeToken -> CodeToken)
-> (CodeToken -> CodeToken -> CodeToken)
-> Ord CodeToken
CodeToken -> CodeToken -> Bool
CodeToken -> CodeToken -> Ordering
CodeToken -> CodeToken -> CodeToken
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CodeToken -> CodeToken -> Ordering
compare :: CodeToken -> CodeToken -> Ordering
$c< :: CodeToken -> CodeToken -> Bool
< :: CodeToken -> CodeToken -> Bool
$c<= :: CodeToken -> CodeToken -> Bool
<= :: CodeToken -> CodeToken -> Bool
$c> :: CodeToken -> CodeToken -> Bool
> :: CodeToken -> CodeToken -> Bool
$c>= :: CodeToken -> CodeToken -> Bool
>= :: CodeToken -> CodeToken -> Bool
$cmax :: CodeToken -> CodeToken -> CodeToken
max :: CodeToken -> CodeToken -> CodeToken
$cmin :: CodeToken -> CodeToken -> CodeToken
min :: CodeToken -> CodeToken -> CodeToken
Ord, Int -> CodeToken -> ShowS
[CodeToken] -> ShowS
CodeToken -> FilePath
(Int -> CodeToken -> ShowS)
-> (CodeToken -> FilePath)
-> ([CodeToken] -> ShowS)
-> Show CodeToken
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodeToken -> ShowS
showsPrec :: Int -> CodeToken -> ShowS
$cshow :: CodeToken -> FilePath
show :: CodeToken -> FilePath
$cshowList :: [CodeToken] -> ShowS
showList :: [CodeToken] -> ShowS
Show)

type Deps = Set.Set Text

-- | Subsection of the haddock documentation where the export should
-- be located, or alternatively the toplevel section.
data HaddockSection = ToplevelSection
                    | Section NamedSection
                    | NamedSubsection NamedSection Text
  deriving (Int -> HaddockSection -> ShowS
[HaddockSection] -> ShowS
HaddockSection -> FilePath
(Int -> HaddockSection -> ShowS)
-> (HaddockSection -> FilePath)
-> ([HaddockSection] -> ShowS)
-> Show HaddockSection
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HaddockSection -> ShowS
showsPrec :: Int -> HaddockSection -> ShowS
$cshow :: HaddockSection -> FilePath
show :: HaddockSection -> FilePath
$cshowList :: [HaddockSection] -> ShowS
showList :: [HaddockSection] -> ShowS
Show, HaddockSection -> HaddockSection -> Bool
(HaddockSection -> HaddockSection -> Bool)
-> (HaddockSection -> HaddockSection -> Bool) -> Eq HaddockSection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HaddockSection -> HaddockSection -> Bool
== :: HaddockSection -> HaddockSection -> Bool
$c/= :: HaddockSection -> HaddockSection -> Bool
/= :: HaddockSection -> HaddockSection -> Bool
Eq, Eq HaddockSection
Eq HaddockSection
-> (HaddockSection -> HaddockSection -> Ordering)
-> (HaddockSection -> HaddockSection -> Bool)
-> (HaddockSection -> HaddockSection -> Bool)
-> (HaddockSection -> HaddockSection -> Bool)
-> (HaddockSection -> HaddockSection -> Bool)
-> (HaddockSection -> HaddockSection -> HaddockSection)
-> (HaddockSection -> HaddockSection -> HaddockSection)
-> Ord HaddockSection
HaddockSection -> HaddockSection -> Bool
HaddockSection -> HaddockSection -> Ordering
HaddockSection -> HaddockSection -> HaddockSection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HaddockSection -> HaddockSection -> Ordering
compare :: HaddockSection -> HaddockSection -> Ordering
$c< :: HaddockSection -> HaddockSection -> Bool
< :: HaddockSection -> HaddockSection -> Bool
$c<= :: HaddockSection -> HaddockSection -> Bool
<= :: HaddockSection -> HaddockSection -> Bool
$c> :: HaddockSection -> HaddockSection -> Bool
> :: HaddockSection -> HaddockSection -> Bool
$c>= :: HaddockSection -> HaddockSection -> Bool
>= :: HaddockSection -> HaddockSection -> Bool
$cmax :: HaddockSection -> HaddockSection -> HaddockSection
max :: HaddockSection -> HaddockSection -> HaddockSection
$cmin :: HaddockSection -> HaddockSection -> HaddockSection
min :: HaddockSection -> HaddockSection -> HaddockSection
Ord)

-- | Known subsections. The ordering here is the ordering in which
-- they will appear in the haddocks.
data NamedSection = MethodSection
                  | PropertySection
                  | SignalSection
                  | EnumSection
                  | FlagSection
  deriving (Int -> NamedSection -> ShowS
[NamedSection] -> ShowS
NamedSection -> FilePath
(Int -> NamedSection -> ShowS)
-> (NamedSection -> FilePath)
-> ([NamedSection] -> ShowS)
-> Show NamedSection
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamedSection -> ShowS
showsPrec :: Int -> NamedSection -> ShowS
$cshow :: NamedSection -> FilePath
show :: NamedSection -> FilePath
$cshowList :: [NamedSection] -> ShowS
showList :: [NamedSection] -> ShowS
Show, NamedSection -> NamedSection -> Bool
(NamedSection -> NamedSection -> Bool)
-> (NamedSection -> NamedSection -> Bool) -> Eq NamedSection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NamedSection -> NamedSection -> Bool
== :: NamedSection -> NamedSection -> Bool
$c/= :: NamedSection -> NamedSection -> Bool
/= :: NamedSection -> NamedSection -> Bool
Eq, Eq NamedSection
Eq NamedSection
-> (NamedSection -> NamedSection -> Ordering)
-> (NamedSection -> NamedSection -> Bool)
-> (NamedSection -> NamedSection -> Bool)
-> (NamedSection -> NamedSection -> Bool)
-> (NamedSection -> NamedSection -> Bool)
-> (NamedSection -> NamedSection -> NamedSection)
-> (NamedSection -> NamedSection -> NamedSection)
-> Ord NamedSection
NamedSection -> NamedSection -> Bool
NamedSection -> NamedSection -> Ordering
NamedSection -> NamedSection -> NamedSection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NamedSection -> NamedSection -> Ordering
compare :: NamedSection -> NamedSection -> Ordering
$c< :: NamedSection -> NamedSection -> Bool
< :: NamedSection -> NamedSection -> Bool
$c<= :: NamedSection -> NamedSection -> Bool
<= :: NamedSection -> NamedSection -> Bool
$c> :: NamedSection -> NamedSection -> Bool
> :: NamedSection -> NamedSection -> Bool
$c>= :: NamedSection -> NamedSection -> Bool
>= :: NamedSection -> NamedSection -> Bool
$cmax :: NamedSection -> NamedSection -> NamedSection
max :: NamedSection -> NamedSection -> NamedSection
$cmin :: NamedSection -> NamedSection -> NamedSection
min :: NamedSection -> NamedSection -> NamedSection
Ord)

-- | Symbol to export.
type SymbolName = Text

-- | Possible exports for a given module. Every export type
-- constructor has two parameters: the section of the haddocks where
-- it should appear, and the symbol name to export in the export list
-- of the module.
data Export = Export {
      Export -> ExportType
exportType    :: ExportType       -- ^ Which kind of export.
    , Export -> Text
exportSymbol  :: SymbolName       -- ^ Actual symbol to export.
    , Export -> [CPPConditional]
exportGuards  :: [CPPConditional] -- ^ Protect the export by the
                                        -- given CPP export guards.
    } deriving (Int -> Export -> ShowS
[Export] -> ShowS
Export -> FilePath
(Int -> Export -> ShowS)
-> (Export -> FilePath) -> ([Export] -> ShowS) -> Show Export
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Export -> ShowS
showsPrec :: Int -> Export -> ShowS
$cshow :: Export -> FilePath
show :: Export -> FilePath
$cshowList :: [Export] -> ShowS
showList :: [Export] -> ShowS
Show, Export -> Export -> Bool
(Export -> Export -> Bool)
-> (Export -> Export -> Bool) -> Eq Export
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Export -> Export -> Bool
== :: Export -> Export -> Bool
$c/= :: Export -> Export -> Bool
/= :: Export -> Export -> Bool
Eq, Eq Export
Eq Export
-> (Export -> Export -> Ordering)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Export)
-> (Export -> Export -> Export)
-> Ord Export
Export -> Export -> Bool
Export -> Export -> Ordering
Export -> Export -> Export
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Export -> Export -> Ordering
compare :: Export -> Export -> Ordering
$c< :: Export -> Export -> Bool
< :: Export -> Export -> Bool
$c<= :: Export -> Export -> Bool
<= :: Export -> Export -> Bool
$c> :: Export -> Export -> Bool
> :: Export -> Export -> Bool
$c>= :: Export -> Export -> Bool
>= :: Export -> Export -> Bool
$cmax :: Export -> Export -> Export
max :: Export -> Export -> Export
$cmin :: Export -> Export -> Export
min :: Export -> Export -> Export
Ord)

-- | Possible types of exports.
data ExportType = ExportSymbol HaddockSection -- ^ An export in the
                  -- given haddock section.
                | ExportTypeDecl -- ^ A type declaration.
                | ExportModule   -- ^ Reexport of a whole module.
                  deriving (Int -> ExportType -> ShowS
[ExportType] -> ShowS
ExportType -> FilePath
(Int -> ExportType -> ShowS)
-> (ExportType -> FilePath)
-> ([ExportType] -> ShowS)
-> Show ExportType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExportType -> ShowS
showsPrec :: Int -> ExportType -> ShowS
$cshow :: ExportType -> FilePath
show :: ExportType -> FilePath
$cshowList :: [ExportType] -> ShowS
showList :: [ExportType] -> ShowS
Show, ExportType -> ExportType -> Bool
(ExportType -> ExportType -> Bool)
-> (ExportType -> ExportType -> Bool) -> Eq ExportType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExportType -> ExportType -> Bool
== :: ExportType -> ExportType -> Bool
$c/= :: ExportType -> ExportType -> Bool
/= :: ExportType -> ExportType -> Bool
Eq, Eq ExportType
Eq ExportType
-> (ExportType -> ExportType -> Ordering)
-> (ExportType -> ExportType -> Bool)
-> (ExportType -> ExportType -> Bool)
-> (ExportType -> ExportType -> Bool)
-> (ExportType -> ExportType -> Bool)
-> (ExportType -> ExportType -> ExportType)
-> (ExportType -> ExportType -> ExportType)
-> Ord ExportType
ExportType -> ExportType -> Bool
ExportType -> ExportType -> Ordering
ExportType -> ExportType -> ExportType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ExportType -> ExportType -> Ordering
compare :: ExportType -> ExportType -> Ordering
$c< :: ExportType -> ExportType -> Bool
< :: ExportType -> ExportType -> Bool
$c<= :: ExportType -> ExportType -> Bool
<= :: ExportType -> ExportType -> Bool
$c> :: ExportType -> ExportType -> Bool
> :: ExportType -> ExportType -> Bool
$c>= :: ExportType -> ExportType -> Bool
>= :: ExportType -> ExportType -> Bool
$cmax :: ExportType -> ExportType -> ExportType
max :: ExportType -> ExportType -> ExportType
$cmin :: ExportType -> ExportType -> ExportType
min :: ExportType -> ExportType -> ExportType
Ord)

-- | Information on a generated module.
data ModuleInfo = ModuleInfo {
      ModuleInfo -> ModulePath
modulePath :: ModulePath -- ^ Full module name: ["Gtk", "Label"].
    , ModuleInfo -> Code
moduleCode :: Code       -- ^ Generated code for the module.
    , ModuleInfo -> Code
bootCode   :: Code       -- ^ Interfaces going into the .hs-boot file.
    , ModuleInfo -> Map Text ModuleInfo
submodules :: M.Map Text ModuleInfo -- ^ Indexed by the relative
                                          -- module name.
    , ModuleInfo -> Deps
moduleDeps :: Deps -- ^ Set of dependencies for this module.
    , ModuleInfo -> Seq Export
moduleExports :: Seq.Seq Export -- ^ Exports for the module.
    , ModuleInfo -> Set ModulePath
qualifiedImports :: Set.Set ModulePath -- ^ Qualified (source) imports.
    , ModuleInfo -> Deps
modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module.
    , ModuleInfo -> Deps
moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module.
    , ModuleInfo -> Set ModuleFlag
moduleFlags   :: Set.Set ModuleFlag -- ^ Flags for the module.
    , ModuleInfo -> Map HaddockSection Text
sectionDocs   :: M.Map HaddockSection Text -- ^ Documentation
                                     -- for the different sections in
                                     -- the module.
    , ModuleInfo -> BaseVersion
moduleMinBase :: BaseVersion -- ^ Minimal version of base the
                                   -- module will work on.
    }

-- | Flags for module code generation.
data ModuleFlag = ImplicitPrelude  -- ^ Use the standard prelude,
                                   -- instead of the haskell-gi-base short one.
                  deriving (Int -> ModuleFlag -> ShowS
[ModuleFlag] -> ShowS
ModuleFlag -> FilePath
(Int -> ModuleFlag -> ShowS)
-> (ModuleFlag -> FilePath)
-> ([ModuleFlag] -> ShowS)
-> Show ModuleFlag
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ModuleFlag -> ShowS
showsPrec :: Int -> ModuleFlag -> ShowS
$cshow :: ModuleFlag -> FilePath
show :: ModuleFlag -> FilePath
$cshowList :: [ModuleFlag] -> ShowS
showList :: [ModuleFlag] -> ShowS
Show, ModuleFlag -> ModuleFlag -> Bool
(ModuleFlag -> ModuleFlag -> Bool)
-> (ModuleFlag -> ModuleFlag -> Bool) -> Eq ModuleFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModuleFlag -> ModuleFlag -> Bool
== :: ModuleFlag -> ModuleFlag -> Bool
$c/= :: ModuleFlag -> ModuleFlag -> Bool
/= :: ModuleFlag -> ModuleFlag -> Bool
Eq, Eq ModuleFlag
Eq ModuleFlag
-> (ModuleFlag -> ModuleFlag -> Ordering)
-> (ModuleFlag -> ModuleFlag -> Bool)
-> (ModuleFlag -> ModuleFlag -> Bool)
-> (ModuleFlag -> ModuleFlag -> Bool)
-> (ModuleFlag -> ModuleFlag -> Bool)
-> (ModuleFlag -> ModuleFlag -> ModuleFlag)
-> (ModuleFlag -> ModuleFlag -> ModuleFlag)
-> Ord ModuleFlag
ModuleFlag -> ModuleFlag -> Bool
ModuleFlag -> ModuleFlag -> Ordering
ModuleFlag -> ModuleFlag -> ModuleFlag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ModuleFlag -> ModuleFlag -> Ordering
compare :: ModuleFlag -> ModuleFlag -> Ordering
$c< :: ModuleFlag -> ModuleFlag -> Bool
< :: ModuleFlag -> ModuleFlag -> Bool
$c<= :: ModuleFlag -> ModuleFlag -> Bool
<= :: ModuleFlag -> ModuleFlag -> Bool
$c> :: ModuleFlag -> ModuleFlag -> Bool
> :: ModuleFlag -> ModuleFlag -> Bool
$c>= :: ModuleFlag -> ModuleFlag -> Bool
>= :: ModuleFlag -> ModuleFlag -> Bool
$cmax :: ModuleFlag -> ModuleFlag -> ModuleFlag
max :: ModuleFlag -> ModuleFlag -> ModuleFlag
$cmin :: ModuleFlag -> ModuleFlag -> ModuleFlag
min :: ModuleFlag -> ModuleFlag -> ModuleFlag
Ord)

-- | Minimal version of base supported by a given module.
data BaseVersion = Base47  -- ^ 4.7.0
                 | Base48  -- ^ 4.8.0
                   deriving (Int -> BaseVersion -> ShowS
[BaseVersion] -> ShowS
BaseVersion -> FilePath
(Int -> BaseVersion -> ShowS)
-> (BaseVersion -> FilePath)
-> ([BaseVersion] -> ShowS)
-> Show BaseVersion
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BaseVersion -> ShowS
showsPrec :: Int -> BaseVersion -> ShowS
$cshow :: BaseVersion -> FilePath
show :: BaseVersion -> FilePath
$cshowList :: [BaseVersion] -> ShowS
showList :: [BaseVersion] -> ShowS
Show, BaseVersion -> BaseVersion -> Bool
(BaseVersion -> BaseVersion -> Bool)
-> (BaseVersion -> BaseVersion -> Bool) -> Eq BaseVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BaseVersion -> BaseVersion -> Bool
== :: BaseVersion -> BaseVersion -> Bool
$c/= :: BaseVersion -> BaseVersion -> Bool
/= :: BaseVersion -> BaseVersion -> Bool
Eq, Eq BaseVersion
Eq BaseVersion
-> (BaseVersion -> BaseVersion -> Ordering)
-> (BaseVersion -> BaseVersion -> Bool)
-> (BaseVersion -> BaseVersion -> Bool)
-> (BaseVersion -> BaseVersion -> Bool)
-> (BaseVersion -> BaseVersion -> Bool)
-> (BaseVersion -> BaseVersion -> BaseVersion)
-> (BaseVersion -> BaseVersion -> BaseVersion)
-> Ord BaseVersion
BaseVersion -> BaseVersion -> Bool
BaseVersion -> BaseVersion -> Ordering
BaseVersion -> BaseVersion -> BaseVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BaseVersion -> BaseVersion -> Ordering
compare :: BaseVersion -> BaseVersion -> Ordering
$c< :: BaseVersion -> BaseVersion -> Bool
< :: BaseVersion -> BaseVersion -> Bool
$c<= :: BaseVersion -> BaseVersion -> Bool
<= :: BaseVersion -> BaseVersion -> Bool
$c> :: BaseVersion -> BaseVersion -> Bool
> :: BaseVersion -> BaseVersion -> Bool
$c>= :: BaseVersion -> BaseVersion -> Bool
>= :: BaseVersion -> BaseVersion -> Bool
$cmax :: BaseVersion -> BaseVersion -> BaseVersion
max :: BaseVersion -> BaseVersion -> BaseVersion
$cmin :: BaseVersion -> BaseVersion -> BaseVersion
min :: BaseVersion -> BaseVersion -> BaseVersion
Ord)

-- | A `Text` representation of the given base version bound.
showBaseVersion :: BaseVersion -> Text
showBaseVersion :: BaseVersion -> Text
showBaseVersion BaseVersion
Base47 = Text
"4.7"
showBaseVersion BaseVersion
Base48 = Text
"4.8"

-- | Generate the empty module.
emptyModule :: ModulePath -> ModuleInfo
emptyModule :: ModulePath -> ModuleInfo
emptyModule ModulePath
m = ModuleInfo { modulePath :: ModulePath
modulePath = ModulePath
m
                           , moduleCode :: Code
moduleCode = Code
emptyCode
                           , bootCode :: Code
bootCode = Code
emptyCode
                           , submodules :: Map Text ModuleInfo
submodules = Map Text ModuleInfo
forall k a. Map k a
M.empty
                           , moduleDeps :: Deps
moduleDeps = Deps
forall a. Set a
Set.empty
                           , moduleExports :: Seq Export
moduleExports = Seq Export
forall a. Seq a
Seq.empty
                           , qualifiedImports :: Set ModulePath
qualifiedImports = Set ModulePath
forall a. Set a
Set.empty
                           , modulePragmas :: Deps
modulePragmas = Deps
forall a. Set a
Set.empty
                           , moduleGHCOpts :: Deps
moduleGHCOpts = Deps
forall a. Set a
Set.empty
                           , moduleFlags :: Set ModuleFlag
moduleFlags = Set ModuleFlag
forall a. Set a
Set.empty
                           , sectionDocs :: Map HaddockSection Text
sectionDocs = Map HaddockSection Text
forall k a. Map k a
M.empty
                           , moduleMinBase :: BaseVersion
moduleMinBase = BaseVersion
Base47
                           }

-- | Information for the code generator.
data CodeGenConfig = CodeGenConfig {
      CodeGenConfig -> Config
hConfig     :: Config          -- ^ Ambient config.
    , CodeGenConfig -> Map Name API
loadedAPIs  :: M.Map Name API  -- ^ APIs available to the generator.
    , CodeGenConfig -> Map CRef Hyperlink
c2hMap      :: M.Map CRef Hyperlink -- ^ Map from C references
                                          -- to Haskell symbols.
    }

-- | Set of errors for the code generator.
data CGError = CGErrorNotImplemented Text
             | CGErrorBadIntrospectionInfo Text
             | CGErrorMissingInfo Text
               deriving (Int -> CGError -> ShowS
[CGError] -> ShowS
CGError -> FilePath
(Int -> CGError -> ShowS)
-> (CGError -> FilePath) -> ([CGError] -> ShowS) -> Show CGError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CGError -> ShowS
showsPrec :: Int -> CGError -> ShowS
$cshow :: CGError -> FilePath
show :: CGError -> FilePath
$cshowList :: [CGError] -> ShowS
showList :: [CGError] -> ShowS
Show)

-- | Temporaty state for the code generator.
data CGState = CGState {
  CGState -> [CPPConditional]
cgsCPPConditionals :: [CPPConditional] -- ^ Active CPP conditionals,
                                         -- outermost condition first.
  , CGState -> NamedTyvar
cgsNextAvailableTyvar :: NamedTyvar -- ^ Next unused type
                                        -- variable.
  }

-- | The name for a type variable.
data NamedTyvar = SingleCharTyvar Char
                -- ^ A single variable type variable: 'a', 'b', etc...
                | IndexedTyvar Text Integer
                -- ^ An indexed type variable: 'a17', 'key1', ...

-- | Clean slate for `CGState`.
emptyCGState :: CGState
emptyCGState :: CGState
emptyCGState = CGState { cgsCPPConditionals :: [CPPConditional]
cgsCPPConditionals = []
                       , cgsNextAvailableTyvar :: NamedTyvar
cgsNextAvailableTyvar = Char -> NamedTyvar
SingleCharTyvar Char
'a'
                       }

-- | The base type for the code generator monad. Generators that
-- cannot throw errors are parametric in the exception type 'excType'.
type CodeGen excType a =
  ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except excType)) a

-- | Code generators that can throw errors.
type ExcCodeGen a = CodeGen CGError a

-- | Run a `CodeGen` with given `Config` and initial state, returning
-- either the resulting exception, or the result and final module info.
runCodeGen :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) ->
              (Either e (a, ModuleInfo))
runCodeGen :: forall e a.
CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen CodeGen e a
cg CodeGenConfig
cfg (CGState, ModuleInfo)
state =
  (a, (CGState, ModuleInfo)) -> (a, ModuleInfo)
forall a. (a, (CGState, ModuleInfo)) -> (a, ModuleInfo)
dropCGState ((a, (CGState, ModuleInfo)) -> (a, ModuleInfo))
-> Either e (a, (CGState, ModuleInfo)) -> Either e (a, ModuleInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Except e (a, (CGState, ModuleInfo))
-> Either e (a, (CGState, ModuleInfo))
forall e a. Except e a -> Either e a
runExcept (StateT (CGState, ModuleInfo) (ExceptT e Identity) a
-> (CGState, ModuleInfo) -> Except e (a, (CGState, ModuleInfo))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (CodeGen e a
-> CodeGenConfig
-> StateT (CGState, ModuleInfo) (ExceptT e Identity) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CodeGen e a
cg CodeGenConfig
cfg) (CGState, ModuleInfo)
state)
  where dropCGState :: (a, (CGState, ModuleInfo)) -> (a, ModuleInfo)
        dropCGState :: forall a. (a, (CGState, ModuleInfo)) -> (a, ModuleInfo)
dropCGState (a
x, (CGState
_, ModuleInfo
m)) = (a
x, ModuleInfo
m)

-- | This is useful when we plan run a subgenerator, and `mconcat` the
-- result to the original structure later.
cleanInfo :: ModuleInfo -> ModuleInfo
cleanInfo :: ModuleInfo -> ModuleInfo
cleanInfo ModuleInfo
info = ModuleInfo
info { moduleCode :: Code
moduleCode = Code
emptyCode, submodules :: Map Text ModuleInfo
submodules = Map Text ModuleInfo
forall k a. Map k a
M.empty,
                        bootCode :: Code
bootCode = Code
emptyCode, moduleExports :: Seq Export
moduleExports = Seq Export
forall a. Seq a
Seq.empty,
                        qualifiedImports :: Set ModulePath
qualifiedImports = Set ModulePath
forall a. Set a
Set.empty,
                        sectionDocs :: Map HaddockSection Text
sectionDocs = Map HaddockSection Text
forall k a. Map k a
M.empty, moduleMinBase :: BaseVersion
moduleMinBase = BaseVersion
Base47 }

-- | Run the given code generator using the state and config of an
-- ambient CodeGen, but without adding the generated code to
-- `moduleCode`, instead returning it explicitly.
recurseCG :: CodeGen e a -> CodeGen e (a, Code)
recurseCG :: forall e a. CodeGen e a -> CodeGen e (a, Code)
recurseCG = (CGState -> CGState) -> CodeGen e a -> CodeGen e (a, Code)
forall e a.
(CGState -> CGState) -> CodeGen e a -> CodeGen e (a, Code)
recurseWithState CGState -> CGState
forall a. a -> a
id

-- | Like `recurseCG`, but we allow for explicitly setting the state
-- of the inner code generator.
recurseWithState :: (CGState -> CGState) -> CodeGen e a
                 -> CodeGen e (a, Code)
recurseWithState :: forall e a.
(CGState -> CGState) -> CodeGen e a -> CodeGen e (a, Code)
recurseWithState CGState -> CGState
cgsSet CodeGen e a
cg = do
  CodeGenConfig
cfg <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  (CGState
cgs, ModuleInfo
oldInfo) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
  -- Start the subgenerator with no code and no submodules.
  let info :: ModuleInfo
info = ModuleInfo -> ModuleInfo
cleanInfo ModuleInfo
oldInfo
  case CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
forall e a.
CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen CodeGen e a
cg CodeGenConfig
cfg (CGState -> CGState
cgsSet CGState
cgs, ModuleInfo
info) of
     Left e
e -> e -> CodeGen e (a, Code)
forall a.
e
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
     Right (a
r, ModuleInfo
new) -> (CGState, ModuleInfo)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (CGState
cgs, ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfoState ModuleInfo
oldInfo ModuleInfo
new) ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> CodeGen e (a, Code) -> CodeGen e (a, Code)
forall a b.
ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       (a, Code) -> CodeGen e (a, Code)
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r, ModuleInfo -> Code
moduleCode ModuleInfo
new)

-- | Like `recurseCG`, giving explicitly the set of loaded APIs and C to
-- Haskell map for the subgenerator.
recurseWithAPIs :: M.Map Name API -> CodeGen e () -> CodeGen e ()
recurseWithAPIs :: forall e. Map Name API -> CodeGen e () -> CodeGen e ()
recurseWithAPIs Map Name API
apis CodeGen e ()
cg = do
  CodeGenConfig
cfg <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  (CGState
cgs, ModuleInfo
oldInfo) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
  -- Start the subgenerator with no code and no submodules.
  let info :: ModuleInfo
info = ModuleInfo -> ModuleInfo
cleanInfo ModuleInfo
oldInfo
      cfg' :: CodeGenConfig
cfg' = CodeGenConfig
cfg {loadedAPIs :: Map Name API
loadedAPIs = Map Name API
apis,
                  c2hMap :: Map CRef Hyperlink
c2hMap = [(Name, API)] -> Map CRef Hyperlink
cToHaskellMap (Map Name API -> [(Name, API)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name API
apis)}
  case CodeGen e ()
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e ((), ModuleInfo)
forall e a.
CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen CodeGen e ()
cg CodeGenConfig
cfg' (CGState
cgs, ModuleInfo
info) of
    Left e
e -> e -> CodeGen e ()
forall a.
e
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
    Right (()
_, ModuleInfo
new) -> (CGState, ModuleInfo) -> CodeGen e ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (CGState
cgs, ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo ModuleInfo
oldInfo ModuleInfo
new)

-- | Merge everything but the generated code for the two given `ModuleInfo`.
mergeInfoState :: ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfoState :: ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfoState ModuleInfo
oldState ModuleInfo
newState =
    let newDeps :: Deps
newDeps = Deps -> Deps -> Deps
forall a. Ord a => Set a -> Set a -> Set a
Set.union (ModuleInfo -> Deps
moduleDeps ModuleInfo
oldState) (ModuleInfo -> Deps
moduleDeps ModuleInfo
newState)
        newSubmodules :: Map Text ModuleInfo
newSubmodules = (ModuleInfo -> ModuleInfo -> ModuleInfo)
-> Map Text ModuleInfo
-> Map Text ModuleInfo
-> Map Text ModuleInfo
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo (ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
oldState) (ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
newState)
        newExports :: Seq Export
newExports = ModuleInfo -> Seq Export
moduleExports ModuleInfo
oldState Seq Export -> Seq Export -> Seq Export
forall a. Semigroup a => a -> a -> a
<> ModuleInfo -> Seq Export
moduleExports ModuleInfo
newState
        newImports :: Set ModulePath
newImports = ModuleInfo -> Set ModulePath
qualifiedImports ModuleInfo
oldState Set ModulePath -> Set ModulePath -> Set ModulePath
forall a. Semigroup a => a -> a -> a
<> ModuleInfo -> Set ModulePath
qualifiedImports ModuleInfo
newState
        newPragmas :: Deps
newPragmas = Deps -> Deps -> Deps
forall a. Ord a => Set a -> Set a -> Set a
Set.union (ModuleInfo -> Deps
modulePragmas ModuleInfo
oldState) (ModuleInfo -> Deps
modulePragmas ModuleInfo
newState)
        newGHCOpts :: Deps
newGHCOpts = Deps -> Deps -> Deps
forall a. Ord a => Set a -> Set a -> Set a
Set.union (ModuleInfo -> Deps
moduleGHCOpts ModuleInfo
oldState) (ModuleInfo -> Deps
moduleGHCOpts ModuleInfo
newState)
        newFlags :: Set ModuleFlag
newFlags = Set ModuleFlag -> Set ModuleFlag -> Set ModuleFlag
forall a. Ord a => Set a -> Set a -> Set a
Set.union (ModuleInfo -> Set ModuleFlag
moduleFlags ModuleInfo
oldState) (ModuleInfo -> Set ModuleFlag
moduleFlags ModuleInfo
newState)
        newBoot :: Code
newBoot = ModuleInfo -> Code
bootCode ModuleInfo
oldState Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> ModuleInfo -> Code
bootCode ModuleInfo
newState
        newDocs :: Map HaddockSection Text
newDocs = ModuleInfo -> Map HaddockSection Text
sectionDocs ModuleInfo
oldState Map HaddockSection Text
-> Map HaddockSection Text -> Map HaddockSection Text
forall a. Semigroup a => a -> a -> a
<> ModuleInfo -> Map HaddockSection Text
sectionDocs ModuleInfo
newState
        newMinBase :: BaseVersion
newMinBase = BaseVersion -> BaseVersion -> BaseVersion
forall a. Ord a => a -> a -> a
max (ModuleInfo -> BaseVersion
moduleMinBase ModuleInfo
oldState) (ModuleInfo -> BaseVersion
moduleMinBase ModuleInfo
newState)
    in ModuleInfo
oldState {moduleDeps :: Deps
moduleDeps = Deps
newDeps, submodules :: Map Text ModuleInfo
submodules = Map Text ModuleInfo
newSubmodules,
                 moduleExports :: Seq Export
moduleExports = Seq Export
newExports, qualifiedImports :: Set ModulePath
qualifiedImports = Set ModulePath
newImports,
                 modulePragmas :: Deps
modulePragmas = Deps
newPragmas,
                 moduleGHCOpts :: Deps
moduleGHCOpts = Deps
newGHCOpts, moduleFlags :: Set ModuleFlag
moduleFlags = Set ModuleFlag
newFlags,
                 bootCode :: Code
bootCode = Code
newBoot, sectionDocs :: Map HaddockSection Text
sectionDocs = Map HaddockSection Text
newDocs,
                 moduleMinBase :: BaseVersion
moduleMinBase = BaseVersion
newMinBase }

-- | Merge the infos, including code too.
mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo ModuleInfo
oldInfo ModuleInfo
newInfo =
    let info :: ModuleInfo
info = ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfoState ModuleInfo
oldInfo ModuleInfo
newInfo
    in ModuleInfo
info { moduleCode :: Code
moduleCode = ModuleInfo -> Code
moduleCode ModuleInfo
oldInfo Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> ModuleInfo -> Code
moduleCode ModuleInfo
newInfo }

-- | Add the given submodule to the list of submodules of the current
-- module.
addSubmodule :: Text -> ModuleInfo -> (CGState, ModuleInfo)
             -> (CGState, ModuleInfo)
addSubmodule :: Text
-> ModuleInfo -> (CGState, ModuleInfo) -> (CGState, ModuleInfo)
addSubmodule Text
modName ModuleInfo
submodule (CGState
cgs, ModuleInfo
current) =
  (CGState
cgs, ModuleInfo
current { submodules :: Map Text ModuleInfo
submodules = (ModuleInfo -> ModuleInfo -> ModuleInfo)
-> Text -> ModuleInfo -> Map Text ModuleInfo -> Map Text ModuleInfo
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo Text
modName ModuleInfo
submodule (ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
current)})

-- | Run the given CodeGen in order to generate a single submodule of the
-- current module. Note that we do not generate the submodule if the
-- code generator generated no code and the module does not have
-- submodules.
submodule' :: Text -> CodeGen e () -> CodeGen e ()
submodule' :: forall e. Text -> CodeGen e () -> CodeGen e ()
submodule' Text
modName CodeGen e ()
cg = do
  CodeGenConfig
cfg <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  (CGState
_, ModuleInfo
oldInfo) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
  let info :: ModuleInfo
info = ModulePath -> ModuleInfo
emptyModule (ModuleInfo -> ModulePath
modulePath ModuleInfo
oldInfo ModulePath -> Text -> ModulePath
/. Text
modName)
  case CodeGen e ()
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e ((), ModuleInfo)
forall e a.
CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen CodeGen e ()
cg CodeGenConfig
cfg (CGState
emptyCGState, ModuleInfo
info) of
    Left e
e -> e -> CodeGen e ()
forall a.
e
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
    Right (()
_, ModuleInfo
smInfo) -> if Code -> Bool
isCodeEmpty (ModuleInfo -> Code
moduleCode ModuleInfo
smInfo) Bool -> Bool -> Bool
&&
                            Map Text ModuleInfo -> Bool
forall k a. Map k a -> Bool
M.null (ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
smInfo)
                         then () -> CodeGen e ()
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                         else ((CGState, ModuleInfo) -> (CGState, ModuleInfo)) -> CodeGen e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (Text
-> ModuleInfo -> (CGState, ModuleInfo) -> (CGState, ModuleInfo)
addSubmodule Text
modName ModuleInfo
smInfo)

-- | Run the given CodeGen in order to generate a submodule (specified
-- an an ordered list) of the current module.
submodule :: ModulePath -> CodeGen e () -> CodeGen e ()
submodule :: forall e. ModulePath -> CodeGen e () -> CodeGen e ()
submodule (ModulePath []) CodeGen e ()
cg = CodeGen e ()
cg
submodule (ModulePath (Text
m:[Text]
ms)) CodeGen e ()
cg = Text -> CodeGen e () -> CodeGen e ()
forall e. Text -> CodeGen e () -> CodeGen e ()
submodule' Text
m (ModulePath -> CodeGen e () -> CodeGen e ()
forall e. ModulePath -> CodeGen e () -> CodeGen e ()
submodule ([Text] -> ModulePath
ModulePath [Text]
ms) CodeGen e ()
cg)

-- | Try running the given `action`, and if it fails run `fallback`
-- instead.
handleCGExc :: (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc :: forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc CGError -> CodeGen e a
fallback
 ExcCodeGen a
action = do
    CodeGenConfig
cfg <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    (CGState
cgs, ModuleInfo
oldInfo) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
    let info :: ModuleInfo
info = ModuleInfo -> ModuleInfo
cleanInfo ModuleInfo
oldInfo
    case ExcCodeGen a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either CGError (a, ModuleInfo)
forall e a.
CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen ExcCodeGen a
action CodeGenConfig
cfg (CGState
cgs, ModuleInfo
info) of
      Left CGError
e -> CGError -> CodeGen e a
fallback CGError
e
      Right (a
r, ModuleInfo
newInfo) -> do
        (CGState, ModuleInfo)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (CGState
cgs, ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo ModuleInfo
oldInfo ModuleInfo
newInfo)
        a -> CodeGen e a
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | Return the currently loaded set of dependencies.
getDeps :: CodeGen e Deps
getDeps :: forall e. CodeGen e Deps
getDeps = ModuleInfo -> Deps
moduleDeps (ModuleInfo -> Deps)
-> ((CGState, ModuleInfo) -> ModuleInfo)
-> (CGState, ModuleInfo)
-> Deps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGState, ModuleInfo) -> ModuleInfo
forall a b. (a, b) -> b
snd ((CGState, ModuleInfo) -> Deps)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (CGState, ModuleInfo)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Deps
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get

-- | Return the ambient configuration for the code generator.
config :: CodeGen e Config
config :: forall e. CodeGen e Config
config = CodeGenConfig -> Config
hConfig (CodeGenConfig -> Config)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     CodeGenConfig
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Return the name of the current module.
currentModule :: CodeGen e Text
currentModule :: forall e. CodeGen e Text
currentModule = do
  (CGState
_, ModuleInfo
s) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
  Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModulePath -> Text
dotWithPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
s))

-- | Return the list of APIs available to the generator.
getAPIs :: CodeGen e (M.Map Name API)
getAPIs :: forall e. CodeGen e (Map Name API)
getAPIs = CodeGenConfig -> Map Name API
loadedAPIs (CodeGenConfig -> Map Name API)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     CodeGenConfig
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Map Name API)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Return the C -> Haskell available to the generator.
getC2HMap :: CodeGen e (M.Map CRef Hyperlink)
getC2HMap :: forall e. CodeGen e (Map CRef Hyperlink)
getC2HMap = CodeGenConfig -> Map CRef Hyperlink
c2hMap (CodeGenConfig -> Map CRef Hyperlink)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     CodeGenConfig
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Map CRef Hyperlink)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Due to the `forall` in the definition of `CodeGen`, if we want to
-- run the monad transformer stack until we get a result, our only
-- option is ignoring the possible error code from `runExcept`. This
-- is perfectly safe, since there is no way to construct a computation
-- in the `CodeGen` monad that throws an exception, due to the higher
-- rank type.
unwrapCodeGen :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo)
              -> (a, ModuleInfo)
unwrapCodeGen :: forall e a.
CodeGen e a
-> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo)
unwrapCodeGen CodeGen e a
cg CodeGenConfig
cfg (CGState, ModuleInfo)
info =
    case CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
forall e a.
CodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen CodeGen e a
cg CodeGenConfig
cfg (CGState, ModuleInfo)
info of
      Left e
_ -> FilePath -> (a, ModuleInfo)
forall a. HasCallStack => FilePath -> a
error FilePath
"unwrapCodeGen:: The impossible happened!"
      Right (a
r, ModuleInfo
newInfo) -> (a
r, ModuleInfo
newInfo)

-- | Run a code generator, and return the information for the
-- generated module together with the return value of the generator.
evalCodeGen :: Config -> M.Map Name API ->
               ModulePath -> CodeGen e a -> (a, ModuleInfo)
evalCodeGen :: forall e a.
Config
-> Map Name API -> ModulePath -> CodeGen e a -> (a, ModuleInfo)
evalCodeGen Config
cfg Map Name API
apis ModulePath
mPath CodeGen e a
cg =
  let initialInfo :: ModuleInfo
initialInfo = ModulePath -> ModuleInfo
emptyModule ModulePath
mPath
      cfg' :: CodeGenConfig
cfg' = CodeGenConfig {hConfig :: Config
hConfig = Config
cfg, loadedAPIs :: Map Name API
loadedAPIs = Map Name API
apis,
                            c2hMap :: Map CRef Hyperlink
c2hMap = [(Name, API)] -> Map CRef Hyperlink
cToHaskellMap (Map Name API -> [(Name, API)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name API
apis)}
  in CodeGen e a
-> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo)
forall e a.
CodeGen e a
-> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo)
unwrapCodeGen CodeGen e a
cg CodeGenConfig
cfg' (CGState
emptyCGState, ModuleInfo
initialInfo)

-- | Like `evalCodeGen`, but discard the resulting output value.
genCode :: Config -> M.Map Name API ->
           ModulePath -> CodeGen e () -> ModuleInfo
genCode :: forall e.
Config -> Map Name API -> ModulePath -> CodeGen e () -> ModuleInfo
genCode Config
cfg Map Name API
apis ModulePath
mPath CodeGen e ()
cg = ((), ModuleInfo) -> ModuleInfo
forall a b. (a, b) -> b
snd (((), ModuleInfo) -> ModuleInfo) -> ((), ModuleInfo) -> ModuleInfo
forall a b. (a -> b) -> a -> b
$ Config
-> Map Name API -> ModulePath -> CodeGen e () -> ((), ModuleInfo)
forall e a.
Config
-> Map Name API -> ModulePath -> CodeGen e a -> (a, ModuleInfo)
evalCodeGen Config
cfg Map Name API
apis ModulePath
mPath CodeGen e ()
cg

-- | Mark the given dependency as used by the module.
registerNSDependency :: Text -> CodeGen e ()
registerNSDependency :: forall e. Text -> CodeGen e ()
registerNSDependency Text
name = do
    Deps
deps <- CodeGen e Deps
forall e. CodeGen e Deps
getDeps
    Bool -> CodeGen e () -> CodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Deps -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
name Deps
deps) (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        let newDeps :: Deps
newDeps = Text -> Deps -> Deps
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
name Deps
deps
        ((CGState, ModuleInfo) -> (CGState, ModuleInfo)) -> CodeGen e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo)) -> CodeGen e ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo)) -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s {moduleDeps :: Deps
moduleDeps = Deps
newDeps})

-- | Return the transitive set of dependencies, i.e. the union of
-- those of the module and (transitively) its submodules.
transitiveModuleDeps :: ModuleInfo -> Deps
transitiveModuleDeps :: ModuleInfo -> Deps
transitiveModuleDeps ModuleInfo
minfo =
    [Deps] -> Deps
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (ModuleInfo -> Deps
moduleDeps ModuleInfo
minfo
               Deps -> [Deps] -> [Deps]
forall a. a -> [a] -> [a]
: (ModuleInfo -> Deps) -> [ModuleInfo] -> [Deps]
forall a b. (a -> b) -> [a] -> [b]
map ModuleInfo -> Deps
transitiveModuleDeps (Map Text ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (Map Text ModuleInfo -> [ModuleInfo])
-> Map Text ModuleInfo -> [ModuleInfo]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
minfo))

-- | Given a module name and a symbol in the module (including a
-- proper namespace), return a qualified name for the symbol.
qualified :: ModulePath -> Name -> CodeGen e Text
qualified :: forall e. ModulePath -> Name -> CodeGen e Text
qualified ModulePath
mp (Name Text
ns Text
s) = do
  Config
cfg <- CodeGen e Config
forall e. CodeGen e Config
config
  -- Make sure the module is listed as a dependency.
  Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Text
modName Config
cfg Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
ns) (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$
    Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
registerNSDependency Text
ns
  (CGState
_, ModuleInfo
minfo) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
  if ModulePath
mp ModulePath -> ModulePath -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo
  then Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
  else do
    Text
qm <- ModulePath -> CodeGen e Text
forall e. ModulePath -> CodeGen e Text
qualifiedImport ModulePath
mp
    Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
qm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s)

-- | Import the given module name qualified (as a source import if the
-- namespace is the same as the current one), and return the name
-- under which the module was imported.
qualifiedImport :: ModulePath -> CodeGen e Text
qualifiedImport :: forall e. ModulePath -> CodeGen e Text
qualifiedImport ModulePath
mp = do
  ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s {qualifiedImports :: Set ModulePath
qualifiedImports = ModulePath -> Set ModulePath -> Set ModulePath
forall a. Ord a => a -> Set a -> Set a
Set.insert ModulePath
mp (ModuleInfo -> Set ModulePath
qualifiedImports ModuleInfo
s)})
  Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModulePath -> Text
qualifiedModuleName ModulePath
mp)

-- | Construct a simplified version of the module name, suitable for a
-- qualified import.
qualifiedModuleName :: ModulePath -> Text
qualifiedModuleName :: ModulePath -> Text
qualifiedModuleName (ModulePath [Text
ns, Text
"Objects", Text
o]) = Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
o
qualifiedModuleName (ModulePath [Text
ns, Text
"Interfaces", Text
i]) = Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i
qualifiedModuleName (ModulePath [Text
ns, Text
"Structs", Text
s]) = Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
qualifiedModuleName (ModulePath [Text
ns, Text
"Unions", Text
u]) = Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u
qualifiedModuleName ModulePath
mp = ModulePath -> Text
dotModulePath ModulePath
mp

-- | Return the minimal base version supported by the module and all
-- its submodules.
minBaseVersion :: ModuleInfo -> BaseVersion
minBaseVersion :: ModuleInfo -> BaseVersion
minBaseVersion ModuleInfo
minfo =
    [BaseVersion] -> BaseVersion
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (ModuleInfo -> BaseVersion
moduleMinBase ModuleInfo
minfo
            BaseVersion -> [BaseVersion] -> [BaseVersion]
forall a. a -> [a] -> [a]
: (ModuleInfo -> BaseVersion) -> [ModuleInfo] -> [BaseVersion]
forall a b. (a -> b) -> [a] -> [b]
map ModuleInfo -> BaseVersion
minBaseVersion (Map Text ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (Map Text ModuleInfo -> [ModuleInfo])
-> Map Text ModuleInfo -> [ModuleInfo]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
minfo))

-- | Print, as a comment, a friendly textual description of the error.
printCGError :: CGError -> CodeGen e ()
printCGError :: forall e. CGError -> CodeGen e ()
printCGError (CGErrorNotImplemented Text
e) = do
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
comment (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"Not implemented: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
printCGError (CGErrorBadIntrospectionInfo Text
e) =
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
comment (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"Bad introspection data: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
printCGError (CGErrorMissingInfo Text
e) =
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
comment (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"Missing info: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

notImplementedError :: Text -> ExcCodeGen a
notImplementedError :: forall a. Text -> ExcCodeGen a
notImplementedError Text
s = CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall a.
CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CGError
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a)
-> CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall a b. (a -> b) -> a -> b
$ Text -> CGError
CGErrorNotImplemented Text
s

badIntroError :: Text -> ExcCodeGen a
badIntroError :: forall a. Text -> ExcCodeGen a
badIntroError Text
s = CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall a.
CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CGError
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a)
-> CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall a b. (a -> b) -> a -> b
$ Text -> CGError
CGErrorBadIntrospectionInfo Text
s

missingInfoError :: Text -> ExcCodeGen a
missingInfoError :: forall a. Text -> ExcCodeGen a
missingInfoError Text
s = CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall a.
CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CGError
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a)
-> CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall a b. (a -> b) -> a -> b
$ Text -> CGError
CGErrorMissingInfo Text
s

-- | Get a type variable unused in the current scope.
getFreshTypeVariable :: CodeGen e Text
getFreshTypeVariable :: forall e. CodeGen e Text
getFreshTypeVariable = do
  (cgs :: CGState
cgs@(CGState{cgsNextAvailableTyvar :: CGState -> NamedTyvar
cgsNextAvailableTyvar = NamedTyvar
available}), ModuleInfo
s) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
  let (Text
tyvar, NamedTyvar
next) =
        case NamedTyvar
available of
          SingleCharTyvar Char
char -> case Char
char of
            Char
'z' -> (Text
"z", Text -> Integer -> NamedTyvar
IndexedTyvar Text
"a" Integer
0)
            -- 'm' is reserved for the MonadIO constraint in signatures
            Char
'm' -> (Text
"n", Char -> NamedTyvar
SingleCharTyvar Char
'o')
            Char
c -> (Char -> Text
T.singleton Char
c, Char -> NamedTyvar
SingleCharTyvar (Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
          IndexedTyvar Text
root Integer
index -> (Text
root Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
tshow Integer
index,
                                      Text -> Integer -> NamedTyvar
IndexedTyvar Text
root (Integer
indexInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1))
  (CGState, ModuleInfo)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (CGState
cgs {cgsNextAvailableTyvar :: NamedTyvar
cgsNextAvailableTyvar = NamedTyvar
next}, ModuleInfo
s)
  Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
tyvar

-- | Introduce a new scope for type variable naming: the next fresh
-- variable will be called 'a'.
resetTypeVariableScope :: CodeGen e ()
resetTypeVariableScope :: forall e. CodeGen e ()
resetTypeVariableScope =
  ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(CGState
cgs, ModuleInfo
s) -> (CGState
cgs {cgsNextAvailableTyvar :: NamedTyvar
cgsNextAvailableTyvar = Char -> NamedTyvar
SingleCharTyvar Char
'a'}, ModuleInfo
s))

-- | Try to find the API associated with a given type, if known.
findAPI :: HasCallStack => Type -> CodeGen e (Maybe API)
findAPI :: forall e. HasCallStack => Type -> CodeGen e (Maybe API)
findAPI (TInterface Name
n) = API -> Maybe API
forall a. a -> Maybe a
Just (API -> Maybe API)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Maybe API)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
n
findAPI Type
_ = Maybe API
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Maybe API)
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe API
forall a. Maybe a
Nothing

-- | Find the API associated with a given type. If the API cannot be
-- found this raises an `error`.
getAPI :: HasCallStack => Type -> CodeGen e API
getAPI :: forall e. HasCallStack => Type -> CodeGen e API
getAPI Type
t = Type -> CodeGen e (Maybe API)
forall e. HasCallStack => Type -> CodeGen e (Maybe API)
findAPI Type
t CodeGen e (Maybe API)
-> (Maybe API
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall a b.
ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
-> (a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           Just API
a -> API
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return API
a
           Maybe API
Nothing -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall a. HasCallStack => Text -> a
terror (Text
"Could not resolve type \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Show a => a -> Text
tshow Type
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\".")

findAPIByName :: HasCallStack => Name -> CodeGen e API
findAPIByName :: forall e. HasCallStack => Name -> CodeGen e API
findAPIByName n :: Name
n@(Name Text
ns Text
_) = do
    Map Name API
apis <- CodeGen e (Map Name API)
forall e. CodeGen e (Map Name API)
getAPIs
    case Name -> Map Name API -> Maybe API
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name API
apis of
        Just API
api -> API -> CodeGen e API
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return API
api
        Maybe API
Nothing ->
            Text -> CodeGen e API
forall a. HasCallStack => Text -> a
terror (Text -> CodeGen e API) -> Text -> CodeGen e API
forall a b. (a -> b) -> a -> b
$ Text
"couldn't find API description for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
n

-- | Add some code to the current generator.
tellCode :: CodeToken -> CodeGen e ()
tellCode :: forall e. CodeToken -> CodeGen e ()
tellCode CodeToken
c = ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s {moduleCode :: Code
moduleCode = ModuleInfo -> Code
moduleCode ModuleInfo
s Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<>
                                                         CodeToken -> Code
codeSingleton CodeToken
c}))

-- | Print out a (newline-terminated) line.
line :: Text -> CodeGen e ()
line :: forall e. Text -> CodeGen e ()
line = CodeToken -> CodeGen e ()
forall e. CodeToken -> CodeGen e ()
tellCode (CodeToken -> CodeGen e ())
-> (Text -> CodeToken) -> Text -> CodeGen e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CodeToken
Line

-- | Print out the given line both to the normal module, and to the
-- HsBoot file.
bline :: Text -> CodeGen e ()
bline :: forall e. Text -> CodeGen e ()
bline Text
l = CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
hsBoot (Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line Text
l) CodeGen e () -> CodeGen e () -> CodeGen e ()
forall a b.
ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line Text
l

-- | A blank line
blank :: CodeGen e ()
blank :: forall e. CodeGen e ()
blank = Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line Text
""

-- | A (possibly multi line) comment, separated by newlines
comment :: Text -> CodeGen e ()
comment :: forall e. Text -> CodeGen e ()
comment = CodeToken -> CodeGen e ()
forall e. CodeToken -> CodeGen e ()
tellCode (CodeToken -> CodeGen e ())
-> (Text -> CodeToken) -> Text -> CodeGen e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> CodeToken
Comment ([Text] -> CodeToken) -> (Text -> [Text]) -> Text -> CodeToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

-- | Increase the indent level for code generation.
indent :: CodeGen e a -> CodeGen e a
indent :: forall e a. CodeGen e a -> CodeGen e a
indent CodeGen e a
cg = do
  (a
x, Code
code) <- CodeGen e a -> CodeGen e (a, Code)
forall e a. CodeGen e a -> CodeGen e (a, Code)
recurseCG CodeGen e a
cg
  CodeToken -> CodeGen e ()
forall e. CodeToken -> CodeGen e ()
tellCode (Code -> CodeToken
Indent Code
code)
  a -> CodeGen e a
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Increase the indentation level for the rest of the lines in the
-- current group.
increaseIndent :: CodeGen e ()
increaseIndent :: forall e. CodeGen e ()
increaseIndent = CodeToken -> CodeGen e ()
forall e. CodeToken -> CodeGen e ()
tellCode CodeToken
IncreaseIndent

-- | Group a set of related code.
group :: CodeGen e a -> CodeGen e a
group :: forall e a. CodeGen e a -> CodeGen e a
group CodeGen e a
cg = do
  (a
x, Code
code) <- CodeGen e a -> CodeGen e (a, Code)
forall e a. CodeGen e a -> CodeGen e (a, Code)
recurseCG CodeGen e a
cg
  CodeToken -> CodeGen e ()
forall e. CodeToken -> CodeGen e ()
tellCode (Code -> CodeToken
Group Code
code)
  CodeGen e ()
forall e. CodeGen e ()
blank
  a -> CodeGen e a
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Guard a block of code with @#if@.
cppIfBlock :: Text -> CodeGen e a -> CodeGen e a
cppIfBlock :: forall e a. Text -> CodeGen e a -> CodeGen e a
cppIfBlock Text
cond CodeGen e a
cg = do
  (a
x, Code
code) <- (CGState -> CGState) -> CodeGen e a -> CodeGen e (a, Code)
forall e a.
(CGState -> CGState) -> CodeGen e a -> CodeGen e (a, Code)
recurseWithState CGState -> CGState
addConditional CodeGen e a
cg
  CodeToken -> CodeGen e ()
forall e. CodeToken -> CodeGen e ()
tellCode (CPPConditional -> Code -> CodeToken
CPPBlock (Text -> CPPConditional
CPPIf Text
cond) Code
code)
  CodeGen e ()
forall e. CodeGen e ()
blank
  a -> CodeGen e a
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    where addConditional :: CGState -> CGState
          addConditional :: CGState -> CGState
addConditional CGState
cgs = CGState
cgs {cgsCPPConditionals :: [CPPConditional]
cgsCPPConditionals = Text -> CPPConditional
CPPIf Text
cond CPPConditional -> [CPPConditional] -> [CPPConditional]
forall a. a -> [a] -> [a]
:
                                                         CGState -> [CPPConditional]
cgsCPPConditionals CGState
cgs}

-- | Possible features to test via CPP.
data CPPGuard = CPPOverloading -- ^ Enable overloading
              | CPPMinVersion Text (Integer, Integer, Integer)
                -- ^ Require a specific version of the given package.

-- | Guard a code block with CPP code, such that it is included only
-- if the specified feature is enabled.
cppIf :: CPPGuard -> CodeGen e a -> CodeGen e a
cppIf :: forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading = Text -> CodeGen e a -> CodeGen e a
forall e a. Text -> CodeGen e a -> CodeGen e a
cppIfBlock Text
"defined(ENABLE_OVERLOADING)"
cppIf (CPPMinVersion Text
pkg (Integer
a,Integer
b,Integer
c)) = Text -> CodeGen e a -> CodeGen e a
forall e a. Text -> CodeGen e a -> CodeGen e a
cppIfBlock (Text -> CodeGen e a -> CodeGen e a)
-> Text -> CodeGen e a -> CodeGen e a
forall a b. (a -> b) -> a -> b
$ Text
"MIN_VERSION_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
tshow Integer
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
tshow Integer
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
tshow Integer
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Write the given code into the .hs-boot file for the current module.
hsBoot :: CodeGen e a -> CodeGen e a
hsBoot :: forall e a. CodeGen e a -> CodeGen e a
hsBoot CodeGen e a
cg = do
  (a
x, Code
code) <- CodeGen e a -> CodeGen e (a, Code)
forall e a. CodeGen e a -> CodeGen e (a, Code)
recurseCG CodeGen e a
cg
  ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{bootCode :: Code
bootCode = ModuleInfo -> Code
bootCode ModuleInfo
s Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<>
                               [CPPConditional] -> Code -> Code
addGuards (CGState -> [CPPConditional]
cgsCPPConditionals CGState
cgs) Code
code}))
  a -> CodeGen e a
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where addGuards :: [CPPConditional] -> Code -> Code
        addGuards :: [CPPConditional] -> Code -> Code
addGuards [] Code
c = Code
c
        addGuards (CPPConditional
cond : [CPPConditional]
conds) Code
c = CodeToken -> Code
codeSingleton (CodeToken -> Code) -> CodeToken -> Code
forall a b. (a -> b) -> a -> b
$ CPPConditional -> Code -> CodeToken
CPPBlock CPPConditional
cond ([CPPConditional] -> Code -> Code
addGuards [CPPConditional]
conds Code
c)

-- | Add a export to the current module.
exportPartial :: ([CPPConditional] -> Export) -> CodeGen e ()
exportPartial :: forall e. ([CPPConditional] -> Export) -> CodeGen e ()
exportPartial [CPPConditional] -> Export
partial =
    ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs,
                            let e :: Export
e = [CPPConditional] -> Export
partial ([CPPConditional] -> Export) -> [CPPConditional] -> Export
forall a b. (a -> b) -> a -> b
$ CGState -> [CPPConditional]
cgsCPPConditionals CGState
cgs
                            in ModuleInfo
s{moduleExports :: Seq Export
moduleExports = ModuleInfo -> Seq Export
moduleExports ModuleInfo
s Seq Export -> Export -> Seq Export
forall a. Seq a -> a -> Seq a
|> Export
e})

-- | Reexport a whole module.
exportModule :: SymbolName -> CodeGen e ()
exportModule :: forall e. Text -> CodeGen e ()
exportModule Text
m = ([CPPConditional] -> Export) -> CodeGen e ()
forall e. ([CPPConditional] -> Export) -> CodeGen e ()
exportPartial (ExportType -> Text -> [CPPConditional] -> Export
Export ExportType
ExportModule Text
m)

-- | Add a type declaration-related export.
exportDecl :: SymbolName -> CodeGen e ()
exportDecl :: forall e. Text -> CodeGen e ()
exportDecl Text
d = ([CPPConditional] -> Export) -> CodeGen e ()
forall e. ([CPPConditional] -> Export) -> CodeGen e ()
exportPartial (ExportType -> Text -> [CPPConditional] -> Export
Export ExportType
ExportTypeDecl Text
d)

-- | Export a symbol in the given haddock subsection.
export :: HaddockSection -> SymbolName -> CodeGen e ()
export :: forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
s Text
n = ([CPPConditional] -> Export) -> CodeGen e ()
forall e. ([CPPConditional] -> Export) -> CodeGen e ()
exportPartial (ExportType -> Text -> [CPPConditional] -> Export
Export (HaddockSection -> ExportType
ExportSymbol HaddockSection
s) Text
n)

-- | Set the language pragmas for the current module.
setLanguagePragmas :: [Text] -> CodeGen e ()
setLanguagePragmas :: forall e. [Text] -> CodeGen e ()
setLanguagePragmas [Text]
ps =
    ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{modulePragmas :: Deps
modulePragmas = [Text] -> Deps
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
ps})

-- | Add a language pragma for the current module.
addLanguagePragma :: Text -> CodeGen e ()
addLanguagePragma :: forall e. Text -> CodeGen e ()
addLanguagePragma Text
p =
  ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{modulePragmas :: Deps
modulePragmas =
                                 Text -> Deps -> Deps
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
p (ModuleInfo -> Deps
modulePragmas ModuleInfo
s)})

-- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma).
setGHCOptions :: [Text] -> CodeGen e ()
setGHCOptions :: forall e. [Text] -> CodeGen e ()
setGHCOptions [Text]
opts =
    ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{moduleGHCOpts :: Deps
moduleGHCOpts = [Text] -> Deps
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
opts})

-- | Set the given flags for the module.
setModuleFlags :: [ModuleFlag] -> CodeGen e ()
setModuleFlags :: forall e. [ModuleFlag] -> CodeGen e ()
setModuleFlags [ModuleFlag]
flags =
    ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{moduleFlags :: Set ModuleFlag
moduleFlags = [ModuleFlag] -> Set ModuleFlag
forall a. Ord a => [a] -> Set a
Set.fromList [ModuleFlag]
flags})

-- | Set the minimum base version supported by the current module.
setModuleMinBase :: BaseVersion -> CodeGen e ()
setModuleMinBase :: forall e. BaseVersion -> CodeGen e ()
setModuleMinBase BaseVersion
v =
    ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{moduleMinBase :: BaseVersion
moduleMinBase = BaseVersion -> BaseVersion -> BaseVersion
forall a. Ord a => a -> a -> a
max BaseVersion
v (ModuleInfo -> BaseVersion
moduleMinBase ModuleInfo
s)})

-- | Add documentation for a given section.
addSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e ()
addSectionFormattedDocs :: forall e. HaddockSection -> Text -> CodeGen e ()
addSectionFormattedDocs HaddockSection
section Text
docs =
    ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{sectionDocs :: Map HaddockSection Text
sectionDocs = (Text -> Text -> Text)
-> HaddockSection
-> Text
-> Map HaddockSection Text
-> Map HaddockSection Text
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ((Text -> Text -> Text) -> Text -> Text -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>))
                                                 HaddockSection
section Text
docs (ModuleInfo -> Map HaddockSection Text
sectionDocs ModuleInfo
s)})

-- | Prepend documentation at the beginning of a given section.
prependSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e ()
prependSectionFormattedDocs :: forall e. HaddockSection -> Text -> CodeGen e ()
prependSectionFormattedDocs HaddockSection
section Text
docs =
    ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((CGState, ModuleInfo) -> (CGState, ModuleInfo))
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \(CGState
cgs, ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{sectionDocs :: Map HaddockSection Text
sectionDocs = (Text -> Text -> Text)
-> HaddockSection
-> Text
-> Map HaddockSection Text
-> Map HaddockSection Text
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>)
                                                 HaddockSection
section Text
docs (ModuleInfo -> Map HaddockSection Text
sectionDocs ModuleInfo
s)})

-- | Format a CPP conditional.
cppCondFormat :: CPPConditional -> (Text, Text)
cppCondFormat :: CPPConditional -> (Text, Text)
cppCondFormat (CPPIf Text
c) = (Text
"#if " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n", Text
"#endif\n")

-- | Return a text representation of the `Code`.
codeToText :: Code -> Text
codeToText :: Code -> Text
codeToText (Code Seq CodeToken
seq) = Text -> Text
LT.toStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Int -> ViewL CodeToken -> Builder
genCode Int
0 (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
seq)
  where genCode :: Int -> ViewL CodeToken -> B.Builder
        genCode :: Int -> ViewL CodeToken -> Builder
genCode Int
_ ViewL CodeToken
Seq.EmptyL = Builder
forall a. Monoid a => a
mempty
        genCode Int
n (Line Text
s :< Seq CodeToken
rest) = Text -> Builder
B.fromText (Int -> Text -> Text
paddedLine Int
n Text
s) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                                      Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)
        genCode Int
n (Indent (Code Seq CodeToken
seq) :< Seq CodeToken
rest) = Int -> ViewL CodeToken -> Builder
genCode (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
seq) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                                      Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)
        genCode Int
n (Group (Code Seq CodeToken
seq) :< Seq CodeToken
rest) = Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
seq) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                                               Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)
        genCode Int
n (Comment [] :< Seq CodeToken
rest) = Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)
        genCode Int
n (Comment [Text
s] :< Seq CodeToken
rest) =
          Text -> Builder
B.fromText (Int -> Text -> Text
paddedLine Int
n (Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)
        genCode Int
n (Comment (Text
l:[Text]
ls):< Seq CodeToken
rest) =
          Text -> Builder
B.fromText (Text
"{-  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                      Int -> [Text] -> Text
paddedLines (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Text]
ls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-}\n") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)
        genCode Int
n (CPPBlock CPPConditional
cond (Code Seq CodeToken
seq) :< Seq CodeToken
rest) =
          let (Text
condBegin, Text
condEnd) = CPPConditional -> (Text, Text)
cppCondFormat CPPConditional
cond
          in Text -> Builder
B.fromText Text
condBegin Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
seq) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
             Text -> Builder
B.fromText Text
condEnd Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> ViewL CodeToken -> Builder
genCode Int
n (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)
        genCode Int
n (CodeToken
IncreaseIndent :< Seq CodeToken
rest) = Int -> ViewL CodeToken -> Builder
genCode (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)

-- | Pad a line to the given number of leading tabs (with one tab
-- equal to four spaces), and add a newline at the end.
paddedLine :: Int -> Text -> Text
paddedLine :: Int -> Text -> Text
paddedLine Int
n Text
s = Int -> Text -> Text
T.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

-- | Pad a set of lines to the given number of leading tabs (with one
-- tab equal to four spaces), and add a newline at the end of each
-- line.
paddedLines :: Int -> [Text] -> Text
paddedLines :: Int -> [Text] -> Text
paddedLines Int
n [Text]
ls = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
paddedLine Int
n) [Text]
ls

-- | Put a (padded) comma at the end of the text.
comma :: Text -> Text
comma :: Text -> Text
comma Text
s = Int -> Text -> Text
padTo Int
40 Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","

-- | Format the given export symbol.
formatExport :: (Export -> Text) -> Export -> Text
formatExport :: (Export -> Text) -> Export -> Text
formatExport Export -> Text
formatName Export
export = [CPPConditional] -> Text
go (Export -> [CPPConditional]
exportGuards Export
export)
  where go :: [CPPConditional] -> Text
        go :: [CPPConditional] -> Text
go [] = (Int -> Text -> Text
paddedLine Int
1 (Text -> Text) -> (Export -> Text) -> Export -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
comma (Text -> Text) -> (Export -> Text) -> Export -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Export -> Text
formatName) Export
export
        go (CPPConditional
c:[CPPConditional]
cs) = let (Text
begin, Text
end) = CPPConditional -> (Text, Text)
cppCondFormat CPPConditional
c
                    in Text
begin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [CPPConditional] -> Text
go [CPPConditional]
cs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end

-- | Format the list of exported modules.
formatExportedModules :: [Export] -> Maybe Text
formatExportedModules :: [Export] -> Maybe Text
formatExportedModules [] = Maybe Text
forall a. Maybe a
Nothing
formatExportedModules [Export]
exports =
    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ([Export] -> Text) -> [Export] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Text) -> ([Export] -> [Text]) -> [Export] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> Text) -> [Export] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Export -> Text) -> Export -> Text
formatExport ((Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Export -> Text) -> Export -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Export -> Text
exportSymbol))
          ([Export] -> [Text])
-> ([Export] -> [Export]) -> [Export] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> Bool) -> [Export] -> [Export]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ExportType -> ExportType -> Bool
forall a. Eq a => a -> a -> Bool
== ExportType
ExportModule) (ExportType -> Bool) -> (Export -> ExportType) -> Export -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Export -> ExportType
exportType) ([Export] -> Maybe Text) -> [Export] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Export]
exports

-- | Format the toplevel exported symbols.
formatToplevel :: [Export] -> Maybe Text
formatToplevel :: [Export] -> Maybe Text
formatToplevel [] = Maybe Text
forall a. Maybe a
Nothing
formatToplevel [Export]
exports =
    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ([Export] -> Text) -> [Export] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Text) -> ([Export] -> [Text]) -> [Export] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> Text) -> [Export] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Export -> Text) -> Export -> Text
formatExport Export -> Text
exportSymbol)
         ([Export] -> [Text])
-> ([Export] -> [Export]) -> [Export] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> Bool) -> [Export] -> [Export]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ExportType -> ExportType -> Bool
forall a. Eq a => a -> a -> Bool
== HaddockSection -> ExportType
ExportSymbol HaddockSection
ToplevelSection) (ExportType -> Bool) -> (Export -> ExportType) -> Export -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Export -> ExportType
exportType) ([Export] -> Maybe Text) -> [Export] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Export]
exports

-- | Format the type declarations section.
formatTypeDecls :: [Export] -> Maybe Text
formatTypeDecls :: [Export] -> Maybe Text
formatTypeDecls [Export]
exports =
    let exportedTypes :: [Export]
exportedTypes = (Export -> Bool) -> [Export] -> [Export]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ExportType -> ExportType -> Bool
forall a. Eq a => a -> a -> Bool
== ExportType
ExportTypeDecl) (ExportType -> Bool) -> (Export -> ExportType) -> Export -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Export -> ExportType
exportType) [Export]
exports
    in if [Export]
exportedTypes [Export] -> [Export] -> Bool
forall a. Eq a => a -> a -> Bool
== []
       then Maybe Text
forall a. Maybe a
Nothing
       else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [ Text
"-- * Exported types"
                               , [Text] -> Text
T.concat ([Text] -> Text) -> ([Export] -> [Text]) -> [Export] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> Text) -> [Export] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ( (Export -> Text) -> Export -> Text
formatExport Export -> Text
exportSymbol )
                                      ([Export] -> Text) -> [Export] -> Text
forall a b. (a -> b) -> a -> b
$ [Export]
exportedTypes ]

-- | A subsection name, with an optional anchor name.
data Subsection = Subsection { Subsection -> Text
subsectionTitle  :: Text
                             , Subsection -> Maybe Text
subsectionAnchor :: Maybe Text
                             , Subsection -> Maybe Text
subsectionDoc    :: Maybe Text
                             } deriving (Subsection -> Subsection -> Bool
(Subsection -> Subsection -> Bool)
-> (Subsection -> Subsection -> Bool) -> Eq Subsection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Subsection -> Subsection -> Bool
== :: Subsection -> Subsection -> Bool
$c/= :: Subsection -> Subsection -> Bool
/= :: Subsection -> Subsection -> Bool
Eq, Int -> Subsection -> ShowS
[Subsection] -> ShowS
Subsection -> FilePath
(Int -> Subsection -> ShowS)
-> (Subsection -> FilePath)
-> ([Subsection] -> ShowS)
-> Show Subsection
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Subsection -> ShowS
showsPrec :: Int -> Subsection -> ShowS
$cshow :: Subsection -> FilePath
show :: Subsection -> FilePath
$cshowList :: [Subsection] -> ShowS
showList :: [Subsection] -> ShowS
Show, Eq Subsection
Eq Subsection
-> (Subsection -> Subsection -> Ordering)
-> (Subsection -> Subsection -> Bool)
-> (Subsection -> Subsection -> Bool)
-> (Subsection -> Subsection -> Bool)
-> (Subsection -> Subsection -> Bool)
-> (Subsection -> Subsection -> Subsection)
-> (Subsection -> Subsection -> Subsection)
-> Ord Subsection
Subsection -> Subsection -> Bool
Subsection -> Subsection -> Ordering
Subsection -> Subsection -> Subsection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Subsection -> Subsection -> Ordering
compare :: Subsection -> Subsection -> Ordering
$c< :: Subsection -> Subsection -> Bool
< :: Subsection -> Subsection -> Bool
$c<= :: Subsection -> Subsection -> Bool
<= :: Subsection -> Subsection -> Bool
$c> :: Subsection -> Subsection -> Bool
> :: Subsection -> Subsection -> Bool
$c>= :: Subsection -> Subsection -> Bool
>= :: Subsection -> Subsection -> Bool
$cmax :: Subsection -> Subsection -> Subsection
max :: Subsection -> Subsection -> Subsection
$cmin :: Subsection -> Subsection -> Subsection
min :: Subsection -> Subsection -> Subsection
Ord)

-- | A subsection with an anchor given by the title and @prefix:title@
-- anchor, and the given documentation.
subsecWithPrefix :: NamedSection -> Text -> Maybe Text -> Subsection
subsecWithPrefix :: NamedSection -> Text -> Maybe Text -> Subsection
subsecWithPrefix NamedSection
mainSection Text
title Maybe Text
doc =
  Subsection { subsectionTitle :: Text
subsectionTitle = Text
title
             , subsectionAnchor :: Maybe Text
subsectionAnchor = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
title)
             , subsectionDoc :: Maybe Text
subsectionDoc = Maybe Text
doc }
  where prefix :: Text
prefix = case NamedSection
mainSection of
          NamedSection
MethodSection -> Text
"method"
          NamedSection
PropertySection -> Text
"attr"
          NamedSection
SignalSection -> Text
"signal"
          NamedSection
EnumSection -> Text
"enum"
          NamedSection
FlagSection -> Text
"flag"

-- | User-facing name in the Haddocks for the given main section.
mainSectionName :: NamedSection -> Text
mainSectionName :: NamedSection -> Text
mainSectionName NamedSection
MethodSection = Text
"Methods"
mainSectionName NamedSection
PropertySection = Text
"Properties"
mainSectionName NamedSection
SignalSection = Text
"Signals"
mainSectionName NamedSection
EnumSection = Text
"Enumerations"
mainSectionName NamedSection
FlagSection = Text
"Flags"

-- | Format a given section made of subsections.
formatSection :: M.Map HaddockSection Text -> NamedSection ->
                 (Set.Set Export, [(Subsection, Export)]) -> Maybe Text
formatSection :: Map HaddockSection Text
-> NamedSection
-> (Set Export, [(Subsection, Export)])
-> Maybe Text
formatSection Map HaddockSection Text
docs NamedSection
section (Set Export
sectionExports, [(Subsection, Export)]
subsectionExports) =
    if [(Subsection, Export)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Subsection, Export)]
subsectionExports Bool -> Bool -> Bool
&& Set Export -> Bool
forall a. Set a -> Bool
Set.null Set Export
sectionExports
    then Maybe Text
forall a. Maybe a
Nothing
    else let docstring :: Text
docstring = case HaddockSection -> Map HaddockSection Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (NamedSection -> HaddockSection
Section NamedSection
section) Map HaddockSection Text
docs of
                           Maybe Text
Nothing -> Text
""
                           Just Text
s -> Text -> Text
formatHaddockComment Text
s
      in Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text
" -- * " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NamedSection -> Text
mainSectionName NamedSection
section
                            , Text
docstring
                            , ( [Text] -> Text
T.concat
                              ([Text] -> Text) -> (Set Export -> [Text]) -> Set Export -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> Text) -> [Export] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Export -> Text) -> Export -> Text
formatExport Export -> Text
exportSymbol)
                              ([Export] -> [Text])
-> (Set Export -> [Export]) -> Set Export -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Export -> [Export]
forall a. Set a -> [a]
Set.toList ) Set Export
sectionExports
                            , ( [Text] -> Text
T.unlines
                              ([Text] -> Text)
-> (Map Subsection (Set Export) -> [Text])
-> Map Subsection (Set Export)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Subsection, Set Export) -> Text)
-> [(Subsection, Set Export)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Subsection, Set Export) -> Text
formatSubsection
                              ([(Subsection, Set Export)] -> [Text])
-> (Map Subsection (Set Export) -> [(Subsection, Set Export)])
-> Map Subsection (Set Export)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Subsection (Set Export) -> [(Subsection, Set Export)]
forall k a. Map k a -> [(k, a)]
M.toList ) Map Subsection (Set Export)
exportedSubsections]

    where
      exportedSubsections :: M.Map Subsection (Set.Set Export)
      exportedSubsections :: Map Subsection (Set Export)
exportedSubsections = ((Subsection, Export)
 -> Map Subsection (Set Export) -> Map Subsection (Set Export))
-> Map Subsection (Set Export)
-> [(Subsection, Export)]
-> Map Subsection (Set Export)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Subsection, Export)
-> Map Subsection (Set Export) -> Map Subsection (Set Export)
extract Map Subsection (Set Export)
forall k a. Map k a
M.empty [(Subsection, Export)]
subsectionExports

      extract :: (Subsection, Export) -> M.Map Subsection (Set.Set Export)
              -> M.Map Subsection (Set.Set Export)
      extract :: (Subsection, Export)
-> Map Subsection (Set Export) -> Map Subsection (Set Export)
extract (Subsection
subsec, Export
m) Map Subsection (Set Export)
secs =
          (Set Export -> Set Export -> Set Export)
-> Subsection
-> Set Export
-> Map Subsection (Set Export)
-> Map Subsection (Set Export)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set Export -> Set Export -> Set Export
forall a. Ord a => Set a -> Set a -> Set a
Set.union Subsection
subsec (Export -> Set Export
forall a. a -> Set a
Set.singleton Export
m) Map Subsection (Set Export)
secs

      formatSubsection :: (Subsection, Set.Set Export) -> Text
      formatSubsection :: (Subsection, Set Export) -> Text
formatSubsection (Subsection
subsec, Set Export
symbols) =
          [Text] -> Text
T.unlines [ Text
"-- ** " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case Subsection -> Maybe Text
subsectionAnchor Subsection
subsec of
                                    Just Text
anchor -> Subsection -> Text
subsectionTitle Subsection
subsec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                                   Text
" #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
anchor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#"
                                    Maybe Text
Nothing -> Subsection -> Text
subsectionTitle Subsection
subsec
                    , case Subsection -> Maybe Text
subsectionDoc Subsection
subsec of
                        Just Text
text -> Text -> Text
formatHaddockComment Text
text
                        Maybe Text
Nothing -> Text
""
                    , ( [Text] -> Text
T.concat
                      ([Text] -> Text) -> (Set Export -> [Text]) -> Set Export -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> Text) -> [Export] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Export -> Text) -> Export -> Text
formatExport Export -> Text
exportSymbol)
                      ([Export] -> [Text])
-> (Set Export -> [Export]) -> Set Export -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Export -> [Export]
forall a. Set a -> [a]
Set.toList ) Set Export
symbols]

-- | Format the list of exports into grouped sections.
formatSubsectionExports :: M.Map HaddockSection Text -> [Export] -> [Maybe Text]
formatSubsectionExports :: Map HaddockSection Text -> [Export] -> [Maybe Text]
formatSubsectionExports Map HaddockSection Text
docs [Export]
exports = ((NamedSection, (Set Export, [(Subsection, Export)]))
 -> Maybe Text)
-> [(NamedSection, (Set Export, [(Subsection, Export)]))]
-> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedSection
 -> (Set Export, [(Subsection, Export)]) -> Maybe Text)
-> (NamedSection, (Set Export, [(Subsection, Export)]))
-> Maybe Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Map HaddockSection Text
-> NamedSection
-> (Set Export, [(Subsection, Export)])
-> Maybe Text
formatSection Map HaddockSection Text
docs))
                                       (Map NamedSection (Set Export, [(Subsection, Export)])
-> [(NamedSection, (Set Export, [(Subsection, Export)]))]
forall k a. Map k a -> [(k, a)]
M.toAscList Map NamedSection (Set Export, [(Subsection, Export)])
collectedExports)
  where collectedExports :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)])
        collectedExports :: Map NamedSection (Set Export, [(Subsection, Export)])
collectedExports = (Map NamedSection (Set Export, [(Subsection, Export)])
 -> Export -> Map NamedSection (Set Export, [(Subsection, Export)]))
-> Map NamedSection (Set Export, [(Subsection, Export)])
-> [Export]
-> Map NamedSection (Set Export, [(Subsection, Export)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map NamedSection (Set Export, [(Subsection, Export)])
-> Export -> Map NamedSection (Set Export, [(Subsection, Export)])
classifyExport Map NamedSection (Set Export, [(Subsection, Export)])
forall k a. Map k a
M.empty [Export]
exports

        classifyExport :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) ->
                          Export ->
                          M.Map NamedSection (Set.Set Export, [(Subsection, Export)])
        classifyExport :: Map NamedSection (Set Export, [(Subsection, Export)])
-> Export -> Map NamedSection (Set Export, [(Subsection, Export)])
classifyExport Map NamedSection (Set Export, [(Subsection, Export)])
m Export
export =
          let join :: (Set a, [a]) -> (Set a, [a]) -> (Set a, [a])
join (Set a
snew, [a]
exnew) (Set a
sold, [a]
exold) = (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
snew Set a
sold,
                                                  [a]
exnew [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
exold)
          in case Export -> ExportType
exportType Export
export of
            ExportSymbol hs :: HaddockSection
hs@(NamedSubsection NamedSection
ms Text
n) ->
              let subsec :: Subsection
subsec = NamedSection -> Text -> Maybe Text -> Subsection
subsecWithPrefix NamedSection
ms Text
n (HaddockSection -> Map HaddockSection Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HaddockSection
hs Map HaddockSection Text
docs)
              in ((Set Export, [(Subsection, Export)])
 -> (Set Export, [(Subsection, Export)])
 -> (Set Export, [(Subsection, Export)]))
-> NamedSection
-> (Set Export, [(Subsection, Export)])
-> Map NamedSection (Set Export, [(Subsection, Export)])
-> Map NamedSection (Set Export, [(Subsection, Export)])
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Set Export, [(Subsection, Export)])
-> (Set Export, [(Subsection, Export)])
-> (Set Export, [(Subsection, Export)])
forall {a} {a}.
Ord a =>
(Set a, [a]) -> (Set a, [a]) -> (Set a, [a])
join NamedSection
ms (Set Export
forall a. Set a
Set.empty, [(Subsection
subsec, Export
export)]) Map NamedSection (Set Export, [(Subsection, Export)])
m
            ExportSymbol (Section NamedSection
s) ->
              ((Set Export, [(Subsection, Export)])
 -> (Set Export, [(Subsection, Export)])
 -> (Set Export, [(Subsection, Export)]))
-> NamedSection
-> (Set Export, [(Subsection, Export)])
-> Map NamedSection (Set Export, [(Subsection, Export)])
-> Map NamedSection (Set Export, [(Subsection, Export)])
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Set Export, [(Subsection, Export)])
-> (Set Export, [(Subsection, Export)])
-> (Set Export, [(Subsection, Export)])
forall {a} {a}.
Ord a =>
(Set a, [a]) -> (Set a, [a]) -> (Set a, [a])
join NamedSection
s (Export -> Set Export
forall a. a -> Set a
Set.singleton Export
export, []) Map NamedSection (Set Export, [(Subsection, Export)])
m
            ExportType
_ -> Map NamedSection (Set Export, [(Subsection, Export)])
m

-- | Format the given export list. This is just the inside of the
-- parenthesis.
formatExportList :: M.Map HaddockSection Text -> [Export] -> Text
formatExportList :: Map HaddockSection Text -> [Export] -> Text
formatExportList Map HaddockSection Text
docs [Export]
exports =
    [Text] -> Text
T.unlines ([Text] -> Text)
-> ([Maybe Text] -> [Text]) -> [Maybe Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> Text) -> [Maybe Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Export] -> Maybe Text
formatExportedModules [Export]
exports
                            Maybe Text -> [Maybe Text] -> [Maybe Text]
forall a. a -> [a] -> [a]
: [Export] -> Maybe Text
formatToplevel [Export]
exports
                            Maybe Text -> [Maybe Text] -> [Maybe Text]
forall a. a -> [a] -> [a]
: [Export] -> Maybe Text
formatTypeDecls [Export]
exports
                            Maybe Text -> [Maybe Text] -> [Maybe Text]
forall a. a -> [a] -> [a]
: Map HaddockSection Text -> [Export] -> [Maybe Text]
formatSubsectionExports Map HaddockSection Text
docs [Export]
exports

-- | Write down the list of language pragmas.
languagePragmas :: [Text] -> Text
languagePragmas :: [Text] -> Text
languagePragmas [] = Text
""
languagePragmas [Text]
ps = Text
"{-# LANGUAGE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ps Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"

-- | Write down the list of GHC options.
ghcOptions :: [Text] -> Text
ghcOptions :: [Text] -> Text
ghcOptions [] = Text
""
ghcOptions [Text]
opts = Text
"{-# OPTIONS_GHC " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
opts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"

-- | Generate some convenience CPP macros.
cppMacros :: Text
cppMacros :: Text
cppMacros = [Text] -> Text
T.unlines
  [Text
"#if (MIN_VERSION_haskell_gi_overloading(1,0,0) && !defined(__HADDOCK_VERSION__))"
  , Text
"#define ENABLE_OVERLOADING"
  , Text
"#endif"]

-- | Standard fields for every module.
standardFields :: Text
standardFields :: Text
standardFields = [Text] -> Text
T.unlines [ Text
"Copyright  : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
authors
                           , Text
"License    : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
license
                           , Text
"Maintainer : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
maintainers ]

-- | The haddock header for the module, including optionally a description.
moduleHaddock :: Maybe Text -> Text
moduleHaddock :: Maybe Text -> Text
moduleHaddock Maybe Text
Nothing = Text -> Text
formatHaddockComment (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
standardFields
moduleHaddock (Just Text
description) =
  Text -> Text
formatHaddockComment (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text
standardFields, Text
description]

-- | Format the comment with the module documentation.
formatHaddockComment :: Text -> Text
formatHaddockComment :: Text -> Text
formatHaddockComment Text
doc = let lines :: [Text]
lines = case Text -> [Text]
T.lines Text
doc of
                                 [] -> []
                                 (Text
first:[Text]
rest) -> (Text
"-- | " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
first) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
                                                 (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
rest
                          in [Text] -> Text
T.unlines [Text]
lines

-- | Generic module prelude. We reexport all of the submodules.
modulePrelude :: M.Map HaddockSection Text -> Text -> [Export] -> [Text] -> Text
modulePrelude :: Map HaddockSection Text -> Text -> [Export] -> [Text] -> Text
modulePrelude Map HaddockSection Text
_ Text
name [] [] = Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" () where\n"
modulePrelude Map HaddockSection Text
docs Text
name [Export]
exports [] =
    Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    ( "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection Text -> [Export] -> Text
formatExportList Map HaddockSection Text
docs [Export]
exports
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    ) where\n"
modulePrelude Map HaddockSection Text
docs Text
name [] [Text]
reexportedModules =
    Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    ( "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection Text -> [Export] -> Text
formatExportList Map HaddockSection Text
docs ((Text -> Export) -> [Text] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
m -> ExportType -> Text -> [CPPConditional] -> Export
Export ExportType
ExportModule Text
m []) [Text]
reexportedModules)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    ) where\n\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"import " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
reexportedModules)
modulePrelude Map HaddockSection Text
docs Text
name [Export]
exports [Text]
reexportedModules =
    Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    ( "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection Text -> [Export] -> Text
formatExportList Map HaddockSection Text
docs ((Text -> Export) -> [Text] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
m -> ExportType -> Text -> [CPPConditional] -> Export
Export ExportType
ExportModule Text
m []) [Text]
reexportedModules)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection Text -> [Export] -> Text
formatExportList Map HaddockSection Text
docs [Export]
exports
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    ) where\n\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"import " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
reexportedModules)

-- | Code for loading the needed dependencies. One needs to give the
-- prefix for the namespace being currently generated, modules with
-- this prefix will be imported as {-# SOURCE #-}, and otherwise will
-- be imported normally.
importDeps :: ModulePath -> [ModulePath] -> Text
importDeps :: ModulePath -> [ModulePath] -> Text
importDeps ModulePath
_ [] = Text
""
importDeps (ModulePath [Text]
prefix) [ModulePath]
deps = [Text] -> Text
T.unlines ([Text] -> Text)
-> ([ModulePath] -> [Text]) -> [ModulePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModulePath -> Text) -> [ModulePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ModulePath -> Text
toImport ([ModulePath] -> Text) -> [ModulePath] -> Text
forall a b. (a -> b) -> a -> b
$ [ModulePath]
deps
    where toImport :: ModulePath -> Text
          toImport :: ModulePath -> Text
toImport ModulePath
dep = let impSt :: Text
impSt = if ModulePath -> Bool
importSource ModulePath
dep
                                     then Text
"import {-# SOURCE #-} qualified "
                                     else Text
"import qualified "
                         in Text
impSt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ModulePath -> Text
dotWithPrefix ModulePath
dep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                Text
" as " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ModulePath -> Text
qualifiedModuleName ModulePath
dep
          importSource :: ModulePath -> Bool
          importSource :: ModulePath -> Bool
importSource (ModulePath [Text
_, Text
"Callbacks"]) = Bool
False
          importSource (ModulePath [Text]
mp) = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
prefix) [Text]
mp [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
prefix

-- | Standard imports.
moduleImports :: Text
moduleImports :: Text
moduleImports = [Text] -> Text
T.unlines [
                 Text
"import Data.GI.Base.ShortPrelude"
                , Text
"import qualified Data.GI.Base.ShortPrelude as SP"
                , Text
"import qualified Data.GI.Base.Overloading as O"
                , Text
"import qualified Prelude as P"
                , Text
""
                , Text
"import qualified Data.GI.Base.Attributes as GI.Attributes"
                , Text
"import qualified Data.GI.Base.BasicTypes as B.Types"
                , Text
"import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr"
                , Text
"import qualified Data.GI.Base.GArray as B.GArray"
                , Text
"import qualified Data.GI.Base.GClosure as B.GClosure"
                , Text
"import qualified Data.GI.Base.GError as B.GError"
                , Text
"import qualified Data.GI.Base.GHashTable as B.GHT"
                , Text
"import qualified Data.GI.Base.GVariant as B.GVariant"
                , Text
"import qualified Data.GI.Base.GValue as B.GValue"
                , Text
"import qualified Data.GI.Base.GParamSpec as B.GParamSpec"
                , Text
"import qualified Data.GI.Base.CallStack as B.CallStack"
                , Text
"import qualified Data.GI.Base.Properties as B.Properties"
                , Text
"import qualified Data.GI.Base.Signals as B.Signals"
                , Text
"import qualified Control.Monad.IO.Class as MIO"
                , Text
"import qualified Data.Coerce as Coerce"
                , Text
"import qualified Data.Text as T"
                , Text
"import qualified Data.ByteString.Char8 as B"
                , Text
"import qualified Data.Map as Map"
                , Text
"import qualified Foreign.Ptr as FP"
                , Text
"import qualified GHC.OverloadedLabels as OL"
                , Text
"import qualified GHC.Records as R" ]

-- | Like `dotModulePath`, but add a "GI." prefix.
dotWithPrefix :: ModulePath -> Text
dotWithPrefix :: ModulePath -> Text
dotWithPrefix ModulePath
mp = ModulePath -> Text
dotModulePath (ModulePath
"GI" ModulePath -> ModulePath -> ModulePath
forall a. Semigroup a => a -> a -> a
<> ModulePath
mp)

-- | Write to disk the code for a module, under the given base
-- directory. Does not write submodules recursively, for that use
-- `writeModuleTree`.
writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> IO ()
writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> IO ()
writeModuleInfo Bool
verbose Maybe FilePath
dirPrefix ModuleInfo
minfo = do
  let submodulePaths :: [ModulePath]
submodulePaths = (ModuleInfo -> ModulePath) -> [ModuleInfo] -> [ModulePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleInfo -> ModulePath
modulePath) (Map Text ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
minfo))
      -- We reexport any submodules.
      submoduleExports :: [Text]
submoduleExports = (ModulePath -> Text) -> [ModulePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ModulePath -> Text
dotWithPrefix [ModulePath]
submodulePaths
      fname :: FilePath
fname = Maybe FilePath -> ModulePath -> ShowS
modulePathToFilePath Maybe FilePath
dirPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo) FilePath
".hs"
      dirname :: FilePath
dirname = ShowS
takeDirectory FilePath
fname
      code :: Text
code = Code -> Text
codeToText (ModuleInfo -> Code
moduleCode ModuleInfo
minfo)
      pragmas :: Text
pragmas = [Text] -> Text
languagePragmas (Deps -> [Text]
forall a. Set a -> [a]
Set.toList (Deps -> [Text]) -> Deps -> [Text]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Deps
modulePragmas ModuleInfo
minfo)
      optionsGHC :: Text
optionsGHC = [Text] -> Text
ghcOptions (Deps -> [Text]
forall a. Set a -> [a]
Set.toList (Deps -> [Text]) -> Deps -> [Text]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Deps
moduleGHCOpts ModuleInfo
minfo)
      prelude :: Text
prelude = Map HaddockSection Text -> Text -> [Export] -> [Text] -> Text
modulePrelude (ModuleInfo -> Map HaddockSection Text
sectionDocs ModuleInfo
minfo)
                (ModulePath -> Text
dotWithPrefix (ModulePath -> Text) -> ModulePath -> Text
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo)
                (Seq Export -> [Export]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (ModuleInfo -> Seq Export
moduleExports ModuleInfo
minfo))
                [Text]
submoduleExports
      imports :: Text
imports = if ModuleFlag
ImplicitPrelude ModuleFlag -> Set ModuleFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ModuleInfo -> Set ModuleFlag
moduleFlags ModuleInfo
minfo
                then Text
""
                else Text
moduleImports
      pkgRoot :: ModulePath
pkgRoot = [Text] -> ModulePath
ModulePath (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
1 (ModulePath -> [Text]
modulePathToList (ModulePath -> [Text]) -> ModulePath -> [Text]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo))
      deps :: Text
deps = ModulePath -> [ModulePath] -> Text
importDeps ModulePath
pkgRoot (Set ModulePath -> [ModulePath]
forall a. Set a -> [a]
Set.toList (Set ModulePath -> [ModulePath]) -> Set ModulePath -> [ModulePath]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Set ModulePath
qualifiedImports ModuleInfo
minfo)
      haddock :: Text
haddock = Maybe Text -> Text
moduleHaddock (HaddockSection -> Map HaddockSection Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HaddockSection
ToplevelSection (ModuleInfo -> Map HaddockSection Text
sectionDocs ModuleInfo
minfo))

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn ((Text -> FilePath
T.unpack (Text -> FilePath)
-> (ModuleInfo -> Text) -> ModuleInfo -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModulePath -> Text
dotWithPrefix (ModulePath -> Text)
-> (ModuleInfo -> ModulePath) -> ModuleInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleInfo -> ModulePath
modulePath) ModuleInfo
minfo
                           FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
fname)
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dirname
  FilePath -> Text -> IO ()
utf8WriteFile FilePath
fname ([Text] -> Text
T.unlines [Text
pragmas, Text
optionsGHC, Text
haddock, Text
cppMacros,
                                 Text
prelude, Text
imports, Text
deps, Text
code])
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (Code -> Bool) -> Code -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code -> Bool
isCodeEmpty (Code -> Bool) -> Code -> Bool
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Code
bootCode ModuleInfo
minfo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let bootFName :: FilePath
bootFName = Maybe FilePath -> ModulePath -> ShowS
modulePathToFilePath Maybe FilePath
dirPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo) FilePath
".hs-boot"
    FilePath -> Text -> IO ()
utf8WriteFile FilePath
bootFName (ModuleInfo -> Text
genHsBoot ModuleInfo
minfo)

-- | Generate the .hs-boot file for the given module.
genHsBoot :: ModuleInfo -> Text
genHsBoot :: ModuleInfo -> Text
genHsBoot ModuleInfo
minfo =
    Text
cppMacros Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ModulePath -> Text
dotWithPrefix (ModulePath -> Text)
-> (ModuleInfo -> ModulePath) -> ModuleInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleInfo -> ModulePath
modulePath) ModuleInfo
minfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    Text
moduleImports Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    Code -> Text
codeToText (ModuleInfo -> Code
bootCode ModuleInfo
minfo)

-- | Construct the filename corresponding to the given module.
modulePathToFilePath :: Maybe FilePath -> ModulePath -> FilePath -> FilePath
modulePathToFilePath :: Maybe FilePath -> ModulePath -> ShowS
modulePathToFilePath Maybe FilePath
dirPrefix (ModulePath [Text]
mp) FilePath
ext =
    [FilePath] -> FilePath
joinPath (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
dirPrefix FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath
"GI" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack [Text]
mp) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
ext

-- | Write down the code for a module and its submodules to disk under
-- the given base directory. It returns the list of written modules.
writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]
writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]
writeModuleTree Bool
verbose Maybe FilePath
dirPrefix ModuleInfo
minfo = do
  [Text]
submodulePaths <- [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> IO [[Text]] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleInfo] -> (ModuleInfo -> IO [Text]) -> IO [[Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map Text ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
minfo))
                                    (Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]
writeModuleTree Bool
verbose Maybe FilePath
dirPrefix)
  Bool -> Maybe FilePath -> ModuleInfo -> IO ()
writeModuleInfo Bool
verbose Maybe FilePath
dirPrefix ModuleInfo
minfo
  [Text] -> IO [Text]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ (ModulePath -> Text
dotWithPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
submodulePaths)

-- | Return the list of modules `writeModuleTree` would write, without
-- actually writing anything to disk.
listModuleTree :: ModuleInfo -> [Text]
listModuleTree :: ModuleInfo -> [Text]
listModuleTree ModuleInfo
minfo =
    let submodulePaths :: [Text]
submodulePaths = (ModuleInfo -> [Text]) -> [ModuleInfo] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModuleInfo -> [Text]
listModuleTree (Map Text ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (ModuleInfo -> Map Text ModuleInfo
submodules ModuleInfo
minfo))
    in ModulePath -> Text
dotWithPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
submodulePaths