-- This file is part of Hoppy.
--
-- Copyright 2015-2021 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP #-}

-- | Shared portion of the Haskell code generator.  Usable by binding
-- definitions.
module Foreign.Hoppy.Generator.Language.Haskell (
  Managed (..),
  getModuleName,
  toModuleName,
  -- * Code generators
  Partial (..),
  Output (..),
  Generator,
  runGenerator,
  evalGenerator,
  execGenerator,
  renderPartial,
  Env (..),
  askInterface,
  askComputedInterfaceData,
  askModule,
  askModuleName,
  getModuleForExtName,
  withErrorContext,
  inFunction,
  -- * Exports
  HsExport,
  addExport,
  addExport',
  addExports,
  -- * Imports
  addImports,
  -- * Language extensions
  addExtension,
  -- * Code generation
  SayExportMode (..),
  sayLn,
  saysLn,
  ln,
  indent,
  indentSpaces,
  sayLet,
  getExtNameModule,
  addExtNameModule,
  toHsTypeName,
  toHsTypeName',
  toHsFnName,
  toHsFnName',
  toArgName,
  HsTypeSide (..),
  cppTypeToHsTypeAndUse,
  getClassHaskellConversion,
  getEffectiveExceptionHandlers,
  prettyPrint,
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Arrow (first)
import Control.Monad.Except (Except, catchError, runExcept, throwError)
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Writer (WriterT, censor, runWriterT, tell)
import Data.Char (toUpper)
import Data.Foldable (forM_)
import Data.Function (on)
import Data.List (intercalate, intersperse)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid, mappend, mconcat, mempty)
#endif
import Data.Semigroup as Sem
import qualified Data.Set as S
import Data.Tuple (swap)
import Foreign.Hoppy.Generator.Common
import Foreign.Hoppy.Generator.Spec.Base
import Foreign.Hoppy.Generator.Spec.Computed (ComputedInterfaceData)
import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Class (
  Class,
  ClassHaskellConversion,
  classConversion,
  classExtName,
  classHaskellConversion,
  classHaskellConversionType,
  )
import Foreign.Hoppy.Generator.Types (constT, objT, ptrT)
import qualified Language.Haskell.Pretty as P
import Language.Haskell.Syntax (
  HsName (HsIdent),
  HsQName (Special, UnQual),
  HsSpecialCon (HsUnitCon),
  HsType (HsTyApp, HsTyCon, HsTyFun),
  )

-- | Indicates who is managing the lifetime of an object via an object pointer.
data Managed =
    Unmanaged
    -- ^ The object's lifetime is being managed manually.
  | Managed
    -- ^ The object's lifetime is being managed by the Haskell garbage
    -- collector.
  deriving (Managed
Managed -> Managed -> Bounded Managed
forall a. a -> a -> Bounded a
maxBound :: Managed
$cmaxBound :: Managed
minBound :: Managed
$cminBound :: Managed
Bounded, Int -> Managed
Managed -> Int
Managed -> [Managed]
Managed -> Managed
Managed -> Managed -> [Managed]
Managed -> Managed -> Managed -> [Managed]
(Managed -> Managed)
-> (Managed -> Managed)
-> (Int -> Managed)
-> (Managed -> Int)
-> (Managed -> [Managed])
-> (Managed -> Managed -> [Managed])
-> (Managed -> Managed -> [Managed])
-> (Managed -> Managed -> Managed -> [Managed])
-> Enum Managed
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Managed -> Managed -> Managed -> [Managed]
$cenumFromThenTo :: Managed -> Managed -> Managed -> [Managed]
enumFromTo :: Managed -> Managed -> [Managed]
$cenumFromTo :: Managed -> Managed -> [Managed]
enumFromThen :: Managed -> Managed -> [Managed]
$cenumFromThen :: Managed -> Managed -> [Managed]
enumFrom :: Managed -> [Managed]
$cenumFrom :: Managed -> [Managed]
fromEnum :: Managed -> Int
$cfromEnum :: Managed -> Int
toEnum :: Int -> Managed
$ctoEnum :: Int -> Managed
pred :: Managed -> Managed
$cpred :: Managed -> Managed
succ :: Managed -> Managed
$csucc :: Managed -> Managed
Enum, Managed -> Managed -> Bool
(Managed -> Managed -> Bool)
-> (Managed -> Managed -> Bool) -> Eq Managed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Managed -> Managed -> Bool
$c/= :: Managed -> Managed -> Bool
== :: Managed -> Managed -> Bool
$c== :: Managed -> Managed -> Bool
Eq, Eq Managed
Eq Managed
-> (Managed -> Managed -> Ordering)
-> (Managed -> Managed -> Bool)
-> (Managed -> Managed -> Bool)
-> (Managed -> Managed -> Bool)
-> (Managed -> Managed -> Bool)
-> (Managed -> Managed -> Managed)
-> (Managed -> Managed -> Managed)
-> Ord Managed
Managed -> Managed -> Bool
Managed -> Managed -> Ordering
Managed -> Managed -> Managed
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 :: Managed -> Managed -> Managed
$cmin :: Managed -> Managed -> Managed
max :: Managed -> Managed -> Managed
$cmax :: Managed -> Managed -> Managed
>= :: Managed -> Managed -> Bool
$c>= :: Managed -> Managed -> Bool
> :: Managed -> Managed -> Bool
$c> :: Managed -> Managed -> Bool
<= :: Managed -> Managed -> Bool
$c<= :: Managed -> Managed -> Bool
< :: Managed -> Managed -> Bool
$c< :: Managed -> Managed -> Bool
compare :: Managed -> Managed -> Ordering
$ccompare :: Managed -> Managed -> Ordering
$cp1Ord :: Eq Managed
Ord)

