utils/ext-core/Language/Core/CoreUtils.hs

   1 module Language.Core.CoreUtils where
   2
   3 import Language.Core.Core
   4 import Language.Core.Utils
   5
   6 import Data.Generics
   7 import Data.List
   8
   9 splitDataConApp_maybe :: Exp -> Maybe (Qual Dcon, [Ty], [Exp])
  10 splitDataConApp_maybe (Dcon d) = Just (d, [], [])
  11 splitDataConApp_maybe (Appt rator t) =
  12    case splitDataConApp_maybe rator of
  13      Just (r, ts, rs) -> Just (r, ts ++ [t], rs)
  14      Nothing          -> Nothing
  15 splitDataConApp_maybe (App rator rand) =
  16   case splitDataConApp_maybe rator of
  17     Just (r, ts, rs) -> Just (r, ts, rs++[rand])
  18     Nothing -> Nothing
  19 splitDataConApp_maybe _ = Nothing
  20
  21 splitApp :: Exp -> (Exp, [Exp])
  22 splitApp (Appt rator _) = splitApp rator
  23 splitApp (App rator rand) =
  24   case splitApp rator of
  25     (r, rs) -> (r, rs++[rand])
  26 splitApp e = (e, [])
  27
  28 splitAppIgnoreCasts :: Exp -> (Exp, [Exp])
  29 splitAppIgnoreCasts (Appt rator _) = splitApp rator
  30 splitAppIgnoreCasts (App (Cast rator _) rand) = splitApp (App rator rand)
  31 splitAppIgnoreCasts (App rator rand) =
  32   case splitApp rator of
  33     (r, rs) -> (r, rs++[rand])
  34 splitAppIgnoreCasts e = (e, [])
  35
  36 splitFunTy_maybe :: Ty -> Maybe ([Ty], Ty)
  37 splitFunTy_maybe (Tforall _ t) = splitFunTy_maybe t
  38 splitFunTy_maybe t =
  39   case splitFunTy2_maybe t of
  40     Just (rator, rand) -> case splitFunTy_maybe rand of
  41                             Just (r,s) -> Just (rator:r, s)
  42                             Nothing -> Just ([rator], rand)
  43     Nothing -> Nothing
  44
  45 splitFunTy2_maybe :: Ty -> Maybe (Ty,Ty)
  46 splitFunTy2_maybe (Tapp (Tapp (Tcon c) t) u) | c == tcArrow = Just (t, u)
  47 splitFunTy2_maybe _ = Nothing
  48
  49 vdefNamesQ :: [Vdef] -> [Qual Var]
  50 vdefNamesQ = map (\ (Vdef (v,_,_)) -> v)
  51
  52 vdefNames :: [Vdef] -> [Var]
  53 vdefNames = snd . unzip . vdefNamesQ
  54
  55 vdefTys :: [Vdef] -> [Ty]
  56 vdefTys = map (\ (Vdef (_,t,_)) -> t)
  57
  58 vdefgNames :: Vdefg -> [Var]
  59 vdefgNames (Rec vds) = map (\ (Vdef ((_,v),_,_)) -> v) vds
  60 vdefgNames (Nonrec (Vdef ((_,v),_,_))) = [v]
  61 vdefgTys :: Vdefg -> [Ty]
  62 vdefgTys (Rec vds) = map (\ (Vdef (_,t,_)) -> t) vds
  63 vdefgTys (Nonrec (Vdef (_,t,_))) = [t]
  64
  65 vbNames :: [Vbind] -> [Var]
  66 vbNames = fst . unzip
  67
  68 -- assumes v is not bound in e
  69 substIn :: Data a => Var -> Var -> a -> a
  70 substIn v newV = everywhereExcept (mkT frob)
  71   where frob (Var (Nothing,v1)) | v == v1   = Var (Nothing,newV)
  72         frob e                              = e
  73
  74 substVars :: Data a => [Var] -> [Var] -> a -> a
  75 substVars oldVars newVars e = foldl' (\ e1 (old,new) -> substIn old new e1)
  76   e (zip oldVars newVars)
  77
  78
  79 tdefNames :: [Tdef] -> [Qual Var]
  80 tdefNames = concatMap doOne
  81   where doOne (Data qtc _ cds) = qtc:(concatMap doCdef cds)
  82         doOne (Newtype qtc qtc1 _ _) = [qtc, qtc1]
  83         doCdef (Constr qdc _ _) = [qdc]
  84
  85 tdefDcons :: [Tdef] -> [Qual Var]
  86 tdefDcons = concatMap doOne
  87   where doOne (Data _ _ cds) = concatMap doCdef cds
  88         doOne _ = []
  89         doCdef (Constr qdc _ _) = [qdc]
  90
  91 tdefTcons :: [Tdef] -> [Qual Var]
  92 tdefTcons = concatMap doOne
  93   where doOne (Data qtc _ _) = [qtc]
  94         doOne (Newtype qtc qtc1 _ _) = [qtc, qtc1]
  95