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

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

    , registerNSDependency
    , qualified
    , getDeps
    , recurseWithAPIs

    , handleCGExc
    , describeCGError
    , notImplementedError
    , badIntroError
    , missingInfoError

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

    , getFreshTypeVariable
    , resetTypeVariableScope

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

    , addSectionFormattedDocs

    , 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.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 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
/= :: CPPConditional -> CPPConditional -> Bool
$c/= :: CPPConditional -> CPPConditional -> Bool
== :: CPPConditional -> CPPConditional -> Bool
$c== :: CPPConditional -> CPPConditional -> Bool
Eq, Int -> CPPConditional -> ShowS
[CPPConditional] -> ShowS
CPPConditional -> String
(Int -> CPPConditional -> ShowS)
-> (CPPConditional -> String)
-> ([CPPConditional] -> ShowS)
-> Show CPPConditional
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CPPConditional] -> ShowS
$cshowList :: [CPPConditional] -> ShowS
show :: CPPConditional -> String
$cshow :: CPPConditional -> String
showsPrec :: Int -> CPPConditional -> ShowS
$cshowsPrec :: Int -> 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
min :: CPPConditional -> CPPConditional -> CPPConditional
$cmin :: CPPConditional -> CPPConditional -> CPPConditional
max :: CPPConditional -> CPPConditional -> CPPConditional
$cmax :: CPPConditional -> CPPConditional -> CPPConditional
>= :: CPPConditional -> CPPConditional -> Bool
$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
compare :: CPPConditional -> CPPConditional -> Ordering
$ccompare :: CPPConditional -> CPPConditional -> Ordering
$cp1Ord :: Eq CPPConditional
Ord)

-- | The generated `Code` is a sequence of `CodeToken`s.
newtype Code = Code (Seq.Seq CodeToken)
  deriving (b -> Code -> Code
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
stimes :: b -> Code -> Code
$cstimes :: forall b. Integral b => b -> Code -> Code
sconcat :: NonEmpty Code -> Code
$csconcat :: NonEmpty Code -> Code
<> :: Code -> Code -> Code
$c<> :: Code -> 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
mconcat :: [Code] -> Code
$cmconcat :: [Code] -> Code
mappend :: Code -> Code -> Code
$cmappend :: Code -> Code -> Code
mempty :: Code
$cmempty :: Code
$cp1Monoid :: Semigroup Code
Monoid, Code -> Code -> Bool
(Code -> Code -> Bool) -> (Code -> Code -> Bool) -> Eq Code
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Code -> Code -> Bool
$c/= :: Code -> Code -> Bool
== :: Code -> Code -> Bool
$c== :: Code -> Code -> Bool
Eq, Int -> Code -> ShowS
[Code] -> ShowS
Code -> String
(Int -> Code -> ShowS)
-> (Code -> String) -> ([Code] -> ShowS) -> Show Code
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Code] -> ShowS
$cshowList :: [Code] -> ShowS
show :: Code -> String
$cshow :: Code -> String
showsPrec :: Int -> Code -> ShowS
$cshowsPrec :: Int -> 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
min :: Code -> Code -> Code
$cmin :: Code -> Code -> Code
max :: Code -> Code -> Code
$cmax :: Code -> Code -> Code
>= :: Code -> Code -> Bool
$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
compare :: Code -> Code -> Ordering
$ccompare :: Code -> Code -> Ordering
$cp1Ord :: Eq 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 :: 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 t :: 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
    | 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
/= :: CodeToken -> CodeToken -> Bool
$c/= :: CodeToken -> CodeToken -> Bool
== :: CodeToken -> CodeToken -> Bool
$c== :: 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
min :: CodeToken -> CodeToken -> CodeToken
$cmin :: CodeToken -> CodeToken -> CodeToken
max :: CodeToken -> CodeToken -> CodeToken
$cmax :: CodeToken -> CodeToken -> CodeToken
>= :: CodeToken -> CodeToken -> Bool
$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
compare :: CodeToken -> CodeToken -> Ordering
$ccompare :: CodeToken -> CodeToken -> Ordering
$cp1Ord :: Eq CodeToken
Ord, Int -> CodeToken -> ShowS
[CodeToken] -> ShowS
CodeToken -> String
(Int -> CodeToken -> ShowS)
-> (CodeToken -> String)
-> ([CodeToken] -> ShowS)
-> Show CodeToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeToken] -> ShowS
$cshowList :: [CodeToken] -> ShowS
show :: CodeToken -> String
$cshow :: CodeToken -> String
showsPrec :: Int -> CodeToken -> ShowS
$cshowsPrec :: Int -> 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
                    | NamedSubsection NamedSection Text
  deriving (Int -> HaddockSection -> ShowS
[HaddockSection] -> ShowS
HaddockSection -> String
(Int -> HaddockSection -> ShowS)
-> (HaddockSection -> String)
-> ([HaddockSection] -> ShowS)
-> Show HaddockSection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HaddockSection] -> ShowS
$cshowList :: [HaddockSection] -> ShowS
show :: HaddockSection -> String
$cshow :: HaddockSection -> String
showsPrec :: Int -> HaddockSection -> ShowS
$cshowsPrec :: Int -> HaddockSection -> ShowS
Show, HaddockSection -> HaddockSection -> Bool
(HaddockSection -> HaddockSection -> Bool)
-> (HaddockSection -> HaddockSection -> Bool) -> Eq HaddockSection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HaddockSection -> HaddockSection -> Bool
$c/= :: HaddockSection -> HaddockSection -> Bool
== :: HaddockSection -> HaddockSection -> Bool
$c== :: 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
min :: HaddockSection -> HaddockSection -> HaddockSection
$cmin :: HaddockSection -> HaddockSection -> HaddockSection
max :: HaddockSection -> HaddockSection -> HaddockSection
$cmax :: HaddockSection -> HaddockSection -> HaddockSection
>= :: HaddockSection -> HaddockSection -> Bool
$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
compare :: HaddockSection -> HaddockSection -> Ordering
$ccompare :: HaddockSection -> HaddockSection -> Ordering
$cp1Ord :: Eq 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 -> String
(Int -> NamedSection -> ShowS)
-> (NamedSection -> String)
-> ([NamedSection] -> ShowS)
-> Show NamedSection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NamedSection] -> ShowS
$cshowList :: [NamedSection] -> ShowS
show :: NamedSection -> String
$cshow :: NamedSection -> String
showsPrec :: Int -> NamedSection -> ShowS
$cshowsPrec :: Int -> NamedSection -> ShowS
Show, NamedSection -> NamedSection -> Bool
(NamedSection -> NamedSection -> Bool)
-> (NamedSection -> NamedSection -> Bool) -> Eq NamedSection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NamedSection -> NamedSection -> Bool
$c/= :: NamedSection -> NamedSection -> Bool
== :: NamedSection -> NamedSection -> Bool
$c== :: 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
min :: NamedSection -> NamedSection -> NamedSection
$cmin :: NamedSection -> NamedSection -> NamedSection
max :: NamedSection -> NamedSection -> NamedSection
$cmax :: NamedSection -> NamedSection -> NamedSection
>= :: NamedSection -> NamedSection -> Bool
$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
compare :: NamedSection -> NamedSection -> Ordering
$ccompare :: NamedSection -> NamedSection -> Ordering
$cp1Ord :: Eq 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 -> SymbolName
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 -> String
(Int -> Export -> ShowS)
-> (Export -> String) -> ([Export] -> ShowS) -> Show Export
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Export] -> ShowS
$cshowList :: [Export] -> ShowS
show :: Export -> String
$cshow :: Export -> String
showsPrec :: Int -> Export -> ShowS
$cshowsPrec :: Int -> Export -> ShowS
Show, Export -> Export -> Bool
(Export -> Export -> Bool)
-> (Export -> Export -> Bool) -> Eq Export
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Export -> Export -> Bool
$c/= :: Export -> Export -> Bool
== :: Export -> Export -> Bool
$c== :: 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
min :: Export -> Export -> Export
$cmin :: Export -> Export -> Export
max :: Export -> Export -> Export
$cmax :: Export -> Export -> Export
>= :: Export -> Export -> Bool
$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
compare :: Export -> Export -> Ordering
$ccompare :: Export -> Export -> Ordering
$cp1Ord :: Eq 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 -> String
(Int -> ExportType -> ShowS)
-> (ExportType -> String)
-> ([ExportType] -> ShowS)
-> Show ExportType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExportType] -> ShowS
$cshowList :: [ExportType] -> ShowS
show :: ExportType -> String
$cshow :: ExportType -> String
showsPrec :: Int -> ExportType -> ShowS
$cshowsPrec :: Int -> ExportType -> ShowS
Show, ExportType -> ExportType -> Bool
(ExportType -> ExportType -> Bool)
-> (ExportType -> ExportType -> Bool) -> Eq ExportType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExportType -> ExportType -> Bool
$c/= :: ExportType -> ExportType -> Bool
== :: ExportType -> ExportType -> Bool
$c== :: 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
min :: ExportType -> ExportType -> ExportType
$cmin :: ExportType -> ExportType -> ExportType
max :: ExportType -> ExportType -> ExportType
$cmax :: ExportType -> ExportType -> ExportType
>= :: ExportType -> ExportType -> Bool
$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
compare :: ExportType -> ExportType -> Ordering
$ccompare :: ExportType -> ExportType -> Ordering
$cp1Ord :: Eq 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 SymbolName 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 SymbolName
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 -> String
(Int -> ModuleFlag -> ShowS)
-> (ModuleFlag -> String)
-> ([ModuleFlag] -> ShowS)
-> Show ModuleFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleFlag] -> ShowS
$cshowList :: [ModuleFlag] -> ShowS
show :: ModuleFlag -> String
$cshow :: ModuleFlag -> String
showsPrec :: Int -> ModuleFlag -> ShowS
$cshowsPrec :: Int -> ModuleFlag -> ShowS
Show, ModuleFlag -> ModuleFlag -> Bool
(ModuleFlag -> ModuleFlag -> Bool)
-> (ModuleFlag -> ModuleFlag -> Bool) -> Eq ModuleFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleFlag -> ModuleFlag -> Bool
$c/= :: ModuleFlag -> ModuleFlag -> Bool
== :: ModuleFlag -> ModuleFlag -> Bool
$c== :: 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
min :: ModuleFlag -> ModuleFlag -> ModuleFlag
$cmin :: ModuleFlag -> ModuleFlag -> ModuleFlag
max :: ModuleFlag -> ModuleFlag -> ModuleFlag
$cmax :: ModuleFlag -> ModuleFlag -> ModuleFlag
>= :: ModuleFlag -> ModuleFlag -> Bool
$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
compare :: ModuleFlag -> ModuleFlag -> Ordering
$ccompare :: ModuleFlag -> ModuleFlag -> Ordering
$cp1Ord :: Eq 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 -> String
(Int -> BaseVersion -> ShowS)
-> (BaseVersion -> String)
-> ([BaseVersion] -> ShowS)
-> Show BaseVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BaseVersion] -> ShowS
$cshowList :: [BaseVersion] -> ShowS
show :: BaseVersion -> String
$cshow :: BaseVersion -> String
showsPrec :: Int -> BaseVersion -> ShowS
$cshowsPrec :: Int -> BaseVersion -> ShowS
Show, BaseVersion -> BaseVersion -> Bool
(BaseVersion -> BaseVersion -> Bool)
-> (BaseVersion -> BaseVersion -> Bool) -> Eq BaseVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BaseVersion -> BaseVersion -> Bool
$c/= :: BaseVersion -> BaseVersion -> Bool
== :: BaseVersion -> BaseVersion -> Bool
$c== :: 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
min :: BaseVersion -> BaseVersion -> BaseVersion
$cmin :: BaseVersion -> BaseVersion -> BaseVersion
max :: BaseVersion -> BaseVersion -> BaseVersion
$cmax :: BaseVersion -> BaseVersion -> BaseVersion
>= :: BaseVersion -> BaseVersion -> Bool
$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
compare :: BaseVersion -> BaseVersion -> Ordering
$ccompare :: BaseVersion -> BaseVersion -> Ordering
$cp1Ord :: Eq BaseVersion
Ord)

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