-- | Returns the complete Haskell module name for a 'Module' in an 'Interface',
-- taking into account the 'interfaceHaskellModuleBase' and the
-- 'moduleHaskellName'.
getModuleName :: Interface -> Module -> String
getModuleName :: Interface -> Module -> String
getModuleName Interface
iface Module
m =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  Interface -> [String]
interfaceHaskellModuleBase Interface
iface [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [String -> String
toModuleName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Module -> String
moduleName Module
m] (Module -> Maybe [String]
moduleHaskellName Module
m)

-- | Performs case conversions on the given string to ensure that it is a valid
-- component of a Haskell module name.
toModuleName :: String -> String
toModuleName :: String -> String
toModuleName (Char
x:String
xs) = Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
toModuleName String
"" = String
""

-- | Renders a set of imports in Haskell syntax on multiple lines.
renderImports :: HsImportSet -> [String]
renderImports :: HsImportSet -> [String]
renderImports = ((HsImportKey, HsImportSpecs) -> String)
-> [(HsImportKey, HsImportSpecs)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (HsImportKey, HsImportSpecs) -> String
renderModuleImport ([(HsImportKey, HsImportSpecs)] -> [String])
-> (HsImportSet -> [(HsImportKey, HsImportSpecs)])
-> HsImportSet
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map HsImportKey HsImportSpecs -> [(HsImportKey, HsImportSpecs)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map HsImportKey HsImportSpecs -> [(HsImportKey, HsImportSpecs)])
-> (HsImportSet -> Map HsImportKey HsImportSpecs)
-> HsImportSet
-> [(HsImportKey, HsImportSpecs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsImportSet -> Map HsImportKey HsImportSpecs
getHsImportSet
  where -- | Renders an import as a string that contains one or more lines.
        renderModuleImport :: (HsImportKey, HsImportSpecs) -> String
        renderModuleImport :: (HsImportKey, HsImportSpecs) -> String
renderModuleImport (HsImportKey
key, HsImportSpecs
specs) =
          let modName :: String
modName = HsImportKey -> String
hsImportModule HsImportKey
key
              maybeQualifiedName :: Maybe String
maybeQualifiedName = HsImportKey -> Maybe String
hsImportQualifiedName HsImportKey
key
              isQual :: Bool
isQual = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
maybeQualifiedName
              importPrefix :: String
importPrefix = if HsImportSpecs -> Bool
hsImportSource HsImportSpecs
specs
                             then String
"import {-# SOURCE #-} "
                             else String
"import "
              importQualifiedPrefix :: String
importQualifiedPrefix =
                if HsImportSpecs -> Bool
hsImportSource HsImportSpecs
specs
                then String
"import {-# SOURCE #-} qualified "
                else String
"import qualified "
          in case HsImportSpecs -> Maybe (Map String HsImportVal)
getHsImportSpecs HsImportSpecs
specs of
            Maybe (Map String HsImportVal)
Nothing -> case Maybe String
maybeQualifiedName of
              Maybe String
Nothing -> String
importPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modName
              Just String
qualifiedName ->
                [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
importQualifiedPrefix, String
modName, String
" as ", String
qualifiedName]
            Just Map String HsImportVal
specMap ->
              let specWords :: [String]
                  specWords :: [String]
specWords = [[String]] -> [String]
concatWithCommas ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, HsImportVal) -> [String])
-> [(String, HsImportVal)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String, HsImportVal) -> [String]
renderSpecAsWords ([(String, HsImportVal)] -> [[String]])
-> [(String, HsImportVal)] -> [[String]]
forall a b. (a -> b) -> a -> b
$ Map String HsImportVal -> [(String, HsImportVal)]
forall k a. Map k a -> [(k, a)]
M.assocs Map String HsImportVal
specMap
                  singleLineImport :: String
                  singleLineImport :: String
singleLineImport =
                    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                    (if Bool
isQual then String
importQualifiedPrefix else String
importPrefix) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                    String
modName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
" (" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" " [String]
specWords [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                    case Maybe String
maybeQualifiedName of
                      Maybe String
Nothing -> [String
")"]
                      Just String
qualifiedName -> [String
") as ", String
qualifiedName]
              in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
maxLineLength String
singleLineImport
                 then String
singleLineImport
                 else String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                      (String
importPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                      [String] -> [String]
groupWordsIntoLines [String]
specWords [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                      case Maybe String
maybeQualifiedName of
                        Maybe String
Nothing -> [String
"  )"]
                        Just String
qualifiedName -> [String
"  ) as " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
qualifiedName]

        -- | Takes an import spec, and returns a list of words that comprise
        -- that spec.  Line breaking may be performed by the caller only between
        -- these words.
        renderSpecAsWords :: (HsImportName, HsImportVal) -> [String]
        renderSpecAsWords :: (String, HsImportVal) -> [String]
renderSpecAsWords (String
name, HsImportVal
val) = case HsImportVal
val of
          HsImportVal
HsImportVal -> [String
name]
          -- When we export specific subnames under a name, then we put a
          -- non-breaking space between the outer name and the first inner name,
          -- just for a little readability.
          HsImportValSome [String]
parts -> case [String]
parts of
            [] -> [String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ()"]
            [String
part] -> [[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
name, String
" (", String
part, String
")"]]
            String
part0:[String]
parts' -> let ([String]
parts'', [String
partN]) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parts' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [String]
parts'
                           in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
name, String
" (", String
part0, String
","] String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                              (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",") [String]
parts'' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                              [String
partN String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"]
          HsImportVal
HsImportValAll -> [String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (..)"]

        -- | Takes a list of list of words.  Concatenates to get a list of
        -- words, appending a comma to the final word in each list of words.
        concatWithCommas :: [[String]] -> [String]
        concatWithCommas :: [[String]] -> [String]
concatWithCommas [] = []
        concatWithCommas [[String]]
ss =
          let ([[String]]
ss', ssLast :: [[String]]
ssLast@[[String]
_]) = Int -> [[String]] -> ([[String]], [[String]])
forall a. Int -> [a] -> ([a], [a])
splitAt ([[String]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[String]]
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [[String]]
ss
          in [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
onLast (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",")) [[String]]
ss' [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [[String]]
ssLast

        -- | Applies a function to the final element of a list, if the list is
        -- nonempty.
        onLast :: (a -> a) -> [a] -> [a]
        onLast :: (a -> a) -> [a] -> [a]
onLast a -> a
_ [] = []
        onLast a -> a
f [a]
xs = let ([a]
xs', [a
x]) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs
                      in [a]
xs' [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a -> a
f a
x]

        -- | Takes a list of words, and returns a list of lines with the words
        -- flowed.
        groupWordsIntoLines :: [String] -> [String]
        groupWordsIntoLines :: [String] -> [String]
groupWordsIntoLines [] = []
        groupWordsIntoLines [String]
wordList =
          let (Int
wordCount, String
line, Int
_) =
                [(Int, String, Int)] -> (Int, String, Int)
forall a. [a] -> a
last ([(Int, String, Int)] -> (Int, String, Int))
-> [(Int, String, Int)] -> (Int, String, Int)
forall a b. (a -> b) -> a -> b
$
                ((Int, String, Int) -> Bool)
-> [(Int, String, Int)] -> [(Int, String, Int)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Int
wordCount', String
_, Int
len) -> Int
wordCount' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 Bool -> Bool -> Bool
|| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxLineLength) ([(Int, String, Int)] -> [(Int, String, Int)])
-> [(Int, String, Int)] -> [(Int, String, Int)]
forall a b. (a -> b) -> a -> b
$
                ((Int, String, Int) -> String -> (Int, String, Int))
-> (Int, String, Int) -> [String] -> [(Int, String, Int)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(Int
wordCount', String
acc, Int
len) String
word ->
                        (Int
wordCount' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
                         [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
acc, String
" ", String
word],
                         Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
word))
                      (Int
0, String
"", Int
0)
                      [String]
wordList
          in String
line String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
groupWordsIntoLines (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
wordCount [String]
wordList)

        maxLineLength :: Int
        maxLineLength :: Int
maxLineLength = Int
100

-- | A generator monad for Haskell code.
--
-- Errors thrown in this monad are of the form:
--
-- > "$problem; $context; $moreContext; $evenMoreContext."
--
-- For example, "Class Foo is not convertible (use classModifyConversion);
-- generating function bar; in module baz.".
--
-- The main error message given to 'throwError' should be capitalized and should
-- not end with punctuation.  If there is a suggestion, include it in
-- parentheses at the end of the message.  'withErrorContext' and 'inFunction'
-- add context information, and should be given clauses, without punctuation.
type Generator = ReaderT Env (WriterT Output (Except ErrorMsg))

-- | Context information for generating Haskell code.
data Env = Env
  { Env -> Interface
envInterface :: Interface
  , Env -> ComputedInterfaceData
envComputedInterfaceData :: ComputedInterfaceData
  , Env -> Module
envModule :: Module
  , Env -> String
envModuleName :: String
  }

-- | Returns the currently generating interface.
askInterface :: Generator Interface
askInterface :: Generator Interface
askInterface = (Env -> Interface) -> Generator Interface
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Interface
envInterface

-- | Returns the computed data for the currently generating interface.
askComputedInterfaceData :: Generator ComputedInterfaceData
askComputedInterfaceData :: Generator ComputedInterfaceData
askComputedInterfaceData = (Env -> ComputedInterfaceData) -> Generator ComputedInterfaceData
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ComputedInterfaceData
envComputedInterfaceData

-- | Returns the currently generating module.
askModule :: Generator Module
askModule :: Generator Module
askModule = (Env -> Module) -> Generator Module
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Module
envModule

-- | Returns the currently generating module's Haskell module name.
askModuleName :: Generator String
askModuleName :: Generator String
askModuleName = (Env -> String) -> Generator String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> String
envModuleName

-- | Looks up the 'Module' containing a given external name, throwing an error
-- if it can't be found.
getModuleForExtName :: ExtName -> Generator Module
getModuleForExtName :: ExtName -> Generator Module
getModuleForExtName ExtName
extName = String -> Generator Module -> Generator Module
forall a. String -> Generator a -> Generator a
inFunction String
"getModuleForExtName" (Generator Module -> Generator Module)
-> Generator Module -> Generator Module
forall a b. (a -> b) -> a -> b
$ do
  Interface
iface <- Generator Interface
askInterface
  case ExtName -> Map ExtName Module -> Maybe Module
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ExtName
extName (Map ExtName Module -> Maybe Module)
-> Map ExtName Module -> Maybe Module
forall a b. (a -> b) -> a -> b
$ Interface -> Map ExtName Module
interfaceNamesToModules Interface
iface of
    Just Module
m -> Module -> Generator Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
    Maybe Module
Nothing -> String -> Generator Module
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator Module) -> String -> Generator Module
forall a b. (a -> b) -> a -> b
$ String
"Can't find module for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
show ExtName
extName

-- | A partially-rendered 'Module'.  Contains all of the module's bindings, but
-- may be subject to further processing.
data Partial = Partial
  { Partial -> String
partialModuleHsName :: String  -- ^ This is just the module name.
  , Partial -> Output
partialOutput :: Output
  }

instance Eq Partial where
  == :: Partial -> Partial -> Bool
(==) = String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> (Partial -> String) -> Partial -> Partial -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Partial -> String
partialModuleHsName

instance Ord Partial where
  compare :: Partial -> Partial -> Ordering
compare = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (String -> String -> Ordering)
-> (Partial -> String) -> Partial -> Partial -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Partial -> String
partialModuleHsName

-- | A chunk of generated Haskell code, including information about imports and
-- exports.
data Output = Output
  { Output -> [String]
outputExports :: [HsExport]
    -- ^ Haskell module exports.  Each 'HsExport' should include one item to go
    -- in the export list of the generated module.  Should only contain objects
    -- imported or defined in the same 'Output'.
  , Output -> HsImportSet
outputImports :: HsImportSet
    -- ^ Haskell module imports.  Should include all imports needed for the
    -- 'outputBody'.
  , Output -> [String]
outputBody :: [String]
    -- ^ Lines of Haskell code (possibly empty).  These lines may not contain
    -- the newline character in them.  There is an implicit newline between each
    -- string, as given by @intercalate \"\\n\" . outputBody@.
  , Output -> Set String
outputExtensions :: S.Set String
    -- ^ Language extensions to enable via the @{-# LANGUAGE #-}@ pragma for the
    -- whole module.
  }

instance Sem.Semigroup Output where
  (Output [String]
e HsImportSet
i [String]
b Set String
x) <> :: Output -> Output -> Output
<> (Output [String]
e' HsImportSet
i' [String]
b' Set String
x') =
    [String] -> HsImportSet -> [String] -> Set String -> Output
Output ([String]
e [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
e') (HsImportSet
i HsImportSet -> HsImportSet -> HsImportSet
forall a. Semigroup a => a -> a -> a
<> HsImportSet
i') ([String]
b [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
b') (Set String
x Set String -> Set String -> Set String
forall a. Semigroup a => a -> a -> a
<> Set String
x')

instance Monoid Output where
  mempty :: Output
mempty = [String] -> HsImportSet -> [String] -> Set String -> Output
Output [String]
forall a. Monoid a => a
mempty HsImportSet
forall a. Monoid a => a
mempty [String]
forall a. Monoid a => a
mempty Set String
forall a. Monoid a => a
mempty

  mappend :: Output -> Output -> Output
mappend = Output -> Output -> Output
forall a. Semigroup a => a -> a -> a
(<>)

  mconcat :: [Output] -> Output
mconcat [Output]
os =
    [String] -> HsImportSet -> [String] -> Set String -> Output
Output ([[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (Output -> [String]) -> [Output] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Output -> [String]
outputExports [Output]
os)
           ([HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat ([HsImportSet] -> HsImportSet) -> [HsImportSet] -> HsImportSet
forall a b. (a -> b) -> a -> b
$ (Output -> HsImportSet) -> [Output] -> [HsImportSet]
forall a b. (a -> b) -> [a] -> [b]
map Output -> HsImportSet
outputImports [Output]
os)
           ([[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (Output -> [String]) -> [Output] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map Output -> [String]
outputBody [Output]
os)
           ([Set String] -> Set String
forall a. Monoid a => [a] -> a
mconcat ([Set String] -> Set String) -> [Set String] -> Set String
forall a b. (a -> b) -> a -> b
$ (Output -> Set String) -> [Output] -> [Set String]
forall a b. (a -> b) -> [a] -> [b]
map Output -> Set String
outputExtensions [Output]
os)

-- | Runs a generator action for the given interface and module name string.
-- Returns an error message if an error occurred, otherwise the action's output
-- together with its value.
runGenerator ::
     Interface
  -> ComputedInterfaceData
  -> Module
  -> Generator a
  -> Either ErrorMsg (Partial, a)
runGenerator :: Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either String (Partial, a)
runGenerator Interface
iface ComputedInterfaceData
computed Module
m Generator a
generator =
  let modName :: String
modName = Interface -> Module -> String
getModuleName Interface
iface Module
m
  in ((a, Output) -> (Partial, a))
-> Either String (a, Output) -> Either String (Partial, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Output -> Partial) -> (Output, a) -> (Partial, a)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String -> Output -> Partial
Partial String
modName) ((Output, a) -> (Partial, a))
-> ((a, Output) -> (Output, a)) -> (a, Output) -> (Partial, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Output) -> (Output, a)
forall a b. (a, b) -> (b, a)
swap) (Either String (a, Output) -> Either String (Partial, a))
-> Either String (a, Output) -> Either String (Partial, a)
forall a b. (a -> b) -> a -> b
$
     Except String (a, Output) -> Either String (a, Output)
forall e a. Except e a -> Either e a
runExcept (Except String (a, Output) -> Either String (a, Output))
-> Except String (a, Output) -> Either String (a, Output)
forall a b. (a -> b) -> a -> b
$
     (Except String (a, Output)
 -> (String -> Except String (a, Output))
 -> Except String (a, Output))
-> (String -> Except String (a, Output))
-> Except String (a, Output)
-> Except String (a, Output)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Except String (a, Output)
-> (String -> Except String (a, Output))
-> Except String (a, Output)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (\String
msg -> String -> Except String (a, Output)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Except String (a, Output))
-> String -> Except String (a, Output)
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") (Except String (a, Output) -> Except String (a, Output))
-> Except String (a, Output) -> Except String (a, Output)
forall a b. (a -> b) -> a -> b
$
     WriterT Output (Except String) a -> Except String (a, Output)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Output (Except String) a -> Except String (a, Output))
-> WriterT Output (Except String) a -> Except String (a, Output)
forall a b. (a -> b) -> a -> b
$ Generator a -> Env -> WriterT Output (Except String) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Generator a
generator (Env -> WriterT Output (Except String) a)
-> Env -> WriterT Output (Except String) a
forall a b. (a -> b) -> a -> b
$ Interface -> ComputedInterfaceData -> Module -> String -> Env
Env Interface
iface ComputedInterfaceData
computed Module
m String
modName

-- | Runs a generator action and returns the its value.
evalGenerator :: Interface -> ComputedInterfaceData -> Module -> Generator a -> Either ErrorMsg a
evalGenerator :: Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either String a
evalGenerator Interface
iface ComputedInterfaceData
computed Module
m = ((Partial, a) -> a)
-> Either String (Partial, a) -> Either String a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Partial, a) -> a
forall a b. (a, b) -> b
snd (Either String (Partial, a) -> Either String a)
-> (Generator a -> Either String (Partial, a))
-> Generator a
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either String (Partial, a)
forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either String (Partial, a)
runGenerator Interface
iface ComputedInterfaceData
computed Module
m

-- | Runs a generator action and returns its output.
execGenerator ::
     Interface
  -> ComputedInterfaceData
  -> Module
  -> Generator a
  -> Either ErrorMsg Partial
execGenerator :: Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either String Partial
execGenerator Interface
iface ComputedInterfaceData
computed Module
m = ((Partial, a) -> Partial)
-> Either String (Partial, a) -> Either String Partial
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Partial, a) -> Partial
forall a b. (a, b) -> a
fst (Either String (Partial, a) -> Either String Partial)
-> (Generator a -> Either String (Partial, a))
-> Generator a
-> Either String Partial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either String (Partial, a)
forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either String (Partial, a)
runGenerator Interface
iface ComputedInterfaceData
computed Module
m

-- | Converts a 'Partial' into a complete Haskell module.
renderPartial :: Partial -> String
renderPartial :: Partial -> String
renderPartial Partial
partial =
  let modName :: String
modName = Partial -> String
partialModuleHsName Partial
partial
      output :: Output
output = Partial -> Output
partialOutput Partial
partial
      imports :: HsImportSet
imports = Output -> HsImportSet
outputImports Output
output
      body :: String
body =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ String
"---------- GENERATED FILE, EDITS WILL BE LOST ----------"
          , String
""
          ]
        , case Set String -> [String]
forall a. Set a -> [a]
S.elems (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ Output -> Set String
outputExtensions Output
output of
            [] -> []
            [String]
extensions -> [ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"{-# LANGUAGE " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " [String]
extensions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
" #-}"]
                          , String
""
                          ]
        , case Output -> [String]
outputExports Output
output of
            [] -> [[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"module ", String
modName, String
" where"]]
            [String]
exports ->
              [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"module ", String
modName, String
" ("] String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
              (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
export -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"  ", String
export, String
","]) [String]
exports [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
              [String
"  ) where"]
        , if Map HsImportKey HsImportSpecs -> Bool
forall k a. Map k a -> Bool
M.null (Map HsImportKey HsImportSpecs -> Bool)
-> Map HsImportKey HsImportSpecs -> Bool
forall a b. (a -> b) -> a -> b
$ HsImportSet -> Map HsImportKey HsImportSpecs
getHsImportSet HsImportSet
imports
          then []
          else String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsImportSet -> [String]
renderImports HsImportSet
imports
        , [String
""]
        , Output -> [String]
outputBody Output
output
        ]
  in String
body

-- | Adds context information to the end of any error message thrown by the
-- action.  See 'Generator'.
withErrorContext :: String -> Generator a -> Generator a
withErrorContext :: String -> Generator a -> Generator a
withErrorContext String
msg' Generator a
action = Generator a -> (String -> Generator a) -> Generator a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError Generator a
action ((String -> Generator a) -> Generator a)
-> (String -> Generator a) -> Generator a
forall a b. (a -> b) -> a -> b
$ \String
msg -> String -> Generator a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator a) -> String -> Generator a
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
msg, String
"; ", String
msg']

-- | Adds the given function name to any error message thrown by the action, for
-- context.
inFunction :: String -> Generator a -> Generator a
inFunction :: String -> Generator a -> Generator a
inFunction String
fnName = String -> Generator a -> Generator a
forall a. String -> Generator a -> Generator a
withErrorContext (String -> Generator a -> Generator a)
-> String -> Generator a -> Generator a
forall a b. (a -> b) -> a -> b
$ String
"in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnName

-- | Indicates strings that represent an item in a Haskell module export list.
type HsExport = String

-- | Adds an export to the current module.
addExport :: HsExport -> Generator ()
addExport :: String -> Generator ()
addExport = [String] -> Generator ()
addExports ([String] -> Generator ())
-> (String -> [String]) -> String -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[])

-- | @addExport' \"x\"@ adds an export of the form @x (..)@ to the current
-- module.
addExport' :: HsExport -> Generator ()
addExport' :: String -> Generator ()
addExport' String
x = [String] -> Generator ()
addExports [String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (..)"]

-- | Adds multiple exports to the current module.
addExports :: [HsExport] -> Generator ()
addExports :: [String] -> Generator ()
addExports [String]
exports = Output -> Generator ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Output -> Generator ()) -> Output -> Generator ()
forall a b. (a -> b) -> a -> b
$ Output
forall a. Monoid a => a
mempty { outputExports :: [String]
outputExports = [String]
exports }

-- | Adds imports to the current module.
addImports :: HsImportSet -> Generator ()
addImports :: HsImportSet -> Generator ()
addImports HsImportSet
imports = Output -> Generator ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Output
forall a. Monoid a => a
mempty { outputImports :: HsImportSet
outputImports = HsImportSet
imports }

-- | Adds a Haskell language extension to the current module.
addExtension :: String -> Generator ()
addExtension :: String -> Generator ()
addExtension String
extensionName =
  Output -> Generator ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Output -> Generator ()) -> Output -> Generator ()
forall a b. (a -> b) -> a -> b
$ Output
forall a. Monoid a => a
mempty { outputExtensions :: Set String
outputExtensions = String -> Set String
forall a. a -> Set a
S.singleton String
extensionName }

-- | The section of code that Hoppy is generating, for an export.
data SayExportMode =
    SayExportForeignImports
    -- ^ Hoppy is generating @foreign import@ statements for an export.  This is
    -- separate from the main 'SayExportDecls' phase because foreign import
    -- statements are emitted directly by a 'Generator', and these need to
    -- appear earlier in the code.
  | SayExportDecls
    -- ^ Hoppy is generating Haskell code to bind to the export.  This is the
    -- main step of Haskell code generation for an export.
    --
    -- Here, imports of Haskell modules should be added with 'LH.addImports'
    -- rather than emitting an @import@ statement yourself in the foreign import
    -- step.  'LH.addExtNameModule' may be used to import and reference the
    -- Haskell module of another export.
  | SayExportBoot
    -- ^ If Hoppy needs to generate @hs-boot@ files to break circular
    -- dependences between generated modules, then for each export in each
    -- module involved in a cycle, it will call the generator in this mode to
    -- produce @hs-boot@ code.  This code should provide a minimal declaration
    -- of Haskell entities generated by 'SayExportDecls', without providing any
    -- implementation.
    --
    -- For information on the special format of @hs-boot@ files, see the
    -- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/separate_compilation.html#how-to-compile-mutually-recursive-modules GHC User's Guide>.
  deriving (SayExportMode -> SayExportMode -> Bool
(SayExportMode -> SayExportMode -> Bool)
-> (SayExportMode -> SayExportMode -> Bool) -> Eq SayExportMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SayExportMode -> SayExportMode -> Bool
$c/= :: SayExportMode -> SayExportMode -> Bool
== :: SayExportMode -> SayExportMode -> Bool
$c== :: SayExportMode -> SayExportMode -> Bool
Eq, Int -> SayExportMode -> String -> String
[SayExportMode] -> String -> String
SayExportMode -> String
(Int -> SayExportMode -> String -> String)
-> (SayExportMode -> String)
-> ([SayExportMode] -> String -> String)
-> Show SayExportMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SayExportMode] -> String -> String
$cshowList :: [SayExportMode] -> String -> String
show :: SayExportMode -> String
$cshow :: SayExportMode -> String
showsPrec :: Int -> SayExportMode -> String -> String
$cshowsPrec :: Int -> SayExportMode -> String -> String
Show)

-- | Outputs a line of Haskell code.  A newline will be added on the end of the
-- input.  Newline characters must not be given to this function.
sayLn :: String -> Generator ()
sayLn :: String -> Generator ()
sayLn String
x =
  if Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
x
  then String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
inFunction String
"sayLn" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
       [String
"Refusing to speak '\n', received ", String -> String
forall a. Show a => a -> String
show String
x, String
" (use (mapM_ sayLn . lines) instead)"]
  else Output -> Generator ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Output -> Generator ()) -> Output -> Generator ()
forall a b. (a -> b) -> a -> b
$ Output
forall a. Monoid a => a
mempty { outputBody :: [String]
outputBody = [String
x] }

-- | Outputs multiple words to form a line of Haskell code (effectively @saysLn
-- = sayLn . concat@).
saysLn :: [String] -> Generator ()
saysLn :: [String] -> Generator ()
saysLn = String -> Generator ()
sayLn (String -> Generator ())
-> ([String] -> String) -> [String] -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

-- | Outputs an empty line of Haskell code.  This is reportedly valid Perl code
-- as well.
ln :: Generator ()
ln :: Generator ()
ln = String -> Generator ()
sayLn String
""

-- | Runs the given action, indenting all code output by the action one level.
indent :: Generator a -> Generator a
indent :: Generator a -> Generator a
indent = (Output -> Output) -> Generator a -> Generator a
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor ((Output -> Output) -> Generator a -> Generator a)
-> (Output -> Output) -> Generator a -> Generator a
forall a b. (a -> b) -> a -> b
$ \Output
o -> Output
o { outputBody :: [String]
outputBody = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
x) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Output -> [String]
outputBody Output
o }

