module Language.Modulo.Haskell (
HaskellStyle(..),
stdHaskellStyle,
printModuleHaskell,
renderModuleHaskell,
printModuleHaskellStyle,
renderModuleHaskellStyle
) where
import Data.Default
import Data.Foldable (toList)
import Data.Semigroup
import Data.Char (chr)
import Data.Text (pack)
import Data.String
import Language.Haskell.Syntax hiding (Module)
import Language.Haskell.Pretty
import Language.Modulo.C
import Language.Modulo.Util
import Language.Modulo.Util.Unmangle
import Language.Modulo
import qualified Data.List as List
import qualified Language.Haskell.Syntax as Hs
data HaskellStyle =
HaskellStyle {
cStyle :: CStyle
}
stdHaskellStyle = HaskellStyle {
cStyle = stdStyle
}
instance Default HaskellStyle where
def = stdHaskellStyle
instance Semigroup HaskellStyle where
a <> b = a
instance Monoid HaskellStyle where
mempty = def
mappend = (<>)
printModuleHaskell :: Module -> String
printModuleHaskell = printModuleHaskellStyle def
printModuleHaskellStyle :: HaskellStyle -> Module -> String
printModuleHaskellStyle style = (++ "\n\n") . prettyPrint . renderModuleHaskellStyle style
renderModuleHaskell :: Module -> HsModule
renderModuleHaskell = renderModuleHaskellStyle def
renderModuleHaskellStyle :: HaskellStyle -> Module -> HsModule
renderModuleHaskellStyle st = convertTopLevel st
convertTopLevel :: HaskellStyle -> Module -> HsModule
convertTopLevel st (Module n opt doc is ds) =
HsModule def (convertModule n) Nothing imps decls
where
imps = standardForeignImports ++ concatMap (uncurry convertImport) is
decls = concatMap (convertDecl st . snd) ds
convertImport :: ModuleName -> Maybe String -> [HsImportDecl]
convertImport _ (Just "C") = []
convertImport n _ = [HsImportDecl def (convertModule n) False Nothing Nothing]
standardForeignImports = [
HsImportDecl def (Hs.Module "Foreign") False Nothing Nothing,
HsImportDecl def (Hs.Module "Foreign.C") False Nothing Nothing]
convertDecl :: HaskellStyle -> Decl -> [HsDecl]
convertDecl st (TypeDecl n Nothing) = declOpaque st n
convertDecl st (TypeDecl n (Just t)) = return $ declType st n t
convertDecl st (FunctionDecl n t) = return $ declFun st n t
convertDecl st (TagDecl t) = return $ notSupported "Tag decls"
convertDecl st (ConstDecl n v t) = return $ notSupported "Constants"
convertDecl st (GlobalDecl n v t) = return $ notSupported "Globals"
declOpaque :: HaskellStyle -> Name -> [HsDecl]
declOpaque st (Name n) = error "Expected qualified name"
declOpaque st (QName _ n) = [HsDataDecl def [] (HsIdent $ n ++ "_") [] [] [],
HsTypeDecl def (HsIdent $ n) [] $
HsTyCon (UnQual "Ptr") `HsTyApp` HsTyCon (UnQual (HsIdent $ n ++ "_"))]
declType :: HaskellStyle -> Name -> Type -> HsDecl
declType st n t = HsTypeDecl def (HsIdent $ getNameEnd n) [] (convertType st t)
declFun :: HaskellStyle -> Name -> FunType -> HsDecl
declFun st n t = HsForeignImport def "ccall" HsUnsafe cName hsName (addIO hsType)
where
cName = getName (translFun (cStyle st) n)
hsName = HsIdent $ getNameEnd n
hsType = convertFunType st t
addIO (HsTyFun a b) = HsTyFun a (addIO b)
addIO b = HsTyApp (HsTyVar $ HsIdent "IO") b
getNameEnd (QName _ x) = x
getNameEnd _ = error "Expected qualified name"
convertType :: HaskellStyle -> Type -> HsType
convertType st (AliasType n) = convertAlias st n
convertType st (PrimType t) = convertPrimType st t
convertType st (RefType t) = convertRefType st t
convertType st (FunType t) = convertFunType st t
convertType st (CompType t) = convertCompType st t
convertAlias :: HaskellStyle -> Name -> HsType
convertAlias st n = HsTyCon $ UnQual $ HsIdent $ getNameEnd n
convertPrimType :: HaskellStyle -> PrimType -> HsType
convertPrimType st Bool = HsTyCon (UnQual "CInt")
convertPrimType st Void = unit_tycon
convertPrimType st Char = HsTyCon (UnQual "CChar")
convertPrimType st Short = HsTyCon (UnQual "CShort")
convertPrimType st Int = HsTyCon (UnQual "CInt")
convertPrimType st Long = HsTyCon (UnQual "CLong")
convertPrimType st LongLong = notSupported "long long with Haskell"
convertPrimType st UChar = HsTyCon (UnQual "CUChar")
convertPrimType st UShort = HsTyCon (UnQual "CUShort")
convertPrimType st UInt = HsTyCon (UnQual "CUInt")
convertPrimType st ULong = HsTyCon (UnQual "CULong")
convertPrimType st ULongLong = notSupported "(unsigned) long long with Haskell"
convertPrimType st Float = HsTyCon (UnQual "CFloat")
convertPrimType st Double = HsTyCon (UnQual "CDouble")
convertPrimType st LongDouble = notSupported "long double with Haskell"
convertPrimType st Int8 = HsTyCon (UnQual "Int8")
convertPrimType st Int16 = HsTyCon (UnQual "Int16")
convertPrimType st Int32 = HsTyCon (UnQual "Int32")
convertPrimType st Int64 = HsTyCon (UnQual "Int64")
convertPrimType st UInt8 = HsTyCon (UnQual "Word8")
convertPrimType st UInt16 = HsTyCon (UnQual "Word16")
convertPrimType st UInt32 = HsTyCon (UnQual "Word32")
convertPrimType st UInt64 = HsTyCon (UnQual "Word64")
convertPrimType st Size = HsTyCon (UnQual "CSize")
convertPrimType st Ptrdiff = HsTyCon (UnQual "CPtrdiff")
convertPrimType st Intptr = HsTyCon (UnQual "CIntPtr")
convertPrimType st UIntptr = notSupported "Uintptr with Haskell"
convertPrimType st SChar = notSupported "Signed chars with Haskell"
convertRefType :: HaskellStyle -> RefType -> HsType
convertRefType st (Pointer t) = HsTyCon (UnQual "Ptr") `HsTyApp` convertType st t
convertRefType st (Array t n) = notSupported "Array types with Haskell"
convertFunType :: HaskellStyle -> FunType -> HsType
convertFunType st = go
where
go (Function [] r) = convertType st r
go (Function ((_,t):ts) r) = convertType st t `HsTyFun` convertFunType st (Function ts r)
convertCompType :: HaskellStyle -> CompType -> HsType
convertCompType st (Enum as) = HsTyCon (UnQual "CInt")
convertCompType st (Struct as) = convertType st voidPtr
convertCompType st (Union as) = convertType st voidPtr
convertCompType st (BitField as) = notSupported "Haskell: bitfields"
instance IsString HsName where
fromString = HsIdent
instance IsString Hs.Module where
fromString = Hs.Module
instance Default SrcLoc where
def = SrcLoc "" 0 0
convertModule :: ModuleName -> Hs.Module
convertModule = Hs.Module . concatSep "." . getModuleNameList
notSupported x = error $ "Not supported yet: " ++ x
voidPtr = RefType (Pointer $ PrimType Void)