-- | Generate the empty module.
emptyModule :: ModulePath -> ModuleInfo
emptyModule :: ModulePath -> ModuleInfo
emptyModule m :: ModulePath
m = ModuleInfo :: ModulePath
-> Code
-> Code
-> Map SymbolName ModuleInfo
-> Deps
-> Seq Export
-> Set ModulePath
-> Deps
-> Deps
-> Set ModuleFlag
-> Map HaddockSection SymbolName
-> BaseVersion
-> ModuleInfo
ModuleInfo { modulePath :: ModulePath
modulePath = ModulePath
m
                           , moduleCode :: Code
moduleCode = Code
emptyCode
                           , bootCode :: Code
bootCode = Code
emptyCode
                           , submodules :: Map SymbolName ModuleInfo
submodules = Map SymbolName 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 SymbolName
sectionDocs = Map HaddockSection SymbolName
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 -> String
(Int -> CGError -> ShowS)
-> (CGError -> String) -> ([CGError] -> ShowS) -> Show CGError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CGError] -> ShowS
$cshowList :: [CGError] -> ShowS
show :: CGError -> String
$cshow :: CGError -> String
showsPrec :: Int -> CGError -> ShowS
$cshowsPrec :: Int -> 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 :: [CPPConditional] -> NamedTyvar -> CGState
CGState { cgsCPPConditionals :: [CPPConditional]
cgsCPPConditionals = []
                       , cgsNextAvailableTyvar :: NamedTyvar
cgsNextAvailableTyvar = Char -> NamedTyvar
SingleCharTyvar 'a'
                       }

-- | The base type for the code generator monad.
type BaseCodeGen excType a =
  ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except excType)) a

-- | The code generator monad, for generators that cannot throw
-- errors. The fact that they cannot throw errors is encoded in the
-- forall, which disallows any operation on the error, except
-- discarding it or passing it along without inspecting. This last
-- operation is useful in order to allow embedding `CodeGen`
-- computations inside `ExcCodeGen` computations, while disallowing
-- the opposite embedding without explicit error handling.
type CodeGen a = forall e. BaseCodeGen e a

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

-- | Run a `CodeGen` with given `Config` and initial state, returning
-- either the resulting exception, or the result and final module info.
runCodeGen :: BaseCodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) ->
              (Either e (a, ModuleInfo))
runCodeGen :: BaseCodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen cg :: BaseCodeGen e a
cg cfg :: CodeGenConfig
cfg state :: (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) (Except e) a
-> (CGState, ModuleInfo) -> Except e (a, (CGState, ModuleInfo))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (BaseCodeGen e a
-> CodeGenConfig -> StateT (CGState, ModuleInfo) (Except e) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT BaseCodeGen e a
cg CodeGenConfig
cfg) (CGState, ModuleInfo)
state)
  where dropCGState :: (a, (CGState, ModuleInfo)) -> (a, ModuleInfo)
        dropCGState :: (a, (CGState, ModuleInfo)) -> (a, ModuleInfo)
