module Foreign.Hoppy.Generator.Language.Haskell (
getModuleName,
toModuleName,
Partial (..),
Output (..),
Generator,
runGenerator,
evalGenerator,
execGenerator,
renderPartial,
withErrorContext,
inFunction,
HsExport,
addExport,
addExport',
addExports,
addImports,
importHsModuleForExtName,
sayLn,
saysLn,
ln,
indent,
sayLet,
toHsEnumTypeName,
toHsEnumCtorName,
toHsBitspaceTypeName,
toHsBitspaceValueName,
toHsBitspaceToNumName,
toHsBitspaceClassName,
toHsBitspaceFromValueName,
toHsValueClassName,
toHsWithValuePtrName,
toHsPtrClassName,
toHsCastMethodName,
toHsDownCastClassName,
toHsDownCastMethodName,
toHsCastPrimitiveName,
toHsConstCastFnName,
toHsDataTypeName,
toHsClassDeleteFnName,
toHsMethodName,
toHsMethodName',
toHsCallbackCtorName,
toHsFnName,
toArgName,
HsTypeSide (..),
cppTypeToHsTypeAndUse,
prettyPrint,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Arrow (first)
import Control.Monad (when)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except (Except, catchError, runExcept, throwError)
#else
import Control.Monad.Error (catchError, throwError)
#endif
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Writer (WriterT, censor, runWriterT, tell)
import Data.Char (toUpper)
import Data.Foldable (forM_)
import Data.Function (on)
import Data.Functor (($>))
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.Tuple (swap)
import Foreign.Hoppy.Generator.Common (capitalize, lowerFirst)
import Foreign.Hoppy.Generator.Spec
import qualified Language.Haskell.Pretty as P
import Language.Haskell.Syntax (
HsName (HsIdent),
HsQName (Special, UnQual),
HsSpecialCon (HsUnitCon),
HsType (HsTyApp, HsTyCon, HsTyFun),
)
getModuleName :: Interface -> Module -> String
getModuleName interface m =
intercalate "." $
interfaceHaskellModuleBase interface ++
fromMaybe [toModuleName $ moduleName m] (moduleHaskellName m)
toModuleName :: String -> String
toModuleName (x:xs) = toUpper x : xs
toModuleName "" = ""
renderImports :: HsImportSet -> [String]
renderImports = map renderModuleImport . M.assocs . getHsImportSet
where
renderModuleImport :: (HsImportKey, HsImportSpecs) -> String
renderModuleImport (key, specs) =
let moduleName = hsImportModule key
maybeQualifiedName = hsImportQualifiedName key
isQual = isJust maybeQualifiedName
importPrefix = if hsImportSource specs
then "import {-# SOURCE #-} "
else "import "
importQualifiedPrefix =
if hsImportSource specs
then "import {-# SOURCE #-} qualified "
else "import qualified "
in case getHsImportSpecs specs of
Nothing -> case maybeQualifiedName of
Nothing -> importPrefix ++ moduleName
Just qualifiedName ->
concat [importQualifiedPrefix, moduleName, " as ", qualifiedName]
Just specMap ->
let specWords :: [String]
specWords = concatWithCommas $ map renderSpecAsWords $ M.assocs specMap
singleLineImport :: String
singleLineImport =
concat $
(if isQual then importQualifiedPrefix else importPrefix) :
moduleName : " (" : intersperse " " specWords ++
case maybeQualifiedName of
Nothing -> [")"]
Just qualifiedName -> [") as ", qualifiedName]
in if null $ drop maxLineLength singleLineImport
then singleLineImport
else intercalate "\n" $
(importPrefix ++ moduleName ++ " (") :
groupWordsIntoLines specWords ++
case maybeQualifiedName of
Nothing -> [" )"]
Just qualifiedName -> [" ) as " ++ qualifiedName]
renderSpecAsWords :: (HsImportName, HsImportVal) -> [String]
renderSpecAsWords (name, val) = case val of
HsImportVal -> [name]
HsImportValSome parts -> case parts of
[] -> [name ++ " ()"]
[part] -> [concat [name, " (", part, ")"]]
part0:parts -> let (parts', [partN]) = splitAt (length parts 1) parts
in concat [name, " (", part0, ","] :
map (++ ",") parts' ++
[partN ++ ")"]
HsImportValAll -> [name ++ " (..)"]
concatWithCommas :: [[String]] -> [String]
concatWithCommas [] = []
concatWithCommas ss =
let (ss', ssLast@[_]) = splitAt (length ss 1) ss
in concat $ map (onLast (++ ",")) ss' ++ ssLast
onLast :: (a -> a) -> [a] -> [a]
onLast _ [] = []
onLast f xs = let (xs', [x]) = splitAt (length xs 1) xs
in xs' ++ [f x]
groupWordsIntoLines :: [String] -> [String]
groupWordsIntoLines [] = []
groupWordsIntoLines words =
let (wordCount, line, _) =
last $
takeWhile (\(wordCount, _, len) -> wordCount <= 1 || len <= maxLineLength) $
scanl (\(wordCount, acc, len) word ->
(wordCount + 1,
concat [acc, " ", word],
len + 1 + length word))
(0, "", 0)
words
in line : groupWordsIntoLines (drop wordCount words)
maxLineLength :: Int
maxLineLength = 100
#if MIN_VERSION_mtl(2,2,1)
type Generator = ReaderT Env (WriterT Output (Except ErrorMsg))
#else
type Generator = ReaderT Env (WriterT Output (Either ErrorMsg))
#endif
data Env = Env
{ envInterface :: Interface
, envModuleName :: String
}
askInterface :: Generator Interface
askInterface = envInterface <$> ask
askModuleName :: Generator String
askModuleName = envModuleName <$> ask
data Partial = Partial
{ partialModuleHsName :: String
, partialOutput :: Output
}
instance Eq Partial where
(==) = (==) `on` partialModuleHsName
instance Ord Partial where
compare = compare `on` partialModuleHsName
data Output = Output
{ outputExports :: [HsExport]
, outputImports :: HsImportSet
, outputBody :: [String]
}
instance Monoid Output where
mempty = Output mempty mempty mempty
(Output e i b) `mappend` (Output e' i' b') =
Output (e `mappend` e') (i `mappend` i') (b `mappend` b')
mconcat os =
Output (mconcat $ map outputExports os)
(mconcat $ map outputImports os)
(mconcat $ map outputBody os)
runGenerator :: Interface -> String -> Generator a -> Either ErrorMsg (Partial, a)
runGenerator iface modName generator =
fmap (first (Partial modName) . swap) $
#if MIN_VERSION_mtl(2,2,1)
runExcept $
#endif
flip catchError (\msg -> throwError $ msg ++ ".") $
runWriterT $ runReaderT generator $ Env iface modName
evalGenerator :: Interface -> String -> Generator a -> Either ErrorMsg a
evalGenerator iface modName =
fmap snd . runGenerator iface modName
execGenerator :: Interface -> String -> Generator a -> Either ErrorMsg Partial
execGenerator iface modName =
fmap fst . runGenerator iface modName
renderPartial :: Partial -> String
renderPartial partial =
let modName = partialModuleHsName partial
output = partialOutput partial
imports = outputImports output
body =
intercalate "\n" $ concat
[ [ "---------- GENERATED FILE, EDITS WILL BE LOST ----------"
, ""
]
, case outputExports output of
[] -> [concat ["module ", modName, " where"]]
exports ->
concat ["module ", modName, " ("] :
map (\export -> concat [" ", export, ","]) exports ++
[" ) where"]
, if M.null $ getHsImportSet imports
then []
else "" : renderImports imports
, [""]
, outputBody output
]
in body
withErrorContext :: String -> Generator a -> Generator a
withErrorContext msg' action = catchError action $ \msg -> throwError $ concat [msg, "; ", msg']
inFunction :: String -> Generator a -> Generator a
inFunction fnName = withErrorContext $ "in " ++ fnName
type HsExport = String
addExport :: HsExport -> Generator ()
addExport = addExports . (:[])
addExport' :: HsExport -> Generator ()
addExport' x = addExports [x ++ " (..)"]
addExports :: [HsExport] -> Generator ()
addExports exports = tell $ mempty { outputExports = exports }
addImports :: HsImportSet -> Generator ()
addImports imports = tell mempty { outputImports = imports }
importHsModuleForExtName :: ExtName -> Generator ()
importHsModuleForExtName extName = inFunction "importHsModuleForExtName" $ do
iface <- askInterface
case M.lookup extName $ interfaceNamesToModules iface of
Just ownerModule -> do
let ownerModuleName = getModuleName iface ownerModule
currentModuleName <- askModuleName
when (currentModuleName /= ownerModuleName) $
addImports $ hsWholeModuleImport ownerModuleName
Nothing ->
throwError $ concat
["Couldn't find module for ", show extName,
" (maybe you forgot to include it in an exports list?)"]
sayLn :: String -> Generator ()
sayLn x =
if '\n' `elem` x
then inFunction "sayLn" $ throwError $ concat
["Refusing to speak '\n', received ", show x, " (use (mapM_ sayLn . lines) instead)"]
else tell $ mempty { outputBody = [x] }
saysLn :: [String] -> Generator ()
saysLn = sayLn . concat
ln :: Generator ()
ln = sayLn ""
indent :: Generator a -> Generator a
indent = censor $ \o -> o { outputBody = map (\x -> ' ':' ':x) $ outputBody o }
sayLet :: [Generator ()] -> Maybe (Generator ()) -> Generator ()
sayLet bindings maybeBody = do
sayLn "let"
indent $ sequence_ bindings
forM_ maybeBody $ \body ->
indent $ do
sayLn "in"
indent body
toHsTypeName :: Constness -> ExtName -> String
toHsTypeName cst extName =
(case cst of
Const -> (++ "Const")
Nonconst -> id) $
case fromExtName extName of
x:xs -> toUpper x:xs
[] -> []
toHsEnumTypeName :: CppEnum -> String
toHsEnumTypeName = toHsTypeName Nonconst . enumExtName
toHsEnumCtorName :: CppEnum -> [String] -> String
toHsEnumCtorName enum words =
concat $ toHsEnumTypeName enum : "_" : map capitalize words
toHsBitspaceTypeName :: Bitspace -> String
toHsBitspaceTypeName = toHsTypeName Nonconst . bitspaceExtName
toHsBitspaceValueName :: Bitspace -> [String] -> String
toHsBitspaceValueName bitspace words =
lowerFirst $ concat $ toHsBitspaceTypeName bitspace : "_" : map capitalize words
toHsBitspaceToNumName :: Bitspace -> String
toHsBitspaceToNumName = ("from" ++) . toHsBitspaceTypeName
toHsBitspaceClassName :: Bitspace -> String
toHsBitspaceClassName bitspace = 'I':'s':toHsBitspaceTypeName bitspace
toHsBitspaceFromValueName :: Bitspace -> String
toHsBitspaceFromValueName = ("to" ++) . toHsBitspaceTypeName
toHsValueClassName :: Class -> String
toHsValueClassName cls = toHsDataTypeName Nonconst cls ++ "Value"
toHsWithValuePtrName :: Class -> String
toHsWithValuePtrName cls = concat ["with", toHsDataTypeName Nonconst cls, "Ptr"]
toHsPtrClassName :: Constness -> Class -> String
toHsPtrClassName cst cls = toHsDataTypeName cst cls ++ "Ptr"
toHsCastMethodName :: Constness -> Class -> String
toHsCastMethodName cst cls = "to" ++ toHsDataTypeName cst cls
toHsDownCastClassName :: Constness -> Class -> String
toHsDownCastClassName cst cls =
concat [toHsDataTypeName Nonconst cls,
"Super",
case cst of
Const -> "Const"
Nonconst -> ""]
toHsDownCastMethodName :: Constness -> Class -> String
toHsDownCastMethodName cst cls = "downTo" ++ toHsDataTypeName cst cls
toHsCastPrimitiveName :: Class -> Class -> String
toHsCastPrimitiveName from to =
concat ["cast", toHsDataTypeName Nonconst from, "To", toHsDataTypeName Nonconst to]
toHsConstCastFnName :: Constness -> Class -> String
toHsConstCastFnName cst cls =
concat ["cast", toHsDataTypeName Nonconst cls,
case cst of
Const -> "ToConst"
Nonconst -> "ToNonconst"]
toHsDataTypeName :: Constness -> Class -> String
toHsDataTypeName cst cls = toHsTypeName cst $ classExtName cls
toHsClassDeleteFnName :: Class -> String
toHsClassDeleteFnName cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName Nonconst cls
toHsMethodName :: Class -> Method -> String
toHsMethodName cls method = toHsMethodName' cls $ fromExtName $ methodExtName method
toHsMethodName' :: IsFnName String name => Class -> name -> String
toHsMethodName' cls methodName =
lowerFirst $
concat [fromExtName $ classExtName cls, "_",
case toFnName methodName of
FnName name -> name
FnOp op -> fromExtName $ operatorPreferredExtName op]
toHsCallbackCtorName :: Callback -> String
toHsCallbackCtorName = toHsFnName . callbackExtName
toHsFnName :: ExtName -> String
toHsFnName = lowerFirst . fromExtName
toArgName :: Int -> String
toArgName = ("arg'" ++) . show
data HsTypeSide =
HsCSide
| HsHsSide
deriving (Eq, Show)
cppTypeToHsTypeAndUse :: HsTypeSide -> Type -> Generator HsType
cppTypeToHsTypeAndUse side t =
withErrorContext (concat ["converting ", show t, " to ", show side, " type"]) $
case t of
TVoid -> return $ HsTyCon $ Special HsUnitCon
TBool -> case side of
HsCSide -> addImports hsImportForRuntime $> HsTyCon (UnQual $ HsIdent "HoppyFHR.CBool")
HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Bool")
TChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CChar")
TUChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUChar")
TShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CShort")
TUShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUShort")
TInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CInt")
TUInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUInt")
TLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLong")
TULong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULong")
TLLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLLong")
TULLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULLong")
TFloat -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CFloat")
TDouble -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CDouble")
TInt8 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int8")
TInt16 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int16")
TInt32 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int32")
TInt64 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int64")
TWord8 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word8")
TWord16 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word16")
TWord32 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word32")
TWord64 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word64")
TPtrdiff -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CPtrdiff")
TSize -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CSize")
TSSize -> addImports hsImportForSystemPosixTypes $> HsTyCon (UnQual $ HsIdent "HoppySPT.CSsize")
TEnum e -> HsTyCon . UnQual . HsIdent <$> case side of
HsCSide -> addImports hsImportForForeignC $> "HoppyFC.CInt"
HsHsSide -> importHsModuleForExtName (enumExtName e) $> toHsEnumTypeName e
TBitspace b -> case side of
HsCSide -> cppTypeToHsTypeAndUse side $ bitspaceType b
HsHsSide -> importHsModuleForExtName (bitspaceExtName b) $>
HsTyCon (UnQual $ HsIdent $ toHsBitspaceTypeName b)
TPtr (TObj cls) ->
importHsModuleForExtName (classExtName cls) $>
HsTyCon (UnQual $ HsIdent $ toHsTypeName Nonconst $ classExtName cls)
TPtr (TConst (TObj cls)) ->
importHsModuleForExtName (classExtName cls) $>
HsTyCon (UnQual $ HsIdent $ toHsTypeName Const $ classExtName cls)
TPtr (TFn paramTypes retType) -> do
paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes
retHsType <- cppTypeToHsTypeAndUse side retType
sideFn <- case side of
HsCSide -> do addImports hsImportForForeign
return $ HsTyApp $ HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr"
HsHsSide -> return id
addImports hsImportForPrelude
return $ sideFn $
foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes
TPtr t' -> do
addImports hsImportForForeign
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") <$> cppTypeToHsTypeAndUse HsCSide t'
TRef t' -> cppTypeToHsTypeAndUse side $ TPtr t'
TFn paramTypes retType -> do
paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes
retHsType <- cppTypeToHsTypeAndUse side retType
addImports hsImportForPrelude
return $
foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes
TCallback cb -> do
hsType <- cppTypeToHsTypeAndUse side $ callbackToTFn cb
case side of
HsHsSide -> return hsType
HsCSide -> do
addImports hsImportForRuntime
return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsType
TObj cls -> case side of
HsCSide -> cppTypeToHsTypeAndUse side $ TPtr $ TConst t
HsHsSide ->
case classHaskellConversionType <$> classHaskellConversion (classConversion cls) of
Nothing ->
throwError $ concat
["Expected a Haskell type for ", show cls, " but there isn't one"]
Just t' -> t'
TObjToHeap cls -> cppTypeToHsTypeAndUse side $ TPtr $ TObj cls
TConst t' -> cppTypeToHsTypeAndUse side t'
prettyPrint :: P.Pretty a => a -> String
prettyPrint = filter (/= '\n') . P.prettyPrint