-- | Runs the given action, indenting all code output by the action N spaces.
indentSpaces :: Int -> Generator a -> Generator a
indentSpaces :: Int -> Generator a -> Generator a
indentSpaces Int
n = (Output -> Output) -> Generator a -> Generator a
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor ((Output -> Output) -> Generator a -> Generator a)
-> (Output -> Output) -> Generator a -> Generator a
forall a b. (a -> b) -> a -> b
$ \Output
o -> Output
o { outputBody :: [String]
outputBody = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> String
indentation String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Output -> [String]
outputBody Output
o }
  where indentation :: String
indentation = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' '

-- | Takes a list of binding actions and a body action, and outputs a @let@
-- expression.  By passing in 'Nothing' for the body, it will be omitted, so
-- @let@ statements in @do@ blocks can be created as well.  Output is of the
-- form:
--
-- > let
-- >   <binding1>
-- >   ...
-- >   <bindingN>
-- >   in
-- >     <body>
--
-- To stretch a binding over multiple lines, lines past the first should use
-- 'indent' manually.
sayLet :: [Generator ()] -> Maybe (Generator ()) -> Generator ()
sayLet :: [Generator ()] -> Maybe (Generator ()) -> Generator ()
sayLet [Generator ()]
bindings Maybe (Generator ())
maybeBody = do
  String -> Generator ()