dropCGState (x :: a
x, (_, m :: 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 info :: ModuleInfo
info = ModuleInfo
info { moduleCode :: Code
moduleCode = Code
emptyCode, submodules :: Map SymbolName ModuleInfo
submodules = Map SymbolName 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 SymbolName
sectionDocs = Map HaddockSection SymbolName
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 :: BaseCodeGen e a -> BaseCodeGen e (a, Code)
recurseCG :: BaseCodeGen e a -> BaseCodeGen e (a, Code)
recurseCG = (CGState -> CGState) -> BaseCodeGen e a -> BaseCodeGen e (a, Code)
forall e a.
(CGState -> CGState) -> BaseCodeGen e a -> BaseCodeGen 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) -> BaseCodeGen e a
                 -> BaseCodeGen e (a, Code)
recurseWithState :: (CGState -> CGState) -> BaseCodeGen e a -> BaseCodeGen e (a, Code)
recurseWithState cgsSet :: CGState -> CGState
cgsSet cg :: BaseCodeGen e a
cg = do
  CodeGenConfig
cfg <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  (cgs :: CGState
cgs, oldInfo :: 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 BaseCodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
forall e a.
BaseCodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen BaseCodeGen e a
cg CodeGenConfig
cfg (CGState -> CGState
cgsSet CGState
cgs, ModuleInfo
info) of
     Left e :: e
e -> e -> BaseCodeGen e (a, Code)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
     Right (r :: a
r, new :: 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)) ()
-> BaseCodeGen e (a, Code) -> BaseCodeGen e (a, Code)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       (a, Code) -> BaseCodeGen e (a, Code)
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 () -> CodeGen ()
recurseWithAPIs :: Map Name API -> CodeGen () -> CodeGen ()
recurseWithAPIs apis :: Map Name API
apis cg :: CodeGen ()
cg = do
  CodeGenConfig
cfg <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  (cgs :: CGState
cgs, oldInfo :: 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 BaseCodeGen e ()
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e ((), ModuleInfo)
forall e a.
BaseCodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen BaseCodeGen e ()
CodeGen ()
cg CodeGenConfig
cfg' (CGState
cgs, ModuleInfo
info) of
    Left e :: e
e -> e -> BaseCodeGen e ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
    Right (_, new :: ModuleInfo
new) -> (CGState, ModuleInfo) -> BaseCodeGen 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 oldState :: ModuleInfo
oldState newState :: 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 SymbolName ModuleInfo
newSubmodules = (ModuleInfo -> ModuleInfo -> ModuleInfo)
-> Map SymbolName ModuleInfo
-> Map SymbolName ModuleInfo
-> Map SymbolName 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 SymbolName ModuleInfo
submodules ModuleInfo
oldState) (ModuleInfo -> Map SymbolName 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 SymbolName
newDocs = ModuleInfo -> Map HaddockSection SymbolName
sectionDocs ModuleInfo
oldState Map HaddockSection SymbolName
-> Map HaddockSection SymbolName -> Map HaddockSection SymbolName
forall a. Semigroup a => a -> a -> a
<> ModuleInfo -> Map HaddockSection SymbolName
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 SymbolName ModuleInfo
submodules = Map SymbolName 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 SymbolName
sectionDocs = Map HaddockSection SymbolName
newDocs,
                 moduleMinBase :: BaseVersion
moduleMinBase = BaseVersion
newMinBase }

-- | Merge the infos, including code too.
mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo oldInfo :: ModuleInfo
oldInfo newInfo :: 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 :: SymbolName
-> ModuleInfo -> (CGState, ModuleInfo) -> (CGState, ModuleInfo)
addSubmodule modName :: SymbolName
modName submodule :: ModuleInfo
submodule (cgs :: CGState
cgs, current :: ModuleInfo
current) =
  (CGState
cgs, ModuleInfo
current { submodules :: Map SymbolName ModuleInfo
submodules = (ModuleInfo -> ModuleInfo -> ModuleInfo)
-> SymbolName
-> ModuleInfo
-> Map SymbolName ModuleInfo
-> Map SymbolName ModuleInfo
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ModuleInfo -> ModuleInfo -> ModuleInfo
mergeInfo SymbolName
modName ModuleInfo
submodule (ModuleInfo -> Map SymbolName 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 -> BaseCodeGen e () -> BaseCodeGen e ()
submodule' :: SymbolName -> BaseCodeGen e () -> BaseCodeGen e ()
submodule' modName :: SymbolName
modName cg :: BaseCodeGen e ()
cg = do
  CodeGenConfig
cfg <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  CodeGenConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  (_, oldInfo :: 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 -> SymbolName -> ModulePath
/. SymbolName
modName)
  case BaseCodeGen e ()
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e ((), ModuleInfo)
forall e a.
BaseCodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen BaseCodeGen e ()
cg CodeGenConfig
cfg (CGState
emptyCGState, ModuleInfo
info) of
    Left e :: e
e -> e -> BaseCodeGen e ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
    Right (_, smInfo :: ModuleInfo
smInfo) -> if Code -> Bool
isCodeEmpty (ModuleInfo -> Code
moduleCode ModuleInfo
smInfo) Bool -> Bool -> Bool
&&
                            Map SymbolName ModuleInfo -> Bool
forall k a. Map k a -> Bool
M.null (ModuleInfo -> Map SymbolName ModuleInfo
submodules ModuleInfo
smInfo)
                         then () -> BaseCodeGen e ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                         else ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> BaseCodeGen e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (SymbolName
-> ModuleInfo -> (CGState, ModuleInfo) -> (CGState, ModuleInfo)
addSubmodule SymbolName
modName ModuleInfo
smInfo)

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

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

-- | Return the currently loaded set of dependencies.
getDeps :: CodeGen Deps
getDeps :: BaseCodeGen 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)
-> BaseCodeGen 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 Config
config :: BaseCodeGen e Config
config = CodeGenConfig -> Config
hConfig (CodeGenConfig -> Config)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     CodeGenConfig
-> BaseCodeGen 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 Text
currentModule :: BaseCodeGen e SymbolName
currentModule = do
  (_, s :: ModuleInfo
s) <- ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except e))
  (CGState, ModuleInfo)
forall s (m :: * -> *). MonadState s m => m s
get
  SymbolName -> BaseCodeGen e SymbolName
forall (m :: * -> *) a. Monad m => a -> m a
return (ModulePath -> SymbolName
dotWithPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
s))

-- | Return the list of APIs available to the generator.
getAPIs :: CodeGen (M.Map Name API)
getAPIs :: BaseCodeGen e (Map Name API)
getAPIs = CodeGenConfig -> Map Name API
loadedAPIs (CodeGenConfig -> Map Name API)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     CodeGenConfig
-> BaseCodeGen 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 (M.Map CRef Hyperlink)
getC2HMap :: BaseCodeGen e (Map CRef Hyperlink)
getC2HMap = CodeGenConfig -> Map CRef Hyperlink
c2hMap (CodeGenConfig -> Map CRef Hyperlink)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     CodeGenConfig
-> BaseCodeGen 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 a -> CodeGenConfig -> (CGState, ModuleInfo)
              -> (a, ModuleInfo)
unwrapCodeGen :: CodeGen a
-> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo)
unwrapCodeGen cg :: CodeGen a
cg cfg :: CodeGenConfig
cfg info :: (CGState, ModuleInfo)
info =
    case BaseCodeGen Any a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either Any (a, ModuleInfo)
forall e a.
BaseCodeGen e a
-> CodeGenConfig
-> (CGState, ModuleInfo)
-> Either e (a, ModuleInfo)
runCodeGen BaseCodeGen Any a
CodeGen a
cg CodeGenConfig
cfg (CGState, ModuleInfo)
info of
      Left _ -> String -> (a, ModuleInfo)
forall a. HasCallStack => String -> a
error "unwrapCodeGen:: The impossible happened!"
      Right (r :: a
r, newInfo :: 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 a -> (a, ModuleInfo)
evalCodeGen :: Config
-> Map Name API -> ModulePath -> CodeGen a -> (a, ModuleInfo)
evalCodeGen cfg :: Config
cfg apis :: Map Name API
apis mPath :: ModulePath
mPath cg :: CodeGen a
cg =
  let initialInfo :: ModuleInfo
initialInfo = ModulePath -> ModuleInfo
emptyModule ModulePath
mPath
      cfg' :: CodeGenConfig
cfg' = CodeGenConfig :: Config -> Map Name API -> Map CRef Hyperlink -> CodeGenConfig
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 a
-> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo)
forall a.
CodeGen a
-> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo)
unwrapCodeGen CodeGen a
cg CodeGenConfig
cfg' (CGState
emptyCGState, ModuleInfo
initialInfo)

