/ReductionSemantics.lhs

  1\begin{code}
  2
  3module ReductionSemantics where
  4import qualified AbstractSyntax as S
  5import qualified EvaluationContext as E
  6import qualified StructuralOperationalSemantics as S
  7import qualified IntegerArithmetic as I
  8
  9makeEvalContext :: S.Term -> Maybe (S.Term, E.Context)
 10makeEvalContext t = case t of
 11  S.App (S.Abs x tau11 t12) t2
 12    | S.isValue t2 -> Just (t, E.Hole)
 13  S.App t1 t2
 14    | S.isValue t1 -> case makeEvalContext t2 of
 15                        Just (t2', c2) -> Just (t2', (E.AppV t1 c2))
 16                        _              -> Nothing
 17    | otherwise -> case makeEvalContext t1 of
 18                        Just(t1', c1) -> Just (t1', (E.AppT c1 t2))
 19                        _             -> Nothing
 20  S.If (S.Tru) t2 t3 -> Just (t, E.Hole)
 21  S.If (S.Fls) t2 t3 -> Just (t, E.Hole)
 22  S.If t1 t2 t3 -> case makeEvalContext t1 of
 23                        Just(t1', c1) -> Just (t1', (E.If c1 t2 t3))
 24                        _             -> Nothing
 25  S.IntAdd t1 t2
 26    | S.isValue t1 -> case makeEvalContext t2 of
 27                           Just(t2', c2) -> Just(t2', (E.IntAddV t1 c2))
 28                           Nothing       -> Just(t, E.Hole)
 29    | otherwise    -> case makeEvalContext t1 of
 30                           Just(t1', c1) -> Just(t1', (E.IntAddT c1 t2))
 31                           _             -> Nothing
 32  S.IntSub t1 t2
 33    | S.isValue t1 -> case makeEvalContext t2 of
 34                           Just(t2', c2) -> Just(t2', (E.IntSubV t1 c2))
 35                           Nothing -> Just(t, E.Hole)
 36    | otherwise -> case makeEvalContext t1 of
 37                        Just(t1', c1) -> Just(t1', (E.IntSubT c1 t2))
 38                        _             -> Nothing
 39  S.IntMul t1 t2
 40    | S.isValue t1 -> case makeEvalContext t2 of
 41                           Just(t2', c2) -> Just(t2', (E.IntMulV t1 c2))
 42                           Nothing       -> Just(t, E.Hole)
 43    | otherwise -> case makeEvalContext t1 of
 44                        Just(t1', c1) -> Just(t1', (E.IntMulT c1 t2))
 45                        _             -> Nothing
 46  S.IntDiv t1 t2
 47    | S.isValue t1 -> case makeEvalContext t2 of
 48                           Just(t2', c2) -> Just(t2', (E.IntDivV t1 c2))
 49                           Nothing -> Just(t, E.Hole)
 50    | otherwise -> case makeEvalContext t1 of
 51                        Just(t1', c1) -> Just(t1', (E.IntDivT c1 t2))
 52                        _             -> Nothing
 53  S.IntNand t1 t2
 54    | S.isValue t1 -> case makeEvalContext t2 of
 55                           Just(t2', c2) -> Just(t2', (E.IntNandV t1 c2))
 56                           Nothing -> Just(t, E.Hole)
 57    | otherwise -> case makeEvalContext t1 of
 58                           Just(t1', c1) -> Just(t1', (E.IntNandT c1 t2))
 59                           _             -> Nothing
 60  S.IntEq t1 t2
 61    | S.isValue t1 -> case makeEvalContext t2 of
 62                           Just(t2', c2) -> Just(t2', (E.IntEqV t1 c2))
 63                           Nothing -> Just(t, E.Hole)
 64    | otherwise -> case makeEvalContext t1 of
 65                        Just(t1', c1) -> Just(t1', (E.IntEqT c1 t2))
 66                        _ -> Nothing
 67  S.IntLt t1 t2
 68    | S.isValue t1 -> case makeEvalContext t2 of
 69                           Just(t2', c2) -> Just(t2', (E.IntLtV t1 c2))
 70                           Nothing -> Just(t, E.Hole)
 71    | otherwise -> case makeEvalContext t1 of
 72                        Just(t1', c1) -> Just(t1', (E.IntLtT c1 t2))
 73                        _             -> Nothing
 74  S.Let x t1 t2
 75    | S.isValue t1 -> Just (t, E.Hole)
 76    | otherwise -> case makeEvalContext t1 of
 77                        Just(t1', c1) -> Just(t1', (E.Let x c1 t2))
 78                        _             -> Nothing
 79  S.Fix (S.Abs x tau1 t2) -> Just (t, E.Hole)
 80  S.Fix t -> case makeEvalContext t of
 81                  Just(t', c) -> Just(t', E.Fix c)
 82                  _           -> Nothing
 83  _ -> Nothing
 84
 85makeContractum :: S.Term -> S.Term
 86makeContractum t = case t of
 87  S.App (S.Abs x tau11 t12) t2 -> S.subst x t2 t12
 88  S.If (S.Tru) t2 t3 -> t2
 89  S.If (S.Fls) t2 t3 -> t3
 90  S.IntAdd (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intAdd n1 n2)
 91  S.IntSub (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intSub n1 n2)
 92  S.IntMul (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intMul n1 n2)
 93  S.IntDiv (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intDiv n1 n2)
 94  S.IntNand (S.IntConst n1) (S.IntConst n2) -> S.IntConst (I.intNand n1 n2)
 95  S.IntEq (S.IntConst n1) (S.IntConst n2) -> if I.intEq n1 n2 then S.Tru else S.Fls
 96  S.IntLt (S.IntConst n1) (S.IntConst n2) -> if I.intLt n1 n2 then S.Tru else S.Fls
 97  S.Let x t1 t2 -> S.subst x t1 t2
 98  S.Fix (S.Abs x tau1 t2) -> S.subst x (S.Fix (S.Abs x tau1 t2)) t2
 99
100textualMachineStep :: S.Term -> Maybe S.Term
101textualMachineStep t =
102  case makeEvalContext t of
103       Just(t1, c) -> Just (E.fillWithTerm c (makeContractum t1))
104       Nothing     -> Nothing
105
106textualMachineEval :: S.Term -> S.Term
107textualMachineEval t =
108  case textualMachineStep t of
109       Just t' -> textualMachineEval t'
110       Nothing -> t
111
112\end{code}
113
114