Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH / Types.hs @ 2992f2f7

History | View | Annotate | Download (3.3 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| Utility Template Haskell functions for working with types.
4

    
5
-}
6

    
7
{-
8

    
9
Copyright (C) 2013 Google Inc.
10

    
11
This program is free software; you can redistribute it and/or modify
12
it under the terms of the GNU General Public License as published by
13
the Free Software Foundation; either version 2 of the License, or
14
(at your option) any later version.
15

    
16
This program is distributed in the hope that it will be useful, but
17
WITHOUT ANY WARRANTY; without even the implied warranty of
18
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19
General Public License for more details.
20

    
21
You should have received a copy of the GNU General Public License
22
along with this program; if not, write to the Free Software
23
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24
02110-1301, USA.
25

    
26
-}
27

    
28
module Ganeti.THH.Types
29
  ( typeOfFun
30
  , funArgs
31
  , tupleArgs
32
  , uncurryVarType
33
  , uncurryVar
34
  , OneTuple(..)
35
  ) where
36

    
37
import Control.Arrow (first)
38
import Control.Monad (liftM)
39
import Language.Haskell.TH
40
import qualified Text.JSON as J
41

    
42
-- | This fills the gap between @()@ and @(,)@, providing a wrapper for
43
-- 1-element tuples. It's needed for RPC, where arguments for a function are
44
-- sent as a list of values, and therefore for 1-argument functions we need
45
-- this wrapper, which packs/unpacks 1-element lists.
46
newtype OneTuple a = OneTuple { getOneTuple :: a }
47
  deriving (Eq, Ord, Show)
48
instance Functor OneTuple where
49
  fmap f (OneTuple x) = OneTuple (f x)
50
-- The value is stored in @JSON@ as a 1-element list.
51
instance J.JSON a => J.JSON (OneTuple a) where
52
  showJSON (OneTuple a) = J.JSArray [J.showJSON a]
53
  readJSON (J.JSArray [x]) = liftM OneTuple (J.readJSON x)
54
  readJSON _               = J.Error "Unable to read 1 tuple"
55

    
56
-- | Returns the type of a function. If the given name doesn't correspond to a
57
-- function, fails.
58
typeOfFun :: Name -> Q Type
59
typeOfFun name = reify name >>= args
60
  where
61
    args :: Info -> Q Type
62
    args (VarI _ tp _ _) = return tp
63
    args _               = fail $ "Not a function: " ++ show name
64

    
65
-- | Splits a function type into the types of its arguments and the result.
66
funArgs :: Type -> ([Type], Type)
67
funArgs = first reverse . f []
68
  where
69
    f ts (ForallT _ _ x)            = f ts x
70
    f ts (AppT (AppT ArrowT t) x)   = f (t:ts) x
71
    f ts x                          = (ts, x)
72

    
73
tupleArgs :: Type -> Maybe [Type]
74
tupleArgs = fmap reverse . f []
75
  where
76
    f ts (TupleT _)                = Just ts
77
    f ts (AppT (AppT ArrowT x) t)  = f (t:ts) x
78
    f _  _                         = Nothing
79

    
80
-- | Generic 'uncurry' that counts the number of function arguments in a type
81
-- and constructs the appropriate uncurry function into @i -> o@.
82
-- It the type has no arguments, it's converted into @() -> o@.
83
uncurryVarType :: Type -> Q Exp
84
uncurryVarType = uncurryN . length . fst . funArgs
85
  where
86
    uncurryN 0 = do
87
      f <- newName "f"
88
      return $ LamE [VarP f, TupP []] (VarE f)
89
    uncurryN 1 = [| (. getOneTuple) |]
90
    uncurryN n = do
91
      f <- newName "f"
92
      ps <- mapM newName (replicate n "x")
93
      return $ LamE [VarP f, TupP $ map VarP ps]
94
                 (foldl AppE (VarE f) $ map VarE ps)
95

    
96
-- | Creates an uncurried version of a function.
97
-- If the function has no arguments, it's converted into @() -> o@.
98
uncurryVar :: Name -> Q Exp
99
uncurryVar name = do
100
  t <- typeOfFun name
101
  appE (uncurryVarType t) (varE name)