-- This file is part of Hoppy.
--
-- Copyright 2015-2024 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
$cminBound :: Managed
minBound :: Managed
$cmaxBound :: Managed
maxBound :: 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
$csucc :: Managed -> Managed
succ :: Managed -> Managed
$cpred :: Managed -> Managed
pred :: Managed -> Managed
$ctoEnum :: Int -> Managed
toEnum :: Int -> Managed
$cfromEnum :: Managed -> Int
fromEnum :: Managed -> Int
$cenumFrom :: Managed -> [Managed]
enumFrom :: Managed -> [Managed]
$cenumFromThen :: Managed -> Managed -> [Managed]
enumFromThen :: Managed -> Managed -> [Managed]
$cenumFromTo :: Managed -> Managed -> [Managed]
enumFromTo :: Managed -> Managed -> [Managed]
$cenumFromThenTo :: Managed -> Managed -> Managed -> [Managed]
enumFromThenTo :: Managed -> Managed -> Managed -> [Managed]
Enum, Managed -> Managed -> Bool
(Managed -> Managed -> Bool)
-> (Managed -> Managed -> Bool) -> Eq Managed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Managed -> Managed -> Bool
== :: Managed -> Managed -> Bool
$c/= :: Managed -> Managed -> Bool
/= :: 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
$ccompare :: Managed -> Managed -> Ordering
compare :: Managed -> Managed -> Ordering
$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
>= :: Managed -> Managed -> Bool
$cmax :: Managed -> Managed -> Managed
max :: Managed -> Managed -> Managed
$cmin :: Managed -> Managed -> Managed
min :: Managed -> Managed -> 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 -> ErrorMsg
getModuleName Interface
iface Module
m =
  ErrorMsg -> [ErrorMsg] -> ErrorMsg
forall a. [a] -> [[a]] -> [a]
intercalate ErrorMsg
"." ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> ErrorMsg
forall a b. (a -> b) -> a -> b
$
  Interface -> [ErrorMsg]
interfaceHaskellModuleBase Interface
iface [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++
  [ErrorMsg] -> Maybe [ErrorMsg] -> [ErrorMsg]
forall a. a -> Maybe a -> a
fromMaybe [ErrorMsg -> ErrorMsg
toModuleName (ErrorMsg -> ErrorMsg) -> ErrorMsg -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Module -> ErrorMsg
moduleName Module
m] (Module -> Maybe [ErrorMsg]
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 :: ErrorMsg -> ErrorMsg
toModuleName (Char
x:ErrorMsg
xs) = Char -> Char
toUpper Char
x Char -> ErrorMsg -> ErrorMsg
forall a. a -> [a] -> [a]
: ErrorMsg
xs
toModuleName ErrorMsg
"" = ErrorMsg
""

-- | Renders a set of imports in Haskell syntax on multiple lines.
renderImports :: HsImportSet -> [String]
renderImports :: HsImportSet -> [ErrorMsg]
renderImports = ((HsImportKey, HsImportSpecs) -> ErrorMsg)
-> [(HsImportKey, HsImportSpecs)] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (HsImportKey, HsImportSpecs) -> ErrorMsg
renderModuleImport ([(HsImportKey, HsImportSpecs)] -> [ErrorMsg])
-> (HsImportSet -> [(HsImportKey, HsImportSpecs)])
-> HsImportSet
-> [ErrorMsg]
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) -> ErrorMsg
renderModuleImport (HsImportKey
key, HsImportSpecs
specs) =
          let modName :: ErrorMsg
modName = HsImportKey -> ErrorMsg
hsImportModule HsImportKey
key
              maybeQualifiedName :: Maybe ErrorMsg
maybeQualifiedName = HsImportKey -> Maybe ErrorMsg
hsImportQualifiedName HsImportKey
key
              isQual :: Bool
isQual = Maybe ErrorMsg -> Bool
forall a. Maybe a -> Bool
isJust Maybe ErrorMsg
maybeQualifiedName
              importPrefix :: ErrorMsg
importPrefix = if HsImportSpecs -> Bool
hsImportSource HsImportSpecs
specs
                             then ErrorMsg
"import {-# SOURCE #-} "
                             else ErrorMsg
"import "
              importQualifiedPrefix :: ErrorMsg
importQualifiedPrefix =
                if HsImportSpecs -> Bool
hsImportSource HsImportSpecs
specs
                then ErrorMsg
"import {-# SOURCE #-} qualified "
                else ErrorMsg
"import qualified "
          in case HsImportSpecs -> Maybe (Map ErrorMsg HsImportVal)
getHsImportSpecs HsImportSpecs
specs of
            Maybe (Map ErrorMsg HsImportVal)
Nothing -> case Maybe ErrorMsg
maybeQualifiedName of
              Maybe ErrorMsg
Nothing -> ErrorMsg
importPrefix ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
modName
              Just ErrorMsg
qualifiedName ->
                [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
importQualifiedPrefix, ErrorMsg
modName, ErrorMsg
" as ", ErrorMsg
qualifiedName]
            Just Map ErrorMsg HsImportVal
specMap ->
              let specWords :: [String]
                  specWords :: [ErrorMsg]
specWords = [[ErrorMsg]] -> [ErrorMsg]
concatWithCommas ([[ErrorMsg]] -> [ErrorMsg]) -> [[ErrorMsg]] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ ((ErrorMsg, HsImportVal) -> [ErrorMsg])
-> [(ErrorMsg, HsImportVal)] -> [[ErrorMsg]]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg, HsImportVal) -> [ErrorMsg]
renderSpecAsWords ([(ErrorMsg, HsImportVal)] -> [[ErrorMsg]])
-> [(ErrorMsg, HsImportVal)] -> [[ErrorMsg]]
forall a b. (a -> b) -> a -> b
$ Map ErrorMsg HsImportVal -> [(ErrorMsg, HsImportVal)]
forall k a. Map k a -> [(k, a)]
M.assocs Map ErrorMsg HsImportVal
specMap
                  singleLineImport :: String
                  singleLineImport :: ErrorMsg