-- | Like `evalCodeGen`, but discard the resulting output value.
genCode :: Config -> M.Map Name API ->
           ModulePath -> CodeGen () -> ModuleInfo
genCode :: Config -> Map Name API -> ModulePath -> CodeGen () -> ModuleInfo
genCode cfg :: Config
cfg apis :: Map Name API
apis mPath :: ModulePath
mPath cg :: CodeGen ()
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 () -> ((), ModuleInfo)
forall a.
Config
-> Map Name API -> ModulePath -> CodeGen a -> (a, ModuleInfo)
evalCodeGen Config
cfg Map Name API
apis ModulePath
mPath CodeGen ()
cg

-- | Mark the given dependency as used by the module.
registerNSDependency :: Text -> CodeGen ()
registerNSDependency :: SymbolName -> CodeGen ()
registerNSDependency name :: SymbolName
name = do
    Deps
deps <- BaseCodeGen e Deps
CodeGen Deps
getDeps
    Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SymbolName -> Deps -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member SymbolName
name Deps
deps) (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
$ do
        let newDeps :: Deps
newDeps = SymbolName -> Deps -> Deps
forall a. Ord a => a -> Set a -> Set a
Set.insert SymbolName
name Deps
deps
        ((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
$ \(cgs :: CGState
cgs, s :: 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 minfo :: 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 SymbolName ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (Map SymbolName ModuleInfo -> [ModuleInfo])
-> Map SymbolName ModuleInfo -> [ModuleInfo]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Map SymbolName 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 Text
qualified :: ModulePath -> Name -> CodeGen SymbolName
qualified mp :: ModulePath
mp (Name ns :: SymbolName
ns s :: SymbolName
s) = do
  Config
cfg <- BaseCodeGen e Config
CodeGen 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 -> SymbolName
modName Config
cfg SymbolName -> SymbolName -> Bool
forall a. Eq a => a -> a -> Bool
/= SymbolName
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
$
    SymbolName -> CodeGen ()
registerNSDependency SymbolName
ns
  (_, minfo :: 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 SymbolName
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) SymbolName
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolName
s
  else do
    SymbolName
qm <- ModulePath -> CodeGen SymbolName
qualifiedImport ModulePath
mp
    SymbolName
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) SymbolName
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolName
qm SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "." SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
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 Text
qualifiedImport :: ModulePath -> CodeGen SymbolName
qualifiedImport mp :: 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
$ \(cgs :: CGState
cgs, s :: 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)})
  SymbolName
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) SymbolName
forall (m :: * -> *) a. Monad m => a -> m a
return (ModulePath -> SymbolName
qualifiedModuleName ModulePath
mp)

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

-- | Return the minimal base version supported by the module and all
-- its submodules.
minBaseVersion :: ModuleInfo -> BaseVersion
minBaseVersion :: ModuleInfo -> BaseVersion
minBaseVersion minfo :: ModuleInfo
minfo =
    [BaseVersion] -> BaseVersion
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 SymbolName ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (Map SymbolName ModuleInfo -> [ModuleInfo])
-> Map SymbolName ModuleInfo -> [ModuleInfo]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Map SymbolName ModuleInfo
submodules ModuleInfo
minfo))

-- | Give a friendly textual description of the error for presenting
-- to the user.
describeCGError :: CGError -> Text
describeCGError :: CGError -> SymbolName
describeCGError (CGErrorNotImplemented e :: SymbolName
e) = "Not implemented: " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName -> SymbolName
forall a. Show a => a -> SymbolName
tshow SymbolName
e
describeCGError (CGErrorBadIntrospectionInfo e :: SymbolName
e) = "Bad introspection data: " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName -> SymbolName
forall a. Show a => a -> SymbolName
tshow SymbolName
e
describeCGError (CGErrorMissingInfo e :: SymbolName
e) = "Missing info: " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName -> SymbolName
forall a. Show a => a -> SymbolName
tshow SymbolName
e

notImplementedError :: Text -> ExcCodeGen a
notImplementedError :: SymbolName -> ExcCodeGen a
notImplementedError s :: SymbolName
s = CGError -> ExcCodeGen a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CGError -> ExcCodeGen a) -> CGError -> ExcCodeGen a
forall a b. (a -> b) -> a -> b
$ SymbolName -> CGError
CGErrorNotImplemented SymbolName
s

badIntroError :: Text -> ExcCodeGen a
badIntroError :: SymbolName -> ExcCodeGen a
badIntroError s :: SymbolName
s = CGError -> ExcCodeGen a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CGError -> ExcCodeGen a) -> CGError -> ExcCodeGen a
forall a b. (a -> b) -> a -> b
$ SymbolName -> CGError
CGErrorBadIntrospectionInfo SymbolName
s

missingInfoError :: Text -> ExcCodeGen a
missingInfoError :: SymbolName -> ExcCodeGen a
missingInfoError s :: SymbolName
s = CGError -> ExcCodeGen a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CGError -> ExcCodeGen a) -> CGError -> ExcCodeGen a
forall a b. (a -> b) -> a -> b
$ SymbolName -> CGError
CGErrorMissingInfo SymbolName
s

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

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

