On Fri, Dec 13, 2013 at 12:47:53PM +0100, Petr Pudlak wrote:
> Currently they are generated only as Strings.
>
> Signed-off-by: Petr Pudlak <[email protected]>
> ---
> Makefile.am | 2 +
> src/Ganeti/Hs2Py/GenOpCodes.hs | 7 ++-
> src/Ganeti/THH.hs | 102 +++++----------------------------
> src/Ganeti/THH/PyType.hs | 126
> +++++++++++++++++++++++++++++++++++++++++
> 4 files changed, 147 insertions(+), 90 deletions(-)
> create mode 100644 src/Ganeti/THH/PyType.hs
>
> diff --git a/Makefile.am b/Makefile.am
> index e50d369..d4489e7 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -129,6 +129,7 @@ HS_DIRS = \
> src/Ganeti/Storage/Diskstats \
> src/Ganeti/Storage/Drbd \
> src/Ganeti/Storage/Lvm \
> + src/Ganeti/THH \
> test/hs \
> test/hs/Test \
> test/hs/Test/Ganeti \
> @@ -726,6 +727,7 @@ HS_LIB_SRCS = \
> src/Ganeti/Storage/Lvm/Types.hs \
> src/Ganeti/Storage/Utils.hs \
> src/Ganeti/THH.hs \
> + src/Ganeti/THH/PyType.hs \
> src/Ganeti/Types.hs \
> src/Ganeti/Utils.hs
>
> diff --git a/src/Ganeti/Hs2Py/GenOpCodes.hs b/src/Ganeti/Hs2Py/GenOpCodes.hs
> index 5f0c48c..d59602f 100644
> --- a/src/Ganeti/Hs2Py/GenOpCodes.hs
> +++ b/src/Ganeti/Hs2Py/GenOpCodes.hs
> @@ -44,10 +44,11 @@ pyClassDoc doc
> -- | Generates an opcode parameter in Python.
> pyClassField :: OpCodeField -> String
> pyClassField (OpCodeField name typ Nothing doc) =
> - "(" ++ intercalate ", " [show name, "None", typ, show doc] ++ ")"
> + "(" ++ intercalate ", " [show name, "None", showValue typ, show doc] ++ ")"
>
> pyClassField (OpCodeField name typ (Just def) doc) =
> - "(" ++ intercalate ", " [show name, showValue def, typ, show doc] ++ ")"
> + "(" ++ intercalate ", "
> + [show name, showValue def, showValue typ, show doc] ++ ")"
>
> -- | Comma intercalates and indents opcode parameters in Python.
> intercalateIndent :: [String] -> String
> @@ -73,7 +74,7 @@ showPyClass (OpCodeDescriptor name typ doc fields dsc) =
> " OP_PARAMS = [" ++
> intercalateIndent (map pyClassField fields) ++
> "\n ]" ++ "\n" ++
> - " OP_RESULT = " ++ typ ++
> + " OP_RESULT = " ++ showValue typ ++
> withLU ++ "\n\n"
>
> -- | Generates all opcodes as Python classes.
> diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
> index c6b48e6..3092733 100644
> --- a/src/Ganeti/THH.hs
> +++ b/src/Ganeti/THH.hs
> @@ -10,7 +10,7 @@ needs in this module (except the one for unittests).
>
> {-
>
> -Copyright (C) 2011, 2012 Google Inc.
> +Copyright (C) 2011, 2012, 2013 Google Inc.
>
> This program is free software; you can redistribute it and/or modify
> it under the terms of the GNU General Public License as published by
> @@ -81,6 +81,7 @@ import Text.JSON.Pretty (pp_value)
>
> import Ganeti.JSON
> import Ganeti.PyValue
> +import Ganeti.THH.PyType
>
>
> -- * Exported types
> @@ -587,7 +588,7 @@ type OpParam = (String, Q Type, Q Exp)
> -- * Python code generation
>
> data OpCodeField = OpCodeField { ocfName :: String
> - , ocfType :: String
> + , ocfType :: PyType
> , ocfDefl :: Maybe PyValueEx
> , ocfDoc :: String
> }
> @@ -595,87 +596,12 @@ data OpCodeField = OpCodeField { ocfName :: String
> -- | Transfers opcode data between the opcode description (through
> -- @genOpCode@) and the Python code generation functions.
> data OpCodeDescriptor = OpCodeDescriptor { ocdName :: String
> - , ocdType :: String
> + , ocdType :: PyType
> , ocdDoc :: String
> , ocdFields :: [OpCodeField]
> , ocdDescr :: String
> }
>
> --- | Strips out the module name
> ---
> --- @
> --- pyBaseName "Data.Map" = "Map"
> --- @
> -pyBaseName :: String -> String
> -pyBaseName str =
> - case span (/= '.') str of
> - (x, []) -> x
> - (_, _:x) -> pyBaseName x
> -
> --- | Converts a Haskell type name into a Python type name.
> ---
> --- @
> --- pyTypename "Bool" = "ht.TBool"
> --- @
> -pyTypeName :: Show a => a -> String
> -pyTypeName name =
> - "ht.T" ++ (case pyBaseName (show name) of
> - "()" -> "None"
> - "Map" -> "DictOf"
> - "Set" -> "SetOf"
> - "ListSet" -> "SetOf"
> - "Either" -> "Or"
> - "GenericContainer" -> "DictOf"
> - "JSValue" -> "Any"
> - "JSObject" -> "Object"
> - str -> str)
> -
> --- | Converts a Haskell type into a Python type.
> ---
> --- @
> --- pyType [Int] = "ht.TListOf(ht.TInt)"
> --- @
> -pyType :: Type -> Q String
> -pyType (AppT typ1 typ2) =
> - do t <- pyCall typ1 typ2
> - return $ t ++ ")"
> -
> -pyType (ConT name) = return (pyTypeName name)
> -pyType ListT = return "ht.TListOf"
> -pyType (TupleT 0) = return "ht.TNone"
> -pyType (TupleT _) = return "ht.TTupleOf"
> -pyType typ = error $ "unhandled case for type " ++ show typ
> -
Trailing whitespace.
> --- | Converts a Haskell type application into a Python type.
> ---
> --- @
> --- Maybe Int = "ht.TMaybe(ht.TInt)"
> --- @
> -pyCall :: Type -> Type -> Q String
> -pyCall (AppT typ1 typ2) arg =
> - do t <- pyCall typ1 typ2
> - targ <- pyType arg
> - return $ t ++ ", " ++ targ
> -
> -pyCall typ1 typ2 =
> - do t1 <- pyType typ1
> - t2 <- pyType typ2
> - return $ t1 ++ "(" ++ t2
> -
> --- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
> --- where @opt@ determines if the converted type is optional (i.e.,
> --- Maybe).
> ---
> --- @
> --- pyType False [Int] = "ht.TListOf(ht.TInt)" (mandatory)
> --- pyType True [Int] = "ht.TMaybe(ht.TListOf(ht.TInt))" (optional)
> --- @
> -pyOptionalType :: Bool -> Type -> Q String
> -pyOptionalType opt typ
> - | opt = do t <- pyType typ
> - return $ "ht.TMaybe(" ++ t ++ ")"
> - | otherwise = pyType typ
> -
> -- | Optionally encapsulates default values in @PyValueEx@.
> --
> -- @maybeApp exp typ@ returns a quoted expression that encapsulates
> @@ -689,14 +615,15 @@ maybeApp Nothing _ =
> maybeApp (Just expr) typ =
> [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]
>
> -
> -- | Generates a Python type according to whether the field is
> --- optional
> -genPyType' :: OptionalType -> Q Type -> Q Exp
> -genPyType' opt typ = typ >>= pyOptionalType (opt /= NotOptional) >>= stringE
> +-- optional.
> +--
> +-- The type of created expression is PyType.
> +genPyType' :: OptionalType -> Q Type -> Q PyType
> +genPyType' opt typ = typ >>= pyOptionalType (opt /= NotOptional)
>
> -- | Generates Python types from opcode parameters.
> -genPyType :: Field -> Q Exp
> +genPyType :: Field -> Q PyType
> genPyType f = genPyType' (fieldIsOptional f) (fieldType f)
>
> -- | Generates Python default values from opcode parameters.
> @@ -704,8 +631,9 @@ genPyDefault :: Field -> Q Exp
> genPyDefault f = maybeApp (fieldDefault f) (fieldType f)
>
> pyField :: Field -> Q Exp
> -pyField f = [| OpCodeField $(stringE (fieldName f))
> - $(genPyType f)
> +pyField f = genPyType f >>= \t ->
> + [| OpCodeField $(stringE (fieldName f))
> + t
> $(genPyDefault f)
> $(stringE (fieldDoc f)) |]
>
> @@ -715,7 +643,7 @@ pyClass :: OpCodeConstructor -> Q Exp
> pyClass (consName, consType, consDoc, consFields, consDscField) =
> do let pyClassVar = varNameE "showPyClass"
> consName' = stringE consName
> - let consType' = genPyType' NotOptional consType
> + consType' <- genPyType' NotOptional consType
> let consDoc' = stringE consDoc
> {-
> consFieldNames = listE $ map (stringE . fieldName) consFields
> @@ -724,7 +652,7 @@ pyClass (consName, consType, consDoc, consFields,
> consDscField) =
> let consFieldDefaults = genPyDefaults consFields
> -}
> [| OpCodeDescriptor $consName'
> - $consType'
> + consType'
> $consDoc'
> $(listE $ map pyField consFields)
> consDscField |]
> diff --git a/src/Ganeti/THH/PyType.hs b/src/Ganeti/THH/PyType.hs
> new file mode 100644
> index 0000000..cf51b5d
> --- /dev/null
> +++ b/src/Ganeti/THH/PyType.hs
> @@ -0,0 +1,126 @@
> +{-# LANGUAGE TemplateHaskell #-}
> +
> +{-| PyType helper for Ganeti Haskell code.
> +
> +-}
> +
> +{-
> +
> +Copyright (C) 2013 Google Inc.
> +
> +This program is free software; you can redistribute it and/or modify
> +it under the terms of the GNU General Public License as published by
> +the Free Software Foundation; either version 2 of the License, or
> +(at your option) any later version.
> +
> +This program is distributed in the hope that it will be useful, but
> +WITHOUT ANY WARRANTY; without even the implied warranty of
> +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
> +General Public License for more details.
> +
> +You should have received a copy of the GNU General Public License
> +along with this program; if not, write to the Free Software
> +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
> +02110-1301, USA.
> +
> +-}
> +module Ganeti.THH.PyType
> + ( PyType(..)
> + , pyType
> + , pyOptionalType
> + ) where
> +
> +import Control.Applicative
> +import Control.Monad
> +import Data.List (intercalate)
> +import Language.Haskell.TH
> +import Language.Haskell.TH.Syntax (Lift(..))
> +
> +import Ganeti.PyValue
> +
> +
> +-- | Represents a Python encoding of types.
> +data PyType
> + = PTMaybe PyType
> + | PTApp PyType [PyType]
> + | PTOther String
> + | PTAny
> + | PTDictOf
> + | PTListOf
> + | PTNone
> + | PTObject
> + | PTOr
> + | PTSetOf
> + | PTTupleOf
> + deriving (Show, Eq, Ord)
> +
> +-- TODO: We could use th-lift to generate this instance automatically.
> +instance Lift PyType where
> + lift (PTMaybe x) = [| PTMaybe x |]
> + lift (PTApp tf as) = [| PTApp tf as |]
> + lift (PTOther i) = [| PTOther i |]
> + lift PTAny = [| PTAny |]
> + lift PTDictOf = [| PTDictOf |]
> + lift PTListOf = [| PTListOf |]
> + lift PTNone = [| PTNone |]
> + lift PTObject = [| PTObject |]
> + lift PTOr = [| PTOr |]
> + lift PTSetOf = [| PTSetOf |]
> + lift PTTupleOf = [| PTTupleOf |]
> +
> +instance PyValue PyType where
> + showValue (PTMaybe x) = ptApp (ht "Maybe") [x]
> + showValue (PTApp tf as) = ptApp (showValue tf) as
> + showValue (PTOther i) = ht i
> + showValue PTAny = ht "Any"
> + showValue PTDictOf = ht "DictOf"
> + showValue PTListOf = ht "ListOf"
> + showValue PTNone = ht "None"
> + showValue PTObject = ht "Object"
> + showValue PTOr = ht "Or"
> + showValue PTSetOf = ht "SetOf"
> + showValue PTTupleOf = ht "TupleOf"
> +
> +ht :: String -> String
> +ht = ("ht.T" ++)
> +
> +ptApp :: String -> [PyType] -> String
> +ptApp name ts = name ++ "(" ++ intercalate ", " (map showValue ts) ++ ")"
> +
> +-- | Converts a Haskell type name into a Python type name.
> +pyTypeName :: Name -> PyType
> +pyTypeName name =
> + case nameBase name of
> + "()" -> PTNone
> + "Map" -> PTDictOf
> + "Set" -> PTSetOf
> + "ListSet" -> PTSetOf
> + "Either" -> PTOr
> + "GenericContainer" -> PTDictOf
> + "JSValue" -> PTAny
> + "JSObject" -> PTObject
> + str -> PTOther str
> +
> +-- | Converts a Haskell type into a Python type.
> +pyType :: Type -> Q PyType
> +pyType t | not (null args) = PTApp `liftM` pyType fn `ap` mapM pyType args
> + where (fn, args) = pyAppType t
> +pyType (ConT name) = return $ pyTypeName name
> +pyType ListT = return PTListOf
> +pyType (TupleT 0) = return PTNone
> +pyType (TupleT _) = return PTTupleOf
> +pyType typ = fail $ "unhandled case for type " ++ show typ
> +
Trailing whitespace.
> +-- | Returns a type and its type arguments.
> +pyAppType :: Type -> (Type, [Type])
> +pyAppType = g []
> + where
> + g as (AppT typ1 typ2) = g (typ2 : as) typ1
> + g as typ = (typ, as)
> +
> +-- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
> +-- where @opt@ determines if the converted type is optional (i.e.,
> +-- Maybe).
> +pyOptionalType :: Bool -> Type -> Q PyType
> +pyOptionalType True typ = PTMaybe <$> pyType typ
> +pyOptionalType False typ = pyType typ
> --
> 1.8.5.1
>
--
Jose Antonio Lopes
Ganeti Engineering
Google Germany GmbH
Dienerstr. 12, 80331, München
Registergericht und -nummer: Hamburg, HRB 86891
Sitz der Gesellschaft: Hamburg
Geschäftsführer: Graham Law, Christine Elizabeth Flores
Steuernummer: 48/725/00206
Umsatzsteueridentifikationsnummer: DE813741370