sayLn String
"let"
  Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [Generator ()] -> Generator ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Generator ()]
bindings
  Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Generator ())
maybeBody ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
body ->
    -- Indent here in case we have a "let ... in ..." within a do block.
    Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
      String -> Generator ()
sayLn String
"in"
      Generator () -> Generator ()
forall a. Generator a -> Generator a
indent Generator ()
body

-- | Looks up the module that exports an external name.  Throws an error if the
-- external name is not exported.
getExtNameModule :: ExtName -> Generator Module
getExtNameModule :: ExtName -> Generator Module
getExtNameModule ExtName
extName = String -> Generator Module -> Generator Module
forall a. String -> Generator a -> Generator a
inFunction String
"getExtNameModule" (Generator Module -> Generator Module)
-> Generator Module -> Generator Module
forall a b. (a -> b) -> a -> b
$ do
  Interface
iface <- Generator Interface
askInterface
  Generator Module -> Maybe Module -> Generator Module
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (String -> Generator Module
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator Module) -> String -> Generator Module
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find module for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
show ExtName
extName String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
" (is it included in a module's export list?)") (Maybe Module -> Generator Module)
-> Maybe Module -> Generator Module
forall a b. (a -> b) -> a -> b
$
    ExtName -> Map ExtName Module -> Maybe Module
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ExtName
extName (Map ExtName Module -> Maybe Module)
-> Map ExtName Module -> Maybe Module
forall a b. (a -> b) -> a -> b
$
    Interface -> Map ExtName Module