findAPI :: Type -> CodeGen (Maybe API)
findAPI :: Type -> CodeGen (Maybe API)
findAPI TError = 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 -> CodeGen API
findAPIByName (SymbolName -> SymbolName -> Name
Name "GLib" "Error")
findAPI (TInterface n :: 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 -> CodeGen API
findAPIByName Name
n
findAPI _ = Maybe API
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) (Maybe API)
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 :: Type -> CodeGen API
getAPI :: Type -> CodeGen API
getAPI t :: Type
t = Type -> CodeGen (Maybe API)
findAPI Type
t BaseCodeGen e (Maybe API)
-> (Maybe API
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           Just a :: API
a -> API
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall (m :: * -> *) a. Monad m => a -> m a
return API
a
           Nothing -> SymbolName
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall a. SymbolName -> a
terror ("Could not resolve type \"" SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> Type -> SymbolName
forall a. Show a => a -> SymbolName
tshow Type
t SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "\".")

findAPIByName :: Name -> CodeGen API
findAPIByName :: Name -> CodeGen API
findAPIByName n :: Name
n@(Name ns :: SymbolName
ns _) = do
    Map Name API
apis <- BaseCodeGen e (Map Name API)
CodeGen (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 -> API
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall (m :: * -> *) a. Monad m => a -> m a
return API
api
        Nothing ->
            SymbolName
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall a. SymbolName -> a
terror (SymbolName
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API)
-> SymbolName
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall a b. (a -> b) -> a -> b
$ "couldn't find API description for " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
ns SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "." SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> Name -> SymbolName
name Name
n

-- | Add some code to the current generator.
tellCode :: CodeToken -> CodeGen ()
tellCode :: CodeToken -> CodeGen ()
tellCode c :: CodeToken
c = ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(cgs :: CGState
cgs, s :: 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 ()
line :: SymbolName -> CodeGen ()
line = CodeToken -> BaseCodeGen e ()
CodeToken -> CodeGen ()
tellCode (CodeToken -> BaseCodeGen e ())
-> (SymbolName -> CodeToken) -> SymbolName -> BaseCodeGen e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolName -> CodeToken
Line

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

-- | A blank line
blank :: CodeGen ()
blank :: BaseCodeGen e ()
blank = SymbolName -> CodeGen ()
line ""

-- | Increase the indent level for code generation.
indent :: BaseCodeGen e a -> BaseCodeGen e a
indent :: BaseCodeGen e a -> BaseCodeGen e a
indent cg :: BaseCodeGen e a
cg = do
  (x :: a
x, code :: Code
code) <- BaseCodeGen e a -> BaseCodeGen e (a, Code)
forall e a. BaseCodeGen e a -> BaseCodeGen e (a, Code)
recurseCG BaseCodeGen e a
cg
  CodeToken -> CodeGen ()
tellCode (Code -> CodeToken
Indent Code
code)
  a -> BaseCodeGen 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 ()
increaseIndent :: BaseCodeGen e ()
increaseIndent = CodeToken -> CodeGen ()
tellCode CodeToken
IncreaseIndent

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

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

-- | Guard a code block with CPP code, such that it is included only
-- if the specified feature is enabled.
cppIf :: CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf :: CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPOverloading = SymbolName -> BaseCodeGen e a -> BaseCodeGen e a
forall e a. SymbolName -> BaseCodeGen e a -> BaseCodeGen e a
cppIfBlock "defined(ENABLE_OVERLOADING)"

-- | Write the given code into the .hs-boot file for the current module.
hsBoot :: BaseCodeGen e a -> BaseCodeGen e a
hsBoot :: BaseCodeGen e a -> BaseCodeGen e a
hsBoot cg :: BaseCodeGen e a
cg = do
  (x :: a
x, code :: Code
code) <- BaseCodeGen e a -> BaseCodeGen e (a, Code)
forall e a. BaseCodeGen e a -> BaseCodeGen e (a, Code)
recurseCG BaseCodeGen e a
cg
  ((CGState, ModuleInfo) -> (CGState, ModuleInfo))
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(cgs :: CGState
cgs, s :: 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 -> BaseCodeGen e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where addGuards :: [CPPConditional] -> Code -> Code
        addGuards :: [CPPConditional] -> Code -> Code
addGuards [] c :: Code
c = Code
c
        addGuards (cond :: CPPConditional
cond : conds :: [CPPConditional]
conds) c :: 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 ()
exportPartial :: ([CPPConditional] -> Export) -> CodeGen ()
exportPartial partial :: [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
$ \(cgs :: CGState
cgs, s :: 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 ()
exportModule :: SymbolName -> CodeGen ()
exportModule m :: SymbolName
m = ([CPPConditional] -> Export) -> CodeGen ()
exportPartial (ExportType -> SymbolName -> [CPPConditional] -> Export
Export ExportType
ExportModule SymbolName
m)

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

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

-- | Set the language pragmas for the current module.
setLanguagePragmas :: [Text] -> CodeGen ()
setLanguagePragmas :: [SymbolName] -> CodeGen ()
setLanguagePragmas ps :: [SymbolName]
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
$ \(cgs :: CGState
cgs, s :: ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{modulePragmas :: Deps
modulePragmas = [SymbolName] -> Deps
forall a. Ord a => [a] -> Set a
Set.fromList [SymbolName]
ps})

-- | Add a language pragma for the current module.
addLanguagePragma :: Text -> CodeGen ()
addLanguagePragma :: SymbolName -> CodeGen ()
addLanguagePragma p :: SymbolName
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
$ \(cgs :: CGState
cgs, s :: ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{modulePragmas :: Deps
modulePragmas =
                                 SymbolName -> Deps -> Deps
forall a. Ord a => a -> Set a -> Set a
Set.insert SymbolName
p (ModuleInfo -> Deps
modulePragmas ModuleInfo
s)})

-- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma).
setGHCOptions :: [Text] -> CodeGen ()
setGHCOptions :: [SymbolName] -> CodeGen ()
setGHCOptions opts :: [SymbolName]
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
$ \(cgs :: CGState
cgs, s :: ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{moduleGHCOpts :: Deps
moduleGHCOpts = [SymbolName] -> Deps
forall a. Ord a => [a] -> Set a
Set.fromList [SymbolName]
opts})

-- | Set the given flags for the module.
setModuleFlags :: [ModuleFlag] -> CodeGen ()
setModuleFlags :: [ModuleFlag] -> CodeGen ()
setModuleFlags flags :: [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
$ \(cgs :: CGState
cgs, s :: 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 ()
setModuleMinBase :: BaseVersion -> CodeGen ()
setModuleMinBase v :: 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
$ \(cgs :: CGState
cgs, s :: 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 ()
addSectionFormattedDocs :: HaddockSection -> SymbolName -> CodeGen ()
addSectionFormattedDocs section :: HaddockSection
section docs :: SymbolName
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
$ \(cgs :: CGState
cgs, s :: ModuleInfo
s) -> (CGState
cgs, ModuleInfo
s{sectionDocs :: Map HaddockSection SymbolName
sectionDocs = (SymbolName -> SymbolName -> SymbolName)
-> HaddockSection
-> SymbolName
-> Map HaddockSection SymbolName
-> Map HaddockSection SymbolName
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
(<>) HaddockSection
section
                                                 SymbolName
docs (ModuleInfo -> Map HaddockSection SymbolName
sectionDocs ModuleInfo
s)})

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

-- | Return a text representation of the `Code`.
codeToText :: Code -> Text
codeToText :: Code -> SymbolName
codeToText (Code seq :: Seq CodeToken
seq) = Text -> SymbolName
LT.toStrict (Text -> SymbolName) -> (Builder -> Text) -> Builder -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText (Builder -> SymbolName) -> Builder -> SymbolName
forall a b. (a -> b) -> a -> b
$ Int -> ViewL CodeToken -> Builder
genCode 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 _ Seq.EmptyL = Builder
forall a. Monoid a => a
mempty
        genCode n :: Int
n (Line s :: SymbolName
s :< rest :: Seq CodeToken
rest) = SymbolName -> Builder
B.fromText (Int -> SymbolName -> SymbolName
paddedLine Int
n SymbolName
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 n :: Int
n (Indent (Code seq :: Seq CodeToken
seq) :< rest :: Seq CodeToken
rest) = Int -> ViewL CodeToken -> Builder
genCode (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+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 n :: Int
n (Group (Code seq :: Seq CodeToken
seq) :< rest :: 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 n :: Int
n (CPPBlock cond :: CPPConditional
cond (Code seq :: Seq CodeToken
seq) :< rest :: Seq CodeToken
rest) =
          let (condBegin :: SymbolName
condBegin, condEnd :: SymbolName
condEnd) = CPPConditional -> (SymbolName, SymbolName)
cppCondFormat CPPConditional
cond
          in SymbolName -> Builder
B.fromText SymbolName
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
<>
             SymbolName -> Builder
B.fromText SymbolName
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 n :: Int
n (IncreaseIndent :< rest :: Seq CodeToken
rest) = Int -> ViewL CodeToken -> Builder
genCode (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Seq CodeToken -> ViewL CodeToken
forall a. Seq a -> ViewL a
viewl Seq CodeToken
rest)

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

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

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

-- | Format the list of exported modules.
formatExportedModules :: [Export] -> Maybe Text
formatExportedModules :: [Export] -> Maybe SymbolName
formatExportedModules [] = Maybe SymbolName
forall a. Maybe a
Nothing
formatExportedModules exports :: [Export]
exports =
    SymbolName -> Maybe SymbolName
forall a. a -> Maybe a
Just (SymbolName -> Maybe SymbolName)
-> ([Export] -> SymbolName) -> [Export] -> Maybe SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolName] -> SymbolName
T.concat ([SymbolName] -> SymbolName)
-> ([Export] -> [SymbolName]) -> [Export] -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> SymbolName) -> [Export] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ((Export -> SymbolName) -> Export -> SymbolName
formatExport (("module " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<>) (SymbolName -> SymbolName)
-> (Export -> SymbolName) -> Export -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Export -> SymbolName
exportSymbol))
          ([Export] -> [SymbolName])
-> ([Export] -> [Export]) -> [Export] -> [SymbolName]
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 SymbolName) -> [Export] -> Maybe SymbolName
forall a b. (a -> b) -> a -> b
$ [Export]
exports

-- | Format the toplevel exported symbols.
formatToplevel :: [Export] -> Maybe Text
formatToplevel :: [Export] -> Maybe SymbolName
formatToplevel [] = Maybe SymbolName
forall a. Maybe a
Nothing
formatToplevel exports :: [Export]
exports =
    SymbolName -> Maybe SymbolName
forall a. a -> Maybe a
Just (SymbolName -> Maybe SymbolName)
-> ([Export] -> SymbolName) -> [Export] -> Maybe SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolName] -> SymbolName
T.concat ([SymbolName] -> SymbolName)
-> ([Export] -> [SymbolName]) -> [Export] -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> SymbolName) -> [Export] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ((Export -> SymbolName) -> Export -> SymbolName
formatExport Export -> SymbolName
exportSymbol)
         ([Export] -> [SymbolName])
-> ([Export] -> [Export]) -> [Export] -> [SymbolName]
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 SymbolName) -> [Export] -> Maybe SymbolName
forall a b. (a -> b) -> a -> b
$ [Export]
exports

-- | Format the type declarations section.
formatTypeDecls :: [Export] -> Maybe Text
formatTypeDecls :: [Export] -> Maybe SymbolName
formatTypeDecls exports :: [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 SymbolName
forall a. Maybe a
Nothing
       else SymbolName -> Maybe SymbolName
forall a. a -> Maybe a
Just (SymbolName -> Maybe SymbolName)
-> ([SymbolName] -> SymbolName) -> [SymbolName] -> Maybe SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolName] -> SymbolName
T.unlines ([SymbolName] -> Maybe SymbolName)
-> [SymbolName] -> Maybe SymbolName
forall a b. (a -> b) -> a -> b
$ [ "-- * Exported types"
                               , [SymbolName] -> SymbolName
T.concat ([SymbolName] -> SymbolName)
-> ([Export] -> [SymbolName]) -> [Export] -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> SymbolName) -> [Export] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ( (Export -> SymbolName) -> Export -> SymbolName
formatExport Export -> SymbolName
exportSymbol )
                                      ([Export] -> SymbolName) -> [Export] -> SymbolName
forall a b. (a -> b) -> a -> b
$ [Export]
exportedTypes ]

-- | A subsection name, with an optional anchor name.
data Subsection = Subsection { Subsection -> SymbolName
subsectionTitle  :: Text
                             , Subsection -> Maybe SymbolName
subsectionAnchor :: Maybe Text
                             , Subsection -> Maybe SymbolName
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
/= :: Subsection -> Subsection -> Bool
$c/= :: Subsection -> Subsection -> Bool
== :: Subsection -> Subsection -> Bool
$c== :: Subsection -> Subsection -> Bool
Eq, Int -> Subsection -> ShowS
[Subsection] -> ShowS
Subsection -> String
(Int -> Subsection -> ShowS)
-> (Subsection -> String)
-> ([Subsection] -> ShowS)
-> Show Subsection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Subsection] -> ShowS
$cshowList :: [Subsection] -> ShowS
show :: Subsection -> String
$cshow :: Subsection -> String
showsPrec :: Int -> Subsection -> ShowS
$cshowsPrec :: Int -> 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
min :: Subsection -> Subsection -> Subsection
$cmin :: Subsection -> Subsection -> Subsection
max :: Subsection -> Subsection -> Subsection
$cmax :: Subsection -> Subsection -> Subsection
>= :: Subsection -> Subsection -> Bool
$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
compare :: Subsection -> Subsection -> Ordering
$ccompare :: Subsection -> Subsection -> Ordering
$cp1Ord :: Eq 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 -> SymbolName -> Maybe SymbolName -> Subsection
subsecWithPrefix mainSection :: NamedSection
mainSection title :: SymbolName
title doc :: Maybe SymbolName
doc =
  Subsection :: SymbolName -> Maybe SymbolName -> Maybe SymbolName -> Subsection
Subsection { subsectionTitle :: SymbolName
subsectionTitle = SymbolName
title
             , subsectionAnchor :: Maybe SymbolName
subsectionAnchor = SymbolName -> Maybe SymbolName
forall a. a -> Maybe a
Just (SymbolName
prefix SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> ":" SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
title)
             , subsectionDoc :: Maybe SymbolName
subsectionDoc = Maybe SymbolName
doc }
  where prefix :: SymbolName
prefix = case NamedSection
mainSection of
          MethodSection -> "method"
          PropertySection -> "attr"
          SignalSection -> "signal"
          EnumSection -> "enum"
          FlagSection -> "flag"

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

-- | Format a given section made of subsections.
formatSection :: NamedSection -> [(Subsection, Export)] -> Maybe Text
formatSection :: NamedSection -> [(Subsection, Export)] -> Maybe SymbolName
formatSection section :: NamedSection
section exports :: [(Subsection, Export)]
exports =
    if [(Subsection, Export)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Subsection, Export)]
exports
    then Maybe SymbolName
forall a. Maybe a
Nothing
    else SymbolName -> Maybe SymbolName
forall a. a -> Maybe a
Just (SymbolName -> Maybe SymbolName)
-> ([SymbolName] -> SymbolName) -> [SymbolName] -> Maybe SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolName] -> SymbolName
T.unlines ([SymbolName] -> Maybe SymbolName)
-> [SymbolName] -> Maybe SymbolName
forall a b. (a -> b) -> a -> b
$ [" -- * " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> NamedSection -> SymbolName
mainSectionName NamedSection
section
                            , ( [SymbolName] -> SymbolName
T.unlines
                              ([SymbolName] -> SymbolName)
-> (Map Subsection (Set Export) -> [SymbolName])
-> Map Subsection (Set Export)
-> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Subsection, Set Export) -> SymbolName)
-> [(Subsection, Set Export)] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map (Subsection, Set Export) -> SymbolName
formatSubsection
                              ([(Subsection, Set Export)] -> [SymbolName])
-> (Map Subsection (Set Export) -> [(Subsection, Set Export)])
-> Map Subsection (Set Export)
-> [SymbolName]
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 (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)]
exports

      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 (subsec :: Subsection
subsec, m :: Export
m) secs :: 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) -> SymbolName
formatSubsection (subsec :: Subsection
subsec, symbols :: Set Export
symbols) =
          [SymbolName] -> SymbolName
