HsValueMap.hs

   1 -- | This module provides the HsValueMap type, which can structurally map a
   2 --   Haskell value to something else.
   3 module HsValueMap where
   4
   5 import qualified Type
   6 import qualified TyCon
   7 import Control.Applicative
   8 import Data.Traversable
   9 import Data.Foldable
  10
  11 -- | A datatype that maps each of the single values in a haskell structure to
  12 -- a mapto. The map has the same structure as the haskell type mapped, ie
  13 -- nested tuples etc.
  14 data HsValueMap mapto =
  15   Tuple [HsValueMap mapto]
  16   | Single mapto
  17   deriving (Show, Eq, Ord)
  18
  19 instance Functor HsValueMap where
  20   fmap f (Single s) = Single (f s)
  21   fmap f (Tuple maps) = Tuple (map (fmap f) maps)
  22
  23 instance Foldable HsValueMap where
  24   foldMap f (Single s) = f s
  25   -- The first foldMap folds a list of HsValueMaps, the second foldMap folds
  26   -- each of the HsValueMaps in that list
  27   foldMap f (Tuple maps) = foldMap (foldMap f) maps
  28
  29 instance Traversable HsValueMap where
  30   traverse f (Single s) = Single <$> f s
  31   traverse f (Tuple maps) = Tuple <$> (traverse (traverse f) maps)
  32
  33 data PassState s x = PassState (s -> (s, x))
  34
  35 instance Functor (PassState s) where
  36   fmap f (PassState a) = PassState (\s -> let (s', a') = a s in (s', f a'))
  37
  38 instance Applicative (PassState s) where
  39   pure x = PassState (\s -> (s, x))
  40   PassState f <*> PassState x = PassState (\s -> let (s', f') = f s; (s'', x') = x s' in (s'', f' x'))
  41
  42 -- | Creates a HsValueMap with the same structure as the given type, using the
  43 --   given function for mapping the single types.
  44 mkHsValueMap ::
  45   Type.Type                         -- ^ The type to map to a HsValueMap
  46   -> HsValueMap Type.Type           -- ^ The resulting map and state
  47
  48 mkHsValueMap ty =
  49   case Type.splitTyConApp_maybe ty of
  50     Just (tycon, args) ->
  51       if (TyCon.isTupleTyCon tycon)
  52         then
  53           Tuple (map mkHsValueMap args)
  54         else
  55           Single ty
  56     Nothing -> Single ty