Merge branch 'stable-2.15' into stable-2.16
[ganeti-github.git] / src / Ganeti / THH / PyType.hs
1 {-# LANGUAGE TemplateHaskell #-}
2
3 {-| PyType helper for Ganeti Haskell code.
4
5 -}
6
7 {-
8
9 Copyright (C) 2013 Google Inc.
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions are
14 met:
15
16 1. Redistributions of source code must retain the above copyright notice,
17 this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in the
21 documentation and/or other materials provided with the distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
27 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35 -}
36 module Ganeti.THH.PyType
37 ( PyType(..)
38 , pyType
39 , pyOptionalType
40 ) where
41
42 import Control.Applicative
43 import Control.Monad
44 import Data.List (intercalate)
45 import Language.Haskell.TH
46 import Language.Haskell.TH.Syntax (Lift(..))
47
48 import Ganeti.PyValue
49
50
51 -- | Represents a Python encoding of types.
52 data PyType
53 = PTMaybe PyType
54 | PTApp PyType [PyType]
55 | PTOther String
56 | PTAny
57 | PTDictOf
58 | PTListOf
59 | PTNone
60 | PTObject
61 | PTOr
62 | PTSetOf
63 | PTTupleOf
64 deriving (Show, Eq, Ord)
65
66 -- TODO: We could use th-lift to generate this instance automatically.
67 instance Lift PyType where
68 lift (PTMaybe x) = [| PTMaybe x |]
69 lift (PTApp tf as) = [| PTApp tf as |]
70 lift (PTOther i) = [| PTOther i |]
71 lift PTAny = [| PTAny |]
72 lift PTDictOf = [| PTDictOf |]
73 lift PTListOf = [| PTListOf |]
74 lift PTNone = [| PTNone |]
75 lift PTObject = [| PTObject |]
76 lift PTOr = [| PTOr |]
77 lift PTSetOf = [| PTSetOf |]
78 lift PTTupleOf = [| PTTupleOf |]
79
80 instance PyValue PyType where
81 -- Use lib/ht.py type aliases to avoid Python creating redundant
82 -- new match functions for commonly used OpCode param types.
83 showValue (PTMaybe (PTOther "NonEmptyString")) = ht "MaybeString"
84 showValue (PTMaybe (PTOther "Bool")) = ht "MaybeBool"
85 showValue (PTMaybe PTDictOf) = ht "MaybeDict"
86 showValue (PTMaybe PTListOf) = ht "MaybeList"
87
88 showValue (PTMaybe x) = ptApp (ht "Maybe") [x]
89 showValue (PTApp tf as) = ptApp (showValue tf) as
90 showValue (PTOther i) = ht i
91 showValue PTAny = ht "Any"
92 showValue PTDictOf = ht "DictOf"
93 showValue PTListOf = ht "ListOf"
94 showValue PTNone = ht "None"
95 showValue PTObject = ht "Object"
96 showValue PTOr = ht "Or"
97 showValue PTSetOf = ht "SetOf"
98 showValue PTTupleOf = ht "TupleOf"
99
100 ht :: String -> String
101 ht = ("ht.T" ++)
102
103 ptApp :: String -> [PyType] -> String
104 ptApp name ts = name ++ "(" ++ intercalate ", " (map showValue ts) ++ ")"
105
106 -- | Converts a Haskell type name into a Python type name.
107 pyTypeName :: Name -> PyType
108 pyTypeName name =
109 case nameBase name of
110 "()" -> PTNone
111 "Map" -> PTDictOf
112 "Set" -> PTSetOf
113 "ListSet" -> PTSetOf
114 "Either" -> PTOr
115 "GenericContainer" -> PTDictOf
116 "JSValue" -> PTAny
117 "JSObject" -> PTObject
118 str -> PTOther str
119
120 -- | Converts a Haskell type into a Python type.
121 pyType :: Type -> Q PyType
122 pyType t | not (null args) = PTApp `liftM` pyType fn `ap` mapM pyType args
123 where (fn, args) = pyAppType t
124 pyType (ConT name) = return $ pyTypeName name
125 pyType ListT = return PTListOf
126 pyType (TupleT 0) = return PTNone
127 pyType (TupleT _) = return PTTupleOf
128 pyType typ = fail $ "unhandled case for type " ++ show typ
129
130 -- | Returns a type and its type arguments.
131 pyAppType :: Type -> (Type, [Type])
132 pyAppType = g []
133 where
134 g as (AppT typ1 typ2) = g (typ2 : as) typ1
135 g as typ = (typ, as)
136
137 -- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
138 -- where @opt@ determines if the converted type is optional (i.e.,
139 -- Maybe).
140 pyOptionalType :: Bool -> Type -> Q PyType
141 pyOptionalType True typ = PTMaybe <$> pyType typ
142 pyOptionalType False typ = pyType typ