{-# LANGUAGE CPP #-}
module Foreign.Hoppy.Generator.Language.Haskell (
Managed (..),
getModuleName,
toModuleName,
Partial (..),
Output (..),
Generator,
runGenerator,
evalGenerator,
execGenerator,
renderPartial,
Env (..),
askInterface,
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 {-# 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 (Bounded, Enum, Eq, Ord)
getModuleName :: Interface -> Module -> String
getModuleName iface m =
intercalate "." $
interfaceHaskellModuleBase iface ++
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 modName = 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 ++ modName
Just qualifiedName ->
concat [importQualifiedPrefix, modName, " as ", qualifiedName]
Just specMap ->
let specWords :: [String]
specWords = concatWithCommas $ map renderSpecAsWords $ M.assocs specMap
singleLineImport :: String
singleLineImport =
concat $
(if isQual then importQualifiedPrefix else importPrefix) :
modName : " (" : intersperse " " specWords ++
case maybeQualifiedName of
Nothing -> [")"]
Just qualifiedName -> [") as ", qualifiedName]
in if null $ drop maxLineLength singleLineImport
then singleLineImport
else intercalate "\n" $
(importPrefix ++ modName ++ " (") :
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 wordList =
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)
wordList
in line : groupWordsIntoLines (drop wordCount wordList)
maxLineLength :: Int
maxLineLength = 100
type Generator = ReaderT Env (WriterT Output (Except ErrorMsg))
data Env = Env
{ envInterface :: Interface
, envModule :: Module
, envModuleName :: String
}
askInterface :: Generator Interface
askInterface = asks envInterface
askModule :: Generator Module
askModule = asks envModule
askModuleName :: Generator String
askModuleName = asks envModuleName
getModuleForExtName :: ExtName -> Generator Module
getModuleForExtName extName = inFunction "getModuleForExtName" $ do
iface <- askInterface
case M.lookup extName $ interfaceNamesToModules iface of
Just m -> return m
Nothing -> throwError $ "Can't find module for " ++ show extName
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]
, outputExtensions :: S.Set String
}
instance Sem.Semigroup Output where
(Output e i b x) <> (Output e' i' b' x') =
Output (e <> e') (i <> i') (b <> b') (x <> x')
instance Monoid Output where
mempty = Output mempty mempty mempty mempty
mappend = (<>)
mconcat os =
Output (mconcat $ map outputExports os)
(mconcat $ map outputImports os)
(mconcat $ map outputBody os)
(mconcat $ map outputExtensions os)
runGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg (Partial, a)
runGenerator iface m generator =
let modName = getModuleName iface m
in fmap (first (Partial modName) . swap) $
runExcept $
flip catchError (\msg -> throwError $ msg ++ ".") $
runWriterT $ runReaderT generator $ Env iface m modName
evalGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg a
evalGenerator iface m = fmap snd . runGenerator iface m
execGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg Partial
execGenerator iface m = fmap fst . runGenerator iface m
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 S.elems $ outputExtensions output of
[] -> []
extensions -> [ concat $ "{-# LANGUAGE " : intersperse ", " extensions ++ [" #-}"]
, ""
]
, 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 }
addExtension :: String -> Generator ()
addExtension extensionName =
tell $ mempty { outputExtensions = S.singleton extensionName }
data SayExportMode =
SayExportForeignImports
| SayExportDecls
| SayExportBoot
deriving (Eq, Show)
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 }
indentSpaces :: Int -> Generator a -> Generator a
indentSpaces n = censor $ \o -> o { outputBody = map (\x -> indentation ++ x) $ outputBody o }
where indentation = replicate n ' '
sayLet :: [Generator ()] -> Maybe (Generator ()) -> Generator ()
sayLet bindings maybeBody = do
sayLn "let"
indent $ sequence_ bindings
forM_ maybeBody $ \body ->
indent $ do
sayLn "in"
indent body
getExtNameModule :: ExtName -> Generator Module
getExtNameModule extName = inFunction "getExtNameModule" $ do
iface <- askInterface
fromMaybeM (throwError $ "Couldn't find module for " ++ show extName ++
" (is it included in a module's export list?)") $
M.lookup extName $
interfaceNamesToModules iface
getModuleImportName :: Module -> Generator String
getModuleImportName m = do
iface <- askInterface
fromMaybeM (throwError $ "Couldn't find a Haskell import name for " ++ show m ++
" (is it included in the interface's module list?)") $
M.lookup m $
interfaceHaskellModuleImportNames iface
importHsModuleForExtName :: ExtName -> Generator (Maybe String)
importHsModuleForExtName extName = do
currentModule <- askModule
owningModule <- getExtNameModule extName
if currentModule == owningModule
then return Nothing
else do iface <- askInterface
let fullName = getModuleName iface owningModule
qualifiedName <- getModuleImportName owningModule
addImports $ hsQualifiedImport fullName qualifiedName
return $ Just qualifiedName
addExtNameModule :: ExtName -> String -> Generator String
addExtNameModule extName hsEntity = do
maybeImportName <- importHsModuleForExtName extName
return $ case maybeImportName of
Nothing -> hsEntity
Just importName -> concat [importName, ".", hsEntity]
toHsTypeName :: Constness -> ExtName -> Generator String
toHsTypeName cst extName =
inFunction "toHsTypeName" $
addExtNameModule extName $ toHsTypeName' cst extName
toHsTypeName' :: Constness -> ExtName -> String
toHsTypeName' cst extName =
(case cst of
Const -> (++ "Const")
Nonconst -> id) $
case fromExtName extName of
x:xs -> toUpper x:xs
[] -> []
toHsFnName :: ExtName -> Generator String
toHsFnName extName =
inFunction "toHsFnName" $
addExtNameModule extName $ toHsFnName' extName
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
Internal_TVoid -> return $ HsTyCon $ Special HsUnitCon
Internal_TPtr (Internal_TObj cls) -> do
typeName <- toHsTypeName Nonconst $ classExtName cls
let dataType = HsTyCon $ UnQual $ HsIdent typeName
case side of
HsCSide -> do
addImports hsImportForForeign
return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") dataType
HsHsSide -> return dataType
Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> do
typeName <- toHsTypeName Const $ classExtName cls
let dataType = HsTyCon $ UnQual $ HsIdent typeName
case side of
HsCSide -> do
addImports hsImportForForeign
return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") dataType
HsHsSide -> return dataType
Internal_TPtr fn@(Internal_TFn {}) -> do
addImports hsImportForForeign
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") <$> cppTypeToHsTypeAndUse HsCSide fn
Internal_TPtr t' -> do
addImports hsImportForForeign
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") <$> cppTypeToHsTypeAndUse HsCSide t'
Internal_TRef t' -> cppTypeToHsTypeAndUse side $ ptrT t'
Internal_TFn params retType -> do
paramHsTypes <- mapM (cppTypeToHsTypeAndUse side . parameterType) params
retHsType <- cppTypeToHsTypeAndUse side retType
addImports hsImportForPrelude
return $
foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes
Internal_TObj cls -> case side of
HsCSide -> cppTypeToHsTypeAndUse side $ ptrT $ constT t
HsHsSide -> case classHaskellConversionType $ getClassHaskellConversion cls of
Just typeGen -> typeGen
Nothing ->
throwError $ concat
["Expected a Haskell type for ", show cls, " but there isn't one"]
Internal_TObjToHeap cls -> cppTypeToHsTypeAndUse side $ ptrT $ objT cls
Internal_TToGc t' -> case t' of
Internal_TRef _ -> cppTypeToHsTypeAndUse side t'
Internal_TPtr _ -> cppTypeToHsTypeAndUse side t'
Internal_TObj cls -> cppTypeToHsTypeAndUse side $ ptrT $ objT cls
_ -> throwError $ tToGcInvalidFormErrorMessage Nothing t'
Internal_TManual s -> case conversionSpecHaskell s of
Just h -> case side of
HsHsSide -> conversionSpecHaskellHsType h
HsCSide -> fromMaybe (conversionSpecHaskellHsType h) $
conversionSpecHaskellCType h
Nothing -> throwError $ show s ++ " defines no Haskell conversion"
Internal_TConst t' -> cppTypeToHsTypeAndUse side t'
getClassHaskellConversion :: Class -> ClassHaskellConversion
getClassHaskellConversion = classHaskellConversion . classConversion
getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers
getEffectiveExceptionHandlers handlers = do
ifaceHandlers <- interfaceExceptionHandlers <$> askInterface
moduleHandlers <- getExceptionHandlers <$> askModule
return $ mconcat [handlers, moduleHandlers, ifaceHandlers]
prettyPrint :: P.Pretty a => a -> String
prettyPrint = collapseSpaces . filter (/= '\n') . P.prettyPrint
where collapseSpaces (' ':xs) = ' ' : collapseSpaces (dropWhile (== ' ') xs)
collapseSpaces (x:xs) = x : collapseSpaces xs
collapseSpaces [] = []