interfaceNamesToModules Interface
iface

-- | Returns a module's unique short name that should be used for a qualified
-- import of the module.
getModuleImportName :: Module -> Generator String
getModuleImportName :: Module -> Generator String
getModuleImportName Module
m = do
  Interface
iface <- Generator Interface
askInterface
  Generator String -> Maybe String -> Generator String
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (String -> Generator String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find a Haskell import name for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
forall a. Show a => a -> String
show Module
m String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
" (is it included in the interface's module list?)") (Maybe String -> Generator String)
-> Maybe String -> Generator String
forall a b. (a -> b) -> a -> b
$
    Module -> Map Module String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
m (Map Module String -> Maybe String)
-> Map Module String -> Maybe String
forall a b. (a -> b) -> a -> b
$
    Interface -> Map Module String
interfaceHaskellModuleImportNames Interface
iface

-- | Adds a qualified import of the given external name's module into the current
-- module, and returns the qualified name of the import.  If the external name
-- is defined in the current module, then this is a no-op and 'Nothing' is
-- returned.
importHsModuleForExtName :: ExtName -> Generator (Maybe String)
importHsModuleForExtName :: ExtName -> Generator (Maybe String)
importHsModuleForExtName ExtName
extName = do
  Module
currentModule <- Generator Module
askModule
  Module
