Shapify.hs

   1 module Shapify where
   2
   3 import Util
   4 import AST
   5
   6 import Data.Map (Map)
   7 import qualified Data.Map as Map
   8
   9 import Data.Function (fix)
  10 import Data.Maybe
  11 import Data.List ((\\), intersect)
  12
  13 -- replaces  "Nil :: Unit"            -> "Z"
  14 --           "Cons(_,y) :: List Unit" ->  S(y)
  15 introNat :: AST -> AST
  16 introNat (AST decls) =
  17     AST $ map introNatD decls
  18     where
  19       natT = TCon (Name "Nat") []
  20       zP i   = PCon i natT (Name "Z") []
  21       sP i x = PCon i natT (Name "S") [x]
  22       zE i   = ECon i natT (Name "Z") []
  23       sE i x = ECon i natT (Name "S") [x]
  24       introNatD (Decl f (TFun is ts t) ps e) =
  25           let ts' = map replT ts
  26               t'  = replT t
  27               ps' = map replP ps
  28               e'  = replE e
  29           in Decl f (TFun is ts' t') ps' e'
  30       replT (TCon (Name "List") [TCon (Name "Unit") []])
  31           = TCon (Name "Nat") []
  32       replT (TVar i)    = TVar i
  33       replT (TCon c ts) = TCon c (map replT ts)
  34
  35       replP (PVar i (TCon (Name "List") [TCon (Name "Unit") []]) x)
  36           = PVar i (TCon (Name "Nat") []) x
  37       replP (PVar i t x)
  38           = PVar i (replT t) x
  39       replP (PCon i (TCon (Name "List") [TCon (Name "Unit") []])
  40                       (Name "Nil") [])
  41           = zP i
  42       replP (PCon i (TCon (Name "List") [TCon (Name "Unit") []])
  43                       (Name "Cons") [x,y])
  44           = sP i (replP y)
  45       replP (PCon i t c ps)
  46           = PCon i (replT t) c (map replP ps)
  47
  48       replE (EVar i (TCon (Name "List") [TCon (Name "Unit") []]) x)
  49           = EVar i (TCon (Name "Nat") []) x
  50       replE (EVar i t x)
  51           = EVar i (replT t) x
  52       replE (ECon i (TCon (Name "List") [TCon (Name "Unit") []])
  53                       (Name "Nil") [])
  54           = zE i
  55       replE (ECon i (TCon (Name "List") [TCon (Name "Unit") []])
  56                       (Name "Cons") [x,y])
  57           = sE i (replE y)
  58       replE (ECon i t c es) = ECon i (replT t) c (map replE es)
  59       replE (EFun i t f es) = EFun i (replT t) f (map replE es)
  60
  61
  62 -- removes parameters/arguments of which type is Unit
  63 -- FIXME: This function only checks "Unit" but no singleton types.
  64 specializeUnit :: AST -> AST
  65 specializeUnit (AST decls) =
  66     assignIDsAST $ AST $ map spUnitD decls
  67     where
  68       spUnitD (Decl f (TFun is ts t) ps e) =
  69           let isUnits = map isUnit ts
  70               ts'     = map fst $ filter (\(_,b) -> not b) $ zip ts isUnits
  71               ps'     = map fst $ filter (\(_,b) -> not b) $ zip ps isUnits
  72           in Decl f (TFun is ts' t) ps' (spUnitE e)
  73       spUnitE (EVar i t x)    = EVar i t x
  74       spUnitE (ECon i t c es) = ECon i t c (map spUnitE es)
  75       spUnitE (EFun i t f es) =
  76           let isUnits = map isUnit (map typeofE es)
  77               es'     = map fst $ filter (\(_,b) -> not b) $
  78                           zip (map spUnitE es) isUnits
  79           in EFun i t f es'
  80       isUnit (TCon (Name "Unit") []) = True
  81       isUnit _                       = False
  82
  83
  84 -- replaces all "e::t" -> "Unit::Unit"
  85 --          and "p::t" -> "Unit::Unit"
  86 -- in functions with type
  87 --              "forall ... t ... . ..."
  88 shapify :: AST -> AST
  89 shapify (AST decls) = --AST $ map shapifyD decls
  90     specializeUnit $
  91      AST $ fix (\f proced pend rdecls ->
  92                  let rest = pend \\ proced
  93                  in if null rest then
  94                         rdecls
  95                     else
  96                         let decls' = shapifySig rest
  97                             pend'  = collectPending decls'
  98                         in f (rest++proced) pend' (decls'++rdecls))
  99             [] initPend []
 100     where
 101 --       initPend = Map.toList $ Map.fromList $ map
 102 --                    (\(Decl f (TFun is ts t) _ _) ->
 103 --                         (f,TFun [] (map (replT is) ts) (replT is t))) decls
 104       initPend = Map.toList $ Map.fromList $ map
 105                   (\(Decl f (TFun is _ _) _ _) -> (f,is)) decls
 106
 107       unitT = TCon (Name "Unit") []
 108       unitP i = PCon i unitT (Name "Unit") []
 109       unitE i = ECon i unitT (Name "Unit") []
 110
 111       signituresMap
 112           = Map.fromList $ map
 113             (\(Decl f (TFun is ts t) _ _) -> (f,TFun is ts t)) decls
 114
 115       collectPending decls =
 116           snub $ concatMap (\(Decl _ _ _ e) -> funCallsWithT e) decls
 117       funCallsWithT (EVar _ _ _)    = []
 118       funCallsWithT (ECon _ _ _ es) = concatMap funCallsWithT es
 119       funCallsWithT (EFun _ _ (IName f is) es)
 120           = (Name f,is):concatMap funCallsWithT es
 121       funCallsWithT (EFun _ _ _ es) = concatMap funCallsWithT es
 122 --       funCallsWithT (EFun t f es) = (f,TFun [] (map typeofE es) t):
 123 --                                        concatMap funCallsWithT es
 124       shapifySig [] = []
 125       shapifySig ((f,is'):rs)
 126           = concatMap (\(d@(Decl g (TFun _ _ _) _ _))  ->
 127                            if f == g then
 128                                [shapifyD is' d]
 129                            else
 130                                []
 131                            ) decls ++shapifySig rs
 132       unifyU []                                   = []
 133       unifyU ((TCon (Name "Unit") [], TVar i):rs)    = i:unifyU rs
 134       unifyU ((TVar i, TCon (Name "Unit") []):rs)    = i:unifyU rs
 135       unifyU ((TCon c ts, TCon c' ts'):rs) | c == c' = unifyU (zip ts ts') ++ unifyU rs
 136       unifyU (_:rs)                                  = unifyU rs
 137       shapifyD is' (Decl (Name s) (TFun is ts t) ps e)
 138           = let ftype = (TFun (is\\is') (map (replT is') ts) (replT is' t))
 139             in Decl (IName s is') ftype
 140                    (map (replP is') ps) (replE is' e)
 141       replT is (TVar i) | i `elem` is = unitT
 142                         | otherwise   = TVar i
 143       replT is (TCon c ts) = TCon c (map (replT is) ts)
 144
 145       replP is p =
 146           case typeofP p of
 147             TVar i | i `elem` is -> unitP (idofP p)
 148             _ ->
 149                 case p of
 150                   PVar i t x    -> PVar i (replT is t) x
 151                   PCon i t c ps -> PCon i (replT is t) c (map (replP is) ps)
 152
 153       replE is e =
 154           case typeofE e of
 155             TVar i | i `elem` is -> unitE (idofE e)
 156             _ ->
 157                 case e of
 158                   EVar i t x    -> EVar i (replT is t) x
 159                   ECon i t c es -> ECon i (replT is t) c (map (replE is) es)
 160                   EFun i t (IName f _) es ->
 161                       funCallE i is t f es
 162                   EFun i t (Name f) es ->
 163                       funCallE i is t f es
 164           where funCallE i is t f es =
 165                     let es' = map (replE is) es
 166                         TFun is' ts' t'
 167                             = fromJust $ Map.lookup (Name f) signituresMap
 168                         ts  = map typeofE es'
 169                         is'' = intersect
 170                                  is'
 171                                  (snub $ unifyU $ zip (t:ts) (t':ts'))
 172                     in
 173                       EFun i (replT is t) (IName f is'') es'