| 0 | 0 |
module Language.Fountain.Store (
|
| 1 | 1 |
Store, empty, fetch, insert, update, updateStore,
|
| 2 | |
constructStore, ceval, applyConstraint,
|
|
2 |
ceval, applyConstraint,
|
| 3 | 3 |
trace
|
| 4 | 4 |
) where
|
| 5 | 5 |
|
|
| 11 | 11 |
|
| 12 | 12 |
import qualified Data.Map as Map
|
| 13 | 13 |
|
| 14 | |
import Language.Fountain.Value
|
| 15 | 14 |
import Language.Fountain.Constraint
|
| 16 | |
import Language.Fountain.Loader (parseConstConstraint)
|
| 17 | 15 |
|
| 18 | 16 |
|
| 19 | 17 |
data Store a = Store {
|
|
| 25 | 23 |
fetch k s = Map.lookup k (store s)
|
| 26 | 24 |
insert k v s = s{ store=Map.insert k v $ store s }
|
| 27 | 25 |
update f k s = s{ store=Map.update f k $ store s }
|
| 28 | |
|
| 29 | |
|
| 30 | |
constructStore :: [String] -> Store Value
|
| 31 | |
constructStore [] = empty
|
| 32 | |
constructStore (constConstrainer:rest) =
|
| 33 | |
let
|
| 34 | |
(k, v) = parseConstConstraint constConstrainer
|
| 35 | |
in
|
| 36 | |
insert k v $ constructStore rest
|
| 37 | 26 |
|
| 38 | 27 |
updateStore :: [Variable] -> [Variable] -> Store a -> Store a -> Store a
|
| 39 | 28 |
updateStore [] [] _sourceStore destStore = destStore
|
|
| 52 | 41 |
ceval (CVal val) _ = Just val
|
| 53 | 42 |
ceval (CVar v) st = fetch v st
|
| 54 | 43 |
|
| 55 | |
applyConstraint :: Constraint Value -> Store Value -> Maybe (Store Value)
|
|
44 |
applyConstraint :: (Show a, Num a, Ord a) => Constraint a -> Store a -> Maybe (Store a)
|
| 56 | 45 |
applyConstraint (UnifyConst v i) st =
|
| 57 | 46 |
case fetch v st of
|
| 58 | 47 |
Just value ->
|
|
| 71 | 60 |
Just st
|
| 72 | 61 |
applyConstraint (Inc v e) st =
|
| 73 | 62 |
case ceval e st of
|
| 74 | |
Just (IntVal delta) ->
|
| 75 | |
Just $ update (\(IntVal i) -> Just $ IntVal $ i + delta) v st
|
|
63 |
Just delta ->
|
|
64 |
Just $ update (\i -> Just $ i + delta) v st
|
| 76 | 65 |
Nothing ->
|
| 77 | 66 |
Nothing
|
| 78 | 67 |
applyConstraint (Dec v e) st =
|
| 79 | 68 |
case ceval e st of
|
| 80 | |
Just (IntVal delta) ->
|
| 81 | |
Just $ update (\(IntVal i) -> Just $ IntVal $ i - delta) v st
|
|
69 |
Just delta ->
|
|
70 |
Just $ update (\i -> Just $ i - delta) v st
|
| 82 | 71 |
Nothing ->
|
| 83 | 72 |
Nothing
|
| 84 | 73 |
applyConstraint (Both c1 c2) st =
|
|
| 93 | 82 |
applyConstraint (LessThanOrEqual v e) st = applyRelConstraint (<=) v e st
|
| 94 | 83 |
applyConstraint other _state = error ("Can't handle this: " ++ show other)
|
| 95 | 84 |
|
| 96 | |
applyRelConstraint :: (Integer -> Integer -> Bool) -> Variable -> CExpr Value -> Store Value -> Maybe (Store Value)
|
|
85 |
applyRelConstraint :: Ord a => (a -> a -> Bool) -> Variable -> CExpr a -> Store a -> Maybe (Store a)
|
| 97 | 86 |
applyRelConstraint op var e st =
|
| 98 | 87 |
case (fetch var st, ceval e st) of
|
| 99 | |
(Just (IntVal value), Just (IntVal target)) ->
|
|
88 |
(Just value, Just target) ->
|
| 100 | 89 |
if value `op` target then Just st else Nothing
|
| 101 | 90 |
_ ->
|
| 102 | 91 |
Nothing
|