bond-haskell-compiler (empty) → 0.1.0.0
raw patch · 12 files changed
+885/−0 lines, 12 filesdep +aesondep +basedep +bondsetup-changed
Dependencies added: aeson, base, bond, bond-haskell-compiler, bytestring, cmdargs, directory, filepath, haskell-src-exts, monad-loops
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/IO.hs +83/−0
- app/Main.hs +44/−0
- app/Options.hs +43/−0
- bond-haskell-compiler.cabal +65/−0
- src/Language/Bond/Codegen/Haskell/Decl.hs +55/−0
- src/Language/Bond/Codegen/Haskell/EnumDecl.hs +79/−0
- src/Language/Bond/Codegen/Haskell/SchemaDecl.hs +112/−0
- src/Language/Bond/Codegen/Haskell/StructDecl.hs +198/−0
- src/Language/Bond/Codegen/Haskell/Util.hs +172/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/IO.hs view
@@ -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
+ app/Main.hs view
@@ -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
+ app/Options.hs view
@@ -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<T> 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
+ bond-haskell-compiler.cabal view
@@ -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
+ src/Language/Bond/Codegen/Haskell/Decl.hs view
@@ -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
+ src/Language/Bond/Codegen/Haskell/EnumDecl.hs view
@@ -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"
+ src/Language/Bond/Codegen/Haskell/SchemaDecl.hs view
@@ -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+ ]
+ src/Language/Bond/Codegen/Haskell/StructDecl.hs view
@@ -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"
+ src/Language/Bond/Codegen/Haskell/Util.hs view
@@ -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]
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"