Use a data type when generating Python types of OpCodes

Currently they are generated only as Strings.
Signed-off-by: Petr Pudlak <pudlak@google.com>
Reviewed-by: Jose A. Lopes <jabolopes@google.com>

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/UDSServer.hs \
 	src/Ganeti/Utils.hs

src/Ganeti/Hs2Py/GenOpCodes.hs

@@ -44,9 +44,10 @@ 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
@@ -72,7 +73,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.

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
-        
--- | 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,10 +643,10 @@ 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
      [| OpCodeDescriptor $consName'
-                         $consType'
+                         consType'
                          $consDoc'
                          $(listE $ map pyField consFields)
                          consDscField |]

src/Ganeti/THH/PyType.hs

+{-# 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
+
+-- | 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