Make the typesafe imperative language work properly.

code/typesafe-imperative/TypesafeImp.idr

@@ -23,20 +23,20 @@ data Expr : RegState -> Ty -> Type where
   Not : Expr s BoolTy -> Expr s BoolTy
 
 mutual
-  data Stmt : RegState -> RegState -> Type where
-    Store : (r : Reg) -> Expr s t -> Stmt s (setRegTy r t s)
-    If : Expr s BoolTy -> Prog s n -> Prog s n -> Stmt s n
-    Loop : Prog s s -> Stmt s s
+  data Stmt : RegState -> RegState -> RegState -> Type where
+    Store : (r : Reg) -> Expr s t -> Stmt l s (setRegTy r t s)
+    If : Expr s BoolTy -> Prog l s n -> Prog l s n -> Stmt l s n
+    Loop : Prog s s s -> Stmt l s s
+    Break : Stmt s s s
 
-  data Prog : RegState -> RegState -> Type where
-    Nil : Prog s s
-    Break : Prog s s
-    (::) : Stmt s n -> Prog n m -> Prog s m
+  data Prog : RegState -> RegState -> RegState -> Type where
+    Nil : Prog l s s
+    (::) : Stmt l s n -> Prog l n m -> Prog l s m
 
 initialState : RegState
 initialState = (IntTy, IntTy, IntTy)
 
-testProg : Prog Main.initialState Main.initialState
+testProg : Prog Main.initialState Main.initialState Main.initialState
 testProg =
   [ Store A (Lit 1 `Leq` Lit 2)
   , If (Load A)
@@ -45,3 +45,55 @@ testProg =
   , Store B (Lit 2)
   , Store R (Add (Load A) (Load B))
   ]
+
+prodProg : Prog Main.initialState Main.initialState Main.initialState
+prodProg =
+  [ Store A (Lit 7)
+  , Store B (Lit 9)
+  , Store R (Lit 0)
+  , Loop
+    [ If (Load A `Leq` Lit 0)
+      [ Break ]
+      [ Store R (Load R `Add` Load B)
+      , Store A (Load A `Add` Lit (-1))
+      ]
+    ]
+  ]
+
+repr : Ty -> Type
+repr IntTy = Int
+repr BoolTy = Bool
+
+data State : RegState -> Type where
+  MkState : (repr a, repr b, repr c) -> State (a, b, c)
+
+getReg : (r : Reg) -> State s -> repr (getRegTy r s)
+getReg A (MkState (a, _, _)) = a
+getReg B (MkState (_, b, _)) = b
+getReg R (MkState (_, _, r)) = r
+
+setReg : (r : Reg) -> repr t -> State s -> State (setRegTy r t s)
+setReg A a (MkState (_, b, r)) = MkState (a, b, r)
+setReg B b (MkState (a, _, r)) = MkState (a, b, r)
+setReg R r (MkState (a, b, _)) = MkState (a, b, r)
+
+expr : Expr s t -> State s -> repr t
+expr (Lit i) _ = i
+expr (Load r) s = getReg r s
+expr (Add l r) s = expr l s + expr r s
+expr (Leq l r) s = expr l s <= expr r s
+expr (Not e) s = not $ expr e s
+
+mutual
+  stmt : Stmt l s n -> State s -> Either (State l) (State n)
+  stmt (Store r e) s = Right $ setReg r (expr e s) s
+  stmt (If c t e) s = if expr c s then prog t s else prog e s
+  stmt (Loop p) s =
+    case prog p s >>= stmt (Loop p) of
+      Right s => Right s
+      Left s => Right s
+  stmt Break s = Left s
+
+  prog : Prog l s n -> State s -> Either (State l) (State n)
+  prog Nil s = Right s
+  prog (st::p) s = stmt st s >>= prog p