diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrey Sverdlichenko (c) 2015-2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of author nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/IO.hs b/app/IO.hs new file mode 100644 --- /dev/null +++ b/app/IO.hs @@ -0,0 +1,83 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +module IO + ( parseFile + , parseBondFile + , parseASTFile + , parseNamespaceMappings + , parseAliasMappings + ) + where + +import System.Exit +import System.FilePath +import System.Directory +import System.IO +import Control.Applicative +import Prelude +import Data.Aeson (eitherDecode) +import Control.Monad.Loops (firstM) +import qualified Data.ByteString.Lazy as BL +import Language.Bond.Syntax.Types (Bond(..)) +import Language.Bond.Syntax.JSON() +import Language.Bond.Parser +import Language.Bond.Codegen.TypeMapping + + +parseFile :: [FilePath] -> FilePath -> IO Bond +parseFile importDirs file = + if takeExtension file == ".json" then + parseASTFile file else + parseBondFile importDirs file + + +parseBondFile :: [FilePath] -> FilePath -> IO Bond +parseBondFile importDirs file = do + cwd <- getCurrentDirectory + input <- readFileUtf8 file + result <- parseBond file input (cwd file) readImportFile + case result of + Left err -> do + putStrLn $ "Error parsing " ++ file ++ ": " ++ show err + exitFailure + Right bond -> return bond + where + readImportFile parentFile importFile = do + path <- findFilePath (takeDirectory parentFile:importDirs) + case path of + Just path' -> do + content <- readFileUtf8 path' + return (path', content) + Nothing -> fail $ "Can't find import file " ++ importFile + where + findFilePath dirs = fmap ( importFile) <$> firstM (doesFileExist . ( importFile)) dirs + + readFileUtf8 name = do + h <- openFile name ReadMode + hSetEncoding h utf8_bom + hGetContents h + + +parseASTFile :: FilePath -> IO Bond +parseASTFile file = do + input <- BL.readFile file + case eitherDecode input of + Left err -> do + putStrLn $ "Error parsing " ++ file ++ ": " ++ show err + exitFailure + Right bond -> return bond + + +parseAliasMappings :: [String] -> IO [AliasMapping] +parseAliasMappings = mapM $ + \ s -> case parseAliasMapping s of + Left err -> fail $ show err + Right m -> return m + + +parseNamespaceMappings :: [String] -> IO [NamespaceMapping] +parseNamespaceMappings = mapM $ + \ s -> case parseNamespaceMapping s of + Left err -> fail $ show err + Right m -> return m diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,44 @@ +module Main where + +import IO +import Options + +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping (MappingContext(MappingContext)) +import Language.Bond.Codegen.Haskell.Decl + +import Control.Monad +import System.Directory +import System.Environment +import System.FilePath + +type Template = MappingContext -> [Declaration] -> CodegenOutput + +main :: IO () +main = do + args <- getArgs + options <- (if null args then withArgs ["--help"] else id) getOptions + + let opts = CodegenOpts { + setType = if hashset options then "HashSet" else "Set", + deriveEq = not (noEq options), + deriveShow = not (noShow options) + } + let codegens = if hsboot options + then [decl_hs opts, decl_hsboot opts] + else [decl_hs opts] + forM_ (files options) $ codegen options codegens + +codegen :: Options -> [Template] -> FilePath -> IO () +codegen options templates file = do + (Bond _ namespaces declarations) <- parseFile (import_dir options) file + let outputDir = output_dir options + aliasMapping <- parseAliasMappings $ using options + namespaceMapping <- parseNamespaceMappings $ namespace options + let mappingContext = MappingContext (error "can't create TypeMapping") aliasMapping namespaceMapping namespaces + forM_ templates $ \template -> do + let MultiFile outputFiles = template mappingContext declarations + forM_ outputFiles $ \(name, code) -> do + let fileName = outputDir name + createDirectoryIfMissing True $ takeDirectory fileName + writeFile fileName code diff --git a/app/Options.hs b/app/Options.hs new file mode 100644 --- /dev/null +++ b/app/Options.hs @@ -0,0 +1,43 @@ +{-# Language DeriveDataTypeable #-} +module Options where + +import Paths_bond_haskell_compiler (version) +import Data.Version (showVersion) +import System.Console.CmdArgs + +data Options = Haskell + { files :: [FilePath] + , import_dir :: [FilePath] + , output_dir :: FilePath + , using :: [String] + , namespace :: [String] + , hsboot :: Bool + , hashset :: Bool + , noShow :: Bool + , noEq :: Bool + } + deriving (Show, Data, Typeable) + +haskell :: Options +haskell = Haskell + { files = def &= typFile &= args + , import_dir = def &= typDir &= name "i" &= help "Add the directory to import search path" + , output_dir = "." &= typDir &= name "o" &= help "Output generated files into the specified directory" + , using = def &= typ "MAPPING" &= name "u" &= help "Custom type alias mapping in the form alias=type" + , namespace = def &= typ "MAPPING" &= name "n" &= help "Custom namespace mapping in the form bond_namespace=language_namespace" + , hsboot = def &= name "s" &= help "Generate both .hs and .hs-boot files" + , hashset = def &= name "h" &= help "Use HashSet for set fields" + , noShow = def &= explicit &= name "noshow" &= help "do not derive Show instance for structs" + , noEq = def &= explicit &= name "noeq" &= help "do not derive Eq instance for structs" + } &= + name "haskell" &= + help "Generate Haskell code" + +mode :: Mode (CmdArgs Options) +mode = cmdArgsMode $ modes [haskell &= auto] &= + program "hbc" &= + help "Compile Bond schema file(s) and generate specified output. The schema file(s) can be in one of two formats: Bond IDL or JSON representation of the schema abstract syntax tree as produced by `gbc schema`. Multiple schema files can be specified either directly on the command line or by listing them in a text file passed to gbc via @listfile syntax." &= + summary ("Bond2Haskell Compiler " ++ showVersion version) + +getOptions :: IO Options +getOptions = cmdArgsRun mode diff --git a/bond-haskell-compiler.cabal b/bond-haskell-compiler.cabal new file mode 100644 --- /dev/null +++ b/bond-haskell-compiler.cabal @@ -0,0 +1,65 @@ +name: bond-haskell-compiler +version: 0.1.0.0 +synopsis: Bond code generator for Haskell +description: Bond is a cross-platform framework for handling schematized + data. It supports cross-language de/serialization and + powerful generic mechanisms for efficiently manipulating + data. + . + The package contains a command-line compiler/codegen + tool, named hbc, which is used to generate code for Haskell + programs using Bond. +homepage: http://github.com/rblaze/bond-haskell-compiler#readme +license: BSD3 +license-file: LICENSE +author: blaze@ruddy.ru +maintainer: Andrey Sverdlichenko +copyright: (C) 2015 Andrey Sverdlichenko +category: Language +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Language.Bond.Codegen.Haskell.Decl + Language.Bond.Codegen.Haskell.EnumDecl + Language.Bond.Codegen.Haskell.SchemaDecl + Language.Bond.Codegen.Haskell.StructDecl + Language.Bond.Codegen.Haskell.Util + ghc-options: -W -Wall + build-depends: base >= 4.7 && < 5 + , bond == 0.4.0.1 + , filepath >= 1.0 + , haskell-src-exts >= 1.16 + default-language: Haskell2010 + +executable hbc + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall + build-depends: base + , aeson >= 0.7.0.6 && < 0.10.0.0 + , bond == 0.4.0.1 + , bond-haskell-compiler + , bytestring >= 0.10 + , cmdargs >= 0.10.10 + , directory >= 1.1 + , filepath >= 1.0 + , monad-loops >= 0.4 + default-language: Haskell2010 + other-modules: IO + Options + Paths_bond_haskell_compiler + +test-suite bond-haskell-compiler-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/rblaze/bond-haskell.git diff --git a/src/Language/Bond/Codegen/Haskell/Decl.hs b/src/Language/Bond/Codegen/Haskell/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Haskell/Decl.hs @@ -0,0 +1,55 @@ +module Language.Bond.Codegen.Haskell.Decl ( + CodegenOpts(..), + CodegenOutput(..), + decl_hs, + decl_hsboot + ) where + +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping (MappingContext) +import Language.Bond.Codegen.Haskell.EnumDecl +import Language.Bond.Codegen.Haskell.StructDecl +import Language.Bond.Codegen.Haskell.Util + +import Control.Arrow +import Data.Maybe +import Language.Haskell.Exts +import System.FilePath (joinPath) + +data CodegenOutput + = SingleFile FilePath String + | MultiFile [(FilePath, String)] + +decl_hs :: CodegenOpts -> MappingContext -> [Declaration] -> CodegenOutput +decl_hs opts ctx declarations = MultiFile $ mapMaybe step declarations + where + step = fmap (second prettyPrint) . makeModule opts ctx + +decl_hsboot :: CodegenOpts -> MappingContext -> [Declaration] -> CodegenOutput +decl_hsboot opts ctx declarations = MultiFile $ mapMaybe step declarations + where + step = fmap (second prettyPrint) . makeHsBootModule opts ctx + +makeModule :: CodegenOpts -> MappingContext -> Declaration -> Maybe (FilePath, Module) +makeModule opts ctx decl = fmap ((,) sourceName) code + where + code = case decl of + Enum{} -> enumDecl opts ctx moduleName decl + Struct{} -> structDecl opts ctx moduleName decl + _ -> Nothing + hsModule = capitalize (makeDeclName decl) + hsNamespaces = map capitalize $ getNamespace ctx + sourceName = joinPath $ hsNamespaces ++ [hsModule ++ ".hs"] + moduleName = mkModuleName hsNamespaces hsModule + +makeHsBootModule :: CodegenOpts -> MappingContext -> Declaration -> Maybe (FilePath, Module) +makeHsBootModule opts ctx decl = fmap ((,) hsBootName) code + where + code = case decl of + Enum{} -> enumHsBootDecl opts ctx moduleName decl + Struct{} -> structHsBootDecl opts ctx moduleName decl + _ -> Nothing + hsModule = capitalize (makeDeclName decl) + hsNamespaces = map capitalize $ getNamespace ctx + hsBootName = joinPath $ hsNamespaces ++ [hsModule ++ ".hs-boot"] + moduleName = mkModuleName hsNamespaces hsModule diff --git a/src/Language/Bond/Codegen/Haskell/EnumDecl.hs b/src/Language/Bond/Codegen/Haskell/EnumDecl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Haskell/EnumDecl.hs @@ -0,0 +1,79 @@ +module Language.Bond.Codegen.Haskell.EnumDecl ( + enumDecl, + enumHsBootDecl + ) where + +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping (MappingContext(..)) +import Language.Bond.Codegen.Haskell.Util +import Language.Haskell.Exts hiding (mode) +import Language.Haskell.Exts.SrcLoc (noLoc) + +enumDecl :: CodegenOpts -> MappingContext -> ModuleName -> Declaration -> Maybe Module +enumDecl _ ctx moduleName decl@Enum{} = Just source + where + source = Module noLoc moduleName + [ LanguagePragma noLoc + [ Ident "GeneralizedNewtypeDeriving" + , Ident "DeriveDataTypeable" + , Ident "OverloadedStrings" + ] + ] + Nothing + Nothing + [importInternalModule, importPrelude] + (dataDecl : bondTypeDecl : typeSig : values) + typeName = mkType $ makeDeclName decl + typeCon = TyCon (UnQual typeName) + dataDecl = DataDecl noLoc NewType [] typeName [] + [ QualConDecl noLoc [] [] (ConDecl typeName [implType "Int32"]) ] + [ (pQual "Show", []), (pQual "Eq", []), (pQual "Ord", []), (pQual "Enum", []) + , (implQual "Hashable", []), (implQual "Default", []), (implQual "Typeable", []) + ] + bondTypeDecl = InstDecl noLoc Nothing [] [] (implQual "BondType") + [typeCon] + [InsDecl $ + FunBind + [Match noLoc (Ident "bondPut") + [PParen (PApp (UnQual typeName) [PVar $ Ident "v'"])] + Nothing + (UnGuardedRhs $ + App (Var $ implQual "bondPut") (Var $ unqual "v'")) + noBinds], + InsDecl $ + PatBind noLoc (PVar $ Ident "bondGet") + (UnGuardedRhs $ + appFun (Var $ pQual "fmap") [Con $ UnQual typeName, Var $ implQual "bondGet"]) + noBinds, + InsDecl $ wildcardFunc "getName" $ strE (declName decl), + InsDecl $ wildcardFunc "getQualifiedName" $ strE (getDeclTypeName ctx{namespaceMapping = []} decl), + InsDecl $ wildcardFunc "getElementType" $ Con (implQual "ElementInt32") + ] + typeSig = TypeSig noLoc (map (mkVar . constantName) (enumConstants decl)) typeCon + values = makeValue 0 (enumConstants decl) + makeValue _ [] = [] + makeValue _ (Constant{constantName = cname, constantValue = Just i} : xs) + = mkConst cname i : makeValue (i + 1) xs + makeValue i (Constant{constantName = cname} : xs) + = mkConst cname i : makeValue (i + 1) xs + mkConst constName val + = patBind noLoc (PVar $ mkVar constName) $ App (Con $ UnQual typeName) (parenIntL val) + +enumDecl _ _ _ _ = error "enumDecl called for invalid type" + +enumHsBootDecl :: CodegenOpts -> MappingContext -> ModuleName -> Declaration -> Maybe Module +enumHsBootDecl _ _ moduleName decl@Enum{} = Just hsboot + where + hsboot = Module noLoc moduleName [] Nothing Nothing [importInternalModule{importSrc = True}, importPrelude] [ + DataDecl noLoc NewType [] typeName [] [QualConDecl noLoc [] [] (ConDecl typeName [implType "Int32"])] [], + showInstance, + eqInstance, + typeSig + ] + typeName = mkType $ makeDeclName decl + typeCon = TyCon (UnQual typeName) + typeSig = TypeSig noLoc (map (mkVar . constantName) (enumConstants decl)) typeCon + showInstance = InstDecl noLoc Nothing [] [] (pQual "Show") [typeCon] [] + eqInstance = InstDecl noLoc Nothing [] [] (pQual "Eq") [typeCon] [] + +enumHsBootDecl _ _ _ _ = error "enumDecl called for invalid type" diff --git a/src/Language/Bond/Codegen/Haskell/SchemaDecl.hs b/src/Language/Bond/Codegen/Haskell/SchemaDecl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Haskell/SchemaDecl.hs @@ -0,0 +1,112 @@ +module Language.Bond.Codegen.Haskell.SchemaDecl ( + getSchema, + structNameAndType + ) where + +import Language.Bond.Codegen.Haskell.Util + +import Language.Bond.Codegen.TypeMapping (MappingContext(..)) +import Language.Bond.Syntax.Types + +import Data.Maybe +import Language.Haskell.Exts +import Language.Haskell.Exts.SrcLoc (noLoc) + +makeFieldType :: String -> MappingContext -> Field -> Exp +makeFieldType settype ctx field + | BT_Bool <- fieldType field = reuseDefault "FieldBool" + | BT_Int8 <- fieldType field = reuseDefault "FieldInt8" + | BT_Int16 <- fieldType field = reuseDefault "FieldInt16" + | BT_Int32 <- fieldType field = reuseDefault "FieldInt32" + | BT_Int64 <- fieldType field = reuseDefault "FieldInt64" + | BT_UInt8 <- fieldType field = reuseDefault "FieldUInt8" + | BT_UInt16 <- fieldType field = reuseDefault "FieldUInt16" + | BT_UInt32 <- fieldType field = reuseDefault "FieldUInt32" + | BT_UInt64 <- fieldType field = reuseDefault "FieldUInt64" + | BT_Float <- fieldType field = reuseDefault "FieldFloat" + | BT_Double <- fieldType field = reuseDefault "FieldDouble" + | BT_String <- fieldType field = reuseDefault "FieldString" + | BT_WString <- fieldType field = reuseDefault "FieldWString" + | BT_UserDefined Enum{} _ <- fieldType field = + App (Con $ implQual "FieldInt32") $ Paren $ + App (Con $ implQual "DefaultValue") $ Paren $ + App (Var $ pQual "fromIntegral") $ Paren $ + App (Var $ pQual "fromEnum") $ Paren $ + App (Var $ UnQual $ mkVar $ makeFieldName field) $ Paren $ + InfixApp (Var $ implQual "defaultValue") (QVarOp $ implQual "asProxyTypeOf") (Var $ unqual "type'proxy") + | BT_Maybe t <- fieldType field = + App (Var $ implQual "elementToDefNothingFieldType") $ Paren $ + App (Var $ implQual "getElementType") $ Paren $ + proxyOf $ hsType settype ctx t + | t <- fieldType field = + App (Var $ implQual "elementToFieldType") $ Paren $ + App (Var $ implQual "getElementType") $ Paren $ + proxyOf $ hsType settype ctx t + where + reuseDefault con = App (Con $ implQual con) $ Paren $ + App (Con $ implQual "DefaultValue") $ Paren $ + App (Var $ UnQual $ mkVar $ makeFieldName field) $ Paren $ + InfixApp (Var $ implQual "defaultValue") (QVarOp $ implQual "asProxyTypeOf") (Var $ unqual "type'proxy") + +getSchema :: CodegenOpts -> MappingContext -> Declaration -> InstDecl +getSchema opts ctx decl = InsDecl $ simpleFun noLoc (Ident "getSchema") (Ident "type'proxy") $ + RecConstr (implQual "StructSchema") + [ FieldUpdate (implQual "structTag") $ + App (Var $ implQual "typeRep") (Var $ unqual "type'proxy") + , FieldUpdate (implQual "structName") $ + App (Var $ implQual "getName") (Var $ unqual "type'proxy") + , FieldUpdate (implQual "structQualifiedName") $ + App (Var $ implQual "getQualifiedName") (Var $ unqual "type'proxy") + , FieldUpdate (implQual "structAttrs") $ + App (Var $ implQual "makeMap") (List $ map makeAttr (declAttributes decl)) + , FieldUpdate (implQual "structBase") $ + case structBase decl of + Nothing -> Con (pQual "Nothing") + Just base -> App (Con $ pQual "Just") $ Paren $ + App (Var $ implQual "getSchema") (Paren $ proxyOf $ hsType (setType opts) ctx base) + , FieldUpdate (implQual "structFields") $ + App (Var $ implQual "makeMap") (List $ map makeFieldInfo (structFields decl)) + , FieldUpdate (implQual "structRequiredOrdinals") $ + App (Var $ implQual "fromOrdinalList") (List requiredOrdinals) + ] + where + requiredOrdinals = mapMaybe (\ field -> + if fieldModifier field == Required + then Just $ App (Con $ implQual "Ordinal") (intL $ fieldOrdinal field) + else Nothing) (structFields decl) + makeFieldInfo field = Tuple Boxed + [ App (Con $ implQual "Ordinal") (intL $ fieldOrdinal field) + , RecConstr (implQual "FieldSchema") + [ FieldUpdate (implQual "fieldName") $ strE $ fieldName field + , FieldUpdate (implQual "fieldAttrs") $ + App (Var $ implQual "makeMap") (List $ map makeAttr (fieldAttributes field)) + , FieldUpdate (implQual "fieldModifier") $ Con $ implQual $ + case fieldModifier field of + Optional -> "FieldOptional" + Required -> "FieldRequired" + RequiredOptional -> "FieldRequiredOptional" + , FieldUpdate (implQual "fieldType") $ makeFieldType (setType opts) ctx field + ] + ] + makeAttr a = Tuple Boxed + [ strE $ getQualifiedName ctx $ attrName a + , strE $ attrValue a + ] + + +structNameAndType :: MappingContext -> Declaration -> [InstDecl] +structNameAndType ctx decl = + [ InsDecl $ wildcardFunc "getName" $ nameFunc $ declName decl + , InsDecl $ wildcardFunc "getQualifiedName" $ nameFunc $ getDeclTypeName ctx{namespaceMapping = []} decl + , InsDecl $ simpleFun noLoc (Ident "getElementType") (Ident "type'proxy") $ + App (Con $ implQual "ElementStruct") (Paren $ App (Var $ implQual "getSchema") (Var $ unqual "type'proxy")) + ] + where + paramProxies = map (Paren . proxyOf . TyVar . mkVar . paramName) (declParams decl) + nameFunc ownName = + if null (declParams decl) + then strE ownName + else appFun (Var $ implQual "makeGenericName") + [ strE ownName + , List $ map (App (Var $ implQual "getQualifiedName")) paramProxies + ] diff --git a/src/Language/Bond/Codegen/Haskell/StructDecl.hs b/src/Language/Bond/Codegen/Haskell/StructDecl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Haskell/StructDecl.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE NamedFieldPuns, PatternGuards #-} +module Language.Bond.Codegen.Haskell.StructDecl ( + structDecl, + structHsBootDecl + ) where + +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping (MappingContext) +import Language.Bond.Codegen.Haskell.SchemaDecl +import Language.Bond.Codegen.Haskell.Util + +import Data.Maybe +import Language.Haskell.Exts +import Language.Haskell.Exts.SrcLoc (noLoc) + +baseStructField :: Name +baseStructField = Ident "base'" + +getTypeModules :: Language.Haskell.Exts.Type -> [ModuleName] +getTypeModules (TyCon (Qual moduleName _)) = [moduleName] +getTypeModules (TyApp t1 t2) = getTypeModules t1 ++ getTypeModules t2 +getTypeModules (TyList t) = getTypeModules t +getTypeModules _ = [] + +defaultFieldValue :: MappingContext -> Language.Bond.Syntax.Types.Field -> FieldUpdate +defaultFieldValue ctx f@Field{fieldType, fieldDefault} + = FieldUpdate (UnQual $ mkVar $ makeFieldName f) (defValue fieldDefault) + where + defValue Nothing = Var $ implQual "defaultValue" + defValue (Just (DefaultBool v)) = Con $ pQual $ show v + defValue (Just (DefaultInteger v)) = intL v + defValue (Just (DefaultFloat v)) = floatL v + defValue (Just (DefaultString v)) = strE v + defValue (Just (DefaultEnum v)) + = let BT_UserDefined decl [] = fieldType + ns = getDeclNamespace ctx decl + typename = declName decl + in Var $ Qual (mkModuleName ns typename) (mkVar v) + defValue (Just DefaultNothing) = Con $ pQual "Nothing" + +getUntagged :: Name -> Declaration -> InstDecl +getUntagged cname decl = InsDecl $ + patBind noLoc (PVar $ Ident "bondStructGetUntagged") code + where + baseVar = Ident "base'struct" + fieldsGet = map fieldFunc (structFields decl) + fieldFunc f | fieldDefault f == Just DefaultNothing = Var $ implQual "bondGetDefNothing" + | BT_Nullable _ <- fieldType f = Var $ implQual "bondGetNullable" + | otherwise = Var $ implQual "bondGet" + code | isNothing (structBase decl) = foldl (\a b -> InfixApp a (QVarOp $ implQual "ap") b) + (App (Var $ pQual "return") (Con $ UnQual cname)) fieldsGet + | otherwise = Do [ + Generator noLoc (PVar baseVar) (Var $ implQual "bondGetBaseStruct"), + Qualifier $ foldl (\a b -> InfixApp a (QVarOp $ implQual "ap") b) + (App (Var $ pQual "return") (Paren $ App (Con $ UnQual cname) (Var $ UnQual baseVar))) fieldsGet + ] + +getBase :: Declaration -> InstDecl +getBase decl = InsDecl $ FunBind [Match noLoc (Ident "bondStructGetBase") [PVar self] Nothing (UnGuardedRhs code) noBinds] + where + self = Ident "self'" + base = Ident "base'val" + code | isNothing (structBase decl) = App (Var $ pQual "return") (Var $ UnQual self) + | otherwise = Do [ + Generator noLoc (PVar base) (Var $ implQual "bondGetBaseStruct"), + Qualifier $ App (Var $ pQual "return") $ RecUpdate (Var $ UnQual self) [ + FieldUpdate (UnQual baseStructField) (Var $ UnQual base) + ] + ] + +getField :: Declaration -> InstDecl +getField decl = InsDecl $ FunBind $ map fieldFunc (structFields decl) ++ [defaultFunc] + where + self = Ident "self'" + val = Ident "field'val" + defaultFunc = Match noLoc (Ident "bondStructGetField") [PWildCard, PWildCard] Nothing + (UnGuardedRhs $ App (Var $ pQual "error") (strE "unknown field ordinal")) noBinds + fieldFunc f = Match noLoc (Ident "bondStructGetField") + [PParen $ PApp (implQual "Ordinal") [PLit Signless $ Int $ fromIntegral $ fieldOrdinal f], PVar self] + Nothing + (UnGuardedRhs $ Do [ + Generator noLoc (PVar val) (Var $ getFunc f), + Qualifier $ App (Var $ pQual "return") $ RecUpdate (Var $ UnQual self) [ + FieldUpdate (UnQual $ mkVar $ makeFieldName f) (Var $ UnQual val) + ] + ]) noBinds + getFunc f | fieldDefault f == Just DefaultNothing = implQual "bondGetDefNothing" + | otherwise = implQual "bondGet" + +structPut :: Name -> Declaration -> InstDecl +structPut tname decl = InsDecl $ FunBind [Match noLoc (Ident "bondStructPut") [selfPVar] Nothing (UnGuardedRhs code) noBinds] + where + self = Ident "self'" + selfPVar | isNothing (structBase decl) && null (structFields decl) = PWildCard + | otherwise = PVar self + code | isNothing (structBase decl) && null (structFields decl) = App (Var $ pQual "return") (Tuple Boxed []) + | otherwise = Do $ map Qualifier (baseCode ++ fieldsCode) + baseCode | isNothing (structBase decl) = [] + | otherwise = [ + App (Var $ implQual "bondPutBaseStruct") $ Paren $ App (Var $ UnQual baseStructField) (Var $ UnQual self) + ] + fieldsCode = map putField (structFields decl) + putField f = appFun (Var $ putFunc f) + [ proxyOf $ makeType True tname (declParams decl) + , Paren $ App (Con $ implQual "Ordinal") (intL $ fieldOrdinal f) + , Paren $ App (Var $ UnQual $ mkVar $ makeFieldName f) (Var $ UnQual self) + ] + putFunc f | fieldDefault f == Just DefaultNothing = implQual "bondPutDefNothingField" + | otherwise = implQual "bondPutField" + +structDecl :: CodegenOpts -> MappingContext -> ModuleName -> Declaration -> Maybe Module +structDecl opts ctx moduleName decl@Struct{structBase, structFields, declParams} = Just source + where + source = Module noLoc moduleName + [LanguagePragma noLoc + [Ident "ScopedTypeVariables", Ident "DeriveDataTypeable", Ident "OverloadedStrings"] + ] + Nothing + (Just [EThingAll $ UnQual typeName]) + imports + [dataDecl, defaultDecl, bondTypeDecl, + bondStructDecl + ] + + imports = importInternalModule : importPrelude : map (\ m -> importTemplate{importModule = m}) fieldModules + + typeName = mkType $ makeDeclName decl + typeParams = map (\TypeParam{paramName} -> UnkindedVar $ mkVar paramName) declParams + fieldModules = unique $ filter (/= moduleName) $ filter (/= internalModuleAlias) + $ concatMap (getTypeModules . snd) fields + mkField f = ([mkVar $ makeFieldName f], hsType (setType opts) ctx (fieldType f)) + ownFields = map mkField structFields + fields | Just base <- structBase = ([baseStructField], hsType (setType opts) ctx base) : ownFields + | otherwise = ownFields + dataDecl = DataDecl noLoc DataType [] typeName typeParams + [QualConDecl noLoc [] [] (RecDecl typeName fields)] + (derivingShow $ derivingEq [(implQual "Typeable", [])]) + derivingShow = if deriveShow opts then ((pQual "Show", []) :) else id + derivingEq = if deriveEq opts then ((pQual "Eq", []) :) else id + + ownFieldDefaults = map (defaultFieldValue ctx) structFields + fieldDefaults | isNothing structBase = ownFieldDefaults + | otherwise = FieldUpdate (UnQual baseStructField) (Var $ implQual "defaultValue") : ownFieldDefaults + defaultDecl = InstDecl noLoc Nothing [] + (map (typeParamConstraint $ implQual "Default") declParams) + (implQual "Default") + [makeType True typeName declParams] + [InsDecl $ + patBind noLoc (PVar $ Ident "defaultValue") $ + RecConstr (UnQual typeName) fieldDefaults + ] + bondTypeDecl = InstDecl noLoc Nothing [] + (map (typeParamConstraint $ implQual "BondType") declParams) + (implQual "BondType") + [makeType True typeName declParams] + ([InsDecl $ + patBind noLoc (PVar $ Ident "bondGet") $ + Var (implQual "bondGetStruct"), + InsDecl $ + patBind noLoc (PVar $ Ident "bondPut") $ + Var (implQual "bondPutStruct") + ] ++ structNameAndType ctx decl) + bondStructDecl = InstDecl noLoc Nothing [] + (map (typeParamConstraint $ implQual "BondType") declParams) + (implQual "BondStruct") + [makeType True typeName declParams] + [ structPut typeName decl + , getUntagged typeName decl + , getBase decl + , getField decl + , getSchema opts ctx decl + ] + +structDecl _ _ _ _ = error "structDecl called for invalid type" + +structHsBootDecl :: CodegenOpts -> MappingContext -> ModuleName -> Declaration -> Maybe Module +structHsBootDecl opts ctx moduleName decl@Struct{structBase, structFields, declParams} = Just hsboot + where + hsboot = Module noLoc moduleName [] Nothing Nothing + (importInternalModule{importSrc = True} : map (\ m -> importTemplate{importModule = m, importSrc = True}) fieldModules) + [ + DataDecl noLoc DataType [] typeName typeParams [QualConDecl noLoc [] [] (RecDecl typeName fields)] [], + InstDecl noLoc Nothing [] + (map (typeParamConstraint $ implQual "Default") declParams) + (implQual "Default") + [makeType True typeName declParams] [] + ] + + typeName = mkType $ makeDeclName decl + typeParams = map (\TypeParam{paramName} -> UnkindedVar $ mkVar paramName) declParams + fieldModules = unique $ filter (/= moduleName) $ filter (/= internalModuleAlias) + $ concatMap (getTypeModules . snd) fields + mkField f = ([mkVar $ makeFieldName f], hsType (setType opts) ctx (fieldType f)) + ownFields = map mkField structFields + fields | Just base <- structBase = ([baseStructField], hsType (setType opts) ctx base) : ownFields + | otherwise = ownFields + +structHsBootDecl _ _ _ _ = error "structDecl called for invalid type" diff --git a/src/Language/Bond/Codegen/Haskell/Util.hs b/src/Language/Bond/Codegen/Haskell/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Haskell/Util.hs @@ -0,0 +1,172 @@ +module Language.Bond.Codegen.Haskell.Util where + +import Data.Char +import Language.Bond.Codegen.TypeMapping (MappingContext(..), NamespaceMapping(..)) +import Language.Bond.Syntax.Types +import Language.Haskell.Exts hiding (Namespace) +import Language.Haskell.Exts.SrcLoc (noLoc) +import Control.Applicative +import Data.List +import Data.Maybe + +data CodegenOpts = CodegenOpts + { setType :: String + , deriveShow :: Bool + , deriveEq :: Bool + } + +unique :: Ord a => [a] -> [a] +unique = map head . group . sort + +internalModuleName :: ModuleName +internalModuleName = ModuleName "Data.Bond.Internal.Imports" + +internalModuleAlias :: ModuleName +internalModuleAlias = ModuleName "B'" + +preludeAlias :: ModuleName +preludeAlias = ModuleName "P'" + +capitalize :: String -> String +capitalize (h : t) = toUpper h : t +capitalize "" = "" + +uncapitalize :: String -> String +uncapitalize (h : t) = toLower h : t +uncapitalize "" = "" + +unqual :: String -> QName +unqual = UnQual . Ident + +mkVar :: String -> Name +mkVar = Ident . uncapitalize + +mkType :: String -> Name +mkType = Ident . capitalize + +pQual :: String -> QName +pQual = Qual preludeAlias . Ident + +implQual :: String -> QName +implQual = Qual internalModuleAlias . Ident + +implType :: String -> Language.Haskell.Exts.Type +implType = TyCon . implQual + +intL :: Integral a => a -> Exp +intL n | n >= 0 = Lit $ Int $ fromIntegral n +intL n = NegApp $ intL $ abs n + +parenIntL :: Integral a => a -> Exp +parenIntL n | n >= 0 = intL n +parenIntL n = Paren $ intL n + +floatL :: Real a => a -> Exp +floatL n | n >= 0 = Lit $ Frac $ toRational n +floatL n = NegApp $ floatL $ abs n + +importTemplate :: ImportDecl +importTemplate = ImportDecl + { importLoc = noLoc, importModule = undefined, + importQualified = True, importSrc = False, importSafe = False, + importPkg = Nothing, importAs = Nothing, importSpecs = Nothing + } + +importInternalModule :: ImportDecl +importInternalModule = importTemplate + { importModule = internalModuleName, + importAs = Just internalModuleAlias + } + +importPrelude :: ImportDecl +importPrelude = importTemplate + { importModule = ModuleName "Prelude", + importAs = Just preludeAlias + } + +mkModuleName :: QualifiedName -> String -> ModuleName +mkModuleName ns typename = ModuleName $ intercalate "." $ map capitalize $ ns ++ [typename] + +typeParamConstraint :: QName -> TypeParam -> Asst +typeParamConstraint className t = ClassA className [TyVar $ mkVar $ paramName t] + +wildcardFunc :: String -> Exp -> Decl +wildcardFunc f rhs = FunBind [Match noLoc (Ident f) [PWildCard] Nothing (UnGuardedRhs rhs) noBinds] + +makeType :: Bool -> Name -> [TypeParam] -> Language.Haskell.Exts.Type +makeType _ typeName [] = TyCon $ UnQual typeName +makeType needParen typeName params + | needParen = TyParen typeDecl + | otherwise = typeDecl + where + typeDecl = foldl1 TyApp $ (TyCon $ UnQual typeName) : map (TyVar . mkVar . paramName) params + +hsType :: String -> MappingContext -> Language.Bond.Syntax.Types.Type -> Language.Haskell.Exts.Type +hsType _ _ BT_Int8 = implType "Int8" +hsType _ _ BT_Int16 = implType "Int16" +hsType _ _ BT_Int32 = implType "Int32" +hsType _ _ BT_Int64 = implType "Int64" +hsType _ _ BT_UInt8 = implType "Word8" +hsType _ _ BT_UInt16 = implType "Word16" +hsType _ _ BT_UInt32 = implType "Word32" +hsType _ _ BT_UInt64 = implType "Word64" +hsType _ _ BT_Float = implType "Float" +hsType _ _ BT_Double = implType "Double" +hsType _ _ BT_Bool = implType "Bool" +hsType _ _ BT_String = implType "Utf8" +hsType _ _ BT_WString = implType "Utf16" +hsType _ _ BT_MetaName = error "BT_MetaName not implemented" +hsType _ _ BT_MetaFullName = error "BT_MetaFullName not implemented" +hsType _ _ BT_Blob = implType "Blob" +hsType _ _ (BT_IntTypeArg _) = error "BT_IntTypeArg not implemented" +hsType s c (BT_Maybe type_) = TyApp (implType "Maybe") (hsType s c type_) +hsType s c (BT_Nullable type_) = TyApp (implType "Maybe") (hsType s c type_) +hsType s c (BT_List element) = TyList $ hsType s c element +hsType s c (BT_Vector element) = TyApp (implType "Vector") (hsType s c element) +hsType s c (BT_Set element) = TyApp (implType s) (hsType s c element) +hsType s c (BT_Map key value) = TyApp (TyApp (implType "Map") (hsType s c key)) (hsType s c value) +hsType s c (BT_Bonded type_) = TyApp (implType "Bonded") (hsType s c type_) +hsType _ _ (BT_TypeParam type_) = TyVar $ mkVar $ paramName type_ +hsType _ _ (BT_UserDefined Alias{} _) = error "BT_UserDefined Alias" +hsType s c (BT_UserDefined decl params) = foldl1 TyApp $ declType : map (hsType s c) params + where + declType = let ns = getDeclNamespace c decl + typename = declName decl + in TyCon $ Qual (mkModuleName ns typename) (mkType typename) + +proxyOf :: Language.Haskell.Exts.Type -> Exp +proxyOf = ExpTypeSig noLoc (Con $ implQual "Proxy") . TyApp (TyCon $ implQual "Proxy") + +makeDeclName :: Declaration -> String +makeDeclName decl = overrideName (declName decl) (declAttributes decl) + +makeFieldName :: Field -> String +makeFieldName f = overrideName (fieldName f) (fieldAttributes f) + +overrideName :: String -> [Attribute] -> String +overrideName def attrs = maybe def attrValue $ find (\a -> attrName a == ["HaskellName"]) attrs + +-- overrides for bond functions I can't use because of opaque TypeMapping + +getNamespace :: MappingContext -> QualifiedName +getNamespace c = resolveNamespace c (namespaces c) + +getQualifiedName :: MappingContext -> QualifiedName -> String +getQualifiedName _ = intercalate "." + +getDeclNamespace :: MappingContext -> Declaration -> QualifiedName +getDeclNamespace c = resolveNamespace c . declNamespaces + +getDeclTypeName :: MappingContext -> Declaration -> String +getDeclTypeName c = getQualifiedName c . declQualifiedName c + +resolveNamespace :: MappingContext -> [Namespace] -> QualifiedName +resolveNamespace c ns = + maybe namespaceName toNamespace $ find ((namespaceName ==) . fromNamespace) (namespaceMapping c) + where + namespaceName = nsName . fromJust $ neutralNamespace <|> fallbackNamespace + neutralNamespace = find (isNothing . nsLanguage) ns + fallbackNamespace = Just $ last ns + +declQualifiedName :: MappingContext -> Declaration -> QualifiedName +declQualifiedName c decl = getDeclNamespace c decl ++ [declName decl] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"