singleLineImport =
                    [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> ErrorMsg
forall a b. (a -> b) -> a -> b
$
                    (if Bool
isQual then ErrorMsg
importQualifiedPrefix else ErrorMsg
importPrefix) ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
                    ErrorMsg
modName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
" (" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
" " [ErrorMsg]
specWords [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++
                    case Maybe ErrorMsg
maybeQualifiedName of
                      Maybe ErrorMsg
Nothing -> [ErrorMsg
")"]
                      Just ErrorMsg
qualifiedName -> [ErrorMsg
") as ", ErrorMsg
qualifiedName]
              in if ErrorMsg -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ErrorMsg -> Bool) -> ErrorMsg -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> ErrorMsg -> ErrorMsg
forall a. Int -> [a] -> [a]
drop Int
maxLineLength ErrorMsg
singleLineImport
                 then ErrorMsg
singleLineImport
                 else ErrorMsg -> [ErrorMsg] -> ErrorMsg
forall a. [a] -> [[a]] -> [a]
intercalate ErrorMsg
"\n" ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> ErrorMsg
forall a b. (a -> b) -> a -> b
$
                      (ErrorMsg
importPrefix ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
modName ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" (") ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
                      [ErrorMsg] -> [ErrorMsg]
groupWordsIntoLines [ErrorMsg]
specWords [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++
                      case Maybe ErrorMsg
maybeQualifiedName of
                        Maybe ErrorMsg
Nothing -> [ErrorMsg
"  )"]
                        Just ErrorMsg
qualifiedName -> [ErrorMsg
"  ) as " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
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 :: (ErrorMsg, HsImportVal) -> [ErrorMsg]
renderSpecAsWords (ErrorMsg
name, HsImportVal
val) = case HsImportVal
val of
          HsImportVal
HsImportVal -> [ErrorMsg
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 [ErrorMsg]
parts -> case [ErrorMsg]
parts of
            [] -> [ErrorMsg
name ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" ()"]
            [ErrorMsg
part] -> [[ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
name, ErrorMsg
" (", ErrorMsg
part, ErrorMsg
")"]]
            ErrorMsg
part0:[ErrorMsg]
parts' -> let ([ErrorMsg]
parts'', [ErrorMsg
partN]) = Int -> [ErrorMsg] -> ([ErrorMsg], [ErrorMsg])
forall a. Int -> [a] -> ([a], [a])
splitAt ([ErrorMsg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrorMsg]
parts' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [ErrorMsg]
parts'
                           in [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
name, ErrorMsg
" (", ErrorMsg
part0, ErrorMsg
","] ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
                              (ErrorMsg -> ErrorMsg) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
",") [ErrorMsg]
parts'' [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++
                              [ErrorMsg
partN ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
")"]
          HsImportVal
HsImportValAll -> [ErrorMsg
name ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" (..)"]

        -- | 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 :: [[ErrorMsg]] -> [ErrorMsg]
concatWithCommas [] = []
        concatWithCommas [[ErrorMsg]]
ss =
          let ([[ErrorMsg]]
ss', ssLast :: [[ErrorMsg]]
ssLast@[[ErrorMsg]
_]) = Int -> [[ErrorMsg]] -> ([[ErrorMsg]], [[ErrorMsg]])
forall a. Int -> [a] -> ([a], [a])
splitAt ([[ErrorMsg]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[ErrorMsg]]
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [[ErrorMsg]]
ss
          in [[ErrorMsg]] -> [ErrorMsg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ErrorMsg]] -> [ErrorMsg]) -> [[ErrorMsg]] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ ([ErrorMsg] -> [ErrorMsg]) -> [[ErrorMsg]] -> [[ErrorMsg]]
forall a b. (a -> b) -> [a] -> [b]
map ((ErrorMsg -> ErrorMsg) -> [ErrorMsg] -> [ErrorMsg]
forall a. (a -> a) -> [a] -> [a]
onLast (ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
",")) [[ErrorMsg]]
ss' [[ErrorMsg]] -> [[ErrorMsg]] -> [[ErrorMsg]]
forall a. [a] -> [a] -> [a]
++ [[ErrorMsg]]
ssLast

        -- | Applies a function to the final element of a list, if the list is
        -- nonempty.
        onLast :: (a -> a) -> [a] -> [a]
        onLast :: forall a. (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 a. [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 :: [ErrorMsg] -> [ErrorMsg]
groupWordsIntoLines [] = []
        groupWordsIntoLines [ErrorMsg]
wordList =
          let (Int
wordCount, ErrorMsg
line, Int
_) =
                [(Int, ErrorMsg, Int)] -> (Int, ErrorMsg, Int)
forall a. HasCallStack => [a] -> a
last ([(Int, ErrorMsg, Int)] -> (Int, ErrorMsg, Int))
-> [(Int, ErrorMsg, Int)] -> (Int, ErrorMsg, Int)
forall a b. (a -> b) -> a -> b
$
                ((Int, ErrorMsg, Int) -> Bool)
-> [(Int, ErrorMsg, Int)] -> [(Int, ErrorMsg, Int)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Int
wordCount', ErrorMsg
_, 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, ErrorMsg, Int)] -> [(Int, ErrorMsg, Int)])
-> [(Int, ErrorMsg, Int)] -> [(Int, ErrorMsg, Int)]
forall a b. (a -> b) -> a -> b
$
                ((Int, ErrorMsg, Int) -> ErrorMsg -> (Int, ErrorMsg, Int))
-> (Int, ErrorMsg, Int) -> [ErrorMsg] -> [(Int, ErrorMsg, Int)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(Int
wordCount', ErrorMsg
acc, Int
len) ErrorMsg
word ->
                        (Int
wordCount' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
                         [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
acc, ErrorMsg
" ", ErrorMsg
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
+ ErrorMsg -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrorMsg
word))
                      (Int
0, ErrorMsg
"", Int
0)
                      [ErrorMsg]
wordList
          in ErrorMsg
line ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: [ErrorMsg] -> [ErrorMsg]
groupWordsIntoLines (Int -> [ErrorMsg] -> [ErrorMsg]
forall a. Int -> [a] -> [a]
drop Int
wordCount [ErrorMsg]
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 -> ErrorMsg
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 ErrorMsg
askModuleName = (Env -> ErrorMsg) -> Generator ErrorMsg
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ErrorMsg
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 = ErrorMsg -> Generator Module -> Generator Module
forall a. ErrorMsg -> Generator a -> Generator a
inFunction ErrorMsg
"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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
    Maybe Module
Nothing -> ErrorMsg -> Generator Module
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator Module) -> ErrorMsg -> Generator Module
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Can't find module for " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
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 -> ErrorMsg
partialModuleHsName :: String  -- ^ This is just the module name.
  , Partial -> Output
partialOutput :: Output
  }

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

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

-- | A chunk of generated Haskell code, including information about imports and
-- exports.
data Output = Output
  { Output -> [ErrorMsg]
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 -> [ErrorMsg]
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 ErrorMsg
outputExtensions :: S.Set String
    -- ^ Language extensions to enable via the @{-# LANGUAGE #-}@ pragma for the
    -- whole module.
  }

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

instance Monoid Output where
  mempty :: Output
mempty = [ErrorMsg] -> HsImportSet -> [ErrorMsg] -> Set ErrorMsg -> Output
Output [ErrorMsg]
forall a. Monoid a => a
mempty HsImportSet
forall a. Monoid a => a
mempty [ErrorMsg]
forall a. Monoid a => a
mempty Set ErrorMsg
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 =
    [ErrorMsg] -> HsImportSet -> [ErrorMsg] -> Set ErrorMsg -> Output
Output ([[ErrorMsg]] -> [ErrorMsg]
forall a. Monoid a => [a] -> a
mconcat ([[ErrorMsg]] -> [ErrorMsg]) -> [[ErrorMsg]] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ (Output -> [ErrorMsg]) -> [Output] -> [[ErrorMsg]]
forall a b. (a -> b) -> [a] -> [b]
map Output -> [ErrorMsg]
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)
           ([[ErrorMsg]] -> [ErrorMsg]
forall a. Monoid a => [a] -> a
mconcat ([[ErrorMsg]] -> [ErrorMsg]) -> [[ErrorMsg]] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ (Output -> [ErrorMsg]) -> [Output] -> [[ErrorMsg]]
forall a b. (a -> b) -> [a] -> [b]
map Output -> [ErrorMsg]
outputBody [Output]
os)
           ([Set ErrorMsg] -> Set ErrorMsg
forall a. Monoid a => [a] -> a
mconcat ([Set ErrorMsg] -> Set ErrorMsg) -> [Set ErrorMsg] -> Set ErrorMsg
forall a b. (a -> b) -> a -> b
$ (Output -> Set ErrorMsg) -> [Output] -> [Set ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Output -> Set ErrorMsg
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 :: forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either ErrorMsg (Partial, a)
runGenerator Interface
iface ComputedInterfaceData
computed Module
m Generator a
generator =
  let modName :: ErrorMsg
modName = Interface -> Module -> ErrorMsg
getModuleName Interface
iface Module
m
  in ((a, Output) -> (Partial, a))
-> Either ErrorMsg (a, Output) -> Either ErrorMsg (Partial, a)
forall a b. (a -> b) -> Either ErrorMsg a -> Either ErrorMsg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Output -> Partial) -> (Output, a) -> (Partial, a)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (ErrorMsg -> Output -> Partial
Partial ErrorMsg
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 ErrorMsg (a, Output) -> Either ErrorMsg (Partial, a))
-> Either ErrorMsg (a, Output) -> Either ErrorMsg (Partial, a)
forall a b. (a -> b) -> a -> b
$
     Except ErrorMsg (a, Output) -> Either ErrorMsg (a, Output)
forall e a. Except e a -> Either e a
runExcept (Except ErrorMsg (a, Output) -> Either ErrorMsg (a, Output))
-> Except ErrorMsg (a, Output) -> Either ErrorMsg (a, Output)
forall a b. (a -> b) -> a -> b
$
     (Except ErrorMsg (a, Output)
 -> (ErrorMsg -> Except ErrorMsg (a, Output))
 -> Except ErrorMsg (a, Output))
-> (ErrorMsg -> Except ErrorMsg (a, Output))
-> Except ErrorMsg (a, Output)
-> Except ErrorMsg (a, Output)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Except ErrorMsg (a, Output)
-> (ErrorMsg -> Except ErrorMsg (a, Output))
-> Except ErrorMsg (a, Output)
forall a.
ExceptT ErrorMsg Identity a
-> (ErrorMsg -> ExceptT ErrorMsg Identity a)
-> ExceptT ErrorMsg Identity a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (\ErrorMsg
msg -> ErrorMsg -> Except ErrorMsg (a, Output)
forall a. ErrorMsg -> ExceptT ErrorMsg Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Except ErrorMsg (a, Output))
-> ErrorMsg -> Except ErrorMsg (a, Output)
forall a b. (a -> b) -> a -> b
$ ErrorMsg
msg ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
".") (Except ErrorMsg (a, Output) -> Except ErrorMsg (a, Output))
-> Except ErrorMsg (a, Output) -> Except ErrorMsg (a, Output)
forall a b. (a -> b) -> a -> b
$
     WriterT Output (Except ErrorMsg) a -> Except ErrorMsg (a, Output)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Output (Except ErrorMsg) a -> Except ErrorMsg (a, Output))
-> WriterT Output (Except ErrorMsg) a
-> Except ErrorMsg (a, Output)
forall a b. (a -> b) -> a -> b
$ Generator a -> Env -> WriterT Output (Except ErrorMsg) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Generator a
generator (Env -> WriterT Output (Except ErrorMsg) a)
-> Env -> WriterT Output (Except ErrorMsg) a
forall a b. (a -> b) -> a -> b
$ Interface -> ComputedInterfaceData -> Module -> ErrorMsg -> Env
Env Interface
iface ComputedInterfaceData
computed Module
m ErrorMsg
modName

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

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

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

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

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

-- | Adds multiple exports to the current module.
addExports :: [HsExport] -> Generator ()
addExports :: [ErrorMsg] -> Generator ()
addExports [ErrorMsg]
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 = 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 = imports }

-- | Adds a Haskell language extension to the current module.
addExtension :: String -> Generator ()
addExtension :: ErrorMsg -> Generator ()
addExtension ErrorMsg
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 = S.singleton 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
$c== :: SayExportMode -> SayExportMode -> Bool
== :: SayExportMode -> SayExportMode -> Bool
$c/= :: SayExportMode -> SayExportMode -> Bool
/= :: SayExportMode -> SayExportMode -> Bool
Eq, Int -> SayExportMode -> ErrorMsg -> ErrorMsg
[SayExportMode] -> ErrorMsg -> ErrorMsg
SayExportMode -> ErrorMsg
(Int -> SayExportMode -> ErrorMsg -> ErrorMsg)
-> (SayExportMode -> ErrorMsg)
-> ([SayExportMode] -> ErrorMsg -> ErrorMsg)
-> Show SayExportMode
forall a.
(Int -> a -> ErrorMsg -> ErrorMsg)
-> (a -> ErrorMsg) -> ([a] -> ErrorMsg -> ErrorMsg) -> Show a
$cshowsPrec :: Int -> SayExportMode -> ErrorMsg -> ErrorMsg
showsPrec :: Int -> SayExportMode -> ErrorMsg -> ErrorMsg
$cshow :: SayExportMode -> ErrorMsg
show :: SayExportMode -> ErrorMsg
$cshowList :: [SayExportMode] -> ErrorMsg -> ErrorMsg
showList :: [SayExportMode] -> ErrorMsg -> ErrorMsg
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 :: ErrorMsg -> Generator ()
sayLn ErrorMsg
x =
  if Char
'\n' Char -> ErrorMsg -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ErrorMsg
x
  then ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
inFunction ErrorMsg
"sayLn" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
       [ErrorMsg
"Refusing to speak '\n', received ", ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ErrorMsg
x, ErrorMsg
" (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 = [x] }

-- | Outputs multiple words to form a line of Haskell code (effectively @saysLn
-- = sayLn . concat@).
saysLn :: [String] -> Generator ()
saysLn :: [ErrorMsg] -> Generator ()
saysLn = ErrorMsg -> Generator ()
sayLn (ErrorMsg -> Generator ())
-> ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrorMsg] -> ErrorMsg
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 = ErrorMsg -> Generator ()
sayLn ErrorMsg
""

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

-- | Runs the given action, indenting all code output by the action N spaces.
indentSpaces :: Int -> Generator a -> Generator a
indentSpaces :: forall a. Int -> Generator a -> Generator a
indentSpaces Int
n = (Output -> Output)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) a
-> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor ((Output -> Output)
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) a)
-> (Output -> Output)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) a
-> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall a b. (a -> b) -> a -> b
$ \Output
o -> Output
o { outputBody = map (\ErrorMsg
x -> ErrorMsg
indentation ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
x) $ outputBody o }
  where indentation :: ErrorMsg
