| Line No. | Rev | Author | Line |
|---|---|---|---|
| 1 | 1 | paulosilva | |
| 2 | {-# LANGUAGE TypeOperators, Rank2Types, PatternSignatures #-} | ||
| 3 | {-# OPTIONS_GHC -Wall #-} | ||
| 4 | |||
| 5 | ------------------------------------------------------------------------------- | ||
| 6 | |||
| 7 | {- | | ||
| 8 | Module : Galculator.Evaluate | ||
| 9 | Description : | ||
| 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 Galculator.Evaluate ( | ||
| 22 | evalCombinator, | ||
| 23 | evalDerivation | ||
| 24 | ) where | ||
| 25 | |||
| 26 | import Control.GalcError | ||
| 27 | import Control.Monad.Error | ||
| 28 | import Galculator.Engine.GcToLaw | ||
| 29 | import Galculator.Engine.LawToRule | ||
| 30 | import Galculator.Rule | ||
| 31 | import Galculator.State | ||
| 32 | import Language.Combinator.Syntax | ||
| 33 | import Language.Derivation.Syntax | ||
| 34 | import Language.Law.Syntax | ||
| 35 | import Language.R.Rewrite | ||
| 36 | import Language.R.Syntax | ||
| 37 | import qualified Language.Type.Syntax as T | ||
| 38 | import Prelude hiding (all) | ||
| 39 | |||
| 40 | ------------------------------------------------------------------------------- | ||
| 41 | |||
| 42 | combBin :: Combinator -> (Rule -> Rule -> Rule) -> Combinator -> GalcStateT Rule | ||
| 43 | combBin c1 comb c2 = do | ||
| 44 | c1' <- evalCombinator c1 | ||
| 45 | c2' <- evalCombinator c2 | ||
| 46 | let rc = comb c1' c2' | ||
| 47 | return rc | ||
| 48 | |||
| 49 | ------------------------------------------------------------------------------- | ||
| 50 | |||
| 51 | combUni :: (Rule -> Rule) -> Combinator -> GalcStateT Rule | ||
| 52 | combUni comb c = do | ||
| 53 | c' <- evalCombinator c | ||
| 54 | let rc = comb c' | ||
| 55 | return rc | ||
| 56 | |||
| 57 | ------------------------------------------------------------------------------- | ||
| 58 | |||
| 59 | evalCombinator :: Combinator -> GalcStateT Rule | ||
| 60 | 7 | paulosilva | evalCombinator Nop = return nop |
| 61 | evalCombinator Fail = return failM | ||
| 62 | evalCombinator (Seq c1 c2) = combBin c1 (>>>) c2 | ||
| 63 | evalCombinator (Choice c1 c2) = combBin c1 (|||) c2 | ||
| 64 | 1 | paulosilva | evalCombinator (LChoice c1 c2) = combBin c1 (|<|) c2 |
| 65 | 7 | paulosilva | evalCombinator (Many c) = combUni many c |
| 66 | evalCombinator (Many1 c) = combUni many1 c | ||
| 67 | evalCombinator (Try c) = combUni try c | ||
| 68 | evalCombinator (Once c) = combUni once c | ||
| 69 | evalCombinator (Everywhere c) = combUni everywhere c | ||
| 70 | 1 | paulosilva | evalCombinator (Everywhere' c) = combUni everywhere' c |
| 71 | 7 | paulosilva | evalCombinator (Innermost c) = combUni innermost c |
| 72 | evalCombinator (All c) = combUni all c | ||
| 73 | evalCombinator (One c) = combUni one c | ||
| 74 | 1 | paulosilva | evalCombinator (Rule r) = |
| 75 | case r of | ||
| 76 | Inv drv -> do | ||
| 77 | lw <- evalDerivation drv | ||
| 78 | let (rl::Rule) = getRuleInv lw | ||
| 79 | return rl | ||
| 80 | _ -> do | ||
| 81 | lw <- evalDerivation r | ||
| 82 | let (rl::Rule) = getRule lw | ||
| 83 | return rl | ||
| 84 | |||
| 85 | ------------------------------------------------------------------------------- | ||
| 86 | |||
| 87 | deriveLaw :: String -> (forall t . T.Type t -> R t -> GalcStateT Law) -> GalcStateT Law | ||
| 88 | deriveLaw ref f = do | ||
| 89 | gc <- maybe2error (ReferenceError ref) =<< getGC ref | ||
| 90 | rType2Law gc f | ||
| 91 | |||
| 92 | ------------------------------------------------------------------------------- | ||
| 93 | |||
| 94 | evalDerivation :: Derivation -> GalcStateT Law | ||
| 95 | 7 | paulosilva | evalDerivation (Inv _) = throwError DerivationError |
| 96 | evalDerivation (Shunt ref) = deriveLaw ref gcShunting | ||
| 97 | evalDerivation (DistrLow ref) = deriveLaw ref gcDistributivityLower | ||
| 98 | evalDerivation (DistrUp ref) = deriveLaw ref gcDistributivityUpper | ||
| 99 | evalDerivation (MonotLow ref) = deriveLaw ref gcMonotonicityLower | ||
| 100 | evalDerivation (MonotUp ref) = deriveLaw ref gcMonotonicityUpper | ||
| 101 | 1 | paulosilva | evalDerivation (TopPreserv ref) = deriveLaw ref gcPreservingTop |
| 102 | evalDerivation (BotPreserv ref) = deriveLaw ref gcPreservingBottom | ||
| 103 | 7 | paulosilva | evalDerivation (CancUp ref) = deriveLaw ref gcCancellationUpper |
| 104 | evalDerivation (CancLow ref) = deriveLaw ref gcCancellationLower | ||
| 105 | evalDerivation (Free _) = undefined | ||
| 106 | evalDerivation (Apply ref) = getLaw ref | ||
| 107 | 1 | paulosilva | |
| 108 | ------------------------------------------------------------------------------- | ||
| 109 |