T.unlines [ "-- ** " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> case Subsection -> Maybe SymbolName
subsectionAnchor Subsection
subsec of
                                    Just anchor :: SymbolName
anchor -> Subsection -> SymbolName
subsectionTitle Subsection
subsec SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<>
                                                   " #" SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
anchor SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "#"
                                    Nothing -> Subsection -> SymbolName
subsectionTitle Subsection
subsec
                    , case Subsection -> Maybe SymbolName
subsectionDoc Subsection
subsec of
                        Just text :: SymbolName
text -> SymbolName -> SymbolName
formatHaddockComment SymbolName
text
                        Nothing -> ""
                    , ( [SymbolName] -> SymbolName
T.concat
                      ([SymbolName] -> SymbolName)
-> (Set Export -> [SymbolName]) -> Set Export -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Export -> SymbolName) -> [Export] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ((Export -> SymbolName) -> Export -> SymbolName
formatExport Export -> SymbolName
exportSymbol)
                      ([Export] -> [SymbolName])
-> (Set Export -> [Export]) -> Set Export -> [SymbolName]
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 SymbolName -> [Export] -> [Maybe SymbolName]
formatSubsectionExports docs :: Map HaddockSection SymbolName
docs exports :: [Export]
exports = ((NamedSection, [(Subsection, Export)]) -> Maybe SymbolName)
-> [(NamedSection, [(Subsection, Export)])] -> [Maybe SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedSection -> [(Subsection, Export)] -> Maybe SymbolName)
-> (NamedSection, [(Subsection, Export)]) -> Maybe SymbolName
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NamedSection -> [(Subsection, Export)] -> Maybe SymbolName
formatSection)
                                       (Map NamedSection [(Subsection, Export)]
-> [(NamedSection, [(Subsection, Export)])]
forall k a. Map k a -> [(k, a)]
M.toAscList Map NamedSection [(Subsection, Export)]
collectedExports)
  where collectedExports :: M.Map NamedSection [(Subsection, Export)]
        collectedExports :: Map NamedSection [(Subsection, Export)]