indentation = Int -> Char -> ErrorMsg
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
  ErrorMsg -> Generator ()
sayLn ErrorMsg
"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
      ErrorMsg -> Generator ()
sayLn ErrorMsg
"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 = ErrorMsg -> Generator Module -> Generator Module
forall a. ErrorMsg -> Generator a -> Generator a
inFunction ErrorMsg
"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 (ErrorMsg -> Generator Module
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator Module) -> ErrorMsg -> Generator Module
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Couldn't find module for " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ExtName
extName ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++
              ErrorMsg
" (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 ErrorMsg
getModuleImportName Module
m = do
  Interface
iface <- Generator Interface
askInterface
  Generator ErrorMsg -> Maybe ErrorMsg -> Generator ErrorMsg
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (ErrorMsg -> Generator ErrorMsg
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Couldn't find a Haskell import name for " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ Module -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Module
m ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++
              ErrorMsg
" (is it included in the interface's module list?)") (Maybe ErrorMsg -> Generator ErrorMsg)
-> Maybe ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
    Module -> Map Module ErrorMsg -> Maybe ErrorMsg
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
m (Map Module ErrorMsg -> Maybe ErrorMsg)
-> Map Module ErrorMsg -> Maybe ErrorMsg
forall a b. (a -> b) -> a -> b
$
    Interface -> Map Module ErrorMsg
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 ErrorMsg)
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 ErrorMsg -> Generator (Maybe ErrorMsg)
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ErrorMsg
forall a. Maybe a
Nothing
    else do Interface
