WIP cleaning up AST

src/Act/Coq.hs

@@ -5,7 +5,7 @@
  - unsupported features:
  - + bytestrings
  - + external storage
- - + specifications for multiple contracts
+ - + casting from addresses to contract
  -
  -}
 
@@ -121,7 +121,7 @@ transition :: Store -> Behaviour -> Fresh T.Text
 transition store (Behaviour name cname i _ _ _ _ rewrites _) = do
   name' <- fresh name
   return $ definition name' (envDecl <> " " <> stateDecl <> " " <> interface i) $
-    stateval store cname (\ref _ -> storageRef ref) rewrites
+    stateval store cname (\r _ -> ref r) rewrites
 
 -- | inductive definition of a return claim
 -- ignores claims that do not specify a return value
@@ -145,8 +145,9 @@ retVal _ = return ""
 
 -- | produce a state value from a list of storage updates
 -- 'handler' defines what to do in cases where a given name isn't updated
-stateval :: Store -> Id -> (StorageRef -> SlotType -> T.Text) -> [StorageUpdate] -> T.Text
-stateval store contract handler updates = T.unwords $ stateConstructor : fmap (\(n, (t, _)) -> updateVar store updates handler (SVar nowhere contract n) t) (M.toList store')
+stateval :: Store -> Id -> (Ref Storage -> SlotType -> T.Text) -> [StorageUpdate] -> T.Text
+stateval store contract handler updates = T.unwords $ 
+  stateConstructor : fmap (\(n, (t, _)) -> updateVar store updates handler (SVar nowhere contract n) t) (M.toList store')
   where
     store' = contractStore contract store
 
@@ -156,21 +157,21 @@ contractStore contract store = case M.lookup contract store of
   Nothing -> error "Internal error: cannot find constructor in store"
 
 
--- | Check is an update update a specific strage reference
-eqRef :: StorageRef -> StorageUpdate -> Bool
-eqRef ref (Update _ (Item _ _ ref') _) = ref == ref'
+-- | Check is an update update a specific storage reference
+eqRef :: Ref Storage -> StorageUpdate -> Bool
+eqRef r (Update _ (Item _ _ r') _) = r == r'
 
 -- | Check if an update updates a location that has a given storage
 -- reference as a base
-baseRef :: StorageRef -> StorageUpdate -> Bool
-baseRef baseref (Update _ (Item _ _ ref) _) = hasBase ref
+baseRef :: Ref Storage -> StorageUpdate -> Bool
+baseRef baseref (Update _ (Item _ _ r) _) = hasBase r
   where
     hasBase (SVar _ _ _) = False
-    hasBase (SMapping _ ref' _) = ref' == baseref || hasBase ref'
-    hasBase (SField _ ref' _ _) = ref' == baseref || hasBase ref'
+    hasBase (SMapping _ r' _) = r' == baseref || hasBase r'
+    hasBase (SField _ r' _ _) = r' == baseref || hasBase r'
 
 
-updateVar :: Store -> [StorageUpdate] -> (StorageRef -> SlotType -> T.Text) -> StorageRef -> SlotType -> T.Text
+updateVar :: Store -> [StorageUpdate] -> (Ref Storage -> SlotType -> T.Text) -> Ref Storage -> SlotType -> T.Text
 updateVar store updates handler focus t@(StorageValue (ContractType cid)) =
   case (constructorUpdates, fieldUpdates) of
     -- Only some fields are updated
@@ -275,11 +276,9 @@ abiVal _ = error "TODO: missing default values"
 
 -- | coq syntax for an expression
 coqexp :: Exp a -> T.Text
-
 -- booleans
 coqexp (LitBool _ True)  = "true"
 coqexp (LitBool _ False) = "false"
-coqexp (Var _ _ SBoolean _ (VVar _ _ name))  = T.pack name
 coqexp (And _ e1 e2)  = parens $ "andb "   <> coqexp e1 <> " " <> coqexp e2
 coqexp (Or _ e1 e2)   = parens $ "orb"     <> coqexp e1 <> " " <> coqexp e2
 coqexp (Impl _ e1 e2) = parens $ "implb"   <> coqexp e1 <> " " <> coqexp e2
@@ -293,7 +292,6 @@ coqexp (GEQ _ e1 e2)  = parens $ coqexp e2 <> " <=? " <> coqexp e1
 
 -- integers
 coqexp (LitInt _ i) = T.pack $ show i
-coqexp (Var _ _ SInteger _ (VVar _ _ name))  = T.pack name
 coqexp (Add _ e1 e2) = parens $ coqexp e1 <> " + " <> coqexp e2
 coqexp (Sub _ e1 e2) = parens $ coqexp e1 <> " - " <> coqexp e2
 coqexp (Mul _ e1 e2) = parens $ coqexp e1 <> " * " <> coqexp e2
@@ -308,6 +306,7 @@ coqexp (UIntMax _ n) = parens $ "UINT_MAX " <> T.pack (show n)
 coqexp (InRange _ t e) = coqexp (bound t e)
 
 -- polymorphic
+coqexp (Var _ _ (Item _ _ r)) = ref r
 coqexp (TEntry _ w e) = entry e w
 coqexp (ITE _ b e1 e2) = parens $ "if "
                                <> coqexp b
@@ -325,11 +324,9 @@ coqexp (Create _ cid args) = parens $ T.pack cid <> "." <> T.pack cid <> " " <>
 -- unsupported
 coqexp Cat {} = error "bytestrings not supported"
 coqexp Slice {} = error "bytestrings not supported"
-coqexp (Var _ _ SByteStr _ _) = error "bytestrings not supported"
 coqexp ByStr {} = error "bytestrings not supported"
 coqexp ByLit {} = error "bytestrings not supported"
 coqexp ByEnv {} = error "bytestrings not supported"
-coqexp (Var _ _ _ _ _)  = error "Casting to contracts is not supported"
 
 -- | coq syntax for a proposition
 coqprop :: Exp a -> T.Text
@@ -353,15 +350,16 @@ coqprop e = error "ill formed proposition: " <> T.pack (show e)
 typedexp :: TypedExp -> T.Text
 typedexp (TExp _ e) = coqexp e
 
-entry :: TStorageItem a -> When -> T.Text
+entry :: TItem k a -> When -> T.Text
 entry (Item SByteStr _ _) _ = error "bytestrings not supported"
 entry _ Post = error "TODO: missing support for poststate references in coq backend"
-entry (Item _ _ ref) _ = storageRef ref
+entry (Item _ _ r) _ = ref r
 
-storageRef :: StorageRef -> T.Text
-storageRef (SVar _ _ name) = parens $ T.pack name <> " " <> stateVar
-storageRef (SMapping _ ref ixs) = parens $ storageRef ref <> " " <> coqargs ixs
-storageRef (SField _ ref cid name) = parens $ T.pack cid <> "." <> T.pack name <> " " <> storageRef ref
+ref :: Ref k -> T.Text
+ref (SVar _ _ name) = parens $ T.pack name <> " " <> stateVar
+ref (CVar _ _ name) = T.pack name
+ref (SMapping _ r ixs) = parens $ ref r <> " " <> coqargs ixs
+ref (SField _ r cid name) = parens $ T.pack cid <> "." <> T.pack name <> " " <> ref r
 
 -- | coq syntax for a list of arguments
 coqargs :: [TypedExp] -> T.Text

src/Act/Print.hs

@@ -143,32 +143,25 @@ prettyExp e = case e of
   --polymorphic
   ITE _ a b c -> "(if " <> prettyExp a <> " then " <> prettyExp b <> " else " <> prettyExp c <> ")"
   TEntry _ t a -> timeParens t $ prettyItem a
-  Var _ _ _ _ x -> prettyVar x
+  Var _ _ a -> prettyItem a
   where
     print2 sym a b = "(" <> prettyExp a <> " " <> sym <> " " <> prettyExp b <> ")"
 
 prettyTypedExp :: TypedExp t -> String
 prettyTypedExp (TExp _ e) = prettyExp e
 
-prettyItem :: TStorageItem a t -> String
+prettyItem :: TItem k a t -> String
 prettyItem (Item _ _ r) = prettyRef r
 
-prettyRef :: StorageRef t -> String
+prettyRef :: Ref k t -> String
 prettyRef = \case
+  CVar _ _ n -> n
   SVar _ _ n -> n
   SMapping _ r args -> prettyRef r <> concatMap (brackets . prettyTypedExp) args
   SField _ r _ n -> prettyRef r <> "." <> n
   where
     brackets str = "[" <> str <> "]"
 
-prettyVar :: VarRef t -> String
-prettyVar = \case
-  VVar _ _ n -> n
-  VMapping _ r args -> prettyVar r <> concatMap (brackets . prettyTypedExp) args
-  VField _ r _ n -> prettyVar r <> "." <> n
-  where
-    brackets str = "[" <> str <> "]"
-
 prettyLocation :: StorageLocation t -> String
 prettyLocation (Loc _ item) = prettyItem item
 
@@ -204,15 +197,11 @@ prettyInvPred = prettyExp . untime . fst
     untimeTyped :: TypedExp t -> TypedExp Untimed
     untimeTyped (TExp t e) = TExp t (untime e)
 
-    untimeStorageRef :: StorageRef t -> StorageRef Untimed
-    untimeStorageRef (SVar p c a) = SVar p c a
-    untimeStorageRef (SMapping p e xs) = SMapping p (untimeStorageRef e) (fmap untimeTyped xs)
-    untimeStorageRef (SField p e c x) = SField p (untimeStorageRef e) c x
-
-    untimeVarRef :: VarRef t -> VarRef Untimed
-    untimeVarRef (VVar p c a) = VVar p c a
-    untimeVarRef (VMapping p e xs) = VMapping p (untimeVarRef e) (fmap untimeTyped xs)
-    untimeVarRef (VField p e c x) = VField p (untimeVarRef e) c x
+    untimeRef:: Ref k t -> Ref k Untimed
+    untimeRef (SVar p c a) = SVar p c a
+    untimeRef (CVar p c a) = CVar p c a
+    untimeRef (SMapping p e xs) = SMapping p (untimeRef e) (fmap untimeTyped xs)
+    untimeRef (SField p e c x) = SField p (untimeRef e) c x
 
     untime :: Exp a t -> Exp a Untimed
     untime e = case e of
@@ -247,8 +236,8 @@ prettyInvPred = prettyExp . untime . fst
       ByEnv p a   -> ByEnv p a
       ITE p x y z -> ITE p (untime x) (untime y) (untime z)
       Slice p a b c -> Slice p (untime a) (untime b) (untime c)
-      TEntry p _ (Item t vt a) -> TEntry p Neither (Item t vt (untimeStorageRef a))
-      Var p _ at vt a -> Var p Neither at vt (untimeVarRef a)
+      TEntry p _ (Item t vt a) -> TEntry p Neither (Item t vt (untimeRef a))
+      Var p _ (Item t vt a) -> Var p Neither (Item t vt (untimeRef a))
 
 
 -- | Doc type for terminal output