collectedExports = (Map NamedSection [(Subsection, Export)]
 -> Export -> Map NamedSection [(Subsection, Export)])
-> Map NamedSection [(Subsection, Export)]
-> [Export]
-> Map NamedSection [(Subsection, Export)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map NamedSection [(Subsection, Export)]
-> Export -> Map NamedSection [(Subsection, Export)]
classifyExport Map NamedSection [(Subsection, Export)]
forall k a. Map k a
M.empty [Export]
exports

        classifyExport :: M.Map NamedSection [(Subsection, Export)] ->
                          Export -> M.Map NamedSection [(Subsection, Export)]
        classifyExport :: Map NamedSection [(Subsection, Export)]
-> Export -> Map NamedSection [(Subsection, Export)]
classifyExport m :: Map NamedSection [(Subsection, Export)]
m export :: Export
export =
          case Export -> ExportType
exportType Export
export of
            ExportSymbol hs :: HaddockSection
hs@(NamedSubsection ms :: NamedSection
ms n :: SymbolName
n) ->
              let subsec :: Subsection
subsec = NamedSection -> SymbolName -> Maybe SymbolName -> Subsection
subsecWithPrefix NamedSection
ms SymbolName
n (HaddockSection -> Map HaddockSection SymbolName -> Maybe SymbolName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HaddockSection
hs Map HaddockSection SymbolName
docs)
              in ([(Subsection, Export)]
 -> [(Subsection, Export)] -> [(Subsection, Export)])
-> NamedSection
-> [(Subsection, Export)]
-> Map NamedSection [(Subsection, Export)]
-> Map NamedSection [(Subsection, Export)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith [(Subsection, Export)]
-> [(Subsection, Export)] -> [(Subsection, Export)]
forall a. [a] -> [a] -> [a]
(++) NamedSection
ms [(Subsection
subsec, Export
export)] Map NamedSection [(Subsection, Export)]
m
            _ -> Map NamedSection [(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 SymbolName -> [Export] -> SymbolName
formatExportList docs :: Map HaddockSection SymbolName
docs exports :: [Export]
exports =
    [SymbolName] -> SymbolName
T.unlines ([SymbolName] -> SymbolName)
-> ([Maybe SymbolName] -> [SymbolName])
-> [Maybe SymbolName]
-> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe SymbolName] -> [SymbolName]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SymbolName] -> SymbolName)
-> [Maybe SymbolName] -> SymbolName
forall a b. (a -> b) -> a -> b
$ [Export] -> Maybe SymbolName
formatExportedModules [Export]
exports
                            Maybe SymbolName -> [Maybe SymbolName] -> [Maybe SymbolName]
forall a. a -> [a] -> [a]
: [Export] -> Maybe SymbolName
formatToplevel [Export]
exports
                            Maybe SymbolName -> [Maybe SymbolName] -> [Maybe SymbolName]
forall a. a -> [a] -> [a]
: [Export] -> Maybe SymbolName
formatTypeDecls [Export]
exports
                            Maybe SymbolName -> [Maybe SymbolName] -> [Maybe SymbolName]
forall a. a -> [a] -> [a]
: Map HaddockSection SymbolName -> [Export] -> [Maybe SymbolName]
formatSubsectionExports Map HaddockSection SymbolName
docs [Export]
exports

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

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

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

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

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

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

-- | Generic module prelude. We reexport all of the submodules.
modulePrelude :: M.Map HaddockSection Text -> Text -> [Export] -> [Text] -> Text
modulePrelude :: Map HaddockSection SymbolName
-> SymbolName -> [Export] -> [SymbolName] -> SymbolName
modulePrelude _ name :: SymbolName
name [] [] = "module " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
name SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> " () where\n"
modulePrelude docs :: Map HaddockSection SymbolName
docs name :: SymbolName
name exports :: [Export]
exports [] =
    "module " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
name SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "\n    ( "
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection SymbolName -> [Export] -> SymbolName
formatExportList Map HaddockSection SymbolName
docs [Export]
exports
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "    ) where\n"
modulePrelude docs :: Map HaddockSection SymbolName
docs name :: SymbolName
name [] reexportedModules :: [SymbolName]
reexportedModules =
    "module " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
name SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "\n    ( "
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection SymbolName -> [Export] -> SymbolName
formatExportList Map HaddockSection SymbolName
docs ((SymbolName -> Export) -> [SymbolName] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (\m :: SymbolName
m -> ExportType -> SymbolName -> [CPPConditional] -> Export
Export ExportType
ExportModule SymbolName
m []) [SymbolName]
reexportedModules)
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "    ) where\n\n"
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> [SymbolName] -> SymbolName
T.unlines ((SymbolName -> SymbolName) -> [SymbolName] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ("import " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<>) [SymbolName]
reexportedModules)
modulePrelude docs :: Map HaddockSection SymbolName
docs name :: SymbolName
name exports :: [Export]
exports reexportedModules :: [SymbolName]
reexportedModules =
    "module " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
name SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "\n    ( "
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection SymbolName -> [Export] -> SymbolName
formatExportList Map HaddockSection SymbolName
docs ((SymbolName -> Export) -> [SymbolName] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (\m :: SymbolName
m -> ExportType -> SymbolName -> [CPPConditional] -> Export
Export ExportType
ExportModule SymbolName
m []) [SymbolName]
reexportedModules)
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "\n"
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> Map HaddockSection SymbolName -> [Export] -> SymbolName
formatExportList Map HaddockSection SymbolName
docs [Export]
exports
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> "    ) where\n\n"
    SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> [SymbolName] -> SymbolName
T.unlines ((SymbolName -> SymbolName) -> [SymbolName] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ("import " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<>) [SymbolName]
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] -> SymbolName
importDeps _ [] = ""
importDeps (ModulePath prefix :: [SymbolName]
prefix) deps :: [ModulePath]
deps = [SymbolName] -> SymbolName
T.unlines ([SymbolName] -> SymbolName)
-> ([ModulePath] -> [SymbolName]) -> [ModulePath] -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModulePath -> SymbolName) -> [ModulePath] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ModulePath -> SymbolName
toImport ([ModulePath] -> SymbolName) -> [ModulePath] -> SymbolName
forall a b. (a -> b) -> a -> b
$ [ModulePath]
deps
    where toImport :: ModulePath -> Text
          toImport :: ModulePath -> SymbolName
toImport dep :: ModulePath
dep = let impSt :: SymbolName
impSt = if ModulePath -> Bool
importSource ModulePath
dep
                                     then "import {-# SOURCE #-} qualified "
                                     else "import qualified "
                         in SymbolName
impSt SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> ModulePath -> SymbolName
dotWithPrefix ModulePath
dep SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<>
                                " as " SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> ModulePath -> SymbolName
qualifiedModuleName ModulePath
dep
          importSource :: ModulePath -> Bool
          importSource :: ModulePath -> Bool
importSource (ModulePath [_, "Callbacks"]) = Bool
False
          importSource (ModulePath mp :: [SymbolName]
mp) = Int -> [SymbolName] -> [SymbolName]
forall a. Int -> [a] -> [a]
take ([SymbolName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SymbolName]
prefix) [SymbolName]
mp [SymbolName] -> [SymbolName] -> Bool
forall a. Eq a => a -> a -> Bool
== [SymbolName]
prefix

