| Line No. | Rev | Author | Line |
|---|---|---|---|
| 1 | 1 | paulosilva | |
| 2 | {-# LANGUAGE GADTs, Rank2Types #-} | ||
| 3 | {-# OPTIONS_GHC -Wall #-} | ||
| 4 | |||
| 5 | ------------------------------------------------------------------------------- | ||
| 6 | |||
| 7 | {- | | ||
| 8 | Module : Language.R.Rewrite | ||
| 9 | Description : Strategic rewriting combinators for the expression | ||
| 10 | representation. | ||
| 11 | Copyright : (c) Paulo Silva | ||
| 12 | License : LGPL | ||
| 13 | |||
| 14 | Maintainer : paufil@di.uminho.pt | ||
| 15 | Stability : experimental | ||
| 16 | Portability : portable | ||
| 17 | |||
| 18 | -} | ||
| 19 | |||
| 20 | ------------------------------------------------------------------------------- | ||
| 21 | |||
| 22 | |||
| 23 | module Language.R.Rewrite ( | ||
| 24 | GenericM, | ||
| 25 | seqRules, | ||
| 26 | nop, | ||
| 27 | failM, | ||
| 28 | (>>>), | ||
| 29 | (|||), | ||
| 30 | (|<|), | ||
| 31 | many, | ||
| 32 | many1, | ||
| 33 | try, | ||
| 34 | once, | ||
| 35 | everywhere, | ||
| 36 | everywhere', | ||
| 37 | innermost, | ||
| 38 | all, | ||
| 39 | one | ||
| 40 | ) where | ||
| 41 | |||
| 42 | import Control.MonadOr | ||
| 43 | import Control.Monad.State | ||
| 44 | import Language.R.Spine | ||
| 45 | import Language.R.Syntax | ||
| 46 | import Language.Type.Syntax | ||
| 47 | import Prelude hiding (all) | ||
| 48 | |||
| 49 | ------------------------------------------------------------------------------- | ||
| 50 | |||
| 51 | type GenericM m = forall a . Type a -> R a -> m (R a) | ||
| 52 | |||
| 53 | ------------------------------------------------------------------------------- | ||
| 54 | |||
| 55 | seqRules :: MonadOr m => [GenericM m] -> GenericM m | ||
| 56 | seqRules [] = failM | ||
| 57 | seqRules (x:xs) = x |<| seqRules xs | ||
| 58 | |||
| 59 | ------------------------------------------------------------------------------- | ||
| 60 | |||
| 61 | nop :: Monad m => GenericM m | ||
| 62 | nop _ = return | ||
| 63 | |||
| 64 | ------------------------------------------------------------------------------- | ||
| 65 | |||
| 66 | failM :: MonadPlus m => GenericM m | ||
| 67 | failM _ _ = mzero | ||
| 68 | |||
| 69 | ------------------------------------------------------------------------------- | ||
| 70 | |||
| 71 | (>>>) :: Monad m => GenericM m -> GenericM m -> GenericM m | ||
| 72 | 3 | paulosilva | (f >>> g) t = f t >=> g t |
| 73 | 1 | paulosilva | |
| 74 | ------------------------------------------------------------------------------- | ||
| 75 | |||
| 76 | (|||) :: MonadPlus m => GenericM m -> GenericM m -> GenericM m | ||
| 77 | (f ||| g) t x = f t x `mplus` g t x | ||
| 78 | |||
| 79 | ------------------------------------------------------------------------------- | ||
| 80 | |||
| 81 | (|<|) :: MonadOr m => GenericM m -> GenericM m -> GenericM m | ||
| 82 | (f |<| g) t x = f t x `morelse` g t x | ||
| 83 | |||
| 84 | ------------------------------------------------------------------------------- | ||
| 85 | |||
| 86 | many :: MonadOr m => GenericM m -> GenericM m | ||
| 87 | many r = (r >>> many r) |<| nop | ||
| 88 | |||
| 89 | ------------------------------------------------------------------------------- | ||
| 90 | |||
| 91 | many1 :: MonadOr m => GenericM m -> GenericM m | ||
| 92 | many1 r = r >>> many r | ||
| 93 | |||
| 94 | ------------------------------------------------------------------------------- | ||
| 95 | |||
| 96 | try :: MonadOr m => GenericM m -> GenericM m | ||
| 97 | try x = x |<| nop | ||
| 98 | |||
| 99 | ------------------------------------------------------------------------------- | ||
| 100 | |||
| 101 | once :: MonadOr m => GenericM m -> GenericM m | ||
| 102 | once f = f |<| one (once f) | ||
| 103 | |||
| 104 | ------------------------------------------------------------------------------- | ||
| 105 | |||
| 106 | everywhere :: Monad m => GenericM m -> GenericM m | ||
| 107 | everywhere f = f >>> all (everywhere f) | ||
| 108 | |||
| 109 | ------------------------------------------------------------------------------- | ||
| 110 | |||
| 111 | everywhere' :: Monad m => GenericM m -> GenericM m | ||
| 112 | everywhere' f = all (everywhere' f) >>> f | ||
| 113 | |||
| 114 | ------------------------------------------------------------------------------- | ||
| 115 | |||
| 116 | innermost :: MonadOr m => GenericM m -> GenericM m | ||
| 117 | innermost f = all (innermost f) >>> try (f >>> innermost f) | ||
| 118 | |||
| 119 | ------------------------------------------------------------------------------- | ||
| 120 | |||
| 121 | all :: Monad m => GenericM m -> GenericM m | ||
| 122 | all strg typ expr = do | ||
| 123 | s <- aux strg (toSpine typ expr) | ||
| 124 | return (fromSpine s) | ||
| 125 | where | ||
| 126 | aux :: Monad m => GenericM m -> (Spine a -> m (Spine a)) | ||
| 127 | aux _ x@(Constr _) = return x | ||
| 128 | aux g (f `Ap` (t :| x)) = do | ||
| 129 | h <- aux g f | ||
| 130 | y <- g t x | ||
| 131 | return (h `Ap` (t :| y)) | ||
| 132 | |||
| 133 | ------------------------------------------------------------------------------- | ||
| 134 | |||
| 135 | one :: MonadOr m => GenericM m -> GenericM m | ||
| 136 | one strg typ expr = do | ||
| 137 | s <- aux strg (toSpine typ expr) | ||
| 138 | return (fromSpine s) | ||
| 139 | where | ||
| 140 | aux :: MonadOr m => GenericM m -> (Spine a -> m (Spine a)) | ||
| 141 | aux _ (Constr _) = mzero | ||
| 142 | aux g (f `Ap` (t :| x)) = | ||
| 143 | (do h <- aux g f | ||
| 144 | return $ h `Ap` (t :| x)) | ||
| 145 | `morelse` | ||
| 146 | (do j <- g t x | ||
| 147 | return $ f `Ap` (t :| j)) | ||
| 148 | |||
| 149 | ------------------------------------------------------------------------------- |