root / src / Ganeti / THH / Types.hs @ d8216f2d
History | View | Annotate | Download (3.3 kB)
1 | f3a522ff | Petr Pudlak | {-# LANGUAGE TemplateHaskell #-} |
---|---|---|---|
2 | f3a522ff | Petr Pudlak | |
3 | f3a522ff | Petr Pudlak | {-| Utility Template Haskell functions for working with types. |
4 | f3a522ff | Petr Pudlak | |
5 | f3a522ff | Petr Pudlak | -} |
6 | f3a522ff | Petr Pudlak | |
7 | f3a522ff | Petr Pudlak | {- |
8 | f3a522ff | Petr Pudlak | |
9 | f3a522ff | Petr Pudlak | Copyright (C) 2013 Google Inc. |
10 | f3a522ff | Petr Pudlak | |
11 | f3a522ff | Petr Pudlak | This program is free software; you can redistribute it and/or modify |
12 | f3a522ff | Petr Pudlak | it under the terms of the GNU General Public License as published by |
13 | f3a522ff | Petr Pudlak | the Free Software Foundation; either version 2 of the License, or |
14 | f3a522ff | Petr Pudlak | (at your option) any later version. |
15 | f3a522ff | Petr Pudlak | |
16 | f3a522ff | Petr Pudlak | This program is distributed in the hope that it will be useful, but |
17 | f3a522ff | Petr Pudlak | WITHOUT ANY WARRANTY; without even the implied warranty of |
18 | f3a522ff | Petr Pudlak | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
19 | f3a522ff | Petr Pudlak | General Public License for more details. |
20 | f3a522ff | Petr Pudlak | |
21 | f3a522ff | Petr Pudlak | You should have received a copy of the GNU General Public License |
22 | f3a522ff | Petr Pudlak | along with this program; if not, write to the Free Software |
23 | f3a522ff | Petr Pudlak | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
24 | f3a522ff | Petr Pudlak | 02110-1301, USA. |
25 | f3a522ff | Petr Pudlak | |
26 | f3a522ff | Petr Pudlak | -} |
27 | f3a522ff | Petr Pudlak | |
28 | f3a522ff | Petr Pudlak | module Ganeti.THH.Types |
29 | f3a522ff | Petr Pudlak | ( typeOfFun |
30 | f3a522ff | Petr Pudlak | , funArgs |
31 | f3a522ff | Petr Pudlak | , tupleArgs |
32 | f3a522ff | Petr Pudlak | , uncurryVarType |
33 | f3a522ff | Petr Pudlak | , uncurryVar |
34 | f3a522ff | Petr Pudlak | , OneTuple(..) |
35 | f3a522ff | Petr Pudlak | ) where |
36 | f3a522ff | Petr Pudlak | |
37 | f3a522ff | Petr Pudlak | import Control.Arrow (first) |
38 | f3a522ff | Petr Pudlak | import Control.Monad (liftM) |
39 | f3a522ff | Petr Pudlak | import Language.Haskell.TH |
40 | f3a522ff | Petr Pudlak | import qualified Text.JSON as J |
41 | f3a522ff | Petr Pudlak | |
42 | f3a522ff | Petr Pudlak | -- | This fills the gap between @()@ and @(,)@, providing a wrapper for |
43 | f3a522ff | Petr Pudlak | -- 1-element tuples. It's needed for RPC, where arguments for a function are |
44 | f3a522ff | Petr Pudlak | -- sent as a list of values, and therefore for 1-argument functions we need |
45 | f3a522ff | Petr Pudlak | -- this wrapper, which packs/unpacks 1-element lists. |
46 | f3a522ff | Petr Pudlak | newtype OneTuple a = OneTuple { getOneTuple :: a } |
47 | f3a522ff | Petr Pudlak | deriving (Eq, Ord, Show) |
48 | f3a522ff | Petr Pudlak | instance Functor OneTuple where |
49 | f3a522ff | Petr Pudlak | fmap f (OneTuple x) = OneTuple (f x) |
50 | f3a522ff | Petr Pudlak | -- The value is stored in @JSON@ as a 1-element list. |
51 | f3a522ff | Petr Pudlak | instance J.JSON a => J.JSON (OneTuple a) where |
52 | f3a522ff | Petr Pudlak | showJSON (OneTuple a) = J.JSArray [J.showJSON a] |
53 | f3a522ff | Petr Pudlak | readJSON (J.JSArray [x]) = liftM OneTuple (J.readJSON x) |
54 | f3a522ff | Petr Pudlak | readJSON _ = J.Error "Unable to read 1 tuple" |
55 | f3a522ff | Petr Pudlak | |
56 | f3a522ff | Petr Pudlak | -- | Returns the type of a function. If the given name doesn't correspond to a |
57 | f3a522ff | Petr Pudlak | -- function, fails. |
58 | f3a522ff | Petr Pudlak | typeOfFun :: Name -> Q Type |
59 | f3a522ff | Petr Pudlak | typeOfFun name = reify name >>= args |
60 | f3a522ff | Petr Pudlak | where |
61 | f3a522ff | Petr Pudlak | args :: Info -> Q Type |
62 | f3a522ff | Petr Pudlak | args (VarI _ tp _ _) = return tp |
63 | f3a522ff | Petr Pudlak | args _ = fail $ "Not a function: " ++ show name |
64 | f3a522ff | Petr Pudlak | |
65 | f3a522ff | Petr Pudlak | -- | Splits a function type into the types of its arguments and the result. |
66 | f3a522ff | Petr Pudlak | funArgs :: Type -> ([Type], Type) |
67 | f3a522ff | Petr Pudlak | funArgs = first reverse . f [] |
68 | f3a522ff | Petr Pudlak | where |
69 | f3a522ff | Petr Pudlak | f ts (ForallT _ _ x) = f ts x |
70 | f3a522ff | Petr Pudlak | f ts (AppT (AppT ArrowT t) x) = f (t:ts) x |
71 | f3a522ff | Petr Pudlak | f ts x = (ts, x) |
72 | f3a522ff | Petr Pudlak | |
73 | f3a522ff | Petr Pudlak | tupleArgs :: Type -> Maybe [Type] |
74 | f3a522ff | Petr Pudlak | tupleArgs = fmap reverse . f [] |
75 | f3a522ff | Petr Pudlak | where |
76 | f3a522ff | Petr Pudlak | f ts (TupleT _) = Just ts |
77 | f3a522ff | Petr Pudlak | f ts (AppT (AppT ArrowT x) t) = f (t:ts) x |
78 | f3a522ff | Petr Pudlak | f _ _ = Nothing |
79 | f3a522ff | Petr Pudlak | |
80 | f3a522ff | Petr Pudlak | -- | Generic 'uncurry' that counts the number of function arguments in a type |
81 | f3a522ff | Petr Pudlak | -- and constructs the appropriate uncurry function into @i -> o@. |
82 | f3a522ff | Petr Pudlak | -- It the type has no arguments, it's converted into @() -> o@. |
83 | f3a522ff | Petr Pudlak | uncurryVarType :: Type -> Q Exp |
84 | f3a522ff | Petr Pudlak | uncurryVarType = uncurryN . length . fst . funArgs |
85 | f3a522ff | Petr Pudlak | where |
86 | f3a522ff | Petr Pudlak | uncurryN 0 = do |
87 | f3a522ff | Petr Pudlak | f <- newName "f" |
88 | f3a522ff | Petr Pudlak | return $ LamE [VarP f, TupP []] (VarE f) |
89 | f3a522ff | Petr Pudlak | uncurryN 1 = [| (. getOneTuple) |] |
90 | f3a522ff | Petr Pudlak | uncurryN n = do |
91 | f3a522ff | Petr Pudlak | f <- newName "f" |
92 | f3a522ff | Petr Pudlak | ps <- mapM newName (replicate n "x") |
93 | f3a522ff | Petr Pudlak | return $ LamE (VarP f : map VarP ps) (foldl AppE (VarE f) $ map VarE ps) |
94 | f3a522ff | Petr Pudlak | |
95 | f3a522ff | Petr Pudlak | -- | Creates an uncurried version of a function. |
96 | f3a522ff | Petr Pudlak | -- If the function has no arguments, it's converted into @() -> o@. |
97 | f3a522ff | Petr Pudlak | uncurryVar :: Name -> Q Exp |
98 | f3a522ff | Petr Pudlak | uncurryVar name = do |
99 | f3a522ff | Petr Pudlak | t <- typeOfFun name |
100 | f3a522ff | Petr Pudlak | appE (uncurryVarType t) (varE name) |