owningModule <- ExtName -> Generator Module
getExtNameModule ExtName
extName
  if Module
currentModule Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
owningModule
    then Maybe String -> Generator (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    else do Interface
iface <- Generator Interface
askInterface
            let fullName :: String
fullName = Interface -> Module -> String
getModuleName Interface
iface Module
owningModule
            String
qualifiedName <- Module -> Generator String
getModuleImportName Module
owningModule
            HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> String -> HsImportSet
hsQualifiedImport String
fullName String
qualifiedName
            Maybe String -> Generator (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> Generator (Maybe String))
-> Maybe String -> Generator (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
qualifiedName

-- | Used like @addExtNameModule extName hsEntity@.  @hsEntity@ is a name in
-- Haskell code that is generated from the definition of @extName@, and thus
-- lives in @extName@'s module.  This function adds imports and returns a
-- qualified name as necessary to refer to the given entity.
addExtNameModule :: ExtName -> String -> Generator String
addExtNameModule :: ExtName -> String -> Generator String
addExtNameModule ExtName
extName String
hsEntity = do
  Maybe String
maybeImportName <- ExtName -> Generator (Maybe String)
importHsModuleForExtName ExtName
extName
  String -> Generator String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ case Maybe String
maybeImportName of
    Maybe String
Nothing -> String
hsEntity  -- Same module.
    Just String
importName -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
importName, String
".", String
hsEntity]  -- Different module.

-- | Constructs Haskell names from external names.  Returns a name that is a
-- suitable Haskell type name for the external name, and if given 'Const', then
-- with @\"Const\"@ appended.
toHsTypeName :: Constness -> ExtName -> Generator String
toHsTypeName :: Constness -> ExtName -> Generator String
toHsTypeName Constness
cst ExtName
extName =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
inFunction String
"toHsTypeName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
addExtNameModule ExtName
extName (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Constness -> ExtName -> String
toHsTypeName' Constness
cst ExtName
extName

-- | Pure version of 'toHsTypeName' that doesn't create a qualified name.
toHsTypeName' :: Constness -> ExtName -> String
toHsTypeName' :: Constness -> ExtName -> String
toHsTypeName' Constness
cst ExtName
extName =
  (case Constness
cst of
      Constness
Const -> (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Const")
      Constness
Nonconst -> String -> String
forall a. a -> a
id) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
  case ExtName -> String
fromExtName ExtName
extName of
    Char
x:String
xs -> Char -> Char
toUpper Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs
    [] -> []

-- | Converts an external name into a name suitable for a Haskell function or
-- variable.
toHsFnName :: ExtName -> Generator String
toHsFnName :: ExtName -> Generator String
toHsFnName ExtName
extName =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
inFunction String
"toHsFnName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
addExtNameModule ExtName
extName (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ ExtName -> String
toHsFnName' ExtName
extName

-- | Pure version of 'toHsFnName' that doesn't create a qualified name.
toHsFnName' :: ExtName -> String
toHsFnName' :: ExtName -> String
toHsFnName' = String -> String
lowerFirst (String -> String) -> (ExtName -> String) -> ExtName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtName -> String
fromExtName

-- | Returns a distinct argument variable name for each nonnegative number.
toArgName :: Int -> String
toArgName :: Int -> String
toArgName = (String
"arg'" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

-- | The Haskell side of bindings performs conversions between C FFI types and
-- Haskell types.  This denotes which side's type is being used.
data HsTypeSide =
  HsCSide  -- ^ The C type sent from C++.
  | HsHsSide  -- ^ The Haskell-native type.
  deriving (HsTypeSide -> HsTypeSide -> Bool
(HsTypeSide -> HsTypeSide -> Bool)
-> (HsTypeSide -> HsTypeSide -> Bool) -> Eq HsTypeSide
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsTypeSide -> HsTypeSide -> Bool
$c/= :: HsTypeSide -> HsTypeSide -> Bool
== :: HsTypeSide -> HsTypeSide -> Bool
$c== :: HsTypeSide -> HsTypeSide -> Bool
Eq, Int -> HsTypeSide -> String -> String
[HsTypeSide] -> String -> String
HsTypeSide -> String
(Int -> HsTypeSide -> String -> String)
-> (HsTypeSide -> String)
-> ([HsTypeSide] -> String -> String)
-> Show HsTypeSide
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HsTypeSide] -> String -> String
$cshowList :: [HsTypeSide] -> String -> String
show :: HsTypeSide -> String
$cshow :: HsTypeSide -> String
showsPrec :: Int -> HsTypeSide -> String -> String
$cshowsPrec :: Int -> HsTypeSide -> String -> String
Show)

-- | Returns the 'HsType' corresponding to a 'Type', and also adds imports to
-- the 'Generator' as necessary for Haskell types that the 'Type' references.
-- On failure, an error is thrown.
cppTypeToHsTypeAndUse :: HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse :: HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side Type
t =
  String -> Generator HsType -> Generator HsType
forall a. String -> Generator a -> Generator a
withErrorContext ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"converting ", Type -> String
forall a. Show a => a -> String
show Type
t, String
" to ", HsTypeSide -> String
forall a. Show a => a -> String
show HsTypeSide
side, String
" type"]) (Generator HsType -> Generator HsType)
-> Generator HsType -> Generator HsType
forall a b. (a -> b) -> a -> b
$
  case Type
t of
    Type
Internal_TVoid -> HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType -> Generator HsType) -> HsType -> Generator HsType
forall a b. (a -> b) -> a -> b
$ HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsSpecialCon -> HsQName
Special HsSpecialCon
HsUnitCon
    Internal_TPtr (Internal_TObj Class
cls) -> do
      -- Same as TPtr (TConst (TObj cls)), but nonconst.
      String
typeName <- Constness -> ExtName -> Generator String
toHsTypeName Constness
Nonconst (ExtName -> Generator String) -> ExtName -> Generator String
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
cls
      let dataType :: HsType
dataType = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
typeName
      case HsTypeSide
side of
        HsTypeSide
HsCSide -> do
          HsImportSet -> Generator ()
addImports HsImportSet
hsImportForForeign
          HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType -> Generator HsType) -> HsType -> Generator HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyF.Ptr") HsType
