| Line No. | Rev | Author | Line |
|---|---|---|---|
| 1 | 1 | paulosilva | |
| 2 | {-# LANGUAGE GADTs, Rank2Types #-} | ||
| 3 | {-# OPTIONS_GHC -Wall #-} | ||
| 4 | |||
| 5 | ------------------------------------------------------------------------------- | ||
| 6 | |||
| 7 | {- | | ||
| 8 | Module : Language.Type.Rewrite | ||
| 9 | Description : Strategic rewriting combinators for the type representation. | ||
| 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.Type.Rewrite ( | ||
| 22 | Rule, | ||
| 23 | View(View), | ||
| 24 | showType, | ||
| 25 | view2Box, | ||
| 26 | nop, | ||
| 27 | fail, | ||
| 28 | seqRules, | ||
| 29 | (>>>), | ||
| 30 | (|||), | ||
| 31 | 2 | paulosilva | (|<|), |
| 32 | 1 | paulosilva | many, |
| 33 | many1, | ||
| 34 | try, | ||
| 35 | once, | ||
| 36 | everywhere, | ||
| 37 | everywhere', | ||
| 38 | innermost, | ||
| 39 | 2 | paulosilva | one, |
| 40 | 1 | paulosilva | all |
| 41 | ) where | ||
| 42 | |||
| 43 | 2 | paulosilva | import Control.MonadOr |
| 44 | 1 | paulosilva | import Control.Monad hiding (fail) |
| 45 | import Data.Existential | ||
| 46 | import Language.Type.Syntax | ||
| 47 | import Prelude hiding (all,fail) | ||
| 48 | |||
| 49 | ------------------------------------------------------------------------------- | ||
| 50 | |||
| 51 | data View a where | ||
| 52 | View :: Type b -> View (Type a) | ||
| 53 | |||
| 54 | instance Show (View a) where | ||
| 55 | show (View b) = "View: " ++ show b | ||
| 56 | |||
| 57 | ------------------------------------------------------------------------------- | ||
| 58 | |||
| 59 | showType :: View a -> String | ||
| 60 | showType (View b) = show b | ||
| 61 | |||
| 62 | ------------------------------------------------------------------------------- | ||
| 63 | |||
| 64 | view2Box :: View (Type b) -> TypeBox | ||
| 65 | view2Box (View t) = Hide t | ||
| 66 | |||
| 67 | ------------------------------------------------------------------------------- | ||
| 68 | |||
| 69 | 2 | paulosilva | type Rule = forall a . forall m . MonadOr m => Type a -> m (View (Type a)) |
| 70 | 1 | paulosilva | |
| 71 | ------------------------------------------------------------------------------- | ||
| 72 | |||
| 73 | nop :: Rule | ||
| 74 | nop = return . View | ||
| 75 | |||
| 76 | ------------------------------------------------------------------------------- | ||
| 77 | |||
| 78 | fail :: Rule | ||
| 79 | fail _ = mzero | ||
| 80 | |||
| 81 | ------------------------------------------------------------------------------- | ||
| 82 | |||
| 83 | seqRules :: [Rule] -> Rule | ||
| 84 | seqRules [] = fail | ||
| 85 | 2 | paulosilva | seqRules (x:xs) = x |<| seqRules xs |
| 86 | 1 | paulosilva | |
| 87 | ------------------------------------------------------------------------------- | ||
| 88 | |||
| 89 | (>>>) :: Rule -> Rule -> Rule | ||
| 90 | (f >>> g) a = do | ||
| 91 | View b <- f a | ||
| 92 | View c <- g b | ||
| 93 | return $ View c | ||
| 94 | |||
| 95 | ------------------------------------------------------------------------------- | ||
| 96 | |||
| 97 | (|||) :: Rule -> Rule -> Rule | ||
| 98 | (f ||| g) x = f x `mplus` g x | ||
| 99 | |||
| 100 | ------------------------------------------------------------------------------- | ||
| 101 | |||
| 102 | 2 | paulosilva | (|<|) :: Rule -> Rule -> Rule |
| 103 | (f |<| g) x = f x `morelse` g x | ||
| 104 | |||
| 105 | ------------------------------------------------------------------------------- | ||
| 106 | |||
| 107 | 1 | paulosilva | many :: Rule -> Rule |
| 108 | 2 | paulosilva | many r = (r >>> many r) |<| nop |
| 109 | 1 | paulosilva | |
| 110 | ------------------------------------------------------------------------------- | ||
| 111 | |||
| 112 | many1 :: Rule -> Rule | ||
| 113 | many1 r = r >>> many r | ||
| 114 | |||
| 115 | ------------------------------------------------------------------------------- | ||
| 116 | |||
| 117 | try :: Rule -> Rule | ||
| 118 | 2 | paulosilva | try r = r |<| nop |
| 119 | 1 | paulosilva | |
| 120 | ------------------------------------------------------------------------------- | ||
| 121 | |||
| 122 | once :: Rule -> Rule | ||
| 123 | 2 | paulosilva | once f = f |<| one (once f) |
| 124 | 1 | paulosilva | |
| 125 | ------------------------------------------------------------------------------- | ||
| 126 | |||
| 127 | everywhere :: Rule -> Rule | ||
| 128 | everywhere r = r >>> all (everywhere r) | ||
| 129 | |||
| 130 | ------------------------------------------------------------------------------- | ||
| 131 | |||
| 132 | everywhere' :: Rule -> Rule | ||
| 133 | everywhere' r = all (everywhere' r) >>> r | ||
| 134 | |||
| 135 | ------------------------------------------------------------------------------- | ||
| 136 | |||
| 137 | innermost :: Rule -> Rule | ||
| 138 | innermost r = all (innermost r) >>> try (r >>> innermost r) | ||
| 139 | |||
| 140 | ------------------------------------------------------------------------------- | ||
| 141 | |||
| 142 | all :: Rule -> Rule | ||
| 143 | 2 | paulosilva | all _ x@(TVar _) = return $ View x |
| 144 | all _ One = return $ View One | ||
| 145 | all _ Bool = return $ View Bool | ||
| 146 | all _ Char = return $ View Char | ||
| 147 | all _ String = return $ View String | ||
| 148 | all _ Int = return $ View Int | ||
| 149 | all _ Float = return $ View Float | ||
| 150 | 1 | paulosilva | all r (Prod a b) = do |
| 151 | View a' <- r a | ||
| 152 | View b' <- r b | ||
| 153 | return $ View (Prod a' b') | ||
| 154 | all r (Either a b) = do | ||
| 155 | View a' <- r a | ||
| 156 | View b' <- r b | ||
| 157 | return $ View (Either a' b') | ||
| 158 | all r (Maybe a) = do | ||
| 159 | View a' <- r a | ||
| 160 | return $ View (Maybe a') | ||
| 161 | all r (List a) = do | ||
| 162 | View a' <- r a | ||
| 163 | return $ View (List a') | ||
| 164 | all r (Set a) = do | ||
| 165 | View a' <- r a | ||
| 166 | return $ View (Set a') | ||
| 167 | all r (Map a b) = do | ||
| 168 | View a' <- r a | ||
| 169 | View b' <- r b | ||
| 170 | return $ View (Map a' b') | ||
| 171 | all r (Fun a b) = do | ||
| 172 | View a' <- r a | ||
| 173 | View b' <- r b | ||
| 174 | return $ View (Fun a' b') | ||
| 175 | all r (Rel a b) = do | ||
| 176 | View a' <- r a | ||
| 177 | View b' <- r b | ||
| 178 | return $ View (Rel a' b') | ||
| 179 | all r (Ord a) = do | ||
| 180 | View a' <- r a | ||
| 181 | return $ View (Ord a') | ||
| 182 | all r (GC a b) = do | ||
| 183 | View a' <- r a | ||
| 184 | View b' <- r b | ||
| 185 | return $ View (GC a' b') | ||
| 186 | |||
| 187 | ------------------------------------------------------------------------------- | ||
| 188 | |||
| 189 | 2 | paulosilva | one :: Rule -> Rule |
| 190 | one _ (TVar _) = mzero | ||
| 191 | one _ One = mzero | ||
| 192 | one _ Bool = mzero | ||
| 193 | one _ Char = mzero | ||
| 194 | one _ String = mzero | ||
| 195 | one _ Int = mzero | ||
| 196 | one _ Float = mzero | ||
| 197 | one r (Prod a b) = | ||
| 198 | (do View c <- r a | ||
| 199 | return $ View (Prod c b)) `morelse` | ||
| 200 | (do View c <- r b | ||
| 201 | return $ View (Prod a c)) | ||
| 202 | one r (Either a b) = | ||
| 203 | (do View c <- r a | ||
| 204 | return $ View (Either c b)) `morelse` | ||
| 205 | (do View c <- r b | ||
| 206 | return $ View (Prod a c)) | ||
| 207 | one r (Maybe a) = | ||
| 208 | (do View c <- r a | ||
| 209 | return $ View (Maybe c)) | ||
| 210 | one r (List a) = | ||
| 211 | (do View c <- r a | ||
| 212 | return $ View (List c)) | ||
| 213 | one r (Set a) = | ||
| 214 | (do View c <- r a | ||
| 215 | return $ View (Set c)) | ||
| 216 | one r (Map a b) = | ||
| 217 | (do View c <- r a | ||
| 218 | return $ View (Map c b)) `morelse` | ||
| 219 | (do View c <- r b | ||
| 220 | return $ View (Map a c)) | ||
| 221 | one r (Fun a b) = | ||
| 222 | (do View c <- r a | ||
| 223 | return $ View (Fun c b)) `morelse` | ||
| 224 | (do View c <- r b | ||
| 225 | return $ View (Fun a c)) | ||
| 226 | one r (Rel a b) = | ||
| 227 | (do View c <- r a | ||
| 228 | return $ View (Rel c b)) `morelse` | ||
| 229 | (do View c <- r b | ||
| 230 | return $ View (Rel a c)) | ||
| 231 | one r (Ord a) = | ||
| 232 | (do View c <- r a | ||
| 233 | return $ View (Ord c)) | ||
| 234 | one r (GC a b) = | ||
| 235 | (do View c <- r a | ||
| 236 | return $ View (GC c b)) `morelse` | ||
| 237 | (do View c <- r b | ||
| 238 | return $ View (GC a c)) | ||
| 239 | |||
| 240 | ------------------------------------------------------------------------------- | ||
| 241 |