iface <- Generator Interface
askInterface
            let fullName :: ErrorMsg
fullName = Interface -> Module -> ErrorMsg
getModuleName Interface
iface Module
owningModule
            ErrorMsg
qualifiedName <- Module -> Generator ErrorMsg
getModuleImportName Module
owningModule
            HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsQualifiedImport ErrorMsg
fullName ErrorMsg
qualifiedName
            Maybe ErrorMsg -> Generator (Maybe ErrorMsg)
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ErrorMsg -> Generator (Maybe ErrorMsg))
-> Maybe ErrorMsg -> Generator (Maybe ErrorMsg)
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
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 -> ErrorMsg -> Generator ErrorMsg
addExtNameModule ExtName
extName ErrorMsg
hsEntity = do
  Maybe ErrorMsg
maybeImportName <- ExtName -> Generator (Maybe ErrorMsg)
importHsModuleForExtName ExtName
extName
  ErrorMsg -> Generator ErrorMsg
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ case Maybe ErrorMsg
maybeImportName of
    Maybe ErrorMsg
Nothing -> ErrorMsg
hsEntity  -- Same module.
    Just ErrorMsg
importName -> [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
importName, ErrorMsg
".", ErrorMsg
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 ErrorMsg
toHsTypeName Constness
cst ExtName
extName =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
inFunction ErrorMsg
"toHsTypeName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
addExtNameModule ExtName
extName (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Constness -> ExtName -> ErrorMsg
toHsTypeName' Constness
cst ExtName
extName

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

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

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

-- | Returns a distinct argument variable name for each nonnegative number.
toArgName :: Int -> String
toArgName :: Int -> ErrorMsg
toArgName = (ErrorMsg
"arg'" ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++) (ErrorMsg -> ErrorMsg) -> (Int -> ErrorMsg) -> Int -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
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
$c== :: HsTypeSide -> HsTypeSide -> Bool
== :: HsTypeSide -> HsTypeSide -> Bool
$c/= :: HsTypeSide -> HsTypeSide -> Bool
/= :: HsTypeSide -> HsTypeSide -> Bool
Eq, Int -> HsTypeSide -> ErrorMsg -> ErrorMsg
[HsTypeSide] -> ErrorMsg -> ErrorMsg
HsTypeSide -> ErrorMsg
(Int -> HsTypeSide -> ErrorMsg -> ErrorMsg)
-> (HsTypeSide -> ErrorMsg)
-> ([HsTypeSide] -> ErrorMsg -> ErrorMsg)
-> Show HsTypeSide
forall a.
(Int -> a -> ErrorMsg -> ErrorMsg)
-> (a -> ErrorMsg) -> ([a] -> ErrorMsg -> ErrorMsg) -> Show a
$cshowsPrec :: Int -> HsTypeSide -> ErrorMsg -> ErrorMsg
showsPrec :: Int -> HsTypeSide -> ErrorMsg -> ErrorMsg
$cshow :: HsTypeSide -> ErrorMsg
show :: HsTypeSide -> ErrorMsg
$cshowList :: [HsTypeSide] -> ErrorMsg -> ErrorMsg
showList :: [HsTypeSide] -> ErrorMsg -> ErrorMsg
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 =
  ErrorMsg -> Generator HsType -> Generator HsType
forall a. ErrorMsg -> Generator a -> Generator a
withErrorContext ([ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"converting ", Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
t, ErrorMsg
" to ", HsTypeSide -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show HsTypeSide
side, ErrorMsg
" 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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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.
      ErrorMsg
typeName <- Constness -> ExtName -> Generator ErrorMsg
toHsTypeName Constness
Nonconst (ExtName -> Generator ErrorMsg) -> ExtName -> Generator ErrorMsg
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
typeName
      case HsTypeSide
side of
        HsTypeSide
HsCSide -> do
          HsImportSet -> Generator ()
addImports HsImportSet
hsImportForForeign
          HsType -> Generator HsType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"HoppyF.Ptr") HsType
dataType
        HsTypeSide
HsHsSide -> HsType -> Generator HsType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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.
      ErrorMsg
typeName <- Constness -> ExtName -> Generator ErrorMsg
toHsTypeName Constness
Const (ExtName -> Generator ErrorMsg) -> ExtName -> Generator ErrorMsg
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
typeName
      case HsTypeSide
side of
        HsTypeSide
HsCSide -> do
          HsImportSet -> Generator ()
addImports HsImportSet
hsImportForForeign
          HsType -> Generator HsType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"HoppyF.Ptr") HsType
dataType
        HsTypeSide
HsHsSide -> HsType -> Generator HsType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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 ErrorMsg)) [HsType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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 a b. (a -> b -> b) -> b -> [a] -> b
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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 ->
          ErrorMsg -> Generator HsType
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator HsType) -> ErrorMsg -> Generator HsType
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ErrorMsg
"Expected a Haskell type for ", Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls, ErrorMsg
" 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
_ -> ErrorMsg -> Generator HsType
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator HsType) -> ErrorMsg -> Generator HsType
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Type -> ErrorMsg
tToGcInvalidFormErrorMessage Maybe ErrorMsg
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 -> ErrorMsg -> Generator HsType
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator HsType) -> ErrorMsg -> Generator HsType
forall a b. (a -> b) -> a -> b
$ ConversionSpec -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ConversionSpec
s ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" 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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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 :: forall a. Pretty a => a -> ErrorMsg
prettyPrint = ErrorMsg -> ErrorMsg
collapseSpaces (ErrorMsg -> ErrorMsg) -> (a -> ErrorMsg) -> a -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ErrorMsg -> ErrorMsg
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (ErrorMsg -> ErrorMsg) -> (a -> ErrorMsg) -> a -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
P.prettyPrint
  where collapseSpaces :: ErrorMsg -> ErrorMsg
collapseSpaces (Char
' ':ErrorMsg
xs) = Char
' ' Char -> ErrorMsg -> ErrorMsg
forall a. a -> [a] -> [a]
: ErrorMsg -> ErrorMsg
collapseSpaces ((Char -> Bool) -> ErrorMsg -> ErrorMsg
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ErrorMsg
xs)
        collapseSpaces (Char
x:ErrorMsg
xs) = Char
x Char -> ErrorMsg -> ErrorMsg
forall a. a -> [a] -> [a]
: ErrorMsg -> ErrorMsg
collapseSpaces ErrorMsg
xs
        collapseSpaces [] = []