dataType
        HsTypeSide
HsHsSide -> HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return HsType
dataType
    Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> do
      -- Same as TPtr (TObj cls), but const.
      String
typeName <- Constness -> ExtName -> Generator String
toHsTypeName Constness
Const (ExtName -> Generator String) -> ExtName -> Generator String
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
cls
      let dataType :: HsType
dataType = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
typeName
      case HsTypeSide
side of
        HsTypeSide
HsCSide -> do
          HsImportSet -> Generator ()
addImports HsImportSet
hsImportForForeign
          HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType -> Generator HsType) -> HsType -> Generator HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyF.Ptr") HsType
dataType
        HsTypeSide
HsHsSide -> HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return HsType
dataType
    Internal_TPtr fn :: Type
fn@(Internal_TFn {}) -> do
      HsImportSet -> Generator ()
addImports HsImportSet
hsImportForForeign
      HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyF.FunPtr") (HsType -> HsType) -> Generator HsType -> Generator HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
HsCSide Type
fn
    Internal_TPtr Type
t' -> do
      HsImportSet -> Generator ()
addImports HsImportSet
hsImportForForeign
      -- Pointers to types not covered above point to raw C++ values, so we need
      -- to use the C-side type of the pointer target here.
      HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyF.Ptr") (HsType -> HsType) -> Generator HsType -> Generator HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
