diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -19,11 +19,13 @@ 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 opts = CodegenOpts + { setType = if hashset options then "HashSet" else "Set" + , deriveEq = not (noEq options) + , deriveShow = not (noShow options) + , deriveNFData = nfData options + , deriveGeneric = nfData options || generic options + } let codegens = if hsboot options then [decl_hs opts, decl_hsboot opts] else [decl_hs opts] diff --git a/app/Options.hs b/app/Options.hs --- a/app/Options.hs +++ b/app/Options.hs @@ -15,6 +15,8 @@ , hashset :: Bool , noShow :: Bool , noEq :: Bool + , generic :: Bool + , nfData :: Bool } deriving (Show, Data, Typeable) @@ -27,8 +29,10 @@ , 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" + , noShow = def &= help "do not derive Show instance for structs" + , noEq = def &= help "do not derive Eq instance for structs" + , generic = def &= help "derive Generic instance for structs" + , nfData = def &= help "derive NFData instance for structs (implies --generic)" } &= name "haskell" &= help "Generate Haskell code" 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.2.0 +version: 0.1.3.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 @@ -29,7 +29,7 @@ Language.Bond.Codegen.Haskell.Util ghc-options: -W -Wall build-depends: base >= 4.7 && < 5 - , bond == 0.4.0.1 + , bond >= 0.4.1.0 && < 0.4.2.0 , filepath >= 1.0 , haskell-src-exts >= 1.16 default-language: Haskell2010 @@ -39,8 +39,8 @@ 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 + , aeson + , bond == 0.4.1.0 , bond-haskell-compiler , bytestring >= 0.10 , cmdargs >= 0.10.10 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 @@ -27,7 +27,7 @@ typeCon = TyCon (UnQual typeName) dataDecl = DataDecl noLoc NewType [] typeName [] [ QualConDecl noLoc [] [] (ConDecl typeName [implType "Int32"]) ] - [ (pQual "Show", []), (pQual "Eq", []), (pQual "Ord", []), (pQual "Enum", []) + [ (pQual "Show", []), (pQual "Eq", []), (implQual "NFData", []), (pQual "Ord", []), (pQual "Enum", []) , (implQual "Hashable", []), (implQual "Default", []), (implQual "Typeable", []) ] bondTypeDecl = InstDecl noLoc Nothing [] [] (implQual "BondType") 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 @@ -113,16 +113,17 @@ where source = Module noLoc moduleName [LanguagePragma noLoc - [Ident "ScopedTypeVariables", Ident "DeriveDataTypeable", Ident "OverloadedStrings"] + ([Ident "ScopedTypeVariables", Ident "DeriveDataTypeable", Ident "OverloadedStrings"] ++ pragmaDeriveGeneric) ] Nothing (Just [EThingAll $ UnQual typeName]) imports - [dataDecl, defaultDecl, bondTypeDecl, - bondStructDecl - ] + ([dataDecl, defaultDecl, bondTypeDecl, bondStructDecl] ++ nfdataDecl) + pragmaDeriveGeneric = [Ident "DeriveGeneric" | deriveGeneric opts] imports = importInternalModule : importPrelude : map (\ m -> importTemplate{importModule = m}) fieldModules + ++ importGhcGenerics + importGhcGenerics = [importGenerics | deriveGeneric opts] typeName = mkType $ makeDeclName decl typeParams = map (\TypeParam{paramName} -> UnkindedVar $ mkVar paramName) declParams @@ -134,9 +135,10 @@ | otherwise = ownFields dataDecl = DataDecl noLoc DataType [] typeName typeParams [QualConDecl noLoc [] [] (RecDecl typeName fields)] - (derivingShow $ derivingEq [(implQual "Typeable", [])]) + (derivingGeneric $ derivingShow $ derivingEq [(implQual "Typeable", [])]) derivingShow = if deriveShow opts then ((pQual "Show", []) :) else id derivingEq = if deriveEq opts then ((pQual "Eq", []) :) else id + derivingGeneric = if deriveGeneric opts then ((pQual "Generic", []) :) else id ownFieldDefaults = map (defaultFieldValue ctx) structFields fieldDefaults | isNothing structBase = ownFieldDefaults @@ -149,6 +151,14 @@ patBind noLoc (PVar $ Ident "defaultValue") $ RecConstr (UnQual typeName) fieldDefaults ] + nfdataDecl = if deriveNFData opts + then [InstDecl noLoc Nothing [] + (map (typeParamConstraint $ implQual "NFData") declParams) + (implQual "NFData") + [makeType True typeName declParams] + [] + ] + else [] bondTypeDecl = InstDecl noLoc Nothing [] (map (typeParamConstraint $ implQual "BondType") declParams) (implQual "BondType") 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 @@ -11,8 +11,10 @@ data CodegenOpts = CodegenOpts { setType :: String - , deriveShow :: Bool , deriveEq :: Bool + , deriveGeneric :: Bool + , deriveNFData :: Bool + , deriveShow :: Bool } unique :: Ord a => [a] -> [a] @@ -67,22 +69,33 @@ importTemplate :: ImportDecl importTemplate = ImportDecl - { importLoc = noLoc, importModule = undefined, - importQualified = True, importSrc = False, importSafe = False, - importPkg = Nothing, importAs = Nothing, importSpecs = Nothing - } + { 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 - } + { importModule = internalModuleName + , importAs = Just internalModuleAlias + } importPrelude :: ImportDecl importPrelude = importTemplate - { importModule = ModuleName "Prelude", - importAs = Just preludeAlias - } + { importModule = ModuleName "Prelude" + , importAs = Just preludeAlias + } + +importGenerics :: ImportDecl +importGenerics = importTemplate + { importModule = ModuleName "GHC.Generics" + , importAs = Just preludeAlias + } mkModuleName :: QualifiedName -> String -> ModuleName mkModuleName ns typename = ModuleName $ intercalate "." $ map capitalize $ ns ++ [typename]