-- | Standard imports.
moduleImports :: Text
moduleImports :: SymbolName
moduleImports = [SymbolName] -> SymbolName
T.unlines [
                 "import Data.GI.Base.ShortPrelude"
                , "import qualified Data.GI.Base.ShortPrelude as SP"
                , "import qualified Data.GI.Base.Overloading as O"
                , "import qualified Prelude as P"
                , ""
                , "import qualified Data.GI.Base.Attributes as GI.Attributes"
                , "import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr"
                , "import qualified Data.GI.Base.GClosure as B.GClosure"
                , "import qualified Data.GI.Base.GError as B.GError"
                , "import qualified Data.GI.Base.GVariant as B.GVariant"
                , "import qualified Data.GI.Base.GValue as B.GValue"
                , "import qualified Data.GI.Base.GParamSpec as B.GParamSpec"
                , "import qualified Data.GI.Base.CallStack as B.CallStack"
                , "import qualified Data.GI.Base.Properties as B.Properties"
                , "import qualified Data.GI.Base.Signals as B.Signals"
                , "import qualified Data.Text as T"
                , "import qualified Data.ByteString.Char8 as B"
                , "import qualified Data.Map as Map"
                , "import qualified Foreign.Ptr as FP"
                , "import qualified GHC.OverloadedLabels as OL" ]

-- | Like `dotModulePath`, but add a "GI." prefix.
dotWithPrefix :: ModulePath -> Text
dotWithPrefix :: ModulePath -> SymbolName
dotWithPrefix mp :: ModulePath
mp = ModulePath -> SymbolName
dotModulePath ("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 String -> ModuleInfo -> IO ()
writeModuleInfo verbose :: Bool
verbose dirPrefix :: Maybe String
dirPrefix minfo :: ModuleInfo
minfo = do
  let submodulePaths :: [ModulePath]
submodulePaths = (ModuleInfo -> ModulePath) -> [ModuleInfo] -> [ModulePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleInfo -> ModulePath
modulePath) (Map SymbolName ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (ModuleInfo -> Map SymbolName ModuleInfo
submodules ModuleInfo
minfo))
      -- We reexport any submodules.
      submoduleExports :: [SymbolName]
submoduleExports = (ModulePath -> SymbolName) -> [ModulePath] -> [SymbolName]
forall a b. (a -> b) -> [a] -> [b]
map ModulePath -> SymbolName
dotWithPrefix [ModulePath]
submodulePaths
      fname :: String
fname = Maybe String -> ModulePath -> ShowS
modulePathToFilePath Maybe String
dirPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo) ".hs"
      dirname :: String
dirname = ShowS
takeDirectory String
fname
      code :: SymbolName
code = Code -> SymbolName
codeToText (ModuleInfo -> Code
moduleCode ModuleInfo
minfo)
      pragmas :: SymbolName
pragmas = [SymbolName] -> SymbolName
languagePragmas (Deps -> [SymbolName]
forall a. Set a -> [a]
Set.toList (Deps -> [SymbolName]) -> Deps -> [SymbolName]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Deps
modulePragmas ModuleInfo
minfo)
      optionsGHC :: SymbolName
optionsGHC = [SymbolName] -> SymbolName
ghcOptions (Deps -> [SymbolName]
forall a. Set a -> [a]
Set.toList (Deps -> [SymbolName]) -> Deps -> [SymbolName]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Deps
moduleGHCOpts ModuleInfo
minfo)
      prelude :: SymbolName
prelude = Map HaddockSection SymbolName
-> SymbolName -> [Export] -> [SymbolName] -> SymbolName
modulePrelude (ModuleInfo -> Map HaddockSection SymbolName
sectionDocs ModuleInfo
minfo)
                (ModulePath -> SymbolName
dotWithPrefix (ModulePath -> SymbolName) -> ModulePath -> SymbolName
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo)
                (Seq Export -> [Export]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (ModuleInfo -> Seq Export
moduleExports ModuleInfo
minfo))
                [SymbolName]
submoduleExports
      imports :: SymbolName
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 ""
                else SymbolName
moduleImports
      pkgRoot :: ModulePath
pkgRoot = [SymbolName] -> ModulePath
ModulePath (Int -> [SymbolName] -> [SymbolName]
forall a. Int -> [a] -> [a]
take 1 (ModulePath -> [SymbolName]
modulePathToList (ModulePath -> [SymbolName]) -> ModulePath -> [SymbolName]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo))
      deps :: SymbolName
deps = ModulePath -> [ModulePath] -> SymbolName
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 :: SymbolName
haddock = Maybe SymbolName -> SymbolName
moduleHaddock (HaddockSection -> Map HaddockSection SymbolName -> Maybe SymbolName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HaddockSection
ToplevelSection (ModuleInfo -> Map HaddockSection SymbolName
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
$ String -> IO ()
putStrLn ((SymbolName -> String
T.unpack (SymbolName -> String)
-> (ModuleInfo -> SymbolName) -> ModuleInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModulePath -> SymbolName
dotWithPrefix (ModulePath -> SymbolName)
-> (ModuleInfo -> ModulePath) -> ModuleInfo -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleInfo -> ModulePath
modulePath) ModuleInfo
minfo
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ " -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname)
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dirname
  String -> SymbolName -> IO ()
utf8WriteFile String
fname ([SymbolName] -> SymbolName
T.unlines [SymbolName
pragmas, SymbolName
optionsGHC, SymbolName
haddock, SymbolName
cppMacros,
                                 SymbolName
prelude, SymbolName
imports, SymbolName
deps, SymbolName
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 :: String
bootFName = Maybe String -> ModulePath -> ShowS
modulePathToFilePath Maybe String
dirPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo) ".hs-boot"
    String -> SymbolName -> IO ()
utf8WriteFile String
bootFName (ModuleInfo -> SymbolName
genHsBoot ModuleInfo
minfo)

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

-- | Construct the filename corresponding to the given module.
modulePathToFilePath :: Maybe FilePath -> ModulePath -> FilePath -> FilePath
modulePathToFilePath :: Maybe String -> ModulePath -> ShowS
modulePathToFilePath dirPrefix :: Maybe String
dirPrefix (ModulePath mp :: [SymbolName]
mp) ext :: String
ext =
    [String] -> String
joinPath (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
dirPrefix String -> [String] -> [String]
forall a. a -> [a] -> [a]
: "GI" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (SymbolName -> String) -> [SymbolName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolName -> String
T.unpack [SymbolName]
mp) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 String -> ModuleInfo -> IO [SymbolName]
writeModuleTree verbose :: Bool
verbose dirPrefix :: Maybe String
dirPrefix minfo :: ModuleInfo
minfo = do
  [SymbolName]
submodulePaths <- [[SymbolName]] -> [SymbolName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SymbolName]] -> [SymbolName])
-> IO [[SymbolName]] -> IO [SymbolName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleInfo]
-> (ModuleInfo -> IO [SymbolName]) -> IO [[SymbolName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map SymbolName ModuleInfo -> [ModuleInfo]
forall k a. Map k a -> [a]
M.elems (ModuleInfo -> Map SymbolName ModuleInfo
submodules ModuleInfo
minfo))
                                    (Bool -> Maybe String -> ModuleInfo -> IO [SymbolName]
writeModuleTree Bool
verbose Maybe String
dirPrefix)
  Bool -> Maybe String -> ModuleInfo -> IO ()
writeModuleInfo Bool
verbose Maybe String
dirPrefix ModuleInfo
minfo
  [SymbolName] -> IO [SymbolName]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SymbolName] -> IO [SymbolName])
-> [SymbolName] -> IO [SymbolName]
forall a b. (a -> b) -> a -> b
$ (ModulePath -> SymbolName
dotWithPrefix (ModuleInfo -> ModulePath
modulePath ModuleInfo
minfo) SymbolName -> [SymbolName] -> [SymbolName]
forall a. a -> [a] -> [a]
: [SymbolName]
submodulePaths)

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