| Line No. | Rev | Author | Line |
|---|---|---|---|
| 1 | 1 | paulosilva | |
| 2 | {-# LANGUAGE FlexibleContexts #-} | ||
| 3 | {-# OPTIONS_GHC -Wall #-} | ||
| 4 | |||
| 5 | ------------------------------------------------------------------------------- | ||
| 6 | |||
| 7 | {- | | ||
| 8 | Module : Language.R.Refresh | ||
| 9 | Description : Operations for refreshing the variable names. | ||
| 10 | Copyright : (c) Paulo Silva | ||
| 11 | License : LGPL | ||
| 12 | |||
| 13 | Maintainer : paufil@di.uminho.pt | ||
| 14 | Stability : experimental | ||
| 15 | Portability : portable | ||
| 16 | |||
| 17 | -} | ||
| 18 | |||
| 19 | ------------------------------------------------------------------------------- | ||
| 20 | |||
| 21 | module Language.R.Refresh ( | ||
| 22 | refresh, | ||
| 23 | collect, | ||
| 24 | replace, | ||
| 25 | refreshVar, | ||
| 26 | refreshType, | ||
| 27 | St(..) | ||
| 28 | ) where | ||
| 29 | |||
| 30 | import Control.Monad.Fresh | ||
| 31 | import Control.Monad.Reader | ||
| 32 | import Data.Existential | ||
| 33 | import Language.R.SyntaxADT | ||
| 34 | import Language.Type.Constraint | ||
| 35 | import Language.Type.Syntax | ||
| 36 | import Language.Type.Utils | ||
| 37 | |||
| 38 | ------------------------------------------------------------------------------- | ||
| 39 | |||
| 40 | refresh :: MonadFresh [String] String m => S -> m S | ||
| 41 | refresh s = do | ||
| 42 | let (rvar,tvar) = collect s | ||
| 43 | newVars <- refreshVar rvar | ||
| 44 | newTypes <- refreshType tvar | ||
| 45 | return . runReader (replace s) $ St {rvars = newVars, tvars = newTypes} | ||
| 46 | |||
| 47 | ------------------------------------------------------------------------------- | ||
| 48 | |||
| 49 | -- ============ | ||
| 50 | data St = St {rvars :: [(String,String)], tvars :: [Constraint]} | ||
| 51 | -- ============ | ||
| 52 | |||
| 53 | ------------------------------------------------------------------------------- | ||
| 54 | |||
| 55 | refreshVar :: MonadFresh [String] String m => [String] -> m [(String,String)] | ||
| 56 | refreshVar = mapM (\x -> do v <- getFresh; return $ (x,'r':v)) | ||
| 57 | |||
| 58 | ------------------------------------------------------------------------------- | ||
| 59 | |||
| 60 | refreshType :: MonadFresh [String] String m => [String] -> m [Constraint] | ||
| 61 | refreshType = mapM (\x -> do v <- getFresh; return $ TVar x :=: TVar ('t':v)) | ||
| 62 | |||
| 63 | ------------------------------------------------------------------------------- | ||
| 64 | |||
| 65 | collect :: S -> ([String], [String]) | ||
| 66 | collect (DefS _ _ t) = ([], map getTVarNameTB . collectTVarTB $ t) | ||
| 67 | collect (VarS _ n) = ([n], []) | ||
| 68 | collect (NegS _ s) = collect s | ||
| 69 | collect (MeetS _ s1 s2) = let | ||
| 70 | (i1, tb1) = collect s1 | ||
| 71 | (i2, tb2) = collect s2 | ||
| 72 | in (i1++i2, tb1++tb2) | ||
| 73 | collect (JoinS _ s1 s2) = let | ||
| 74 | (i1, tb1) = collect s1 | ||
| 75 | (i2, tb2) = collect s2 | ||
| 76 | in (i1++i2, tb1++tb2) | ||
| 77 | collect (ConvS _ s) = collect s | ||
| 78 | collect (CompS _ s1 s2) = let | ||
| 79 | (i1, tb1) = collect s1 | ||
| 80 | (i2, tb2) = collect s2 | ||
| 81 | in (i1++i2, tb1++tb2) | ||
| 82 | collect (SplitS _ s1 s2) = let | ||
| 83 | (i1, tb1) = collect s1 | ||
| 84 | (i2, tb2) = collect s2 | ||
| 85 | in (i1++i2, tb1++tb2) | ||
| 86 | collect (OrdS _ s) = collect s | ||
| 87 | collect (FunS _ s) = collect s | ||
| 88 | collect (LeftsecS _ s1 s2) = let | ||
| 89 | (i1, tb1) = collect s1 | ||
| 90 | (i2, tb2) = collect s2 | ||
| 91 | in (i1++i2, tb1++tb2) | ||
| 92 | collect (RightsecS _ s1 s2) = let | ||
| 93 | (i1, tb1) = collect s1 | ||
| 94 | (i2, tb2) = collect s2 | ||
| 95 | in (i1++i2, tb1++tb2) | ||
| 96 | collect (ApplyS _ s1 s2) = let | ||
| 97 | (i1, tb1) = collect s1 | ||
| 98 | (i2, tb2) = collect s2 | ||
| 99 | in (i1++i2, tb1++tb2) | ||
| 100 | collect (ProdS _ s1 s2) = let | ||
| 101 | (i1, tb1) = collect s1 | ||
| 102 | (i2, tb2) = collect s2 | ||
| 103 | in (i1++i2, tb1++tb2) | ||
| 104 | collect (EitherS _ s1 s2) = let | ||
| 105 | (i1, tb1) = collect s1 | ||
| 106 | (i2, tb2) = collect s2 | ||
| 107 | in (i1++i2, tb1++tb2) | ||
| 108 | collect (MaybeS _ s) = collect s | ||
| 109 | collect (ListS _ s) = collect s | ||
| 110 | collect (SetS _ s) = collect s | ||
| 111 | collect (MapS _ s) = collect s | ||
| 112 | 5 | paulosilva | collect (ReynoldsS _ s1 s2) = let |
| 113 | (i1, tb1) = collect s1 | ||
| 114 | (i2, tb2) = collect s2 | ||
| 115 | in (i1++i2, tb1++tb2) | ||
| 116 | 1 | paulosilva | collect (FCompS _ s1 s2) = let |
| 117 | (i1, tb1) = collect s1 | ||
| 118 | (i2, tb2) = collect s2 | ||
| 119 | in (i1++i2, tb1++tb2) | ||
| 120 | collect (OCompS _ s1 s2) = let | ||
| 121 | (i1, tb1) = collect s1 | ||
| 122 | (i2, tb2) = collect s2 | ||
| 123 | in (i1++i2, tb1++tb2) | ||
| 124 | collect (OConvS _ s) = collect s | ||
| 125 | collect (OProdS _ s) = collect s | ||
| 126 | collect (OJoinS _ s) = collect s | ||
| 127 | collect (OMeetS _ s) = collect s | ||
| 128 | collect (OMaxS _ s) = collect s | ||
| 129 | collect (OMinS _ s) = collect s | ||
| 130 | collect (GDefS _ _ f1 f2 o1 o2) = let | ||
| 131 | (if1, tbf1) = collect f1 | ||
| 132 | (if2, tbf2) = collect f2 | ||
| 133 | (io1, tbo1) = collect o1 | ||
| 134 | (io2, tbo2) = collect o2 | ||
| 135 | in (if1 ++ if2 ++ io1 ++ io2, tbf1 ++ tbf2 ++ tbo1 ++ tbo2) | ||
| 136 | collect (GCompS _ s1 s2) = let | ||
| 137 | (i1, tb1) = collect s1 | ||
| 138 | (i2, tb2) = collect s2 | ||
| 139 | in (i1++i2, tb1++tb2) | ||
| 140 | collect (GConvS _ s) = collect s | ||
| 141 | collect (GLAdjS _ s) = collect s | ||
| 142 | collect (GUAdjS _ s) = collect s | ||
| 143 | collect (GLOrdS _ s) = collect s | ||
| 144 | collect (GUOrdS _ s) = collect s | ||
| 145 | collect _ = ([],[]) | ||
| 146 | |||
| 147 | ------------------------------------------------------------------------------- | ||
| 148 | |||
| 149 | replace :: MonadReader St m => S -> m S | ||
| 150 | replace (DefS p n (Hide t)) = do | ||
| 151 | env <- ask | ||
| 152 | let Just t' = typeRewrite (tvars env) t | ||
| 153 | return $ DefS p n t' | ||
| 154 | replace (VarS p n) = do | ||
| 155 | env <- ask | ||
| 156 | let Just n' = lookup n . rvars $ env | ||
| 157 | return $ VarS p n' | ||
| 158 | replace (NegS p s) = do | ||
| 159 | s' <- replace s | ||
| 160 | return $ NegS p s' | ||
| 161 | replace (MeetS p s1 s2) = do | ||
| 162 | s1' <- replace s1 | ||
| 163 | s2' <- replace s2 | ||
| 164 | return $ MeetS p s1' s2' | ||
| 165 | replace (JoinS p s1 s2) = do | ||
| 166 | s1' <- replace s1 | ||
| 167 | s2' <- replace s2 | ||
| 168 | return $ JoinS p s1' s2' | ||
| 169 | replace (ConvS p s) = do | ||
| 170 | s' <- replace s | ||
| 171 | return $ ConvS p s' | ||
| 172 | replace (CompS p s1 s2) = do | ||
| 173 | s1' <- replace s1 | ||
| 174 | s2' <- replace s2 | ||
| 175 | return $ CompS p s1' s2' | ||
| 176 | replace (SplitS p s1 s2) = do | ||
| 177 | s1' <- replace s1 | ||
| 178 | s2' <- replace s2 | ||
| 179 | return $ SplitS p s1' s2' | ||
| 180 | replace (OrdS p s) = do | ||
| 181 | s' <- replace s | ||
| 182 | return $ OrdS p s' | ||
| 183 | replace (FunS p s) = do | ||
| 184 | s' <- replace s | ||
| 185 | return $ FunS p s' | ||
| 186 | replace (LeftsecS p s1 s2) = do | ||
| 187 | s1' <- replace s1 | ||
| 188 | s2' <- replace s2 | ||
| 189 | return $ LeftsecS p s1' s2' | ||
| 190 | replace (RightsecS p s1 s2) = do | ||
| 191 | s1' <- replace s1 | ||
| 192 | s2' <- replace s2 | ||
| 193 | return $ RightsecS p s1' s2' | ||
| 194 | replace (ApplyS p s1 s2) = do | ||
| 195 | s1' <- replace s1 | ||
| 196 | s2' <- replace s2 | ||
| 197 | return $ ApplyS p s1' s2' | ||
| 198 | replace (ProdS p s1 s2) = do | ||
| 199 | s1' <- replace s1 | ||
| 200 | s2' <- replace s2 | ||
| 201 | return $ ProdS p s1' s2' | ||
| 202 | replace (EitherS p s1 s2) = do | ||
| 203 | s1' <- replace s1 | ||
| 204 | s2' <- replace s2 | ||
| 205 | return $ EitherS p s1' s2' | ||
| 206 | replace (MaybeS p s) = do | ||
| 207 | s' <- replace s | ||
| 208 | return $ MaybeS p s' | ||
| 209 | replace (ListS p s) = do | ||
| 210 | s' <- replace s | ||
| 211 | return $ ListS p s' | ||
| 212 | replace (SetS p s) = do | ||
| 213 | s' <- replace s | ||
| 214 | return $ SetS p s' | ||
| 215 | replace (MapS p s) = do | ||
| 216 | s' <- replace s | ||
| 217 | return $ MapS p s' | ||
| 218 | 5 | paulosilva | replace (ReynoldsS p s1 s2) = do |
| 219 | s1' <- replace s1 | ||
| 220 | s2' <- replace s2 | ||
| 221 | return $ ReynoldsS p s1' s2' | ||
| 222 | 1 | paulosilva | replace (FCompS p s1 s2) = do |
| 223 | s1' <- replace s1 | ||
| 224 | s2' <- replace s2 | ||
| 225 | return $ FCompS p s1' s2' | ||
| 226 | replace (OCompS p s1 s2) = do | ||
| 227 | s1' <- replace s1 | ||
| 228 | s2' <- replace s2 | ||
| 229 | return $ OCompS p s1' s2' | ||
| 230 | replace (OConvS p s) = do | ||
| 231 | s' <- replace s | ||
| 232 | return $ OConvS p s' | ||
| 233 | replace (OProdS p s) = do | ||
| 234 | s' <- replace s | ||
| 235 | return $ OProdS p s' | ||
| 236 | replace (OJoinS p s) = do | ||
| 237 | s' <- replace s | ||
| 238 | return $ OJoinS p s' | ||
| 239 | replace (OMeetS p s) = do | ||
| 240 | s' <- replace s | ||
| 241 | return $ OMeetS p s' | ||
| 242 | replace (OMaxS p s) = do | ||
| 243 | s' <- replace s | ||
| 244 | return $ OMaxS p s' | ||
| 245 | replace (OMinS p s) = do | ||
| 246 | s' <- replace s | ||
| 247 | return $ OMinS p s' | ||
| 248 | replace (GDefS p n f1 f2 o1 o2) = do | ||
| 249 | f1' <- replace f1 | ||
| 250 | f2' <- replace f2 | ||
| 251 | o1' <- replace o1 | ||
| 252 | o2' <- replace o2 | ||
| 253 | return $ GDefS p n f1' f2' o1' o2' | ||
| 254 | replace (GCompS p s1 s2) = do | ||
| 255 | s1' <- replace s1 | ||
| 256 | s2' <- replace s2 | ||
| 257 | return $ GCompS p s1' s2' | ||
| 258 | replace (GConvS p s) = do | ||
| 259 | s' <- replace s | ||
| 260 | return $ GConvS p s' | ||
| 261 | replace (GLAdjS p s) = do | ||
| 262 | s' <- replace s | ||
| 263 | return $ GLAdjS p s' | ||
| 264 | replace (GUAdjS p s) = do | ||
| 265 | s' <- replace s | ||
| 266 | return $ GUAdjS p s' | ||
| 267 | replace (GLOrdS p s) = do | ||
| 268 | s' <- replace s | ||
| 269 | return $ GLOrdS p s' | ||
| 270 | replace (GUOrdS p s) = do | ||
| 271 | s' <- replace s | ||
| 272 | return $ GUOrdS p s' | ||
| 273 | replace s = return s | ||
| 274 | |||
| 275 | ------------------------------------------------------------------------------- | ||
| 276 |