Let getNormalized return Nothing on non-normalizeable functions.
[matthijs/master-project/cλash.git] / 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
57
58 -- | Creates a map of pairs from two maps. The maps must have the same
59 --   structure.
60 zipValueMaps :: (Show a, Show b) => HsValueMap a -> HsValueMap b -> HsValueMap (a, b)
61 zipValueMaps = zipValueMapsWith (\a b -> (a, b))
62
63 -- | Creates a map of two maps using the given combination function.
64 zipValueMapsWith :: (Show a, Show b) => (a -> b -> c) -> HsValueMap a -> HsValueMap b -> HsValueMap c
65 zipValueMapsWith f (Tuple as) (Tuple bs) =
66   Tuple $ zipWith (zipValueMapsWith f) as bs
67 zipValueMapsWith f (Single a) (Single b) =
68   Single $ f a b
69 zipValueMapsWith _ a b =
70   --Tuple []
71   error $ "Trying to zip unsimilarly formed trees!\n" ++ (show a) ++ "\nand\n" ++ (show b)
72