HsCSide Type
t'
    Internal_TRef Type
t' -> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT Type
t'
    Internal_TFn [Parameter]
params Type
retType -> do
      [HsType]
paramHsTypes <- (Parameter -> Generator HsType)
-> [Parameter]
-> ReaderT Env (WriterT Output (Except String)) [HsType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side (Type -> Generator HsType)
-> (Parameter -> Type) -> Parameter -> Generator HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parameter -> Type
parameterType) [Parameter]
params
      HsType
retHsType <- HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side Type
retType
      HsImportSet -> Generator ()
addImports HsImportSet
hsImportForPrelude
      HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType -> Generator HsType) -> HsType -> Generator HsType
forall a b. (a -> b) -> a -> b
$
        (HsType -> HsType -> HsType) -> HsType -> [HsType] -> HsType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsType -> HsType -> HsType
HsTyFun (HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyP.IO") HsType
retHsType) [HsType]
paramHsTypes
    Internal_TObj Class
cls -> case HsTypeSide
side of
      HsTypeSide
HsCSide -> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
constT Type
t
      HsTypeSide
HsHsSide -> case ClassHaskellConversion -> Maybe (Generator HsType)
classHaskellConversionType (ClassHaskellConversion -> Maybe (Generator HsType))
-> ClassHaskellConversion -> Maybe (Generator HsType)
forall a b. (a -> b) -> a -> b
$ Class -> ClassHaskellConversion
getClassHaskellConversion Class
cls of
        Just Generator HsType
typeGen -> Generator HsType
typeGen
        Maybe (Generator HsType)
Nothing ->
          String -> Generator HsType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator HsType) -> String -> Generator HsType
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [String
"Expected a Haskell type for ", Class -> String
forall a. Show a => a -> String
show Class
cls, String
" but there isn't one"]
    Internal_TObjToHeap Class
cls -> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls
    Internal_TToGc Type
t' -> case Type
t' of
      Internal_TRef Type
_ -> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side Type
t'  -- References behave the same as pointers.
      Internal_TPtr Type
_ -> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side Type
t'
      Internal_TObj Class
cls -> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side (Type -> Generator HsType) -> Type -> Generator HsType
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls
      Type
_ -> String -> Generator HsType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator HsType) -> String -> Generator HsType
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
tToGcInvalidFormErrorMessage Maybe String
forall a. Maybe a
Nothing Type
t'
    Internal_TManual ConversionSpec
s -> case ConversionSpec -> Maybe ConversionSpecHaskell
conversionSpecHaskell ConversionSpec
s of
      Just ConversionSpecHaskell
h -> case HsTypeSide
side of
        HsTypeSide
HsHsSide -> ConversionSpecHaskell -> Generator HsType
conversionSpecHaskellHsType ConversionSpecHaskell
h
        HsTypeSide
HsCSide -> Generator HsType -> Maybe (Generator HsType) -> Generator HsType
forall a. a -> Maybe a -> a
fromMaybe (ConversionSpecHaskell -> Generator HsType
conversionSpecHaskellHsType ConversionSpecHaskell
h) (Maybe (Generator HsType) -> Generator HsType)
-> Maybe (Generator HsType) -> Generator HsType
forall a b. (a -> b) -> a -> b
$
                   ConversionSpecHaskell -> Maybe (Generator HsType)
conversionSpecHaskellCType ConversionSpecHaskell
h
      Maybe ConversionSpecHaskell
Nothing -> String -> Generator HsType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator HsType) -> String -> Generator HsType
forall a b. (a -> b) -> a -> b
$ ConversionSpec -> String
forall a. Show a => a -> String
show ConversionSpec
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" defines no Haskell conversion"
    Internal_TConst Type
t' -> HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse HsTypeSide
side Type
t'

-- | Returns the 'ClassHaskellConversion' of a class.
getClassHaskellConversion :: Class -> ClassHaskellConversion
getClassHaskellConversion :: Class -> ClassHaskellConversion
getClassHaskellConversion = ClassConversion -> ClassHaskellConversion
classHaskellConversion (ClassConversion -> ClassHaskellConversion)
-> (Class -> ClassConversion) -> Class -> ClassHaskellConversion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> ClassConversion
classConversion

-- | Combines the given exception handlers (from a particular exported entity)
-- with the handlers from the current module and interface.  The given handlers
-- have highest precedence, followed by module handlers, followed by interface
-- handlers.
getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers
getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers
getEffectiveExceptionHandlers ExceptionHandlers
handlers = do
  ExceptionHandlers
ifaceHandlers <- Interface -> ExceptionHandlers
interfaceExceptionHandlers (Interface -> ExceptionHandlers)
-> Generator Interface -> Generator ExceptionHandlers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Generator Interface
askInterface
  ExceptionHandlers
moduleHandlers <- Module -> ExceptionHandlers
forall a. HandlesExceptions a => a -> ExceptionHandlers
getExceptionHandlers (Module -> ExceptionHandlers)
-> Generator Module -> Generator ExceptionHandlers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Generator Module
askModule
  -- Exception handlers declared lower in the hierarchy take precedence over
  -- those higher in the hierarchy; ExceptionHandlers is a left-biased monoid.
  ExceptionHandlers -> Generator ExceptionHandlers
forall (m :: * -> *) a. Monad m => a -> m a
return (ExceptionHandlers -> Generator ExceptionHandlers)
-> ExceptionHandlers -> Generator ExceptionHandlers
forall a b. (a -> b) -> a -> b
$ [ExceptionHandlers] -> ExceptionHandlers
forall a. Monoid a => [a] -> a
mconcat [ExceptionHandlers
handlers, ExceptionHandlers
moduleHandlers, ExceptionHandlers
ifaceHandlers]

-- | Prints a value like 'P.prettyPrint', but removes newlines so that they
-- don't cause problems with this module's textual generation.  Should be mainly
-- used for printing types; stripping newlines from definitions for example
-- could go badly.
prettyPrint :: P.Pretty a => a -> String
prettyPrint :: a -> String
prettyPrint = String -> String
collapseSpaces (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Pretty a => a -> String
P.prettyPrint
  where collapseSpaces :: String -> String
collapseSpaces (Char
' ':String
xs) = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
collapseSpaces ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
xs)
        collapseSpaces (Char
x:String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
collapseSpaces String
xs
        collapseSpaces [] = []