/ReductionSemantics.lhs
Haskell | 114 lines | 106 code | 8 blank | 0 comment | 4 complexity | 4b970a0ad08f2cd1d83e24116e24539f MD5 | raw file
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