diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,8 @@ import Options import Language.Bond.Syntax.Types -import Language.Bond.Codegen.TypeMapping (MappingContext(MappingContext)) +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Haskell.TypeMapping import Language.Bond.Codegen.Haskell.Decl import Control.Monad @@ -33,11 +34,11 @@ codegen :: Options -> [Template] -> FilePath -> IO () codegen options templates file = do - (Bond _ namespaces declarations) <- parseFile (import_dir options) file + (Bond _ fileNamespaces 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 + fileAliasMapping <- parseAliasMappings $ using options + fileNamespaceMapping <- parseNamespaceMappings $ namespace options + let mappingContext = MappingContext haskellTypeMapping fileAliasMapping fileNamespaceMapping fileNamespaces forM_ templates $ \template -> do let outputFiles = template mappingContext declarations forM_ outputFiles $ \ moduleInfo -> do diff --git a/bond-haskell-compiler.cabal b/bond-haskell-compiler.cabal --- a/bond-haskell-compiler.cabal +++ b/bond-haskell-compiler.cabal @@ -1,5 +1,5 @@ name: bond-haskell-compiler -version: 0.1.3.1 +version: 0.1.4.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 @@ -27,12 +27,14 @@ Language.Bond.Codegen.Haskell.EnumDecl Language.Bond.Codegen.Haskell.SchemaDecl Language.Bond.Codegen.Haskell.StructDecl + Language.Bond.Codegen.Haskell.TypeMapping Language.Bond.Codegen.Haskell.Util ghc-options: -W -Wall build-depends: base >= 4.7 && < 5 - , bond >= 0.4.1.0 && < 0.4.2.0 + , bond >= 0.5.0.0 && < 0.5.1.0 , filepath >= 1.0 , haskell-src-exts >= 1.16 && < 1.18 + , text default-language: Haskell2010 executable hbc @@ -41,7 +43,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall build-depends: base , aeson - , bond == 0.4.1.0 + , bond , bond-haskell-compiler , bytestring >= 0.10 , cmdargs >= 0.10.10 diff --git a/src/Language/Bond/Codegen/Haskell/Decl.hs b/src/Language/Bond/Codegen/Haskell/Decl.hs --- a/src/Language/Bond/Codegen/Haskell/Decl.hs +++ b/src/Language/Bond/Codegen/Haskell/Decl.hs @@ -7,7 +7,7 @@ ) where import Language.Bond.Syntax.Types -import Language.Bond.Codegen.TypeMapping (MappingContext) +import Language.Bond.Codegen.TypeMapping import Language.Bond.Codegen.Haskell.AliasDecl import Language.Bond.Codegen.Haskell.EnumDecl import Language.Bond.Codegen.Haskell.StructDecl diff --git a/src/Language/Bond/Codegen/Haskell/EnumDecl.hs b/src/Language/Bond/Codegen/Haskell/EnumDecl.hs --- a/src/Language/Bond/Codegen/Haskell/EnumDecl.hs +++ b/src/Language/Bond/Codegen/Haskell/EnumDecl.hs @@ -4,7 +4,7 @@ ) where import Language.Bond.Syntax.Types -import Language.Bond.Codegen.TypeMapping (MappingContext(..)) +import Language.Bond.Codegen.TypeMapping import Language.Bond.Codegen.Haskell.Util import Language.Haskell.Exts hiding (mode) import Language.Haskell.Exts.SrcLoc (noLoc) @@ -46,7 +46,7 @@ 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 "getQualifiedName" $ strE $ fromBuilder $ getDeclTypeName ctx{namespaceMapping = []} decl , InsDecl $ wildcardFunc "getElementType" $ Con (implQual "ElementInt32") ] bondEnumDecl = InstDecl noLoc Nothing [] [] (implQual "BondEnum") diff --git a/src/Language/Bond/Codegen/Haskell/SchemaDecl.hs b/src/Language/Bond/Codegen/Haskell/SchemaDecl.hs --- a/src/Language/Bond/Codegen/Haskell/SchemaDecl.hs +++ b/src/Language/Bond/Codegen/Haskell/SchemaDecl.hs @@ -5,7 +5,7 @@ import Language.Bond.Codegen.Haskell.Util -import Language.Bond.Codegen.TypeMapping (MappingContext(..)) +import Language.Bond.Codegen.TypeMapping import Language.Bond.Syntax.Types import Data.Maybe @@ -89,7 +89,7 @@ ] ] makeAttr a = Tuple Boxed - [ strE $ getQualifiedName ctx $ attrName a + [ strE $ fromBuilder $ getQualifiedName ctx $ attrName a , strE $ attrValue a ] @@ -97,7 +97,7 @@ structNameAndType :: MappingContext -> Declaration -> [InstDecl] structNameAndType ctx decl = [ InsDecl $ wildcardFunc "getName" $ nameFunc $ declName decl - , InsDecl $ wildcardFunc "getQualifiedName" $ nameFunc $ getDeclTypeName ctx{namespaceMapping = []} decl + , InsDecl $ wildcardFunc "getQualifiedName" $ nameFunc $ fromBuilder $ 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")) ] diff --git a/src/Language/Bond/Codegen/Haskell/StructDecl.hs b/src/Language/Bond/Codegen/Haskell/StructDecl.hs --- a/src/Language/Bond/Codegen/Haskell/StructDecl.hs +++ b/src/Language/Bond/Codegen/Haskell/StructDecl.hs @@ -5,7 +5,7 @@ ) where import Language.Bond.Syntax.Types -import Language.Bond.Codegen.TypeMapping (MappingContext) +import Language.Bond.Codegen.TypeMapping import Language.Bond.Codegen.Haskell.SchemaDecl import Language.Bond.Codegen.Haskell.Util diff --git a/src/Language/Bond/Codegen/Haskell/TypeMapping.hs b/src/Language/Bond/Codegen/Haskell/TypeMapping.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Haskell/TypeMapping.hs @@ -0,0 +1,20 @@ +module Language.Bond.Codegen.Haskell.TypeMapping + ( haskellTypeMapping + ) where + +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping +import Data.Text.Lazy.Builder + +-- Most of the fields are just use catchers. +-- Can't use mapType for my own type mapping because it returns text, and haskell codegen needs AST type. +haskellTypeMapping :: TypeMapping +haskellTypeMapping = TypeMapping + Nothing + (fromString "") + (singleton '.') + (error "mapType") + (error "fixSyntax") + (error "instanceMapping") + (error "elementMapping") + (error "annotatedMapping") diff --git a/src/Language/Bond/Codegen/Haskell/Util.hs b/src/Language/Bond/Codegen/Haskell/Util.hs --- a/src/Language/Bond/Codegen/Haskell/Util.hs +++ b/src/Language/Bond/Codegen/Haskell/Util.hs @@ -1,13 +1,13 @@ module Language.Bond.Codegen.Haskell.Util where import Data.Char -import Language.Bond.Codegen.TypeMapping (MappingContext(..), NamespaceMapping(..)) +import Language.Bond.Codegen.TypeMapping 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 +import Data.Text.Lazy (unpack) +import Data.Text.Lazy.Builder data CodegenOpts = CodegenOpts { setType :: String @@ -20,6 +20,9 @@ unique :: Ord a => [a] -> [a] unique = map head . group . sort +fromBuilder :: Builder -> String +fromBuilder = unpack . toLazyText + internalModuleName :: ModuleName internalModuleName = ModuleName "Data.Bond.Internal.Imports" @@ -167,28 +170,3 @@ 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]