{-# LANGUAGE CPP #-}
module Foreign.Hoppy.Generator.Language.Haskell (
Managed (..),
getModuleName,
toModuleName,
Partial (..),
Output (..),
Generator,
runGenerator,
evalGenerator,
execGenerator,
renderPartial,
Env (..),
askInterface,
askComputedInterfaceData,
askModule,
askModuleName,
getModuleForExtName,
withErrorContext,
inFunction,
HsExport,
addExport,
addExport',
addExports,
addImports,
addExtension,
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),
)
data Managed =
Unmanaged
| Managed
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)
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)
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
""
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
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]
renderSpecAsWords :: (HsImportName, HsImportVal) -> [String]
renderSpecAsWords :: (String, HsImportVal) -> [String]
renderSpecAsWords (String
name, HsImportVal
val) = case HsImportVal
val of
HsImportVal
HsImportVal -> [String
name]
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
" (..)"]
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
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]
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
type Generator = ReaderT Env (WriterT Output (Except ErrorMsg))
data Env = Env
{ Env -> Interface
envInterface :: Interface
, Env -> ComputedInterfaceData
envComputedInterfaceData :: ComputedInterfaceData
, Env -> Module
envModule :: Module
, Env -> String
envModuleName :: String
}
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
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
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
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
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
data Partial = Partial
{ Partial -> String
partialModuleHsName :: String
, 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
data Output = Output
{ Output -> [String]
outputExports :: [HsExport]
, Output -> HsImportSet
outputImports :: HsImportSet
, Output -> [String]
outputBody :: [String]
, Output -> Set String
outputExtensions :: S.Set String
}
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)
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
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
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
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
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']
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
type HsExport = String
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' :: HsExport -> Generator ()
addExport' :: String -> Generator ()
addExport' String
x = [String] -> Generator ()
addExports [String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (..)"]
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 }
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 }
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 }
data SayExportMode =
SayExportForeignImports
| SayExportDecls
| SayExportBoot
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)
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] }
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
ln :: Generator ()
ln :: Generator ()
ln = String -> Generator ()
sayLn String
""
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 }
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
' '
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 ->
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
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
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
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
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
Just String
importName -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
importName, String
".", String
hsEntity]
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
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
[] -> []
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
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
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
data HsTypeSide =
HsCSide
| HsHsSide
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)
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
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
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
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'
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'
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
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
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]
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 [] = []