From 634602c00d58bb07dddb87e18eda635c4afa1faa Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Wed, 14 Jul 2021 17:13:32 +0200
Subject: [PATCH 01/36] add `ErrorLogger`

---
 src/ErrorLogger.hs | 52 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 52 insertions(+)
 create mode 100644 src/ErrorLogger.hs

diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs
new file mode 100644
index 00000000..272a6df6
--- /dev/null
+++ b/src/ErrorLogger.hs
@@ -0,0 +1,52 @@
+module ErrorLogger where
+
+import Control.Applicative
+import Control.Monad.Writer
+
+import Data.Functor (($>))
+import Data.Maybe
+
+-- Experimental error logging/handling
+
+newtype Err e a = Err { unErr :: Writer [e] (Maybe a) }
+
+instance Functor (Err e) where
+  fmap f (Err w) = Err $ fmap f <$> w
+
+instance Applicative (Err e) where
+  pure a              = Err . pure . pure $ a
+  (Err f) <*> (Err a) = Err $ fmap ap f <*> a
+
+instance Alternative (Err e) where
+  empty = Err $ pure Nothing
+  a <|> b | succeeds a = a
+          | otherwise  = b
+
+--instance Monad (Err e) where
+--  return = pure
+--  (Err wA) >>= f = Err $ let (a, w1) = runWriter wA
+--                    in case f <$> a of
+--                      Nothing -> writer (Nothing,w1)
+--                      Just eB -> writer . fmap (w1 <>) . runWriter . unErr $ eB
+
+
+throw :: e -> Err e a
+throw e = Err $ tell [e] $> Nothing
+
+getErrs :: Err e a -> [e]
+getErrs = execWriter . unErr
+
+runErr :: Err e a -> (Maybe a, [e])
+runErr = runWriter . unErr
+
+getResult :: Err e a -> Maybe a
+getResult = fst . runErr
+
+fails :: Err e a -> Bool
+fails = isNothing . getResult
+
+succeeds :: Err e a -> Bool
+succeeds = isJust . getResult
+
+maybeThrow :: e -> Maybe a -> Err e a
+maybeThrow e = maybe (throw e) pure

From 063c36cf010c00ef3a9d5b7f762be448225cbe74 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Thu, 2 Sep 2021 00:14:42 +0200
Subject: [PATCH 02/36] error handling using `Validation` and `Writer` in
 `Type.hs`

---
 src/ErrorLogger.hs                            |  63 ++--
 src/Main.hs                                   | 108 +++---
 src/Parse.y                                   |   8 +-
 src/Syntax.hs                                 |   3 +
 src/Syntax/Untyped.hs                         |   6 +-
 src/Type.hs                                   | 314 +++++++++---------
 src/act.cabal                                 |   7 +-
 tests/frontend/fail/emptystorage/circular.act |   1 +
 tests/frontend/fail/multipledef/threedefs.act |   8 +
 9 files changed, 255 insertions(+), 263 deletions(-)
 create mode 100644 tests/frontend/fail/multipledef/threedefs.act

diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs
index 272a6df6..49831259 100644
--- a/src/ErrorLogger.hs
+++ b/src/ErrorLogger.hs
@@ -1,52 +1,27 @@
-module ErrorLogger where
+{-# LANGUAGE OverloadedLists #-}
 
-import Control.Applicative
-import Control.Monad.Writer
-
-import Data.Functor (($>))
-import Data.Maybe
-
--- Experimental error logging/handling
-
-newtype Err e a = Err { unErr :: Writer [e] (Maybe a) }
-
-instance Functor (Err e) where
-  fmap f (Err w) = Err $ fmap f <$> w
+module ErrorLogger (module ErrorLogger) where
 
-instance Applicative (Err e) where
-  pure a              = Err . pure . pure $ a
-  (Err f) <*> (Err a) = Err $ fmap ap f <*> a
-
-instance Alternative (Err e) where
-  empty = Err $ pure Nothing
-  a <|> b | succeeds a = a
-          | otherwise  = b
-
---instance Monad (Err e) where
---  return = pure
---  (Err wA) >>= f = Err $ let (a, w1) = runWriter wA
---                    in case f <$> a of
---                      Nothing -> writer (Nothing,w1)
---                      Just eB -> writer . fmap (w1 <>) . runWriter . unErr $ eB
-
-
-throw :: e -> Err e a
-throw e = Err $ tell [e] $> Nothing
+import Control.Lens as ErrorLogger ((#))
+import Control.Monad.Writer
+import Data.Functor
+import Data.List.NonEmpty
+import Data.Validation as ErrorLogger
 
-getErrs :: Err e a -> [e]
-getErrs = execWriter . unErr
+import Syntax.Untyped (Pn)
 
-runErr :: Err e a -> (Maybe a, [e])
-runErr = runWriter . unErr
+type Error e a = Validation (NonEmpty (Pn,e)) a
 
-getResult :: Err e a -> Maybe a
-getResult = fst . runErr
+throw :: (Pn,e) -> Error e a
+throw err = _Failure # [err]
 
-fails :: Err e a -> Bool
-fails = isNothing . getResult
+bindDummy :: (Monoid a, Semigroup e) => Validation e a -> (a -> Validation e b) -> Validation e b
+bindDummy val cont = validation (\e -> cont mempty <* Failure e) cont val
 
-succeeds :: Err e a -> Bool
-succeeds = isJust . getResult
+(>>=?) :: (Monoid a, Semigroup e) => Validation e a -> (a -> Validation e b) -> Validation e b
+(>>=?) = bindDummy
 
-maybeThrow :: e -> Maybe a -> Err e a
-maybeThrow e = maybe (throw e) pure
+liftWriter :: Writer [(Pn,e)] a -> Error e a
+liftWriter writer = case runWriter writer of
+  (res, []) -> pure res
+  (_,   es) -> _Failure # fromList es
diff --git a/src/Main.hs b/src/Main.hs
index 0ec6b3ab..d574518d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -30,6 +30,7 @@ import qualified Data.ByteString.Lazy.Char8 as B
 import Control.Monad
 
 import ErrM
+import qualified ErrorLogger as Logger
 import Lex (lexer, AlexPosn(..))
 import Options.Generic
 import Parse
@@ -38,9 +39,10 @@ import Syntax.Untyped
 import Enrich
 import K hiding (normalize, indent)
 import SMT
-import Type
+import Type hiding (Err)
+import qualified Type
 import Coq hiding (indent)
-import HEVM
+--import HEVM
 
 --command line options
 data Command w
@@ -93,8 +95,8 @@ main = do
       Type f -> type' f
       Prove file' solver' smttimeout' debug' -> prove file' solver' smttimeout' debug'
       Coq f -> coq' f
-      K spec' soljson' gas' storage' extractbin' out' -> k spec' soljson' gas' storage' extractbin' out'
-      HEVM spec' soljson' solver' smttimeout' debug' -> hevm spec' soljson' solver' smttimeout' debug'
+      --K spec' soljson' gas' storage' extractbin' out' -> k spec' soljson' gas' storage' extractbin' out'
+      --HEVM spec' soljson' solver' smttimeout' debug' -> hevm spec' soljson' solver' smttimeout' debug'
 
 
 ---------------------------------
@@ -118,8 +120,8 @@ type' :: FilePath -> IO ()
 type' f = do
   contents <- readFile f
   case compile contents of
-    Ok a  -> B.putStrLn $ encode a
-    Bad e -> prettyErr contents e
+    Logger.Success a -> B.putStrLn (encode a)
+    Logger.Failure e -> mapM_ (prettyErr contents) e >> exitFailure
 
 prove :: FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
 prove file' solver' smttimeout' debug' = do
@@ -187,43 +189,43 @@ coq' f = do
   proceed contents (compile contents) $ \claims ->
     TIO.putStr $ coq claims
 
-k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
-k spec' soljson' gas' storage' extractbin' out' = do
-  specContents <- readFile spec'
-  solContents  <- readFile soljson'
-  let kOpts = KOptions (maybe mempty Map.fromList gas') storage' extractbin'
-      errKSpecs = do refinedSpecs <- compile specContents
-                     (sources, _, _) <- errMessage (nowhere, "Could not read sol.json")
-                       $ Solidity.readJSON $ pack solContents
-                     forM [b | B b <- refinedSpecs]
-                       $ makekSpec sources kOpts
-  proceed specContents errKSpecs $ \kSpecs -> do
-    let printFile (filename, content) = case out' of
-          Nothing -> putStrLn (filename <> ".k") >> putStrLn content
-          Just dir -> writeFile (dir <> "/" <> filename <> ".k") content
-    forM_ kSpecs printFile
-
-hevm :: FilePath -> FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
-hevm spec' soljson' solver' smttimeout' smtdebug' = do
-  specContents <- readFile spec'
-  solContents  <- readFile soljson'
-  let preprocess = do refinedSpecs  <- compile specContents
-                      (sources, _, _) <- errMessage (nowhere, "Could not read sol.json")
-                        $ Solidity.readJSON $ pack solContents
-                      return ([b | B b <- refinedSpecs], sources)
-  proceed specContents preprocess $ \(specs, sources) -> do
-    -- TODO: prove constructor too
-    passes <- forM specs $ \behv -> do
-      res <- runSMTWithTimeOut solver' smttimeout' smtdebug' $ proveBehaviour sources behv
-      case res of
-        Left posts -> do
-           putStrLn $ "Successfully proved " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
-             <> ", " <> show (length $ last $ levels posts) <> " cases."
-           return True
-        Right _ -> do
-           putStrLn $ "Failed to prove " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
-           return False
-    unless (and passes) exitFailure
+-- k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
+-- k spec' soljson' gas' storage' extractbin' out' = do
+--   specContents <- readFile spec'
+--   solContents  <- readFile soljson'
+--   let kOpts = KOptions (maybe mempty Map.fromList gas') storage' extractbin'
+--       errKSpecs = do refinedSpecs <- compile specContents
+--                      (sources, _, _) <- errMessage (nowhere, "Could not read sol.json")
+--                        $ Solidity.readJSON $ pack solContents
+--                      forM [b | B b <- refinedSpecs]
+--                        $ makekSpec sources kOpts
+--   proceed specContents errKSpecs $ \kSpecs -> do
+--     let printFile (filename, content) = case out' of
+--           Nothing -> putStrLn (filename <> ".k") >> putStrLn content
+--           Just dir -> writeFile (dir <> "/" <> filename <> ".k") content
+--     forM_ kSpecs printFile
+
+-- hevm :: FilePath -> FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
+-- hevm spec' soljson' solver' smttimeout' smtdebug' = do
+--   specContents <- readFile spec'
+--   solContents  <- readFile soljson'
+--   let preprocess = do refinedSpecs  <- compile specContents
+--                       (sources, _, _) <- errMessage (nowhere, "Could not read sol.json")
+--                         $ Solidity.readJSON $ pack solContents
+--                       return ([b | B b <- refinedSpecs], sources)
+--   proceed specContents preprocess $ \(specs, sources) -> do
+--     -- TODO: prove constructor too
+--     passes <- forM specs $ \behv -> do
+--       res <- runSMTWithTimeOut solver' smttimeout' smtdebug' $ proveBehaviour sources behv
+--       case res of
+--         Left posts -> do
+--            putStrLn $ "Successfully proved " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
+--              <> ", " <> show (length $ last $ levels posts) <> " cases."
+--            return True
+--         Right _ -> do
+--            putStrLn $ "Failed to prove " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
+--            return False
+--     unless (and passes) exitFailure
 
 
 -------------------
@@ -246,18 +248,22 @@ runSMTWithTimeOut solver' maybeTimeout debug' sym
        runwithz3 = runSMTWith z3{verbose=debug'} $ (setTimeOut timeout) >> sym
 
 -- | Fail on error, or proceed with continuation
-proceed :: String -> Err a -> (a -> IO ()) -> IO ()
-proceed contents (Bad e) _ = prettyErr contents e
-proceed _ (Ok a) continue = continue a
+proceed :: String -> Type.Err a -> (a -> IO ()) -> IO ()
+proceed contents comp continue = Logger.validation (mapM_ $ prettyErr contents) continue comp
+
+--compile :: String -> Err [Claim]
+--compile = pure . fmap annotate . enrich <=< typecheck <=< parse . lexer
 
-compile :: String -> Err [Claim]
-compile = pure . fmap annotate . enrich <=< typecheck <=< parse . lexer
+compile :: String -> Type.Err [Claim]
+compile source = case parse . lexer $ source of
+  Bad e -> Logger.throw e
+  Ok a  -> fmap annotate . enrich <$> typecheck a
 
 prettyErr :: String -> (Pn, String) -> IO ()
 prettyErr _ (pn, msg) | pn == nowhere = do
   hPutStrLn stderr "Internal error:"
   hPutStrLn stderr msg
-  exitFailure
+--  exitFailure
 prettyErr contents (pn, msg) | pn == lastPos = do
   let culprit = last $ lines contents
       line' = length (lines contents) - 1
@@ -265,13 +271,13 @@ prettyErr contents (pn, msg) | pn == lastPos = do
   hPutStrLn stderr $ show line' <> " | " <> culprit
   hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
   hPutStrLn stderr msg
-  exitFailure
+--  exitFailure
 prettyErr contents (AlexPn _ line' col, msg) = do
   let cxt = safeDrop (line' - 1) (lines contents)
   hPutStrLn stderr $ show line' <> " | " <> head cxt
   hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
   hPutStrLn stderr msg
-  exitFailure
+--  exitFailure
   where
     safeDrop :: Int -> [a] -> [a]
     safeDrop 0 a = a
diff --git a/src/Parse.y b/src/Parse.y
index 0f9f65b3..a5f388a3 100644
--- a/src/Parse.y
+++ b/src/Parse.y
@@ -1,5 +1,5 @@
 {
-module Parse where
+module Parse (module Parse, showposn) where
 import Prelude hiding (EQ, GT, LT)
 import Lex
 import EVM.ABI
@@ -162,7 +162,7 @@ Transition : 'behaviour' id 'of' id
              Interface
              list(Precondition)
              Cases
-             Ensures                                  { Transition (name $2) (name $4)
+             Ensures                                  { Transition (posn $2) (name $2) (name $4)
                                                         $5 $6 $7 $8 }
 
 Constructor : 'constructor' 'of' id
@@ -171,7 +171,7 @@ Constructor : 'constructor' 'of' id
               Creation
               list(ExtStorage)
               Ensures
-              Invariants                              { Definition (name $3)
+              Invariants                              { Definition (posn $3) (name $3)
                                                          $4 $5 $6 $7 $8 $9 }
 
 Ensures : optblock('ensures', Expr)                   { $1 }
@@ -221,7 +221,7 @@ Assign : StorageVar ':=' Expr                         { AssignVal $1 $3 }
 Defn : Expr ':=' Expr                                 { Defn $1 $3 }
 Decl : Type id                                        { Decl $1 (name $2) }
 
-StorageVar : SlotType id                              { StorageVar $1 (name $2) }
+StorageVar : SlotType id                              { StorageVar (posn $2) $1 (name $2) }
 
 Type : 'uint'
        { case validsize $1 of
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 394ead49..42b2a5a7 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -316,6 +316,9 @@ getPosn expr = case expr of
     IntLit pn _ -> pn
     BoolLit pn _ -> pn
 
+posFromDef :: Defn -> Pn
+posFromDef (Defn e _) = getPosn e
+
 -- | Returns all the identifiers used in an expression,
 -- as well all of the positions they're used in.
 idFromRewrites :: Expr -> Map Id [Pn]
diff --git a/src/Syntax/Untyped.hs b/src/Syntax/Untyped.hs
index ca49c5aa..508e6446 100644
--- a/src/Syntax/Untyped.hs
+++ b/src/Syntax/Untyped.hs
@@ -22,8 +22,8 @@ newtype Act = Main [RawBehaviour]
   deriving (Eq, Show)
 
 data RawBehaviour
-  = Transition Id Id Interface [IffH] Cases Ensures
-  | Definition Id Interface [IffH] Creates [ExtStorage] Ensures Invariants
+  = Transition Pn Id Id Interface [IffH] Cases Ensures
+  | Definition Pn Id Interface [IffH] Creates [ExtStorage] Ensures Invariants
   deriving (Eq, Show)
 
 type Ensures = [Expr]
@@ -134,7 +134,7 @@ data EthEnv
   | Nonce
   deriving (Show, Eq)
 
-data StorageVar = StorageVar SlotType Id
+data StorageVar = StorageVar Pn SlotType Id
   deriving (Eq, Show)
 
 data Decl = Decl AbiType Id
diff --git a/src/Type.hs b/src/Type.hs
index b018dfac..f7394f19 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -5,8 +5,9 @@
 {-# Language ScopedTypeVariables #-}
 {-# Language NamedFieldPuns #-}
 {-# Language DataKinds #-}
+{-# LANGUAGE ApplicativeDo, OverloadedLists #-}
 
-module Type (typecheck, bound, lookupVars, defaultStore, metaType) where
+module Type (typecheck, bound, lookupVars, defaultStore, metaType, Err) where
 
 import Data.List
 import EVM.ABI
@@ -22,50 +23,53 @@ import Type.Reflection (typeRep)
 import Data.ByteString (ByteString)
 
 import Control.Applicative
-import Data.Traversable (for)
-import Control.Monad
+import Control.Monad (join,unless)
+import Control.Monad.Writer
+import Data.Functor
+import Data.Functor.Alt
+import Data.Foldable
+import Data.Traversable
 
 import Syntax
 import Syntax.Timing
 import Syntax.Untyped hiding (Post,Constant,Rewrite)
 import qualified Syntax.Untyped as Untyped
 import Syntax.Typed
-import ErrM
+import ErrorLogger
 import Parse
 
+type Err a = Error TypeErr a
+
+type TypeErr = String
+
 typecheck :: [RawBehaviour] -> Err [Claim]
-typecheck behvs = do store <- lookupVars behvs
-                     bs <- mapM (splitBehaviour store) behvs
-                     return $ S store : join bs
+typecheck behvs = do
+  let (store,errs) = runWriter $ lookupVars behvs
+  traverse throw errs
+  bs <- traverse (splitBehaviour store) behvs
+  pure $ S store : concat bs
 
 --- Finds storage declarations from constructors
-lookupVars :: [RawBehaviour] -> Err Store
+lookupVars :: [RawBehaviour] -> Writer [(Pn,TypeErr)] Store
 lookupVars ((Transition {}):bs) = lookupVars bs
-lookupVars ((Definition contract _ _ (Creates assigns) _ _ _):bs) =
-  let assignments = fromAssign <$> assigns
-  in case duplicates $ fst <$> assignments of
-        [] ->
-          let new' = Map.singleton contract (Map.fromList assignments)
-           in do old <- lookupVars bs
-                 if null (Map.intersection new' old)
-                 then pure $ new' <> old
-                 else Bad (nowhere, "Multiple definitions given of contract: " <> contract)
-        vs -> Bad (nowhere,
-                   concatMap (\v -> "Multiple definitions given of state variable: " <> v <> "\n") vs)
+lookupVars ((Definition pn contract _ _ (Creates assigns) _ _ _):bs) = do
+  let assignments = Map.fromListWith (<>) $ fromAssign <$> assigns
+
+  allVars <- lookupVars bs
+  newVars <- flip Map.traverseWithKey assignments $ \var ((p,typ) :| rest) -> pure typ
+                      <* for rest (\(pn,_) ->
+                            tell [(pn, var <> " already defined at " <> showposn p <> ".")])
+
+  if contract `Map.member` allVars
+    then allVars <$ tell [(pn, "Conflicting definitions for " <> contract <> ".")]
+    else pure $ Map.insert contract newVars allVars
 lookupVars [] = pure mempty
 
-fromAssign :: Assign -> (Id, SlotType)
-fromAssign (AssignVal (StorageVar typ var) _) = (var, typ)
-fromAssign (AssignMany (StorageVar typ var) _) = (var, typ)
+fromAssign :: Assign -> (Id, NonEmpty (Pn, SlotType))
+fromAssign (AssignVal (StorageVar pn typ var) _) = (var, [(pn, typ)])
+fromAssign (AssignMany (StorageVar pn typ var) _) = (var, [(pn, typ)])
 fromAssign (AssignStruct _ _) = error "TODO: assignstruct"
 
--- | filters out duplicate entries in list
-duplicates :: Eq a => [a] -> [a]
-duplicates [] = []
-duplicates (x:xs) =
-  let e = [x | x `elem` xs]
-  in e <> duplicates xs
-
 -- | The type checking environment. 
 data Env = Env
   { contract :: Id              -- ^ The name of the current contract.
@@ -95,10 +99,10 @@ defaultStore =
 
 -- checks a transition given a typing of its storage variables
 splitBehaviour :: Store -> RawBehaviour -> Err [Claim]
-splitBehaviour store (Transition name contract iface@(Interface _ decls) iffs' cases posts) = do
+splitBehaviour store (Transition pn name contract iface@(Interface _ decls) iffs' cases posts) = -- do
   -- constrain integer calldata variables (TODO: other types)
-  iff <- checkIffs env iffs'
-  postcondition <- mapM (inferExpr env) posts
+  checkIffs env iffs' >>=? \iff ->
+  traverse (inferExpr env) posts >>=? \postcondition ->
   flatten iff postcondition cases
   where
     env :: Env
@@ -110,13 +114,13 @@ splitBehaviour store (Transition name contract iface@(Interface _ decls) iffs' c
       let wildcard (Case _ (WildExp _) _) = True
           wildcard _ = False
       in case findIndex wildcard cases' of
-        Nothing -> return $ snd $ mapAccumL checkCase (BoolLit nowhere False) cases'
+        Nothing -> pure $ snd $ mapAccumL checkCase (BoolLit nowhere False) cases'
         Just ind ->
           -- wildcard must be last element
           if ind < length cases' - 1
           then case cases' !! ind of
-            (Case p _ _) -> Bad (p, "Wildcard pattern must be last case")
-          else return $ snd $ mapAccumL checkCase (BoolLit nowhere False) cases'
+            (Case p _ _) -> throw (p, "Wildcard pattern must be last case")
+          else pure $ snd $ mapAccumL checkCase (BoolLit nowhere False) cases'
 
 
     checkCase :: Expr -> Case -> (Expr, Case)
@@ -128,36 +132,34 @@ splitBehaviour store (Transition name contract iface@(Interface _ decls) iffs' c
 
     -- flatten case list
     flatten :: [Exp Bool Untimed] -> [Exp Bool Timed] -> Cases -> Err [Claim]
-    flatten iff postc (Direct post) = do
-      (p, maybeReturn) <- checkPost env post
-      return $ splitCase name contract iface [] iff maybeReturn p postc
-    flatten iff postc (Branches branches) = do
-      branches' <- normalize branches
-      cases' <- forM branches' $ \(Case _ cond post) -> do
+    flatten iff postc (Direct post) = 
+      (\(p, maybeReturn) -> splitCase name contract iface [] iff maybeReturn p postc) <$> checkPost env post
+    flatten iff postc (Branches branches) = --do
+      normalize branches >>=? \branches' -> do
+      cases' <- for branches' $ \(Case _ cond post) -> do
         if' <- inferExpr env cond
         (post', ret) <- checkPost env post
-        return (if', post', ret)
-      pure $
-        (\(ifcond, stateUpdates, ret)
-            -> splitCase name contract iface [ifcond] iff ret stateUpdates postc)
-           =<< cases'
-
-splitBehaviour store (Definition contract iface@(Interface _ decls) iffs (Creates assigns) extStorage postcs invs) = do
-  unless (null extStorage) $ error "TODO: support extStorage in constructor"
-
-  let env = mkEnv contract store decls
-  stateUpdates <- concat <$> mapM (checkAssign env) assigns
-  iffs' <- checkIffs env iffs
-
-  invariants <- mapM (inferExpr env) invs
-  ensures <- mapM (inferExpr env) postcs
-
-  let cases' = if null iffs' then [C $ Constructor contract Pass iface iffs' ensures stateUpdates []]
-               else [ C $ Constructor contract Pass iface iffs' ensures stateUpdates []
-                       , C $ Constructor contract Fail iface [Neg (mconcat iffs')] ensures [] []]
-
-  return $ (I . Invariant contract [] [] <$> invariants)
-           <> cases'
+        pure (if', post', ret)
+      pure $ concatMap
+              (\(ifcond, stateUpdates, ret)-> splitCase name contract iface [ifcond] iff ret stateUpdates postc)
+              cases'
+
+splitBehaviour store (Definition pn contract iface@(Interface _ decls) iffs (Creates assigns) extStorage postcs invs) =
+  if not . null $ extStorage then error "TODO: support extStorage in constructor"
+  else let env = mkEnv contract store decls
+  in do
+    stateUpdates <- concat <$> traverse (checkAssign env) assigns
+    iffs' <- checkIffs env iffs
+    invariants <- traverse (inferExpr env) invs
+    ensures <- traverse (inferExpr env) postcs
+
+    pure $ invrClaims invariants <> ctorClaims stateUpdates iffs' ensures
+  where
+    invrClaims invariants = I . Invariant contract [] [] <$> invariants
+    ctorClaims updates iffs' ensures
+      | null iffs' = [ C $ Constructor contract Pass iface []                    ensures updates [] ]
+      | otherwise  = [ C $ Constructor contract Pass iface iffs'                 ensures updates []
+                     , C $ Constructor contract Fail iface [Neg (mconcat iffs')] ensures []      [] ]
 
 mkEnv :: Id -> Store -> [Decl]-> Env
 mkEnv contract store decls = Env
@@ -180,61 +182,59 @@ splitCase name contract iface if' iffs ret storage postcs =
 
 -- | Ensures that none of the storage variables are read in the supplied `Expr`.
 noStorageRead :: Map Id SlotType -> Expr -> Err ()
-noStorageRead store expr = forM_ (keys store) $ \name ->
-  forM_ (findWithDefault [] name (idFromRewrites expr)) $ \pn ->
-    Bad (pn,"Cannot read storage in creates block")
+noStorageRead store expr = for_ (keys store) $ \name ->
+  for_ (findWithDefault [] name (idFromRewrites expr)) $ \pn ->
+    throw (pn,"Cannot read storage in creates block")
+
+checkUpdate :: Env -> AbiType -> Id -> [TypedExp Untimed] -> Expr -> Err StorageUpdate
+checkUpdate env@Env{contract} typ name ixs newVal =
+  case metaType typ of
+    Integer -> IntUpdate   (IntItem   contract name ixs) <$> inferExpr env newVal
+    Boolean -> BoolUpdate  (BoolItem  contract name ixs) <$> inferExpr env newVal
+    ByteStr -> BytesUpdate (BytesItem contract name ixs) <$> inferExpr env newVal
 
 -- ensures that key types match value types in an Assign
 checkAssign :: Env -> Assign -> Err [StorageUpdate]
-checkAssign env@Env{contract, store} (AssignVal (StorageVar (StorageValue typ) name) expr) = do
-  noStorageRead store expr
-  case metaType typ of
-    Integer -> return . IntUpdate   (IntItem contract name [])   <$> inferExpr env expr
-    Boolean -> return . BoolUpdate  (BoolItem contract name [])  <$> inferExpr env expr
-    ByteStr -> return . BytesUpdate (BytesItem contract name []) <$> inferExpr env expr
-checkAssign env@Env{store} (AssignMany (StorageVar (StorageMapping (keyType :| _) valType) name) defns)
-  = forM defns $ \def@(Defn e1 e2) -> do
-      mapM_ (noStorageRead store) [e1,e2]
-      checkDefn env keyType valType name def
-checkAssign _ (AssignVal (StorageVar (StorageMapping _ _) _) expr)
-  = Bad (getPosn expr, "Cannot assign a single expression to a composite type")
-checkAssign _ (AssignMany (StorageVar (StorageValue _) _) _)
-  = Bad (nowhere, "Cannot assign multiple values to an atomic type")
+checkAssign env@Env{contract, store} (AssignVal (StorageVar pn (StorageValue typ) name) expr)
+  = sequenceA [checkUpdate env typ name [] expr]
+    <* noStorageRead store expr
+checkAssign env@Env{store} (AssignMany (StorageVar pn (StorageMapping (keyType :| _) valType) name) defns)
+  = for defns $ \def@(Defn e1 e2) -> checkDefn env keyType valType name def
+                                     <* noStorageRead store e1
+                                     <* noStorageRead store e2
+checkAssign _ (AssignVal (StorageVar pn (StorageMapping _ _) _) expr)
+  = throw (getPosn expr, "Cannot assign a single expression to a composite type")
+checkAssign _ (AssignMany (StorageVar pn (StorageValue _) _) _)
+  = throw (pn, "Cannot assign multiple values to an atomic type")
 checkAssign _ _ = error "todo: support struct assignment in constructors"
 
 -- ensures key and value types match when assigning a defn to a mapping
 -- TODO: handle nested mappings
 checkDefn :: Env -> AbiType -> AbiType -> Id -> Defn -> Err StorageUpdate
-checkDefn env@Env{contract} keyType valType name (Defn k v) = do
-  key <- case metaType keyType of
-    Integer -> ExpInt   <$> inferExpr env k
-    Boolean -> ExpBool  <$> inferExpr env k
-    ByteStr -> ExpBytes <$> inferExpr env k
-  case metaType valType of
-    Integer -> IntUpdate   (IntItem   contract name [key]) <$> inferExpr env v
-    Boolean -> BoolUpdate  (BoolItem  contract name [key]) <$> inferExpr env v
-    ByteStr -> BytesUpdate (BytesItem contract name [key]) <$> inferExpr env v
+checkDefn env@Env{contract} keyType valType name (Defn k val) = 
+  sequenceA [checkExpr env k keyType] >>=? \keys ->
+  checkUpdate env valType name keys val -- TODO really make sure to test this!!
 
 checkPost :: Env -> Untyped.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
 checkPost env@Env{contract,calldata} (Untyped.Post maybeStorage extStorage maybeReturn) =
-  do returnexp <- mapM (typedExp scopedEnv) maybeReturn
+  do returnexp <- traverse (typedExp scopedEnv) maybeReturn
      ourStorage <- case maybeStorage of
        Just entries -> checkEntries contract entries
-       Nothing -> Ok []
+       Nothing -> pure []
      otherStorage <- checkStorages extStorage
-     return (ourStorage <> otherStorage, returnexp)
+     pure (ourStorage <> otherStorage, returnexp)
   where
     checkEntries :: Id -> [Untyped.Storage] -> Err [Rewrite]
     checkEntries name entries =
-      forM entries $ \case
+      for entries $ \case
         Untyped.Constant loc -> Constant <$> checkPattern (focus name scopedEnv) loc
         Untyped.Rewrite loc val -> Rewrite <$> checkStorageExpr (focus name scopedEnv) loc val
 
     checkStorages :: [ExtStorage] -> Err [Rewrite]
-    checkStorages [] = Ok []
+    checkStorages [] = pure []
     checkStorages ((ExtStorage name entries):xs) = do p <- checkEntries name entries
                                                       ps <- checkStorages xs
-                                                      Ok $ p <> ps
+                                                      pure $ p <> ps
     checkStorages _ = error "TODO: check other storages"
 
     -- remove storage items from the env that are not mentioned on the LHS of a storage declaration
@@ -271,49 +271,40 @@ checkPost env@Env{contract,calldata} (Untyped.Post maybeStorage extStorage maybe
 
 checkStorageExpr :: Env -> Pattern -> Expr -> Err StorageUpdate
 checkStorageExpr _ (PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
-checkStorageExpr env@Env{contract,store} (PEntry p name ixs) expr = case Map.lookup name store of
-  Just (StorageValue t)  -> makeUpdate t []
-  Just (StorageMapping argtyps t) ->
-    if length argtyps /= length ixs
-      then Bad (p, "Argument mismatch for storageitem: " <> name)
-      else makeUpdate t (NonEmpty.toList argtyps)
-  Nothing -> Bad (p, "Unknown storage variable: " <> show name)
-  where
-    makeUpdate typ argtyps = do
-      indexExprs <- for (ixs `zip` argtyps) (uncurry $ checkExpr env)
-      case metaType typ of
-        Integer -> IntUpdate (IntItem contract name indexExprs) <$> inferExpr env expr
-        Boolean -> BoolUpdate (BoolItem contract name indexExprs) <$> inferExpr env expr
-        ByteStr -> BytesUpdate (BytesItem contract name indexExprs) <$> inferExpr env expr
+checkStorageExpr env@Env{contract,store} (PEntry p name args) expr = case Map.lookup name store of
+  Just (StorageValue typ) -> checkUpdate env typ name [] expr
+  Just (StorageMapping argtyps typ) ->
+    makeIxs env p args (NonEmpty.toList argtyps) >>=? \indexExprs ->
+    checkUpdate env typ name indexExprs expr
+  Nothing -> throw (p, "Unknown storage variable: " <> show name)
 
 checkPattern :: Env -> Pattern -> Err StorageLocation
-checkPattern env@Env{contract,store} (PEntry p name ixs) =
-  case Map.lookup name store of
-    Just (StorageValue t) -> case metaType t of
-          Integer -> Ok . IntLoc   $ IntItem   contract name []
-          Boolean -> Ok . BoolLoc  $ BoolItem  contract name []
-          ByteStr -> Ok . BytesLoc $ BytesItem contract name []
-    Just (StorageMapping argtyps t) ->
-      if length argtyps /= length ixs
-      then Bad (p, "Argument mismatch for storageitem: " <> name)
-      else let indexExprs = for (ixs `zip` NonEmpty.toList argtyps) (uncurry $ checkExpr env)
-           in case metaType t of
-                  Integer -> (IntLoc . IntItem contract name) <$> indexExprs
-                  Boolean -> (BoolLoc . BoolItem contract name) <$> indexExprs
-                  ByteStr -> (BytesLoc . BytesItem contract name) <$> indexExprs
-    Nothing -> Bad (p, "Unknown storage variable: " <> show name)
 checkPattern _ (PWild _) = error "TODO: checkPattern for Wild storage"
+checkPattern env@Env{contract,store} (PEntry p name args) =
+  case Map.lookup name store of
+    Just (StorageValue t) -> makeLocation t []
+    Just (StorageMapping argtyps t) -> makeLocation t (NonEmpty.toList argtyps)
+    Nothing -> throw (p, "Unknown storage variable: " <> show name)
+  where
+    makeLocation :: AbiType -> [AbiType] -> Err StorageLocation
+    makeLocation locType argTypes = do
+      indexExprs <- makeIxs env p args argTypes -- TODO possibly output errormsg with `name`
+      pure $ case metaType locType of
+        Integer -> IntLoc   $ IntItem   contract name indexExprs
+        Boolean -> BoolLoc  $ BoolItem  contract name indexExprs
+        ByteStr -> BytesLoc $ BytesItem contract name indexExprs
+
 
 checkIffs :: Env -> [IffH] -> Err [Exp Bool Untimed]
 checkIffs env ((Iff _ exps):xs) = do
-  hd <- mapM (inferExpr env) exps
+  hd <- traverse (inferExpr env) exps
   tl <- checkIffs env xs
-  Ok $ hd <> tl
+  pure $ hd <> tl
 checkIffs env ((IffIn _ typ exps):xs) = do
-  hd <- mapM (inferExpr env) exps
+  hd <- traverse (inferExpr env) exps
   tl <- checkIffs env xs
-  Ok $ map (bound typ) hd <> tl
-checkIffs _ [] = Ok []
+  pure $ map (bound typ) hd <> tl
+checkIffs _ [] = pure []
 
 bound :: AbiType -> Exp Integer t -> Exp Bool t
 bound typ e = And (LEQ (lowerBound typ) e) $ LEQ e (upperBound typ)
@@ -342,9 +333,9 @@ checkExpr env e typ = case metaType typ of
 -- | Attempt to typecheck an untyped expression as any possible type.
 typedExp :: Typeable t => Env -> Expr -> Err (TypedExp t)
 typedExp env e = ExpInt   <$> inferExpr env e
-             <|> ExpBool  <$> inferExpr env e
-             <|> ExpBytes <$> inferExpr env e
-             <|> Bad (getPosn e, "TypedExp: no suitable type") -- TODO improve error handling once we've merged the unified stuff!
+             <!> ExpBool  <$> inferExpr env e
+             <!> ExpBytes <$> inferExpr env e
+             <!> throw (getPosn e, "TypedExp: no suitable type") -- TODO improve error handling once we've merged the unified stuff!
 
 -- | Attempts to construct an expression with the type and timing required by
 -- the caller. If this is impossible, an error is thrown instead.
@@ -369,13 +360,13 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
   IntLit  p v1    -> check p . pure $ LitInt v1
   BoolLit p v1    -> check p . pure $ LitBool v1
   EITE    _ v1 v2 v3 -> ITE <$> inferExpr env v1 <*> inferExpr env v2 <*> inferExpr env v3
-  EUTEntry   p name es -> entry p Neither name es
-  EPreEntry  p name es -> entry p Pre     name es
-  EPostEntry p name es -> entry p Post    name es
+  EUTEntry   p name es -> checkTime p $ entry p Neither name es
+  EPreEntry  p name es -> checkTime p $ entry p Pre     name es
+  EPostEntry p name es -> checkTime p $ entry p Post    name es
   EnvExp p v1 -> case lookup v1 defaultStore of
     Just Integer -> check p . pure $ IntEnv v1
     Just ByteStr -> check p . pure $ ByEnv  v1
-    _            -> Bad (p, "unknown environment variable: " <> show v1)
+    _            -> throw (p, "unknown environment variable: " <> show v1)
   v -> error $ "internal error: infer type of:" <> show v
   -- Wild ->
   -- Zoom Var Exp
@@ -391,26 +382,31 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
   where
     -- Try to cast the type parameter of an expression to the goal of `inferExpr`.
     -- The cast only succeeds if they already are the same.
-    check :: forall x. Typeable x => Pn -> Err (Exp x t) -> Err (Exp a t)
-    check pn e =
-      errMessage (pn,"Type mismatch. Expected " <> show (typeRep @a) <> ", got " <> show (typeRep @x) <> ".")
-        =<< castType <$> e
+    check :: forall x t0. Typeable x => Pn -> Err (Exp x t0) -> Err (Exp a t0)
+    check pn = ensure
+                [(pn,"Type mismatch. Expected " <> show (typeRep @a) <> ", got " <> show (typeRep @x) <> ".")]
+                castType
+              
+    checkTime :: forall x t0. Typeable t0 => Pn -> Err (Exp x t0) -> Err (Exp x t)
+    checkTime pn = ensure
+                    [(pn, (tail . show $ typeRep @t) <> " variable needed here!")]
+                    castTime
 
     -- Takes a polymorphic binary AST constructor and specializes it to each of
     -- our types. Those specializations are used in order to guide the
     -- typechecking of the two supplied expressions. Returns at first success.
     polycheck :: Typeable x => Pn -> (forall y. (Eq y, Typeable y) => Exp y t -> Exp y t -> Exp x t) -> Expr -> Expr -> Err (Exp a t)
     polycheck pn cons e1 e2 = check pn (cons @Integer    <$> inferExpr env e1 <*> inferExpr env e2)
-                          <|> check pn (cons @Bool       <$> inferExpr env e1 <*> inferExpr env e2)
-                          <|> check pn (cons @ByteString <$> inferExpr env e1 <*> inferExpr env e2)
-                          <|> Bad (pn, "Couldn't harmonize types!") -- TODO improve error handling once we've merged the unified stuff!
+                          <!> check pn (cons @Bool       <$> inferExpr env e1 <*> inferExpr env e2)
+                          <!> check pn (cons @ByteString <$> inferExpr env e1 <*> inferExpr env e2)
+                          <!> throw (pn, "Couldn't harmonize types!") -- TODO improve error handling once we've merged the unified stuff!
 
     -- Try to construct a reference to a calldata variable or an item in storage.
-    entry :: Typeable t0 => Pn -> Time t0 -> Id -> [Expr] -> Err (Exp a t)
+    entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [Expr] -> Err (Exp a t0)
     entry pn timing name es = case (Map.lookup name store, Map.lookup name calldata) of
-      (Nothing, Nothing) -> Bad (pn, "Unknown variable: " <> name)
-      (Just _, Just _)   -> Bad (pn, "Ambiguous variable: " <> name)
-      (Nothing, Just c) -> if isTimed timing then Bad (pn, "Calldata var cannot be pre/post.") else case c of
+      (Nothing, Nothing) -> throw (pn, "Unknown variable: " <> name)
+      (Just _, Just _)   -> throw (pn, "Ambiguous variable: " <> name)
+      (Nothing, Just c) -> if isTimed timing then throw (pn, "Calldata var cannot be pre/post.") else case c of
         -- Create a calldata reference and typecheck it as with normal expressions.
         Integer -> check pn . pure $ IntVar  name
         Boolean -> check pn . pure $ BoolVar name
@@ -418,21 +414,23 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
       (Just (StorageValue a), Nothing)      -> makeEntry a []
       (Just (StorageMapping ts a), Nothing) -> makeEntry a $ NonEmpty.toList ts
       where
-        makeEntry :: AbiType -> [AbiType] -> Err (Exp a t)
+        makeEntry :: AbiType -> [AbiType] -> Err (Exp a t0)
         makeEntry a ts = case metaType a of
-          Integer -> makeItem IntItem
-          Boolean -> makeItem BoolItem
-          ByteStr -> makeItem BytesItem
+          Integer -> check pn $ makeItem IntItem
+          Boolean -> check pn $ makeItem BoolItem
+          ByteStr -> check pn $ makeItem BytesItem
           where
             -- Given that the indices used in the expression agree with the storage,
             -- create a `TStorageItem` using the supplied constructor, place it
             -- in a `TEntry` and then attempt to cast its timing parameter to the
             -- target timing of `inferExpr`. Finally, `check` the type parameter as
             -- with all other expressions.
-            makeItem :: Typeable x => (forall t0. Id -> Id -> [TypedExp t0] -> TStorageItem x t0) -> Err (Exp a t)
-            makeItem maker = do
-              when (length ts /= length es) $ Bad (pn, "Index mismatch for entry!")
-              ixs <- for (es `zip` ts) (uncurry $ checkExpr env)
-              check pn
-                $ errMessage (pn, (tail . show $ typeRep @t) <> " variable needed here!")
-                $ castTime (TEntry (maker contract name ixs) timing)
+            makeItem :: Typeable x => (Id -> Id -> [TypedExp t0] -> TStorageItem x t0) -> Err (Exp x t0)
+            makeItem cons = do
+              ixs <- makeIxs env pn es ts
+              pure $ TEntry (cons contract name ixs) timing
+
+makeIxs :: Typeable t => Env -> Pn -> [Expr] -> [AbiType] -> Err [TypedExp t]
+makeIxs env pn exprs types = if length exprs /= length types
+                              then throw (pn, "Index mismatch for entry!")
+                              else traverse (uncurry $ checkExpr env) (exprs `zip` types)
diff --git a/src/act.cabal b/src/act.cabal
index 55f2df2a..d804a50a 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -14,7 +14,7 @@ common deps
   build-depends: base             >= 4.9 && < 5,
                  aeson            >= 1.0,
                  containers       >= 0.5,
-                 hevm             >= 0.47.1,
+                 hevm             >= 0.47.1 && < 0.48,
                  lens             >= 4.17.1,
                  text             >= 1.2,
                  array            >= 0.5.3.0,
@@ -26,8 +26,9 @@ common deps
                  utf8-string      >= 1.0.1.1,
                  process          >= 1.6.5.0,
                  ansi-wl-pprint   >= 0.6.9,
-                 regex-tdfa
-  other-modules: Lex ErrM Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
+                 regex-tdfa,
+                 validation       >= 1.1.1
+  other-modules: Lex ErrM ErrorLogger Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
   
   if flag(ci)
       ghc-options: -O2 -Wall -Werror -Wno-orphans -Wno-unticked-promoted-constructors
diff --git a/tests/frontend/fail/emptystorage/circular.act b/tests/frontend/fail/emptystorage/circular.act
index dc1ff15f..6da0a05b 100644
--- a/tests/frontend/fail/emptystorage/circular.act
+++ b/tests/frontend/fail/emptystorage/circular.act
@@ -5,3 +5,4 @@ creates
 
     uint x := y
     uint y := x
+    uint z := x
diff --git a/tests/frontend/fail/multipledef/threedefs.act b/tests/frontend/fail/multipledef/threedefs.act
new file mode 100644
index 00000000..d44ab329
--- /dev/null
+++ b/tests/frontend/fail/multipledef/threedefs.act
@@ -0,0 +1,8 @@
+constructor of LValue
+interface constructor()
+
+creates
+
+  uint x := 2
+  bool x := false
+  uint x := 3

From 18d78b0e5a709ace3a4aadcf1b6736de99b44854 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Thu, 2 Sep 2021 11:15:11 +0200
Subject: [PATCH 03/36] add `semigroupoids` build dependency

---
 src/act.cabal | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/act.cabal b/src/act.cabal
index d804a50a..7e0049aa 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -27,7 +27,8 @@ common deps
                  process          >= 1.6.5.0,
                  ansi-wl-pprint   >= 0.6.9,
                  regex-tdfa,
-                 validation       >= 1.1.1
+                 validation       >= 1.1.1,
+                 semigroupoids    >= 5.2.2
   other-modules: Lex ErrM ErrorLogger Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
   
   if flag(ci)

From 68217e6e1eb96c6c0e703d472c893416d149cf6d Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Thu, 9 Sep 2021 23:02:50 +0200
Subject: [PATCH 04/36] =?UTF-8?q?singleton=20types=20work;=20lets=20us=20r?=
 =?UTF-8?q?emove=20several=20ugly=20`(>>=3D=3F)`?=

---
 src/ErrorLogger.hs         |  21 ++++---
 src/Syntax.hs              |   9 ++-
 src/Syntax/TimeAgnostic.hs |  49 ++++++++++++++-
 src/Type.hs                | 119 ++++++++++++++++++++-----------------
 src/act.cabal              |   4 +-
 5 files changed, 133 insertions(+), 69 deletions(-)

diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs
index 49831259..8231f84c 100644
--- a/src/ErrorLogger.hs
+++ b/src/ErrorLogger.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedLists,TypeOperators, FlexibleInstances, ApplicativeDo, MultiParamTypeClasses, ScopedTypeVariables, InstanceSigs #-}
 
 module ErrorLogger (module ErrorLogger) where
 
@@ -7,13 +7,16 @@ import Control.Monad.Writer
 import Data.Functor
 import Data.List.NonEmpty
 import Data.Validation as ErrorLogger
+import GHC.Generics
 
 import Syntax.Untyped (Pn)
 
-type Error e a = Validation (NonEmpty (Pn,e)) a
+type Error e = Validation (NonEmpty (Pn,e))
+
+type Logger e = Writer [(Pn,e)]
 
 throw :: (Pn,e) -> Error e a
-throw err = _Failure # [err]
+throw msg = _Failure # [msg]
 
 bindDummy :: (Monoid a, Semigroup e) => Validation e a -> (a -> Validation e b) -> Validation e b
 bindDummy val cont = validation (\e -> cont mempty <* Failure e) cont val
@@ -21,7 +24,11 @@ bindDummy val cont = validation (\e -> cont mempty <* Failure e) cont val
 (>>=?) :: (Monoid a, Semigroup e) => Validation e a -> (a -> Validation e b) -> Validation e b
 (>>=?) = bindDummy
 
-liftWriter :: Writer [(Pn,e)] a -> Error e a
-liftWriter writer = case runWriter writer of
-  (res, []) -> pure res
-  (_,   es) -> _Failure # fromList es
+logErrs :: Logger e a -> (a -> Error e b) -> Error e b
+logErrs writer cont = case runWriter writer of
+  (res, []  ) -> cont res
+  (res, errs) -> cont res <* traverse throw errs
+
+log' :: (Pn,e) -> Logger e ()
+log' msg = tell [msg]
+
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 42b2a5a7..82a1c22e 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -109,7 +109,7 @@ locsFromExp = nub . go
       IntEnv _ -> []
       ByEnv _ -> []
       ITE x y z -> go x <> go y <> go z
-      TEntry a _ -> locsFromItem a
+      TEntry _ a -> locsFromItem a
 
 ethEnvFromBehaviour :: Behaviour t -> [EthEnv]
 ethEnvFromBehaviour (Behaviour _ _ _ _ preconds postconds rewrites returns) = nub $
@@ -180,7 +180,7 @@ ethEnvFromExp = nub . go
       NewAddr a b -> go a <> go b
       IntEnv a -> [a]
       ByEnv a -> [a]
-      TEntry a _ -> ethEnvFromItem a
+      TEntry _ a -> ethEnvFromItem a
 
 metaType :: AbiType -> MType
 metaType (AbiUIntType _)     = Integer
@@ -359,3 +359,8 @@ idFromRewrites e = case e of
   BoolLit {}        -> empty
   where
     idFromRewrites' = unionsWith (<>) . fmap idFromRewrites
+
+-- | True iff the case is a wildcard.
+wildcard :: Case -> Bool
+wildcard (Case _ (WildExp _) _) = True
+wildcard _                      = False
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 0fc2d808..d051f70f 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -12,6 +12,9 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
 
+
+{-# LANGUAGE RankNTypes, StandaloneKindSignatures #-}
+
 {-|
 Module      : Syntax.TimeAgnostic
 Description : AST data types where implicit timings may or may not have been made explicit.
@@ -42,11 +45,51 @@ import Data.Typeable
 import Data.Vector (fromList)
 
 import EVM.Solidity (SlotType(..))
+import EVM.ABI (AbiType(..))
 
 -- Reexports
 import Syntax.Timing  as Syntax.TimeAgnostic
 import Syntax.Untyped as Syntax.TimeAgnostic (Id, Interface(..), EthEnv(..), Decl(..))
 
+
+import Data.Singletons
+
+data SType :: * -> * where
+  SInteger :: SType Integer
+  SBoolean :: SType Bool
+  SByteStr :: SType ByteString
+
+type instance Sing = SType
+
+instance SingI Integer where sing = SInteger
+instance SingI Bool where sing = SBoolean
+instance SingI ByteString where sing = SByteStr
+
+instance SingKind * where
+  type Demote * = MType
+
+  fromSing SInteger = Integer
+  fromSing SBoolean = Boolean
+  fromSing SByteStr = ByteStr
+
+  toSing Integer = SomeSing SInteger
+  toSing Boolean = SomeSing SBoolean
+  toSing ByteStr = SomeSing SByteStr
+
+
+class TypeableSing k where
+  isTypeableSing :: Sing (a :: k) -> (Typeable a => r) -> r
+
+instance TypeableSing * where
+  isTypeableSing SInteger r = r
+  isTypeableSing SBoolean r = r
+  isTypeableSing SByteStr r = r
+
+withSomeType :: forall k r. (SingKind k, TypeableSing k)
+                     => Demote k -> (forall (a :: k). Typeable a => Sing a -> r) -> r
+withSomeType x f = withSomeSing x $ \s -> isTypeableSing s (f s)
+
+
 -- AST post typechecking
 data Claim t
   = C (Constructor t)
@@ -217,7 +260,7 @@ data Exp (a :: *) (t :: Timing) where
   Eq  :: (Eq a, Typeable a) => Exp a t -> Exp a t -> Exp Bool t
   NEq :: (Eq a, Typeable a) => Exp a t -> Exp a t -> Exp Bool t
   ITE :: Exp Bool t -> Exp a t -> Exp a t -> Exp a t
-  TEntry :: TStorageItem a t -> Time t -> Exp a t
+  TEntry :: Time t -> TStorageItem a t -> Exp a t
 deriving instance Show (Exp a t)
 
 instance Eq (Exp a t) where
@@ -327,7 +370,7 @@ instance Timable (Exp a) where
     Eq  x y -> Eq  (go x) (go y)
     NEq x y -> NEq (go x) (go y)
     ITE x y z -> ITE (go x) (go y) (go z)
-    TEntry item _ -> TEntry (go item) time
+    TEntry _ item -> TEntry time (go item)
     where
       go :: Timable c => c Untimed -> c Timed
       go = setTime time
@@ -441,7 +484,7 @@ instance Typeable a => ToJSON (Exp a t) where
   toJSON (UIntMin a) = toJSON $ show $ uintmin a
   toJSON (UIntMax a) = toJSON $ show $ uintmax a
   toJSON (IntEnv a) = String $ pack $ show a
-  toJSON (TEntry a t) = object [ pack (show t) .= toJSON a ]
+  toJSON (TEntry t a) = object [ pack (show t) .= toJSON a ]
   toJSON (ITE a b c) = object [  "symbol"   .= pack "ite"
                               ,  "arity"    .= Data.Aeson.Types.Number 3
                               ,  "args"     .= Array (fromList [toJSON a, toJSON b, toJSON c])]
diff --git a/src/Type.hs b/src/Type.hs
index f7394f19..1994058b 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -25,11 +25,14 @@ import Data.ByteString (ByteString)
 import Control.Applicative
 import Control.Monad (join,unless)
 import Control.Monad.Writer
+import Data.List.Extra (unsnoc)
 import Data.Functor
 import Data.Functor.Alt
 import Data.Foldable
 import Data.Traversable
 
+import Data.Singletons
+
 import Syntax
 import Syntax.Timing
 import Syntax.Untyped hiding (Post,Constant,Rewrite)
@@ -43,14 +46,17 @@ type Err a = Error TypeErr a
 type TypeErr = String
 
 typecheck :: [RawBehaviour] -> Err [Claim]
-typecheck behvs = do
-  let (store,errs) = runWriter $ lookupVars behvs
-  traverse throw errs
+typecheck behvs = logErrs (lookupVars behvs) $ \store -> do
   bs <- traverse (splitBehaviour store) behvs
   pure $ S store : concat bs
 
+--typecheck' :: [RawBehaviour] -> ErrorLogger TypeErr [Claim]
+--typecheck' behvs = logErrs (lookupVars behvs) $ \store -> do
+--  bs <- traverse (splitBehaviour store) behvs
+--  pure $ S store : concat bs
+
 --- Finds storage declarations from constructors
-lookupVars :: [RawBehaviour] -> Writer [(Pn,TypeErr)] Store
+lookupVars :: [RawBehaviour] -> Logger TypeErr Store
 lookupVars ((Transition {}):bs) = lookupVars bs
 lookupVars ((Definition pn contract _ _ (Creates assigns) _ _ _):bs) = do
   let assignments = Map.fromListWith (<>) $ fromAssign <$> assigns
@@ -58,10 +64,10 @@ lookupVars ((Definition pn contract _ _ (Creates assigns) _ _ _):bs) = do
   allVars <- lookupVars bs
   newVars <- flip Map.traverseWithKey assignments $ \var ((p,typ) :| rest) -> pure typ
                       <* for rest (\(pn,_) ->
-                            tell [(pn, var <> " already defined at " <> showposn p <> ".")])
+                            log' (pn, var <> " already defined at " <> showposn p <> "."))
 
   if contract `Map.member` allVars
-    then allVars <$ tell [(pn, "Conflicting definitions for " <> contract <> ".")]
+    then allVars <$ log' (pn, "Conflicting definitions for " <> contract <> ".")
     else pure $ Map.insert contract newVars allVars
 lookupVars [] = pure mempty
 
@@ -99,7 +105,7 @@ defaultStore =
 
 -- checks a transition given a typing of its storage variables
 splitBehaviour :: Store -> RawBehaviour -> Err [Claim]
-splitBehaviour store (Transition pn name contract iface@(Interface _ decls) iffs' cases posts) = -- do
+splitBehaviour store (Transition pn name contract iface@(Interface _ decls) iffs' cases posts) = do
   -- constrain integer calldata variables (TODO: other types)
   checkIffs env iffs' >>=? \iff ->
   traverse (inferExpr env) posts >>=? \postcondition ->
@@ -109,40 +115,29 @@ splitBehaviour store (Transition pn name contract iface@(Interface _ decls) iffs
     env = mkEnv contract store decls
 
     -- translate wildcards into negation of other cases
-    normalize :: [Case] -> Err [Case]
+    normalize :: [Case] -> Logger TypeErr [Case]
+    normalize []     = pure []
     normalize cases' =
-      let wildcard (Case _ (WildExp _) _) = True
-          wildcard _ = False
-      in case findIndex wildcard cases' of
-        Nothing -> pure $ snd $ mapAccumL checkCase (BoolLit nowhere False) cases'
-        Just ind ->
-          -- wildcard must be last element
-          if ind < length cases' - 1
-          then case cases' !! ind of
-            (Case p _ _) -> throw (p, "Wildcard pattern must be last case")
-          else pure $ snd $ mapAccumL checkCase (BoolLit nowhere False) cases'
-
+      let 
+        Just (rest, Case p _ post) = unsnoc cases'
+        (wilds,nowilds) = partition wildcard rest
+        normalized = flip (Case p) post $ foldl (\acc (Case nowhere e _) -> EOr nowhere e acc) (BoolLit nowhere False) nowilds
+      in
+        normalized:rest <$ unless (null wilds) (log' (p, "Wildcard pattern must be last case"))
 
-    checkCase :: Expr -> Case -> (Expr, Case)
-    checkCase acc (Case p (WildExp _) post) =
-      (error "wildcard not last case",
-        Case p (ENot nowhere acc) post)
-    checkCase acc (Case p e post) = (EOr nowhere e acc, Case p e post)
+--    checkCase :: Expr -> Case -> (Expr, Case)
+--    checkCase acc c@(Case p e post) | wildcard c = (acc, Case p (ENot nowhere acc) post)
+--                                    | otherwise  = (EOr nowhere e acc, Case p e post)
 
 
     -- flatten case list
     flatten :: [Exp Bool Untimed] -> [Exp Bool Timed] -> Cases -> Err [Claim]
-    flatten iff postc (Direct post) = 
-      (\(p, maybeReturn) -> splitCase name contract iface [] iff maybeReturn p postc) <$> checkPost env post
-    flatten iff postc (Branches branches) = --do
-      normalize branches >>=? \branches' -> do
-      cases' <- for branches' $ \(Case _ cond post) -> do
+    flatten iff postc (Direct post)       = uncurry (splitCase name contract iface [] iff postc) <$> checkPost env post
+    flatten iff postc (Branches branches) = logErrs (normalize branches) $ \branches' ->
+      fmap concat . for branches' $ \(Case _ cond post) -> do
         if' <- inferExpr env cond
-        (post', ret) <- checkPost env post
-        pure (if', post', ret)
-      pure $ concatMap
-              (\(ifcond, stateUpdates, ret)-> splitCase name contract iface [ifcond] iff ret stateUpdates postc)
-              cases'
+        (updates, ret) <- checkPost env post
+        pure $ splitCase name contract iface [if'] iff postc updates ret
 
 splitBehaviour store (Definition pn contract iface@(Interface _ decls) iffs (Creates assigns) extStorage postcs invs) =
   if not . null $ extStorage then error "TODO: support extStorage in constructor"
@@ -172,11 +167,11 @@ mkEnv contract store decls = Env
    abiVars = Map.fromList $ map (\(Decl typ var) -> (var, metaType typ)) decls
 
 -- | split case into pass and fail case
-splitCase :: Id -> Id -> Interface -> [Exp Bool Untimed] -> [Exp Bool Untimed] -> Maybe (TypedExp Timed)
-          -> [Rewrite] -> [Exp Bool Timed] -> [Claim]
-splitCase name contract iface if' [] ret storage postcs =
+splitCase :: Id -> Id -> Interface -> [Exp Bool Untimed] -> [Exp Bool Untimed] -> [Exp Bool Timed]
+          -> [Rewrite] -> Maybe (TypedExp Timed) -> [Claim]
+splitCase name contract iface if' [] postcs storage ret =
   [ B $ Behaviour name Pass contract iface if' postcs storage ret ]
-splitCase name contract iface if' iffs ret storage postcs =
+splitCase name contract iface if' iffs postcs storage ret =
   [ B $ Behaviour name Pass contract iface (if' <> iffs) postcs storage ret,
     B $ Behaviour name Fail contract iface (if' <> [Neg (mconcat iffs)]) [] (Constant . locFromRewrite <$> storage) Nothing ]
 
@@ -186,18 +181,29 @@ noStorageRead store expr = for_ (keys store) $ \name ->
   for_ (findWithDefault [] name (idFromRewrites expr)) $ \pn ->
     throw (pn,"Cannot read storage in creates block")
 
-checkUpdate :: Env -> AbiType -> Id -> [TypedExp Untimed] -> Expr -> Err StorageUpdate
-checkUpdate env@Env{contract} typ name ixs newVal =
-  case metaType typ of
-    Integer -> IntUpdate   (IntItem   contract name ixs) <$> inferExpr env newVal
-    Boolean -> BoolUpdate  (BoolItem  contract name ixs) <$> inferExpr env newVal
-    ByteStr -> BytesUpdate (BytesItem contract name ixs) <$> inferExpr env newVal
+--makeItemWith :: (Typeable a, Typeable t) => Env -> (TStorageItem a t -> a) -> AbiType -> Id -> [TypedExp t] ->
+makeItemWith env@Env{contract} pn name cons itemcons (args,types) new = cons . itemcons <$> makeIxs
+
+-- checkUpdate :: Env -> AbiType -> Id -> [TypedExp Untimed] -> Expr -> Err StorageUpdate
+-- checkUpdate env@Env{contract} typ name ixs newVal =
+--   case metaType typ of
+--     Integer -> IntUpdate   (IntItem   contract name ixs) <$> inferExpr env newVal
+--     Boolean -> BoolUpdate  (BoolItem  contract name ixs) <$> inferExpr env newVal
+--     ByteStr -> BytesUpdate (BytesItem contract name ixs) <$> inferExpr env newVal
+
+makeUpdate :: Env -> Sing a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
+makeUpdate env@Env{contract} typ name ixs newVal =
+  case typ of
+    SInteger -> IntUpdate   (IntItem   contract name ixs) newVal
+    SBoolean -> BoolUpdate  (BoolItem  contract name ixs) newVal
+    SByteStr -> BytesUpdate (BytesItem contract name ixs) newVal
 
 -- ensures that key types match value types in an Assign
 checkAssign :: Env -> Assign -> Err [StorageUpdate]
 checkAssign env@Env{contract, store} (AssignVal (StorageVar pn (StorageValue typ) name) expr)
-  = sequenceA [checkUpdate env typ name [] expr]
-    <* noStorageRead store expr
+  = withSomeType (metaType typ) $ \stype ->
+      sequenceA [makeUpdate env stype name [] <$> inferExpr env expr]
+      <* noStorageRead store expr
 checkAssign env@Env{store} (AssignMany (StorageVar pn (StorageMapping (keyType :| _) valType) name) defns)
   = for defns $ \def@(Defn e1 e2) -> checkDefn env keyType valType name def
                                      <* noStorageRead store e1
@@ -211,9 +217,8 @@ checkAssign _ _ = error "todo: support struct assignment in constructors"
 -- ensures key and value types match when assigning a defn to a mapping
 -- TODO: handle nested mappings
 checkDefn :: Env -> AbiType -> AbiType -> Id -> Defn -> Err StorageUpdate
-checkDefn env@Env{contract} keyType valType name (Defn k val) = 
-  sequenceA [checkExpr env k keyType] >>=? \keys ->
-  checkUpdate env valType name keys val -- TODO really make sure to test this!!
+checkDefn env@Env{contract} keyType valType name (Defn k val) = withSomeType (metaType valType) $ \valType' ->
+  makeUpdate env valType' name <$> sequenceA [checkExpr env k keyType] <*> inferExpr env val
 
 checkPost :: Env -> Untyped.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
 checkPost env@Env{contract,calldata} (Untyped.Post maybeStorage extStorage maybeReturn) =
@@ -272,10 +277,10 @@ checkPost env@Env{contract,calldata} (Untyped.Post maybeStorage extStorage maybe
 checkStorageExpr :: Env -> Pattern -> Expr -> Err StorageUpdate
 checkStorageExpr _ (PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
 checkStorageExpr env@Env{contract,store} (PEntry p name args) expr = case Map.lookup name store of
-  Just (StorageValue typ) -> checkUpdate env typ name [] expr
-  Just (StorageMapping argtyps typ) ->
-    makeIxs env p args (NonEmpty.toList argtyps) >>=? \indexExprs ->
-    checkUpdate env typ name indexExprs expr
+  Just (StorageValue typ) -> withSomeType (metaType typ) $ \stype ->
+    makeUpdate env stype name [] <$> inferExpr env expr
+  Just (StorageMapping argtyps typ) -> withSomeType (metaType typ) $ \stype ->
+    makeUpdate env stype name <$> makeIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env expr
   Nothing -> throw (p, "Unknown storage variable: " <> show name)
 
 checkPattern :: Env -> Pattern -> Err StorageLocation
@@ -426,11 +431,13 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
             -- target timing of `inferExpr`. Finally, `check` the type parameter as
             -- with all other expressions.
             makeItem :: Typeable x => (Id -> Id -> [TypedExp t0] -> TStorageItem x t0) -> Err (Exp x t0)
-            makeItem cons = do
-              ixs <- makeIxs env pn es ts
-              pure $ TEntry (cons contract name ixs) timing
+            makeItem cons = TEntry timing . cons contract name <$> makeIxs env pn es ts
 
 makeIxs :: Typeable t => Env -> Pn -> [Expr] -> [AbiType] -> Err [TypedExp t]
 makeIxs env pn exprs types = if length exprs /= length types
                               then throw (pn, "Index mismatch for entry!")
                               else traverse (uncurry $ checkExpr env) (exprs `zip` types)
+
+-- makeIxs' :: Typeable t => Env -> Pn -> [Expr] -> [AbiType] -> Logger TypeErr [TypedExp t]
+-- makeIxs' env pn exprs types = traverse (uncurry $ checkExpr env) (exprs `zip` types)
+--                           <* when (length exprs /= length types) (log' (pn, "Index mismatch for entry!"))
diff --git a/src/act.cabal b/src/act.cabal
index 7e0049aa..f13bd24a 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -28,7 +28,9 @@ common deps
                  ansi-wl-pprint   >= 0.6.9,
                  regex-tdfa,
                  validation       >= 1.1.1,
-                 semigroupoids    >= 5.2.2
+                 semigroupoids    >= 5.2.2,
+                 extra,
+                 singletons
   other-modules: Lex ErrM ErrorLogger Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
   
   if flag(ci)

From 9e3930e5cfa954528a98b6c2bddbe2ddbd090871 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Thu, 9 Sep 2021 23:04:56 +0200
Subject: [PATCH 05/36] remove bad `do`

---
 src/Type.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Type.hs b/src/Type.hs
index 1994058b..22421cff 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -105,7 +105,7 @@ defaultStore =
 
 -- checks a transition given a typing of its storage variables
 splitBehaviour :: Store -> RawBehaviour -> Err [Claim]
-splitBehaviour store (Transition pn name contract iface@(Interface _ decls) iffs' cases posts) = do
+splitBehaviour store (Transition pn name contract iface@(Interface _ decls) iffs' cases posts) =
   -- constrain integer calldata variables (TODO: other types)
   checkIffs env iffs' >>=? \iff ->
   traverse (inferExpr env) posts >>=? \postcondition ->

From 2a6a5506d1e92ad79cffd5ae10669aaec3a8be79 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 13 Sep 2021 06:08:26 +0200
Subject: [PATCH 06/36] completely `Applicative` style in `Type.hs`

---
 src/ErrorLogger.hs         |  17 --
 src/Parse.y                |   8 +-
 src/Syntax.hs              |   6 +-
 src/Syntax/TimeAgnostic.hs |   7 +-
 src/Syntax/Untyped.hs      |   2 +-
 src/Type.hs                | 434 +++++++++++++++++++------------------
 6 files changed, 230 insertions(+), 244 deletions(-)

diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs
index 8231f84c..372ae2e9 100644
--- a/src/ErrorLogger.hs
+++ b/src/ErrorLogger.hs
@@ -13,22 +13,5 @@ import Syntax.Untyped (Pn)
 
 type Error e = Validation (NonEmpty (Pn,e))
 
-type Logger e = Writer [(Pn,e)]
-
 throw :: (Pn,e) -> Error e a
 throw msg = _Failure # [msg]
-
-bindDummy :: (Monoid a, Semigroup e) => Validation e a -> (a -> Validation e b) -> Validation e b
-bindDummy val cont = validation (\e -> cont mempty <* Failure e) cont val
-
-(>>=?) :: (Monoid a, Semigroup e) => Validation e a -> (a -> Validation e b) -> Validation e b
-(>>=?) = bindDummy
-
-logErrs :: Logger e a -> (a -> Error e b) -> Error e b
-logErrs writer cont = case runWriter writer of
-  (res, []  ) -> cont res
-  (res, errs) -> cont res <* traverse throw errs
-
-log' :: (Pn,e) -> Logger e ()
-log' msg = tell [msg]
-
diff --git a/src/Parse.y b/src/Parse.y
index a5f388a3..435c4a9a 100644
--- a/src/Parse.y
+++ b/src/Parse.y
@@ -188,10 +188,10 @@ Cases : Post                                          { Direct $1 }
 Case : 'case' Expr ':' Post                           { Case (posn $1) $2 $4 }
 
 
-Post  : Storage list(ExtStorage)                      { Post (Just $1) $2 Nothing }
-      | list(ExtStorage) Returns                      { Post Nothing $1 (Just $2) }
-      | nonempty(ExtStorage)                          { Post Nothing $1 Nothing }
-      | Storage list(ExtStorage) Returns              { Post (Just $1) $2 (Just $3) }
+Post  : Storage list(ExtStorage)                      { Post $1 $2 Nothing }
+      | list(ExtStorage) Returns                      { Post [] $1 (Just $2) }
+      | nonempty(ExtStorage)                          { Post [] $1 Nothing }
+      | Storage list(ExtStorage) Returns              { Post $1 $2 (Just $3) }
 
 Returns : 'returns' Expr                              { $2 }
 
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 82a1c22e..67f86954 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -361,6 +361,6 @@ idFromRewrites e = case e of
     idFromRewrites' = unionsWith (<>) . fmap idFromRewrites
 
 -- | True iff the case is a wildcard.
-wildcard :: Case -> Bool
-wildcard (Case _ (WildExp _) _) = True
-wildcard _                      = False
+isWild :: Case -> Bool
+isWild (Case _ (WildExp _) _) = True
+isWild _                      = False
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index d051f70f..44afcf1b 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -54,10 +54,12 @@ import Syntax.Untyped as Syntax.TimeAgnostic (Id, Interface(..), EthEnv(..), Dec
 
 import Data.Singletons
 
-data SType :: * -> * where
+data SType a where
   SInteger :: SType Integer
   SBoolean :: SType Bool
   SByteStr :: SType ByteString
+deriving instance Show (SType a)
+deriving instance Eq (SType a)
 
 type instance Sing = SType
 
@@ -86,10 +88,9 @@ instance TypeableSing * where
   isTypeableSing SByteStr r = r
 
 withSomeType :: forall k r. (SingKind k, TypeableSing k)
-                     => Demote k -> (forall (a :: k). Typeable a => Sing a -> r) -> r
+             => Demote k -> (forall (a :: k). Typeable a => Sing a -> r) -> r
 withSomeType x f = withSomeSing x $ \s -> isTypeableSing s (f s)
 
-
 -- AST post typechecking
 data Claim t
   = C (Constructor t)
diff --git a/src/Syntax/Untyped.hs b/src/Syntax/Untyped.hs
index 508e6446..6749a558 100644
--- a/src/Syntax/Untyped.hs
+++ b/src/Syntax/Untyped.hs
@@ -45,7 +45,7 @@ data Case = Case Pn Expr Post
   deriving (Eq, Show)
 
 data Post
-  = Post (Maybe [Storage]) [ExtStorage] (Maybe Expr)
+  = Post [Storage] [ExtStorage] (Maybe Expr)
   deriving (Eq, Show)
 
 newtype Creates = Creates [Assign]
diff --git a/src/Type.hs b/src/Type.hs
index 22421cff..35ab6022 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -5,7 +5,7 @@
 {-# Language ScopedTypeVariables #-}
 {-# Language NamedFieldPuns #-}
 {-# Language DataKinds #-}
-{-# LANGUAGE ApplicativeDo, OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo, OverloadedLists, PatternSynonyms, ViewPatterns #-}
 
 module Type (typecheck, bound, lookupVars, defaultStore, metaType, Err) where
 
@@ -25,18 +25,21 @@ import Data.ByteString (ByteString)
 import Control.Applicative
 import Control.Monad (join,unless)
 import Control.Monad.Writer
-import Data.List.Extra (unsnoc)
+import Data.List.Extra (snoc,unsnoc)
+import Data.Function (on)
 import Data.Functor
 import Data.Functor.Alt
 import Data.Foldable
 import Data.Traversable
+import Data.Tuple.Extra (uncurry3)
 
 import Data.Singletons
 
 import Syntax
 import Syntax.Timing
-import Syntax.Untyped hiding (Post,Constant,Rewrite)
-import qualified Syntax.Untyped as Untyped
+import Syntax.Untyped (Pn)
+--import Syntax.Untyped hiding (Post,Constant,Rewrite)
+import qualified Syntax.Untyped as U
 import Syntax.Typed
 import ErrorLogger
 import Parse
@@ -45,36 +48,43 @@ type Err a = Error TypeErr a
 
 type TypeErr = String
 
-typecheck :: [RawBehaviour] -> Err [Claim]
-typecheck behvs = logErrs (lookupVars behvs) $ \store -> do
-  bs <- traverse (splitBehaviour store) behvs
-  pure $ S store : concat bs
+typecheck :: [U.RawBehaviour] -> Err [Claim]
+typecheck behvs = (S store:) . concat <$> traverse (splitBehaviour store) behvs
+                  <* noDuplicateContracts behvs
+                  <* traverse noDuplicateVars [creates | U.Definition _ _ _ _ creates _ _ _ <- behvs]
+  where
+    store = lookupVars behvs
+
+noDuplicateContracts :: [U.RawBehaviour] -> Err ()
+noDuplicateContracts behvs = noDuplicates [(pn,contract) | U.Definition pn contract _ _ _ _ _ _ <- behvs]
+                             $ \c -> "Multiple definitions of " <> c <> "."
+
+noDuplicateVars :: U.Creates -> Err ()
+noDuplicateVars (U.Creates assigns) = noDuplicates (fmap fst . fromAssign <$> assigns)
+                                      $ \x -> "Multiple definitions of " <> x <> "."
+
+noDuplicates :: [(Pn,Id)] -> (Id -> String) -> Err ()
+noDuplicates xs errmsg = traverse_ (throw . fmap errmsg) . duplicatesBy ((==) `on` snd) $ xs
 
---typecheck' :: [RawBehaviour] -> ErrorLogger TypeErr [Claim]
---typecheck' behvs = logErrs (lookupVars behvs) $ \store -> do
---  bs <- traverse (splitBehaviour store) behvs
---  pure $ S store : concat bs
 
 --- Finds storage declarations from constructors
-lookupVars :: [RawBehaviour] -> Logger TypeErr Store
-lookupVars ((Transition {}):bs) = lookupVars bs
-lookupVars ((Definition pn contract _ _ (Creates assigns) _ _ _):bs) = do
-  let assignments = Map.fromListWith (<>) $ fromAssign <$> assigns
-
-  allVars <- lookupVars bs
-  newVars <- flip Map.traverseWithKey assignments $ \var ((p,typ) :| rest) -> pure typ
-                      <* for rest (\(pn,_) ->
-                            log' (pn, var <> " already defined at " <> showposn p <> "."))
-
-  if contract `Map.member` allVars
-    then allVars <$ log' (pn, "Conflicting definitions for " <> contract <> ".")
-    else pure $ Map.insert contract newVars allVars
-lookupVars [] = pure mempty
-
-fromAssign :: Assign -> (Id, NonEmpty (Pn, SlotType))
-fromAssign (AssignVal (StorageVar pn typ var) _) = (var, [(pn, typ)])
-fromAssign (AssignMany (StorageVar pn typ var) _) = (var, [(pn, typ)])
-fromAssign (AssignStruct _ _) = error "TODO: assignstruct"
+lookupVars :: [U.RawBehaviour] -> Store
+lookupVars = foldMap $ \case
+  U.Transition {} -> mempty
+  U.Definition _ contract _ _ (U.Creates assigns) _ _ _ ->
+    Map.singleton contract . Map.fromList $ snd . fromAssign <$> assigns
+
+fromAssign :: U.Assign -> (Pn, (Id, SlotType))
+fromAssign (U.AssignVal (U.StorageVar pn typ var) _) = (pn, (var, typ))
+fromAssign (U.AssignMany (U.StorageVar pn typ var) _) = (pn, (var, typ))
+fromAssign (U.AssignStruct _ _) = error "TODO: assignstruct"
+
+-- | filters out duplicate entries in list
+duplicatesBy :: (a -> a -> Bool) -> [a] -> [a]
+duplicatesBy f [] = []
+duplicatesBy f (x:xs) =
+  let e = [x | any (f x) xs]
+  in e <> duplicatesBy f xs
 
 -- | The type checking environment. 
 data Env = Env
@@ -103,50 +113,62 @@ defaultStore =
    --others TODO
   ]
 
+mkEnv :: Id -> Store -> [Decl] -> Env
+mkEnv contract store decls = Env
+  { contract = contract
+  , store    = fromMaybe mempty (Map.lookup contract store)
+  , theirs   = store
+  , calldata = abiVars
+  }
+ where
+   abiVars = Map.fromList $ map (\(Decl typ var) -> (var, metaType typ)) decls
+
 -- checks a transition given a typing of its storage variables
-splitBehaviour :: Store -> RawBehaviour -> Err [Claim]
-splitBehaviour store (Transition pn name contract iface@(Interface _ decls) iffs' cases posts) =
+splitBehaviour :: Store -> U.RawBehaviour -> Err [Claim]
+splitBehaviour store (U.Transition pn name contract iface@(Interface _ decls) iffs cases posts) =
   -- constrain integer calldata variables (TODO: other types)
-  checkIffs env iffs' >>=? \iff ->
-  traverse (inferExpr env) posts >>=? \postcondition ->
-  flatten iff postcondition cases
+  fmap concatMap (caseClaims
+                    <$> checkIffs env iffs
+                    <*> traverse (inferExpr env sing) posts)
+    <*> traverse (checkCase env) normalizedCases
+  <* noIllegalWilds
   where
     env :: Env
     env = mkEnv contract store decls
 
-    -- translate wildcards into negation of other cases
-    normalize :: [Case] -> Logger TypeErr [Case]
-    normalize []     = pure []
-    normalize cases' =
-      let 
-        Just (rest, Case p _ post) = unsnoc cases'
-        (wilds,nowilds) = partition wildcard rest
-        normalized = flip (Case p) post $ foldl (\acc (Case nowhere e _) -> EOr nowhere e acc) (BoolLit nowhere False) nowilds
-      in
-        normalized:rest <$ unless (null wilds) (log' (p, "Wildcard pattern must be last case"))
-
---    checkCase :: Expr -> Case -> (Expr, Case)
---    checkCase acc c@(Case p e post) | wildcard c = (acc, Case p (ENot nowhere acc) post)
---                                    | otherwise  = (EOr nowhere e acc, Case p e post)
-
-
-    -- flatten case list
-    flatten :: [Exp Bool Untimed] -> [Exp Bool Timed] -> Cases -> Err [Claim]
-    flatten iff postc (Direct post)       = uncurry (splitCase name contract iface [] iff postc) <$> checkPost env post
-    flatten iff postc (Branches branches) = logErrs (normalize branches) $ \branches' ->
-      fmap concat . for branches' $ \(Case _ cond post) -> do
-        if' <- inferExpr env cond
-        (updates, ret) <- checkPost env post
-        pure $ splitCase name contract iface [if'] iff postc updates ret
-
-splitBehaviour store (Definition pn contract iface@(Interface _ decls) iffs (Creates assigns) extStorage postcs invs) =
+    noIllegalWilds :: Err ()
+    noIllegalWilds = case cases of
+      U.Direct   _  -> pure ()
+      U.Branches bs -> for_ (init bs) $ \c@(U.Case p _ _) ->
+                          when (isWild c) (throw (p, "Wildcard pattern must be last case"))  -- TODO test when wildcard isn't last
+
+    -- translate wildcards into negation of other branches and translate a single case to a wildcard 
+    normalizedCases :: [U.Case]
+    normalizedCases = case cases of
+      U.Direct   post -> [U.Case nowhere (U.WildExp nowhere) post]
+      U.Branches bs ->
+        let
+          Just (rest, last@(U.Case pn _ post)) = unsnoc bs
+          negation = U.ENot nowhere $
+                        foldl (\acc (U.Case _ e _) -> U.EOr nowhere e acc) (U.BoolLit nowhere False) rest
+        in rest `snoc` (if isWild last then U.Case pn negation post else last)
+
+    -- | split case into pass and fail case
+    caseClaims :: [Exp Bool Untimed] -> [Exp Bool Timed] -> ([Exp Bool Untimed], [Rewrite], Maybe (TypedExp Timed)) -> [Claim]
+    caseClaims []   postcs (if',storage,ret) =
+      [ B $ Behaviour name Pass contract iface if' postcs storage ret ]
+    caseClaims iffs postcs (if',storage,ret) =
+      [ B $ Behaviour name Pass contract iface (if' <> iffs) postcs storage ret,
+        B $ Behaviour name Fail contract iface (if' <> [Neg (mconcat iffs)]) [] (Constant . locFromRewrite <$> storage) Nothing ]
+
+splitBehaviour store (U.Definition pn contract iface@(Interface _ decls) iffs (U.Creates assigns) extStorage postcs invs) =
   if not . null $ extStorage then error "TODO: support extStorage in constructor"
   else let env = mkEnv contract store decls
   in do
     stateUpdates <- concat <$> traverse (checkAssign env) assigns
     iffs' <- checkIffs env iffs
-    invariants <- traverse (inferExpr env) invs
-    ensures <- traverse (inferExpr env) postcs
+    invariants <- traverse (inferExpr env sing) invs
+    ensures <- traverse (inferExpr env sing) postcs
 
     pure $ invrClaims invariants <> ctorClaims stateUpdates iffs' ensures
   where
@@ -156,41 +178,20 @@ splitBehaviour store (Definition pn contract iface@(Interface _ decls) iffs (Cre
       | otherwise  = [ C $ Constructor contract Pass iface iffs'                 ensures updates []
                      , C $ Constructor contract Fail iface [Neg (mconcat iffs')] ensures []      [] ]
 
-mkEnv :: Id -> Store -> [Decl]-> Env
-mkEnv contract store decls = Env
-  { contract = contract
-  , store    = fromMaybe mempty (Map.lookup contract store)
-  , theirs   = store
-  , calldata = abiVars
-  }
- where
-   abiVars = Map.fromList $ map (\(Decl typ var) -> (var, metaType typ)) decls
-
--- | split case into pass and fail case
-splitCase :: Id -> Id -> Interface -> [Exp Bool Untimed] -> [Exp Bool Untimed] -> [Exp Bool Timed]
-          -> [Rewrite] -> Maybe (TypedExp Timed) -> [Claim]
-splitCase name contract iface if' [] postcs storage ret =
-  [ B $ Behaviour name Pass contract iface if' postcs storage ret ]
-splitCase name contract iface if' iffs postcs storage ret =
-  [ B $ Behaviour name Pass contract iface (if' <> iffs) postcs storage ret,
-    B $ Behaviour name Fail contract iface (if' <> [Neg (mconcat iffs)]) [] (Constant . locFromRewrite <$> storage) Nothing ]
+checkCase :: Env -> U.Case -> Err ([Exp Bool Untimed], [Rewrite], Maybe (TypedExp Timed))
+checkCase env c@(U.Case pn pre post)
+  | isWild c  = checkCase env (U.Case pn (U.BoolLit (getPosn pre) True) post)
+  | otherwise = do
+      if' <- inferExpr env sing pre
+      (storage,return) <- checkPost env post
+      pure ([if'],storage,return)
 
 -- | Ensures that none of the storage variables are read in the supplied `Expr`.
-noStorageRead :: Map Id SlotType -> Expr -> Err ()
+noStorageRead :: Map Id SlotType -> U.Expr -> Err ()
 noStorageRead store expr = for_ (keys store) $ \name ->
   for_ (findWithDefault [] name (idFromRewrites expr)) $ \pn ->
     throw (pn,"Cannot read storage in creates block")
 
---makeItemWith :: (Typeable a, Typeable t) => Env -> (TStorageItem a t -> a) -> AbiType -> Id -> [TypedExp t] ->
-makeItemWith env@Env{contract} pn name cons itemcons (args,types) new = cons . itemcons <$> makeIxs
-
--- checkUpdate :: Env -> AbiType -> Id -> [TypedExp Untimed] -> Expr -> Err StorageUpdate
--- checkUpdate env@Env{contract} typ name ixs newVal =
---   case metaType typ of
---     Integer -> IntUpdate   (IntItem   contract name ixs) <$> inferExpr env newVal
---     Boolean -> BoolUpdate  (BoolItem  contract name ixs) <$> inferExpr env newVal
---     ByteStr -> BytesUpdate (BytesItem contract name ixs) <$> inferExpr env newVal
-
 makeUpdate :: Env -> Sing a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
 makeUpdate env@Env{contract} typ name ixs newVal =
   case typ of
@@ -198,48 +199,43 @@ makeUpdate env@Env{contract} typ name ixs newVal =
     SBoolean -> BoolUpdate  (BoolItem  contract name ixs) newVal
     SByteStr -> BytesUpdate (BytesItem contract name ixs) newVal
 
--- ensures that key types match value types in an Assign
-checkAssign :: Env -> Assign -> Err [StorageUpdate]
-checkAssign env@Env{contract, store} (AssignVal (StorageVar pn (StorageValue typ) name) expr)
+-- ensures that key types match value types in an U.Assign
+checkAssign :: Env -> U.Assign -> Err [StorageUpdate]
+checkAssign env@Env{contract, store} (U.AssignVal (U.StorageVar pn (StorageValue typ) name) expr)
   = withSomeType (metaType typ) $ \stype ->
-      sequenceA [makeUpdate env stype name [] <$> inferExpr env expr]
-      <* noStorageRead store expr
-checkAssign env@Env{store} (AssignMany (StorageVar pn (StorageMapping (keyType :| _) valType) name) defns)
-  = for defns $ \def@(Defn e1 e2) -> checkDefn env keyType valType name def
+      sequenceA [makeUpdate env stype name [] <$> inferExpr env stype expr]
+        <* noStorageRead store expr
+checkAssign env@Env{store} (U.AssignMany (U.StorageVar pn (StorageMapping (keyType :| _) valType) name) defns)
+  = for defns $ \def@(U.Defn e1 e2) -> checkDefn env keyType valType name def
                                      <* noStorageRead store e1
                                      <* noStorageRead store e2
-checkAssign _ (AssignVal (StorageVar pn (StorageMapping _ _) _) expr)
+checkAssign _ (U.AssignVal (U.StorageVar pn (StorageMapping _ _) _) expr)
   = throw (getPosn expr, "Cannot assign a single expression to a composite type")
-checkAssign _ (AssignMany (StorageVar pn (StorageValue _) _) _)
+checkAssign _ (U.AssignMany (U.StorageVar pn (StorageValue _) _) _)
   = throw (pn, "Cannot assign multiple values to an atomic type")
 checkAssign _ _ = error "todo: support struct assignment in constructors"
 
 -- ensures key and value types match when assigning a defn to a mapping
 -- TODO: handle nested mappings
-checkDefn :: Env -> AbiType -> AbiType -> Id -> Defn -> Err StorageUpdate
-checkDefn env@Env{contract} keyType valType name (Defn k val) = withSomeType (metaType valType) $ \valType' ->
-  makeUpdate env valType' name <$> sequenceA [checkExpr env k keyType] <*> inferExpr env val
-
-checkPost :: Env -> Untyped.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
-checkPost env@Env{contract,calldata} (Untyped.Post maybeStorage extStorage maybeReturn) =
-  do returnexp <- traverse (typedExp scopedEnv) maybeReturn
-     ourStorage <- case maybeStorage of
-       Just entries -> checkEntries contract entries
-       Nothing -> pure []
-     otherStorage <- checkStorages extStorage
-     pure (ourStorage <> otherStorage, returnexp)
+checkDefn :: Env -> AbiType -> AbiType -> Id -> U.Defn -> Err StorageUpdate
+checkDefn env@Env{contract} keyType valType name (U.Defn k val) = withSomeType (metaType valType) $ \valType' ->
+  makeUpdate env valType' name <$> checkIxs env (getPosn k) [k] [keyType] <*> inferExpr env valType' val
+
+checkPost :: Env -> U.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
+checkPost env@Env{contract,calldata} (U.Post storage extStorage maybeReturn) = do
+  returnexp <- traverse (typedExp scopedEnv) maybeReturn
+  ourStorage <- checkEntries contract storage
+  otherStorage <- checkStorages extStorage
+  pure (ourStorage <> otherStorage, returnexp)
   where
-    checkEntries :: Id -> [Untyped.Storage] -> Err [Rewrite]
-    checkEntries name entries =
-      for entries $ \case
-        Untyped.Constant loc -> Constant <$> checkPattern (focus name scopedEnv) loc
-        Untyped.Rewrite loc val -> Rewrite <$> checkStorageExpr (focus name scopedEnv) loc val
+    checkEntries :: Id -> [U.Storage] -> Err [Rewrite]
+    checkEntries name entries = for entries $ \case
+      U.Constant loc     -> Constant <$> checkPattern     (focus name scopedEnv) loc
+      U.Rewrite  loc val -> Rewrite  <$> checkStorageExpr (focus name scopedEnv) loc val
 
-    checkStorages :: [ExtStorage] -> Err [Rewrite]
+    checkStorages :: [U.ExtStorage] -> Err [Rewrite]
     checkStorages [] = pure []
-    checkStorages ((ExtStorage name entries):xs) = do p <- checkEntries name entries
-                                                      ps <- checkStorages xs
-                                                      pure $ p <> ps
+    checkStorages (U.ExtStorage name entries:xs) = mappend <$> checkEntries name entries <*> checkStorages xs
     checkStorages _ = error "TODO: check other storages"
 
     -- remove storage items from the env that are not mentioned on the LHS of a storage declaration
@@ -265,27 +261,27 @@ checkPost env@Env{contract,calldata} (Untyped.Post maybeStorage extStorage maybe
       }
 
     localNames :: [Id]
-    localNames = nameFromStorage <$> fromMaybe mempty maybeStorage
+    localNames = nameFromStorage <$> storage
 
     externalNames :: Map Id [Id]
     externalNames = Map.fromList $ mapMaybe (\case
-        ExtStorage name storages -> Just (name, nameFromStorage <$> storages)
-        ExtCreates {} -> error "TODO: handle ExtCreate"
-        WildStorage -> Nothing
+        U.ExtStorage name storages -> Just (name, nameFromStorage <$> storages)
+        U.ExtCreates {} -> error "TODO: handle ExtCreate"
+        U.WildStorage -> Nothing
       ) extStorage
 
-checkStorageExpr :: Env -> Pattern -> Expr -> Err StorageUpdate
-checkStorageExpr _ (PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
-checkStorageExpr env@Env{contract,store} (PEntry p name args) expr = case Map.lookup name store of
-  Just (StorageValue typ) -> withSomeType (metaType typ) $ \stype ->
-    makeUpdate env stype name [] <$> inferExpr env expr
-  Just (StorageMapping argtyps typ) -> withSomeType (metaType typ) $ \stype ->
-    makeUpdate env stype name <$> makeIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env expr
+checkStorageExpr :: Env -> U.Pattern -> U.Expr -> Err StorageUpdate
+checkStorageExpr _ (U.PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
+checkStorageExpr env@Env{contract,store} (U.PEntry p name args) expr = case Map.lookup name store of
+  Just (StorageValue typ) -> withSomeType (metaType typ) $ \typ' ->
+    makeUpdate env typ' name [] <$> inferExpr env typ' expr
+  Just (StorageMapping argtyps valType) -> withSomeType (metaType valType) $ \valType' ->
+    makeUpdate env valType' name <$> checkIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env valType' expr
   Nothing -> throw (p, "Unknown storage variable: " <> show name)
 
-checkPattern :: Env -> Pattern -> Err StorageLocation
-checkPattern _ (PWild _) = error "TODO: checkPattern for Wild storage"
-checkPattern env@Env{contract,store} (PEntry p name args) =
+checkPattern :: Env -> U.Pattern -> Err StorageLocation
+checkPattern _ (U.PWild _) = error "TODO: checkPattern for Wild storage"
+checkPattern env@Env{contract,store} (U.PEntry p name args) =
   case Map.lookup name store of
     Just (StorageValue t) -> makeLocation t []
     Just (StorageMapping argtyps t) -> makeLocation t (NonEmpty.toList argtyps)
@@ -293,23 +289,26 @@ checkPattern env@Env{contract,store} (PEntry p name args) =
   where
     makeLocation :: AbiType -> [AbiType] -> Err StorageLocation
     makeLocation locType argTypes = do
-      indexExprs <- makeIxs env p args argTypes -- TODO possibly output errormsg with `name`
+      indexExprs <- checkIxs env p args argTypes -- TODO possibly output errormsg with `name` in `checkIxs`?
       pure $ case metaType locType of
         Integer -> IntLoc   $ IntItem   contract name indexExprs
         Boolean -> BoolLoc  $ BoolItem  contract name indexExprs
         ByteStr -> BytesLoc $ BytesItem contract name indexExprs
 
-
-checkIffs :: Env -> [IffH] -> Err [Exp Bool Untimed]
-checkIffs env ((Iff _ exps):xs) = do
-  hd <- traverse (inferExpr env) exps
-  tl <- checkIffs env xs
-  pure $ hd <> tl
-checkIffs env ((IffIn _ typ exps):xs) = do
-  hd <- traverse (inferExpr env) exps
-  tl <- checkIffs env xs
-  pure $ map (bound typ) hd <> tl
-checkIffs _ [] = pure []
+checkIffs :: Env -> [U.IffH] -> Err [Exp Bool Untimed]
+checkIffs env = foldr check (pure [])
+  where
+    check (U.Iff   _     exps) acc = mappend <$> traverse (inferExpr env sing) exps                    <*> acc
+    check (U.IffIn _ typ exps) acc = mappend <$> traverse (fmap (bound typ) . inferExpr env sing) exps <*> acc
+--checkIffs env (U.Iff _ exps:xs) = do
+--  hd <- traverse (inferExpr env sing) exps
+--  tl <- checkIffs env xs
+--  pure $ hd <> tl
+--checkIffs env (U.IffIn _ typ exps:xs) = do
+--  hd <- traverse (inferExpr env sing) exps
+--  tl <- checkIffs env xs
+--  pure $ map (bound typ) hd <> tl
+--checkIffs _ [] = pure []
 
 bound :: AbiType -> Exp Integer t -> Exp Bool t
 bound typ e = And (LEQ (lowerBound typ) e) $ LEQ e (upperBound typ)
@@ -329,64 +328,71 @@ upperBound typ  = error $ "upperBound not implemented for " ++ show typ
 
 -- | Attempt to construct a `TypedExp` whose type matches the supplied `AbiType`.
 -- The target timing parameter will be whatever is required by the caller.
-checkExpr :: Typeable t => Env -> Expr -> AbiType -> Err (TypedExp t)
+checkExpr :: Typeable t => Env -> U.Expr -> AbiType -> Err (TypedExp t)
 checkExpr env e typ = case metaType typ of
-  Integer -> ExpInt <$> inferExpr env e
-  Boolean -> ExpBool <$> inferExpr env e
-  ByteStr -> ExpBytes <$> inferExpr env e
+  Integer -> ExpInt <$> inferExpr env sing e
+  Boolean -> ExpBool <$> inferExpr env sing e
+  ByteStr -> ExpBytes <$> inferExpr env sing e
 
 -- | Attempt to typecheck an untyped expression as any possible type.
-typedExp :: Typeable t => Env -> Expr -> Err (TypedExp t)
-typedExp env e = ExpInt   <$> inferExpr env e
-             <!> ExpBool  <$> inferExpr env e
-             <!> ExpBytes <$> inferExpr env e
+typedExp :: Typeable t => Env -> U.Expr -> Err (TypedExp t)
+typedExp env e = ExpInt   <$> inferExpr env sing e
+             <!> ExpBool  <$> inferExpr env sing e
+             <!> ExpBytes <$> inferExpr env sing e
              <!> throw (getPosn e, "TypedExp: no suitable type") -- TODO improve error handling once we've merged the unified stuff!
 
 -- | Attempts to construct an expression with the type and timing required by
 -- the caller. If this is impossible, an error is thrown instead.
-inferExpr :: forall a t. (Typeable a, Typeable t) => Env -> Expr -> Err (Exp a t)
-inferExpr env@Env{contract,store,calldata} expr = case expr of
-  ENot    p v1    -> check p $ Neg  <$> inferExpr env v1
-  EAnd    p v1 v2 -> check p $ And  <$> inferExpr env v1 <*> inferExpr env v2
-  EOr     p v1 v2 -> check p $ Or   <$> inferExpr env v1 <*> inferExpr env v2
-  EImpl   p v1 v2 -> check p $ Impl <$> inferExpr env v1 <*> inferExpr env v2
-  EEq     p v1 v2 -> polycheck p Eq v1 v2
-  ENeq    p v1 v2 -> polycheck p NEq v1 v2
-  ELT     p v1 v2 -> check p $ LE   <$> inferExpr env v1 <*> inferExpr env v2
-  ELEQ    p v1 v2 -> check p $ LEQ  <$> inferExpr env v1 <*> inferExpr env v2
-  EGEQ    p v1 v2 -> check p $ GEQ  <$> inferExpr env v1 <*> inferExpr env v2
-  EGT     p v1 v2 -> check p $ GE   <$> inferExpr env v1 <*> inferExpr env v2
-  EAdd    p v1 v2 -> check p $ Add  <$> inferExpr env v1 <*> inferExpr env v2
-  ESub    p v1 v2 -> check p $ Sub  <$> inferExpr env v1 <*> inferExpr env v2
-  EMul    p v1 v2 -> check p $ Mul  <$> inferExpr env v1 <*> inferExpr env v2
-  EDiv    p v1 v2 -> check p $ Div  <$> inferExpr env v1 <*> inferExpr env v2
-  EMod    p v1 v2 -> check p $ Mod  <$> inferExpr env v1 <*> inferExpr env v2
-  EExp    p v1 v2 -> check p $ Exp  <$> inferExpr env v1 <*> inferExpr env v2
-  IntLit  p v1    -> check p . pure $ LitInt v1
-  BoolLit p v1    -> check p . pure $ LitBool v1
-  EITE    _ v1 v2 v3 -> ITE <$> inferExpr env v1 <*> inferExpr env v2 <*> inferExpr env v3
-  EUTEntry   p name es -> checkTime p $ entry p Neither name es
-  EPreEntry  p name es -> checkTime p $ entry p Pre     name es
-  EPostEntry p name es -> checkTime p $ entry p Post    name es
-  EnvExp p v1 -> case lookup v1 defaultStore of
+inferExpr :: forall a t. (Typeable a, Typeable t) => Env -> Sing a -> U.Expr -> Err (Exp a t)
+inferExpr env@Env{contract,store,calldata} typ expr = case expr of
+  U.ENot    p v1    -> check p $ Neg  <$> inferExpr env sing v1
+  U.EAnd    p v1 v2 -> check p $ And  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EOr     p v1 v2 -> check p $ Or   <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EImpl   p v1 v2 -> check p $ Impl <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EEq     p v1 v2 -> polycheck p Eq v1 v2
+  U.ENeq    p v1 v2 -> polycheck p NEq v1 v2
+  U.ELT     p v1 v2 -> check p $ LE   <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.ELEQ    p v1 v2 -> check p $ LEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EGEQ    p v1 v2 -> check p $ GEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EGT     p v1 v2 -> check p $ GE   <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EAdd    p v1 v2 -> check p $ Add  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.ESub    p v1 v2 -> check p $ Sub  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EMul    p v1 v2 -> check p $ Mul  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EDiv    p v1 v2 -> check p $ Div  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EMod    p v1 v2 -> check p $ Mod  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.EExp    p v1 v2 -> check p $ Exp  <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.IntLit  p v1    -> check p . pure $ LitInt v1
+  U.BoolLit p v1    -> check p . pure $ LitBool v1
+  U.EITE    _ v1 v2 v3 -> ITE <$> inferExpr env sing v1 <*> inferExpr env typ v2 <*> inferExpr env typ v3
+  U.EUTEntry   p name es -> checkTime p $ entry p Neither name es
+  U.EPreEntry  p name es -> checkTime p $ entry p Pre     name es
+  U.EPostEntry p name es -> checkTime p $ entry p Post    name es
+  U.EnvExp p v1 -> case lookup v1 defaultStore of
     Just Integer -> check p . pure $ IntEnv v1
     Just ByteStr -> check p . pure $ ByEnv  v1
     _            -> throw (p, "unknown environment variable: " <> show v1)
   v -> error $ "internal error: infer type of:" <> show v
   -- Wild ->
   -- Zoom Var Exp
-  -- Func Var [Expr]
-  -- Look Expr Expr
-  -- ECat Expr Expr
-  -- ESlice Expr Expr Expr
-  -- Newaddr Expr Expr
-  -- Newaddr2 Expr Expr Expr
-  -- BYHash Expr
-  -- BYAbiE Expr
+  -- Func Var [U.Expr]
+  -- Look U.Expr U.Expr
+  -- ECat U.Expr U.Expr
+  -- ESlice U.Expr U.Expr U.Expr
+  -- Newaddr U.Expr U.Expr
+  -- Newaddr2 U.Expr U.Expr U.Expr
+  -- BYHash U.Expr
+  -- BYAbiE U.Expr
   -- StringLit String
   where
-    -- Try to cast the type parameter of an expression to the goal of `inferExpr`.
-    -- The cast only succeeds if they already are the same.
+--    expected = sing @a
+--
+--    check' :: Typeable x => Sing x -> Pn -> Exp x t0 -> Err (Exp a t0)
+--    check' actual pn = validate
+--                        [(pn,"Type mismatch. Expected " <> show expected <> ", got " <> show actual <> ".")]
+--                        castType
+
+    -- Try to cast the type parameter of an expression to the goal of `inferExpr`,
+    -- or throw an error.
     check :: forall x t0. Typeable x => Pn -> Err (Exp x t0) -> Err (Exp a t0)
     check pn = ensure
                 [(pn,"Type mismatch. Expected " <> show (typeRep @a) <> ", got " <> show (typeRep @x) <> ".")]
@@ -400,14 +406,14 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
     -- Takes a polymorphic binary AST constructor and specializes it to each of
     -- our types. Those specializations are used in order to guide the
     -- typechecking of the two supplied expressions. Returns at first success.
-    polycheck :: Typeable x => Pn -> (forall y. (Eq y, Typeable y) => Exp y t -> Exp y t -> Exp x t) -> Expr -> Expr -> Err (Exp a t)
-    polycheck pn cons e1 e2 = check pn (cons @Integer    <$> inferExpr env e1 <*> inferExpr env e2)
-                          <!> check pn (cons @Bool       <$> inferExpr env e1 <*> inferExpr env e2)
-                          <!> check pn (cons @ByteString <$> inferExpr env e1 <*> inferExpr env e2)
+    polycheck :: Typeable x => Pn -> (forall y. (Eq y, Typeable y) => Exp y t -> Exp y t -> Exp x t) -> U.Expr -> U.Expr -> Err (Exp a t)
+    polycheck pn cons e1 e2 = check pn (cons @Integer    <$> inferExpr env sing e1 <*> inferExpr env sing e2)
+                          <!> check pn (cons @Bool       <$> inferExpr env sing e1 <*> inferExpr env sing e2)
+                          <!> check pn (cons @ByteString <$> inferExpr env sing e1 <*> inferExpr env sing e2)
                           <!> throw (pn, "Couldn't harmonize types!") -- TODO improve error handling once we've merged the unified stuff!
 
     -- Try to construct a reference to a calldata variable or an item in storage.
-    entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [Expr] -> Err (Exp a t0)
+    entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [U.Expr] -> Err (Exp a t0)
     entry pn timing name es = case (Map.lookup name store, Map.lookup name calldata) of
       (Nothing, Nothing) -> throw (pn, "Unknown variable: " <> name)
       (Just _, Just _)   -> throw (pn, "Ambiguous variable: " <> name)
@@ -416,28 +422,24 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
         Integer -> check pn . pure $ IntVar  name
         Boolean -> check pn . pure $ BoolVar name
         ByteStr -> check pn . pure $ ByVar   name
-      (Just (StorageValue a), Nothing)      -> makeEntry a []
-      (Just (StorageMapping ts a), Nothing) -> makeEntry a $ NonEmpty.toList ts
+      (Just (StorageValue a), Nothing)      -> checkEntry a []
+      (Just (StorageMapping ts a), Nothing) -> checkEntry a $ NonEmpty.toList ts
       where
-        makeEntry :: AbiType -> [AbiType] -> Err (Exp a t0)
-        makeEntry a ts = case metaType a of
-          Integer -> check pn $ makeItem IntItem
-          Boolean -> check pn $ makeItem BoolItem
-          ByteStr -> check pn $ makeItem BytesItem
+        checkEntry :: AbiType -> [AbiType] -> Err (Exp a t0)
+        checkEntry a ts = case metaType a of
+          Integer -> check pn $ using IntItem
+          Boolean -> check pn $ using BoolItem
+          ByteStr -> check pn $ using BytesItem
           where
-            -- Given that the indices used in the expression agree with the storage,
-            -- create a `TStorageItem` using the supplied constructor, place it
-            -- in a `TEntry` and then attempt to cast its timing parameter to the
-            -- target timing of `inferExpr`. Finally, `check` the type parameter as
-            -- with all other expressions.
-            makeItem :: Typeable x => (Id -> Id -> [TypedExp t0] -> TStorageItem x t0) -> Err (Exp x t0)
-            makeItem cons = TEntry timing . cons contract name <$> makeIxs env pn es ts
-
-makeIxs :: Typeable t => Env -> Pn -> [Expr] -> [AbiType] -> Err [TypedExp t]
-makeIxs env pn exprs types = if length exprs /= length types
+            -- Using the supplied constructor, create a `TStorageItem` and then place it in a `TEntry`.
+            using :: Typeable x => (Id -> Id -> [TypedExp t0] -> TStorageItem x t0) -> Err (Exp x t0)
+            using cons = TEntry timing . cons contract name <$> checkIxs env pn es ts
+
+checkIxs :: Typeable t => Env -> Pn -> [U.Expr] -> [AbiType] -> Err [TypedExp t]
+checkIxs env pn exprs types = if length exprs /= length types
                               then throw (pn, "Index mismatch for entry!")
                               else traverse (uncurry $ checkExpr env) (exprs `zip` types)
 
--- makeIxs' :: Typeable t => Env -> Pn -> [Expr] -> [AbiType] -> Logger TypeErr [TypedExp t]
--- makeIxs' env pn exprs types = traverse (uncurry $ checkExpr env) (exprs `zip` types)
+-- checkIxs' :: Typeable t => Env -> Pn -> [U.Expr] -> [AbiType] -> Logger TypeErr [TypedExp t]
+-- checkIxs' env pn exprs types = traverse (uncurry $ checkExpr env) (exprs `zip` types)
 --                           <* when (length exprs /= length types) (log' (pn, "Index mismatch for entry!"))

From 0e5711109b1cdf3d85c66268aecb9aa70b16e010 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 13 Sep 2021 21:58:48 +0200
Subject: [PATCH 07/36] custom `Alt`-function, `TStorageItem` uses `Sing`

---
 src/Enrich.hs              |   6 +-
 src/ErrorLogger.hs         |  51 ++++++++++++-
 src/Main.hs                | 142 ++++++++++++++++++-------------------
 src/Print.hs               |   2 +-
 src/Syntax.hs              |  46 ++++++------
 src/Syntax/TimeAgnostic.hs |  77 +++++++++++---------
 src/Type.hs                | 141 ++++++++++++++++--------------------
 7 files changed, 252 insertions(+), 213 deletions(-)

diff --git a/src/Enrich.hs b/src/Enrich.hs
index 60ec41ea..50318044 100644
--- a/src/Enrich.hs
+++ b/src/Enrich.hs
@@ -63,7 +63,7 @@ mkEthEnvBounds vars = catMaybes $ mkBound <$> nub vars
   where
     mkBound :: EthEnv -> Maybe (Exp Bool t)
     mkBound e = case lookup e defaultStore of
-      Just (Integer) -> Just $ bound (toAbiType e) (IntEnv e)
+      Just Integer -> Just $ bound (toAbiType e) (IntEnv e)
       _ -> Nothing
 
     toAbiType :: EthEnv -> AbiType
@@ -92,7 +92,7 @@ mkStorageBounds store refs = catMaybes $ mkBound <$> refs
     mkBound _ = Nothing
 
     fromItem :: TStorageItem Integer Untimed -> Exp Bool Untimed
-    fromItem item@(IntItem contract name _) = bound (abiType $ slotType contract name) (TEntry item Neither)
+    fromItem item@(Item _ contract name _) = bound (abiType $ slotType contract name) (TEntry Neither item)
 
     slotType :: Id -> Id -> SlotType
     slotType contract name = let
@@ -105,5 +105,5 @@ mkStorageBounds store refs = catMaybes $ mkBound <$> refs
 
 mkCallDataBounds :: [Decl] -> [Exp Bool t]
 mkCallDataBounds = concatMap $ \(Decl typ name) -> case metaType typ of
-  Integer -> [bound typ (IntVar name)]
+  Integer -> [bound typ (mkVar name)]
   _ -> []
diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs
index 372ae2e9..5c988d6e 100644
--- a/src/ErrorLogger.hs
+++ b/src/ErrorLogger.hs
@@ -1,12 +1,15 @@
-{-# LANGUAGE OverloadedLists,TypeOperators, FlexibleInstances, ApplicativeDo, MultiParamTypeClasses, ScopedTypeVariables, InstanceSigs #-}
+{-# LANGUAGE OverloadedLists,TypeOperators, LambdaCase, AllowAmbiguousTypes, TypeApplications, TypeFamilies, DeriveFunctor, ConstraintKinds, UndecidableInstances, FlexibleContexts, FlexibleInstances, RankNTypes, KindSignatures, ApplicativeDo, MultiParamTypeClasses, ScopedTypeVariables, InstanceSigs #-}
 
 module ErrorLogger (module ErrorLogger) where
 
 import Control.Lens as ErrorLogger ((#))
-import Control.Monad.Writer
+import Control.Monad.Writer hiding (Alt)
 import Data.Functor
-import Data.List.NonEmpty
+import Data.Functor.Alt
+import Data.List.NonEmpty as NE
 import Data.Validation as ErrorLogger
+import Data.Proxy
+import Data.Reflection
 import GHC.Generics
 
 import Syntax.Untyped (Pn)
@@ -15,3 +18,45 @@ type Error e = Validation (NonEmpty (Pn,e))
 
 throw :: (Pn,e) -> Error e a
 throw msg = _Failure # [msg]
+
+notAtPosn :: Pn -> (forall s. Reifies s (AltDict (Error e)) => A s (Error e) a) -> Error e a
+notAtPosn p = withAlt $ \case
+  Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
+  res         -> const res
+
+-- notAtPosn' :: forall e a. Pn -> (forall s. Reifies s (Def Alt (Error e)) => Lift Alt (Error e) s a) -> Error e a
+-- notAtPosn' p = flip (with @Alt @(Error e)) undefined $ \case
+--   Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
+--   res         -> const res
+
+
+-- newtype Lift (p :: (* -> *) -> Constraint) (f :: * -> *) (s :: * -> *) a = Lift { lower :: f a } deriving (Functor)
+
+-- class ReifiableConstraint p where
+--   data Def (p :: (* -> *) -> Constraint) (f :: * -> *) :: *
+--   reifiedIns :: Reifies s (Def p f) :- p (Lift p f s)
+
+
+-- instance Functor f => ReifiableConstraint Alt where
+--   data Def Alt f = Alt { alt_ :: forall a. f a -> f a -> f a }
+--   reifiedIns = Sub Dict
+
+
+-- instance (Functor (Lift Alt f s), Reifies s (Def Alt f)) => Alt (Lift Alt f s) where
+--   Lift a <!> Lift b = let alt' = alt_ $ reflect (Proxy @s)
+--                        in Lift $ a `alt'` b
+
+-- with :: forall p f a. Def p f -> (forall (s :: * -> *). Reifies s (Def p f) => Lift p f s a) -> f a
+-- with d comp = reify @(Def p f) d $ ((\(Proxy :: Proxy (s :: * -> *)) -> lower (comp @s)) :: forall (s :: * -> *). Reifies s (Def p f) => Proxy s -> f a)
+
+
+newtype A s f a = A { runA :: f a } deriving (Show, Functor)
+
+newtype AltDict f = AltDict { alt :: forall a. f a -> f a -> f a }
+
+instance (Functor (A s f), Reifies s (AltDict f)) => Alt (A s f) where
+ A l <!> A r = let alt_ = alt $ reflect (Proxy @s)
+                in A $ l `alt_` r
+
+withAlt :: (forall a. f a -> f a -> f a) -> (forall s. Reifies s (AltDict f) => A s f b) -> f b
+withAlt alt_ comp = reify (AltDict alt_) $ \(_ :: Proxy s) -> runA (comp @s)
diff --git a/src/Main.hs b/src/Main.hs
index d574518d..ab6c85e7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -37,11 +37,11 @@ import Parse
 import Syntax.Annotated
 import Syntax.Untyped
 import Enrich
-import K hiding (normalize, indent)
-import SMT
+--import K hiding (normalize, indent)
+--import SMT
 import Type hiding (Err)
 import qualified Type
-import Coq hiding (indent)
+--import Coq hiding (indent)
 --import HEVM
 
 --command line options
@@ -93,8 +93,8 @@ main = do
       Lex f -> lex' f
       Parse f -> parse' f
       Type f -> type' f
-      Prove file' solver' smttimeout' debug' -> prove file' solver' smttimeout' debug'
-      Coq f -> coq' f
+      --Prove file' solver' smttimeout' debug' -> prove file' solver' smttimeout' debug'
+      --Coq f -> coq' f
       --K spec' soljson' gas' storage' extractbin' out' -> k spec' soljson' gas' storage' extractbin' out'
       --HEVM spec' soljson' solver' smttimeout' debug' -> hevm spec' soljson' solver' smttimeout' debug'
 
@@ -123,71 +123,71 @@ type' f = do
     Logger.Success a -> B.putStrLn (encode a)
     Logger.Failure e -> mapM_ (prettyErr contents) e >> exitFailure
 
-prove :: FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
-prove file' solver' smttimeout' debug' = do
-  let
-    parseSolver s = case s of
-      Just "z3" -> SMT.Z3
-      Just "cvc4" -> SMT.CVC4
-      Nothing -> SMT.Z3
-      Just _ -> error "unrecognized solver"
-    config = SMT.SMTConfig (parseSolver solver') (fromMaybe 20000 smttimeout') debug'
-  contents <- readFile file'
-  proceed contents (compile contents) $ \claims -> do
-    let
-      catModels results = [m | Sat m <- results]
-      catErrors results = [e | e@SMT.Error {} <- results]
-      catUnknowns results = [u | u@SMT.Unknown {} <- results]
-
-      (<->) :: Doc -> [Doc] -> Doc
-      x <-> y = x <$$> line <> (indent 2 . vsep $ y)
-
-      failMsg :: [SMT.SMTResult] -> Doc
-      failMsg results
-        | not . null . catUnknowns $ results
-            = text "could not be proven due to a" <+> (yellow . text $ "solver timeout")
-        | not . null . catErrors $ results
-            = (red . text $ "failed") <+> "due to solver errors:" <-> ((fmap (text . show)) . catErrors $ results)
-        | otherwise
-            = (red . text $ "violated") <> colon <-> (fmap pretty . catModels $ results)
-
-      passMsg :: Doc
-      passMsg = (green . text $ "holds") <+> (bold . text $ "∎")
-
-      accumulateResults :: (Bool, Doc) -> (Query, [SMT.SMTResult]) -> (Bool, Doc)
-      accumulateResults (status, report) (query, results) = (status && holds, report <$$> msg <$$> smt)
-        where
-          holds = all isPass results
-          msg = identifier query <+> if holds then passMsg else failMsg results
-          smt = if debug' then line <> getSMT query else empty
-
-    solverInstance <- spawnSolver config
-    pcResults <- mapM (runQuery solverInstance) (concatMap mkPostconditionQueries claims)
-    invResults <- mapM (runQuery solverInstance) (mkInvariantQueries claims)
-    stopSolver solverInstance
-
-    let
-      invTitle = line <> (underline . bold . text $ "Invariants:") <> line
-      invOutput = foldl' accumulateResults (True, empty) invResults
-
-      pcTitle = line <> (underline . bold . text $ "Postconditions:") <> line
-      pcOutput = foldl' accumulateResults (True, empty) pcResults
-
-    render $ vsep
-      [ ifExists invResults invTitle
-      , indent 2 $ snd invOutput
-      , ifExists pcResults pcTitle
-      , indent 2 $ snd pcOutput
-      ]
-
-    unless (fst invOutput && fst pcOutput) exitFailure
-
-
-coq' :: FilePath -> IO()
-coq' f = do
-  contents <- readFile f
-  proceed contents (compile contents) $ \claims ->
-    TIO.putStr $ coq claims
+-- prove :: FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
+-- prove file' solver' smttimeout' debug' = do
+--   let
+--     parseSolver s = case s of
+--       Just "z3" -> SMT.Z3
+--       Just "cvc4" -> SMT.CVC4
+--       Nothing -> SMT.Z3
+--       Just _ -> error "unrecognized solver"
+--     config = SMT.SMTConfig (parseSolver solver') (fromMaybe 20000 smttimeout') debug'
+--   contents <- readFile file'
+--   proceed contents (compile contents) $ \claims -> do
+--     let
+--       catModels results = [m | Sat m <- results]
+--       catErrors results = [e | e@SMT.Error {} <- results]
+--       catUnknowns results = [u | u@SMT.Unknown {} <- results]
+
+--       (<->) :: Doc -> [Doc] -> Doc
+--       x <-> y = x <$$> line <> (indent 2 . vsep $ y)
+
+--       failMsg :: [SMT.SMTResult] -> Doc
+--       failMsg results
+--         | not . null . catUnknowns $ results
+--             = text "could not be proven due to a" <+> (yellow . text $ "solver timeout")
+--         | not . null . catErrors $ results
+--             = (red . text $ "failed") <+> "due to solver errors:" <-> ((fmap (text . show)) . catErrors $ results)
+--         | otherwise
+--             = (red . text $ "violated") <> colon <-> (fmap pretty . catModels $ results)
+
+--       passMsg :: Doc
+--       passMsg = (green . text $ "holds") <+> (bold . text $ "∎")
+
+--       accumulateResults :: (Bool, Doc) -> (Query, [SMT.SMTResult]) -> (Bool, Doc)
+--       accumulateResults (status, report) (query, results) = (status && holds, report <$$> msg <$$> smt)
+--         where
+--           holds = all isPass results
+--           msg = identifier query <+> if holds then passMsg else failMsg results
+--           smt = if debug' then line <> getSMT query else empty
+
+--     solverInstance <- spawnSolver config
+--     pcResults <- mapM (runQuery solverInstance) (concatMap mkPostconditionQueries claims)
+--     invResults <- mapM (runQuery solverInstance) (mkInvariantQueries claims)
+--     stopSolver solverInstance
+
+--     let
+--       invTitle = line <> (underline . bold . text $ "Invariants:") <> line
+--       invOutput = foldl' accumulateResults (True, empty) invResults
+
+--       pcTitle = line <> (underline . bold . text $ "Postconditions:") <> line
+--       pcOutput = foldl' accumulateResults (True, empty) pcResults
+
+--     render $ vsep
+--       [ ifExists invResults invTitle
+--       , indent 2 $ snd invOutput
+--       , ifExists pcResults pcTitle
+--       , indent 2 $ snd pcOutput
+--       ]
+
+--     unless (fst invOutput && fst pcOutput) exitFailure
+
+
+-- coq' :: FilePath -> IO()
+-- coq' f = do
+--   contents <- readFile f
+--   proceed contents (compile contents) $ \claims ->
+--     TIO.putStr $ coq claims
 
 -- k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
 -- k spec' soljson' gas' storage' extractbin' out' = do
@@ -274,9 +274,9 @@ prettyErr contents (pn, msg) | pn == lastPos = do
 --  exitFailure
 prettyErr contents (AlexPn _ line' col, msg) = do
   let cxt = safeDrop (line' - 1) (lines contents)
+  hPutStrLn stderr $ msg <> ":"
   hPutStrLn stderr $ show line' <> " | " <> head cxt
   hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
-  hPutStrLn stderr msg
 --  exitFailure
   where
     safeDrop :: Int -> [a] -> [a]
diff --git a/src/Print.hs b/src/Print.hs
index 6a5019e7..5af5aa60 100644
--- a/src/Print.hs
+++ b/src/Print.hs
@@ -82,7 +82,7 @@ prettyExp e = case e of
 
   --polymorphic
   ITE a b c -> "(if " <> prettyExp a <> " then " <> prettyExp b <> " else " <> prettyExp c <> ")"
-  TEntry a t -> timeParens t $ prettyItem a
+  TEntry t a -> timeParens t $ prettyItem a
   where
     print2 sym a b = "(" <> prettyExp a <> " " <> sym <> " " <> prettyExp b <> ")"
 
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 67f86954..f98db577 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -58,10 +58,10 @@ locFromUpdate (BoolUpdate  item _) = BoolLoc item
 locFromUpdate (BytesUpdate item _) = BytesLoc item
 
 locsFromItem :: TStorageItem a t -> [StorageLocation t]
-locsFromItem t = case t of
-  IntItem   contract name ixs -> IntLoc   (IntItem   contract name ixs) : ixLocs ixs
-  BoolItem  contract name ixs -> BoolLoc  (BoolItem  contract name ixs) : ixLocs ixs
-  BytesItem contract name ixs -> BytesLoc (BytesItem contract name ixs) : ixLocs ixs
+locsFromItem item@(Item typ _ _ ixs) = case typ of
+  SInteger -> IntLoc   item : ixLocs ixs
+  SBoolean -> BoolLoc  item : ixLocs ixs
+  SByteStr -> BytesLoc item : ixLocs ixs
   where
     ixLocs :: [TypedExp t] -> [StorageLocation t]
     ixLocs = concatMap locsFromTypedExp
@@ -94,7 +94,7 @@ locsFromExp = nub . go
       Exp a b   -> go a <> go b
       Cat a b   -> go a <> go b
       Slice a b c -> go a <> go b <> go c
-      ByVar _ -> []
+      --ByVar _ -> []
       ByStr _ -> []
       ByLit _ -> []
       LitInt _  -> []
@@ -102,14 +102,15 @@ locsFromExp = nub . go
       IntMax _  -> []
       UIntMin _ -> []
       UIntMax _ -> []
-      IntVar _  -> []
+      --IntVar _  -> []
       LitBool _ -> []
-      BoolVar _ -> []
+      --BoolVar _ -> []
       NewAddr a b -> go a <> go b
       IntEnv _ -> []
       ByEnv _ -> []
       ITE x y z -> go x <> go y <> go z
       TEntry _ a -> locsFromItem a
+      Var _ _ -> []
 
 ethEnvFromBehaviour :: Behaviour t -> [EthEnv]
 ethEnvFromBehaviour (Behaviour _ _ _ _ preconds postconds rewrites returns) = nub $
@@ -166,13 +167,13 @@ ethEnvFromExp = nub . go
       Cat a b   -> go a <> go b
       Slice a b c -> go a <> go b <> go c
       ITE a b c -> go a <> go b <> go c
-      ByVar _ -> []
+      --ByVar _ -> []
       ByStr _ -> []
       ByLit _ -> []
       LitInt _  -> []
-      IntVar _  -> []
+      --IntVar _  -> []
       LitBool _ -> []
-      BoolVar _ -> []
+      --BoolVar _ -> []
       IntMin _ -> []
       IntMax _ -> []
       UIntMin _ -> []
@@ -181,6 +182,7 @@ ethEnvFromExp = nub . go
       IntEnv a -> [a]
       ByEnv a -> [a]
       TEntry _ a -> ethEnvFromItem a
+      Var _ _ -> []
 
 metaType :: AbiType -> MType
 metaType (AbiUIntType _)     = Integer
@@ -199,9 +201,7 @@ idFromRewrite :: Rewrite t -> Id
 idFromRewrite = onRewrite idFromLocation idFromUpdate
 
 idFromItem :: TStorageItem a t -> Id
-idFromItem (IntItem _ name _) = name
-idFromItem (BoolItem _ name _) = name
-idFromItem (BytesItem _ name _) = name
+idFromItem (Item _ _ name _) = name
 
 idFromUpdate :: StorageUpdate t -> Id
 idFromUpdate (IntUpdate   item _) = idFromItem item
@@ -217,14 +217,14 @@ contractFromRewrite :: Rewrite t -> Id
 contractFromRewrite = onRewrite contractFromLoc contractFromUpdate
 
 contractFromItem :: TStorageItem a t -> Id
-contractFromItem (IntItem   c _ _) = c
-contractFromItem (BoolItem  c _ _) = c
-contractFromItem (BytesItem c _ _) = c
+contractFromItem (Item _ c _ _) = c
+--contractFromItem (BoolItem  c _ _) = c
+--contractFromItem (BytesItem c _ _) = c
 
 ixsFromItem :: TStorageItem a t -> [TypedExp t]
-ixsFromItem (IntItem   _ _ ixs) = ixs
-ixsFromItem (BoolItem  _ _ ixs) = ixs
-ixsFromItem (BytesItem _ _ ixs) = ixs
+ixsFromItem (Item _ _ _ ixs) = ixs
+--ixsFromItem (BoolItem  _ _ ixs) = ixs
+--ixsFromItem (BytesItem _ _ ixs) = ixs
 
 contractsInvolved :: Behaviour t -> [Id]
 contractsInvolved = fmap contractFromRewrite . _stateUpdates
@@ -252,10 +252,10 @@ ixsFromUpdate (BytesUpdate item _) = ixsFromItem item
 ixsFromRewrite :: Rewrite t -> [TypedExp t]
 ixsFromRewrite = onRewrite ixsFromLocation ixsFromUpdate
 
-itemType :: TStorageItem a t -> MType
-itemType IntItem{}   = Integer
-itemType BoolItem{}  = Boolean
-itemType BytesItem{} = ByteStr
+--itemType :: TStorageItem a t -> MType
+--itemType IntItem{}   = Integer
+--itemType BoolItem{}  = Boolean
+--itemType BytesItem{} = ByteStr
 
 isMapping :: StorageLocation t -> Bool
 isMapping = not . null . ixsFromLocation
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 44afcf1b..c217902b 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -61,6 +60,12 @@ data SType a where
 deriving instance Show (SType a)
 deriving instance Eq (SType a)
 
+(~==) :: SType a -> SType b -> Bool
+SInteger ~== SInteger = True
+SBoolean ~== SBoolean = True
+SByteStr ~== SByteStr = True
+_        ~== _        = False
+
 type instance Sing = SType
 
 instance SingI Integer where sing = SInteger
@@ -196,9 +201,10 @@ data StorageLocation t
 -- refer to the pre-/post-state, or not. `a` is the type of the item that is
 -- referenced.
 data TStorageItem (a :: *) (t :: Timing) where
-  IntItem    :: Id -> Id -> [TypedExp t] -> TStorageItem Integer t
-  BoolItem   :: Id -> Id -> [TypedExp t] -> TStorageItem Bool t
-  BytesItem  :: Id -> Id -> [TypedExp t] -> TStorageItem ByteString t
+  Item :: Sing a -> Id -> Id -> [TypedExp t] -> TStorageItem a t
+--  IntItem    :: Id -> Id -> [TypedExp t] -> TStorageItem Integer t
+--  BoolItem   :: Id -> Id -> [TypedExp t] -> TStorageItem Bool t
+--  BytesItem  :: Id -> Id -> [TypedExp t] -> TStorageItem ByteString t
 deriving instance Show (TStorageItem a t)
 deriving instance Eq (TStorageItem a t)
 
@@ -231,7 +237,7 @@ data Exp (a :: *) (t :: Timing) where
   GEQ :: Exp Integer t -> Exp Integer t -> Exp Bool t
   GE :: Exp Integer t -> Exp Integer t -> Exp Bool t
   LitBool :: Bool -> Exp Bool t
-  BoolVar :: Id -> Exp Bool t
+  Var :: Sing a -> Id -> Exp a t
   -- integers
   Add :: Exp Integer t -> Exp Integer t -> Exp Integer t
   Sub :: Exp Integer t -> Exp Integer t -> Exp Integer t
@@ -240,7 +246,7 @@ data Exp (a :: *) (t :: Timing) where
   Mod :: Exp Integer t -> Exp Integer t -> Exp Integer t
   Exp :: Exp Integer t -> Exp Integer t -> Exp Integer t
   LitInt :: Integer -> Exp Integer t
-  IntVar :: Id -> Exp Integer t
+  --IntVar :: Id -> Exp Integer t
   IntEnv :: EthEnv -> Exp Integer t
   -- bounds
   IntMin :: Int -> Exp Integer t
@@ -250,7 +256,7 @@ data Exp (a :: *) (t :: Timing) where
   -- bytestrings
   Cat :: Exp ByteString t -> Exp ByteString t -> Exp ByteString t
   Slice :: Exp ByteString t -> Exp Integer t -> Exp Integer t -> Exp ByteString t
-  ByVar :: Id -> Exp ByteString t
+  --ByVar :: Id -> Exp ByteString t
   ByStr :: String -> Exp ByteString t
   ByLit :: ByteString -> Exp ByteString t
   ByEnv :: EthEnv -> Exp ByteString t
@@ -274,7 +280,7 @@ instance Eq (Exp a t) where
   GEQ a b == GEQ c d = a == c && b == d
   GE a b == GE c d = a == c && b == d
   LitBool a == LitBool b = a == b
-  BoolVar a == BoolVar b = a == b
+  --BoolVar a == BoolVar b = a == b
 
   Add a b == Add c d = a == c && b == d
   Sub a b == Sub c d = a == c && b == d
@@ -283,7 +289,7 @@ instance Eq (Exp a t) where
   Mod a b == Mod c d = a == c && b == d
   Exp a b == Exp c d = a == c && b == d
   LitInt a == LitInt b = a == b
-  IntVar a == IntVar b = a == b
+  --IntVar a == IntVar b = a == b
   IntEnv a == IntEnv b = a == b
 
   IntMin a == IntMin b = a == b
@@ -293,7 +299,7 @@ instance Eq (Exp a t) where
 
   Cat a b == Cat c d = a == c && b == d
   Slice a b c == Slice d e f = a == d && b == e && c == f
-  ByVar a == ByVar b = a == b
+  --ByVar a == ByVar b = a == b
   ByStr a == ByStr b = a == b
   ByLit a == ByLit b = a == b
   ByEnv a == ByEnv b = a == b
@@ -310,6 +316,7 @@ instance Eq (Exp a t) where
       Nothing -> False
   ITE a b c == ITE d e f = a == d && b == e && c == f
   TEntry a t == TEntry b u = a == b && t == u
+  Var _ a == Var _ b = a == b
   _ == _ = False
 
 instance Semigroup (Exp Bool t) where
@@ -342,7 +349,7 @@ instance Timable (Exp a) where
     GEQ x y -> GEQ (go x) (go y)
     GE x y -> GE (go x) (go y)
     LitBool x -> LitBool x
-    BoolVar x -> BoolVar x
+    --BoolVar x -> BoolVar x
     -- integers
     Add x y -> Add (go x) (go y)
     Sub x y -> Sub (go x) (go y)
@@ -351,7 +358,7 @@ instance Timable (Exp a) where
     Mod x y -> Mod (go x) (go y)
     Exp x y -> Exp (go x) (go y)
     LitInt x -> LitInt x
-    IntVar x -> IntVar x
+    --IntVar x -> IntVar x
     IntEnv x -> IntEnv x
     -- bounds
     IntMin x -> IntMin x
@@ -361,7 +368,7 @@ instance Timable (Exp a) where
     -- bytestrings
     Cat x y -> Cat (go x) (go y)
     Slice x y z -> Slice (go x) (go y) (go z)
-    ByVar x -> ByVar x
+    --ByVar x -> ByVar x
     ByStr x -> ByStr x
     ByLit x -> ByLit x
     ByEnv x -> ByEnv x
@@ -372,15 +379,13 @@ instance Timable (Exp a) where
     NEq x y -> NEq (go x) (go y)
     ITE x y z -> ITE (go x) (go y) (go z)
     TEntry _ item -> TEntry time (go item)
+    Var t x -> Var t x
     where
       go :: Timable c => c Untimed -> c Timed
       go = setTime time
 
 instance Timable (TStorageItem a) where
-  setTime time item = case item of
-    IntItem   c x ixs -> IntItem   c x $ setTime time <$> ixs
-    BoolItem  c x ixs -> BoolItem  c x $ setTime time <$> ixs
-    BytesItem c x ixs -> BytesItem c x $ setTime time <$> ixs
+  setTime time (Item typ c x ixs) = Item typ c x $ setTime time <$> ixs
 
 ------------------------
 -- * JSON instances * --
@@ -448,15 +453,15 @@ instance ToJSON (StorageUpdate t) where
   toJSON (BytesUpdate a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
 
 instance ToJSON (TStorageItem a t) where
-  toJSON (IntItem a b []) = object ["sort" .= pack "int"
+  toJSON (Item SInteger a b []) = object ["sort" .= pack "int"
                                   , "name" .= String (pack a <> "." <> pack b)]
-  toJSON (BoolItem a b []) = object ["sort" .= pack "bool"
+  toJSON (Item SBoolean a b []) = object ["sort" .= pack "bool"
                                    , "name" .= String (pack a <> "." <> pack b)]
-  toJSON (BytesItem a b []) = object ["sort" .= pack "bytes"
+  toJSON (Item SByteStr a b []) = object ["sort" .= pack "bytes"
                                     , "name" .= String (pack a <> "." <> pack b)]
-  toJSON (IntItem a b c) = mapping a b c
-  toJSON (BoolItem a b c) = mapping a b c
-  toJSON (BytesItem a b c) = mapping a b c
+  toJSON (Item SInteger a b c) = mapping a b c
+  toJSON (Item SBoolean a b c) = mapping a b c
+  toJSON (Item SByteStr a b c) = mapping a b c
 
 mapping :: (ToJSON a1, ToJSON a2, ToJSON a3) => a1 -> a2 -> a3 -> Value
 mapping c a b = object [  "symbol"   .= pack "lookup"
@@ -478,7 +483,7 @@ instance Typeable a => ToJSON (Exp a t) where
   toJSON (Mul a b) = symbol "*" a b
   toJSON (Div a b) = symbol "/" a b
   toJSON (NewAddr a b) = symbol "newAddr" a b
-  toJSON (IntVar a) = String $ pack a
+  --toJSON (IntVar a) = String $ pack a
   toJSON (LitInt a) = toJSON $ show a
   toJSON (IntMin a) = toJSON $ show $ intmin a
   toJSON (IntMax a) = toJSON $ show $ intmax a
@@ -486,6 +491,7 @@ instance Typeable a => ToJSON (Exp a t) where
   toJSON (UIntMax a) = toJSON $ show $ uintmax a
   toJSON (IntEnv a) = String $ pack $ show a
   toJSON (TEntry t a) = object [ pack (show t) .= toJSON a ]
+  toJSON (Var _ a) = toJSON a
   toJSON (ITE a b c) = object [  "symbol"   .= pack "ite"
                               ,  "arity"    .= Data.Aeson.Types.Number 3
                               ,  "args"     .= Array (fromList [toJSON a, toJSON b, toJSON c])]
@@ -499,7 +505,7 @@ instance Typeable a => ToJSON (Exp a t) where
   toJSON (LEQ a b)  = symbol "<=" a b
   toJSON (GEQ a b)  = symbol ">=" a b
   toJSON (LitBool a) = String $ pack $ show a
-  toJSON (BoolVar a) = toJSON a
+  --toJSON (BoolVar a) = toJSON a
   toJSON (Neg a) = object [  "symbol"   .= pack "not"
                           ,  "arity"    .= Data.Aeson.Types.Number 1
                           ,  "args"     .= Array (fromList [toJSON a])]
@@ -509,7 +515,7 @@ instance Typeable a => ToJSON (Exp a t) where
                                 , "arity"  .= Data.Aeson.Types.Number 3
                                 , "args"   .= Array (fromList [toJSON s, toJSON a, toJSON b])
                                 ]
-  toJSON (ByVar a) = toJSON a
+  --toJSON (ByVar a) = toJSON a
   toJSON (ByStr a) = toJSON a
   toJSON (ByLit a) = String . pack $ show a
   toJSON (ByEnv a) = String . pack $ show a
@@ -571,13 +577,16 @@ uintmin _ = 0
 uintmax :: Int -> Integer
 uintmax a = 2 ^ a - 1
 
-castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
-castTime = gcast
+mkVar :: SingI a => Id -> Exp a t
+mkVar name = Var sing name
+
+-- castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
+-- castTime = gcast
 
-castType :: (Typeable a, Typeable x) => Exp x t -> Maybe (Exp a t)
-castType = gcast0
+-- castType :: (Typeable a, Typeable x) => Exp x t -> Maybe (Exp a t)
+-- castType = gcast0
 
--- | Analogous to `gcast1` and `gcast2` from `Data.Typeable`. We *could* technically use `cast` instead
--- but then we would catch too many errors at once, so we couldn't emit informative error messages.
-gcast0 :: forall t t' a. (Typeable t, Typeable t') => t a -> Maybe (t' a)
-gcast0 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))
+-- -- | Analogous to `gcast1` and `gcast2` from `Data.Typeable`. We *could* technically use `cast` instead
+-- -- but then we would catch too many errors at once, so we couldn't emit informative error messages.
+-- gcast0 :: forall t t' a. (Typeable t, Typeable t') => t a -> Maybe (t' a)
+-- gcast0 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))
diff --git a/src/Type.hs b/src/Type.hs
index 35ab6022..5414d3e4 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -23,6 +23,7 @@ import Type.Reflection (typeRep)
 import Data.ByteString (ByteString)
 
 import Control.Applicative
+import Control.Lens.Operators ((??))
 import Control.Monad (join,unless)
 import Control.Monad.Writer
 import Data.List.Extra (snoc,unsnoc)
@@ -66,7 +67,6 @@ noDuplicateVars (U.Creates assigns) = noDuplicates (fmap fst . fromAssign <$> as
 noDuplicates :: [(Pn,Id)] -> (Id -> String) -> Err ()
 noDuplicates xs errmsg = traverse_ (throw . fmap errmsg) . duplicatesBy ((==) `on` snd) $ xs
 
-
 --- Finds storage declarations from constructors
 lookupVars :: [U.RawBehaviour] -> Store
 lookupVars = foldMap $ \case
@@ -193,11 +193,11 @@ noStorageRead store expr = for_ (keys store) $ \name ->
     throw (pn,"Cannot read storage in creates block")
 
 makeUpdate :: Env -> Sing a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
-makeUpdate env@Env{contract} typ name ixs newVal =
+makeUpdate env@Env{contract} typ name ixs newVal = let item = Item typ contract name ixs in
   case typ of
-    SInteger -> IntUpdate   (IntItem   contract name ixs) newVal
-    SBoolean -> BoolUpdate  (BoolItem  contract name ixs) newVal
-    SByteStr -> BytesUpdate (BytesItem contract name ixs) newVal
+    SInteger -> IntUpdate   item newVal
+    SBoolean -> BoolUpdate  item newVal--(BoolItem  contract name ixs) newVal
+    SByteStr -> BytesUpdate item newVal--(BytesItem contract name ixs) newVal
 
 -- ensures that key types match value types in an U.Assign
 checkAssign :: Env -> U.Assign -> Err [StorageUpdate]
@@ -277,7 +277,7 @@ checkStorageExpr env@Env{contract,store} (U.PEntry p name args) expr = case Map.
     makeUpdate env typ' name [] <$> inferExpr env typ' expr
   Just (StorageMapping argtyps valType) -> withSomeType (metaType valType) $ \valType' ->
     makeUpdate env valType' name <$> checkIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env valType' expr
-  Nothing -> throw (p, "Unknown storage variable: " <> show name)
+  Nothing -> throw (p, "Unknown storage variable " <> show name)
 
 checkPattern :: Env -> U.Pattern -> Err StorageLocation
 checkPattern _ (U.PWild _) = error "TODO: checkPattern for Wild storage"
@@ -285,15 +285,14 @@ checkPattern env@Env{contract,store} (U.PEntry p name args) =
   case Map.lookup name store of
     Just (StorageValue t) -> makeLocation t []
     Just (StorageMapping argtyps t) -> makeLocation t (NonEmpty.toList argtyps)
-    Nothing -> throw (p, "Unknown storage variable: " <> show name)
+    Nothing -> throw (p, "Unknown storage variable " <> show name)
   where
     makeLocation :: AbiType -> [AbiType] -> Err StorageLocation
-    makeLocation locType argTypes = do
-      indexExprs <- checkIxs env p args argTypes -- TODO possibly output errormsg with `name` in `checkIxs`?
-      pure $ case metaType locType of
-        Integer -> IntLoc   $ IntItem   contract name indexExprs
-        Boolean -> BoolLoc  $ BoolItem  contract name indexExprs
-        ByteStr -> BytesLoc $ BytesItem contract name indexExprs
+    makeLocation locType argTypes = withSomeType (metaType locType) $ \locType' ->
+      case locType' of
+        SInteger -> IntLoc   . Item locType' contract name <$> checkIxs env p args argTypes
+        --SBoolean -> BoolLoc  <$> item
+        --SByteStr -> BytesLoc <$> item
 
 checkIffs :: Env -> [U.IffH] -> Err [Exp Bool Untimed]
 checkIffs env = foldr check (pure [])
@@ -336,42 +335,42 @@ checkExpr env e typ = case metaType typ of
 
 -- | Attempt to typecheck an untyped expression as any possible type.
 typedExp :: Typeable t => Env -> U.Expr -> Err (TypedExp t)
-typedExp env e = ExpInt   <$> inferExpr env sing e
-             <!> ExpBool  <$> inferExpr env sing e
-             <!> ExpBytes <$> inferExpr env sing e
-             <!> throw (getPosn e, "TypedExp: no suitable type") -- TODO improve error handling once we've merged the unified stuff!
+typedExp env e = notAtPosn (getPosn e)
+                    $ A (ExpInt <$> inferExpr env sing e)
+                  <!> A (ExpBool <$> inferExpr env sing e)
+                  <!> A (ExpBytes <$> inferExpr env sing e)
 
 -- | Attempts to construct an expression with the type and timing required by
 -- the caller. If this is impossible, an error is thrown instead.
 inferExpr :: forall a t. (Typeable a, Typeable t) => Env -> Sing a -> U.Expr -> Err (Exp a t)
 inferExpr env@Env{contract,store,calldata} typ expr = case expr of
-  U.ENot    p v1    -> check p $ Neg  <$> inferExpr env sing v1
-  U.EAnd    p v1 v2 -> check p $ And  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EOr     p v1 v2 -> check p $ Or   <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EImpl   p v1 v2 -> check p $ Impl <$> inferExpr env sing v1 <*> inferExpr env sing v2
+  U.ENot    p v1    -> check p <*> (Neg  <$> inferExpr env sing v1)
+  U.EAnd    p v1 v2 -> check p <*> (And  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EOr     p v1 v2 -> check p <*> (Or   <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EImpl   p v1 v2 -> check p <*> (Impl <$> inferExpr env sing v1 <*> inferExpr env sing v2)
   U.EEq     p v1 v2 -> polycheck p Eq v1 v2
   U.ENeq    p v1 v2 -> polycheck p NEq v1 v2
-  U.ELT     p v1 v2 -> check p $ LE   <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.ELEQ    p v1 v2 -> check p $ LEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EGEQ    p v1 v2 -> check p $ GEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EGT     p v1 v2 -> check p $ GE   <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EAdd    p v1 v2 -> check p $ Add  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.ESub    p v1 v2 -> check p $ Sub  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EMul    p v1 v2 -> check p $ Mul  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EDiv    p v1 v2 -> check p $ Div  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EMod    p v1 v2 -> check p $ Mod  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.EExp    p v1 v2 -> check p $ Exp  <$> inferExpr env sing v1 <*> inferExpr env sing v2
-  U.IntLit  p v1    -> check p . pure $ LitInt v1
-  U.BoolLit p v1    -> check p . pure $ LitBool v1
+  U.ELT     p v1 v2 -> check p <*> (LE   <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.ELEQ    p v1 v2 -> check p <*> (LEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EGEQ    p v1 v2 -> check p <*> (GEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EGT     p v1 v2 -> check p <*> (GE   <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EAdd    p v1 v2 -> check p <*> (Add  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.ESub    p v1 v2 -> check p <*> (Sub  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EMul    p v1 v2 -> check p <*> (Mul  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EDiv    p v1 v2 -> check p <*> (Div  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EMod    p v1 v2 -> check p <*> (Mod  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.EExp    p v1 v2 -> check p <*> (Exp  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.IntLit  p v1    -> check p ?? LitInt v1
+  U.BoolLit p v1    -> check p ?? LitBool v1
   U.EITE    _ v1 v2 v3 -> ITE <$> inferExpr env sing v1 <*> inferExpr env typ v2 <*> inferExpr env typ v3
-  U.EUTEntry   p name es -> checkTime p $ entry p Neither name es
-  U.EPreEntry  p name es -> checkTime p $ entry p Pre     name es
-  U.EPostEntry p name es -> checkTime p $ entry p Post    name es
+  U.EUTEntry   p name es -> checkTime p <*> entry p Neither name es
+  U.EPreEntry  p name es -> checkTime p <*> entry p Pre     name es
+  U.EPostEntry p name es -> checkTime p <*> entry p Post    name es
   U.EnvExp p v1 -> case lookup v1 defaultStore of
-    Just Integer -> check p . pure $ IntEnv v1
-    Just ByteStr -> check p . pure $ ByEnv  v1
-    _            -> throw (p, "unknown environment variable: " <> show v1)
-  v -> error $ "internal error: infer type of:" <> show v
+    Just Integer -> check p ?? IntEnv v1
+    Just ByteStr -> check p ?? ByEnv  v1
+    _            -> throw (p, "unknown environment variable " <> show v1)
+  v -> error $ "internal error: infer type of" <> show v
   -- Wild ->
   -- Zoom Var Exp
   -- Func Var [U.Expr]
@@ -384,60 +383,46 @@ inferExpr env@Env{contract,store,calldata} typ expr = case expr of
   -- BYAbiE U.Expr
   -- StringLit String
   where
---    expected = sing @a
---
---    check' :: Typeable x => Sing x -> Pn -> Exp x t0 -> Err (Exp a t0)
---    check' actual pn = validate
---                        [(pn,"Type mismatch. Expected " <> show expected <> ", got " <> show actual <> ".")]
---                        castType
-
-    -- Try to cast the type parameter of an expression to the goal of `inferExpr`,
-    -- or throw an error.
-    check :: forall x t0. Typeable x => Pn -> Err (Exp x t0) -> Err (Exp a t0)
-    check pn = ensure
-                [(pn,"Type mismatch. Expected " <> show (typeRep @a) <> ", got " <> show (typeRep @x) <> ".")]
-                castType
-              
-    checkTime :: forall x t0. Typeable t0 => Pn -> Err (Exp x t0) -> Err (Exp x t)
-    checkTime pn = ensure
-                    [(pn, (tail . show $ typeRep @t) <> " variable needed here!")]
-                    castTime
+    check :: forall x t0. Typeable x => Pn -> Err (Exp x t0 -> Exp a t0)
+    check pn = case eqT @a @x of
+      Just Refl -> pure id
+      Nothing   -> throw (pn,"Type mismatch. Expected " <> show (typeRep @a) <> ", got " <> show (typeRep @x))
+
+    checkTime :: forall x t0. (Typeable t0, Typeable x) => Pn -> Err (Exp x t0 -> Exp x t)
+    checkTime pn = case eqT @t @t0 of
+      Just Refl -> pure id
+      Nothing   -> throw (pn, (tail . show $ typeRep @t) <> " variable needed here")
 
     -- Takes a polymorphic binary AST constructor and specializes it to each of
     -- our types. Those specializations are used in order to guide the
     -- typechecking of the two supplied expressions. Returns at first success.
     polycheck :: Typeable x => Pn -> (forall y. (Eq y, Typeable y) => Exp y t -> Exp y t -> Exp x t) -> U.Expr -> U.Expr -> Err (Exp a t)
-    polycheck pn cons e1 e2 = check pn (cons @Integer    <$> inferExpr env sing e1 <*> inferExpr env sing e2)
-                          <!> check pn (cons @Bool       <$> inferExpr env sing e1 <*> inferExpr env sing e2)
-                          <!> check pn (cons @ByteString <$> inferExpr env sing e1 <*> inferExpr env sing e2)
-                          <!> throw (pn, "Couldn't harmonize types!") -- TODO improve error handling once we've merged the unified stuff!
+    polycheck pn cons e1 e2 = check pn <*> (cons @Integer    <$> inferExpr env sing e1 <*> inferExpr env sing e2)
+                          <!> check pn <*> (cons @Bool       <$> inferExpr env sing e1 <*> inferExpr env sing e2)
+                          <!> check pn <*> (cons @ByteString <$> inferExpr env sing e1 <*> inferExpr env sing e2)
+                          <!> throw (pn, "Type mismatch. Left- and right-hand sides do not match")
 
     -- Try to construct a reference to a calldata variable or an item in storage.
     entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [U.Expr] -> Err (Exp a t0)
     entry pn timing name es = case (Map.lookup name store, Map.lookup name calldata) of
-      (Nothing, Nothing) -> throw (pn, "Unknown variable: " <> name)
-      (Just _, Just _)   -> throw (pn, "Ambiguous variable: " <> name)
-      (Nothing, Just c) -> if isTimed timing then throw (pn, "Calldata var cannot be pre/post.") else case c of
-        -- Create a calldata reference and typecheck it as with normal expressions.
-        Integer -> check pn . pure $ IntVar  name
-        Boolean -> check pn . pure $ BoolVar name
-        ByteStr -> check pn . pure $ ByVar   name
+      (Nothing, Nothing) -> throw (pn, "Unknown variable " <> name)
+      (Just _, Just _)   -> throw (pn, "Ambiguous variable " <> name)
+      (Nothing, Just c) -> if isTimed timing then throw (pn, "Calldata var cannot be pre/post") else
+        withSomeType c $ \vartyp -> check pn ?? Var vartyp name
+          ---- Create a calldata reference and typecheck it as with normal expressions.
+         --Integer -> check pn ?? IntVar  name
+          --Boolean -> check pn ?? BoolVar name
+          --ByteStr -> check pn ?? ByVar   name
       (Just (StorageValue a), Nothing)      -> checkEntry a []
       (Just (StorageMapping ts a), Nothing) -> checkEntry a $ NonEmpty.toList ts
       where
         checkEntry :: AbiType -> [AbiType] -> Err (Exp a t0)
-        checkEntry a ts = case metaType a of
-          Integer -> check pn $ using IntItem
-          Boolean -> check pn $ using BoolItem
-          ByteStr -> check pn $ using BytesItem
-          where
-            -- Using the supplied constructor, create a `TStorageItem` and then place it in a `TEntry`.
-            using :: Typeable x => (Id -> Id -> [TypedExp t0] -> TStorageItem x t0) -> Err (Exp x t0)
-            using cons = TEntry timing . cons contract name <$> checkIxs env pn es ts
+        checkEntry a ts = withSomeType (metaType a) $ \entrytyp ->
+          check pn <*> (TEntry timing . Item typ contract name <$> checkIxs env pn es ts)
 
 checkIxs :: Typeable t => Env -> Pn -> [U.Expr] -> [AbiType] -> Err [TypedExp t]
 checkIxs env pn exprs types = if length exprs /= length types
-                              then throw (pn, "Index mismatch for entry!")
+                              then throw (pn, "Index mismatch for entry")
                               else traverse (uncurry $ checkExpr env) (exprs `zip` types)
 
 -- checkIxs' :: Typeable t => Env -> Pn -> [U.Expr] -> [AbiType] -> Logger TypeErr [TypedExp t]

From db8b853002caf474cfc87b12bb9714d42a188608 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Wed, 15 Sep 2021 20:42:19 +0200
Subject: [PATCH 08/36] new error handling done in `Type.hs`

---
 src/Error.hs                                  |  45 ++++++
 src/ErrorLogger.hs                            |  62 --------
 src/Print.hs                                  |   4 +-
 src/Syntax.hs                                 |  17 +-
 src/Syntax/TimeAgnostic.hs                    |  81 +++++-----
 src/Type.hs                                   | 146 +++++++++---------
 src/act.cabal                                 |   5 +-
 tests/frontend/pass/array/array.act.parsed.hs |   2 +-
 .../pass/creation/create.act.parsed.hs        |   2 +-
 .../creation/createMultiple.act.parsed.hs     |   2 +-
 tests/frontend/pass/dss/vat.act.parsed.hs     |   2 +-
 tests/frontend/pass/multi/multi.act.parsed.hs |   2 +-
 .../pass/safemath/safemathraw.act.parsed.hs   |   2 +-
 tests/frontend/pass/smoke/smoke.act.parsed.hs |   2 +-
 .../staticstore/staticstore.act.parsed.hs     |   2 +-
 .../pass/token/transfer.act.parsed.hs         |   2 +-
 16 files changed, 170 insertions(+), 208 deletions(-)
 create mode 100644 src/Error.hs
 delete mode 100644 src/ErrorLogger.hs

diff --git a/src/Error.hs b/src/Error.hs
new file mode 100644
index 00000000..0c85529b
--- /dev/null
+++ b/src/Error.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedLists,TypeOperators, LambdaCase, AllowAmbiguousTypes, TypeApplications, TypeFamilies, DeriveFunctor, ConstraintKinds, UndecidableInstances, FlexibleContexts, FlexibleInstances, RankNTypes, KindSignatures, ApplicativeDo, MultiParamTypeClasses, ScopedTypeVariables, InstanceSigs #-}
+
+module Error where
+
+import Control.Monad.Writer hiding (Alt)
+import Data.Functor
+import Data.Functor.Alt
+import Data.List.NonEmpty as NE
+import Data.Validation
+import Data.Proxy
+import Data.Reflection
+import GHC.Generics
+
+import Syntax.Untyped (Pn)
+
+type Error e = Validation (NonEmpty (Pn,e))
+
+throw :: (Pn,e) -> Error e a
+throw msg = Failure [msg]
+
+-- | If there is no error at the supplied position, we accept this result and
+-- do not attempt to run any later branches, even if there were other errors.
+-- (The second argument looks intimidating but it simply demands that each
+-- @'Error' e a@ branch is wrapped in 'A' before being passed to '(<!>)'.)
+notAtPosn :: Pn -> (forall s. Reifies s (Alt_ (Error e)) => A s (Error e) a) -> Error e a
+notAtPosn p = withAlt $ \case
+  Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
+  res         -> const res
+
+-- | Wraps any functor in a type that can be supplied a custom 'Alt' instance. 
+newtype A s f a = A { runA :: f a }
+  deriving Functor
+
+-- | The type of custom 'Alt' instances.
+newtype Alt_ f = Alt_ { alt :: forall a. f a -> f a -> f a }
+
+-- | Given a proof that we can reify a custom 'Alt' instance on the wrapped
+-- functor, we can give it an actual 'Alt' instance (allows using '(<!>)').
+instance (Functor f, Reifies s (Alt_ f)) => Alt (A s f) where
+  A l <!> A r = A $ alt (reflect @s Proxy) l r
+
+-- | The first argument is used as a custom 'Alt' instance when evaluating
+-- a functor wrapped in 'A'.
+withAlt :: (forall a. f a -> f a -> f a) -> (forall s. Reifies s (Alt_ f) => A s f b) -> f b
+withAlt alt_ comp = reify (Alt_ alt_) $ \(_ :: Proxy s) -> runA @s comp
diff --git a/src/ErrorLogger.hs b/src/ErrorLogger.hs
deleted file mode 100644
index 5c988d6e..00000000
--- a/src/ErrorLogger.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-{-# LANGUAGE OverloadedLists,TypeOperators, LambdaCase, AllowAmbiguousTypes, TypeApplications, TypeFamilies, DeriveFunctor, ConstraintKinds, UndecidableInstances, FlexibleContexts, FlexibleInstances, RankNTypes, KindSignatures, ApplicativeDo, MultiParamTypeClasses, ScopedTypeVariables, InstanceSigs #-}
-
-module ErrorLogger (module ErrorLogger) where
-
-import Control.Lens as ErrorLogger ((#))
-import Control.Monad.Writer hiding (Alt)
-import Data.Functor
-import Data.Functor.Alt
-import Data.List.NonEmpty as NE
-import Data.Validation as ErrorLogger
-import Data.Proxy
-import Data.Reflection
-import GHC.Generics
-
-import Syntax.Untyped (Pn)
-
-type Error e = Validation (NonEmpty (Pn,e))
-
-throw :: (Pn,e) -> Error e a
-throw msg = _Failure # [msg]
-
-notAtPosn :: Pn -> (forall s. Reifies s (AltDict (Error e)) => A s (Error e) a) -> Error e a
-notAtPosn p = withAlt $ \case
-  Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
-  res         -> const res
-
--- notAtPosn' :: forall e a. Pn -> (forall s. Reifies s (Def Alt (Error e)) => Lift Alt (Error e) s a) -> Error e a
--- notAtPosn' p = flip (with @Alt @(Error e)) undefined $ \case
---   Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
---   res         -> const res
-
-
--- newtype Lift (p :: (* -> *) -> Constraint) (f :: * -> *) (s :: * -> *) a = Lift { lower :: f a } deriving (Functor)
-
--- class ReifiableConstraint p where
---   data Def (p :: (* -> *) -> Constraint) (f :: * -> *) :: *
---   reifiedIns :: Reifies s (Def p f) :- p (Lift p f s)
-
-
--- instance Functor f => ReifiableConstraint Alt where
---   data Def Alt f = Alt { alt_ :: forall a. f a -> f a -> f a }
---   reifiedIns = Sub Dict
-
-
--- instance (Functor (Lift Alt f s), Reifies s (Def Alt f)) => Alt (Lift Alt f s) where
---   Lift a <!> Lift b = let alt' = alt_ $ reflect (Proxy @s)
---                        in Lift $ a `alt'` b
-
--- with :: forall p f a. Def p f -> (forall (s :: * -> *). Reifies s (Def p f) => Lift p f s a) -> f a
--- with d comp = reify @(Def p f) d $ ((\(Proxy :: Proxy (s :: * -> *)) -> lower (comp @s)) :: forall (s :: * -> *). Reifies s (Def p f) => Proxy s -> f a)
-
-
-newtype A s f a = A { runA :: f a } deriving (Show, Functor)
-
-newtype AltDict f = AltDict { alt :: forall a. f a -> f a -> f a }
-
-instance (Functor (A s f), Reifies s (AltDict f)) => Alt (A s f) where
- A l <!> A r = let alt_ = alt $ reflect (Proxy @s)
-                in A $ l `alt_` r
-
-withAlt :: (forall a. f a -> f a -> f a) -> (forall s. Reifies s (AltDict f) => A s f b) -> f b
-withAlt alt_ comp = reify (AltDict alt_) $ \(_ :: Proxy s) -> runA (comp @s)
diff --git a/src/Print.hs b/src/Print.hs
index 5af5aa60..bcb5964e 100644
--- a/src/Print.hs
+++ b/src/Print.hs
@@ -52,7 +52,6 @@ prettyExp e = case e of
   Neg a -> "(not " <> prettyExp a <> ")"
   Impl a b -> print2 "=>" a b
   LitBool b -> if b then "true" else "false"
-  BoolVar b -> b
 
   -- integers
   Add a b -> print2 "+" a b
@@ -66,13 +65,11 @@ prettyExp e = case e of
   IntMax a -> show $ intmax a
   IntMin a -> show $ intmin a
   LitInt a -> show a
-  IntVar a -> a
   IntEnv a -> prettyEnv a
 
   -- bytestrings
   Cat a b -> print2 "++" a b
   Slice a b c -> (prettyExp a) <> "[" <> (prettyExp b) <> ":" <> (prettyExp c) <> "]"
-  ByVar a -> a
   ByStr a -> a
   ByLit a -> toString a
   ByEnv a -> prettyEnv a
@@ -83,6 +80,7 @@ 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 -> x
   where
     print2 sym a b = "(" <> prettyExp a <> " " <> sym <> " " <> prettyExp b <> ")"
 
diff --git a/src/Syntax.hs b/src/Syntax.hs
index f98db577..ccf3ab09 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE GADTs #-}
 
+{-# LANGUAGE PatternSynonyms #-}
+
 {-|
 Module      : Syntax
 Description : Functions for manipulating and collapsing all our different ASTs.
@@ -9,8 +11,6 @@ module Syntax where
 import Data.List
 import Data.Map (Map,empty,insertWith,unionsWith)
 
-import EVM.ABI (AbiType(..))
-
 import Syntax.TimeAgnostic as Agnostic
 import qualified Syntax.Annotated as Annotated
 import           Syntax.Untyped hiding (Constant,Rewrite)
@@ -184,19 +184,6 @@ ethEnvFromExp = nub . go
       TEntry _ a -> ethEnvFromItem a
       Var _ _ -> []
 
-metaType :: AbiType -> MType
-metaType (AbiUIntType _)     = Integer
-metaType (AbiIntType  _)     = Integer
-metaType AbiAddressType      = Integer
-metaType AbiBoolType         = Boolean
-metaType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
-metaType AbiBytesDynamicType = ByteStr
-metaType AbiStringType       = ByteStr
---metaType (AbiArrayDynamicType a) =
---metaType (AbiArrayType        Int AbiType
---metaType (AbiTupleType        (Vector AbiType)
-metaType _ = error "Extract.metaType: TODO"
-
 idFromRewrite :: Rewrite t -> Id
 idFromRewrite = onRewrite idFromLocation idFromUpdate
 
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index c217902b..8f7b1de1 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -12,7 +12,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 
-{-# LANGUAGE RankNTypes, StandaloneKindSignatures #-}
+{-# LANGUAGE RankNTypes, StandaloneKindSignatures, PatternSynonyms, ViewPatterns #-}
 
 {-|
 Module      : Syntax.TimeAgnostic
@@ -50,9 +50,31 @@ import EVM.ABI (AbiType(..))
 import Syntax.Timing  as Syntax.TimeAgnostic
 import Syntax.Untyped as Syntax.TimeAgnostic (Id, Interface(..), EthEnv(..), Decl(..))
 
-
 import Data.Singletons
 
+--types understood by proving tools
+data MType
+  = Integer
+  | Boolean
+  | ByteStr
+  deriving (Eq, Ord, Show, Read)
+
+metaType :: AbiType -> MType
+metaType (AbiUIntType _)     = Integer
+metaType (AbiIntType  _)     = Integer
+metaType AbiAddressType      = Integer
+metaType AbiBoolType         = Boolean
+metaType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
+metaType AbiBytesDynamicType = ByteStr
+metaType AbiStringType       = ByteStr
+--metaType (AbiArrayDynamicType a) =
+--metaType (AbiArrayType        Int AbiType
+--metaType (AbiTupleType        (Vector AbiType)
+metaType _ = error "Extract.metaType: TODO"
+
+pattern FromAbi t <- (metaType -> FromSing (STypeable t))
+pattern FromMeta t <- FromSing (STypeable t)
+
 data SType a where
   SInteger :: SType Integer
   SBoolean :: SType Bool
@@ -60,41 +82,27 @@ data SType a where
 deriving instance Show (SType a)
 deriving instance Eq (SType a)
 
-(~==) :: SType a -> SType b -> Bool
-SInteger ~== SInteger = True
-SBoolean ~== SBoolean = True
-SByteStr ~== SByteStr = True
-_        ~== _        = False
+data STypeable a where
+  STypeable :: Typeable a => SType a -> STypeable a
+deriving instance Show (STypeable a)
+deriving instance Eq (STypeable a)
 
-type instance Sing = SType
+type instance Sing = STypeable
 
-instance SingI Integer where sing = SInteger
-instance SingI Bool where sing = SBoolean
-instance SingI ByteString where sing = SByteStr
+instance SingI Integer    where sing = STypeable SInteger
+instance SingI Bool       where sing = STypeable SBoolean
+instance SingI ByteString where sing = STypeable SByteStr
 
 instance SingKind * where
   type Demote * = MType
 
-  fromSing SInteger = Integer
-  fromSing SBoolean = Boolean
-  fromSing SByteStr = ByteStr
-
-  toSing Integer = SomeSing SInteger
-  toSing Boolean = SomeSing SBoolean
-  toSing ByteStr = SomeSing SByteStr
+  fromSing (STypeable SInteger) = Integer
+  fromSing (STypeable SBoolean) = Boolean
+  fromSing (STypeable SByteStr) = ByteStr
 
-
-class TypeableSing k where
-  isTypeableSing :: Sing (a :: k) -> (Typeable a => r) -> r
-
-instance TypeableSing * where
-  isTypeableSing SInteger r = r
-  isTypeableSing SBoolean r = r
-  isTypeableSing SByteStr r = r
-
-withSomeType :: forall k r. (SingKind k, TypeableSing k)
-             => Demote k -> (forall (a :: k). Typeable a => Sing a -> r) -> r
-withSomeType x f = withSomeSing x $ \s -> isTypeableSing s (f s)
+  toSing Integer = SomeSing (STypeable SInteger)
+  toSing Boolean = SomeSing (STypeable SBoolean)
+  toSing ByteStr = SomeSing (STypeable SByteStr)
 
 -- AST post typechecking
 data Claim t
@@ -169,13 +177,6 @@ data Mode
   | OOG
   deriving (Eq, Show)
 
---types understood by proving tools
-data MType
-  = Integer
-  | Boolean
-  | ByteStr
-  deriving (Eq, Ord, Show, Read)
-
 data Rewrite t
   = Constant (StorageLocation t)
   | Rewrite (StorageUpdate t)
@@ -201,7 +202,7 @@ data StorageLocation t
 -- refer to the pre-/post-state, or not. `a` is the type of the item that is
 -- referenced.
 data TStorageItem (a :: *) (t :: Timing) where
-  Item :: Sing a -> Id -> Id -> [TypedExp t] -> TStorageItem a t
+  Item :: SType a -> Id -> Id -> [TypedExp t] -> TStorageItem a t
 --  IntItem    :: Id -> Id -> [TypedExp t] -> TStorageItem Integer t
 --  BoolItem   :: Id -> Id -> [TypedExp t] -> TStorageItem Bool t
 --  BytesItem  :: Id -> Id -> [TypedExp t] -> TStorageItem ByteString t
@@ -237,7 +238,7 @@ data Exp (a :: *) (t :: Timing) where
   GEQ :: Exp Integer t -> Exp Integer t -> Exp Bool t
   GE :: Exp Integer t -> Exp Integer t -> Exp Bool t
   LitBool :: Bool -> Exp Bool t
-  Var :: Sing a -> Id -> Exp a t
+  Var :: SType a -> Id -> Exp a t
   -- integers
   Add :: Exp Integer t -> Exp Integer t -> Exp Integer t
   Sub :: Exp Integer t -> Exp Integer t -> Exp Integer t
@@ -578,7 +579,7 @@ uintmax :: Int -> Integer
 uintmax a = 2 ^ a - 1
 
 mkVar :: SingI a => Id -> Exp a t
-mkVar name = Var sing name
+mkVar name = let STypeable t = sing in Var t name
 
 -- castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
 -- castTime = gcast
diff --git a/src/Type.hs b/src/Type.hs
index 5414d3e4..ac544196 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -42,7 +42,7 @@ import Syntax.Untyped (Pn)
 --import Syntax.Untyped hiding (Post,Constant,Rewrite)
 import qualified Syntax.Untyped as U
 import Syntax.Typed
-import ErrorLogger
+import Error
 import Parse
 
 type Err a = Error TypeErr a
@@ -58,11 +58,11 @@ typecheck behvs = (S store:) . concat <$> traverse (splitBehaviour store) behvs
 
 noDuplicateContracts :: [U.RawBehaviour] -> Err ()
 noDuplicateContracts behvs = noDuplicates [(pn,contract) | U.Definition pn contract _ _ _ _ _ _ <- behvs]
-                             $ \c -> "Multiple definitions of " <> c <> "."
+                             $ \c -> "Multiple definitions of " <> c
 
 noDuplicateVars :: U.Creates -> Err ()
 noDuplicateVars (U.Creates assigns) = noDuplicates (fmap fst . fromAssign <$> assigns)
-                                      $ \x -> "Multiple definitions of " <> x <> "."
+                                      $ \x -> "Multiple definitions of " <> x
 
 noDuplicates :: [(Pn,Id)] -> (Id -> String) -> Err ()
 noDuplicates xs errmsg = traverse_ (throw . fmap errmsg) . duplicatesBy ((==) `on` snd) $ xs
@@ -129,7 +129,7 @@ splitBehaviour store (U.Transition pn name contract iface@(Interface _ decls) if
   -- constrain integer calldata variables (TODO: other types)
   fmap concatMap (caseClaims
                     <$> checkIffs env iffs
-                    <*> traverse (inferExpr env sing) posts)
+                    <*> traverse (inferExpr env) posts)
     <*> traverse (checkCase env) normalizedCases
   <* noIllegalWilds
   where
@@ -167,8 +167,8 @@ splitBehaviour store (U.Definition pn contract iface@(Interface _ decls) iffs (U
   in do
     stateUpdates <- concat <$> traverse (checkAssign env) assigns
     iffs' <- checkIffs env iffs
-    invariants <- traverse (inferExpr env sing) invs
-    ensures <- traverse (inferExpr env sing) postcs
+    invariants <- traverse (inferExpr env) invs
+    ensures <- traverse (inferExpr env) postcs
 
     pure $ invrClaims invariants <> ctorClaims stateUpdates iffs' ensures
   where
@@ -179,12 +179,10 @@ splitBehaviour store (U.Definition pn contract iface@(Interface _ decls) iffs (U
                      , C $ Constructor contract Fail iface [Neg (mconcat iffs')] ensures []      [] ]
 
 checkCase :: Env -> U.Case -> Err ([Exp Bool Untimed], [Rewrite], Maybe (TypedExp Timed))
-checkCase env c@(U.Case pn pre post)
-  | isWild c  = checkCase env (U.Case pn (U.BoolLit (getPosn pre) True) post)
-  | otherwise = do
-      if' <- inferExpr env sing pre
-      (storage,return) <- checkPost env post
-      pure ([if'],storage,return)
+checkCase env c@(U.Case _ pre post) = do
+  if' <- traverse (inferExpr env) $ if isWild c then [] else [pre]
+  (storage,return) <- checkPost env post
+  pure (if',storage,return)
 
 -- | Ensures that none of the storage variables are read in the supplied `Expr`.
 noStorageRead :: Map Id SlotType -> U.Expr -> Err ()
@@ -192,7 +190,7 @@ noStorageRead store expr = for_ (keys store) $ \name ->
   for_ (findWithDefault [] name (idFromRewrites expr)) $ \pn ->
     throw (pn,"Cannot read storage in creates block")
 
-makeUpdate :: Env -> Sing a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
+makeUpdate :: Env -> SType a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
 makeUpdate env@Env{contract} typ name ixs newVal = let item = Item typ contract name ixs in
   case typ of
     SInteger -> IntUpdate   item newVal
@@ -201,14 +199,13 @@ makeUpdate env@Env{contract} typ name ixs newVal = let item = Item typ contract
 
 -- ensures that key types match value types in an U.Assign
 checkAssign :: Env -> U.Assign -> Err [StorageUpdate]
-checkAssign env@Env{contract, store} (U.AssignVal (U.StorageVar pn (StorageValue typ) name) expr)
-  = withSomeType (metaType typ) $ \stype ->
-      sequenceA [makeUpdate env stype name [] <$> inferExpr env stype expr]
-        <* noStorageRead store expr
+checkAssign env@Env{contract, store} (U.AssignVal (U.StorageVar pn (StorageValue (FromAbi typ)) name) expr)
+  = sequenceA [makeUpdate env typ name [] <$> inferExpr env expr]
+    <* noStorageRead store expr
 checkAssign env@Env{store} (U.AssignMany (U.StorageVar pn (StorageMapping (keyType :| _) valType) name) defns)
   = for defns $ \def@(U.Defn e1 e2) -> checkDefn env keyType valType name def
-                                     <* noStorageRead store e1
-                                     <* noStorageRead store e2
+                                       <* noStorageRead store e1
+                                       <* noStorageRead store e2
 checkAssign _ (U.AssignVal (U.StorageVar pn (StorageMapping _ _) _) expr)
   = throw (getPosn expr, "Cannot assign a single expression to a composite type")
 checkAssign _ (U.AssignMany (U.StorageVar pn (StorageValue _) _) _)
@@ -218,8 +215,8 @@ checkAssign _ _ = error "todo: support struct assignment in constructors"
 -- ensures key and value types match when assigning a defn to a mapping
 -- TODO: handle nested mappings
 checkDefn :: Env -> AbiType -> AbiType -> Id -> U.Defn -> Err StorageUpdate
-checkDefn env@Env{contract} keyType valType name (U.Defn k val) = withSomeType (metaType valType) $ \valType' ->
-  makeUpdate env valType' name <$> checkIxs env (getPosn k) [k] [keyType] <*> inferExpr env valType' val
+checkDefn env@Env{contract} keyType (FromAbi valType) name (U.Defn k val) =
+  makeUpdate env valType name <$> checkIxs env (getPosn k) [k] [keyType] <*> inferExpr env val
 
 checkPost :: Env -> U.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
 checkPost env@Env{contract,calldata} (U.Post storage extStorage maybeReturn) = do
@@ -273,10 +270,10 @@ checkPost env@Env{contract,calldata} (U.Post storage extStorage maybeReturn) = d
 checkStorageExpr :: Env -> U.Pattern -> U.Expr -> Err StorageUpdate
 checkStorageExpr _ (U.PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
 checkStorageExpr env@Env{contract,store} (U.PEntry p name args) expr = case Map.lookup name store of
-  Just (StorageValue typ) -> withSomeType (metaType typ) $ \typ' ->
-    makeUpdate env typ' name [] <$> inferExpr env typ' expr
-  Just (StorageMapping argtyps valType) -> withSomeType (metaType valType) $ \valType' ->
-    makeUpdate env valType' name <$> checkIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env valType' expr
+  Just (StorageValue (FromAbi typ)) ->
+    makeUpdate env typ name [] <$> inferExpr env expr
+  Just (StorageMapping argtyps (FromAbi valType)) ->
+    makeUpdate env valType name <$> checkIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env expr
   Nothing -> throw (p, "Unknown storage variable " <> show name)
 
 checkPattern :: Env -> U.Pattern -> Err StorageLocation
@@ -288,26 +285,18 @@ checkPattern env@Env{contract,store} (U.PEntry p name args) =
     Nothing -> throw (p, "Unknown storage variable " <> show name)
   where
     makeLocation :: AbiType -> [AbiType] -> Err StorageLocation
-    makeLocation locType argTypes = withSomeType (metaType locType) $ \locType' ->
-      case locType' of
-        SInteger -> IntLoc   . Item locType' contract name <$> checkIxs env p args argTypes
-        --SBoolean -> BoolLoc  <$> item
-        --SByteStr -> BytesLoc <$> item
+    makeLocation (FromAbi locType) argTypes =
+      let item = Item locType contract name <$> checkIxs @Untimed env p args argTypes
+      in case locType of
+        SInteger -> IntLoc   <$> item
+        SBoolean -> BoolLoc  <$> item
+        SByteStr -> BytesLoc <$> item
 
 checkIffs :: Env -> [U.IffH] -> Err [Exp Bool Untimed]
 checkIffs env = foldr check (pure [])
   where
-    check (U.Iff   _     exps) acc = mappend <$> traverse (inferExpr env sing) exps                    <*> acc
-    check (U.IffIn _ typ exps) acc = mappend <$> traverse (fmap (bound typ) . inferExpr env sing) exps <*> acc
---checkIffs env (U.Iff _ exps:xs) = do
---  hd <- traverse (inferExpr env sing) exps
---  tl <- checkIffs env xs
---  pure $ hd <> tl
---checkIffs env (U.IffIn _ typ exps:xs) = do
---  hd <- traverse (inferExpr env sing) exps
---  tl <- checkIffs env xs
---  pure $ map (bound typ) hd <> tl
---checkIffs _ [] = pure []
+    check (U.Iff   _     exps) acc = mappend <$> traverse (inferExpr env) exps                    <*> acc
+    check (U.IffIn _ typ exps) acc = mappend <$> traverse (fmap (bound typ) . inferExpr env) exps <*> acc
 
 bound :: AbiType -> Exp Integer t -> Exp Bool t
 bound typ e = And (LEQ (lowerBound typ) e) $ LEQ e (upperBound typ)
@@ -329,43 +318,44 @@ upperBound typ  = error $ "upperBound not implemented for " ++ show typ
 -- The target timing parameter will be whatever is required by the caller.
 checkExpr :: Typeable t => Env -> U.Expr -> AbiType -> Err (TypedExp t)
 checkExpr env e typ = case metaType typ of
-  Integer -> ExpInt <$> inferExpr env sing e
-  Boolean -> ExpBool <$> inferExpr env sing e
-  ByteStr -> ExpBytes <$> inferExpr env sing e
+  Integer -> ExpInt   <$> inferExpr env e
+  Boolean -> ExpBool  <$> inferExpr env e
+  ByteStr -> ExpBytes <$> inferExpr env e
 
 -- | Attempt to typecheck an untyped expression as any possible type.
 typedExp :: Typeable t => Env -> U.Expr -> Err (TypedExp t)
 typedExp env e = notAtPosn (getPosn e)
-                    $ A (ExpInt <$> inferExpr env sing e)
-                  <!> A (ExpBool <$> inferExpr env sing e)
-                  <!> A (ExpBytes <$> inferExpr env sing e)
+    $ A (ExpInt   <$> inferExpr env e)
+  <!> A (ExpBool  <$> inferExpr env e)
+  <!> A (ExpBytes <$> inferExpr env e)
+  <!> error "Internal error: typedExp"
 
 -- | Attempts to construct an expression with the type and timing required by
 -- the caller. If this is impossible, an error is thrown instead.
-inferExpr :: forall a t. (Typeable a, Typeable t) => Env -> Sing a -> U.Expr -> Err (Exp a t)
-inferExpr env@Env{contract,store,calldata} typ expr = case expr of
-  U.ENot    p v1    -> check p <*> (Neg  <$> inferExpr env sing v1)
-  U.EAnd    p v1 v2 -> check p <*> (And  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EOr     p v1 v2 -> check p <*> (Or   <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EImpl   p v1 v2 -> check p <*> (Impl <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+inferExpr :: forall a t. (Typeable a, Typeable t) => Env -> U.Expr -> Err (Exp a t)
+inferExpr env@Env{contract,store,calldata} expr = case expr of
+  U.ENot    p v1    -> check p <*> (Neg  <$> inferExpr env v1)
+  U.EAnd    p v1 v2 -> check p <*> (And  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EOr     p v1 v2 -> check p <*> (Or   <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EImpl   p v1 v2 -> check p <*> (Impl <$> inferExpr env v1 <*> inferExpr env v2)
   U.EEq     p v1 v2 -> polycheck p Eq v1 v2
   U.ENeq    p v1 v2 -> polycheck p NEq v1 v2
-  U.ELT     p v1 v2 -> check p <*> (LE   <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.ELEQ    p v1 v2 -> check p <*> (LEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EGEQ    p v1 v2 -> check p <*> (GEQ  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EGT     p v1 v2 -> check p <*> (GE   <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EAdd    p v1 v2 -> check p <*> (Add  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.ESub    p v1 v2 -> check p <*> (Sub  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EMul    p v1 v2 -> check p <*> (Mul  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EDiv    p v1 v2 -> check p <*> (Div  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EMod    p v1 v2 -> check p <*> (Mod  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
-  U.EExp    p v1 v2 -> check p <*> (Exp  <$> inferExpr env sing v1 <*> inferExpr env sing v2)
+  U.ELT     p v1 v2 -> check p <*> (LE   <$> inferExpr env v1 <*> inferExpr env v2)
+  U.ELEQ    p v1 v2 -> check p <*> (LEQ  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EGEQ    p v1 v2 -> check p <*> (GEQ  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EGT     p v1 v2 -> check p <*> (GE   <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EAdd    p v1 v2 -> check p <*> (Add  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.ESub    p v1 v2 -> check p <*> (Sub  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EMul    p v1 v2 -> check p <*> (Mul  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EDiv    p v1 v2 -> check p <*> (Div  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EMod    p v1 v2 -> check p <*> (Mod  <$> inferExpr env v1 <*> inferExpr env v2)
+  U.EExp    p v1 v2 -> check p <*> (Exp  <$> inferExpr env v1 <*> inferExpr env v2)
   U.IntLit  p v1    -> check p ?? LitInt v1
   U.BoolLit p v1    -> check p ?? LitBool v1
-  U.EITE    _ v1 v2 v3 -> ITE <$> inferExpr env sing v1 <*> inferExpr env typ v2 <*> inferExpr env typ v3
-  U.EUTEntry   p name es -> checkTime p <*> entry p Neither name es
-  U.EPreEntry  p name es -> checkTime p <*> entry p Pre     name es
-  U.EPostEntry p name es -> checkTime p <*> entry p Post    name es
+  U.EITE    _ v1 v2 v3 -> ITE <$> inferExpr env v1 <*> inferExpr env v2 <*> inferExpr env v3
+  U.EUTEntry   p name es -> entry p Neither name es
+  U.EPreEntry  p name es -> entry p Pre     name es
+  U.EPostEntry p name es -> entry p Post    name es
   U.EnvExp p v1 -> case lookup v1 defaultStore of
     Just Integer -> check p ?? IntEnv v1
     Just ByteStr -> check p ?? ByEnv  v1
@@ -397,18 +387,20 @@ inferExpr env@Env{contract,store,calldata} typ expr = case expr of
     -- our types. Those specializations are used in order to guide the
     -- typechecking of the two supplied expressions. Returns at first success.
     polycheck :: Typeable x => Pn -> (forall y. (Eq y, Typeable y) => Exp y t -> Exp y t -> Exp x t) -> U.Expr -> U.Expr -> Err (Exp a t)
-    polycheck pn cons e1 e2 = check pn <*> (cons @Integer    <$> inferExpr env sing e1 <*> inferExpr env sing e2)
-                          <!> check pn <*> (cons @Bool       <$> inferExpr env sing e1 <*> inferExpr env sing e2)
-                          <!> check pn <*> (cons @ByteString <$> inferExpr env sing e1 <*> inferExpr env sing e2)
-                          <!> throw (pn, "Type mismatch. Left- and right-hand sides do not match")
+    polycheck pn cons e1 e2 = notAtPosn (getPosn e1)
+        $ A (check pn <*> (cons @Integer    <$> inferExpr env e1 <*> inferExpr env e2))
+      <!> A (check pn <*> (cons @Bool       <$> inferExpr env e1 <*> inferExpr env e2))
+      <!> A (check pn <*> (cons @ByteString <$> inferExpr env e1 <*> inferExpr env e2))
+      <!> error "Internal error: polycheck" -- throw (pn, "Type mismatch. Left- and right-hand sides do not match")
 
     -- Try to construct a reference to a calldata variable or an item in storage.
-    entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [U.Expr] -> Err (Exp a t0)
+    entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [U.Expr] -> Err (Exp a t)
     entry pn timing name es = case (Map.lookup name store, Map.lookup name calldata) of
       (Nothing, Nothing) -> throw (pn, "Unknown variable " <> name)
       (Just _, Just _)   -> throw (pn, "Ambiguous variable " <> name)
-      (Nothing, Just c) -> if isTimed timing then throw (pn, "Calldata var cannot be pre/post") else
-        withSomeType c $ \vartyp -> check pn ?? Var vartyp name
+      (Nothing, Just (FromMeta varType)) ->
+        if isTimed timing then throw (pn, "Calldata var cannot be pre/post")
+          else check pn ?? Var varType name
           ---- Create a calldata reference and typecheck it as with normal expressions.
          --Integer -> check pn ?? IntVar  name
           --Boolean -> check pn ?? BoolVar name
@@ -416,9 +408,9 @@ inferExpr env@Env{contract,store,calldata} typ expr = case expr of
       (Just (StorageValue a), Nothing)      -> checkEntry a []
       (Just (StorageMapping ts a), Nothing) -> checkEntry a $ NonEmpty.toList ts
       where
-        checkEntry :: AbiType -> [AbiType] -> Err (Exp a t0)
-        checkEntry a ts = withSomeType (metaType a) $ \entrytyp ->
-          check pn <*> (TEntry timing . Item typ contract name <$> checkIxs env pn es ts)
+        checkEntry :: AbiType -> [AbiType] -> Err (Exp a t)
+        checkEntry (FromAbi entryType) ts = checkTime pn <*> (check pn <*>
+          (TEntry timing . Item entryType contract name <$> checkIxs env pn es ts))
 
 checkIxs :: Typeable t => Env -> Pn -> [U.Expr] -> [AbiType] -> Err [TypedExp t]
 checkIxs env pn exprs types = if length exprs /= length types
diff --git a/src/act.cabal b/src/act.cabal
index f13bd24a..58109d86 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -30,8 +30,9 @@ common deps
                  validation       >= 1.1.1,
                  semigroupoids    >= 5.2.2,
                  extra,
-                 singletons
-  other-modules: Lex ErrM ErrorLogger Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
+                 singletons,
+                 reflection       >= 2.1.6
+  other-modules: Lex ErrM Error Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
   
   if flag(ci)
       ghc-options: -O2 -Wall -Werror -Wno-orphans -Wno-unticked-promoted-constructors
diff --git a/tests/frontend/pass/array/array.act.parsed.hs b/tests/frontend/pass/array/array.act.parsed.hs
index 6aa0f3d3..ab99d9fd 100644
--- a/tests/frontend/pass/array/array.act.parsed.hs
+++ b/tests/frontend/pass/array/array.act.parsed.hs
@@ -1 +1 @@
-[Transition "f" "A" f(address[2] xs) [] (Direct (Post Nothing [] (Just (EUTEntry (AlexPn 53 4 9) "xs" [IntLit (AlexPn 56 4 12) 1])))) []]
+[Transition (AlexPn 10 1 11) "f" "A" f(address[2] xs) [] (Direct (Post [] [] (Just (EUTEntry (AlexPn 53 4 9) "xs" [IntLit (AlexPn 56 4 12) 1])))) []]
diff --git a/tests/frontend/pass/creation/create.act.parsed.hs b/tests/frontend/pass/creation/create.act.parsed.hs
index fee95c78..26ba0c2d 100644
--- a/tests/frontend/pass/creation/create.act.parsed.hs
+++ b/tests/frontend/pass/creation/create.act.parsed.hs
@@ -1 +1 @@
-[Definition "Modest" constructor() [] (Creates [AssignVal (StorageVar uint256 "x") (IntLit (AlexPn 666 16 15) 1),AssignVal (StorageVar address "y") (EnvExp (AlexPn 685 17 18) Caller)]) [] [] []]
+[Definition (AlexPn 439 9 16) "Modest" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 661 16 10) uint256 "x") (IntLit (AlexPn 666 16 15) 1),AssignVal (StorageVar (AlexPn 680 17 13) address "y") (EnvExp (AlexPn 685 17 18) Caller)]) [] [] []]
diff --git a/tests/frontend/pass/creation/createMultiple.act.parsed.hs b/tests/frontend/pass/creation/createMultiple.act.parsed.hs
index fa5a2a21..afa3fe57 100644
--- a/tests/frontend/pass/creation/createMultiple.act.parsed.hs
+++ b/tests/frontend/pass/creation/createMultiple.act.parsed.hs
@@ -1 +1 @@
-[Definition "B" constructor() [] (Creates [AssignVal (StorageVar address "a") (IntLit (AlexPn 65 5 16) 0)]) [] [] [],Transition "create_a" "B" create_a() [Iff (AlexPn 114 10 1) [EEq (AlexPn 131 11 14) (EnvExp (AlexPn 121 11 4) Callvalue) (IntLit (AlexPn 134 11 17) 0)]] (Direct (Post (Just [Rewrite (PEntry (AlexPn 148 14 4) "a" []) (ENewaddr (AlexPn 153 14 9) (EnvExp (AlexPn 161 14 17) This) (EnvExp (AlexPn 167 14 23) Nonce))]) [ExtCreates "A" (ENewaddr (AlexPn 239 17 14) (EnvExp (AlexPn 247 17 22) This) (EnvExp (AlexPn 253 17 28) Nonce)) [AssignVal (StorageVar uint256 "x") (IntLit (AlexPn 273 18 14) 1)]] Nothing)) []]
+[Definition (AlexPn 15 1 16) "B" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 60 5 11) address "a") (IntLit (AlexPn 65 5 16) 0)]) [] [] [],Transition (AlexPn 78 7 11) "create_a" "B" create_a() [Iff (AlexPn 114 10 1) [EEq (AlexPn 131 11 14) (EnvExp (AlexPn 121 11 4) Callvalue) (IntLit (AlexPn 134 11 17) 0)]] (Direct (Post [Rewrite (PEntry (AlexPn 148 14 4) "a" []) (ENewaddr (AlexPn 153 14 9) (EnvExp (AlexPn 161 14 17) This) (EnvExp (AlexPn 167 14 23) Nonce))] [ExtCreates "A" (ENewaddr (AlexPn 239 17 14) (EnvExp (AlexPn 247 17 22) This) (EnvExp (AlexPn 253 17 28) Nonce)) [AssignVal (StorageVar (AlexPn 268 18 9) uint256 "x") (IntLit (AlexPn 273 18 14) 1)]] Nothing)) []]
diff --git a/tests/frontend/pass/dss/vat.act.parsed.hs b/tests/frontend/pass/dss/vat.act.parsed.hs
index 4c070219..2d2246d3 100644
--- a/tests/frontend/pass/dss/vat.act.parsed.hs
+++ b/tests/frontend/pass/dss/vat.act.parsed.hs
@@ -1 +1 @@
-[Transition "frob" "Vat" frob(bytes32 i, address u, address v, address w, int256 dink, int256 dart) [IffIn (AlexPn 546 20 1) uint256 [EUTEntry (AlexPn 572 22 5) "urns" [EUTEntry (AlexPn 577 22 10) "i" [],EUTEntry (AlexPn 580 22 13) "u" [],EAdd (AlexPn 587 22 20) (EUTEntry (AlexPn 583 22 16) "ink" []) (EUTEntry (AlexPn 589 22 22) "dink" [])],EUTEntry (AlexPn 598 23 5) "urns" [EUTEntry (AlexPn 603 23 10) "i" [],EUTEntry (AlexPn 606 23 13) "u" [],EAdd (AlexPn 613 23 20) (EUTEntry (AlexPn 609 23 16) "art" []) (EUTEntry (AlexPn 615 23 22) "dart" [])],EUTEntry (AlexPn 624 24 5) "ilks" [EUTEntry (AlexPn 629 24 10) "i" [],EAdd (AlexPn 639 24 20) (EUTEntry (AlexPn 632 24 13) "Art" []) (EUTEntry (AlexPn 641 24 22) "dart" [])],EMul (AlexPn 671 25 26) (EUTEntry (AlexPn 651 25 6) "ilks" [EUTEntry (AlexPn 656 25 11) "i" [],EAdd (AlexPn 663 25 18) (EUTEntry (AlexPn 659 25 14) "Art" []) (EUTEntry (AlexPn 665 25 20) "dart" [])]) (EUTEntry (AlexPn 673 25 28) "ilks" [EUTEntry (AlexPn 678 25 33) "i" [],EUTEntry (AlexPn 681 25 36) "rate" []]),EAdd (AlexPn 697 26 12) (EUTEntry (AlexPn 690 26 5) "dai" [EUTEntry (AlexPn 694 26 9) "w" []]) (EUTEntry (AlexPn 700 26 15) "ilks" [EUTEntry (AlexPn 705 26 20) "i" [],EMul (AlexPn 713 26 28) (EUTEntry (AlexPn 708 26 23) "rate" []) (EUTEntry (AlexPn 715 26 30) "dart" [])]),EAdd (AlexPn 730 27 10) (EUTEntry (AlexPn 725 27 5) "debt" []) (EUTEntry (AlexPn 733 27 13) "ilks" [EUTEntry (AlexPn 738 27 18) "i" [],EMul (AlexPn 746 27 26) (EUTEntry (AlexPn 741 27 21) "rate" []) (EUTEntry (AlexPn 748 27 28) "dart" [])])],IffIn (AlexPn 755 29 1) int256 [EUTEntry (AlexPn 780 31 5) "ilks" [EUTEntry (AlexPn 785 31 10) "i" [],EUTEntry (AlexPn 788 31 13) "rate" []],EUTEntry (AlexPn 797 32 5) "ilks" [EUTEntry (AlexPn 802 32 10) "i" [],EMul (AlexPn 810 32 18) (EUTEntry (AlexPn 805 32 13) "rate" []) (EUTEntry (AlexPn 812 32 20) "dart" [])]],Iff (AlexPn 818 34 1) [EEq (AlexPn 836 35 15) (EnvExp (AlexPn 826 35 5) Callvalue) (IntLit (AlexPn 839 35 18) 0),EEq (AlexPn 850 36 10) (EUTEntry (AlexPn 845 36 5) "live" []) (IntLit (AlexPn 853 36 13) 1),EUTEntry (AlexPn 859 37 5) "ilks" [EUTEntry (AlexPn 864 37 10) "i" [],ENeq (AlexPn 872 37 18) (EUTEntry (AlexPn 867 37 13) "rate" []) (IntLit (AlexPn 876 37 22) 0)],EOr (AlexPn 892 38 15) (ELEQ (AlexPn 887 38 10) (EUTEntry (AlexPn 882 38 5) "dart" []) (IntLit (AlexPn 890 38 13) 0)) (EMul (AlexPn 917 38 40) (EUTEntry (AlexPn 897 38 20) "ilks" [EUTEntry (AlexPn 902 38 25) "i" [],EAdd (AlexPn 909 38 32) (EUTEntry (AlexPn 905 38 28) "art" []) (EUTEntry (AlexPn 911 38 34) "dart" [])]) (EUTEntry (AlexPn 919 38 42) "ilks" [EUTEntry (AlexPn 924 38 47) "i" [],ELEQ (AlexPn 932 38 55) (EUTEntry (AlexPn 927 38 50) "rate" []) (EUTEntry (AlexPn 935 38 58) "ilks" [EUTEntry (AlexPn 940 38 63) "i" [],EAnd (AlexPn 948 38 71) (EUTEntry (AlexPn 943 38 66) "line" []) (EAdd (AlexPn 957 38 80) (EUTEntry (AlexPn 952 38 75) "debt" []) (EUTEntry (AlexPn 959 38 82) "ilks" [EUTEntry (AlexPn 964 38 87) "i" [],ELEQ (AlexPn 979 38 102) (EMul (AlexPn 972 38 95) (EUTEntry (AlexPn 967 38 90) "rate" []) (EUTEntry (AlexPn 974 38 97) "dart" [])) (EUTEntry (AlexPn 982 38 105) "line" [])]))])])),EOr (AlexPn 1004 39 17) (ELEQ (AlexPn 998 39 11) (EUTEntry (AlexPn 993 39 6) "dart" []) (IntLit (AlexPn 1001 39 14) 0)) (EAnd (AlexPn 1062 39 75) (EMul (AlexPn 1030 39 43) (EUTEntry (AlexPn 1010 39 23) "ilks" [EUTEntry (AlexPn 1015 39 28) "i" [],EAdd (AlexPn 1022 39 35) (EUTEntry (AlexPn 1018 39 31) "Art" []) (EUTEntry (AlexPn 1024 39 37) "dart" [])]) (EUTEntry (AlexPn 1032 39 45) "ilks" [EUTEntry (AlexPn 1037 39 50) "i" [],ELEQ (AlexPn 1045 39 58) (EUTEntry (AlexPn 1040 39 53) "rate" []) (EUTEntry (AlexPn 1048 39 61) "ilks" [EUTEntry (AlexPn 1053 39 66) "i" [],EUTEntry (AlexPn 1056 39 69) "line" []])])) (ELEQ (AlexPn 1096 39 109) (EAdd (AlexPn 1073 39 86) (EUTEntry (AlexPn 1068 39 81) "debt" []) (EUTEntry (AlexPn 1075 39 88) "ilks" [EUTEntry (AlexPn 1080 39 93) "i" [],EMul (AlexPn 1088 39 101) (EUTEntry (AlexPn 1083 39 96) "rate" []) (EUTEntry (AlexPn 1090 39 103) "dart" [])])) (EUTEntry (AlexPn 1099 39 112) "line" []))),EOr (AlexPn 1136 40 31) (EAnd (AlexPn 1121 40 16) (ELEQ (AlexPn 1116 40 11) (EUTEntry (AlexPn 1111 40 6) "dart" []) (IntLit (AlexPn 1119 40 14) 0)) (EGEQ (AlexPn 1130 40 25) (EUTEntry (AlexPn 1125 40 20) "dink" []) (IntLit (AlexPn 1133 40 28) 0))) (ELEQ (AlexPn 1181 40 76) (EMul (AlexPn 1165 40 60) (EUTEntry (AlexPn 1142 40 37) "urns" [EUTEntry (AlexPn 1147 40 42) "i" [],EUTEntry (AlexPn 1150 40 45) "u" [],EAdd (AlexPn 1157 40 52) (EUTEntry (AlexPn 1153 40 48) "art" []) (EUTEntry (AlexPn 1159 40 54) "dart" [])]) (EUTEntry (AlexPn 1167 40 62) "ilks" [EUTEntry (AlexPn 1172 40 67) "i" [],EUTEntry (AlexPn 1175 40 70) "rate" []])) (EMul (AlexPn 1209 40 104) (EUTEntry (AlexPn 1186 40 81) "urns" [EUTEntry (AlexPn 1191 40 86) "i" [],EUTEntry (AlexPn 1194 40 89) "u" [],EAdd (AlexPn 1201 40 96) (EUTEntry (AlexPn 1197 40 92) "ink" []) (EUTEntry (AlexPn 1203 40 98) "dink" [])]) (EUTEntry (AlexPn 1211 40 106) "ilks" [EUTEntry (AlexPn 1216 40 111) "i" [],EUTEntry (AlexPn 1219 40 114) "spot" []]))),EOr (AlexPn 1256 41 31) (EAnd (AlexPn 1241 41 16) (ELEQ (AlexPn 1236 41 11) (EUTEntry (AlexPn 1231 41 6) "dart" []) (IntLit (AlexPn 1239 41 14) 0)) (EGEQ (AlexPn 1250 41 25) (EUTEntry (AlexPn 1245 41 20) "dink" []) (IntLit (AlexPn 1253 41 28) 0))) (EOr (AlexPn 1272 41 47) (EEq (AlexPn 1262 41 37) (EUTEntry (AlexPn 1260 41 35) "u" []) (EnvExp (AlexPn 1265 41 40) Caller)) (EEq (AlexPn 1290 41 65) (EUTEntry (AlexPn 1275 41 50) "can" [EUTEntry (AlexPn 1279 41 54) "u" [],EnvExp (AlexPn 1282 41 57) Caller]) (IntLit (AlexPn 1293 41 68) 1))),EOr (AlexPn 1313 43 17) (ELEQ (AlexPn 1307 43 11) (EUTEntry (AlexPn 1302 43 6) "dink" []) (IntLit (AlexPn 1310 43 14) 0)) (EOr (AlexPn 1329 43 33) (EEq (AlexPn 1319 43 23) (EUTEntry (AlexPn 1317 43 21) "v" []) (EnvExp (AlexPn 1322 43 26) Caller)) (EEq (AlexPn 1347 43 51) (EUTEntry (AlexPn 1332 43 36) "Can" [EUTEntry (AlexPn 1336 43 40) "v" [],EnvExp (AlexPn 1339 43 43) Caller]) (IntLit (AlexPn 1350 43 54) 1))),EOr (AlexPn 1369 44 17) (EGEQ (AlexPn 1363 44 11) (EUTEntry (AlexPn 1358 44 6) "dart" []) (IntLit (AlexPn 1366 44 14) 0)) (EOr (AlexPn 1385 44 33) (EEq (AlexPn 1375 44 23) (EUTEntry (AlexPn 1373 44 21) "w" []) (EnvExp (AlexPn 1378 44 26) Caller)) (EEq (AlexPn 1403 44 51) (EUTEntry (AlexPn 1388 44 36) "Can" [EUTEntry (AlexPn 1392 44 40) "w" [],EnvExp (AlexPn 1395 44 43) Caller]) (IntLit (AlexPn 1406 44 54) 1)))]] (Direct (Post (Just [Constant (PEntry (AlexPn 1423 48 5) "urns" [EUTEntry (AlexPn 1428 48 10) "i" [],EUTEntry (AlexPn 1431 48 13) "u" [],EImpl (AlexPn 1438 48 20) (EUTEntry (AlexPn 1434 48 16) "ink" []) (EUTEntry (AlexPn 1441 48 23) "urns" [EUTEntry (AlexPn 1446 48 28) "i" [],EUTEntry (AlexPn 1449 48 31) "u" [],EAdd (AlexPn 1456 48 38) (EUTEntry (AlexPn 1452 48 34) "ink" []) (EUTEntry (AlexPn 1458 48 40) "dink" [])])]),Constant (PEntry (AlexPn 1467 49 5) "urns" [EUTEntry (AlexPn 1472 49 10) "i" [],EUTEntry (AlexPn 1475 49 13) "u" [],EImpl (AlexPn 1482 49 20) (EUTEntry (AlexPn 1478 49 16) "art" []) (EUTEntry (AlexPn 1485 49 23) "urns" [EUTEntry (AlexPn 1490 49 28) "i" [],EUTEntry (AlexPn 1493 49 31) "u" [],EAdd (AlexPn 1500 49 38) (EUTEntry (AlexPn 1496 49 34) "art" []) (EUTEntry (AlexPn 1502 49 40) "dart" [])])]),Constant (PEntry (AlexPn 1511 50 5) "ilks" [EUTEntry (AlexPn 1516 50 10) "i" [],EImpl (AlexPn 1526 50 20) (EUTEntry (AlexPn 1519 50 13) "Art" []) (EUTEntry (AlexPn 1529 50 23) "ilks" [EUTEntry (AlexPn 1534 50 28) "i" [],EAdd (AlexPn 1541 50 35) (EUTEntry (AlexPn 1537 50 31) "Art" []) (EUTEntry (AlexPn 1543 50 37) "dart" [])])]),Rewrite (PEntry (AlexPn 1552 51 5) "gem" [EUTEntry (AlexPn 1556 51 9) "i" [],EUTEntry (AlexPn 1559 51 12) "v" []]) (ESub (AlexPn 1582 51 35) (EUTEntry (AlexPn 1570 51 23) "gem" [EUTEntry (AlexPn 1574 51 27) "i" [],EUTEntry (AlexPn 1577 51 30) "v" []]) (EUTEntry (AlexPn 1584 51 37) "dink" [])),Rewrite (PEntry (AlexPn 1593 52 5) "dai" [EUTEntry (AlexPn 1597 52 9) "w" []]) (EAdd (AlexPn 1618 52 30) (EUTEntry (AlexPn 1611 52 23) "dai" [EUTEntry (AlexPn 1615 52 27) "w" []]) (EUTEntry (AlexPn 1620 52 32) "ilks" [EUTEntry (AlexPn 1625 52 37) "i" [],EMul (AlexPn 1633 52 45) (EUTEntry (AlexPn 1628 52 40) "rate" []) (EUTEntry (AlexPn 1635 52 47) "dart" [])])),Rewrite (PEntry (AlexPn 1644 53 5) "debt" []) (EAdd (AlexPn 1669 53 30) (EUTEntry (AlexPn 1662 53 23) "debt" []) (EUTEntry (AlexPn 1671 53 32) "ilks" [EUTEntry (AlexPn 1676 53 37) "i" [],EMul (AlexPn 1684 53 45) (EUTEntry (AlexPn 1679 53 40) "rate" []) (EUTEntry (AlexPn 1686 53 47) "dart" [])]))]) [] Nothing)) []]
+[Transition (AlexPn 454 17 11) "frob" "Vat" frob(bytes32 i, address u, address v, address w, int256 dink, int256 dart) [IffIn (AlexPn 546 20 1) uint256 [EUTEntry (AlexPn 572 22 5) "urns" [EUTEntry (AlexPn 577 22 10) "i" [],EUTEntry (AlexPn 580 22 13) "u" [],EAdd (AlexPn 587 22 20) (EUTEntry (AlexPn 583 22 16) "ink" []) (EUTEntry (AlexPn 589 22 22) "dink" [])],EUTEntry (AlexPn 598 23 5) "urns" [EUTEntry (AlexPn 603 23 10) "i" [],EUTEntry (AlexPn 606 23 13) "u" [],EAdd (AlexPn 613 23 20) (EUTEntry (AlexPn 609 23 16) "art" []) (EUTEntry (AlexPn 615 23 22) "dart" [])],EUTEntry (AlexPn 624 24 5) "ilks" [EUTEntry (AlexPn 629 24 10) "i" [],EAdd (AlexPn 639 24 20) (EUTEntry (AlexPn 632 24 13) "Art" []) (EUTEntry (AlexPn 641 24 22) "dart" [])],EMul (AlexPn 671 25 26) (EUTEntry (AlexPn 651 25 6) "ilks" [EUTEntry (AlexPn 656 25 11) "i" [],EAdd (AlexPn 663 25 18) (EUTEntry (AlexPn 659 25 14) "Art" []) (EUTEntry (AlexPn 665 25 20) "dart" [])]) (EUTEntry (AlexPn 673 25 28) "ilks" [EUTEntry (AlexPn 678 25 33) "i" [],EUTEntry (AlexPn 681 25 36) "rate" []]),EAdd (AlexPn 697 26 12) (EUTEntry (AlexPn 690 26 5) "dai" [EUTEntry (AlexPn 694 26 9) "w" []]) (EUTEntry (AlexPn 700 26 15) "ilks" [EUTEntry (AlexPn 705 26 20) "i" [],EMul (AlexPn 713 26 28) (EUTEntry (AlexPn 708 26 23) "rate" []) (EUTEntry (AlexPn 715 26 30) "dart" [])]),EAdd (AlexPn 730 27 10) (EUTEntry (AlexPn 725 27 5) "debt" []) (EUTEntry (AlexPn 733 27 13) "ilks" [EUTEntry (AlexPn 738 27 18) "i" [],EMul (AlexPn 746 27 26) (EUTEntry (AlexPn 741 27 21) "rate" []) (EUTEntry (AlexPn 748 27 28) "dart" [])])],IffIn (AlexPn 755 29 1) int256 [EUTEntry (AlexPn 780 31 5) "ilks" [EUTEntry (AlexPn 785 31 10) "i" [],EUTEntry (AlexPn 788 31 13) "rate" []],EUTEntry (AlexPn 797 32 5) "ilks" [EUTEntry (AlexPn 802 32 10) "i" [],EMul (AlexPn 810 32 18) (EUTEntry (AlexPn 805 32 13) "rate" []) (EUTEntry (AlexPn 812 32 20) "dart" [])]],Iff (AlexPn 818 34 1) [EEq (AlexPn 836 35 15) (EnvExp (AlexPn 826 35 5) Callvalue) (IntLit (AlexPn 839 35 18) 0),EEq (AlexPn 850 36 10) (EUTEntry (AlexPn 845 36 5) "live" []) (IntLit (AlexPn 853 36 13) 1),EUTEntry (AlexPn 859 37 5) "ilks" [EUTEntry (AlexPn 864 37 10) "i" [],ENeq (AlexPn 872 37 18) (EUTEntry (AlexPn 867 37 13) "rate" []) (IntLit (AlexPn 876 37 22) 0)],EOr (AlexPn 892 38 15) (ELEQ (AlexPn 887 38 10) (EUTEntry (AlexPn 882 38 5) "dart" []) (IntLit (AlexPn 890 38 13) 0)) (EMul (AlexPn 917 38 40) (EUTEntry (AlexPn 897 38 20) "ilks" [EUTEntry (AlexPn 902 38 25) "i" [],EAdd (AlexPn 909 38 32) (EUTEntry (AlexPn 905 38 28) "art" []) (EUTEntry (AlexPn 911 38 34) "dart" [])]) (EUTEntry (AlexPn 919 38 42) "ilks" [EUTEntry (AlexPn 924 38 47) "i" [],ELEQ (AlexPn 932 38 55) (EUTEntry (AlexPn 927 38 50) "rate" []) (EUTEntry (AlexPn 935 38 58) "ilks" [EUTEntry (AlexPn 940 38 63) "i" [],EAnd (AlexPn 948 38 71) (EUTEntry (AlexPn 943 38 66) "line" []) (EAdd (AlexPn 957 38 80) (EUTEntry (AlexPn 952 38 75) "debt" []) (EUTEntry (AlexPn 959 38 82) "ilks" [EUTEntry (AlexPn 964 38 87) "i" [],ELEQ (AlexPn 979 38 102) (EMul (AlexPn 972 38 95) (EUTEntry (AlexPn 967 38 90) "rate" []) (EUTEntry (AlexPn 974 38 97) "dart" [])) (EUTEntry (AlexPn 982 38 105) "line" [])]))])])),EOr (AlexPn 1004 39 17) (ELEQ (AlexPn 998 39 11) (EUTEntry (AlexPn 993 39 6) "dart" []) (IntLit (AlexPn 1001 39 14) 0)) (EAnd (AlexPn 1062 39 75) (EMul (AlexPn 1030 39 43) (EUTEntry (AlexPn 1010 39 23) "ilks" [EUTEntry (AlexPn 1015 39 28) "i" [],EAdd (AlexPn 1022 39 35) (EUTEntry (AlexPn 1018 39 31) "Art" []) (EUTEntry (AlexPn 1024 39 37) "dart" [])]) (EUTEntry (AlexPn 1032 39 45) "ilks" [EUTEntry (AlexPn 1037 39 50) "i" [],ELEQ (AlexPn 1045 39 58) (EUTEntry (AlexPn 1040 39 53) "rate" []) (EUTEntry (AlexPn 1048 39 61) "ilks" [EUTEntry (AlexPn 1053 39 66) "i" [],EUTEntry (AlexPn 1056 39 69) "line" []])])) (ELEQ (AlexPn 1096 39 109) (EAdd (AlexPn 1073 39 86) (EUTEntry (AlexPn 1068 39 81) "debt" []) (EUTEntry (AlexPn 1075 39 88) "ilks" [EUTEntry (AlexPn 1080 39 93) "i" [],EMul (AlexPn 1088 39 101) (EUTEntry (AlexPn 1083 39 96) "rate" []) (EUTEntry (AlexPn 1090 39 103) "dart" [])])) (EUTEntry (AlexPn 1099 39 112) "line" []))),EOr (AlexPn 1136 40 31) (EAnd (AlexPn 1121 40 16) (ELEQ (AlexPn 1116 40 11) (EUTEntry (AlexPn 1111 40 6) "dart" []) (IntLit (AlexPn 1119 40 14) 0)) (EGEQ (AlexPn 1130 40 25) (EUTEntry (AlexPn 1125 40 20) "dink" []) (IntLit (AlexPn 1133 40 28) 0))) (ELEQ (AlexPn 1181 40 76) (EMul (AlexPn 1165 40 60) (EUTEntry (AlexPn 1142 40 37) "urns" [EUTEntry (AlexPn 1147 40 42) "i" [],EUTEntry (AlexPn 1150 40 45) "u" [],EAdd (AlexPn 1157 40 52) (EUTEntry (AlexPn 1153 40 48) "art" []) (EUTEntry (AlexPn 1159 40 54) "dart" [])]) (EUTEntry (AlexPn 1167 40 62) "ilks" [EUTEntry (AlexPn 1172 40 67) "i" [],EUTEntry (AlexPn 1175 40 70) "rate" []])) (EMul (AlexPn 1209 40 104) (EUTEntry (AlexPn 1186 40 81) "urns" [EUTEntry (AlexPn 1191 40 86) "i" [],EUTEntry (AlexPn 1194 40 89) "u" [],EAdd (AlexPn 1201 40 96) (EUTEntry (AlexPn 1197 40 92) "ink" []) (EUTEntry (AlexPn 1203 40 98) "dink" [])]) (EUTEntry (AlexPn 1211 40 106) "ilks" [EUTEntry (AlexPn 1216 40 111) "i" [],EUTEntry (AlexPn 1219 40 114) "spot" []]))),EOr (AlexPn 1256 41 31) (EAnd (AlexPn 1241 41 16) (ELEQ (AlexPn 1236 41 11) (EUTEntry (AlexPn 1231 41 6) "dart" []) (IntLit (AlexPn 1239 41 14) 0)) (EGEQ (AlexPn 1250 41 25) (EUTEntry (AlexPn 1245 41 20) "dink" []) (IntLit (AlexPn 1253 41 28) 0))) (EOr (AlexPn 1272 41 47) (EEq (AlexPn 1262 41 37) (EUTEntry (AlexPn 1260 41 35) "u" []) (EnvExp (AlexPn 1265 41 40) Caller)) (EEq (AlexPn 1290 41 65) (EUTEntry (AlexPn 1275 41 50) "can" [EUTEntry (AlexPn 1279 41 54) "u" [],EnvExp (AlexPn 1282 41 57) Caller]) (IntLit (AlexPn 1293 41 68) 1))),EOr (AlexPn 1313 43 17) (ELEQ (AlexPn 1307 43 11) (EUTEntry (AlexPn 1302 43 6) "dink" []) (IntLit (AlexPn 1310 43 14) 0)) (EOr (AlexPn 1329 43 33) (EEq (AlexPn 1319 43 23) (EUTEntry (AlexPn 1317 43 21) "v" []) (EnvExp (AlexPn 1322 43 26) Caller)) (EEq (AlexPn 1347 43 51) (EUTEntry (AlexPn 1332 43 36) "Can" [EUTEntry (AlexPn 1336 43 40) "v" [],EnvExp (AlexPn 1339 43 43) Caller]) (IntLit (AlexPn 1350 43 54) 1))),EOr (AlexPn 1369 44 17) (EGEQ (AlexPn 1363 44 11) (EUTEntry (AlexPn 1358 44 6) "dart" []) (IntLit (AlexPn 1366 44 14) 0)) (EOr (AlexPn 1385 44 33) (EEq (AlexPn 1375 44 23) (EUTEntry (AlexPn 1373 44 21) "w" []) (EnvExp (AlexPn 1378 44 26) Caller)) (EEq (AlexPn 1403 44 51) (EUTEntry (AlexPn 1388 44 36) "Can" [EUTEntry (AlexPn 1392 44 40) "w" [],EnvExp (AlexPn 1395 44 43) Caller]) (IntLit (AlexPn 1406 44 54) 1)))]] (Direct (Post [Constant (PEntry (AlexPn 1423 48 5) "urns" [EUTEntry (AlexPn 1428 48 10) "i" [],EUTEntry (AlexPn 1431 48 13) "u" [],EImpl (AlexPn 1438 48 20) (EUTEntry (AlexPn 1434 48 16) "ink" []) (EUTEntry (AlexPn 1441 48 23) "urns" [EUTEntry (AlexPn 1446 48 28) "i" [],EUTEntry (AlexPn 1449 48 31) "u" [],EAdd (AlexPn 1456 48 38) (EUTEntry (AlexPn 1452 48 34) "ink" []) (EUTEntry (AlexPn 1458 48 40) "dink" [])])]),Constant (PEntry (AlexPn 1467 49 5) "urns" [EUTEntry (AlexPn 1472 49 10) "i" [],EUTEntry (AlexPn 1475 49 13) "u" [],EImpl (AlexPn 1482 49 20) (EUTEntry (AlexPn 1478 49 16) "art" []) (EUTEntry (AlexPn 1485 49 23) "urns" [EUTEntry (AlexPn 1490 49 28) "i" [],EUTEntry (AlexPn 1493 49 31) "u" [],EAdd (AlexPn 1500 49 38) (EUTEntry (AlexPn 1496 49 34) "art" []) (EUTEntry (AlexPn 1502 49 40) "dart" [])])]),Constant (PEntry (AlexPn 1511 50 5) "ilks" [EUTEntry (AlexPn 1516 50 10) "i" [],EImpl (AlexPn 1526 50 20) (EUTEntry (AlexPn 1519 50 13) "Art" []) (EUTEntry (AlexPn 1529 50 23) "ilks" [EUTEntry (AlexPn 1534 50 28) "i" [],EAdd (AlexPn 1541 50 35) (EUTEntry (AlexPn 1537 50 31) "Art" []) (EUTEntry (AlexPn 1543 50 37) "dart" [])])]),Rewrite (PEntry (AlexPn 1552 51 5) "gem" [EUTEntry (AlexPn 1556 51 9) "i" [],EUTEntry (AlexPn 1559 51 12) "v" []]) (ESub (AlexPn 1582 51 35) (EUTEntry (AlexPn 1570 51 23) "gem" [EUTEntry (AlexPn 1574 51 27) "i" [],EUTEntry (AlexPn 1577 51 30) "v" []]) (EUTEntry (AlexPn 1584 51 37) "dink" [])),Rewrite (PEntry (AlexPn 1593 52 5) "dai" [EUTEntry (AlexPn 1597 52 9) "w" []]) (EAdd (AlexPn 1618 52 30) (EUTEntry (AlexPn 1611 52 23) "dai" [EUTEntry (AlexPn 1615 52 27) "w" []]) (EUTEntry (AlexPn 1620 52 32) "ilks" [EUTEntry (AlexPn 1625 52 37) "i" [],EMul (AlexPn 1633 52 45) (EUTEntry (AlexPn 1628 52 40) "rate" []) (EUTEntry (AlexPn 1635 52 47) "dart" [])])),Rewrite (PEntry (AlexPn 1644 53 5) "debt" []) (EAdd (AlexPn 1669 53 30) (EUTEntry (AlexPn 1662 53 23) "debt" []) (EUTEntry (AlexPn 1671 53 32) "ilks" [EUTEntry (AlexPn 1676 53 37) "i" [],EMul (AlexPn 1684 53 45) (EUTEntry (AlexPn 1679 53 40) "rate" []) (EUTEntry (AlexPn 1686 53 47) "dart" [])]))] [] Nothing)) []]
diff --git a/tests/frontend/pass/multi/multi.act.parsed.hs b/tests/frontend/pass/multi/multi.act.parsed.hs
index f57a1022..31051583 100644
--- a/tests/frontend/pass/multi/multi.act.parsed.hs
+++ b/tests/frontend/pass/multi/multi.act.parsed.hs
@@ -1 +1 @@
-[Definition "a" constructor() [] (Creates [AssignVal (StorageVar uint256 "x") (IntLit (AlexPn 63 5 14) 0)]) [] [] [],Definition "B" constructor() [] (Creates [AssignVal (StorageVar uint256 "y") (IntLit (AlexPn 129 11 14) 0)]) [] [] [],Transition "remote" "B" set_remote(uint256 z) [Iff (AlexPn 185 17 1) [EEq (AlexPn 202 18 14) (EnvExp (AlexPn 192 18 4) Callvalue) (IntLit (AlexPn 205 18 17) 0)]] (Direct (Post Nothing [ExtStorage "a" [Rewrite (PEntry (AlexPn 373 24 4) "x" []) (EUTEntry (AlexPn 378 24 9) "z" [])]] Nothing)) [],Transition "multi" "B" set_remote(uint256 z) [Iff (AlexPn 432 29 1) [EEq (AlexPn 449 30 14) (EnvExp (AlexPn 439 30 4) Callvalue) (IntLit (AlexPn 452 30 17) 0)]] (Direct (Post (Just [Rewrite (PEntry (AlexPn 520 34 4) "y" []) (IntLit (AlexPn 525 34 9) 1)]) [ExtStorage "a" [Rewrite (PEntry (AlexPn 544 37 4) "x" []) (EUTEntry (AlexPn 549 37 9) "z" [])]] Nothing)) []]
+[Definition (AlexPn 15 1 16) "a" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 58 5 9) uint256 "x") (IntLit (AlexPn 63 5 14) 0)]) [] [] [],Definition (AlexPn 81 7 16) "B" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 124 11 9) uint256 "y") (IntLit (AlexPn 129 11 14) 0)]) [] [] [],Transition (AlexPn 143 14 11) "remote" "B" set_remote(uint256 z) [Iff (AlexPn 185 17 1) [EEq (AlexPn 202 18 14) (EnvExp (AlexPn 192 18 4) Callvalue) (IntLit (AlexPn 205 18 17) 0)]] (Direct (Post [] [ExtStorage "a" [Rewrite (PEntry (AlexPn 373 24 4) "x" []) (EUTEntry (AlexPn 378 24 9) "z" [])]] Nothing)) [],Transition (AlexPn 391 26 11) "multi" "B" set_remote(uint256 z) [Iff (AlexPn 432 29 1) [EEq (AlexPn 449 30 14) (EnvExp (AlexPn 439 30 4) Callvalue) (IntLit (AlexPn 452 30 17) 0)]] (Direct (Post [Rewrite (PEntry (AlexPn 520 34 4) "y" []) (IntLit (AlexPn 525 34 9) 1)] [ExtStorage "a" [Rewrite (PEntry (AlexPn 544 37 4) "x" []) (EUTEntry (AlexPn 549 37 9) "z" [])]] Nothing)) []]
diff --git a/tests/frontend/pass/safemath/safemathraw.act.parsed.hs b/tests/frontend/pass/safemath/safemathraw.act.parsed.hs
index dd2b5420..221ce095 100644
--- a/tests/frontend/pass/safemath/safemathraw.act.parsed.hs
+++ b/tests/frontend/pass/safemath/safemathraw.act.parsed.hs
@@ -1 +1 @@
-[Transition "add" "SafeAdd" add(uint256 x, uint256 y) [IffIn (AlexPn 62 4 1) uint256 [EAdd (AlexPn 90 6 7) (EUTEntry (AlexPn 88 6 5) "x" []) (EUTEntry (AlexPn 92 6 9) "y" [])],Iff (AlexPn 95 8 1) [EEq (AlexPn 114 10 15) (EnvExp (AlexPn 104 10 5) Callvalue) (IntLit (AlexPn 117 10 18) 0)]] (Direct (Post Nothing [] (Just (EAdd (AlexPn 130 12 11) (EUTEntry (AlexPn 128 12 9) "x" []) (EUTEntry (AlexPn 132 12 13) "y" []))))) []]
+[Transition (AlexPn 10 1 11) "add" "SafeAdd" add(uint256 x, uint256 y) [IffIn (AlexPn 62 4 1) uint256 [EAdd (AlexPn 90 6 7) (EUTEntry (AlexPn 88 6 5) "x" []) (EUTEntry (AlexPn 92 6 9) "y" [])],Iff (AlexPn 95 8 1) [EEq (AlexPn 114 10 15) (EnvExp (AlexPn 104 10 5) Callvalue) (IntLit (AlexPn 117 10 18) 0)]] (Direct (Post [] [] (Just (EAdd (AlexPn 130 12 11) (EUTEntry (AlexPn 128 12 9) "x" []) (EUTEntry (AlexPn 132 12 13) "y" []))))) []]
diff --git a/tests/frontend/pass/smoke/smoke.act.parsed.hs b/tests/frontend/pass/smoke/smoke.act.parsed.hs
index 1a025023..dad23e13 100644
--- a/tests/frontend/pass/smoke/smoke.act.parsed.hs
+++ b/tests/frontend/pass/smoke/smoke.act.parsed.hs
@@ -1 +1 @@
-[Transition "f" "A" f(uint256 x) [] (Direct (Post Nothing [] (Just (IntLit (AlexPn 46 4 9) 1)))) []]
+[Transition (AlexPn 10 1 11) "f" "A" f(uint256 x) [] (Direct (Post [] [] (Just (IntLit (AlexPn 46 4 9) 1)))) []]
diff --git a/tests/frontend/pass/staticstore/staticstore.act.parsed.hs b/tests/frontend/pass/staticstore/staticstore.act.parsed.hs
index d31a6d1c..e6a3614d 100644
--- a/tests/frontend/pass/staticstore/staticstore.act.parsed.hs
+++ b/tests/frontend/pass/staticstore/staticstore.act.parsed.hs
@@ -1 +1 @@
-[Transition "f" "C" f() [IffIn (AlexPn 32 4 1) uint256 [EAdd (AlexPn 60 6 7) (EUTEntry (AlexPn 58 6 5) "x" []) (EUTEntry (AlexPn 62 6 9) "y" [])]] (Direct (Post (Just [Constant (PEntry (AlexPn 78 10 5) "x" []),Constant (PEntry (AlexPn 85 11 5) "y" [])]) [] (Just (EAdd (AlexPn 98 13 11) (EUTEntry (AlexPn 96 13 9) "x" []) (EUTEntry (AlexPn 100 13 13) "y" []))))) []]
+[Transition (AlexPn 10 1 11) "f" "C" f() [IffIn (AlexPn 32 4 1) uint256 [EAdd (AlexPn 60 6 7) (EUTEntry (AlexPn 58 6 5) "x" []) (EUTEntry (AlexPn 62 6 9) "y" [])]] (Direct (Post [Constant (PEntry (AlexPn 78 10 5) "x" []),Constant (PEntry (AlexPn 85 11 5) "y" [])] [] (Just (EAdd (AlexPn 98 13 11) (EUTEntry (AlexPn 96 13 9) "x" []) (EUTEntry (AlexPn 100 13 13) "y" []))))) []]
diff --git a/tests/frontend/pass/token/transfer.act.parsed.hs b/tests/frontend/pass/token/transfer.act.parsed.hs
index 64c13066..bcf83569 100644
--- a/tests/frontend/pass/token/transfer.act.parsed.hs
+++ b/tests/frontend/pass/token/transfer.act.parsed.hs
@@ -1 +1 @@
-[Definition "Token" constructor(string _symbol, string _name, string _version, uint256 _totalSupply) [] (Creates [AssignVal (StorageVar string "name") (EUTEntry (AlexPn 144 6 26) "_name" []),AssignVal (StorageVar string "symbol") (EUTEntry (AlexPn 175 7 26) "_symbol" []),AssignVal (StorageVar uint256 "totalSupply") (EUTEntry (AlexPn 208 8 26) "_totalSupply" []),AssignMany (StorageVar mapping(address => uint256) "balanceOf") [Defn (EnvExp (AlexPn 263 9 43) Caller) (EUTEntry (AlexPn 273 9 53) "_totalSupply" [])],AssignMany (StorageVar mapping(address => mapping(address => uint256)) "allowance") []]) [] [] [EEq (AlexPn 373 14 15) (EUTEntry (AlexPn 361 14 3) "totalSupply" []) (EUTEntry (AlexPn 376 14 18) "_totalSupply" []),EEq (AlexPn 396 15 8) (EUTEntry (AlexPn 391 15 3) "name" []) (EUTEntry (AlexPn 399 15 11) "_name" []),EEq (AlexPn 414 16 10) (EUTEntry (AlexPn 407 16 3) "symbol" []) (EUTEntry (AlexPn 417 16 13) "_symbol" [])],Transition "transfer" "Token" transfer(uint256 value, address to) [Iff (AlexPn 502 22 1) [EEq (AlexPn 519 24 13) (EnvExp (AlexPn 509 24 3) Callvalue) (IntLit (AlexPn 522 24 16) 0),ELEQ (AlexPn 532 25 9) (EUTEntry (AlexPn 526 25 3) "value" []) (EUTEntry (AlexPn 535 25 12) "balanceOf" [EnvExp (AlexPn 545 25 22) Caller]),EImpl (AlexPn 569 26 17) (ENeq (AlexPn 562 26 10) (EnvExp (AlexPn 555 26 3) Caller) (EUTEntry (AlexPn 566 26 14) "to" [])) (ELT (AlexPn 594 26 42) (EAdd (AlexPn 586 26 34) (EUTEntry (AlexPn 572 26 20) "balanceOf" [EUTEntry (AlexPn 582 26 30) "to" []]) (EUTEntry (AlexPn 588 26 36) "value" [])) (EExp (AlexPn 597 26 45) (IntLit (AlexPn 596 26 44) 2) (IntLit (AlexPn 598 26 46) 256)))]] (Branches [Case (AlexPn 603 28 1) (ENeq (AlexPn 615 28 13) (EnvExp (AlexPn 608 28 6) Caller) (EUTEntry (AlexPn 619 28 17) "to" [])) (Post (Just [Rewrite (PEntry (AlexPn 640 32 6) "balanceOf" [EnvExp (AlexPn 650 32 16) Caller]) (ESub (AlexPn 679 32 45) (EUTEntry (AlexPn 661 32 27) "balanceOf" [EnvExp (AlexPn 671 32 37) Caller]) (EUTEntry (AlexPn 681 32 47) "value" [])),Rewrite (PEntry (AlexPn 692 33 6) "balanceOf" [EUTEntry (AlexPn 702 33 16) "to" []]) (EAdd (AlexPn 727 33 41) (EUTEntry (AlexPn 713 33 27) "balanceOf" [EUTEntry (AlexPn 723 33 37) "to" []]) (EUTEntry (AlexPn 729 33 43) "value" []))]) [] (Just (IntLit (AlexPn 746 35 11) 1))),Case (AlexPn 749 37 1) (EEq (AlexPn 761 37 13) (EnvExp (AlexPn 754 37 6) Caller) (EUTEntry (AlexPn 764 37 16) "to" [])) (Post (Just [Constant (PEntry (AlexPn 784 41 5) "balanceOf" [EnvExp (AlexPn 794 41 15) Caller]),Constant (PEntry (AlexPn 806 42 5) "balanceOf" [EUTEntry (AlexPn 816 42 15) "to" []])]) [] (Just (IntLit (AlexPn 831 44 11) 1)))]) [],Transition "transferFrom" "Token" transferFrom(address src, address dst, uint256 amount) [Iff (AlexPn 930 50 1) [ELEQ (AlexPn 944 52 10) (EUTEntry (AlexPn 937 52 3) "amount" []) (EUTEntry (AlexPn 947 52 13) "balanceOf" [EnvExp (AlexPn 957 52 23) Caller]),EImpl (AlexPn 982 53 18) (ENeq (AlexPn 974 53 10) (EUTEntry (AlexPn 967 53 3) "src" []) (EUTEntry (AlexPn 978 53 14) "dst" [])) (ELT (AlexPn 1009 53 45) (EAdd (AlexPn 1000 53 36) (EUTEntry (AlexPn 985 53 21) "balanceOf" [EUTEntry (AlexPn 995 53 31) "dst" []]) (EUTEntry (AlexPn 1002 53 38) "amount" [])) (EExp (AlexPn 1012 53 48) (IntLit (AlexPn 1011 53 47) 2) (IntLit (AlexPn 1013 53 49) 256))),EImpl (AlexPn 1034 54 18) (ENeq (AlexPn 1026 54 10) (EnvExp (AlexPn 1019 54 3) Caller) (EUTEntry (AlexPn 1030 54 14) "src" [])) (ELEQ (AlexPn 1039 54 23) (IntLit (AlexPn 1037 54 21) 0) (ESub (AlexPn 1065 54 49) (EUTEntry (AlexPn 1042 54 26) "allowance" [EUTEntry (AlexPn 1052 54 36) "src" [],EnvExp (AlexPn 1057 54 41) Caller]) (EUTEntry (AlexPn 1067 54 51) "amount" []))),EEq (AlexPn 1086 55 13) (EnvExp (AlexPn 1076 55 3) Callvalue) (IntLit (AlexPn 1089 55 16) 0)]] (Branches [Case (AlexPn 1092 57 1) (EAnd (AlexPn 1109 57 18) (ENeq (AlexPn 1101 57 10) (EUTEntry (AlexPn 1097 57 6) "src" []) (EUTEntry (AlexPn 1105 57 14) "dst" [])) (EEq (AlexPn 1120 57 29) (EnvExp (AlexPn 1113 57 22) Caller) (EUTEntry (AlexPn 1123 57 32) "src" []))) (Post (Just [Constant (PEntry (AlexPn 1145 61 6) "balanceOf" [EnvExp (AlexPn 1155 61 16) Caller]),Constant (PEntry (AlexPn 1168 62 6) "allowance" [EUTEntry (AlexPn 1178 62 16) "src" [],EnvExp (AlexPn 1183 62 21) Caller]),Rewrite (PEntry (AlexPn 1196 63 6) "balanceOf" [EUTEntry (AlexPn 1206 63 16) "src" []]) (ESub (AlexPn 1229 63 39) (EUTEntry (AlexPn 1214 63 24) "balanceOf" [EUTEntry (AlexPn 1224 63 34) "src" []]) (EUTEntry (AlexPn 1231 63 41) "amount" [])),Rewrite (PEntry (AlexPn 1243 64 6) "balanceOf" [EUTEntry (AlexPn 1253 64 16) "dst" []]) (EAdd (AlexPn 1276 64 39) (EUTEntry (AlexPn 1261 64 24) "balanceOf" [EUTEntry (AlexPn 1271 64 34) "dst" []]) (EUTEntry (AlexPn 1278 64 41) "amount" []))]) [] (Just (IntLit (AlexPn 1296 66 11) 1))),Case (AlexPn 1299 68 1) (EAnd (AlexPn 1335 68 37) (EAnd (AlexPn 1316 68 18) (ENeq (AlexPn 1308 68 10) (EUTEntry (AlexPn 1304 68 6) "src" []) (EUTEntry (AlexPn 1312 68 14) "dst" [])) (ENeq (AlexPn 1327 68 29) (EnvExp (AlexPn 1320 68 22) Caller) (EUTEntry (AlexPn 1331 68 33) "src" []))) (EEq (AlexPn 1362 68 64) (EUTEntry (AlexPn 1339 68 41) "allowance" [EUTEntry (AlexPn 1349 68 51) "src" [],EnvExp (AlexPn 1354 68 56) Caller]) (ESub (AlexPn 1371 68 73) (EExp (AlexPn 1366 68 68) (IntLit (AlexPn 1365 68 67) 2) (IntLit (AlexPn 1367 68 69) 256)) (IntLit (AlexPn 1373 68 75) 1)))) (Post (Just [Constant (PEntry (AlexPn 1393 72 6) "balanceOf" [EnvExp (AlexPn 1403 72 16) Caller]),Constant (PEntry (AlexPn 1416 73 6) "allowance" [EUTEntry (AlexPn 1426 73 16) "src" [],EnvExp (AlexPn 1431 73 21) Caller]),Rewrite (PEntry (AlexPn 1444 74 6) "balanceOf" [EUTEntry (AlexPn 1454 74 16) "src" []]) (ESub (AlexPn 1477 74 39) (EUTEntry (AlexPn 1462 74 24) "balanceOf" [EUTEntry (AlexPn 1472 74 34) "src" []]) (EUTEntry (AlexPn 1479 74 41) "amount" [])),Rewrite (PEntry (AlexPn 1491 75 6) "balanceOf" [EUTEntry (AlexPn 1501 75 16) "dst" []]) (EAdd (AlexPn 1524 75 39) (EUTEntry (AlexPn 1509 75 24) "balanceOf" [EUTEntry (AlexPn 1519 75 34) "dst" []]) (EUTEntry (AlexPn 1526 75 41) "amount" []))]) [] (Just (IntLit (AlexPn 1544 77 11) 1))),Case (AlexPn 1547 79 1) (EAnd (AlexPn 1583 79 37) (EAnd (AlexPn 1564 79 18) (ENeq (AlexPn 1556 79 10) (EUTEntry (AlexPn 1552 79 6) "src" []) (EUTEntry (AlexPn 1560 79 14) "dst" [])) (ENeq (AlexPn 1575 79 29) (EnvExp (AlexPn 1568 79 22) Caller) (EUTEntry (AlexPn 1579 79 33) "src" []))) (ELT (AlexPn 1610 79 64) (EUTEntry (AlexPn 1587 79 41) "allowance" [EUTEntry (AlexPn 1597 79 51) "src" [],EnvExp (AlexPn 1602 79 56) Caller]) (ESub (AlexPn 1618 79 72) (EExp (AlexPn 1613 79 67) (IntLit (AlexPn 1612 79 66) 2) (IntLit (AlexPn 1614 79 68) 256)) (IntLit (AlexPn 1620 79 74) 1)))) (Post (Just [Constant (PEntry (AlexPn 1639 83 5) "balanceOf" [EnvExp (AlexPn 1649 83 15) Caller]),Rewrite (PEntry (AlexPn 1661 84 5) "allowance" [EUTEntry (AlexPn 1671 84 15) "src" [],EnvExp (AlexPn 1676 84 20) Caller]) (ESub (AlexPn 1710 84 54) (EUTEntry (AlexPn 1687 84 31) "allowance" [EUTEntry (AlexPn 1697 84 41) "src" [],EnvExp (AlexPn 1702 84 46) Caller]) (EUTEntry (AlexPn 1712 84 56) "amount" [])),Rewrite (PEntry (AlexPn 1723 85 5) "balanceOf" [EUTEntry (AlexPn 1733 85 15) "src" []]) (ESub (AlexPn 1764 85 46) (EUTEntry (AlexPn 1749 85 31) "balanceOf" [EUTEntry (AlexPn 1759 85 41) "src" []]) (EUTEntry (AlexPn 1766 85 48) "amount" [])),Rewrite (PEntry (AlexPn 1777 86 5) "balanceOf" [EUTEntry (AlexPn 1787 86 15) "dst" []]) (EAdd (AlexPn 1818 86 46) (EUTEntry (AlexPn 1803 86 31) "balanceOf" [EUTEntry (AlexPn 1813 86 41) "dst" []]) (EUTEntry (AlexPn 1820 86 48) "amount" []))]) [] (Just (IntLit (AlexPn 1838 88 11) 1))),Case (AlexPn 1841 90 1) (EEq (AlexPn 1850 90 10) (EUTEntry (AlexPn 1846 90 6) "src" []) (EUTEntry (AlexPn 1853 90 13) "dst" [])) (Post (Just [Constant (PEntry (AlexPn 1875 94 6) "balanceOf" [EnvExp (AlexPn 1885 94 16) Caller]),Constant (PEntry (AlexPn 1898 95 6) "allowance" [EUTEntry (AlexPn 1908 95 16) "src" [],EnvExp (AlexPn 1913 95 21) Caller]),Constant (PEntry (AlexPn 1926 96 6) "balanceOf" [EUTEntry (AlexPn 1936 96 16) "src" []]),Constant (PEntry (AlexPn 1946 97 6) "balanceOf" [EUTEntry (AlexPn 1956 97 16) "dst" []])]) [] (Just (IntLit (AlexPn 1972 99 11) 1)))]) []]
+[Definition (AlexPn 15 1 16) "Token" constructor(string _symbol, string _name, string _version, uint256 _totalSupply) [] (Creates [AssignVal (StorageVar (AlexPn 128 6 10) string "name") (EUTEntry (AlexPn 144 6 26) "_name" []),AssignVal (StorageVar (AlexPn 159 7 10) string "symbol") (EUTEntry (AlexPn 175 7 26) "_symbol" []),AssignVal (StorageVar (AlexPn 193 8 11) uint256 "totalSupply") (EUTEntry (AlexPn 208 8 26) "_totalSupply" []),AssignMany (StorageVar (AlexPn 248 9 28) mapping(address => uint256) "balanceOf") [Defn (EnvExp (AlexPn 263 9 43) Caller) (EUTEntry (AlexPn 273 9 53) "_totalSupply" [])],AssignMany (StorageVar (AlexPn 330 10 44) mapping(address => mapping(address => uint256)) "allowance") []]) [] [] [EEq (AlexPn 373 14 15) (EUTEntry (AlexPn 361 14 3) "totalSupply" []) (EUTEntry (AlexPn 376 14 18) "_totalSupply" []),EEq (AlexPn 396 15 8) (EUTEntry (AlexPn 391 15 3) "name" []) (EUTEntry (AlexPn 399 15 11) "_name" []),EEq (AlexPn 414 16 10) (EUTEntry (AlexPn 407 16 3) "symbol" []) (EUTEntry (AlexPn 417 16 13) "_symbol" [])],Transition (AlexPn 437 19 11) "transfer" "Token" transfer(uint256 value, address to) [Iff (AlexPn 502 22 1) [EEq (AlexPn 519 24 13) (EnvExp (AlexPn 509 24 3) Callvalue) (IntLit (AlexPn 522 24 16) 0),ELEQ (AlexPn 532 25 9) (EUTEntry (AlexPn 526 25 3) "value" []) (EUTEntry (AlexPn 535 25 12) "balanceOf" [EnvExp (AlexPn 545 25 22) Caller]),EImpl (AlexPn 569 26 17) (ENeq (AlexPn 562 26 10) (EnvExp (AlexPn 555 26 3) Caller) (EUTEntry (AlexPn 566 26 14) "to" [])) (ELT (AlexPn 594 26 42) (EAdd (AlexPn 586 26 34) (EUTEntry (AlexPn 572 26 20) "balanceOf" [EUTEntry (AlexPn 582 26 30) "to" []]) (EUTEntry (AlexPn 588 26 36) "value" [])) (EExp (AlexPn 597 26 45) (IntLit (AlexPn 596 26 44) 2) (IntLit (AlexPn 598 26 46) 256)))]] (Branches [Case (AlexPn 603 28 1) (ENeq (AlexPn 615 28 13) (EnvExp (AlexPn 608 28 6) Caller) (EUTEntry (AlexPn 619 28 17) "to" [])) (Post [Rewrite (PEntry (AlexPn 640 32 6) "balanceOf" [EnvExp (AlexPn 650 32 16) Caller]) (ESub (AlexPn 679 32 45) (EUTEntry (AlexPn 661 32 27) "balanceOf" [EnvExp (AlexPn 671 32 37) Caller]) (EUTEntry (AlexPn 681 32 47) "value" [])),Rewrite (PEntry (AlexPn 692 33 6) "balanceOf" [EUTEntry (AlexPn 702 33 16) "to" []]) (EAdd (AlexPn 727 33 41) (EUTEntry (AlexPn 713 33 27) "balanceOf" [EUTEntry (AlexPn 723 33 37) "to" []]) (EUTEntry (AlexPn 729 33 43) "value" []))] [] (Just (IntLit (AlexPn 746 35 11) 1))),Case (AlexPn 749 37 1) (EEq (AlexPn 761 37 13) (EnvExp (AlexPn 754 37 6) Caller) (EUTEntry (AlexPn 764 37 16) "to" [])) (Post [Constant (PEntry (AlexPn 784 41 5) "balanceOf" [EnvExp (AlexPn 794 41 15) Caller]),Constant (PEntry (AlexPn 806 42 5) "balanceOf" [EUTEntry (AlexPn 816 42 15) "to" []])] [] (Just (IntLit (AlexPn 831 44 11) 1)))]) [],Transition (AlexPn 845 47 11) "transferFrom" "Token" transferFrom(address src, address dst, uint256 amount) [Iff (AlexPn 930 50 1) [ELEQ (AlexPn 944 52 10) (EUTEntry (AlexPn 937 52 3) "amount" []) (EUTEntry (AlexPn 947 52 13) "balanceOf" [EnvExp (AlexPn 957 52 23) Caller]),EImpl (AlexPn 982 53 18) (ENeq (AlexPn 974 53 10) (EUTEntry (AlexPn 967 53 3) "src" []) (EUTEntry (AlexPn 978 53 14) "dst" [])) (ELT (AlexPn 1009 53 45) (EAdd (AlexPn 1000 53 36) (EUTEntry (AlexPn 985 53 21) "balanceOf" [EUTEntry (AlexPn 995 53 31) "dst" []]) (EUTEntry (AlexPn 1002 53 38) "amount" [])) (EExp (AlexPn 1012 53 48) (IntLit (AlexPn 1011 53 47) 2) (IntLit (AlexPn 1013 53 49) 256))),EImpl (AlexPn 1034 54 18) (ENeq (AlexPn 1026 54 10) (EnvExp (AlexPn 1019 54 3) Caller) (EUTEntry (AlexPn 1030 54 14) "src" [])) (ELEQ (AlexPn 1039 54 23) (IntLit (AlexPn 1037 54 21) 0) (ESub (AlexPn 1065 54 49) (EUTEntry (AlexPn 1042 54 26) "allowance" [EUTEntry (AlexPn 1052 54 36) "src" [],EnvExp (AlexPn 1057 54 41) Caller]) (EUTEntry (AlexPn 1067 54 51) "amount" []))),EEq (AlexPn 1086 55 13) (EnvExp (AlexPn 1076 55 3) Callvalue) (IntLit (AlexPn 1089 55 16) 0)]] (Branches [Case (AlexPn 1092 57 1) (EAnd (AlexPn 1109 57 18) (ENeq (AlexPn 1101 57 10) (EUTEntry (AlexPn 1097 57 6) "src" []) (EUTEntry (AlexPn 1105 57 14) "dst" [])) (EEq (AlexPn 1120 57 29) (EnvExp (AlexPn 1113 57 22) Caller) (EUTEntry (AlexPn 1123 57 32) "src" []))) (Post [Constant (PEntry (AlexPn 1145 61 6) "balanceOf" [EnvExp (AlexPn 1155 61 16) Caller]),Constant (PEntry (AlexPn 1168 62 6) "allowance" [EUTEntry (AlexPn 1178 62 16) "src" [],EnvExp (AlexPn 1183 62 21) Caller]),Rewrite (PEntry (AlexPn 1196 63 6) "balanceOf" [EUTEntry (AlexPn 1206 63 16) "src" []]) (ESub (AlexPn 1229 63 39) (EUTEntry (AlexPn 1214 63 24) "balanceOf" [EUTEntry (AlexPn 1224 63 34) "src" []]) (EUTEntry (AlexPn 1231 63 41) "amount" [])),Rewrite (PEntry (AlexPn 1243 64 6) "balanceOf" [EUTEntry (AlexPn 1253 64 16) "dst" []]) (EAdd (AlexPn 1276 64 39) (EUTEntry (AlexPn 1261 64 24) "balanceOf" [EUTEntry (AlexPn 1271 64 34) "dst" []]) (EUTEntry (AlexPn 1278 64 41) "amount" []))] [] (Just (IntLit (AlexPn 1296 66 11) 1))),Case (AlexPn 1299 68 1) (EAnd (AlexPn 1335 68 37) (EAnd (AlexPn 1316 68 18) (ENeq (AlexPn 1308 68 10) (EUTEntry (AlexPn 1304 68 6) "src" []) (EUTEntry (AlexPn 1312 68 14) "dst" [])) (ENeq (AlexPn 1327 68 29) (EnvExp (AlexPn 1320 68 22) Caller) (EUTEntry (AlexPn 1331 68 33) "src" []))) (EEq (AlexPn 1362 68 64) (EUTEntry (AlexPn 1339 68 41) "allowance" [EUTEntry (AlexPn 1349 68 51) "src" [],EnvExp (AlexPn 1354 68 56) Caller]) (ESub (AlexPn 1371 68 73) (EExp (AlexPn 1366 68 68) (IntLit (AlexPn 1365 68 67) 2) (IntLit (AlexPn 1367 68 69) 256)) (IntLit (AlexPn 1373 68 75) 1)))) (Post [Constant (PEntry (AlexPn 1393 72 6) "balanceOf" [EnvExp (AlexPn 1403 72 16) Caller]),Constant (PEntry (AlexPn 1416 73 6) "allowance" [EUTEntry (AlexPn 1426 73 16) "src" [],EnvExp (AlexPn 1431 73 21) Caller]),Rewrite (PEntry (AlexPn 1444 74 6) "balanceOf" [EUTEntry (AlexPn 1454 74 16) "src" []]) (ESub (AlexPn 1477 74 39) (EUTEntry (AlexPn 1462 74 24) "balanceOf" [EUTEntry (AlexPn 1472 74 34) "src" []]) (EUTEntry (AlexPn 1479 74 41) "amount" [])),Rewrite (PEntry (AlexPn 1491 75 6) "balanceOf" [EUTEntry (AlexPn 1501 75 16) "dst" []]) (EAdd (AlexPn 1524 75 39) (EUTEntry (AlexPn 1509 75 24) "balanceOf" [EUTEntry (AlexPn 1519 75 34) "dst" []]) (EUTEntry (AlexPn 1526 75 41) "amount" []))] [] (Just (IntLit (AlexPn 1544 77 11) 1))),Case (AlexPn 1547 79 1) (EAnd (AlexPn 1583 79 37) (EAnd (AlexPn 1564 79 18) (ENeq (AlexPn 1556 79 10) (EUTEntry (AlexPn 1552 79 6) "src" []) (EUTEntry (AlexPn 1560 79 14) "dst" [])) (ENeq (AlexPn 1575 79 29) (EnvExp (AlexPn 1568 79 22) Caller) (EUTEntry (AlexPn 1579 79 33) "src" []))) (ELT (AlexPn 1610 79 64) (EUTEntry (AlexPn 1587 79 41) "allowance" [EUTEntry (AlexPn 1597 79 51) "src" [],EnvExp (AlexPn 1602 79 56) Caller]) (ESub (AlexPn 1618 79 72) (EExp (AlexPn 1613 79 67) (IntLit (AlexPn 1612 79 66) 2) (IntLit (AlexPn 1614 79 68) 256)) (IntLit (AlexPn 1620 79 74) 1)))) (Post [Constant (PEntry (AlexPn 1639 83 5) "balanceOf" [EnvExp (AlexPn 1649 83 15) Caller]),Rewrite (PEntry (AlexPn 1661 84 5) "allowance" [EUTEntry (AlexPn 1671 84 15) "src" [],EnvExp (AlexPn 1676 84 20) Caller]) (ESub (AlexPn 1710 84 54) (EUTEntry (AlexPn 1687 84 31) "allowance" [EUTEntry (AlexPn 1697 84 41) "src" [],EnvExp (AlexPn 1702 84 46) Caller]) (EUTEntry (AlexPn 1712 84 56) "amount" [])),Rewrite (PEntry (AlexPn 1723 85 5) "balanceOf" [EUTEntry (AlexPn 1733 85 15) "src" []]) (ESub (AlexPn 1764 85 46) (EUTEntry (AlexPn 1749 85 31) "balanceOf" [EUTEntry (AlexPn 1759 85 41) "src" []]) (EUTEntry (AlexPn 1766 85 48) "amount" [])),Rewrite (PEntry (AlexPn 1777 86 5) "balanceOf" [EUTEntry (AlexPn 1787 86 15) "dst" []]) (EAdd (AlexPn 1818 86 46) (EUTEntry (AlexPn 1803 86 31) "balanceOf" [EUTEntry (AlexPn 1813 86 41) "dst" []]) (EUTEntry (AlexPn 1820 86 48) "amount" []))] [] (Just (IntLit (AlexPn 1838 88 11) 1))),Case (AlexPn 1841 90 1) (EEq (AlexPn 1850 90 10) (EUTEntry (AlexPn 1846 90 6) "src" []) (EUTEntry (AlexPn 1853 90 13) "dst" [])) (Post [Constant (PEntry (AlexPn 1875 94 6) "balanceOf" [EnvExp (AlexPn 1885 94 16) Caller]),Constant (PEntry (AlexPn 1898 95 6) "allowance" [EUTEntry (AlexPn 1908 95 16) "src" [],EnvExp (AlexPn 1913 95 21) Caller]),Constant (PEntry (AlexPn 1926 96 6) "balanceOf" [EUTEntry (AlexPn 1936 96 16) "src" []]),Constant (PEntry (AlexPn 1946 97 6) "balanceOf" [EUTEntry (AlexPn 1956 97 16) "dst" []])] [] (Just (IntLit (AlexPn 1972 99 11) 1)))]) []]

From ed28424c79f290f7db91fb7eef715f431069222d Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Wed, 15 Sep 2021 21:25:12 +0200
Subject: [PATCH 09/36] parser uses new error handling

---
 src/Error.hs | 14 ++++++++--
 src/Main.hs  | 72 +++++++++++++++++++++++-----------------------------
 src/Parse.y  | 11 ++++----
 3 files changed, 50 insertions(+), 47 deletions(-)

diff --git a/src/Error.hs b/src/Error.hs
index 0c85529b..de235c11 100644
--- a/src/Error.hs
+++ b/src/Error.hs
@@ -1,12 +1,12 @@
 {-# LANGUAGE OverloadedLists,TypeOperators, LambdaCase, AllowAmbiguousTypes, TypeApplications, TypeFamilies, DeriveFunctor, ConstraintKinds, UndecidableInstances, FlexibleContexts, FlexibleInstances, RankNTypes, KindSignatures, ApplicativeDo, MultiParamTypeClasses, ScopedTypeVariables, InstanceSigs #-}
 
-module Error where
+module Error (module Error) where
 
 import Control.Monad.Writer hiding (Alt)
 import Data.Functor
 import Data.Functor.Alt
 import Data.List.NonEmpty as NE
-import Data.Validation
+import Data.Validation as Error
 import Data.Proxy
 import Data.Reflection
 import GHC.Generics
@@ -18,6 +18,15 @@ type Error e = Validation (NonEmpty (Pn,e))
 throw :: (Pn,e) -> Error e a
 throw msg = Failure [msg]
 
+infixr 1 <==<, >==>
+
+-- These allow us to chain error-prone computations without a @Monad@ instance.
+(<==<) :: (b -> Error e c) -> (a -> Error e b) -> a -> Error e c
+f <==< g = fromEither . (toEither . f <=< toEither . g)
+
+(>==>) :: (a -> Error e b) -> (b -> Error e c) -> a -> Error e c
+(>==>) = flip (<==<)
+
 -- | If there is no error at the supplied position, we accept this result and
 -- do not attempt to run any later branches, even if there were other errors.
 -- (The second argument looks intimidating but it simply demands that each
@@ -43,3 +52,4 @@ instance (Functor f, Reifies s (Alt_ f)) => Alt (A s f) where
 -- a functor wrapped in 'A'.
 withAlt :: (forall a. f a -> f a -> f a) -> (forall s. Reifies s (Alt_ f) => A s f b) -> f b
 withAlt alt_ comp = reify (Alt_ alt_) $ \(_ :: Proxy s) -> runA @s comp
+
diff --git a/src/Main.hs b/src/Main.hs
index ab6c85e7..42cec6dd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,7 +9,7 @@
 
 module Main where
 
-import Data.Aeson hiding (Bool, Number)
+import Data.Aeson hiding (Bool, Number, Success)
 import GHC.Generics
 import System.Exit ( exitFailure )
 import System.IO (hPutStrLn, stderr, stdout)
@@ -30,7 +30,7 @@ import qualified Data.ByteString.Lazy.Char8 as B
 import Control.Monad
 
 import ErrM
-import qualified ErrorLogger as Logger
+import Error
 import Lex (lexer, AlexPosn(..))
 import Options.Generic
 import Parse
@@ -44,6 +44,8 @@ import qualified Type
 --import Coq hiding (indent)
 --import HEVM
 
+import Data.List.NonEmpty (NonEmpty)
+
 --command line options
 data Command w
   = Lex             { file       :: w ::: String               <?> "Path to file"}
@@ -112,16 +114,12 @@ lex' f = do
 parse' :: FilePath -> IO ()
 parse' f = do
   contents <- readFile f
-  case parse $ lexer contents of
-    Bad e -> prettyErr contents e
-    Ok x -> print x
+  validation (prettyErrs contents) print (parse $ lexer contents)
 
 type' :: FilePath -> IO ()
 type' f = do
   contents <- readFile f
-  case compile contents of
-    Logger.Success a -> B.putStrLn (encode a)
-    Logger.Failure e -> mapM_ (prettyErr contents) e >> exitFailure
+  validation (prettyErrs contents) (B.putStrLn . encode) (compile contents)
 
 -- prove :: FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
 -- prove file' solver' smttimeout' debug' = do
@@ -249,41 +247,35 @@ runSMTWithTimeOut solver' maybeTimeout debug' sym
 
 -- | Fail on error, or proceed with continuation
 proceed :: String -> Type.Err a -> (a -> IO ()) -> IO ()
-proceed contents comp continue = Logger.validation (mapM_ $ prettyErr contents) continue comp
-
---compile :: String -> Err [Claim]
---compile = pure . fmap annotate . enrich <=< typecheck <=< parse . lexer
+proceed contents comp continue = validation (prettyErrs contents) continue comp
 
 compile :: String -> Type.Err [Claim]
-compile source = case parse . lexer $ source of
-  Bad e -> Logger.throw e
-  Ok a  -> fmap annotate . enrich <$> typecheck a
-
-prettyErr :: String -> (Pn, String) -> IO ()
-prettyErr _ (pn, msg) | pn == nowhere = do
-  hPutStrLn stderr "Internal error:"
-  hPutStrLn stderr msg
---  exitFailure
-prettyErr contents (pn, msg) | pn == lastPos = do
-  let culprit = last $ lines contents
-      line' = length (lines contents) - 1
-      col  = length culprit
-  hPutStrLn stderr $ show line' <> " | " <> culprit
-  hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
-  hPutStrLn stderr msg
---  exitFailure
-prettyErr contents (AlexPn _ line' col, msg) = do
-  let cxt = safeDrop (line' - 1) (lines contents)
-  hPutStrLn stderr $ msg <> ":"
-  hPutStrLn stderr $ show line' <> " | " <> head cxt
-  hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
---  exitFailure
+compile = pure . fmap annotate . enrich <==< typecheck <==< parse . lexer
+
+prettyErrs :: Traversable t => String -> t (Pn, String) -> IO ()
+prettyErrs contents errs = mapM_ prettyErr errs >> exitFailure
   where
-    safeDrop :: Int -> [a] -> [a]
-    safeDrop 0 a = a
-    safeDrop _ [] = []
-    safeDrop _ [a] = [a]
-    safeDrop n (_:xs) = safeDrop (n-1) xs
+  prettyErr (pn, msg) | pn == nowhere = do
+    hPutStrLn stderr "Internal error:"
+    hPutStrLn stderr msg
+  prettyErr (pn, msg) | pn == lastPos = do
+    let culprit = last $ lines contents
+        line' = length (lines contents) - 1
+        col  = length culprit
+    hPutStrLn stderr $ show line' <> " | " <> culprit
+    hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
+    hPutStrLn stderr msg
+  prettyErr (AlexPn _ line' col, msg) = do
+    let cxt = safeDrop (line' - 1) (lines contents)
+    hPutStrLn stderr $ msg <> ":"
+    hPutStrLn stderr $ show line' <> " | " <> head cxt
+    hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
+    where
+      safeDrop :: Int -> [a] -> [a]
+      safeDrop 0 a = a
+      safeDrop _ [] = []
+      safeDrop _ [a] = [a]
+      safeDrop n (_:xs) = safeDrop (n-1) xs
 
 -- | prints a Doc, with wider output than the built in `putDoc`
 render :: Doc -> IO ()
diff --git a/src/Parse.y b/src/Parse.y
index 435c4a9a..727337a5 100644
--- a/src/Parse.y
+++ b/src/Parse.y
@@ -6,11 +6,12 @@ import EVM.ABI
 import EVM.Solidity (SlotType(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import Syntax.Untyped
-import ErrM
+import Error
+import Data.Validation
 }
 
 %name parse
-%monad { Err } { (>>=) } { return }
+%monad { Error String } { bindValidation } { pure }
 %tokentype { Lexeme }
 %error { parseError }
 
@@ -309,10 +310,10 @@ lastPos = AlexPn (-1) (-1) (-1)
 validsize :: Int -> Bool
 validsize x = (mod x 8 == 0) && (x >= 8) && (x <= 256)
 
-parseError :: [Lexeme] -> Err a
-parseError [] = Bad (lastPos, "Expected more tokens")
+parseError :: [Lexeme] -> Error String a
+parseError [] = throw (lastPos, "Expected more tokens")
 parseError ((L token pn):_) =
-  Bad $ (pn, concat [
+  throw (pn, concat [
     "parsing error at token ",
     show token])
 }

From 26d9b69b03a344e350933f450c76a2aca8c3e9a5 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Tue, 21 Sep 2021 15:38:04 +0200
Subject: [PATCH 10/36] `Error` doesn't require a `Pn` (backends don't have
 them)

---
 src/Error.hs | 6 +++---
 src/Parse.y  | 4 ++--
 src/Type.hs  | 4 +---
 3 files changed, 6 insertions(+), 8 deletions(-)

diff --git a/src/Error.hs b/src/Error.hs
index de235c11..5ffbc4f0 100644
--- a/src/Error.hs
+++ b/src/Error.hs
@@ -13,9 +13,9 @@ import GHC.Generics
 
 import Syntax.Untyped (Pn)
 
-type Error e = Validation (NonEmpty (Pn,e))
+type Error e = Validation (NonEmpty e)
 
-throw :: (Pn,e) -> Error e a
+throw :: e -> Error e a
 throw msg = Failure [msg]
 
 infixr 1 <==<, >==>
@@ -31,7 +31,7 @@ f <==< g = fromEither . (toEither . f <=< toEither . g)
 -- do not attempt to run any later branches, even if there were other errors.
 -- (The second argument looks intimidating but it simply demands that each
 -- @'Error' e a@ branch is wrapped in 'A' before being passed to '(<!>)'.)
-notAtPosn :: Pn -> (forall s. Reifies s (Alt_ (Error e)) => A s (Error e) a) -> Error e a
+notAtPosn :: Pn -> (forall s. Reifies s (Alt_ (Error (Pn,e))) => A s (Error (Pn,e)) a) -> Error (Pn,e) a
 notAtPosn p = withAlt $ \case
   Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
   res         -> const res
diff --git a/src/Parse.y b/src/Parse.y
index 727337a5..c9828753 100644
--- a/src/Parse.y
+++ b/src/Parse.y
@@ -11,7 +11,7 @@ import Data.Validation
 }
 
 %name parse
-%monad { Error String } { bindValidation } { pure }
+%monad { Error (Pn,String) } { bindValidation } { pure }
 %tokentype { Lexeme }
 %error { parseError }
 
@@ -310,7 +310,7 @@ lastPos = AlexPn (-1) (-1) (-1)
 validsize :: Int -> Bool
 validsize x = (mod x 8 == 0) && (x >= 8) && (x <= 256)
 
-parseError :: [Lexeme] -> Error String a
+parseError :: [Lexeme] -> Error (Pn,String) a
 parseError [] = throw (lastPos, "Expected more tokens")
 parseError ((L token pn):_) =
   throw (pn, concat [
diff --git a/src/Type.hs b/src/Type.hs
index ac544196..25a9ec49 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -45,9 +45,7 @@ import Syntax.Typed
 import Error
 import Parse
 
-type Err a = Error TypeErr a
-
-type TypeErr = String
+type Err = Error (Pn,String)
 
 typecheck :: [U.RawBehaviour] -> Err [Claim]
 typecheck behvs = (S store:) . concat <$> traverse (splitBehaviour store) behvs

From 78327c82849c23ec7ad2e1e84b6aff50732fcf47 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Tue, 21 Sep 2021 15:39:32 +0200
Subject: [PATCH 11/36] add test to check error messages of polymorphic stuff

---
 tests/frontend/fail/typecheck/silly_types.act | 24 +++++++++++++++++++
 1 file changed, 24 insertions(+)
 create mode 100644 tests/frontend/fail/typecheck/silly_types.act

diff --git a/tests/frontend/fail/typecheck/silly_types.act b/tests/frontend/fail/typecheck/silly_types.act
new file mode 100644
index 00000000..da278961
--- /dev/null
+++ b/tests/frontend/fail/typecheck/silly_types.act
@@ -0,0 +1,24 @@
+constructor of Pass
+interface constructor()
+
+creates
+
+    uint x := 0
+    uint y := 2
+    bool p := true
+    bool q := false
+
+behaviour g of Pass
+interface g()
+
+iff in range uint256
+
+    x + y
+
+storage
+
+    // TODO: remove this hack once bug #81 is fixed...
+    x => x
+    y => (x + p) == (q > y)
+    p => (x + p) and (q > y)
+    q

From f76384ca3def56e8fcbaa37a29ec37f65b1438de Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 27 Sep 2021 15:59:28 +0200
Subject: [PATCH 12/36] `K.hs` uses `Error.hs`

---
 src/Error.hs  | 14 ++++++++------
 src/K.hs      | 34 +++++++++++++++++-----------------
 src/Main.hs   | 46 +++++++++++++++++++++++++---------------------
 src/Parse.y   |  4 ++--
 src/Syntax.hs | 14 ++++++++++++++
 src/Type.hs   |  5 ++---
 6 files changed, 68 insertions(+), 49 deletions(-)

diff --git a/src/Error.hs b/src/Error.hs
index 5ffbc4f0..ed33bae5 100644
--- a/src/Error.hs
+++ b/src/Error.hs
@@ -13,25 +13,28 @@ import GHC.Generics
 
 import Syntax.Untyped (Pn)
 
-type Error e = Validation (NonEmpty e)
+-- Reexport NonEmpty so that we can use `-XOverloadedLists` without thinking.
+import Data.List.NonEmpty as Error (NonEmpty)
 
-throw :: e -> Error e a
+type Error e = Validation (NonEmpty (Pn,e))
+
+throw :: (Pn,e) -> Error e a
 throw msg = Failure [msg]
 
 infixr 1 <==<, >==>
 
 -- These allow us to chain error-prone computations without a @Monad@ instance.
 (<==<) :: (b -> Error e c) -> (a -> Error e b) -> a -> Error e c
-f <==< g = fromEither . (toEither . f <=< toEither . g)
+(<==<) = flip (>==>)
 
 (>==>) :: (a -> Error e b) -> (b -> Error e c) -> a -> Error e c
-(>==>) = flip (<==<)
+f >==> g = \x -> f x `bindValidation` g
 
 -- | If there is no error at the supplied position, we accept this result and
 -- do not attempt to run any later branches, even if there were other errors.
 -- (The second argument looks intimidating but it simply demands that each
 -- @'Error' e a@ branch is wrapped in 'A' before being passed to '(<!>)'.)
-notAtPosn :: Pn -> (forall s. Reifies s (Alt_ (Error (Pn,e))) => A s (Error (Pn,e)) a) -> Error (Pn,e) a
+notAtPosn :: Pn -> (forall s. Reifies s (Alt_ (Error e)) => A s (Error e) a) -> Error e a
 notAtPosn p = withAlt $ \case
   Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
   res         -> const res
@@ -52,4 +55,3 @@ instance (Functor f, Reifies s (Alt_ f)) => Alt (A s f) where
 -- a functor wrapped in 'A'.
 withAlt :: (forall a. f a -> f a -> f a) -> (forall s. Reifies s (Alt_ f) => A s f b) -> f b
 withAlt alt_ comp = reify (Alt_ alt_) $ \(_ :: Proxy s) -> runA @s comp
-
diff --git a/src/K.hs b/src/K.hs
index ead0c244..37941ae2 100644
--- a/src/K.hs
+++ b/src/K.hs
@@ -3,13 +3,14 @@
 {-# Language OverloadedStrings #-}
 {-# Language ScopedTypeVariables #-}
 {-# Language TypeApplications #-}
+{-# LANGUAGE ApplicativeDo, OverloadedLists #-}
 
 module K where
 
 import Syntax
 import Syntax.Annotated
 
-import ErrM
+import Error
 import Control.Applicative ((<|>))
 import Data.Functor (($>))
 import Data.Text (Text, pack, unpack)
@@ -28,6 +29,8 @@ import qualified Data.Map.Strict as Map -- abandon in favor of [(a,b)]?
 -- Transforms a RefinedSyntax.Behaviour
 -- to a k spec.
 
+type Err = Error String
+
 cell :: String -> String -> String
 cell key value = "<" <> key <> "> " <> value <> " </" <> key <> "> \n"
 
@@ -60,13 +63,12 @@ makekSpec sources _ behaviour =
       hasLayout = Map.foldr ((&&) . isJust . _storageLayout) True sources
   in
     if hasLayout then do
-      thisSource <- errMessage
-            (nowhere, "err: " <> show this <> "Bytecode not found\nSources available: " <> show (Map.keys sources))
-            (Map.lookup this names)
-
-      return $ mkTerm thisSource names behaviour
+      thisSource <- validate
+        [(nowhere, unlines ["Bytecode not found for:", show this, "Sources available:", show $ Map.keys sources])]
+        (Map.lookup this) names
+      pure $ mkTerm thisSource names behaviour
 
-    else Bad (nowhere, "No storagelayout found")
+    else throw (nowhere, "No storagelayout found")
 
 kCalldata :: Interface -> String
 kCalldata (Interface a args) =
@@ -76,8 +78,8 @@ kCalldata (Interface a args) =
      else intercalate ", " (fmap (\(Decl typ varname) -> "#" <> show typ <> "(" <> kVar varname <> ")") args)
   <> ")"
 
-kStorageName :: TStorageItem a -> When -> String
-kStorageName item t = kVar (idFromItem item) <> "-" <> show t
+kStorageName :: When -> TStorageItem a -> String
+kStorageName t item = kVar (idFromItem item) <> "-" <> show t
                    <> intercalate "_" ("" : fmap kTypedExpr (ixsFromItem item))
 
 kVar :: Id -> String
@@ -107,7 +109,6 @@ kExpr (IntMin a) = kExpr $ LitInt $ negate $ 2 ^ (a - 1)
 kExpr (IntMax a) = kExpr $ LitInt $ 2 ^ (a - 1) - 1
 kExpr (UIntMin _) = kExpr $ LitInt 0
 kExpr (UIntMax a) = kExpr $ LitInt $ 2 ^ a - 1
-kExpr (IntVar a) = kVar a
 kExpr (IntEnv a) = show a
 
 -- booleans
@@ -120,7 +121,6 @@ kExpr (LEQ a b) = "(" <> kExpr a <> " <=Int " <> kExpr b <> ")"
 kExpr (GE a b) = "(" <> kExpr a <> " >Int " <> kExpr b <> ")"
 kExpr (GEQ a b) = "(" <> kExpr a <> " >=Int " <> kExpr b <> ")"
 kExpr (LitBool a) = show a
-kExpr (BoolVar a) = kVar a
 kExpr (NEq a b) = "notBool (" <> kExpr (Eq a b) <> ")"
 kExpr (Eq (a :: Exp a) (b :: Exp a)) = fromMaybe (error "Internal Error: invalid expression type") $
   let eqK typ = "(" <> kExpr a <> " ==" <> typ <> " " <> kExpr b <> ")"
@@ -129,10 +129,10 @@ kExpr (Eq (a :: Exp a) (b :: Exp a)) = fromMaybe (error "Internal Error: invalid
   <|> eqT @a @ByteString $> eqK "K" -- TODO: Is ==K correct?
 
 -- bytestrings
-kExpr (ByVar name) = kVar name
 kExpr (ByStr str) = show str
 kExpr (ByLit bs) = show bs
-kExpr (TEntry item t) = kStorageName item t
+kExpr (TEntry t item) = kStorageName t item
+kExpr (Var _ a) = kVar a
 kExpr v = error ("Internal error: TODO kExpr of " <> show v)
 --kExpr (Cat a b) =
 --kExpr (Slice a start end) =
@@ -154,10 +154,10 @@ kStorageEntry storageLayout update =
          (error "Internal error: storageVar not found, please report this error")
          (Map.lookup (pack (idFromRewrite update)) storageLayout)
   in case update of
-       Rewrite (IntUpdate a b) -> (loc, (offset, kStorageName a Pre, kExpr b))
-       Rewrite (BoolUpdate a b) -> (loc, (offset, kStorageName a Pre, kExpr b))
-       Rewrite (BytesUpdate a b) -> (loc, (offset, kStorageName a Pre, kExpr b))
-       Constant (IntLoc a) -> (loc, (offset, kStorageName a Pre, kStorageName a Pre))
+       Rewrite (IntUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
+       Rewrite (BoolUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
+       Rewrite (BytesUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
+       Constant (IntLoc a) -> (loc, (offset, kStorageName Pre a, kStorageName Pre a))
        v -> error $ "Internal error: TODO kStorageEntry: " <> show v
 
 --packs entries packed in one slot
diff --git a/src/Main.hs b/src/Main.hs
index 42cec6dd..5a8e47c5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# Language TypeOperators #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Main where
 
@@ -18,6 +19,7 @@ import Data.Text (pack, unpack)
 import Data.List
 import Data.Maybe
 import Data.Tree
+import Data.Traversable
 import qualified EVM.Solidity as Solidity
 import qualified Data.Text as Text
 import qualified Data.Text.IO as TIO
@@ -28,23 +30,25 @@ import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
 import qualified Data.ByteString.Lazy.Char8 as B
 
 import Control.Monad
+import Control.Lens.Getter
 
 import ErrM
 import Error
 import Lex (lexer, AlexPosn(..))
 import Options.Generic
 import Parse
+import Syntax
 import Syntax.Annotated
 import Syntax.Untyped
 import Enrich
---import K hiding (normalize, indent)
+import K hiding (normalize, indent)
 --import SMT
 import Type hiding (Err)
 import qualified Type
 --import Coq hiding (indent)
 --import HEVM
 
-import Data.List.NonEmpty (NonEmpty)
+import Data.Validation
 
 --command line options
 data Command w
@@ -97,7 +101,7 @@ main = do
       Type f -> type' f
       --Prove file' solver' smttimeout' debug' -> prove file' solver' smttimeout' debug'
       --Coq f -> coq' f
-      --K spec' soljson' gas' storage' extractbin' out' -> k spec' soljson' gas' storage' extractbin' out'
+      K spec' soljson' gas' storage' extractbin' out' -> k spec' soljson' gas' storage' extractbin' out'
       --HEVM spec' soljson' solver' smttimeout' debug' -> hevm spec' soljson' solver' smttimeout' debug'
 
 
@@ -187,21 +191,21 @@ type' f = do
 --   proceed contents (compile contents) $ \claims ->
 --     TIO.putStr $ coq claims
 
--- k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
--- k spec' soljson' gas' storage' extractbin' out' = do
---   specContents <- readFile spec'
---   solContents  <- readFile soljson'
---   let kOpts = KOptions (maybe mempty Map.fromList gas') storage' extractbin'
---       errKSpecs = do refinedSpecs <- compile specContents
---                      (sources, _, _) <- errMessage (nowhere, "Could not read sol.json")
---                        $ Solidity.readJSON $ pack solContents
---                      forM [b | B b <- refinedSpecs]
---                        $ makekSpec sources kOpts
---   proceed specContents errKSpecs $ \kSpecs -> do
---     let printFile (filename, content) = case out' of
---           Nothing -> putStrLn (filename <> ".k") >> putStrLn content
---           Just dir -> writeFile (dir <> "/" <> filename <> ".k") content
---     forM_ kSpecs printFile
+k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
+k spec' soljson' gas' storage' extractbin' out' = do
+  specContents <- readFile spec'
+  solContents  <- readFile soljson'
+  let kOpts = KOptions (maybe mempty Map.fromList gas') storage' extractbin'
+      errKSpecs = do
+        refinedSpecs <- toEither $ behaviours <$> compile specContents
+        (sources, _, _) <- validate [(nowhere, "Could not read sol.json")]
+                              (Solidity.readJSON . pack) solContents
+        for refinedSpecs (makekSpec sources kOpts) ^. _Either
+  proceed specContents errKSpecs $ \kSpecs -> do
+    let printFile (filename, content) = case out' of
+          Nothing -> putStrLn (filename <> ".k") >> putStrLn content
+          Just dir -> writeFile (dir <> "/" <> filename <> ".k") content
+    forM_ kSpecs printFile
 
 -- hevm :: FilePath -> FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
 -- hevm spec' soljson' solver' smttimeout' smtdebug' = do
@@ -246,10 +250,10 @@ runSMTWithTimeOut solver' maybeTimeout debug' sym
        runwithz3 = runSMTWith z3{verbose=debug'} $ (setTimeOut timeout) >> sym
 
 -- | Fail on error, or proceed with continuation
-proceed :: String -> Type.Err a -> (a -> IO ()) -> IO ()
-proceed contents comp continue = validation (prettyErrs contents) continue comp
+proceed :: Validate err => String -> err (NonEmpty (Pn, String)) a -> (a -> IO ()) -> IO ()
+proceed contents comp continue = validation (prettyErrs contents) continue (comp ^. revalidate)
 
-compile :: String -> Type.Err [Claim]
+compile :: String -> Error String [Claim]
 compile = pure . fmap annotate . enrich <==< typecheck <==< parse . lexer
 
 prettyErrs :: Traversable t => String -> t (Pn, String) -> IO ()
diff --git a/src/Parse.y b/src/Parse.y
index c9828753..727337a5 100644
--- a/src/Parse.y
+++ b/src/Parse.y
@@ -11,7 +11,7 @@ import Data.Validation
 }
 
 %name parse
-%monad { Error (Pn,String) } { bindValidation } { pure }
+%monad { Error String } { bindValidation } { pure }
 %tokentype { Lexeme }
 %error { parseError }
 
@@ -310,7 +310,7 @@ lastPos = AlexPn (-1) (-1) (-1)
 validsize :: Int -> Bool
 validsize x = (mod x 8 == 0) && (x >= 8) && (x <= 256)
 
-parseError :: [Lexeme] -> Error (Pn,String) a
+parseError :: [Lexeme] -> Error String a
 parseError [] = throw (lastPos, "Expected more tokens")
 parseError ((L token pn):_) =
   throw (pn, concat [
diff --git a/src/Syntax.hs b/src/Syntax.hs
index ccf3ab09..9253b583 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -11,6 +11,8 @@ module Syntax where
 import Data.List
 import Data.Map (Map,empty,insertWith,unionsWith)
 
+import Error
+
 import Syntax.TimeAgnostic as Agnostic
 import qualified Syntax.Annotated as Annotated
 import           Syntax.Untyped hiding (Constant,Rewrite)
@@ -42,6 +44,18 @@ locsFromConstructor (Constructor _ _ _ pre post initialStorage rewrites) = nub $
 -- * Extract from any typed AST * --
 ------------------------------------
 
+constructors :: [Claim t] -> [Constructor t]
+constructors claims = [c | C c <- claims]
+
+behaviours :: [Claim t] -> [Behaviour t]
+behaviours claims = [b | B b <- claims]
+
+invariants :: [Claim t] -> [Invariant t]
+invariants claims = [i | I i <- claims]
+
+stores :: [Claim t] -> [Store]
+stores claims = [s | S s <- claims]
+
 locsFromRewrite :: Rewrite t -> [StorageLocation t]
 locsFromRewrite update = nub $ case update of
   Constant loc -> [loc]
diff --git a/src/Type.hs b/src/Type.hs
index 25a9ec49..5576264d 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -39,13 +39,12 @@ import Data.Singletons
 import Syntax
 import Syntax.Timing
 import Syntax.Untyped (Pn)
---import Syntax.Untyped hiding (Post,Constant,Rewrite)
 import qualified Syntax.Untyped as U
 import Syntax.Typed
 import Error
 import Parse
 
-type Err = Error (Pn,String)
+type Err = Error String
 
 typecheck :: [U.RawBehaviour] -> Err [Claim]
 typecheck behvs = (S store:) . concat <$> traverse (splitBehaviour store) behvs
@@ -124,12 +123,12 @@ mkEnv contract store decls = Env
 -- checks a transition given a typing of its storage variables
 splitBehaviour :: Store -> U.RawBehaviour -> Err [Claim]
 splitBehaviour store (U.Transition pn name contract iface@(Interface _ decls) iffs cases posts) =
+  noIllegalWilds *>
   -- constrain integer calldata variables (TODO: other types)
   fmap concatMap (caseClaims
                     <$> checkIffs env iffs
                     <*> traverse (inferExpr env) posts)
     <*> traverse (checkCase env) normalizedCases
-  <* noIllegalWilds
   where
     env :: Env
     env = mkEnv contract store decls

From f8c08bdcfbafb43d8abe3a3a0b77fcc2cb48648a Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 27 Sep 2021 22:28:33 +0200
Subject: [PATCH 13/36] cleanup, reorg, some adaptations to new styles

---
 src/CLI.hs                 | 284 +++++++++++++++++++++++++++++++++++++
 src/Coq.hs                 |  14 +-
 src/ErrM.hs                |  43 ------
 src/Error.hs               |   3 -
 src/HEVM.hs                |  26 ++--
 src/Main.hs                | 284 +------------------------------------
 src/SMT.hs                 |  15 +-
 src/Syntax.hs              |  27 ++--
 src/Syntax/TimeAgnostic.hs |  72 ++--------
 src/Syntax/Types.hs        |  68 +++++++++
 src/Type.hs                |  39 +++--
 src/act.cabal              |   2 +-
 src/test/Test.hs           |  20 ++-
 13 files changed, 424 insertions(+), 473 deletions(-)
 create mode 100644 src/CLI.hs
 delete mode 100644 src/ErrM.hs
 create mode 100644 src/Syntax/Types.hs

diff --git a/src/CLI.hs b/src/CLI.hs
new file mode 100644
index 00000000..8fe2c34f
--- /dev/null
+++ b/src/CLI.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE DeriveGeneric  #-}
+{-# Language DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# Language TypeOperators #-}
+{-# LANGUAGE OverloadedLists, ApplicativeDo #-}
+
+module CLI (main, compile) where
+
+import Data.Aeson hiding (Bool, Number, Success)
+import GHC.Generics
+import System.Exit ( exitFailure )
+import System.IO (hPutStrLn, stderr, stdout)
+import Data.SBV hiding (preprocess, sym, prove)
+import Data.Text (pack, unpack)
+import Data.List
+import Data.Maybe
+import Data.Tree
+import Data.Traversable
+import qualified EVM.Solidity as Solidity
+import qualified Data.Text as Text
+import qualified Data.Text.IO as TIO
+import qualified Data.Map.Strict as Map
+import System.Environment (setEnv)
+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
+
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import Control.Monad
+import Control.Lens.Getter
+
+import Error
+import Lex (lexer, AlexPosn(..))
+import Options.Generic
+import Parse
+import Syntax
+import Syntax.Annotated
+import Syntax.Untyped
+import Enrich
+import K hiding (normalize, indent)
+import SMT
+import Type
+import Coq hiding (indent)
+import HEVM
+
+--command line options
+data Command w
+  = Lex             { file       :: w ::: String               <?> "Path to file"}
+
+  | Parse           { file       :: w ::: String               <?> "Path to file"}
+
+  | Type            { file       :: w ::: String               <?> "Path to file"}
+
+  | Prove           { file       :: w ::: String               <?> "Path to file"
+                    , solver     :: w ::: Maybe Text           <?> "SMT solver: z3 (default) or cvc4"
+                    , smttimeout :: w ::: Maybe Integer        <?> "Timeout given to SMT solver in milliseconds (default: 20000)"
+                    , debug      :: w ::: Bool                 <?> "Print verbose SMT output (default: False)"
+                    }
+
+  | Coq             { file       :: w ::: String               <?> "Path to file"}
+
+  | K               { spec       :: w ::: String               <?> "Path to spec"
+                    , soljson    :: w ::: String               <?> "Path to .sol.json"
+                    , gas        :: w ::: Maybe [(Id, String)] <?> "Gas usage per spec"
+                    , storage    :: w ::: Maybe String         <?> "Path to storage definitions"
+                    , extractbin :: w ::: Bool                 <?> "Put EVM bytecode in separate file"
+                    , out        :: w ::: Maybe String         <?> "output directory"
+                    }
+
+  | HEVM            { spec       :: w ::: String               <?> "Path to spec"
+                    , soljson    :: w ::: String               <?> "Path to .sol.json"
+                    , solver     :: w ::: Maybe Text           <?> "SMT solver: z3 (default) or cvc4"
+                    , smttimeout :: w ::: Maybe Integer        <?> "Timeout given to SMT solver in milliseconds (default: 20000)"
+                    , debug      :: w ::: Bool                 <?> "Print verbose SMT output (default: False)"
+                    }
+ deriving (Generic)
+
+deriving instance ParseField [(Id, String)]
+instance ParseRecord (Command Wrapped)
+deriving instance Show (Command Unwrapped)
+
+
+-----------------------
+-- *** Dispatch *** ---
+-----------------------
+
+
+main :: IO ()
+main = do
+    cmd <- unwrapRecord "Act -- Smart contract specifier"
+    case cmd of
+      Lex f -> lex' f
+      Parse f -> parse' f
+      Type f -> type' f
+      Prove file' solver' smttimeout' debug' -> prove file' solver' smttimeout' debug'
+      Coq f -> coq' f
+      K spec' soljson' gas' storage' extractbin' out' -> k spec' soljson' gas' storage' extractbin' out'
+      HEVM spec' soljson' solver' smttimeout' debug' -> hevm spec' soljson' solver' smttimeout' debug'
+
+
+---------------------------------
+-- *** CLI implementation *** ---
+---------------------------------
+
+
+lex' :: FilePath -> IO ()
+lex' f = do
+  contents <- readFile f
+  print $ lexer contents
+
+parse' :: FilePath -> IO ()
+parse' f = do
+  contents <- readFile f
+  validation (prettyErrs contents) print (parse $ lexer contents)
+
+type' :: FilePath -> IO ()
+type' f = do
+  contents <- readFile f
+  validation (prettyErrs contents) (B.putStrLn . encode) (compile True contents)
+
+prove :: FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
+prove file' solver' smttimeout' debug' = do
+  let
+    parseSolver s = case s of
+      Just "z3" -> SMT.Z3
+      Just "cvc4" -> SMT.CVC4
+      Nothing -> SMT.Z3
+      Just _ -> error "unrecognized solver"
+    config = SMT.SMTConfig (parseSolver solver') (fromMaybe 20000 smttimeout') debug'
+  contents <- readFile file'
+  proceed contents (compile True contents) $ \claims -> do
+    let
+      catModels results = [m | Sat m <- results]
+      catErrors results = [e | e@SMT.Error {} <- results]
+      catUnknowns results = [u | u@SMT.Unknown {} <- results]
+
+      (<->) :: Doc -> [Doc] -> Doc
+      x <-> y = x <$$> line <> (indent 2 . vsep $ y)
+
+      failMsg :: [SMT.SMTResult] -> Doc
+      failMsg results
+        | not . null . catUnknowns $ results
+            = text "could not be proven due to a" <+> (yellow . text $ "solver timeout")
+        | not . null . catErrors $ results
+            = (red . text $ "failed") <+> "due to solver errors:" <-> ((fmap (text . show)) . catErrors $ results)
+        | otherwise
+            = (red . text $ "violated") <> colon <-> (fmap pretty . catModels $ results)
+
+      passMsg :: Doc
+      passMsg = (green . text $ "holds") <+> (bold . text $ "∎")
+
+      accumulateResults :: (Bool, Doc) -> (Query, [SMT.SMTResult]) -> (Bool, Doc)
+      accumulateResults (status, report) (query, results) = (status && holds, report <$$> msg <$$> smt)
+        where
+          holds = all isPass results
+          msg = identifier query <+> if holds then passMsg else failMsg results
+          smt = if debug' then line <> getSMT query else empty
+
+    solverInstance <- spawnSolver config
+    pcResults <- mapM (runQuery solverInstance) (concatMap mkPostconditionQueries claims)
+    invResults <- mapM (runQuery solverInstance) (mkInvariantQueries claims)
+    stopSolver solverInstance
+
+    let
+      invTitle = line <> (underline . bold . text $ "Invariants:") <> line
+      invOutput = foldl' accumulateResults (True, empty) invResults
+
+      pcTitle = line <> (underline . bold . text $ "Postconditions:") <> line
+      pcOutput = foldl' accumulateResults (True, empty) pcResults
+
+    render $ vsep
+      [ ifExists invResults invTitle
+      , indent 2 $ snd invOutput
+      , ifExists pcResults pcTitle
+      , indent 2 $ snd pcOutput
+      ]
+
+    unless (fst invOutput && fst pcOutput) exitFailure
+
+
+coq' :: FilePath -> IO()
+coq' f = do
+  contents <- readFile f
+  proceed contents (compile True contents) $ \claims ->
+    TIO.putStr $ coq claims
+
+k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
+k spec' soljson' gas' storage' extractbin' out' = do
+  specContents <- readFile spec'
+  solContents  <- readFile soljson'
+  let kOpts = KOptions (maybe mempty Map.fromList gas') storage' extractbin'
+      errKSpecs = do
+        behvs <- toEither $ behvsFromClaims <$> compile True specContents
+        (sources, _, _) <- validate [(nowhere, "Could not read sol.json")]
+                              (Solidity.readJSON . pack) solContents
+        for behvs (makekSpec sources kOpts) ^. revalidate
+  proceed specContents errKSpecs $ \kSpecs -> do
+    let printFile (filename, content) = case out' of
+          Nothing -> putStrLn (filename <> ".k") >> putStrLn content
+          Just dir -> writeFile (dir <> "/" <> filename <> ".k") content
+    forM_ kSpecs printFile
+
+hevm :: FilePath -> FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
+hevm spec' soljson' solver' smttimeout' smtdebug' = do
+  specContents <- readFile spec'
+  solContents  <- readFile soljson'
+  let preprocess = do behvs <- behvsFromClaims <$> compile True specContents
+                      (sources, _, _) <- validate [(nowhere, "Could not read sol.json")]
+                        (Solidity.readJSON . pack) solContents
+                      pure (behvs, sources)
+  proceed specContents preprocess $ \(specs, sources) -> do
+    -- TODO: prove constructor too
+    passes <- forM specs $ \behv -> do
+      res <- runSMTWithTimeOut solver' smttimeout' smtdebug' $ proveBehaviour sources behv
+      case res of
+        Left posts -> do
+           putStrLn $ "Successfully proved " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
+             <> ", " <> show (length $ last $ levels posts) <> " cases."
+           return True
+        Right _ -> do
+           putStrLn $ "Failed to prove " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
+           return False
+    unless (and passes) exitFailure
+
+
+-------------------
+-- *** Util *** ---
+-------------------
+
+
+-- cvc4 sets timeout via a commandline option instead of smtlib `(set-option)`
+runSMTWithTimeOut :: Maybe Text -> Maybe Integer -> Bool -> Symbolic a -> IO a
+runSMTWithTimeOut solver' maybeTimeout debug' sym
+  | solver' == Just "cvc4" = do
+      setEnv "SBV_CVC4_OPTIONS" ("--lang=smt --incremental --interactive --no-interactive-prompt --model-witness-value --tlimit-per=" <> show timeout)
+      res <- runSMTWith cvc4{verbose=debug'} sym
+      setEnv "SBV_CVC4_OPTIONS" ""
+      return res
+  | solver' == Just "z3" = runwithz3
+  | isNothing solver' = runwithz3
+  | otherwise = error "Unknown solver. Currently supported solvers; z3, cvc4"
+ where timeout = fromMaybe 20000 maybeTimeout
+       runwithz3 = runSMTWith z3{verbose=debug'} $ (setTimeOut timeout) >> sym
+
+-- | Fail on error, or proceed with continuation
+proceed :: Validate err => String -> err (NonEmpty (Pn, String)) a -> (a -> IO ()) -> IO ()
+proceed contents comp continue = validation (prettyErrs contents) continue (comp ^. revalidate)
+
+compile :: Bool -> String -> Error String [Claim]
+compile shouldEnrich = pure . fmap annotate . enrich' <==< typecheck <==< parse . lexer
+  where
+    enrich' = if shouldEnrich then enrich else id
+
+prettyErrs :: Traversable t => String -> t (Pn, String) -> IO ()
+prettyErrs contents errs = mapM_ prettyErr errs >> exitFailure
+  where
+  prettyErr (pn, msg) | pn == nowhere = do
+    hPutStrLn stderr "Internal error:"
+    hPutStrLn stderr msg
+  prettyErr (pn, msg) | pn == lastPos = do
+    let culprit = last $ lines contents
+        line' = length (lines contents) - 1
+        col  = length culprit
+    hPutStrLn stderr $ show line' <> " | " <> culprit
+    hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
+    hPutStrLn stderr msg
+  prettyErr (AlexPn _ line' col, msg) = do
+    let cxt = safeDrop (line' - 1) (lines contents)
+    hPutStrLn stderr $ msg <> ":"
+    hPutStrLn stderr $ show line' <> " | " <> head cxt
+    hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
+    where
+      safeDrop :: Int -> [a] -> [a]
+      safeDrop 0 a = a
+      safeDrop _ [] = []
+      safeDrop _ [a] = [a]
+      safeDrop n (_:xs) = safeDrop (n-1) xs
+
+-- | prints a Doc, with wider output than the built in `putDoc`
+render :: Doc -> IO ()
+render doc = displayIO stdout (renderPretty 0.9 120 doc)
diff --git a/src/Coq.hs b/src/Coq.hs
index 4e42778f..8f93e139 100644
--- a/src/Coq.hs
+++ b/src/Coq.hs
@@ -237,7 +237,7 @@ coqexp :: Exp a -> T.Text
 -- booleans
 coqexp (LitBool True)  = "true"
 coqexp (LitBool False) = "false"
-coqexp (BoolVar name)  = T.pack name
+coqexp (Var SBoolean 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
@@ -251,7 +251,7 @@ coqexp (GEQ e1 e2)  = parens $ coqexp e2 <> " <=? " <> coqexp e1
 
 -- integers
 coqexp (LitInt i) = T.pack $ show i
-coqexp (IntVar name)  = T.pack name
+coqexp (Var SInteger 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
@@ -264,7 +264,7 @@ coqexp (UIntMin n) = parens $ "UINT_MIN " <> T.pack (show n)
 coqexp (UIntMax n) = parens $ "UINT_MAX " <> T.pack (show n)
 
 -- polymorphic
-coqexp (TEntry e w) = entry e w
+coqexp (TEntry w e) = entry e w
 coqexp (ITE b e1 e2) = parens $ "if "
                              <> coqexp b
                              <> " then "
@@ -276,7 +276,7 @@ coqexp (ITE b e1 e2) = parens $ "if "
 coqexp (IntEnv e) = error $ show e <> ": environment values not yet supported"
 coqexp (Cat _ _) = error "bytestrings not supported"
 coqexp (Slice _ _ _) = error "bytestrings not supported"
-coqexp (ByVar _) = 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"
@@ -305,9 +305,9 @@ typedexp (ExpBool e)  = coqexp e
 typedexp (ExpBytes _) = error "bytestrings not supported"
 
 entry :: TStorageItem a -> When -> T.Text
-entry BytesItem{} _    = error "bytestrings not supported"
-entry _           Post = error "TODO: missing support for poststate references in coq backend"
-entry item        Pre  = case ixsFromItem item of
+entry (Item SByteStr _ _ _) _    = error "bytestrings not supported"
+entry _                     Post = error "TODO: missing support for poststate references in coq backend"
+entry item                  _    = case ixsFromItem item of
   []       -> parens $ T.pack (idFromItem item) <> " " <> stateVar
   (ix:ixs) -> parens $ T.pack (idFromItem item) <> " s " <> coqargs (ix :| ixs)
 
diff --git a/src/ErrM.hs b/src/ErrM.hs
deleted file mode 100644
index 7228144e..00000000
--- a/src/ErrM.hs
+++ /dev/null
@@ -1,43 +0,0 @@
--- BNF Converter: Error Monad
--- Copyright (C) 2004  Author:  Aarne Ranta
-
--- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
-module ErrM where
-import Lex (AlexPosn (..))
-import Syntax.Untyped
--- the Error monad: like Maybe type with error msgs
-
-import Control.Monad (MonadPlus(..), liftM)
-import Control.Applicative (Alternative(..))
-
-data Err a = Ok a | Bad (AlexPosn, String)
-  deriving (Show, Eq)
-
-instance Monad Err where
-  return      = Ok
-  Ok a  >>= f = f a
-  Bad s >>= _ = Bad s
-
-instance Applicative Err where
-  pure = Ok
-  (Bad s) <*> _ = Bad s
-  (Ok f) <*> o  = liftM f o
-
-instance Functor Err where
-  fmap = liftM
-
-instance MonadPlus Err where
-  mzero = Bad (error"", "Err.mzero")
-  mplus (Bad _) y = y
-  mplus x       _ = x
-
-instance MonadFail Err where
-  fail _ = mzero
-
-instance Alternative Err where
-  empty = mzero
-  (<|>) = mplus
-
-errMessage :: (Pn, String) -> Maybe a -> Err a
-errMessage _ (Just c) = Ok c
-errMessage e Nothing = Bad e
diff --git a/src/Error.hs b/src/Error.hs
index ed33bae5..e55984cb 100644
--- a/src/Error.hs
+++ b/src/Error.hs
@@ -2,14 +2,11 @@
 
 module Error (module Error) where
 
-import Control.Monad.Writer hiding (Alt)
-import Data.Functor
 import Data.Functor.Alt
 import Data.List.NonEmpty as NE
 import Data.Validation as Error
 import Data.Proxy
 import Data.Reflection
-import GHC.Generics
 
 import Syntax.Untyped (Pn)
 
diff --git a/src/HEVM.hs b/src/HEVM.hs
index 8e79099e..a2583054 100644
--- a/src/HEVM.hs
+++ b/src/HEVM.hs
@@ -323,8 +323,8 @@ symExpBool ctx@(Ctx c m args store _) e = case e of
   NEq a b   -> sNot (symExpBool ctx (Eq a b))
   Neg a     -> sNot (symExpBool ctx a)
   LitBool a -> literal a
-  BoolVar a -> get (nameFromArg c m a) (catBools args)
-  TEntry a t -> get (nameFromItem m a) (catBools $ timeStore t store)
+  Var _ a   -> get (nameFromArg c m a) (catBools args)
+  TEntry t a -> get (nameFromItem m a) (catBools $ timeStore t store)
   ITE x y z -> ite (symExpBool ctx x) (symExpBool ctx y) (symExpBool ctx z)
   Eq a b -> fromMaybe (error "Internal error: invalid expression type")
       $ [symExpBool  ctx a' .== symExpBool  ctx b' | a' <- castType a, b' <- castType b]
@@ -344,8 +344,8 @@ symExpInt ctx@(Ctx c m args store environment) e = case e of
   IntMax a  -> literal $ intmax a
   UIntMin a -> literal $ uintmin a
   UIntMax a -> literal $ uintmax a
-  IntVar a  -> get (nameFromArg c m a) (catInts args)
-  TEntry a t -> get (nameFromItem m a) (catInts $ timeStore t store)
+  Var _ a   -> get (nameFromArg c m a) (catInts args)
+  TEntry t a -> get (nameFromItem m a) (catInts $ timeStore t store)
   IntEnv a -> get (nameFromEnv c m a) (catInts environment)
   NewAddr _ _ -> error "TODO: handle new addr in SMT expressions"
   ITE x y z -> ite (symExpBool ctx x) (symExpInt ctx y) (symExpInt ctx z)
@@ -353,10 +353,10 @@ symExpInt ctx@(Ctx c m args store environment) e = case e of
 symExpBytes :: Ctx -> Exp ByteString -> SBV String
 symExpBytes ctx@(Ctx c m args store environment) e = case e of
   Cat a b -> symExpBytes ctx a .++ symExpBytes ctx b
-  ByVar a  -> get (nameFromArg c m a) (catBytes args)
+  Var _ a -> get (nameFromArg c m a) (catBytes args)
   ByStr a -> literal a
   ByLit a -> literal $ toString a
-  TEntry a t -> get (nameFromItem m a) (catBytes $ timeStore t store)
+  TEntry t a -> get (nameFromItem m a) (catBytes $ timeStore t store)
   Slice a x y -> subStr (symExpBytes ctx a) (symExpInt ctx x) (symExpInt ctx y)
   ByEnv a -> get (nameFromEnv c m a) (catBytes environment)
   ITE x y z -> ite (symExpBool ctx x) (symExpBytes ctx y) (symExpBytes ctx z)
@@ -368,13 +368,9 @@ timeStore Post s = snd <$> s
 -- *** SMT Variable Names *** --
 
 nameFromItem :: Method -> TStorageItem a -> Id
-nameFromItem method item = case item of
-  IntItem c name ixs -> c @@ method @@ name <> showIxs c ixs
-  BoolItem c name ixs -> c @@ method @@ name <> showIxs c ixs
-  BytesItem c name ixs -> c @@ method @@ name <> showIxs c ixs
+nameFromItem method (Item _ c name ixs) = c @@ method @@ name <> showIxs
   where
-    showIxs :: ContractName -> [TypedExp] -> [Char]
-    showIxs c ixs = intercalate "-" $ "" : fmap (nameFromTypedExp c method) ixs
+    showIxs = intercalate "-" $ "" : fmap (nameFromTypedExp c method) ixs
 
 nameFromTypedExp :: ContractName -> Method -> TypedExp -> Id
 nameFromTypedExp c method e = case e of
@@ -395,7 +391,6 @@ nameFromExp c m e = case e of
   IntMax a  -> show $ intmax a
   UIntMin a -> show $ uintmin a
   UIntMax a -> show $ uintmax a
-  IntVar a -> a
   IntEnv a -> nameFromEnv c m a
   NewAddr _ _ -> error "TODO: handle new addr in SMT expressions"
 
@@ -408,17 +403,16 @@ nameFromExp c m e = case e of
   GEQ a b   -> nameFromExp c m a <> ">=" <> nameFromExp c m b
   Neg a     -> "~" <> nameFromExp c m a
   LitBool a -> show a
-  BoolVar a -> nameFromArg c m a
   Eq a b    -> nameFromExp c m a <> "=="  <> nameFromExp c m b
   NEq a b   -> nameFromExp c m a <> "=/=" <> nameFromExp c m b
   Cat a b -> nameFromExp c m a <> "++" <> nameFromExp c m b
-  ByVar a  -> nameFromArg c m a
   ByStr a -> show a
   ByLit a -> show a
   Slice a x y -> nameFromExp c m a <> "[" <> show x <> ":" <> show y <> "]"
   ByEnv a -> nameFromEnv c m a
 
-  TEntry a _ -> nameFromItem m a
+  Var _ a -> nameFromArg c m a
+  TEntry _ a -> nameFromItem m a
   ITE x y z -> "if-" <> nameFromExp c m x <> "-then-" <> nameFromExp c m y <> "-else-" <> nameFromExp c m z
 
 nameFromDecl :: ContractName -> Method -> Decl -> Id
diff --git a/src/Main.hs b/src/Main.hs
index 5a8e47c5..411417d7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,286 +1,6 @@
-{-# LANGUAGE DeriveGeneric  #-}
-{-# Language DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances  #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# Language TypeOperators #-}
-{-# LANGUAGE OverloadedLists #-}
-
 module Main where
 
-import Data.Aeson hiding (Bool, Number, Success)
-import GHC.Generics
-import System.Exit ( exitFailure )
-import System.IO (hPutStrLn, stderr, stdout)
-import Data.SBV hiding (preprocess, sym, prove)
-import Data.Text (pack, unpack)
-import Data.List
-import Data.Maybe
-import Data.Tree
-import Data.Traversable
-import qualified EVM.Solidity as Solidity
-import qualified Data.Text as Text
-import qualified Data.Text.IO as TIO
-import qualified Data.Map.Strict as Map
-import System.Environment (setEnv)
-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
-
-import qualified Data.ByteString.Lazy.Char8 as B
-
-import Control.Monad
-import Control.Lens.Getter
-
-import ErrM
-import Error
-import Lex (lexer, AlexPosn(..))
-import Options.Generic
-import Parse
-import Syntax
-import Syntax.Annotated
-import Syntax.Untyped
-import Enrich
-import K hiding (normalize, indent)
---import SMT
-import Type hiding (Err)
-import qualified Type
---import Coq hiding (indent)
---import HEVM
-
-import Data.Validation
-
---command line options
-data Command w
-  = Lex             { file       :: w ::: String               <?> "Path to file"}
-
-  | Parse           { file       :: w ::: String               <?> "Path to file"}
-
-  | Type            { file       :: w ::: String               <?> "Path to file"}
-
-  | Prove           { file       :: w ::: String               <?> "Path to file"
-                    , solver     :: w ::: Maybe Text           <?> "SMT solver: z3 (default) or cvc4"
-                    , smttimeout :: w ::: Maybe Integer        <?> "Timeout given to SMT solver in milliseconds (default: 20000)"
-                    , debug      :: w ::: Bool                 <?> "Print verbose SMT output (default: False)"
-                    }
-
-  | Coq             { file       :: w ::: String               <?> "Path to file"}
-
-  | K               { spec       :: w ::: String               <?> "Path to spec"
-                    , soljson    :: w ::: String               <?> "Path to .sol.json"
-                    , gas        :: w ::: Maybe [(Id, String)] <?> "Gas usage per spec"
-                    , storage    :: w ::: Maybe String         <?> "Path to storage definitions"
-                    , extractbin :: w ::: Bool                 <?> "Put EVM bytecode in separate file"
-                    , out        :: w ::: Maybe String         <?> "output directory"
-                    }
-
-  | HEVM            { spec       :: w ::: String               <?> "Path to spec"
-                    , soljson    :: w ::: String               <?> "Path to .sol.json"
-                    , solver     :: w ::: Maybe Text           <?> "SMT solver: z3 (default) or cvc4"
-                    , smttimeout :: w ::: Maybe Integer        <?> "Timeout given to SMT solver in milliseconds (default: 20000)"
-                    , debug      :: w ::: Bool                 <?> "Print verbose SMT output (default: False)"
-                    }
- deriving (Generic)
-
-deriving instance ParseField [(Id, String)]
-instance ParseRecord (Command Wrapped)
-deriving instance Show (Command Unwrapped)
-
-
------------------------
--- *** Dispatch *** ---
------------------------
-
+import qualified CLI
 
 main :: IO ()
-main = do
-    cmd <- unwrapRecord "Act -- Smart contract specifier"
-    case cmd of
-      Lex f -> lex' f
-      Parse f -> parse' f
-      Type f -> type' f
-      --Prove file' solver' smttimeout' debug' -> prove file' solver' smttimeout' debug'
-      --Coq f -> coq' f
-      K spec' soljson' gas' storage' extractbin' out' -> k spec' soljson' gas' storage' extractbin' out'
-      --HEVM spec' soljson' solver' smttimeout' debug' -> hevm spec' soljson' solver' smttimeout' debug'
-
-
----------------------------------
--- *** CLI implementation *** ---
----------------------------------
-
-
-lex' :: FilePath -> IO ()
-lex' f = do
-  contents <- readFile f
-  print $ lexer contents
-
-parse' :: FilePath -> IO ()
-parse' f = do
-  contents <- readFile f
-  validation (prettyErrs contents) print (parse $ lexer contents)
-
-type' :: FilePath -> IO ()
-type' f = do
-  contents <- readFile f
-  validation (prettyErrs contents) (B.putStrLn . encode) (compile contents)
-
--- prove :: FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
--- prove file' solver' smttimeout' debug' = do
---   let
---     parseSolver s = case s of
---       Just "z3" -> SMT.Z3
---       Just "cvc4" -> SMT.CVC4
---       Nothing -> SMT.Z3
---       Just _ -> error "unrecognized solver"
---     config = SMT.SMTConfig (parseSolver solver') (fromMaybe 20000 smttimeout') debug'
---   contents <- readFile file'
---   proceed contents (compile contents) $ \claims -> do
---     let
---       catModels results = [m | Sat m <- results]
---       catErrors results = [e | e@SMT.Error {} <- results]
---       catUnknowns results = [u | u@SMT.Unknown {} <- results]
-
---       (<->) :: Doc -> [Doc] -> Doc
---       x <-> y = x <$$> line <> (indent 2 . vsep $ y)
-
---       failMsg :: [SMT.SMTResult] -> Doc
---       failMsg results
---         | not . null . catUnknowns $ results
---             = text "could not be proven due to a" <+> (yellow . text $ "solver timeout")
---         | not . null . catErrors $ results
---             = (red . text $ "failed") <+> "due to solver errors:" <-> ((fmap (text . show)) . catErrors $ results)
---         | otherwise
---             = (red . text $ "violated") <> colon <-> (fmap pretty . catModels $ results)
-
---       passMsg :: Doc
---       passMsg = (green . text $ "holds") <+> (bold . text $ "∎")
-
---       accumulateResults :: (Bool, Doc) -> (Query, [SMT.SMTResult]) -> (Bool, Doc)
---       accumulateResults (status, report) (query, results) = (status && holds, report <$$> msg <$$> smt)
---         where
---           holds = all isPass results
---           msg = identifier query <+> if holds then passMsg else failMsg results
---           smt = if debug' then line <> getSMT query else empty
-
---     solverInstance <- spawnSolver config
---     pcResults <- mapM (runQuery solverInstance) (concatMap mkPostconditionQueries claims)
---     invResults <- mapM (runQuery solverInstance) (mkInvariantQueries claims)
---     stopSolver solverInstance
-
---     let
---       invTitle = line <> (underline . bold . text $ "Invariants:") <> line
---       invOutput = foldl' accumulateResults (True, empty) invResults
-
---       pcTitle = line <> (underline . bold . text $ "Postconditions:") <> line
---       pcOutput = foldl' accumulateResults (True, empty) pcResults
-
---     render $ vsep
---       [ ifExists invResults invTitle
---       , indent 2 $ snd invOutput
---       , ifExists pcResults pcTitle
---       , indent 2 $ snd pcOutput
---       ]
-
---     unless (fst invOutput && fst pcOutput) exitFailure
-
-
--- coq' :: FilePath -> IO()
--- coq' f = do
---   contents <- readFile f
---   proceed contents (compile contents) $ \claims ->
---     TIO.putStr $ coq claims
-
-k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
-k spec' soljson' gas' storage' extractbin' out' = do
-  specContents <- readFile spec'
-  solContents  <- readFile soljson'
-  let kOpts = KOptions (maybe mempty Map.fromList gas') storage' extractbin'
-      errKSpecs = do
-        refinedSpecs <- toEither $ behaviours <$> compile specContents
-        (sources, _, _) <- validate [(nowhere, "Could not read sol.json")]
-                              (Solidity.readJSON . pack) solContents
-        for refinedSpecs (makekSpec sources kOpts) ^. _Either
-  proceed specContents errKSpecs $ \kSpecs -> do
-    let printFile (filename, content) = case out' of
-          Nothing -> putStrLn (filename <> ".k") >> putStrLn content
-          Just dir -> writeFile (dir <> "/" <> filename <> ".k") content
-    forM_ kSpecs printFile
-
--- hevm :: FilePath -> FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
--- hevm spec' soljson' solver' smttimeout' smtdebug' = do
---   specContents <- readFile spec'
---   solContents  <- readFile soljson'
---   let preprocess = do refinedSpecs  <- compile specContents
---                       (sources, _, _) <- errMessage (nowhere, "Could not read sol.json")
---                         $ Solidity.readJSON $ pack solContents
---                       return ([b | B b <- refinedSpecs], sources)
---   proceed specContents preprocess $ \(specs, sources) -> do
---     -- TODO: prove constructor too
---     passes <- forM specs $ \behv -> do
---       res <- runSMTWithTimeOut solver' smttimeout' smtdebug' $ proveBehaviour sources behv
---       case res of
---         Left posts -> do
---            putStrLn $ "Successfully proved " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
---              <> ", " <> show (length $ last $ levels posts) <> " cases."
---            return True
---         Right _ -> do
---            putStrLn $ "Failed to prove " <> (_name behv) <> "(" <> show (_mode behv) <> ")"
---            return False
---     unless (and passes) exitFailure
-
-
--------------------
--- *** Util *** ---
--------------------
-
-
--- cvc4 sets timeout via a commandline option instead of smtlib `(set-option)`
-runSMTWithTimeOut :: Maybe Text -> Maybe Integer -> Bool -> Symbolic a -> IO a
-runSMTWithTimeOut solver' maybeTimeout debug' sym
-  | solver' == Just "cvc4" = do
-      setEnv "SBV_CVC4_OPTIONS" ("--lang=smt --incremental --interactive --no-interactive-prompt --model-witness-value --tlimit-per=" <> show timeout)
-      res <- runSMTWith cvc4{verbose=debug'} sym
-      setEnv "SBV_CVC4_OPTIONS" ""
-      return res
-  | solver' == Just "z3" = runwithz3
-  | isNothing solver' = runwithz3
-  | otherwise = error "Unknown solver. Currently supported solvers; z3, cvc4"
- where timeout = fromMaybe 20000 maybeTimeout
-       runwithz3 = runSMTWith z3{verbose=debug'} $ (setTimeOut timeout) >> sym
-
--- | Fail on error, or proceed with continuation
-proceed :: Validate err => String -> err (NonEmpty (Pn, String)) a -> (a -> IO ()) -> IO ()
-proceed contents comp continue = validation (prettyErrs contents) continue (comp ^. revalidate)
-
-compile :: String -> Error String [Claim]
-compile = pure . fmap annotate . enrich <==< typecheck <==< parse . lexer
-
-prettyErrs :: Traversable t => String -> t (Pn, String) -> IO ()
-prettyErrs contents errs = mapM_ prettyErr errs >> exitFailure
-  where
-  prettyErr (pn, msg) | pn == nowhere = do
-    hPutStrLn stderr "Internal error:"
-    hPutStrLn stderr msg
-  prettyErr (pn, msg) | pn == lastPos = do
-    let culprit = last $ lines contents
-        line' = length (lines contents) - 1
-        col  = length culprit
-    hPutStrLn stderr $ show line' <> " | " <> culprit
-    hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
-    hPutStrLn stderr msg
-  prettyErr (AlexPn _ line' col, msg) = do
-    let cxt = safeDrop (line' - 1) (lines contents)
-    hPutStrLn stderr $ msg <> ":"
-    hPutStrLn stderr $ show line' <> " | " <> head cxt
-    hPutStrLn stderr $ unpack (Text.replicate (col + length (show line' <> " | ") - 1) " " <> "^")
-    where
-      safeDrop :: Int -> [a] -> [a]
-      safeDrop 0 a = a
-      safeDrop _ [] = []
-      safeDrop _ [a] = [a]
-      safeDrop n (_:xs) = safeDrop (n-1) xs
-
--- | prints a Doc, with wider output than the built in `putDoc`
-render :: Doc -> IO ()
-render doc = displayIO stdout (renderPretty 0.9 120 doc)
+main = CLI.main
diff --git a/src/SMT.hs b/src/SMT.hs
index 710e803d..5b87421a 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -524,8 +524,8 @@ encodeInitialStorage behvName update = case update of
     encode :: TStorageItem a -> Exp a -> SMT2
     encode item e =
       let
-        postentry  = withInterface behvName $ expToSMT2 (TEntry item Post)
-        expression = withInterface behvName $ expToSMT2 (e)
+        postentry  = withInterface behvName $ expToSMT2 (TEntry Post item)
+        expression = withInterface behvName $ expToSMT2 e
       in "(assert (= " <> postentry <> " " <> expression <> "))"
 
 -- | declares a storage location that is created by the constructor, these
@@ -588,7 +588,6 @@ expToSMT2 expr = case expr of
   GEQ a b -> binop ">=" a b
   GE a b -> binop ">" a b
   LitBool a -> pure $ if a then "true" else "false"
-  BoolVar a -> nameFromVarId a
 
   -- integers
   Add a b -> binop "+" a b
@@ -600,7 +599,6 @@ expToSMT2 expr = case expr of
   LitInt a -> pure $ if a >= 0
                       then show a
                       else "(- " <> (show . negate $ a) <> ")" -- cvc4 does not accept negative integer literals
-  IntVar a -> nameFromVarId a
   IntEnv a -> pure $ prettyEnv a
 
   -- bounds
@@ -612,7 +610,6 @@ expToSMT2 expr = case expr of
   -- bytestrings
   Cat a b -> binop "str.++" a b
   Slice a start end -> triop "str.substr" a start (Sub end start)
-  ByVar a -> nameFromVarId a
   ByStr a -> pure a
   ByLit a -> pure $ show a
   ByEnv a -> pure $ prettyEnv a
@@ -624,7 +621,8 @@ expToSMT2 expr = case expr of
   Eq a b -> binop "=" a b
   NEq a b -> unop "not" (Eq a b)
   ITE a b c -> triop "ite" a b c
-  TEntry item w -> entry item w
+  Var _ a -> nameFromVarId a
+  TEntry w item -> entry item w
   where
     unop :: String -> Exp a -> Ctx SMT2
     unop op a = ["(" <> op <> " " <> a' <> ")" | a' <- expToSMT2 a]
@@ -689,10 +687,7 @@ sType' (ExpBytes {}) = "String"
 
 -- Construct the smt2 variable name for a given storage item
 nameFromItem :: When -> TStorageItem a -> Id
-nameFromItem whn item = case item of
-  IntItem c name _ -> c @@ name @@ show whn
-  BoolItem c name _ -> c @@ name @@ show whn
-  BytesItem c name _ -> c @@ name @@ show whn
+nameFromItem whn (Item _ c name _) = c @@ name @@ show whn
 
 -- Construct the smt2 variable name for a given storage location
 nameFromLoc :: When -> StorageLocation -> Id
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 9253b583..a0519f47 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE GADTs #-}
-
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
 
 {-|
 Module      : Syntax
@@ -10,8 +10,7 @@ module Syntax where
 
 import Data.List
 import Data.Map (Map,empty,insertWith,unionsWith)
-
-import Error
+import Data.Singletons
 
 import Syntax.TimeAgnostic as Agnostic
 import qualified Syntax.Annotated as Annotated
@@ -44,17 +43,17 @@ locsFromConstructor (Constructor _ _ _ pre post initialStorage rewrites) = nub $
 -- * Extract from any typed AST * --
 ------------------------------------
 
-constructors :: [Claim t] -> [Constructor t]
-constructors claims = [c | C c <- claims]
+ctorsFromClaims :: [Claim t] -> [Constructor t]
+ctorsFromClaims claims = [c | C c <- claims]
 
-behaviours :: [Claim t] -> [Behaviour t]
-behaviours claims = [b | B b <- claims]
+behvsFromClaims :: [Claim t] -> [Behaviour t]
+behvsFromClaims claims = [b | B b <- claims]
 
-invariants :: [Claim t] -> [Invariant t]
-invariants claims = [i | I i <- claims]
+invsFromClaims :: [Claim t] -> [Invariant t]
+invsFromClaims claims = [i | I i <- claims]
 
-stores :: [Claim t] -> [Store]
-stores claims = [s | S s <- claims]
+storesFromClaims :: [Claim t] -> [Store]
+storesFromClaims claims = [s | S s <- claims]
 
 locsFromRewrite :: Rewrite t -> [StorageLocation t]
 locsFromRewrite update = nub $ case update of
@@ -253,10 +252,8 @@ ixsFromUpdate (BytesUpdate item _) = ixsFromItem item
 ixsFromRewrite :: Rewrite t -> [TypedExp t]
 ixsFromRewrite = onRewrite ixsFromLocation ixsFromUpdate
 
---itemType :: TStorageItem a t -> MType
---itemType IntItem{}   = Integer
---itemType BoolItem{}  = Boolean
---itemType BytesItem{} = ByteStr
+itemType :: forall a t. SingI a => TStorageItem a t -> MType
+itemType _ = withSing @a fromSing
 
 isMapping :: StorageLocation t -> Bool
 isMapping = not . null . ixsFromLocation
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 8f7b1de1..2fa0d32c 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -10,7 +10,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
-
+{-# LANGUAGE TypeOperators #-}
 
 {-# LANGUAGE RankNTypes, StandaloneKindSignatures, PatternSynonyms, ViewPatterns #-}
 
@@ -44,66 +44,14 @@ import Data.Typeable
 import Data.Vector (fromList)
 
 import EVM.Solidity (SlotType(..))
-import EVM.ABI (AbiType(..))
 
 -- Reexports
+import Syntax.Types   as Syntax.TimeAgnostic
 import Syntax.Timing  as Syntax.TimeAgnostic
 import Syntax.Untyped as Syntax.TimeAgnostic (Id, Interface(..), EthEnv(..), Decl(..))
 
 import Data.Singletons
 
---types understood by proving tools
-data MType
-  = Integer
-  | Boolean
-  | ByteStr
-  deriving (Eq, Ord, Show, Read)
-
-metaType :: AbiType -> MType
-metaType (AbiUIntType _)     = Integer
-metaType (AbiIntType  _)     = Integer
-metaType AbiAddressType      = Integer
-metaType AbiBoolType         = Boolean
-metaType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
-metaType AbiBytesDynamicType = ByteStr
-metaType AbiStringType       = ByteStr
---metaType (AbiArrayDynamicType a) =
---metaType (AbiArrayType        Int AbiType
---metaType (AbiTupleType        (Vector AbiType)
-metaType _ = error "Extract.metaType: TODO"
-
-pattern FromAbi t <- (metaType -> FromSing (STypeable t))
-pattern FromMeta t <- FromSing (STypeable t)
-
-data SType a where
-  SInteger :: SType Integer
-  SBoolean :: SType Bool
-  SByteStr :: SType ByteString
-deriving instance Show (SType a)
-deriving instance Eq (SType a)
-
-data STypeable a where
-  STypeable :: Typeable a => SType a -> STypeable a
-deriving instance Show (STypeable a)
-deriving instance Eq (STypeable a)
-
-type instance Sing = STypeable
-
-instance SingI Integer    where sing = STypeable SInteger
-instance SingI Bool       where sing = STypeable SBoolean
-instance SingI ByteString where sing = STypeable SByteStr
-
-instance SingKind * where
-  type Demote * = MType
-
-  fromSing (STypeable SInteger) = Integer
-  fromSing (STypeable SBoolean) = Boolean
-  fromSing (STypeable SByteStr) = ByteStr
-
-  toSing Integer = SomeSing (STypeable SInteger)
-  toSing Boolean = SomeSing (STypeable SBoolean)
-  toSing ByteStr = SomeSing (STypeable SByteStr)
-
 -- AST post typechecking
 data Claim t
   = C (Constructor t)
@@ -581,13 +529,13 @@ uintmax a = 2 ^ a - 1
 mkVar :: SingI a => Id -> Exp a t
 mkVar name = let STypeable t = sing in Var t name
 
--- castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
--- castTime = gcast
+castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
+castTime = gcast
 
--- castType :: (Typeable a, Typeable x) => Exp x t -> Maybe (Exp a t)
--- castType = gcast0
+castType :: (Typeable a, Typeable x) => Exp x t -> Maybe (Exp a t)
+castType = gcast0
 
--- -- | Analogous to `gcast1` and `gcast2` from `Data.Typeable`. We *could* technically use `cast` instead
--- -- but then we would catch too many errors at once, so we couldn't emit informative error messages.
--- gcast0 :: forall t t' a. (Typeable t, Typeable t') => t a -> Maybe (t' a)
--- gcast0 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))
+-- | Analogous to `gcast1` and `gcast2` from `Data.Typeable`. We *could* technically use `cast` instead
+-- but then we would catch too many errors at once, so we couldn't emit informative error messages.
+gcast0 :: forall t t' a. (Typeable t, Typeable t') => t a -> Maybe (t' a)
+gcast0 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
new file mode 100644
index 00000000..0b3cfef9
--- /dev/null
+++ b/src/Syntax/Types.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternSynonyms, StandaloneDeriving, TypeFamilies, FlexibleInstances #-}
+
+module Syntax.Types where
+
+import Data.Singletons
+import Data.Typeable
+
+import Data.ByteString as Syntax.Types (ByteString)
+import EVM.ABI as Syntax.Types (AbiType(..))
+
+--types understood by proving tools
+data MType
+  = Integer
+  | Boolean
+  | ByteStr
+  deriving (Eq, Ord, Show, Read)
+
+metaType :: AbiType -> MType
+metaType (AbiUIntType _)     = Integer
+metaType (AbiIntType  _)     = Integer
+metaType AbiAddressType      = Integer
+metaType AbiBoolType         = Boolean
+metaType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
+metaType AbiBytesDynamicType = ByteStr
+metaType AbiStringType       = ByteStr
+--metaType (AbiArrayDynamicType a) =
+--metaType (AbiArrayType        Int AbiType
+--metaType (AbiTupleType        (Vector AbiType)
+metaType _ = error "Syntax.Types.metaType: TODO"
+
+pattern FromAbi :: () => Typeable a => SType a -> AbiType
+pattern FromAbi t <- (metaType -> FromSing (STypeable t))
+{-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
+
+pattern FromMeta :: () => Typeable a => SType a -> MType
+pattern FromMeta t <- FromSing (STypeable t)
+{-# COMPLETE FromMeta #-} -- We promise that the pattern covers all cases of MType.
+
+data SType a where
+  SInteger :: SType Integer
+  SBoolean :: SType Bool
+  SByteStr :: SType ByteString
+deriving instance Show (SType a)
+deriving instance Eq (SType a)
+
+data STypeable a where
+  STypeable :: Typeable a => SType a -> STypeable a
+deriving instance Show (STypeable a)
+deriving instance Eq (STypeable a)
+
+type instance Sing = STypeable
+
+instance SingI Integer    where sing = STypeable SInteger
+instance SingI Bool       where sing = STypeable SBoolean
+instance SingI ByteString where sing = STypeable SByteStr
+
+instance SingKind * where
+  type Demote * = MType
+
+  fromSing (STypeable SInteger) = Integer
+  fromSing (STypeable SBoolean) = Boolean
+  fromSing (STypeable SByteStr) = ByteStr
+
+  toSing Integer = SomeSing (STypeable SInteger)
+  toSing Boolean = SomeSing (STypeable SBoolean)
+  toSing ByteStr = SomeSing (STypeable SByteStr)
diff --git a/src/Type.hs b/src/Type.hs
index 5576264d..5924f057 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -9,7 +9,6 @@
 
 module Type (typecheck, bound, lookupVars, defaultStore, metaType, Err) where
 
-import Data.List
 import EVM.ABI
 import EVM.Solidity (SlotType(..))
 import Data.Map.Strict    (Map,keys,findWithDefault)
@@ -22,19 +21,13 @@ import Type.Reflection (typeRep)
 
 import Data.ByteString (ByteString)
 
-import Control.Applicative
 import Control.Lens.Operators ((??))
-import Control.Monad (join,unless)
 import Control.Monad.Writer
 import Data.List.Extra (snoc,unsnoc)
 import Data.Function (on)
-import Data.Functor
 import Data.Functor.Alt
 import Data.Foldable
 import Data.Traversable
-import Data.Tuple.Extra (uncurry3)
-
-import Data.Singletons
 
 import Syntax
 import Syntax.Timing
@@ -78,7 +71,7 @@ fromAssign (U.AssignStruct _ _) = error "TODO: assignstruct"
 
 -- | filters out duplicate entries in list
 duplicatesBy :: (a -> a -> Bool) -> [a] -> [a]
-duplicatesBy f [] = []
+duplicatesBy _ [] = []
 duplicatesBy f (x:xs) =
   let e = [x | any (f x) xs]
   in e <> duplicatesBy f xs
@@ -122,7 +115,7 @@ mkEnv contract store decls = Env
 
 -- checks a transition given a typing of its storage variables
 splitBehaviour :: Store -> U.RawBehaviour -> Err [Claim]
-splitBehaviour store (U.Transition pn name contract iface@(Interface _ decls) iffs cases posts) =
+splitBehaviour store (U.Transition _ name contract iface@(Interface _ decls) iffs cases posts) =
   noIllegalWilds *>
   -- constrain integer calldata variables (TODO: other types)
   fmap concatMap (caseClaims
@@ -145,20 +138,20 @@ splitBehaviour store (U.Transition pn name contract iface@(Interface _ decls) if
       U.Direct   post -> [U.Case nowhere (U.WildExp nowhere) post]
       U.Branches bs ->
         let
-          Just (rest, last@(U.Case pn _ post)) = unsnoc bs
+          Just (rest, lastCase@(U.Case pn _ post)) = unsnoc bs
           negation = U.ENot nowhere $
                         foldl (\acc (U.Case _ e _) -> U.EOr nowhere e acc) (U.BoolLit nowhere False) rest
-        in rest `snoc` (if isWild last then U.Case pn negation post else last)
+        in rest `snoc` (if isWild lastCase then U.Case pn negation post else lastCase)
 
     -- | split case into pass and fail case
     caseClaims :: [Exp Bool Untimed] -> [Exp Bool Timed] -> ([Exp Bool Untimed], [Rewrite], Maybe (TypedExp Timed)) -> [Claim]
     caseClaims []   postcs (if',storage,ret) =
       [ B $ Behaviour name Pass contract iface if' postcs storage ret ]
-    caseClaims iffs postcs (if',storage,ret) =
-      [ B $ Behaviour name Pass contract iface (if' <> iffs) postcs storage ret,
-        B $ Behaviour name Fail contract iface (if' <> [Neg (mconcat iffs)]) [] (Constant . locFromRewrite <$> storage) Nothing ]
+    caseClaims iffs' postcs (if',storage,ret) =
+      [ B $ Behaviour name Pass contract iface (if' <> iffs') postcs storage ret,
+        B $ Behaviour name Fail contract iface (if' <> [Neg (mconcat iffs')]) [] (Constant . locFromRewrite <$> storage) Nothing ]
 
-splitBehaviour store (U.Definition pn contract iface@(Interface _ decls) iffs (U.Creates assigns) extStorage postcs invs) =
+splitBehaviour store (U.Definition _ contract iface@(Interface _ decls) iffs (U.Creates assigns) extStorage postcs invs) =
   if not . null $ extStorage then error "TODO: support extStorage in constructor"
   else let env = mkEnv contract store decls
   in do
@@ -178,8 +171,8 @@ splitBehaviour store (U.Definition pn contract iface@(Interface _ decls) iffs (U
 checkCase :: Env -> U.Case -> Err ([Exp Bool Untimed], [Rewrite], Maybe (TypedExp Timed))
 checkCase env c@(U.Case _ pre post) = do
   if' <- traverse (inferExpr env) $ if isWild c then [] else [pre]
-  (storage,return) <- checkPost env post
-  pure (if',storage,return)
+  (storage,return') <- checkPost env post
+  pure (if',storage,return')
 
 -- | Ensures that none of the storage variables are read in the supplied `Expr`.
 noStorageRead :: Map Id SlotType -> U.Expr -> Err ()
@@ -188,7 +181,7 @@ noStorageRead store expr = for_ (keys store) $ \name ->
     throw (pn,"Cannot read storage in creates block")
 
 makeUpdate :: Env -> SType a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
-makeUpdate env@Env{contract} typ name ixs newVal = let item = Item typ contract name ixs in
+makeUpdate Env{contract} typ name ixs newVal = let item = Item typ contract name ixs in
   case typ of
     SInteger -> IntUpdate   item newVal
     SBoolean -> BoolUpdate  item newVal--(BoolItem  contract name ixs) newVal
@@ -196,14 +189,14 @@ makeUpdate env@Env{contract} typ name ixs newVal = let item = Item typ contract
 
 -- ensures that key types match value types in an U.Assign
 checkAssign :: Env -> U.Assign -> Err [StorageUpdate]
-checkAssign env@Env{contract, store} (U.AssignVal (U.StorageVar pn (StorageValue (FromAbi typ)) name) expr)
+checkAssign env@Env{store} (U.AssignVal (U.StorageVar _ (StorageValue (FromAbi typ)) name) expr)
   = sequenceA [makeUpdate env typ name [] <$> inferExpr env expr]
     <* noStorageRead store expr
-checkAssign env@Env{store} (U.AssignMany (U.StorageVar pn (StorageMapping (keyType :| _) valType) name) defns)
+checkAssign env@Env{store} (U.AssignMany (U.StorageVar _ (StorageMapping (keyType :| _) valType) name) defns)
   = for defns $ \def@(U.Defn e1 e2) -> checkDefn env keyType valType name def
                                        <* noStorageRead store e1
                                        <* noStorageRead store e2
-checkAssign _ (U.AssignVal (U.StorageVar pn (StorageMapping _ _) _) expr)
+checkAssign _ (U.AssignVal (U.StorageVar _ (StorageMapping _ _) _) expr)
   = throw (getPosn expr, "Cannot assign a single expression to a composite type")
 checkAssign _ (U.AssignMany (U.StorageVar pn (StorageValue _) _) _)
   = throw (pn, "Cannot assign multiple values to an atomic type")
@@ -212,7 +205,7 @@ checkAssign _ _ = error "todo: support struct assignment in constructors"
 -- ensures key and value types match when assigning a defn to a mapping
 -- TODO: handle nested mappings
 checkDefn :: Env -> AbiType -> AbiType -> Id -> U.Defn -> Err StorageUpdate
-checkDefn env@Env{contract} keyType (FromAbi valType) name (U.Defn k val) =
+checkDefn env keyType (FromAbi valType) name (U.Defn k val) =
   makeUpdate env valType name <$> checkIxs env (getPosn k) [k] [keyType] <*> inferExpr env val
 
 checkPost :: Env -> U.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
@@ -266,7 +259,7 @@ checkPost env@Env{contract,calldata} (U.Post storage extStorage maybeReturn) = d
 
 checkStorageExpr :: Env -> U.Pattern -> U.Expr -> Err StorageUpdate
 checkStorageExpr _ (U.PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
-checkStorageExpr env@Env{contract,store} (U.PEntry p name args) expr = case Map.lookup name store of
+checkStorageExpr env@Env{store} (U.PEntry p name args) expr = case Map.lookup name store of
   Just (StorageValue (FromAbi typ)) ->
     makeUpdate env typ name [] <$> inferExpr env expr
   Just (StorageMapping argtyps (FromAbi valType)) ->
diff --git a/src/act.cabal b/src/act.cabal
index 58109d86..4b80852c 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -32,7 +32,7 @@ common deps
                  extra,
                  singletons,
                  reflection       >= 2.1.6
-  other-modules: Lex ErrM Error Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
+  other-modules: CLI Lex Error Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Types Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
   
   if flag(ci)
       ghc-options: -O2 -Wall -Werror -Wno-orphans -Wno-unticked-promoted-constructors
diff --git a/src/test/Test.hs b/src/test/Test.hs
index 4e219ed2..98174eff 100644
--- a/src/test/Test.hs
+++ b/src/test/Test.hs
@@ -6,7 +6,7 @@ module Main where
 
 import EVM.ABI (AbiType(..))
 import Test.Tasty
-import Test.Tasty.QuickCheck (Gen, arbitrary, testProperty, Property)
+import Test.Tasty.QuickCheck (Gen, arbitrary, testProperty, Property, (===), property)
 import Test.QuickCheck.Instances.ByteString()
 import Test.QuickCheck.GenT
 import Test.QuickCheck.Monadic
@@ -20,10 +20,8 @@ import Data.Maybe (isNothing)
 import qualified Data.Set as Set
 import qualified Data.Map as Map (empty)
 
-import ErrM
-import Lex (lexer)
-import Parse (parse)
-import Type (typecheck)
+import CLI (compile)
+import Error
 import Print (prettyBehaviour)
 import SMT
 import Syntax.Annotated hiding (Mode)
@@ -56,15 +54,15 @@ main = defaultMain $ testGroup "act"
       -}
       [ testProperty "roundtrip" . withExponents $ do
           behv@(Behaviour name _ contract iface preconds _ _ _) <- sized genBehv
-          let actual = pure . fmap annotate <=< typecheck <=< parse . lexer $ prettyBehaviour behv
+          let actual = compile False $ prettyBehaviour behv
               expected = if null preconds then
                   [ S Map.empty, B behv ]
                 else
                   [ S Map.empty, B behv
                   , B $ Behaviour name Fail contract iface [Neg $ mconcat preconds] [] [] Nothing ]
           return $ case actual of
-            Ok a -> a == expected
-            Bad _ -> False
+            Success a -> a === expected
+            Failure _ -> property False
       ]
 
   , testGroup "smt"
@@ -158,12 +156,12 @@ genTypedExp names n = oneof
 
 -- TODO: literals, cat slice, ITE, storage, ByStr
 genExpBytes :: Names -> Int -> ExpoGen (Exp ByteString)
-genExpBytes names _ = ByVar <$> selectName ByteStr names
+genExpBytes names _ = Var SByteStr <$> selectName ByteStr names
 
 -- TODO: ITE, storage
 genExpBool :: Names -> Int -> ExpoGen (Exp Bool)
 genExpBool names 0 = oneof
-  [ BoolVar <$> selectName Boolean names
+  [ Var SBoolean <$> selectName Boolean names
   , LitBool <$> liftGen arbitrary
   ]
 genExpBool names n = oneof
@@ -189,7 +187,7 @@ genExpBool names n = oneof
 genExpInt :: Names -> Int -> ExpoGen (Exp Integer)
 genExpInt names 0 = oneof
   [ LitInt <$> liftGen arbitrary
-  , IntVar <$> selectName Integer names
+  , Var SInteger <$> selectName Integer names
   , return $ IntEnv Caller
   , return $ IntEnv Callvalue
   , return $ IntEnv Calldepth

From 04031e98e0e097e646e1653eb084d865166c81cb Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 27 Sep 2021 23:18:24 +0200
Subject: [PATCH 14/36] restructure cabal file to avoid repeated builds

---
 src/act.cabal | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/src/act.cabal b/src/act.cabal
index 4b80852c..f34ca222 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -32,27 +32,35 @@ common deps
                  extra,
                  singletons,
                  reflection       >= 2.1.6
-  other-modules: CLI Lex Error Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Types Syntax.Annotated Syntax.Timing Syntax.TimeAgnostic Type Print Enrich SMT
   
   if flag(ci)
       ghc-options: -O2 -Wall -Werror -Wno-orphans -Wno-unticked-promoted-constructors
   else
       ghc-options: -Wall -Wno-orphans -Wno-unticked-promoted-constructors
 
+library act-internal
+  import:             deps
+  build-tool-depends: happy:happy, alex:alex
+  hs-source-dirs:     .
+  default-language:   Haskell2010
+  exposed-modules:    CLI Error Print SMT Syntax.Annotated
+  other-modules:      Lex Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Types Syntax.Timing Syntax.TimeAgnostic Type Enrich
+
 executable act
   import:             deps
   main-is:            Main.hs
-  build-tool-depends: happy:happy, alex:alex
   hs-source-dirs:     .
   default-language:   Haskell2010
+  build-depends:      act-internal
 
 Test-Suite test
   import:           deps
   type:             exitcode-stdio-1.0
   default-language: Haskell2010
   main-is:          Test.hs
-  hs-source-dirs:   test, .
-  build-depends:    pretty-simple          >= 2.2,
+  hs-source-dirs:   test
+  build-depends:    act-internal,
+                    pretty-simple          >= 2.2,
                     quickcheck-instances   >= 0.3,
                     quickcheck-transformer >= 0.3,
                     tasty-hunit            >= 0.10,

From 0294e84c568e995388276d7248d988694d256507 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 27 Sep 2021 23:31:23 +0200
Subject: [PATCH 15/36] cleanup

---
 src/CLI.hs                 |  3 +-
 src/Error.hs               | 18 ++++++++----
 src/K.hs                   |  3 +-
 src/Syntax.hs              |  3 +-
 src/Syntax/Annotated.hs    |  1 -
 src/Syntax/TimeAgnostic.hs |  2 --
 src/Syntax/Types.hs        | 56 +++++++++++++++++++++++---------------
 src/Type.hs                |  2 +-
 8 files changed, 54 insertions(+), 34 deletions(-)

diff --git a/src/CLI.hs b/src/CLI.hs
index 8fe2c34f..1e6673c5 100644
--- a/src/CLI.hs
+++ b/src/CLI.hs
@@ -6,7 +6,8 @@
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# Language TypeOperators #-}
-{-# LANGUAGE OverloadedLists, ApplicativeDo #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo #-}
 
 module CLI (main, compile) where
 
diff --git a/src/Error.hs b/src/Error.hs
index e55984cb..1a4e7bb3 100644
--- a/src/Error.hs
+++ b/src/Error.hs
@@ -1,4 +1,11 @@
-{-# LANGUAGE OverloadedLists,TypeOperators, LambdaCase, AllowAmbiguousTypes, TypeApplications, TypeFamilies, DeriveFunctor, ConstraintKinds, UndecidableInstances, FlexibleContexts, FlexibleInstances, RankNTypes, KindSignatures, ApplicativeDo, MultiParamTypeClasses, ScopedTypeVariables, InstanceSigs #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Error (module Error) where
 
@@ -20,13 +27,14 @@ throw msg = Failure [msg]
 
 infixr 1 <==<, >==>
 
--- These allow us to chain error-prone computations without a @Monad@ instance.
-(<==<) :: (b -> Error e c) -> (a -> Error e b) -> a -> Error e c
-(<==<) = flip (>==>)
-
+-- Like @Control.Monad.'(>=>)'@ but allows us to chain error-prone
+-- computations even without a @Monad@ instance.
 (>==>) :: (a -> Error e b) -> (b -> Error e c) -> a -> Error e c
 f >==> g = \x -> f x `bindValidation` g
 
+(<==<) :: (b -> Error e c) -> (a -> Error e b) -> a -> Error e c
+(<==<) = flip (>==>)
+
 -- | If there is no error at the supplied position, we accept this result and
 -- do not attempt to run any later branches, even if there were other errors.
 -- (The second argument looks intimidating but it simply demands that each
diff --git a/src/K.hs b/src/K.hs
index 37941ae2..23ef6f6f 100644
--- a/src/K.hs
+++ b/src/K.hs
@@ -3,7 +3,8 @@
 {-# Language OverloadedStrings #-}
 {-# Language ScopedTypeVariables #-}
 {-# Language TypeApplications #-}
-{-# LANGUAGE ApplicativeDo, OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module K where
 
diff --git a/src/Syntax.hs b/src/Syntax.hs
index a0519f47..7d68dfc7 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {-|
 Module      : Syntax
diff --git a/src/Syntax/Annotated.hs b/src/Syntax/Annotated.hs
index 1bde7caf..877db535 100644
--- a/src/Syntax/Annotated.hs
+++ b/src/Syntax/Annotated.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE RecordWildCards #-}
 
 {-|
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 2fa0d32c..8465b3b4 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -12,8 +12,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 
-{-# LANGUAGE RankNTypes, StandaloneKindSignatures, PatternSynonyms, ViewPatterns #-}
-
 {-|
 Module      : Syntax.TimeAgnostic
 Description : AST data types where implicit timings may or may not have been made explicit.
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index 0b3cfef9..c323911c 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternSynonyms, StandaloneDeriving, TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Syntax.Types where
 
@@ -10,13 +13,28 @@ import Data.Typeable
 import Data.ByteString as Syntax.Types (ByteString)
 import EVM.ABI as Syntax.Types (AbiType(..))
 
---types understood by proving tools
+-- | Types understood by proving tools.
 data MType
   = Integer
   | Boolean
   | ByteStr
   deriving (Eq, Ord, Show, Read)
 
+-- | Singleton types of the types understood by proving tools.
+data SType a where
+  SInteger :: SType Integer
+  SBoolean :: SType Bool
+  SByteStr :: SType ByteString
+deriving instance Show (SType a)
+deriving instance Eq (SType a)
+
+-- | Unfortunate extra layer which allows us to guarantee that our singletons
+-- represent 'Data.Typeable' types.
+data STypeable a where
+  STypeable :: Typeable a => SType a -> STypeable a
+deriving instance Show (STypeable a)
+deriving instance Eq (STypeable a)
+
 metaType :: AbiType -> MType
 metaType (AbiUIntType _)     = Integer
 metaType (AbiIntType  _)     = Integer
@@ -30,28 +48,12 @@ metaType AbiStringType       = ByteStr
 --metaType (AbiTupleType        (Vector AbiType)
 metaType _ = error "Syntax.Types.metaType: TODO"
 
-pattern FromAbi :: () => Typeable a => SType a -> AbiType
-pattern FromAbi t <- (metaType -> FromSing (STypeable t))
-{-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
-
-pattern FromMeta :: () => Typeable a => SType a -> MType
-pattern FromMeta t <- FromSing (STypeable t)
-{-# COMPLETE FromMeta #-} -- We promise that the pattern covers all cases of MType.
-
-data SType a where
-  SInteger :: SType Integer
-  SBoolean :: SType Bool
-  SByteStr :: SType ByteString
-deriving instance Show (SType a)
-deriving instance Eq (SType a)
-
-data STypeable a where
-  STypeable :: Typeable a => SType a -> STypeable a
-deriving instance Show (STypeable a)
-deriving instance Eq (STypeable a)
-
+-- | For our purposes, the singleton of a type 'a' is always an 'STypeable a',
+-- i.e. an @'Data.Typeable' a => 'SType' a@.
 type instance Sing = STypeable
 
+-- Defines which singleton to retreive when we only have the type, not the
+-- actual singleton.
 instance SingI Integer    where sing = STypeable SInteger
 instance SingI Bool       where sing = STypeable SBoolean
 instance SingI ByteString where sing = STypeable SByteStr
@@ -66,3 +68,13 @@ instance SingKind * where
   toSing Integer = SomeSing (STypeable SInteger)
   toSing Boolean = SomeSing (STypeable SBoolean)
   toSing ByteStr = SomeSing (STypeable SByteStr)
+
+-- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType'.
+pattern FromAbi :: () => Typeable a => SType a -> AbiType
+pattern FromAbi t <- (metaType -> FromSing (STypeable t))
+{-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
+
+-- | Pattern match on an 'MType' is if it were an 'SType'.
+pattern FromMeta :: () => Typeable a => SType a -> MType
+pattern FromMeta t <- FromSing (STypeable t)
+{-# COMPLETE FromMeta #-} -- We promise that the pattern covers all cases of MType.
diff --git a/src/Type.hs b/src/Type.hs
index 5924f057..ee10a49d 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -5,7 +5,7 @@
 {-# Language ScopedTypeVariables #-}
 {-# Language NamedFieldPuns #-}
 {-# Language DataKinds #-}
-{-# LANGUAGE ApplicativeDo, OverloadedLists, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE ApplicativeDo #-}
 
 module Type (typecheck, bound, lookupVars, defaultStore, metaType, Err) where
 

From e113d41336c846cfbfa4f2413b2aa327959275a5 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Tue, 28 Sep 2021 00:28:10 +0200
Subject: [PATCH 16/36] fix build errors

---
 src/act.cabal          | 4 ++--
 src/{ => main}/Main.hs | 0
 2 files changed, 2 insertions(+), 2 deletions(-)
 rename src/{ => main}/Main.hs (100%)

diff --git a/src/act.cabal b/src/act.cabal
index f34ca222..f30f8a74 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -32,7 +32,7 @@ common deps
                  extra,
                  singletons,
                  reflection       >= 2.1.6
-  
+--  other-modules: CLI Error Print SMT Syntax.Annotated Lex Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Types Syntax.Timing Syntax.TimeAgnostic Type Enrich
   if flag(ci)
       ghc-options: -O2 -Wall -Werror -Wno-orphans -Wno-unticked-promoted-constructors
   else
@@ -49,7 +49,7 @@ library act-internal
 executable act
   import:             deps
   main-is:            Main.hs
-  hs-source-dirs:     .
+  hs-source-dirs:     main
   default-language:   Haskell2010
   build-depends:      act-internal
 
diff --git a/src/Main.hs b/src/main/Main.hs
similarity index 100%
rename from src/Main.hs
rename to src/main/Main.hs

From ebeaea32b8909cf98de227f9415a722e4992359f Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Wed, 29 Sep 2021 21:21:45 +0200
Subject: [PATCH 17/36] cleanup

---
 src/Syntax/TimeAgnostic.hs | 9 +++------
 1 file changed, 3 insertions(+), 6 deletions(-)

diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 8465b3b4..6adbaf63 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -148,10 +148,7 @@ data StorageLocation t
 -- refer to the pre-/post-state, or not. `a` is the type of the item that is
 -- referenced.
 data TStorageItem (a :: *) (t :: Timing) where
-  Item :: SType a -> Id -> Id -> [TypedExp t] -> TStorageItem a t
---  IntItem    :: Id -> Id -> [TypedExp t] -> TStorageItem Integer t
---  BoolItem   :: Id -> Id -> [TypedExp t] -> TStorageItem Bool t
---  BytesItem  :: Id -> Id -> [TypedExp t] -> TStorageItem ByteString t
+  Item :: Sing a -> Id -> Id -> [TypedExp t] -> TStorageItem a t
 deriving instance Show (TStorageItem a t)
 deriving instance Eq (TStorageItem a t)
 
@@ -184,7 +181,6 @@ data Exp (a :: *) (t :: Timing) where
   GEQ :: Exp Integer t -> Exp Integer t -> Exp Bool t
   GE :: Exp Integer t -> Exp Integer t -> Exp Bool t
   LitBool :: Bool -> Exp Bool t
-  Var :: SType a -> Id -> Exp a t
   -- integers
   Add :: Exp Integer t -> Exp Integer t -> Exp Integer t
   Sub :: Exp Integer t -> Exp Integer t -> Exp Integer t
@@ -214,6 +210,7 @@ data Exp (a :: *) (t :: Timing) where
   Eq  :: (Eq a, Typeable a) => Exp a t -> Exp a t -> Exp Bool t
   NEq :: (Eq a, Typeable a) => Exp a t -> Exp a t -> Exp Bool t
   ITE :: Exp Bool t -> Exp a t -> Exp a t -> Exp a t
+  Var :: Sing a -> Id -> Exp a t
   TEntry :: Time t -> TStorageItem a t -> Exp a t
 deriving instance Show (Exp a t)
 
@@ -525,7 +522,7 @@ uintmax :: Int -> Integer
 uintmax a = 2 ^ a - 1
 
 mkVar :: SingI a => Id -> Exp a t
-mkVar name = let STypeable t = sing in Var t name
+mkVar name = withSing $ flip Var name
 
 castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
 castTime = gcast

From d6f125e433d5c66b6cdffa508b6883a111f21007 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Wed, 29 Sep 2021 21:22:01 +0200
Subject: [PATCH 18/36] retrieve `Typeable` instance without extra type layer
 or pattern noise

---
 src/Syntax/Types.hs | 103 ++++++++++++++++++++++++++++++++++----------
 src/Type.hs         |  66 +++++++++++++++-------------
 2 files changed, 117 insertions(+), 52 deletions(-)

diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index c323911c..aa50f17c 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -4,14 +4,19 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- These extensions should be removed once we remove the defs at the end of this file.
+{-# LANGUAGE RankNTypes, TypeApplications, StandaloneKindSignatures, PolyKinds, ScopedTypeVariables #-}
 
 module Syntax.Types where
 
 import Data.Singletons
-import Data.Typeable
+import Data.Typeable hiding (TypeRep,typeRep)
+import Type.Reflection
 
 import Data.ByteString as Syntax.Types (ByteString)
-import EVM.ABI as Syntax.Types (AbiType(..))
+import EVM.ABI         as Syntax.Types (AbiType(..))
 
 -- | Types understood by proving tools.
 data MType
@@ -28,13 +33,6 @@ data SType a where
 deriving instance Show (SType a)
 deriving instance Eq (SType a)
 
--- | Unfortunate extra layer which allows us to guarantee that our singletons
--- represent 'Data.Typeable' types.
-data STypeable a where
-  STypeable :: Typeable a => SType a -> STypeable a
-deriving instance Show (STypeable a)
-deriving instance Eq (STypeable a)
-
 metaType :: AbiType -> MType
 metaType (AbiUIntType _)     = Integer
 metaType (AbiIntType  _)     = Integer
@@ -48,33 +46,92 @@ metaType AbiStringType       = ByteStr
 --metaType (AbiTupleType        (Vector AbiType)
 metaType _ = error "Syntax.Types.metaType: TODO"
 
--- | For our purposes, the singleton of a type 'a' is always an 'STypeable a',
--- i.e. an @'Data.Typeable' a => 'SType' a@.
-type instance Sing = STypeable
+-- | For our purposes, the singleton of a type 'a' is always an @'SType' a@.
+-- Note that even though there only exist three different 'SType', this does
+-- not mean that the type family is partial. It simply means that the resulting
+-- type is uninhabited if the argument is neither 'Integer', 'Bool' nor
+-- 'ByteString'.
+type instance Sing = SType
 
 -- Defines which singleton to retreive when we only have the type, not the
 -- actual singleton.
-instance SingI Integer    where sing = STypeable SInteger
-instance SingI Bool       where sing = STypeable SBoolean
-instance SingI ByteString where sing = STypeable SByteStr
+instance SingI Integer    where sing = SInteger
+instance SingI Bool       where sing = SBoolean
+instance SingI ByteString where sing = SByteStr
 
+-- | This instance allows us to go between 'MType', @'SType' a@ and @a@,
+-- with @a :: '*'@.
 instance SingKind * where
+  -- | We can demote a type variable @a@ to a value of type 'MType'
   type Demote * = MType
 
-  fromSing (STypeable SInteger) = Integer
-  fromSing (STypeable SBoolean) = Boolean
-  fromSing (STypeable SByteStr) = ByteStr
+  -- | We can go from any singleton type to the corresponding demoted type.
+  fromSing SInteger = Integer
+  fromSing SBoolean = Boolean
+  fromSing SByteStr = ByteStr
 
-  toSing Integer = SomeSing (STypeable SInteger)
-  toSing Boolean = SomeSing (STypeable SBoolean)
-  toSing ByteStr = SomeSing (STypeable SByteStr)
+  -- | We can go from any demoted type to the corresponding singleton type,
+  -- but need to hide its type variable when doing so.
+  toSing Integer = SomeSing SInteger
+  toSing Boolean = SomeSing SBoolean
+  toSing ByteStr = SomeSing SByteStr
 
 -- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType'.
 pattern FromAbi :: () => Typeable a => SType a -> AbiType
-pattern FromAbi t <- (metaType -> FromSing (STypeable t))
+pattern FromAbi t <- (metaType -> FromSing t@Typeable)
 {-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
 
 -- | Pattern match on an 'MType' is if it were an 'SType'.
 pattern FromMeta :: () => Typeable a => SType a -> MType
-pattern FromMeta t <- FromSing (STypeable t)
+pattern FromMeta t <- FromSing t@Typeable
 {-# COMPLETE FromMeta #-} -- We promise that the pattern covers all cases of MType.
+
+-- | Helper pattern to retrieve the 'Typeable' instance of an 'SType'.
+pattern Typeable :: () => Typeable a => SType a
+pattern Typeable <- (stypeRep -> TypeRep)
+
+-- | Allows us to retrieve the 'TypeRep' of any 'SType', which in turn can be used
+-- to retrieve the 'Typeable' instance.
+stypeRep :: SType a -> TypeRep a
+stypeRep = \case
+  SInteger -> typeRep
+  SBoolean -> typeRep
+  SByteStr -> typeRep
+
+-- Everything below will be added to base 4.17 but for now we need it here.
+-- See https://gitlab.haskell.org/ghc/ghc/-/blob/master/libraries/base/Data/Typeable/Internal.hs#L264
+
+-- | A 'TypeableInstance' wraps up a 'Typeable' instance for explicit
+-- handling. For internal use: for defining 'TypeRep' pattern.
+type TypeableInstance :: forall k. k -> *
+data TypeableInstance a where
+ TypeableInstance :: Typeable a => TypeableInstance a
+
+-- | Get a reified 'Typeable' instance from an explicit 'TypeRep'.
+--
+-- For internal use: for defining 'TypeRep' pattern.
+typeableInstance :: forall (k :: *) (a :: k). TypeRep a -> TypeableInstance a
+typeableInstance rep = withTypeable rep TypeableInstance
+
+-- | A explicitly bidirectional pattern synonym to construct a
+-- concrete representation of a type.
+--
+-- As an __expression__: Constructs a singleton @TypeRep a@ given a
+-- implicit 'Typeable a' constraint:
+--
+-- @
+-- TypeRep @a :: Typeable a => TypeRep a
+-- @
+--
+-- As a __pattern__: Matches on an explicit @TypeRep a@ witness bringing
+-- an implicit @Typeable a@ constraint into scope.
+--
+-- @
+-- f :: TypeRep a -> ..
+-- f TypeRep = {- Typeable a in scope -}
+-- @
+--
+-- @since 4.17.0.0
+pattern TypeRep :: forall (k :: *) (a :: k). () => Typeable @k a => TypeRep @k a
+pattern TypeRep <- (typeableInstance -> TypeableInstance)
+  where TypeRep = typeRep
diff --git a/src/Type.hs b/src/Type.hs
index ee10a49d..d70e0335 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -7,7 +7,7 @@
 {-# Language DataKinds #-}
 {-# LANGUAGE ApplicativeDo #-}
 
-module Type (typecheck, bound, lookupVars, defaultStore, metaType, Err) where
+module Type (typecheck, bound, lookupVars, defaultStore, Err) where
 
 import EVM.ABI
 import EVM.Solidity (SlotType(..))
@@ -16,6 +16,7 @@ import Data.Maybe
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map.Strict    as Map -- abandon in favor of [(a,b)]?
+import Data.Singletons
 import Data.Typeable hiding (typeRep)
 import Type.Reflection (typeRep)
 
@@ -39,23 +40,25 @@ import Parse
 
 type Err = Error String
 
+-- | Main typechecking function.
 typecheck :: [U.RawBehaviour] -> Err [Claim]
 typecheck behvs = (S store:) . concat <$> traverse (splitBehaviour store) behvs
-                  <* noDuplicateContracts behvs
+                  <* noDuplicateContracts
                   <* traverse noDuplicateVars [creates | U.Definition _ _ _ _ creates _ _ _ <- behvs]
   where
     store = lookupVars behvs
 
-noDuplicateContracts :: [U.RawBehaviour] -> Err ()
-noDuplicateContracts behvs = noDuplicates [(pn,contract) | U.Definition pn contract _ _ _ _ _ _ <- behvs]
-                             $ \c -> "Multiple definitions of " <> c
+    noDuplicateContracts :: Err ()
+    noDuplicateContracts = noDuplicates [(pn,contract) | U.Definition pn contract _ _ _ _ _ _ <- behvs]
+                           $ \c -> "Multiple definitions of " <> c
 
-noDuplicateVars :: U.Creates -> Err ()
-noDuplicateVars (U.Creates assigns) = noDuplicates (fmap fst . fromAssign <$> assigns)
-                                      $ \x -> "Multiple definitions of " <> x
+    noDuplicateVars :: U.Creates -> Err ()
+    noDuplicateVars (U.Creates assigns) = noDuplicates (fmap fst . fromAssign <$> assigns)
+                                          $ \x -> "Multiple definitions of " <> x
 
-noDuplicates :: [(Pn,Id)] -> (Id -> String) -> Err ()
-noDuplicates xs errmsg = traverse_ (throw . fmap errmsg) . duplicatesBy ((==) `on` snd) $ xs
+    -- Generic helper
+    noDuplicates :: [(Pn,Id)] -> (Id -> String) -> Err ()
+    noDuplicates xs errmsg = traverse_ (throw . fmap errmsg) . duplicatesBy ((==) `on` snd) $ xs
 
 --- Finds storage declarations from constructors
 lookupVars :: [U.RawBehaviour] -> Store
@@ -64,12 +67,15 @@ lookupVars = foldMap $ \case
   U.Definition _ contract _ _ (U.Creates assigns) _ _ _ ->
     Map.singleton contract . Map.fromList $ snd . fromAssign <$> assigns
 
+-- | Extracts what we need to build a 'Store' and to verify that names are unique.
+-- Kind of stupid return type but it makes it easier to use the same function
+-- at both places (without relying on custom functions on triples.)
 fromAssign :: U.Assign -> (Pn, (Id, SlotType))
 fromAssign (U.AssignVal (U.StorageVar pn typ var) _) = (pn, (var, typ))
 fromAssign (U.AssignMany (U.StorageVar pn typ var) _) = (pn, (var, typ))
 fromAssign (U.AssignStruct _ _) = error "TODO: assignstruct"
 
--- | filters out duplicate entries in list
+-- | filters out duplicate entries in list based on a custom equality predicate.
 duplicatesBy :: (a -> a -> Bool) -> [a] -> [a]
 duplicatesBy _ [] = []
 duplicatesBy f (x:xs) =
@@ -168,6 +174,7 @@ splitBehaviour store (U.Definition _ contract iface@(Interface _ decls) iffs (U.
       | otherwise  = [ C $ Constructor contract Pass iface iffs'                 ensures updates []
                      , C $ Constructor contract Fail iface [Neg (mconcat iffs')] ensures []      [] ]
 
+-- | Typechecks a case, returning typed versions of its preconditions, rewrites and return value.
 checkCase :: Env -> U.Case -> Err ([Exp Bool Untimed], [Rewrite], Maybe (TypedExp Timed))
 checkCase env c@(U.Case _ pre post) = do
   if' <- traverse (inferExpr env) $ if isWild c then [] else [pre]
@@ -180,12 +187,13 @@ noStorageRead store expr = for_ (keys store) $ \name ->
   for_ (findWithDefault [] name (idFromRewrites expr)) $ \pn ->
     throw (pn,"Cannot read storage in creates block")
 
-makeUpdate :: Env -> SType a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
+-- | Creates a correctly typed 'StorageUpdate' given correctly typed components.
+makeUpdate :: Env -> Sing a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
 makeUpdate Env{contract} typ name ixs newVal = let item = Item typ contract name ixs in
   case typ of
     SInteger -> IntUpdate   item newVal
-    SBoolean -> BoolUpdate  item newVal--(BoolItem  contract name ixs) newVal
-    SByteStr -> BytesUpdate item newVal--(BytesItem contract name ixs) newVal
+    SBoolean -> BoolUpdate  item newVal
+    SByteStr -> BytesUpdate item newVal
 
 -- ensures that key types match value types in an U.Assign
 checkAssign :: Env -> U.Assign -> Err [StorageUpdate]
@@ -208,6 +216,7 @@ checkDefn :: Env -> AbiType -> AbiType -> Id -> U.Defn -> Err StorageUpdate
 checkDefn env keyType (FromAbi valType) name (U.Defn k val) =
   makeUpdate env valType name <$> checkIxs env (getPosn k) [k] [keyType] <*> inferExpr env val
 
+-- | Typechecks a postcondition, returning typed versions of its storage updates and return expression.
 checkPost :: Env -> U.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
 checkPost env@Env{contract,calldata} (U.Post storage extStorage maybeReturn) = do
   returnexp <- traverse (typedExp scopedEnv) maybeReturn
@@ -257,6 +266,7 @@ checkPost env@Env{contract,calldata} (U.Post storage extStorage maybeReturn) = d
         U.WildStorage -> Nothing
       ) extStorage
 
+-- | Typechecks a non-constant rewrite.
 checkStorageExpr :: Env -> U.Pattern -> U.Expr -> Err StorageUpdate
 checkStorageExpr _ (U.PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
 checkStorageExpr env@Env{store} (U.PEntry p name args) expr = case Map.lookup name store of
@@ -264,15 +274,17 @@ checkStorageExpr env@Env{store} (U.PEntry p name args) expr = case Map.lookup na
     makeUpdate env typ name [] <$> inferExpr env expr
   Just (StorageMapping argtyps (FromAbi valType)) ->
     makeUpdate env valType name <$> checkIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env expr
-  Nothing -> throw (p, "Unknown storage variable " <> show name)
+  Nothing ->
+    throw (p, "Unknown storage variable " <> show name)
 
+-- 
 checkPattern :: Env -> U.Pattern -> Err StorageLocation
 checkPattern _ (U.PWild _) = error "TODO: checkPattern for Wild storage"
 checkPattern env@Env{contract,store} (U.PEntry p name args) =
   case Map.lookup name store of
-    Just (StorageValue t) -> makeLocation t []
+    Just (StorageValue t)           -> makeLocation t []
     Just (StorageMapping argtyps t) -> makeLocation t (NonEmpty.toList argtyps)
-    Nothing -> throw (p, "Unknown storage variable " <> show name)
+    Nothing                         -> throw (p, "Unknown storage variable " <> show name)
   where
     makeLocation :: AbiType -> [AbiType] -> Err StorageLocation
     makeLocation (FromAbi locType) argTypes =
@@ -318,7 +330,8 @@ typedExp env e = notAtPosn (getPosn e)
     $ A (ExpInt   <$> inferExpr env e)
   <!> A (ExpBool  <$> inferExpr env e)
   <!> A (ExpBytes <$> inferExpr env e)
-  <!> error "Internal error: typedExp"
+  <!> error "Internal error: typedExp" -- should never happen since e's constructor can always be given a type
+                                       -- (even though its children may not fit into that)
 
 -- | Attempts to construct an expression with the type and timing required by
 -- the caller. If this is impossible, an error is thrown instead.
@@ -368,7 +381,7 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
       Just Refl -> pure id
       Nothing   -> throw (pn,"Type mismatch. Expected " <> show (typeRep @a) <> ", got " <> show (typeRep @x))
 
-    checkTime :: forall x t0. (Typeable t0, Typeable x) => Pn -> Err (Exp x t0 -> Exp x t)
+    checkTime :: forall x t0. Typeable t0 => Pn -> Err (Exp x t0 -> Exp x t)
     checkTime pn = case eqT @t @t0 of
       Just Refl -> pure id
       Nothing   -> throw (pn, (tail . show $ typeRep @t) <> " variable needed here")
@@ -381,7 +394,8 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
         $ A (check pn <*> (cons @Integer    <$> inferExpr env e1 <*> inferExpr env e2))
       <!> A (check pn <*> (cons @Bool       <$> inferExpr env e1 <*> inferExpr env e2))
       <!> A (check pn <*> (cons @ByteString <$> inferExpr env e1 <*> inferExpr env e2))
-      <!> error "Internal error: polycheck" -- throw (pn, "Type mismatch. Left- and right-hand sides do not match")
+      <!> error "Internal error: polycheck" -- should never happen since e1's constructor can always be given a type
+                                            -- (even though its children may not fit into that)
 
     -- Try to construct a reference to a calldata variable or an item in storage.
     entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [U.Expr] -> Err (Exp a t)
@@ -390,11 +404,7 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
       (Just _, Just _)   -> throw (pn, "Ambiguous variable " <> name)
       (Nothing, Just (FromMeta varType)) ->
         if isTimed timing then throw (pn, "Calldata var cannot be pre/post")
-          else check pn ?? Var varType name
-          ---- Create a calldata reference and typecheck it as with normal expressions.
-         --Integer -> check pn ?? IntVar  name
-          --Boolean -> check pn ?? BoolVar name
-          --ByteStr -> check pn ?? ByVar   name
+        else check pn ?? Var varType name
       (Just (StorageValue a), Nothing)      -> checkEntry a []
       (Just (StorageMapping ts a), Nothing) -> checkEntry a $ NonEmpty.toList ts
       where
@@ -402,11 +412,9 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
         checkEntry (FromAbi entryType) ts = checkTime pn <*> (check pn <*>
           (TEntry timing . Item entryType contract name <$> checkIxs env pn es ts))
 
+-- | Checks that there are as many expressions as expected by the types,
+-- and checks that each one of them agree with its type.
 checkIxs :: Typeable t => Env -> Pn -> [U.Expr] -> [AbiType] -> Err [TypedExp t]
 checkIxs env pn exprs types = if length exprs /= length types
                               then throw (pn, "Index mismatch for entry")
                               else traverse (uncurry $ checkExpr env) (exprs `zip` types)
-
--- checkIxs' :: Typeable t => Env -> Pn -> [U.Expr] -> [AbiType] -> Logger TypeErr [TypedExp t]
--- checkIxs' env pn exprs types = traverse (uncurry $ checkExpr env) (exprs `zip` types)
---                           <* when (length exprs /= length types) (log' (pn, "Index mismatch for entry!"))

From d81dd6947e308d64be637b6389de5e4d57b5ca18 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sat, 2 Oct 2021 06:18:39 +0200
Subject: [PATCH 19/36] all AST constructors use singletons

---
 src/Coq.hs                 |  23 ++++-----
 src/Enrich.hs              |   4 +-
 src/HEVM.hs                |  26 ++++++----
 src/K.hs                   |  22 ++++----
 src/Print.hs               |  19 ++++---
 src/SMT.hs                 |  78 ++++++++++++----------------
 src/Syntax.hs              |  97 +++++++++++++++++++----------------
 src/Syntax/Annotated.hs    |   7 ++-
 src/Syntax/TimeAgnostic.hs | 101 ++++++++++++++++++++++---------------
 src/Syntax/Types.hs        |  54 +++++++++++++++-----
 src/Type.hs                |  52 +++++++++----------
 src/test/Test.hs           |   8 ++-
 12 files changed, 266 insertions(+), 225 deletions(-)

diff --git a/src/Coq.hs b/src/Coq.hs
index 8f93e139..77735b0a 100644
--- a/src/Coq.hs
+++ b/src/Coq.hs
@@ -162,9 +162,8 @@ stateval store handler updates = T.unwords $ stateConstructor : fmap (valuefor u
   valuefor updates' (name, t) =
     case find (eqName name) updates' of
       Nothing -> parens $ handler name t
-      Just (IntUpdate  item e) -> lambda (ixsFromItem item) 0 e (idFromItem item)
-      Just (BoolUpdate item e) -> lambda (ixsFromItem item) 0 e (idFromItem item)
-      Just (BytesUpdate _ _) -> error "bytestrings not supported"
+      Just (Update SByteStr item e) -> error "bytestrings not supported"
+      Just (Update t item e) -> lambda (ixsFromItem item) 0 e (idFromItem item)
 
 -- | filter by name
 eqName :: Id -> StorageUpdate -> Bool
@@ -180,9 +179,9 @@ lambda (x:xs) n e m = parens $
   <> " else " <> T.pack m <> " " <> stateVar <> " " <> lambdaArgs n where
   name = anon <> T.pack (show n)
   lambdaArgs i = T.unwords $ map (\a -> anon <> T.pack (show a)) [0..i]
-  eqsym (ExpInt _) = " =? "
-  eqsym (ExpBool _) = " =?? "
-  eqsym (ExpBytes _) = error "bytestrings not supported"
+  eqsym (TExp SInteger _) = undefined -- T.pack " =? "
+  eqsym (TExp SBoolean _) = undefined -- T.pack " =?? "
+  eqsym (TExp SByteStr _) = error "bytestrings not supported"
 
 -- | produce a block of declarations from an interface
 interface :: Interface -> T.Text
@@ -210,9 +209,9 @@ abiType a = error $ show a
 
 -- | coq syntax for a return type
 returnType :: TypedExp -> T.Text
-returnType (ExpInt _) = "Z"
-returnType (ExpBool _) = "bool"
-returnType (ExpBytes _) = "bytestrings not supported"
+returnType (TExp SInteger _) = "Z"
+returnType (TExp SBoolean _) = "bool"
+returnType (TExp SByteStr _) = "bytestrings not supported"
 
 -- | default value for a given type
 -- this is used in cases where a value is not set in the constructor
@@ -300,9 +299,9 @@ coqprop _ = error "ill formed proposition"
 
 -- | coq syntax for a typed expression
 typedexp :: TypedExp -> T.Text
-typedexp (ExpInt e)   = coqexp e
-typedexp (ExpBool e)  = coqexp e
-typedexp (ExpBytes _) = error "bytestrings not supported"
+typedexp (TExp SInteger e)   = coqexp e
+typedexp (TExp SBoolean e)  = coqexp e
+typedexp (TExp SByteStr _) = error "bytestrings not supported"
 
 entry :: TStorageItem a -> When -> T.Text
 entry (Item SByteStr _ _ _) _    = error "bytestrings not supported"
diff --git a/src/Enrich.hs b/src/Enrich.hs
index 50318044..05a845a3 100644
--- a/src/Enrich.hs
+++ b/src/Enrich.hs
@@ -87,8 +87,8 @@ mkStorageBounds :: Store -> [Rewrite] -> [Exp Bool Untimed]
 mkStorageBounds store refs = catMaybes $ mkBound <$> refs
   where
     mkBound :: Rewrite -> Maybe (Exp Bool Untimed)
-    mkBound (Constant (IntLoc item)) = Just $ fromItem item
-    mkBound (Rewrite (IntUpdate item _)) = Just $ fromItem item
+    mkBound (Constant (Loc SInteger item)) = Just $ fromItem item
+    mkBound (Rewrite (Update SInteger item _)) = Just $ fromItem item
     mkBound _ = Nothing
 
     fromItem :: TStorageItem Integer Untimed -> Exp Bool Untimed
diff --git a/src/HEVM.hs b/src/HEVM.hs
index a2583054..bf953b6b 100644
--- a/src/HEVM.hs
+++ b/src/HEVM.hs
@@ -4,6 +4,7 @@
 {-# Language DataKinds #-}
 {-# Language GADTs #-}
 {-# Language MonadComprehensions #-}
+{-# Language ViewPatterns #-}
 
 module HEVM where
 
@@ -123,8 +124,8 @@ checkPostStorage ctx (Behaviour _ _ _ _ _ _ rewrites _) pre post contractMap sol
                  slot update' = let S _ w = calculateSlot ctx solcjson (locFromUpdate update')
                                in w
                  insertUpdate :: SArray (WordN 256) (WordN 256) -> StorageUpdate -> SArray (WordN 256) (WordN 256)
-                 insertUpdate store u@(IntUpdate _ e) = writeArray store (slot u) $ sFromIntegral $ symExpInt ctx e
-                 insertUpdate store u@(BoolUpdate _ e) = writeArray store (slot u) $ ite (symExpBool ctx e) 1 0
+                 insertUpdate store u@(Update SInteger _ e) = writeArray store (slot u) $ sFromIntegral $ symExpInt ctx e
+                 insertUpdate store u@(Update SBoolean _ e) = writeArray store (slot u) $ ite (symExpBool ctx e) 1 0
                  insertUpdate _ _ = error "bytes unsupported"
                in post' .== foldl insertUpdate pre' insertions
               _ -> sFalse
@@ -208,9 +209,10 @@ locateStorage ctx solcjson contractMap method (pre, post) item =
       Just (S _ postValue) = readStorage (view storage postContract) (calculateSlot ctx solcjson item')
 
       name :: StorageLocation -> Id
-      name (IntLoc   i) = nameFromItem method i
-      name (BoolLoc  i) = nameFromItem method i
-      name (BytesLoc i) = nameFromItem method i
+      name (Loc _ i) = nameFromItem method i
+    --  name (IntLoc   i) = nameFromItem method i
+    --  name (BoolLoc  i) = nameFromItem method i
+    --  name (BytesLoc i) = nameFromItem method i
 
   in (name item',  (SymInteger (sFromIntegral preValue), SymInteger (sFromIntegral postValue)))
 
@@ -307,9 +309,10 @@ type Env = Map Id SMType
 
 symExp :: Ctx -> TypedExp -> SMType
 symExp ctx ret = case ret of
-  ExpInt e -> SymInteger $ symExpInt ctx e
-  ExpBool e -> SymBool $ symExpBool ctx e
-  ExpBytes e -> SymBytes $ symExpBytes ctx e
+  TExp SInteger e -> SymInteger $ symExpInt ctx e -- TODO rest
+--  TExp SInteger e -> SymInteger $ symExpInt ctx e
+--  TExp SBoolean e -> SymBool $ symExpBool ctx e
+--  TExp SByteStr e -> SymBytes $ symExpBytes ctx e
 
 symExpBool :: Ctx -> Exp Bool -> SBV Bool
 symExpBool ctx@(Ctx c m args store _) e = case e of
@@ -374,9 +377,10 @@ nameFromItem method (Item _ c name ixs) = c @@ method @@ name <> showIxs
 
 nameFromTypedExp :: ContractName -> Method -> TypedExp -> Id
 nameFromTypedExp c method e = case e of
-  ExpInt e' -> nameFromExp c method e'
-  ExpBool e' -> nameFromExp c method e'
-  ExpBytes e' -> nameFromExp c method e'
+  TExp _ e' -> nameFromExp c method e'
+--  TExp SInteger e' -> nameFromExp c method e'
+--  TExp SBoolean e' -> nameFromExp c method e'
+--  TExp SByteStr e' -> nameFromExp c method e'
 
 nameFromExp :: ContractName -> Method -> Exp a -> Id
 nameFromExp c m e = case e of
diff --git a/src/K.hs b/src/K.hs
index 23ef6f6f..d6afc484 100644
--- a/src/K.hs
+++ b/src/K.hs
@@ -88,14 +88,14 @@ kVar a = (unpack . Text.toUpper . pack $ [head a]) <> tail a
 
 kAbiEncode :: Maybe TypedExp -> String
 kAbiEncode Nothing = ".ByteArray"
-kAbiEncode (Just (ExpInt a)) = "#enc(#uint256" <> kExpr a <> ")"
-kAbiEncode (Just (ExpBool _)) = ".ByteArray"
-kAbiEncode (Just (ExpBytes _)) = ".ByteArray"
+kAbiEncode (Just (TExp SInteger a)) = "#enc(#uint256" <> kExpr a <> ")"
+kAbiEncode (Just (TExp SBoolean _)) = ".ByteArray"
+kAbiEncode (Just (TExp SByteStr _)) = ".ByteArray"
 
 kTypedExpr :: TypedExp -> String
-kTypedExpr (ExpInt a) = kExpr a
-kTypedExpr (ExpBool a) = kExpr a
-kTypedExpr (ExpBytes _) = error "TODO: add support for ExpBytes to kExpr"
+kTypedExpr (TExp SInteger a) = kExpr a
+kTypedExpr (TExp SBoolean a) = kExpr a
+kTypedExpr (TExp SByteStr _) = error "TODO: add support for TExp SByteStr to kExpr"
 
 kExpr :: Exp a -> String
 -- integers
@@ -155,11 +155,11 @@ kStorageEntry storageLayout update =
          (error "Internal error: storageVar not found, please report this error")
          (Map.lookup (pack (idFromRewrite update)) storageLayout)
   in case update of
-       Rewrite (IntUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
-       Rewrite (BoolUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
-       Rewrite (BytesUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
-       Constant (IntLoc a) -> (loc, (offset, kStorageName Pre a, kStorageName Pre a))
-       v -> error $ "Internal error: TODO kStorageEntry: " <> show v
+       Rewrite (Update _ a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
+       --Rewrite (BoolUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
+       --Rewrite (BytesUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
+       Constant (Loc SInteger a) -> (loc, (offset, kStorageName Pre a, kStorageName Pre a))
+       v -> error $ "Internal error: TODO kStorageEntry: " <> show v -- TODO should this really be separate?
 
 --packs entries packed in one slot
 normalize :: Bool -> [(String, (Int, String, String))] -> String
diff --git a/src/Print.hs b/src/Print.hs
index bcb5964e..2eeff033 100644
--- a/src/Print.hs
+++ b/src/Print.hs
@@ -85,10 +85,9 @@ prettyExp e = case e of
     print2 sym a b = "(" <> prettyExp a <> " " <> sym <> " " <> prettyExp b <> ")"
 
 prettyTypedExp :: TypedExp t -> String
-prettyTypedExp e = case e of
-  ExpInt e' -> prettyExp e'
-  ExpBool e' -> prettyExp e'
-  ExpBytes e' -> prettyExp e'
+prettyTypedExp (TExp t e) = prettyExp e
+--  TExp SBoolean e' -> prettyExp e'
+--  TExp SByteStr e' -> prettyExp e'
 
 prettyItem :: TStorageItem a t -> String
 prettyItem item = contractFromItem item <> "." <> idFromItem item <> concatMap (brackets . prettyTypedExp) (ixsFromItem item)
@@ -96,14 +95,14 @@ prettyItem item = contractFromItem item <> "." <> idFromItem item <> concatMap (
     brackets str = "[" <> str <> "]"
 
 prettyLocation :: StorageLocation t -> String
-prettyLocation (IntLoc item) = prettyItem item
-prettyLocation (BoolLoc item) = prettyItem item
-prettyLocation (BytesLoc item) = prettyItem item
+prettyLocation (Loc _ item) = prettyItem item
+--prettyLocation (BoolLoc item) = prettyItem item
+--prettyLocation (BytesLoc item) = prettyItem item
 
 prettyUpdate :: StorageUpdate t -> String
-prettyUpdate (IntUpdate item e) = prettyItem item <> " => " <> prettyExp e
-prettyUpdate (BoolUpdate item e) = prettyItem item <> " => " <> prettyExp e
-prettyUpdate (BytesUpdate item e) = prettyItem item <> " => " <> prettyExp e
+prettyUpdate (Update _ item e) = prettyItem item <> " => " <> prettyExp e
+--prettyUpdate (BoolUpdate item e) = prettyItem item <> " => " <> prettyExp e
+--prettyUpdate (BytesUpdate item e) = prettyItem item <> " => " <> prettyExp e
 
 prettyEnv :: EthEnv -> String
 prettyEnv e = case e of
diff --git a/src/SMT.hs b/src/SMT.hs
index 5b87421a..91003b99 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MonadComprehensions #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module SMT (
   Solver(..),
@@ -435,7 +436,7 @@ getCtorModel ctor solver = do
 
 -- | Gets a concrete value from the solver for the given storage location
 getStorageValue :: SolverInstance -> Id -> When -> StorageLocation -> IO (StorageLocation, TypedExp)
-getStorageValue solver ifaceName whn loc = do
+getStorageValue solver ifaceName whn loc@(Loc typ _) = do
   let name = if isMapping loc
                 then withInterface ifaceName
                      $ select
@@ -444,10 +445,10 @@ getStorageValue solver ifaceName whn loc = do
                 else nameFromLoc whn loc
   output <- getValue solver name
   -- TODO: handle errors here...
-  let val = case loc of
-              IntLoc {} -> parseIntModel output
-              BoolLoc {} -> parseBoolModel output
-              BytesLoc {} -> parseBytesModel output
+  let val = case typ of
+              SInteger -> parseIntModel output
+              SBoolean -> parseBoolModel output
+              SByteStr -> parseBytesModel output
   pure (loc, val)
 
 -- | Gets a concrete value from the solver for the given calldata argument
@@ -477,11 +478,11 @@ getValue solver name = sendCommand solver $ "(get-value (" <> name <> "))"
 
 -- | Parse the result of a call to getValue as an Int
 parseIntModel :: String -> TypedExp
-parseIntModel = ExpInt . LitInt . read . parseSMTModel
+parseIntModel = _TExp . LitInt . read . parseSMTModel
 
 -- | Parse the result of a call to getValue as a Bool
 parseBoolModel :: String -> TypedExp
-parseBoolModel = ExpBool . LitBool . readBool . parseSMTModel
+parseBoolModel = _TExp . LitBool . readBool . parseSMTModel
   where
     readBool "true" = True
     readBool "false" = False
@@ -489,7 +490,7 @@ parseBoolModel = ExpBool . LitBool . readBool . parseSMTModel
 
 -- | Parse the result of a call to getValue as a Bytes
 parseBytesModel :: String -> TypedExp
-parseBytesModel = ExpBytes . ByLit . fromString . parseSMTModel
+parseBytesModel = _TExp . ByLit . fromString . parseSMTModel
 
 -- | Extracts a string representation of the value in the output from a call to `(get-value)`
 parseSMTModel :: String -> String
@@ -516,29 +517,18 @@ parseSMTModel s = if length s0Caps == 1
 
 -- | encodes a storage update from a constructor creates block as an smt assertion
 encodeInitialStorage :: Id -> StorageUpdate -> SMT2
-encodeInitialStorage behvName update = case update of
-  IntUpdate item e -> encode item e
-  BoolUpdate item e -> encode item e
-  BytesUpdate item e -> encode item e
-  where
-    encode :: TStorageItem a -> Exp a -> SMT2
-    encode item e =
-      let
-        postentry  = withInterface behvName $ expToSMT2 (TEntry Post item)
-        expression = withInterface behvName $ expToSMT2 e
-      in "(assert (= " <> postentry <> " " <> expression <> "))"
+encodeInitialStorage behvName (Update _ item exp) =
+  let
+    postentry  = withInterface behvName $ expToSMT2 (TEntry Post item)
+    expression = withInterface behvName $ expToSMT2 exp
+  in "(assert (= " <> postentry <> " " <> expression <> "))"
 
 -- | declares a storage location that is created by the constructor, these
 --   locations have no prestate, so we declare a post var only
 declareInitialStorage :: StorageUpdate -> SMT2
-declareInitialStorage update = case locFromUpdate update of
-  IntLoc item -> mkItem item
-  BoolLoc item -> mkItem item
-  BytesLoc item -> mkItem item
-  where
-    mkItem item = case ixsFromItem item of
-      []       -> constant (nameFromItem Post item) (itemType item)
-      (ix:ixs) -> array (nameFromItem Post item) (ix :| ixs) (itemType item)
+declareInitialStorage (locFromUpdate -> Loc _ item) = case ixsFromItem item of
+  []       -> constant (nameFromItem Post item)             (itemType item)
+  (ix:ixs) -> array    (nameFromItem Post item) (ix :| ixs) (itemType item)
 
 -- | encodes a storge update rewrite as an smt assertion
 encodeUpdate :: Id -> Rewrite -> SMT2
@@ -548,16 +538,11 @@ encodeUpdate behvName (Rewrite update) = encodeInitialStorage behvName update
 -- | declares a storage location that exists both in the pre state and the post
 --   state (i.e. anything except a loc created by a constructor claim)
 declareStorageLocation :: StorageLocation -> [SMT2]
-declareStorageLocation loc = case loc of
-  IntLoc item -> mkItem item
-  BoolLoc item -> mkItem item
-  BytesLoc item -> mkItem item
-  where
-    mkItem item = case ixsFromItem item of
-      []       -> [ constant (nameFromItem Pre item) (itemType item)
-                  , constant (nameFromItem Post item) (itemType item) ]
-      (ix:ixs) -> [ array (nameFromItem Pre item) (ix :| ixs) (itemType item)
-                  , array (nameFromItem Post item) (ix :| ixs) (itemType item) ]
+declareStorageLocation (Loc _ item) = case ixsFromItem item of
+  []       -> [ constant (nameFromItem Pre item) (itemType item)
+              , constant (nameFromItem Post item) (itemType item) ]
+  (ix:ixs) -> [ array (nameFromItem Pre item) (ix :| ixs) (itemType item)
+              , array (nameFromItem Post item) (ix :| ixs) (itemType item) ]
 
 -- | produces an SMT2 expression declaring the given decl as a symbolic constant
 declareArg :: Id -> Decl -> SMT2
@@ -571,9 +556,9 @@ declareEthEnv env = constant (prettyEnv env) tp
 -- | encodes a typed expression as an smt2 expression
 typedExpToSMT2 :: TypedExp -> Ctx SMT2
 typedExpToSMT2 re = case re of
-  ExpInt ei -> expToSMT2 ei
-  ExpBool eb -> expToSMT2 eb
-  ExpBytes ebs -> expToSMT2 ebs
+  TExp SInteger ei -> expToSMT2 ei
+  TExp SBoolean eb -> expToSMT2 eb
+  TExp SByteStr ebs -> expToSMT2 ebs
 
 -- | encodes the given Exp as an smt2 expression
 expToSMT2 :: Exp a -> Ctx SMT2
@@ -678,9 +663,9 @@ sType ByteStr = "String"
 
 -- | act -> smt2 type translation
 sType' :: TypedExp -> SMT2
-sType' (ExpInt {}) = "Int"
-sType' (ExpBool {}) = "Bool"
-sType' (ExpBytes {}) = "String"
+sType' (TExp SInteger _) = "Int"
+sType' (TExp SBoolean _) = "Bool"
+sType' (TExp SByteStr _) = "String"
 
 
 --- ** Variable Names ** ---
@@ -691,10 +676,9 @@ nameFromItem whn (Item _ c name _) = c @@ name @@ show whn
 
 -- Construct the smt2 variable name for a given storage location
 nameFromLoc :: When -> StorageLocation -> Id
-nameFromLoc whn loc = case loc of
-  IntLoc item -> nameFromItem whn item
-  BoolLoc item -> nameFromItem whn item
-  BytesLoc item -> nameFromItem whn item
+nameFromLoc whn (Loc _ item) = nameFromItem whn item
+  -- BoolLoc item -> nameFromItem whn item
+  -- BytesLoc item -> nameFromItem whn item
 
 -- Construct the smt2 variable name for a given decl
 nameFromDecl :: Id -> Decl -> Id
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 7d68dfc7..8d851b2f 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 {-|
 Module      : Syntax
@@ -59,31 +58,34 @@ storesFromClaims claims = [s | S s <- claims]
 locsFromRewrite :: Rewrite t -> [StorageLocation t]
 locsFromRewrite update = nub $ case update of
   Constant loc -> [loc]
-  Rewrite (IntUpdate   item e) -> locsFromItem item <> locsFromExp e
-  Rewrite (BoolUpdate  item e) -> locsFromItem item <> locsFromExp e
-  Rewrite (BytesUpdate item e) -> locsFromItem item <> locsFromExp e
+  Rewrite (Update _ item e) -> locsFromItem item <> locsFromExp e
+--  Rewrite (BoolUpdate  item e) -> locsFromItem item <> locsFromExp e
+--  Rewrite (BytesUpdate item e) -> locsFromItem item <> locsFromExp e
 
 locFromRewrite :: Rewrite t -> StorageLocation t
 locFromRewrite = onRewrite id locFromUpdate
 
 locFromUpdate :: StorageUpdate t -> StorageLocation t
-locFromUpdate (IntUpdate   item _) = IntLoc item
-locFromUpdate (BoolUpdate  item _) = BoolLoc item
-locFromUpdate (BytesUpdate item _) = BytesLoc item
+locFromUpdate (Update typ item _) = Loc typ item
+--locFromUpdate (IntUpdate   item _) = IntLoc item
+--locFromUpdate (BoolUpdate  item _) = BoolLoc item
+--locFromUpdate (BytesUpdate item _) = BytesLoc item
 
 locsFromItem :: TStorageItem a t -> [StorageLocation t]
-locsFromItem item@(Item typ _ _ ixs) = case typ of
-  SInteger -> IntLoc   item : ixLocs ixs
-  SBoolean -> BoolLoc  item : ixLocs ixs
-  SByteStr -> BytesLoc item : ixLocs ixs
+locsFromItem item@(Item typ _ _ ixs) = Loc typ item : ixLocs ixs
+--case typ of
+--  SInteger -> IntLoc   item : ixLocs ixs
+--  SBoolean -> BoolLoc  item : ixLocs ixs
+--  SByteStr -> BytesLoc item : ixLocs ixs
   where
     ixLocs :: [TypedExp t] -> [StorageLocation t]
     ixLocs = concatMap locsFromTypedExp
 
 locsFromTypedExp :: TypedExp t -> [StorageLocation t]
-locsFromTypedExp (ExpInt e) = locsFromExp e
-locsFromTypedExp (ExpBool e) = locsFromExp e
-locsFromTypedExp (ExpBytes e) = locsFromExp e
+locsFromTypedExp (TExp _ e) = locsFromExp e
+--locsFromTypedExp (TExp SInteger e) = locsFromExp e
+--locsFromTypedExp (TExp SBoolean e) = locsFromExp e
+--locsFromTypedExp (TExp SByteStr e) = locsFromExp e
 
 locsFromExp :: Exp a t -> [StorageLocation t]
 locsFromExp = nub . go
@@ -142,20 +144,23 @@ ethEnvFromConstructor (Constructor _ _ _ pre post initialStorage rewrites) = nub
 
 ethEnvFromRewrite :: Rewrite t -> [EthEnv]
 ethEnvFromRewrite rewrite = case rewrite of
-  Constant (IntLoc item) -> ethEnvFromItem item
-  Constant (BoolLoc item) -> ethEnvFromItem item
-  Constant (BytesLoc item) -> ethEnvFromItem item
-  Rewrite (IntUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
-  Rewrite (BoolUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
-  Rewrite (BytesUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
+  Constant (Loc _ item) -> ethEnvFromItem item
+--  Constant (IntLoc item) -> ethEnvFromItem item
+--  Constant (BoolLoc item) -> ethEnvFromItem item
+--  Constant (BytesLoc item) -> ethEnvFromItem item
+  Rewrite (Update _ item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
+--  Rewrite (IntUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
+--  Rewrite (BoolUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
+--  Rewrite (BytesUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
 
 ethEnvFromItem :: TStorageItem a t -> [EthEnv]
 ethEnvFromItem = nub . concatMap ethEnvFromTypedExp . ixsFromItem
 
 ethEnvFromTypedExp :: TypedExp t -> [EthEnv]
-ethEnvFromTypedExp (ExpInt e) = ethEnvFromExp e
-ethEnvFromTypedExp (ExpBool e) = ethEnvFromExp e
-ethEnvFromTypedExp (ExpBytes e) = ethEnvFromExp e
+ethEnvFromTypedExp (TExp _ e) = ethEnvFromExp e
+--ethEnvFromTypedExp (TExp SInteger e) = ethEnvFromExp e
+--ethEnvFromTypedExp (TExp SBoolean e) = ethEnvFromExp e
+--ethEnvFromTypedExp (TExp SByteStr e) = ethEnvFromExp e
 
 ethEnvFromExp :: Exp a t -> [EthEnv]
 ethEnvFromExp = nub . go
@@ -205,14 +210,16 @@ idFromItem :: TStorageItem a t -> Id
 idFromItem (Item _ _ name _) = name
 
 idFromUpdate :: StorageUpdate t -> Id
-idFromUpdate (IntUpdate   item _) = idFromItem item
-idFromUpdate (BoolUpdate  item _) = idFromItem item
-idFromUpdate (BytesUpdate item _) = idFromItem item
+idFromUpdate (Update _ item _) = idFromItem item
+-- idFromUpdate (IntUpdate   item _) = idFromItem item
+-- idFromUpdate (BoolUpdate  item _) = idFromItem item
+-- idFromUpdate (BytesUpdate item _) = idFromItem item
 
 idFromLocation :: StorageLocation t -> Id
-idFromLocation (IntLoc   item) = idFromItem item
-idFromLocation (BoolLoc  item) = idFromItem item
-idFromLocation (BytesLoc item) = idFromItem item
+idFromLocation (Loc _ item) = idFromItem item
+--idFromLocation (IntLoc   item) = idFromItem item
+--idFromLocation (BoolLoc  item) = idFromItem item
+--idFromLocation (BytesLoc item) = idFromItem item
 
 contractFromRewrite :: Rewrite t -> Id
 contractFromRewrite = onRewrite contractFromLoc contractFromUpdate
@@ -231,30 +238,34 @@ contractsInvolved :: Behaviour t -> [Id]
 contractsInvolved = fmap contractFromRewrite . _stateUpdates
 
 contractFromLoc :: StorageLocation t -> Id
-contractFromLoc (IntLoc   item) = contractFromItem item
-contractFromLoc (BoolLoc  item) = contractFromItem item
-contractFromLoc (BytesLoc item) = contractFromItem item
+contractFromLoc (Loc _ item) = contractFromItem item
+-- contractFromLoc (IntLoc   item) = contractFromItem item
+-- contractFromLoc (BoolLoc  item) = contractFromItem item
+-- contractFromLoc (BytesLoc item) = contractFromItem item
 
 contractFromUpdate :: StorageUpdate t -> Id
-contractFromUpdate (IntUpdate   item _) = contractFromItem item
-contractFromUpdate (BoolUpdate  item _) = contractFromItem item
-contractFromUpdate (BytesUpdate item _) = contractFromItem item
+contractFromUpdate (Update _ item _) = contractFromItem item
+-- contractFromUpdate (IntUpdate   item _) = contractFromItem item
+-- contractFromUpdate (BoolUpdate  item _) = contractFromItem item
+-- contractFromUpdate (BytesUpdate item _) = contractFromItem item
 
 ixsFromLocation :: StorageLocation t -> [TypedExp t]
-ixsFromLocation (IntLoc item) = ixsFromItem item
-ixsFromLocation (BoolLoc item) = ixsFromItem item
-ixsFromLocation (BytesLoc item) = ixsFromItem item
+ixsFromLocation (Loc _ item) = ixsFromItem item
+-- ixsFromLocation (IntLoc item) = ixsFromItem item
+-- ixsFromLocation (BoolLoc item) = ixsFromItem item
+-- ixsFromLocation (BytesLoc item) = ixsFromItem item
 
 ixsFromUpdate :: StorageUpdate t -> [TypedExp t]
-ixsFromUpdate (IntUpdate   item _) = ixsFromItem item
-ixsFromUpdate (BoolUpdate  item _) = ixsFromItem item
-ixsFromUpdate (BytesUpdate item _) = ixsFromItem item
+ixsFromUpdate (Update _ item _) = ixsFromItem item
+-- ixsFromUpdate (IntUpdate   item _) = ixsFromItem item
+-- ixsFromUpdate (BoolUpdate  item _) = ixsFromItem item
+-- ixsFromUpdate (BytesUpdate item _) = ixsFromItem item
 
 ixsFromRewrite :: Rewrite t -> [TypedExp t]
 ixsFromRewrite = onRewrite ixsFromLocation ixsFromUpdate
 
-itemType :: forall a t. SingI a => TStorageItem a t -> MType
-itemType _ = withSing @a fromSing
+itemType :: TStorageItem a t -> MType
+itemType (Item t _ _ _) = fromSing t
 
 isMapping :: StorageLocation t -> Bool
 isMapping = not . null . ixsFromLocation
diff --git a/src/Syntax/Annotated.hs b/src/Syntax/Annotated.hs
index 877db535..ae4fadd8 100644
--- a/src/Syntax/Annotated.hs
+++ b/src/Syntax/Annotated.hs
@@ -72,7 +72,6 @@ instance Annotatable Agnostic.Rewrite where
   annotate (Rewrite  update)   = Rewrite  $ annotate update
 
 instance Annotatable Agnostic.StorageUpdate where
-  annotate update = case update of
-    IntUpdate item expr -> IntUpdate (setPost item) (setPre expr)
-    BoolUpdate item expr -> BoolUpdate (setPost item) (setPre expr)
-    BytesUpdate item expr -> BytesUpdate (setPost item) (setPre expr)
+  annotate (Update typ item expr) = Update typ (setPost item) (setPre expr)
+--    BoolUpdate item expr -> BoolUpdate (setPost item) (setPre expr)
+--    BytesUpdate item expr -> BytesUpdate (setPost item) (setPre expr)
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 6adbaf63..38504f22 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -10,7 +10,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, PatternSynonyms, ViewPatterns #-}
 
 {-|
 Module      : Syntax.TimeAgnostic
@@ -32,10 +32,10 @@ import Control.Applicative (empty)
 
 import Data.Aeson
 import Data.Aeson.Types
-import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.List (genericTake,genericDrop)
 import Data.Map.Strict (Map)
+import Data.Singletons
 import Data.String (fromString)
 import Data.Text (pack)
 import Data.Typeable
@@ -48,7 +48,7 @@ import Syntax.Types   as Syntax.TimeAgnostic
 import Syntax.Timing  as Syntax.TimeAgnostic
 import Syntax.Untyped as Syntax.TimeAgnostic (Id, Interface(..), EthEnv(..), Decl(..))
 
-import Data.Singletons
+import GHC.Records
 
 -- AST post typechecking
 data Claim t
@@ -129,16 +129,33 @@ data Rewrite t
   deriving (Show, Eq)
 
 data StorageUpdate t
-  = IntUpdate (TStorageItem Integer t) (Exp Integer t)
-  | BoolUpdate (TStorageItem Bool t) (Exp Bool t)
-  | BytesUpdate (TStorageItem ByteString t) (Exp ByteString t)
-  deriving (Show, Eq)
+  = forall a. Typeable a => Update (Sing a) (TStorageItem a t) (Exp a t)
+deriving instance Show (StorageUpdate t)
+
+_Update :: Typeable a => TStorageItem a t -> Exp a t -> StorageUpdate t
+_Update item exp = Update (getType item) item exp
+
+instance Eq (StorageUpdate t) where
+  Update t1 i1 e1 == Update t2 i2 e2 = withSingI2 t1 t2 $ eqS i1 i2 && eqS e1 e2
+  --   IntUpdate (TStorageItem Integer t) (Exp Integer t)
+  -- | BoolUpdate (TStorageItem Bool t) (Exp Bool t)
+  -- | BytesUpdate (TStorageItem ByteString t) (Exp ByteString t)
+--  deriving (Show, Eq)
 
 data StorageLocation t
-  = IntLoc (TStorageItem Integer t)
-  | BoolLoc (TStorageItem Bool t)
-  | BytesLoc (TStorageItem ByteString t)
-  deriving (Show, Eq)
+  = forall a. Loc (Sing a) (TStorageItem a t)
+deriving instance Show (StorageLocation t)
+
+_Loc :: TStorageItem a t -> StorageLocation t
+_Loc item = Loc (getType item) item
+
+instance Eq (StorageLocation t) where
+  Loc t1 i1 == Loc t2 i2 = withSingI2 t1 t2 $ eqS i1 i2
+--deriving instance Eq (StorageLocation t)
+--    IntLoc (TStorageItem Integer t)
+--  | BoolLoc (TStorageItem Bool t)
+--  | BytesLoc (TStorageItem ByteString t)
+--  deriving (Show, Eq)
 
 -- | References to items in storage, either as a map lookup or as a reading of
 -- a simple variable. The third argument is a list of indices; it has entries iff
@@ -152,12 +169,27 @@ data TStorageItem (a :: *) (t :: Timing) where
 deriving instance Show (TStorageItem a t)
 deriving instance Eq (TStorageItem a t)
 
+_Item :: SingI a => Id -> Id -> [TypedExp t] -> TStorageItem a t
+_Item = Item sing
+
+instance HasType (TStorageItem a t) a where
+  getType (Item t _ _ _) = t
+
 -- | Expressions for which the return type is known.
 data TypedExp t
-  = ExpInt   (Exp Integer t)
-  | ExpBool  (Exp Bool t)
-  | ExpBytes (Exp ByteString t)
-  deriving (Eq, Show)
+  = forall a. Typeable a => TExp (Sing a) (Exp a t)
+deriving instance Show (TypedExp t)
+--deriving instance Eq (TypedExp t)
+
+_TExp :: (Typeable a, SingI a) => Exp a t -> TypedExp t
+_TExp = TExp sing
+
+instance Eq (TypedExp t) where
+  TExp t1 e1 == TExp t2 e2 = withSingI2 t1 t2 $ eqS e1 e2
+--    TExp SInteger   (Exp Integer t)
+--  | TExp SBoolean  (Exp Bool t)
+--  | TExp SByteStr (Exp ByteString t)
+--  deriving (Eq, Show)
 
 -- | Expressions parametrized by a timing `t` and a type `a`. `t` can be either `Timed` or `Untimed`.
 -- All storage entries within an `Exp a t` contain a value of type `Time t`.
@@ -165,11 +197,6 @@ data TypedExp t
 -- will refer to either the prestate or the poststate.
 -- In `t ~ Untimed`, the only possible such value is `Neither :: Time Untimed`, so all storage entries
 -- will not explicitly refer any particular state.
-
--- It is recommended that backends always input `Exp Timed a` to their codegens (or `Exp Untimed a`
--- if postconditions and return values are irrelevant), as this makes it easier to generate
--- consistent variable names. `Untimed` expressions can be given a specific timing using `as`,
--- e.g. ``expr `as` Pre``.
 data Exp (a :: *) (t :: Timing) where
   -- booleans
   And  :: Exp Bool t -> Exp Bool t -> Exp Bool t
@@ -263,6 +290,10 @@ instance Eq (Exp a t) where
   Var _ a == Var _ b = a == b
   _ == _ = False
 
+-- We could make this explicit which would remove the need for the SingI instance.
+instance SingI a => HasType (Exp a t) a where
+  getType _ = sing
+
 instance Semigroup (Exp Bool t) where
   a <> b = And a b
 
@@ -270,16 +301,14 @@ instance Monoid (Exp Bool t) where
   mempty = LitBool True
 
 instance Timable StorageLocation where
-  setTime time location = case location of
-    IntLoc item -> IntLoc $ setTime time item
-    BoolLoc item -> BoolLoc $ setTime time item
-    BytesLoc item -> BytesLoc $ setTime time item
+  setTime time (Loc typ item) = Loc typ $ setTime time item
+  --  BoolLoc item -> BoolLoc $ setTime time item
+  --  BytesLoc item -> BytesLoc $ setTime time item
 
 instance Timable TypedExp where
-  setTime time texp = case texp of
-    ExpInt expr -> ExpInt $ setTime time expr
-    ExpBool expr -> ExpBool $ setTime time expr
-    ExpBytes expr -> ExpBytes $ setTime time expr
+  setTime time (TExp typ expr) = TExp typ $ setTime time expr
+    --TExp SBoolean expr -> TExp SBoolean $ setTime time expr
+    --TExp SByteStr expr -> TExp SByteStr $ setTime time expr
 
 instance Timable (Exp a) where
   setTime time expr = case expr of
@@ -387,14 +416,10 @@ instance ToJSON (Rewrite t) where
   toJSON (Rewrite a) = object [ "Rewrite" .= toJSON a ]
 
 instance ToJSON (StorageLocation t) where
-  toJSON (IntLoc a) = object ["location" .= toJSON a]
-  toJSON (BoolLoc a) = object ["location" .= toJSON a]
-  toJSON (BytesLoc a) = object ["location" .= toJSON a]
+  toJSON (Loc _ a) = object ["location" .= toJSON a]
 
 instance ToJSON (StorageUpdate t) where
-  toJSON (IntUpdate a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
-  toJSON (BoolUpdate a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
-  toJSON (BytesUpdate a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
+  toJSON (Update _ a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
 
 instance ToJSON (TStorageItem a t) where
   toJSON (Item SInteger a b []) = object ["sort" .= pack "int"
@@ -413,12 +438,8 @@ mapping c a b = object [  "symbol"   .= pack "lookup"
                        ,  "args"     .= Array (fromList [toJSON c, toJSON a, toJSON b])]
 
 instance ToJSON (TypedExp t) where
-   toJSON (ExpInt a) = object ["sort" .= pack "int"
-                              ,"expression" .= toJSON a]
-   toJSON (ExpBool a) = object ["sort" .= String (pack "bool")
+  toJSON (TExp typ a) = object ["sort"       .= pack (show typ)
                                ,"expression" .= toJSON a]
-   toJSON (ExpBytes a) = object ["sort" .= String (pack "bytestring")
-                                ,"expression" .= toJSON a]
 
 instance Typeable a => ToJSON (Exp a t) where
   toJSON (Add a b) = symbol "+" a b
@@ -522,7 +543,7 @@ uintmax :: Int -> Integer
 uintmax a = 2 ^ a - 1
 
 mkVar :: SingI a => Id -> Exp a t
-mkVar name = withSing $ flip Var name
+mkVar name = Var sing name
 
 castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
 castTime = gcast
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index aa50f17c..213b03b3 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -4,19 +4,25 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts #-}
 
 -- These extensions should be removed once we remove the defs at the end of this file.
-{-# LANGUAGE RankNTypes, TypeApplications, StandaloneKindSignatures, PolyKinds, ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes, TypeApplications, StandaloneKindSignatures, PolyKinds #-}
 
-module Syntax.Types where
+{-|
+Module      : Syntax.Types
+Description : Types that represent Act types, and functions and patterns to go between them and Haskell's own types.
+-}
+
+module Syntax.Types (module Syntax.Types) where
 
 import Data.Singletons
+import Data.Type.Equality (TestEquality(..))
 import Data.Typeable hiding (TypeRep,typeRep)
 import Type.Reflection
 
-import Data.ByteString as Syntax.Types (ByteString)
-import EVM.ABI         as Syntax.Types (AbiType(..))
+import Data.ByteString    as Syntax.Types (ByteString)
+import EVM.ABI            as Syntax.Types (AbiType(..))
 
 -- | Types understood by proving tools.
 data MType
@@ -30,9 +36,30 @@ data SType a where
   SInteger :: SType Integer
   SBoolean :: SType Bool
   SByteStr :: SType ByteString
-deriving instance Show (SType a)
+--deriving instance Show (SType a)
 deriving instance Eq (SType a)
 
+instance Show (SType a) where
+  show = \case
+    SInteger -> "int"
+    SBoolean -> "bool"
+    SByteStr -> "bytestring"
+
+instance TestEquality SType where
+  testEquality t1@STypeable t2@STypeable = eqT
+
+eqS :: forall (a :: *) (b :: *) f t. (SingI a, SingI b, Eq (f a t)) => f a t -> f b t -> Bool
+eqS fa fb = maybe False (\Refl -> fa == fb) $ testEquality (sing @a) (sing @b)
+
+class HasType a t where
+  getType :: a -> SType t
+
+  tag :: a -> (SType t, a)
+  tag a = (getType a, a)
+
+withSingI2 :: Sing a -> Sing b -> ((SingI a, SingI b) => r) -> r
+withSingI2 sa sb r = withSingI sa $ withSingI sb $ r
+
 metaType :: AbiType -> MType
 metaType (AbiUIntType _)     = Integer
 metaType (AbiIntType  _)     = Integer
@@ -46,7 +73,7 @@ metaType AbiStringType       = ByteStr
 --metaType (AbiTupleType        (Vector AbiType)
 metaType _ = error "Syntax.Types.metaType: TODO"
 
--- | For our purposes, the singleton of a type 'a' is always an @'SType' a@.
+-- | For our purposes, the singleton of a type @a@ is always @'SType' a@.
 -- Note that even though there only exist three different 'SType', this does
 -- not mean that the type family is partial. It simply means that the resulting
 -- type is uninhabited if the argument is neither 'Integer', 'Bool' nor
@@ -76,19 +103,20 @@ instance SingKind * where
   toSing Boolean = SomeSing SBoolean
   toSing ByteStr = SomeSing SByteStr
 
--- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType'.
+-- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType' with a 'Typeable'
+-- instance.
 pattern FromAbi :: () => Typeable a => SType a -> AbiType
-pattern FromAbi t <- (metaType -> FromSing t@Typeable)
+pattern FromAbi t <- (metaType -> FromSing t@STypeable)
 {-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
 
--- | Pattern match on an 'MType' is if it were an 'SType'.
+-- | Pattern match on an 'MType' is if it were an 'SType' with a 'Typeable' instance.
 pattern FromMeta :: () => Typeable a => SType a -> MType
-pattern FromMeta t <- FromSing t@Typeable
+pattern FromMeta t <- FromSing t@STypeable
 {-# COMPLETE FromMeta #-} -- We promise that the pattern covers all cases of MType.
 
 -- | Helper pattern to retrieve the 'Typeable' instance of an 'SType'.
-pattern Typeable :: () => Typeable a => SType a
-pattern Typeable <- (stypeRep -> TypeRep)
+pattern STypeable :: () => Typeable a => SType a
+pattern STypeable <- (stypeRep -> TypeRep)
 
 -- | Allows us to retrieve the 'TypeRep' of any 'SType', which in turn can be used
 -- to retrieve the 'Typeable' instance.
diff --git a/src/Type.hs b/src/Type.hs
index d70e0335..4a1b58a5 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -187,18 +187,10 @@ noStorageRead store expr = for_ (keys store) $ \name ->
   for_ (findWithDefault [] name (idFromRewrites expr)) $ \pn ->
     throw (pn,"Cannot read storage in creates block")
 
--- | Creates a correctly typed 'StorageUpdate' given correctly typed components.
-makeUpdate :: Env -> Sing a -> Id -> [TypedExp Untimed] -> Exp a Untimed -> StorageUpdate
-makeUpdate Env{contract} typ name ixs newVal = let item = Item typ contract name ixs in
-  case typ of
-    SInteger -> IntUpdate   item newVal
-    SBoolean -> BoolUpdate  item newVal
-    SByteStr -> BytesUpdate item newVal
-
 -- ensures that key types match value types in an U.Assign
 checkAssign :: Env -> U.Assign -> Err [StorageUpdate]
-checkAssign env@Env{store} (U.AssignVal (U.StorageVar _ (StorageValue (FromAbi typ)) name) expr)
-  = sequenceA [makeUpdate env typ name [] <$> inferExpr env expr]
+checkAssign env@Env{contract,store} (U.AssignVal (U.StorageVar _ (StorageValue (FromAbi typ)) name) expr)
+  = sequenceA [_Update (Item typ contract name []) <$> inferExpr env expr]
     <* noStorageRead store expr
 checkAssign env@Env{store} (U.AssignMany (U.StorageVar _ (StorageMapping (keyType :| _) valType) name) defns)
   = for defns $ \def@(U.Defn e1 e2) -> checkDefn env keyType valType name def
@@ -213,8 +205,10 @@ checkAssign _ _ = error "todo: support struct assignment in constructors"
 -- ensures key and value types match when assigning a defn to a mapping
 -- TODO: handle nested mappings
 checkDefn :: Env -> AbiType -> AbiType -> Id -> U.Defn -> Err StorageUpdate
-checkDefn env keyType (FromAbi valType) name (U.Defn k val) =
-  makeUpdate env valType name <$> checkIxs env (getPosn k) [k] [keyType] <*> inferExpr env val
+checkDefn env@Env{contract} keyType (FromAbi valType) name (U.Defn k val) =
+  _Update
+  <$> (Item valType contract name <$> checkIxs env (getPosn k) [k] [keyType])
+  <*> inferExpr env val
 
 -- | Typechecks a postcondition, returning typed versions of its storage updates and return expression.
 checkPost :: Env -> U.Post -> Err ([Rewrite], Maybe (TypedExp Timed))
@@ -269,11 +263,13 @@ checkPost env@Env{contract,calldata} (U.Post storage extStorage maybeReturn) = d
 -- | Typechecks a non-constant rewrite.
 checkStorageExpr :: Env -> U.Pattern -> U.Expr -> Err StorageUpdate
 checkStorageExpr _ (U.PWild _) _ = error "TODO: add support for wild storage to checkStorageExpr"
-checkStorageExpr env@Env{store} (U.PEntry p name args) expr = case Map.lookup name store of
+checkStorageExpr env@Env{contract,store} (U.PEntry p name args) expr = case Map.lookup name store of
   Just (StorageValue (FromAbi typ)) ->
-    makeUpdate env typ name [] <$> inferExpr env expr
+    _Update (Item typ contract name []) <$> inferExpr env expr
   Just (StorageMapping argtyps (FromAbi valType)) ->
-    makeUpdate env valType name <$> checkIxs env p args (NonEmpty.toList argtyps) <*> inferExpr env expr
+    _Update
+    <$> (Item valType contract name <$> checkIxs env p args (NonEmpty.toList argtyps))
+    <*> inferExpr env expr
   Nothing ->
     throw (p, "Unknown storage variable " <> show name)
 
@@ -288,11 +284,11 @@ checkPattern env@Env{contract,store} (U.PEntry p name args) =
   where
     makeLocation :: AbiType -> [AbiType] -> Err StorageLocation
     makeLocation (FromAbi locType) argTypes =
-      let item = Item locType contract name <$> checkIxs @Untimed env p args argTypes
-      in case locType of
-        SInteger -> IntLoc   <$> item
-        SBoolean -> BoolLoc  <$> item
-        SByteStr -> BytesLoc <$> item
+      --let item = 
+      --in 
+      _Loc . Item locType contract name <$> checkIxs @Untimed env p args argTypes
+      --  SBoolean -> BoolLoc  <$> item
+      --  SByteStr -> BytesLoc <$> item
 
 checkIffs :: Env -> [U.IffH] -> Err [Exp Bool Untimed]
 checkIffs env = foldr check (pure [])
@@ -319,19 +315,21 @@ upperBound typ  = error $ "upperBound not implemented for " ++ show typ
 -- | Attempt to construct a `TypedExp` whose type matches the supplied `AbiType`.
 -- The target timing parameter will be whatever is required by the caller.
 checkExpr :: Typeable t => Env -> U.Expr -> AbiType -> Err (TypedExp t)
-checkExpr env e typ = case metaType typ of
-  Integer -> ExpInt   <$> inferExpr env e
-  Boolean -> ExpBool  <$> inferExpr env e
-  ByteStr -> ExpBytes <$> inferExpr env e
+checkExpr env e (FromAbi typ) = TExp typ <$> inferExpr env e
+  -- case metaType typ of
+  -- Integer -> TExp SInteger   <$> inferExpr env e
+  -- Boolean -> TExp SBoolean  <$> inferExpr env e
+  -- ByteStr -> TExp SByteStr <$> inferExpr env e
 
 -- | Attempt to typecheck an untyped expression as any possible type.
 typedExp :: Typeable t => Env -> U.Expr -> Err (TypedExp t)
 typedExp env e = notAtPosn (getPosn e)
-    $ A (ExpInt   <$> inferExpr env e)
-  <!> A (ExpBool  <$> inferExpr env e)
-  <!> A (ExpBytes <$> inferExpr env e)
+    $ A (TExp SInteger <$> inferExpr env e)
+  <!> A (TExp SBoolean <$> inferExpr env e)
+  <!> A (TExp SByteStr <$> inferExpr env e)
   <!> error "Internal error: typedExp" -- should never happen since e's constructor can always be given a type
                                        -- (even though its children may not fit into that)
+                                       -- but this error is more informative than "expected ByteStr, got X"
 
 -- | Attempts to construct an expression with the type and timing required by
 -- the caller. If this is impossible, an error is thrown instead.
diff --git a/src/test/Test.hs b/src/test/Test.hs
index 98174eff..f2d755e4 100644
--- a/src/test/Test.hs
+++ b/src/test/Test.hs
@@ -4,7 +4,6 @@
 
 module Main where
 
-import EVM.ABI (AbiType(..))
 import Test.Tasty
 import Test.Tasty.QuickCheck (Gen, arbitrary, testProperty, Property, (===), property)
 import Test.QuickCheck.Instances.ByteString()
@@ -15,7 +14,6 @@ import Text.PrettyPrint.ANSI.Leijen (pretty)
 import Control.Monad
 import Control.Monad.Trans
 import Control.Monad.Reader
-import Data.ByteString (ByteString)
 import Data.Maybe (isNothing)
 import qualified Data.Set as Set
 import qualified Data.Map as Map (empty)
@@ -148,9 +146,9 @@ genType typ = case typ of
 
 genTypedExp :: Names -> Int -> ExpoGen TypedExp
 genTypedExp names n = oneof
-  [ ExpInt <$> genExpInt names n
-  , ExpBool <$> genExpBool names n
-  , ExpBytes <$> genExpBytes names n
+  [ TExp SInteger <$> genExpInt names n
+  , TExp SBoolean <$> genExpBool names n
+  , TExp SByteStr <$> genExpBytes names n
   ]
 
 

From 3673272bb458698e980658dbb37cf74f3618d5be Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sat, 2 Oct 2021 16:16:08 +0200
Subject: [PATCH 20/36] fix CI build errors

---
 src/Coq.hs                 |  4 ++--
 src/Enrich.hs              |  1 -
 src/HEVM.hs                | 10 ++++------
 src/K.hs                   |  2 +-
 src/Print.hs               |  2 +-
 src/SMT.hs                 |  4 ++--
 src/Syntax/TimeAgnostic.hs |  4 +---
 src/Syntax/Types.hs        |  7 ++++---
 src/Type.hs                |  3 ---
 9 files changed, 15 insertions(+), 22 deletions(-)

diff --git a/src/Coq.hs b/src/Coq.hs
index 77735b0a..a5b27d57 100644
--- a/src/Coq.hs
+++ b/src/Coq.hs
@@ -162,8 +162,8 @@ stateval store handler updates = T.unwords $ stateConstructor : fmap (valuefor u
   valuefor updates' (name, t) =
     case find (eqName name) updates' of
       Nothing -> parens $ handler name t
-      Just (Update SByteStr item e) -> error "bytestrings not supported"
-      Just (Update t item e) -> lambda (ixsFromItem item) 0 e (idFromItem item)
+      Just (Update SByteStr _ _) -> error "bytestrings not supported"
+      Just (Update _ item e) -> lambda (ixsFromItem item) 0 e (idFromItem item)
 
 -- | filter by name
 eqName :: Id -> StorageUpdate -> Bool
diff --git a/src/Enrich.hs b/src/Enrich.hs
index 05a845a3..6c0475e7 100644
--- a/src/Enrich.hs
+++ b/src/Enrich.hs
@@ -7,7 +7,6 @@ import Data.Maybe
 import Data.List (nub)
 import qualified Data.Map.Strict as Map (lookup)
 
-import EVM.ABI (AbiType(..))
 import EVM.Solidity (SlotType(..))
 
 import Syntax
diff --git a/src/HEVM.hs b/src/HEVM.hs
index bf953b6b..09a54b65 100644
--- a/src/HEVM.hs
+++ b/src/HEVM.hs
@@ -13,7 +13,6 @@ import Prelude hiding (lookup)
 import Syntax
 import Syntax.Annotated as Annotated hiding (S)
 
-import Data.ByteString (ByteString)
 import Data.ByteString.UTF8 (toString)
 import Data.Text (Text, pack, splitOn)
 import Data.Maybe
@@ -308,11 +307,10 @@ type Storage = Map Id (SMType, SMType)
 type Env = Map Id SMType
 
 symExp :: Ctx -> TypedExp -> SMType
-symExp ctx ret = case ret of
-  TExp SInteger e -> SymInteger $ symExpInt ctx e -- TODO rest
---  TExp SInteger e -> SymInteger $ symExpInt ctx e
---  TExp SBoolean e -> SymBool $ symExpBool ctx e
---  TExp SByteStr e -> SymBytes $ symExpBytes ctx e
+symExp ctx (TExp t e) = case t of
+  SInteger -> SymInteger $ symExpInt ctx e
+  SBoolean -> SymBool    $ symExpBool ctx e
+  SByteStr -> SymBytes   $ symExpBytes ctx e
 
 symExpBool :: Ctx -> Exp Bool -> SBV Bool
 symExpBool ctx@(Ctx c m args store _) e = case e of
diff --git a/src/K.hs b/src/K.hs
index d6afc484..01e0f186 100644
--- a/src/K.hs
+++ b/src/K.hs
@@ -18,7 +18,7 @@ import Data.Text (Text, pack, unpack)
 import Data.Typeable
 import Data.List hiding (group)
 import Data.Maybe
-import Data.ByteString hiding (group, pack, unpack, intercalate, filter, foldr, concat, head, tail, null)
+-- import Data.ByteString hiding (group, pack, unpack, intercalate, filter, foldr, concat, head, tail, null)
 import qualified Data.Text as Text
 import Parse
 import EVM.Types hiding (Whiff(..))
diff --git a/src/Print.hs b/src/Print.hs
index 2eeff033..421925c9 100644
--- a/src/Print.hs
+++ b/src/Print.hs
@@ -85,7 +85,7 @@ prettyExp e = case e of
     print2 sym a b = "(" <> prettyExp a <> " " <> sym <> " " <> prettyExp b <> ")"
 
 prettyTypedExp :: TypedExp t -> String
-prettyTypedExp (TExp t e) = prettyExp e
+prettyTypedExp (TExp _ e) = prettyExp e
 --  TExp SBoolean e' -> prettyExp e'
 --  TExp SByteStr e' -> prettyExp e'
 
diff --git a/src/SMT.hs b/src/SMT.hs
index 91003b99..dce59c10 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -517,10 +517,10 @@ parseSMTModel s = if length s0Caps == 1
 
 -- | encodes a storage update from a constructor creates block as an smt assertion
 encodeInitialStorage :: Id -> StorageUpdate -> SMT2
-encodeInitialStorage behvName (Update _ item exp) =
+encodeInitialStorage behvName (Update _ item expr) =
   let
     postentry  = withInterface behvName $ expToSMT2 (TEntry Post item)
-    expression = withInterface behvName $ expToSMT2 exp
+    expression = withInterface behvName $ expToSMT2 expr
   in "(assert (= " <> postentry <> " " <> expression <> "))"
 
 -- | declares a storage location that is created by the constructor, these
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 38504f22..d4748b44 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -48,8 +48,6 @@ import Syntax.Types   as Syntax.TimeAgnostic
 import Syntax.Timing  as Syntax.TimeAgnostic
 import Syntax.Untyped as Syntax.TimeAgnostic (Id, Interface(..), EthEnv(..), Decl(..))
 
-import GHC.Records
-
 -- AST post typechecking
 data Claim t
   = C (Constructor t)
@@ -133,7 +131,7 @@ data StorageUpdate t
 deriving instance Show (StorageUpdate t)
 
 _Update :: Typeable a => TStorageItem a t -> Exp a t -> StorageUpdate t
-_Update item exp = Update (getType item) item exp
+_Update item expr = Update (getType item) item expr
 
 instance Eq (StorageUpdate t) where
   Update t1 i1 e1 == Update t2 i2 e2 = withSingI2 t1 t2 $ eqS i1 i2 && eqS e1 e2
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index 213b03b3..022ace85 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -46,7 +46,7 @@ instance Show (SType a) where
     SByteStr -> "bytestring"
 
 instance TestEquality SType where
-  testEquality t1@STypeable t2@STypeable = eqT
+  testEquality STypeable STypeable = eqT
 
 eqS :: forall (a :: *) (b :: *) f t. (SingI a, SingI b, Eq (f a t)) => f a t -> f b t -> Bool
 eqS fa fb = maybe False (\Refl -> fa == fb) $ testEquality (sing @a) (sing @b)
@@ -112,11 +112,12 @@ pattern FromAbi t <- (metaType -> FromSing t@STypeable)
 -- | Pattern match on an 'MType' is if it were an 'SType' with a 'Typeable' instance.
 pattern FromMeta :: () => Typeable a => SType a -> MType
 pattern FromMeta t <- FromSing t@STypeable
-{-# COMPLETE FromMeta #-} -- We promise that the pattern covers all cases of MType.
+{-# COMPLETE FromMeta #-}
 
 -- | Helper pattern to retrieve the 'Typeable' instance of an 'SType'.
 pattern STypeable :: () => Typeable a => SType a
 pattern STypeable <- (stypeRep -> TypeRep)
+{-# COMPLETE STypeable #-}
 
 -- | Allows us to retrieve the 'TypeRep' of any 'SType', which in turn can be used
 -- to retrieve the 'Typeable' instance.
@@ -127,7 +128,7 @@ stypeRep = \case
   SByteStr -> typeRep
 
 -- Everything below will be added to base 4.17 but for now we need it here.
--- See https://gitlab.haskell.org/ghc/ghc/-/blob/master/libraries/base/Data/Typeable/Internal.hs#L264
+-- See https://gitlab.haskell.org/ghc/ghc/-/commit/d3ef2dc2bdfec457d5e0973f3e8f3e92767c16af#786588e27bcbc2a8360d2d0d3b2ce1d075797ffb_232_263
 
 -- | A 'TypeableInstance' wraps up a 'Typeable' instance for explicit
 -- handling. For internal use: for defining 'TypeRep' pattern.
diff --git a/src/Type.hs b/src/Type.hs
index 4a1b58a5..22cd94da 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -16,12 +16,9 @@ import Data.Maybe
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map.Strict    as Map -- abandon in favor of [(a,b)]?
-import Data.Singletons
 import Data.Typeable hiding (typeRep)
 import Type.Reflection (typeRep)
 
-import Data.ByteString (ByteString)
-
 import Control.Lens.Operators ((??))
 import Control.Monad.Writer
 import Data.List.Extra (snoc,unsnoc)

From c5e1a0ae0774e417e9c8a0ad49617fa00f2a9c96 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sat, 2 Oct 2021 16:59:39 +0200
Subject: [PATCH 21/36] cleanup

---
 src/Coq.hs                 | 15 ++++++------
 src/Enrich.hs              |  2 +-
 src/HEVM.hs                |  7 ++----
 src/Print.hs               |  2 --
 src/SMT.hs                 | 11 +++------
 src/Syntax.hs              | 49 --------------------------------------
 src/Syntax/TimeAgnostic.hs | 25 +++++++------------
 src/Syntax/Types.hs        | 11 +++------
 src/Type.hs                |  8 -------
 9 files changed, 24 insertions(+), 106 deletions(-)

diff --git a/src/Coq.hs b/src/Coq.hs
index a5b27d57..48f19f11 100644
--- a/src/Coq.hs
+++ b/src/Coq.hs
@@ -172,16 +172,17 @@ eqName n update = n == idFromUpdate update
 -- represent mapping update with anonymous function
 lambda :: [TypedExp] -> Int -> Exp a -> Id -> T.Text
 lambda [] _ e _ = parens $ coqexp e
-lambda (x:xs) n e m = parens $
+lambda (TExp argType arg:xs) n e m = parens $
   "fun " <> name <> " =>"
-  <> " if " <> name <> eqsym x <> typedexp x
+  <> " if " <> name <> eqsym <> coqexp arg
   <> " then " <> lambda xs (n + 1) e m
   <> " else " <> T.pack m <> " " <> stateVar <> " " <> lambdaArgs n where
   name = anon <> T.pack (show n)
   lambdaArgs i = T.unwords $ map (\a -> anon <> T.pack (show a)) [0..i]
-  eqsym (TExp SInteger _) = undefined -- T.pack " =? "
-  eqsym (TExp SBoolean _) = undefined -- T.pack " =?? "
-  eqsym (TExp SByteStr _) = error "bytestrings not supported"
+  eqsym = case argType of
+    SInteger -> " =? "
+    SBoolean -> " =?? "
+    SByteStr -> error "bytestrings not supported"
 
 -- | produce a block of declarations from an interface
 interface :: Interface -> T.Text
@@ -299,9 +300,7 @@ coqprop _ = error "ill formed proposition"
 
 -- | coq syntax for a typed expression
 typedexp :: TypedExp -> T.Text
-typedexp (TExp SInteger e)   = coqexp e
-typedexp (TExp SBoolean e)  = coqexp e
-typedexp (TExp SByteStr _) = error "bytestrings not supported"
+typedexp (TExp _ e) = coqexp e
 
 entry :: TStorageItem a -> When -> T.Text
 entry (Item SByteStr _ _ _) _    = error "bytestrings not supported"
diff --git a/src/Enrich.hs b/src/Enrich.hs
index 6c0475e7..4cffd450 100644
--- a/src/Enrich.hs
+++ b/src/Enrich.hs
@@ -104,5 +104,5 @@ mkStorageBounds store refs = catMaybes $ mkBound <$> refs
 
 mkCallDataBounds :: [Decl] -> [Exp Bool t]
 mkCallDataBounds = concatMap $ \(Decl typ name) -> case metaType typ of
-  Integer -> [bound typ (mkVar name)]
+  Integer -> [bound typ (_Var name)]
   _ -> []
diff --git a/src/HEVM.hs b/src/HEVM.hs
index 09a54b65..5a7f69b7 100644
--- a/src/HEVM.hs
+++ b/src/HEVM.hs
@@ -308,8 +308,8 @@ type Env = Map Id SMType
 
 symExp :: Ctx -> TypedExp -> SMType
 symExp ctx (TExp t e) = case t of
-  SInteger -> SymInteger $ symExpInt ctx e
-  SBoolean -> SymBool    $ symExpBool ctx e
+  SInteger -> SymInteger $ symExpInt   ctx e
+  SBoolean -> SymBool    $ symExpBool  ctx e
   SByteStr -> SymBytes   $ symExpBytes ctx e
 
 symExpBool :: Ctx -> Exp Bool -> SBV Bool
@@ -376,9 +376,6 @@ nameFromItem method (Item _ c name ixs) = c @@ method @@ name <> showIxs
 nameFromTypedExp :: ContractName -> Method -> TypedExp -> Id
 nameFromTypedExp c method e = case e of
   TExp _ e' -> nameFromExp c method e'
---  TExp SInteger e' -> nameFromExp c method e'
---  TExp SBoolean e' -> nameFromExp c method e'
---  TExp SByteStr e' -> nameFromExp c method e'
 
 nameFromExp :: ContractName -> Method -> Exp a -> Id
 nameFromExp c m e = case e of
diff --git a/src/Print.hs b/src/Print.hs
index 421925c9..b497d9b2 100644
--- a/src/Print.hs
+++ b/src/Print.hs
@@ -86,8 +86,6 @@ prettyExp e = case e of
 
 prettyTypedExp :: TypedExp t -> String
 prettyTypedExp (TExp _ e) = prettyExp e
---  TExp SBoolean e' -> prettyExp e'
---  TExp SByteStr e' -> prettyExp e'
 
 prettyItem :: TStorageItem a t -> String
 prettyItem item = contractFromItem item <> "." <> idFromItem item <> concatMap (brackets . prettyTypedExp) (ixsFromItem item)
diff --git a/src/SMT.hs b/src/SMT.hs
index dce59c10..96d68d14 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -38,6 +38,7 @@ import Data.Maybe
 import Data.List
 import GHC.IO.Handle (Handle, hGetLine, hPutStr, hFlush)
 import Data.ByteString.UTF8 (fromString)
+import Data.Singletons (fromSing)
 
 import Syntax
 import Syntax.Annotated
@@ -555,10 +556,7 @@ declareEthEnv env = constant (prettyEnv env) tp
 
 -- | encodes a typed expression as an smt2 expression
 typedExpToSMT2 :: TypedExp -> Ctx SMT2
-typedExpToSMT2 re = case re of
-  TExp SInteger ei -> expToSMT2 ei
-  TExp SBoolean eb -> expToSMT2 eb
-  TExp SByteStr ebs -> expToSMT2 ebs
+typedExpToSMT2 (TExp _ e) = expToSMT2 e
 
 -- | encodes the given Exp as an smt2 expression
 expToSMT2 :: Exp a -> Ctx SMT2
@@ -663,10 +661,7 @@ sType ByteStr = "String"
 
 -- | act -> smt2 type translation
 sType' :: TypedExp -> SMT2
-sType' (TExp SInteger _) = "Int"
-sType' (TExp SBoolean _) = "Bool"
-sType' (TExp SByteStr _) = "String"
-
+sType' (TExp t _) = sType . fromSing $ t
 
 --- ** Variable Names ** ---
 
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 8d851b2f..f382fb62 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -59,33 +59,21 @@ locsFromRewrite :: Rewrite t -> [StorageLocation t]
 locsFromRewrite update = nub $ case update of
   Constant loc -> [loc]
   Rewrite (Update _ item e) -> locsFromItem item <> locsFromExp e
---  Rewrite (BoolUpdate  item e) -> locsFromItem item <> locsFromExp e
---  Rewrite (BytesUpdate item e) -> locsFromItem item <> locsFromExp e
 
 locFromRewrite :: Rewrite t -> StorageLocation t
 locFromRewrite = onRewrite id locFromUpdate
 
 locFromUpdate :: StorageUpdate t -> StorageLocation t
 locFromUpdate (Update typ item _) = Loc typ item
---locFromUpdate (IntUpdate   item _) = IntLoc item
---locFromUpdate (BoolUpdate  item _) = BoolLoc item
---locFromUpdate (BytesUpdate item _) = BytesLoc item
 
 locsFromItem :: TStorageItem a t -> [StorageLocation t]
 locsFromItem item@(Item typ _ _ ixs) = Loc typ item : ixLocs ixs
---case typ of
---  SInteger -> IntLoc   item : ixLocs ixs
---  SBoolean -> BoolLoc  item : ixLocs ixs
---  SByteStr -> BytesLoc item : ixLocs ixs
   where
     ixLocs :: [TypedExp t] -> [StorageLocation t]
     ixLocs = concatMap locsFromTypedExp
 
 locsFromTypedExp :: TypedExp t -> [StorageLocation t]
 locsFromTypedExp (TExp _ e) = locsFromExp e
---locsFromTypedExp (TExp SInteger e) = locsFromExp e
---locsFromTypedExp (TExp SBoolean e) = locsFromExp e
---locsFromTypedExp (TExp SByteStr e) = locsFromExp e
 
 locsFromExp :: Exp a t -> [StorageLocation t]
 locsFromExp = nub . go
@@ -110,7 +98,6 @@ locsFromExp = nub . go
       Exp a b   -> go a <> go b
       Cat a b   -> go a <> go b
       Slice a b c -> go a <> go b <> go c
-      --ByVar _ -> []
       ByStr _ -> []
       ByLit _ -> []
       LitInt _  -> []
@@ -118,9 +105,7 @@ locsFromExp = nub . go
       IntMax _  -> []
       UIntMin _ -> []
       UIntMax _ -> []
-      --IntVar _  -> []
       LitBool _ -> []
-      --BoolVar _ -> []
       NewAddr a b -> go a <> go b
       IntEnv _ -> []
       ByEnv _ -> []
@@ -145,22 +130,13 @@ ethEnvFromConstructor (Constructor _ _ _ pre post initialStorage rewrites) = nub
 ethEnvFromRewrite :: Rewrite t -> [EthEnv]
 ethEnvFromRewrite rewrite = case rewrite of
   Constant (Loc _ item) -> ethEnvFromItem item
---  Constant (IntLoc item) -> ethEnvFromItem item
---  Constant (BoolLoc item) -> ethEnvFromItem item
---  Constant (BytesLoc item) -> ethEnvFromItem item
   Rewrite (Update _ item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
---  Rewrite (IntUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
---  Rewrite (BoolUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
---  Rewrite (BytesUpdate item e) -> nub $ ethEnvFromItem item <> ethEnvFromExp e
 
 ethEnvFromItem :: TStorageItem a t -> [EthEnv]
 ethEnvFromItem = nub . concatMap ethEnvFromTypedExp . ixsFromItem
 
 ethEnvFromTypedExp :: TypedExp t -> [EthEnv]
 ethEnvFromTypedExp (TExp _ e) = ethEnvFromExp e
---ethEnvFromTypedExp (TExp SInteger e) = ethEnvFromExp e
---ethEnvFromTypedExp (TExp SBoolean e) = ethEnvFromExp e
---ethEnvFromTypedExp (TExp SByteStr e) = ethEnvFromExp e
 
 ethEnvFromExp :: Exp a t -> [EthEnv]
 ethEnvFromExp = nub . go
@@ -186,13 +162,10 @@ ethEnvFromExp = nub . go
       Cat a b   -> go a <> go b
       Slice a b c -> go a <> go b <> go c
       ITE a b c -> go a <> go b <> go c
-      --ByVar _ -> []
       ByStr _ -> []
       ByLit _ -> []
       LitInt _  -> []
-      --IntVar _  -> []
       LitBool _ -> []
-      --BoolVar _ -> []
       IntMin _ -> []
       IntMax _ -> []
       UIntMin _ -> []
@@ -211,55 +184,33 @@ idFromItem (Item _ _ name _) = name
 
 idFromUpdate :: StorageUpdate t -> Id
 idFromUpdate (Update _ item _) = idFromItem item
--- idFromUpdate (IntUpdate   item _) = idFromItem item
--- idFromUpdate (BoolUpdate  item _) = idFromItem item
--- idFromUpdate (BytesUpdate item _) = idFromItem item
 
 idFromLocation :: StorageLocation t -> Id
 idFromLocation (Loc _ item) = idFromItem item
---idFromLocation (IntLoc   item) = idFromItem item
---idFromLocation (BoolLoc  item) = idFromItem item
---idFromLocation (BytesLoc item) = idFromItem item
 
 contractFromRewrite :: Rewrite t -> Id
 contractFromRewrite = onRewrite contractFromLoc contractFromUpdate
 
 contractFromItem :: TStorageItem a t -> Id
 contractFromItem (Item _ c _ _) = c
---contractFromItem (BoolItem  c _ _) = c
---contractFromItem (BytesItem c _ _) = c
 
 ixsFromItem :: TStorageItem a t -> [TypedExp t]
 ixsFromItem (Item _ _ _ ixs) = ixs
---ixsFromItem (BoolItem  _ _ ixs) = ixs
---ixsFromItem (BytesItem _ _ ixs) = ixs
 
 contractsInvolved :: Behaviour t -> [Id]
 contractsInvolved = fmap contractFromRewrite . _stateUpdates
 
 contractFromLoc :: StorageLocation t -> Id
 contractFromLoc (Loc _ item) = contractFromItem item
--- contractFromLoc (IntLoc   item) = contractFromItem item
--- contractFromLoc (BoolLoc  item) = contractFromItem item
--- contractFromLoc (BytesLoc item) = contractFromItem item
 
 contractFromUpdate :: StorageUpdate t -> Id
 contractFromUpdate (Update _ item _) = contractFromItem item
--- contractFromUpdate (IntUpdate   item _) = contractFromItem item
--- contractFromUpdate (BoolUpdate  item _) = contractFromItem item
--- contractFromUpdate (BytesUpdate item _) = contractFromItem item
 
 ixsFromLocation :: StorageLocation t -> [TypedExp t]
 ixsFromLocation (Loc _ item) = ixsFromItem item
--- ixsFromLocation (IntLoc item) = ixsFromItem item
--- ixsFromLocation (BoolLoc item) = ixsFromItem item
--- ixsFromLocation (BytesLoc item) = ixsFromItem item
 
 ixsFromUpdate :: StorageUpdate t -> [TypedExp t]
 ixsFromUpdate (Update _ item _) = ixsFromItem item
--- ixsFromUpdate (IntUpdate   item _) = ixsFromItem item
--- ixsFromUpdate (BoolUpdate  item _) = ixsFromItem item
--- ixsFromUpdate (BytesUpdate item _) = ixsFromItem item
 
 ixsFromRewrite :: Rewrite t -> [TypedExp t]
 ixsFromRewrite = onRewrite ixsFromLocation ixsFromUpdate
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index d4748b44..e4da6022 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -134,11 +134,7 @@ _Update :: Typeable a => TStorageItem a t -> Exp a t -> StorageUpdate t
 _Update item expr = Update (getType item) item expr
 
 instance Eq (StorageUpdate t) where
-  Update t1 i1 e1 == Update t2 i2 e2 = withSingI2 t1 t2 $ eqS i1 i2 && eqS e1 e2
-  --   IntUpdate (TStorageItem Integer t) (Exp Integer t)
-  -- | BoolUpdate (TStorageItem Bool t) (Exp Bool t)
-  -- | BytesUpdate (TStorageItem ByteString t) (Exp ByteString t)
---  deriving (Show, Eq)
+  Update Sing i1 e1 == Update Sing i2 e2 = eqS i1 i2 && eqS e1 e2
 
 data StorageLocation t
   = forall a. Loc (Sing a) (TStorageItem a t)
@@ -148,7 +144,7 @@ _Loc :: TStorageItem a t -> StorageLocation t
 _Loc item = Loc (getType item) item
 
 instance Eq (StorageLocation t) where
-  Loc t1 i1 == Loc t2 i2 = withSingI2 t1 t2 $ eqS i1 i2
+  Loc Sing i1 == Loc Sing i2 = eqS i1 i2
 --deriving instance Eq (StorageLocation t)
 --    IntLoc (TStorageItem Integer t)
 --  | BoolLoc (TStorageItem Bool t)
@@ -179,11 +175,13 @@ data TypedExp t
 deriving instance Show (TypedExp t)
 --deriving instance Eq (TypedExp t)
 
+-- We could remove the 'SingI' constraint here if we also removed it from the
+-- 'HasType' instance for 'Exp'. But it's tedious and noisy and atm unnecessary.
 _TExp :: (Typeable a, SingI a) => Exp a t -> TypedExp t
-_TExp = TExp sing
+_TExp expr = undefined -- TExp (getType expr) expr
 
 instance Eq (TypedExp t) where
-  TExp t1 e1 == TExp t2 e2 = withSingI2 t1 t2 $ eqS e1 e2
+  TExp Sing e1 == TExp Sing e2 = eqS e1 e2
 --    TExp SInteger   (Exp Integer t)
 --  | TExp SBoolean  (Exp Bool t)
 --  | TExp SByteStr (Exp ByteString t)
@@ -300,13 +298,9 @@ instance Monoid (Exp Bool t) where
 
 instance Timable StorageLocation where
   setTime time (Loc typ item) = Loc typ $ setTime time item
-  --  BoolLoc item -> BoolLoc $ setTime time item
-  --  BytesLoc item -> BytesLoc $ setTime time item
 
 instance Timable TypedExp where
   setTime time (TExp typ expr) = TExp typ $ setTime time expr
-    --TExp SBoolean expr -> TExp SBoolean $ setTime time expr
-    --TExp SByteStr expr -> TExp SByteStr $ setTime time expr
 
 instance Timable (Exp a) where
   setTime time expr = case expr of
@@ -320,7 +314,6 @@ instance Timable (Exp a) where
     GEQ x y -> GEQ (go x) (go y)
     GE x y -> GE (go x) (go y)
     LitBool x -> LitBool x
-    --BoolVar x -> BoolVar x
     -- integers
     Add x y -> Add (go x) (go y)
     Sub x y -> Sub (go x) (go y)
@@ -329,7 +322,6 @@ instance Timable (Exp a) where
     Mod x y -> Mod (go x) (go y)
     Exp x y -> Exp (go x) (go y)
     LitInt x -> LitInt x
-    --IntVar x -> IntVar x
     IntEnv x -> IntEnv x
     -- bounds
     IntMin x -> IntMin x
@@ -339,7 +331,6 @@ instance Timable (Exp a) where
     -- bytestrings
     Cat x y -> Cat (go x) (go y)
     Slice x y z -> Slice (go x) (go y) (go z)
-    --ByVar x -> ByVar x
     ByStr x -> ByStr x
     ByLit x -> ByLit x
     ByEnv x -> ByEnv x
@@ -540,8 +531,8 @@ uintmin _ = 0
 uintmax :: Int -> Integer
 uintmax a = 2 ^ a - 1
 
-mkVar :: SingI a => Id -> Exp a t
-mkVar name = Var sing name
+_Var :: SingI a => Id -> Exp a t
+_Var name = Var sing name
 
 castTime :: (Typeable t, Typeable u) => Exp a u -> Maybe (Exp a t)
 castTime = gcast
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index 022ace85..85528495 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -4,7 +4,9 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
 
 -- These extensions should be removed once we remove the defs at the end of this file.
 {-# LANGUAGE RankNTypes, TypeApplications, StandaloneKindSignatures, PolyKinds #-}
@@ -36,7 +38,6 @@ data SType a where
   SInteger :: SType Integer
   SBoolean :: SType Bool
   SByteStr :: SType ByteString
---deriving instance Show (SType a)
 deriving instance Eq (SType a)
 
 instance Show (SType a) where
@@ -54,12 +55,6 @@ eqS fa fb = maybe False (\Refl -> fa == fb) $ testEquality (sing @a) (sing @b)
 class HasType a t where
   getType :: a -> SType t
 
-  tag :: a -> (SType t, a)
-  tag a = (getType a, a)
-
-withSingI2 :: Sing a -> Sing b -> ((SingI a, SingI b) => r) -> r
-withSingI2 sa sb r = withSingI sa $ withSingI sb $ r
-
 metaType :: AbiType -> MType
 metaType (AbiUIntType _)     = Integer
 metaType (AbiIntType  _)     = Integer
diff --git a/src/Type.hs b/src/Type.hs
index 22cd94da..633ab102 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -281,11 +281,7 @@ checkPattern env@Env{contract,store} (U.PEntry p name args) =
   where
     makeLocation :: AbiType -> [AbiType] -> Err StorageLocation
     makeLocation (FromAbi locType) argTypes =
-      --let item = 
-      --in 
       _Loc . Item locType contract name <$> checkIxs @Untimed env p args argTypes
-      --  SBoolean -> BoolLoc  <$> item
-      --  SByteStr -> BytesLoc <$> item
 
 checkIffs :: Env -> [U.IffH] -> Err [Exp Bool Untimed]
 checkIffs env = foldr check (pure [])
@@ -313,10 +309,6 @@ upperBound typ  = error $ "upperBound not implemented for " ++ show typ
 -- The target timing parameter will be whatever is required by the caller.
 checkExpr :: Typeable t => Env -> U.Expr -> AbiType -> Err (TypedExp t)
 checkExpr env e (FromAbi typ) = TExp typ <$> inferExpr env e
-  -- case metaType typ of
-  -- Integer -> TExp SInteger   <$> inferExpr env e
-  -- Boolean -> TExp SBoolean  <$> inferExpr env e
-  -- ByteStr -> TExp SByteStr <$> inferExpr env e
 
 -- | Attempt to typecheck an untyped expression as any possible type.
 typedExp :: Typeable t => Env -> U.Expr -> Err (TypedExp t)

From 731ad472953d6efe2840b7179a6fd942d711cff5 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sat, 2 Oct 2021 18:33:55 +0200
Subject: [PATCH 22/36] fix CI build errors

---
 src/Syntax/TimeAgnostic.hs | 32 +++++++++++++++++---------------
 1 file changed, 17 insertions(+), 15 deletions(-)

diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index e4da6022..4a6a1908 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -127,7 +127,7 @@ data Rewrite t
   deriving (Show, Eq)
 
 data StorageUpdate t
-  = forall a. Typeable a => Update (Sing a) (TStorageItem a t) (Exp a t)
+  = forall a. Typeable a => Update (SType a) (TStorageItem a t) (Exp a t)
 deriving instance Show (StorageUpdate t)
 
 _Update :: Typeable a => TStorageItem a t -> Exp a t -> StorageUpdate t
@@ -135,9 +135,13 @@ _Update item expr = Update (getType item) item expr
 
 instance Eq (StorageUpdate t) where
   Update Sing i1 e1 == Update Sing i2 e2 = eqS i1 i2 && eqS e1 e2
+  u1 == u2 = error $ "Internal error: No singleton in StorageUpdate"
+                  <> "\nUpdate 1: " <> show u1
+                  <> "\nUpdate 2: " <> show u2
+  -- Ugly, stupid, but otherwise GHC compains about incomplete pattern...
 
 data StorageLocation t
-  = forall a. Loc (Sing a) (TStorageItem a t)
+  = forall a. Loc (SType a) (TStorageItem a t)
 deriving instance Show (StorageLocation t)
 
 _Loc :: TStorageItem a t -> StorageLocation t
@@ -145,11 +149,10 @@ _Loc item = Loc (getType item) item
 
 instance Eq (StorageLocation t) where
   Loc Sing i1 == Loc Sing i2 = eqS i1 i2
---deriving instance Eq (StorageLocation t)
---    IntLoc (TStorageItem Integer t)
---  | BoolLoc (TStorageItem Bool t)
---  | BytesLoc (TStorageItem ByteString t)
---  deriving (Show, Eq)
+  l1 == l2 = error $ "Internal error: No singleton in StorageLocation"
+                  <> "\nLocation 1: " <> show l1
+                  <> "\nLocation 2: " <> show l2
+  -- Ugly, stupid, but otherwise GHC compains about incomplete pattern...
 
 -- | References to items in storage, either as a map lookup or as a reading of
 -- a simple variable. The third argument is a list of indices; it has entries iff
@@ -159,7 +162,7 @@ instance Eq (StorageLocation t) where
 -- refer to the pre-/post-state, or not. `a` is the type of the item that is
 -- referenced.
 data TStorageItem (a :: *) (t :: Timing) where
-  Item :: Sing a -> Id -> Id -> [TypedExp t] -> TStorageItem a t
+  Item :: SType a -> Id -> Id -> [TypedExp t] -> TStorageItem a t
 deriving instance Show (TStorageItem a t)
 deriving instance Eq (TStorageItem a t)
 
@@ -171,21 +174,20 @@ instance HasType (TStorageItem a t) a where
 
 -- | Expressions for which the return type is known.
 data TypedExp t
-  = forall a. Typeable a => TExp (Sing a) (Exp a t)
+  = forall a. Typeable a => TExp (SType a) (Exp a t)
 deriving instance Show (TypedExp t)
---deriving instance Eq (TypedExp t)
 
 -- We could remove the 'SingI' constraint here if we also removed it from the
 -- 'HasType' instance for 'Exp'. But it's tedious and noisy and atm unnecessary.
 _TExp :: (Typeable a, SingI a) => Exp a t -> TypedExp t
-_TExp expr = undefined -- TExp (getType expr) expr
+_TExp expr = TExp (getType expr) expr
 
 instance Eq (TypedExp t) where
   TExp Sing e1 == TExp Sing e2 = eqS e1 e2
---    TExp SInteger   (Exp Integer t)
---  | TExp SBoolean  (Exp Bool t)
---  | TExp SByteStr (Exp ByteString t)
---  deriving (Eq, Show)
+  e1 == e2 = error $ "Internal error: No singleton in TypedExp"
+                  <> "\nExp 1: " <> show e1
+                  <> "\nExp 2: " <> show e2
+  -- Ugly, stupid, but otherwise GHC compains about incomplete pattern...
 
 -- | Expressions parametrized by a timing `t` and a type `a`. `t` can be either `Timed` or `Untimed`.
 -- All storage entries within an `Exp a t` contain a value of type `Time t`.

From 31f33c740a6962689d4fe674a04d2be6378889c4 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sun, 3 Oct 2021 01:50:23 +0200
Subject: [PATCH 23/36] cleanup

---
 src/HEVM.hs                                   |  3 ---
 src/K.hs                                      |  3 ---
 src/Print.hs                                  |  4 ----
 src/SMT.hs                                    |  2 --
 src/Syntax.hs                                 | 16 ++-----------
 src/Syntax/Annotated.hs                       |  2 --
 src/Syntax/TimeAgnostic.hs                    | 23 +++++--------------
 src/Type.hs                                   |  9 ++++----
 src/act.cabal                                 |  1 -
 src/test/Test.hs                              | 12 +++++-----
 .../pass/token/transfer.act.typed.json        | 12 +++++-----
 11 files changed, 24 insertions(+), 63 deletions(-)

diff --git a/src/HEVM.hs b/src/HEVM.hs
index 6d5db717..f980366a 100644
--- a/src/HEVM.hs
+++ b/src/HEVM.hs
@@ -208,9 +208,6 @@ locateStorage ctx solcjson contractMap method (pre, post) item =
 
       name :: StorageLocation -> Id
       name (Loc _ i) = nameFromItem method i
-    --  name (IntLoc   i) = nameFromItem method i
-    --  name (BoolLoc  i) = nameFromItem method i
-    --  name (BytesLoc i) = nameFromItem method i
 
   in (name item',  (SymInteger (sFromIntegral preValue), SymInteger (sFromIntegral postValue)))
 
diff --git a/src/K.hs b/src/K.hs
index 01e0f186..703eb65d 100644
--- a/src/K.hs
+++ b/src/K.hs
@@ -18,7 +18,6 @@ import Data.Text (Text, pack, unpack)
 import Data.Typeable
 import Data.List hiding (group)
 import Data.Maybe
--- import Data.ByteString hiding (group, pack, unpack, intercalate, filter, foldr, concat, head, tail, null)
 import qualified Data.Text as Text
 import Parse
 import EVM.Types hiding (Whiff(..))
@@ -156,8 +155,6 @@ kStorageEntry storageLayout update =
          (Map.lookup (pack (idFromRewrite update)) storageLayout)
   in case update of
        Rewrite (Update _ a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
-       --Rewrite (BoolUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
-       --Rewrite (BytesUpdate a b) -> (loc, (offset, kStorageName Pre a, kExpr b))
        Constant (Loc SInteger a) -> (loc, (offset, kStorageName Pre a, kStorageName Pre a))
        v -> error $ "Internal error: TODO kStorageEntry: " <> show v -- TODO should this really be separate?
 
diff --git a/src/Print.hs b/src/Print.hs
index 7009c162..371c9fa4 100644
--- a/src/Print.hs
+++ b/src/Print.hs
@@ -96,13 +96,9 @@ prettyItem item = contractFromItem item <> "." <> idFromItem item <> concatMap (
 
 prettyLocation :: StorageLocation t -> String
 prettyLocation (Loc _ item) = prettyItem item
---prettyLocation (BoolLoc item) = prettyItem item
---prettyLocation (BytesLoc item) = prettyItem item
 
 prettyUpdate :: StorageUpdate t -> String
 prettyUpdate (Update _ item e) = prettyItem item <> " => " <> prettyExp e
---prettyUpdate (BoolUpdate item e) = prettyItem item <> " => " <> prettyExp e
---prettyUpdate (BytesUpdate item e) = prettyItem item <> " => " <> prettyExp e
 
 prettyEnv :: EthEnv -> String
 prettyEnv e = case e of
diff --git a/src/SMT.hs b/src/SMT.hs
index c1f95670..57cfadb9 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -672,8 +672,6 @@ nameFromItem whn (Item _ c name _) = c @@ name @@ show whn
 -- Construct the smt2 variable name for a given storage location
 nameFromLoc :: When -> StorageLocation -> Id
 nameFromLoc whn (Loc _ item) = nameFromItem whn item
-  -- BoolLoc item -> nameFromItem whn item
-  -- BytesLoc item -> nameFromItem whn item
 
 -- Construct the smt2 variable name for a given decl
 nameFromDecl :: Id -> Decl -> Id
diff --git a/src/Syntax.hs b/src/Syntax.hs
index f382fb62..73d1dbeb 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -43,18 +43,9 @@ locsFromConstructor (Constructor _ _ _ pre post initialStorage rewrites) = nub $
 -- * Extract from any typed AST * --
 ------------------------------------
 
-ctorsFromClaims :: [Claim t] -> [Constructor t]
-ctorsFromClaims claims = [c | C c <- claims]
-
 behvsFromClaims :: [Claim t] -> [Behaviour t]
 behvsFromClaims claims = [b | B b <- claims]
 
-invsFromClaims :: [Claim t] -> [Invariant t]
-invsFromClaims claims = [i | I i <- claims]
-
-storesFromClaims :: [Claim t] -> [Store]
-storesFromClaims claims = [s | S s <- claims]
-
 locsFromRewrite :: Rewrite t -> [StorageLocation t]
 locsFromRewrite update = nub $ case update of
   Constant loc -> [loc]
@@ -64,13 +55,10 @@ locFromRewrite :: Rewrite t -> StorageLocation t
 locFromRewrite = onRewrite id locFromUpdate
 
 locFromUpdate :: StorageUpdate t -> StorageLocation t
-locFromUpdate (Update typ item _) = Loc typ item
+locFromUpdate (Update _ item _) = _Loc item
 
 locsFromItem :: TStorageItem a t -> [StorageLocation t]
-locsFromItem item@(Item typ _ _ ixs) = Loc typ item : ixLocs ixs
-  where
-    ixLocs :: [TypedExp t] -> [StorageLocation t]
-    ixLocs = concatMap locsFromTypedExp
+locsFromItem item = _Loc item : concatMap locsFromTypedExp (ixsFromItem item)
 
 locsFromTypedExp :: TypedExp t -> [StorageLocation t]
 locsFromTypedExp (TExp _ e) = locsFromExp e
diff --git a/src/Syntax/Annotated.hs b/src/Syntax/Annotated.hs
index ae4fadd8..e8596533 100644
--- a/src/Syntax/Annotated.hs
+++ b/src/Syntax/Annotated.hs
@@ -73,5 +73,3 @@ instance Annotatable Agnostic.Rewrite where
 
 instance Annotatable Agnostic.StorageUpdate where
   annotate (Update typ item expr) = Update typ (setPost item) (setPre expr)
---    BoolUpdate item expr -> BoolUpdate (setPost item) (setPre expr)
---    BytesUpdate item expr -> BytesUpdate (setPost item) (setPre expr)
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 4a6a1908..d7b8463d 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -214,7 +214,6 @@ data Exp (a :: *) (t :: Timing) where
   Mod :: Exp Integer t -> Exp Integer t -> Exp Integer t
   Exp :: Exp Integer t -> Exp Integer t -> Exp Integer t
   LitInt :: Integer -> Exp Integer t
-  --IntVar :: Id -> Exp Integer t
   IntEnv :: EthEnv -> Exp Integer t
   -- bounds
   IntMin :: Int -> Exp Integer t
@@ -224,7 +223,6 @@ data Exp (a :: *) (t :: Timing) where
   -- bytestrings
   Cat :: Exp ByteString t -> Exp ByteString t -> Exp ByteString t
   Slice :: Exp ByteString t -> Exp Integer t -> Exp Integer t -> Exp ByteString t
-  --ByVar :: Id -> Exp ByteString t
   ByStr :: String -> Exp ByteString t
   ByLit :: ByteString -> Exp ByteString t
   ByEnv :: EthEnv -> Exp ByteString t
@@ -249,7 +247,6 @@ instance Eq (Exp a t) where
   GEQ a b == GEQ c d = a == c && b == d
   GE a b == GE c d = a == c && b == d
   LitBool a == LitBool b = a == b
-  --BoolVar a == BoolVar b = a == b
 
   Add a b == Add c d = a == c && b == d
   Sub a b == Sub c d = a == c && b == d
@@ -258,7 +255,6 @@ instance Eq (Exp a t) where
   Mod a b == Mod c d = a == c && b == d
   Exp a b == Exp c d = a == c && b == d
   LitInt a == LitInt b = a == b
-  --IntVar a == IntVar b = a == b
   IntEnv a == IntEnv b = a == b
 
   IntMin a == IntMin b = a == b
@@ -268,7 +264,6 @@ instance Eq (Exp a t) where
 
   Cat a b == Cat c d = a == c && b == d
   Slice a b c == Slice d e f = a == d && b == e && c == f
-  --ByVar a == ByVar b = a == b
   ByStr a == ByStr b = a == b
   ByLit a == ByLit b = a == b
   ByEnv a == ByEnv b = a == b
@@ -413,15 +408,9 @@ instance ToJSON (StorageUpdate t) where
   toJSON (Update _ a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
 
 instance ToJSON (TStorageItem a t) where
-  toJSON (Item SInteger a b []) = object ["sort" .= pack "int"
+  toJSON (Item t a b []) = object ["sort" .= pack (show t)
                                   , "name" .= String (pack a <> "." <> pack b)]
-  toJSON (Item SBoolean a b []) = object ["sort" .= pack "bool"
-                                   , "name" .= String (pack a <> "." <> pack b)]
-  toJSON (Item SByteStr a b []) = object ["sort" .= pack "bytes"
-                                    , "name" .= String (pack a <> "." <> pack b)]
-  toJSON (Item SInteger a b c) = mapping a b c
-  toJSON (Item SBoolean a b c) = mapping a b c
-  toJSON (Item SByteStr a b c) = mapping a b c
+  toJSON (Item _ a b c)  = mapping a b c
 
 mapping :: (ToJSON a1, ToJSON a2, ToJSON a3) => a1 -> a2 -> a3 -> Value
 mapping c a b = object [  "symbol"   .= pack "lookup"
@@ -439,15 +428,12 @@ instance Typeable a => ToJSON (Exp a t) where
   toJSON (Mul a b) = symbol "*" a b
   toJSON (Div a b) = symbol "/" a b
   toJSON (NewAddr a b) = symbol "newAddr" a b
-  --toJSON (IntVar a) = String $ pack a
   toJSON (LitInt a) = toJSON $ show a
   toJSON (IntMin a) = toJSON $ show $ intmin a
   toJSON (IntMax a) = toJSON $ show $ intmax a
   toJSON (UIntMin a) = toJSON $ show $ uintmin a
   toJSON (UIntMax a) = toJSON $ show $ uintmax a
   toJSON (IntEnv a) = String $ pack $ show a
-  toJSON (TEntry t a) = object [ pack (show t) .= toJSON a ]
-  toJSON (Var _ a) = toJSON a
   toJSON (ITE a b c) = object [  "symbol"   .= pack "ite"
                               ,  "arity"    .= Data.Aeson.Types.Number 3
                               ,  "args"     .= Array (fromList [toJSON a, toJSON b, toJSON c])]
@@ -461,7 +447,6 @@ instance Typeable a => ToJSON (Exp a t) where
   toJSON (LEQ a b)  = symbol "<=" a b
   toJSON (GEQ a b)  = symbol ">=" a b
   toJSON (LitBool a) = String $ pack $ show a
-  --toJSON (BoolVar a) = toJSON a
   toJSON (Neg a) = object [  "symbol"   .= pack "not"
                           ,  "arity"    .= Data.Aeson.Types.Number 1
                           ,  "args"     .= Array (fromList [toJSON a])]
@@ -475,6 +460,10 @@ instance Typeable a => ToJSON (Exp a t) where
   toJSON (ByStr a) = toJSON a
   toJSON (ByLit a) = String . pack $ show a
   toJSON (ByEnv a) = String . pack $ show a
+
+  toJSON (TEntry t a) = object [ pack (show t) .= toJSON a ]
+  toJSON (Var _ a) = toJSON a
+
   toJSON v = error $ "todo: json ast for: " <> show v
 
 symbol :: (ToJSON a1, ToJSON a2) => String -> a1 -> a2 -> Value
diff --git a/src/Type.hs b/src/Type.hs
index 633ab102..ee3e663e 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -270,7 +270,6 @@ checkStorageExpr env@Env{contract,store} (U.PEntry p name args) expr = case Map.
   Nothing ->
     throw (p, "Unknown storage variable " <> show name)
 
--- 
 checkPattern :: Env -> U.Pattern -> Err StorageLocation
 checkPattern _ (U.PWild _) = error "TODO: checkPattern for Wild storage"
 checkPattern env@Env{contract,store} (U.PEntry p name args) =
@@ -299,11 +298,11 @@ lowerBound _ = LitInt 0
 
 -- todo, the rest
 upperBound :: AbiType -> Exp Integer t
-upperBound (AbiUIntType n) = UIntMax n
-upperBound (AbiIntType n) = IntMax n
-upperBound AbiAddressType = UIntMax 160
+upperBound (AbiUIntType  n) = UIntMax n
+upperBound (AbiIntType   n) = IntMax n
+upperBound AbiAddressType   = UIntMax 160
 upperBound (AbiBytesType n) = UIntMax (8 * n)
-upperBound typ  = error $ "upperBound not implemented for " ++ show typ
+upperBound typ = error $ "upperBound not implemented for " ++ show typ
 
 -- | Attempt to construct a `TypedExp` whose type matches the supplied `AbiType`.
 -- The target timing parameter will be whatever is required by the caller.
diff --git a/src/act.cabal b/src/act.cabal
index ec631e1b..2bed16ca 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -36,7 +36,6 @@ common deps
                  extra,
                  singletons,
                  reflection       >= 2.1.6
---  other-modules: CLI Error Print SMT Syntax.Annotated Lex Parse K HEVM Coq Syntax Syntax.Untyped Syntax.Typed Syntax.Types Syntax.Timing Syntax.TimeAgnostic Type Enrich
   if flag(ci)
       ghc-options: -O2 -Wall -Werror -Wno-orphans -Wno-unticked-promoted-constructors
   else
diff --git a/src/test/Test.hs b/src/test/Test.hs
index f2d755e4..080a9e54 100644
--- a/src/test/Test.hs
+++ b/src/test/Test.hs
@@ -146,20 +146,20 @@ genType typ = case typ of
 
 genTypedExp :: Names -> Int -> ExpoGen TypedExp
 genTypedExp names n = oneof
-  [ TExp SInteger <$> genExpInt names n
-  , TExp SBoolean <$> genExpBool names n
-  , TExp SByteStr <$> genExpBytes names n
+  [ _TExp <$> genExpInt names n
+  , _TExp <$> genExpBool names n
+  , _TExp <$> genExpBytes names n
   ]
 
 
 -- TODO: literals, cat slice, ITE, storage, ByStr
 genExpBytes :: Names -> Int -> ExpoGen (Exp ByteString)
-genExpBytes names _ = Var SByteStr <$> selectName ByteStr names
+genExpBytes names _ = _Var <$> selectName ByteStr names
 
 -- TODO: ITE, storage
 genExpBool :: Names -> Int -> ExpoGen (Exp Bool)
 genExpBool names 0 = oneof
-  [ Var SBoolean <$> selectName Boolean names
+  [ _Var <$> selectName Boolean names
   , LitBool <$> liftGen arbitrary
   ]
 genExpBool names n = oneof
@@ -185,7 +185,7 @@ genExpBool names n = oneof
 genExpInt :: Names -> Int -> ExpoGen (Exp Integer)
 genExpInt names 0 = oneof
   [ LitInt <$> liftGen arbitrary
-  , Var SInteger <$> selectName Integer names
+  , _Var <$> selectName Integer names
   , return $ IntEnv Caller
   , return $ IntEnv Callvalue
   , return $ IntEnv Calldepth
diff --git a/tests/frontend/pass/token/transfer.act.typed.json b/tests/frontend/pass/token/transfer.act.typed.json
index b93a29c8..8c53101e 100644
--- a/tests/frontend/pass/token/transfer.act.typed.json
+++ b/tests/frontend/pass/token/transfer.act.typed.json
@@ -124,7 +124,7 @@
           {
             "Pre": {
               "name": "Token.name",
-              "sort": "bytes"
+              "sort": "bytestring"
             }
           },
           "_name"
@@ -137,7 +137,7 @@
           {
             "Post": {
               "name": "Token.name",
-              "sort": "bytes"
+              "sort": "bytestring"
             }
           },
           "_name"
@@ -181,7 +181,7 @@
           {
             "Pre": {
               "name": "Token.symbol",
-              "sort": "bytes"
+              "sort": "bytestring"
             }
           },
           "_symbol"
@@ -194,7 +194,7 @@
           {
             "Post": {
               "name": "Token.symbol",
-              "sort": "bytes"
+              "sort": "bytestring"
             }
           },
           "_symbol"
@@ -236,14 +236,14 @@
       {
         "location": {
           "name": "Token.name",
-          "sort": "bytes"
+          "sort": "bytestring"
         },
         "value": "_name"
       },
       {
         "location": {
           "name": "Token.symbol",
-          "sort": "bytes"
+          "sort": "bytestring"
         },
         "value": "_symbol"
       },

From 0b4c157cdd22c2fde73f6ba3aa2674dedf5c00b9 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sun, 3 Oct 2021 04:04:50 +0200
Subject: [PATCH 24/36] documentation

---
 src/Error.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/src/Error.hs b/src/Error.hs
index 1a4e7bb3..fbfdce67 100644
--- a/src/Error.hs
+++ b/src/Error.hs
@@ -7,6 +7,15 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+{-|
+Module      : Error
+Description : An instantiation of 'Validation' with our error type.
+
+This specializes 'Data.Validation.Validation' to keep its errors in a 'NonEmpty' list
+and keep track of a 'Pn' for every error it logs. There is also some infrastructure
+around modified chaining/branching behaviours.
+-}
+
 module Error (module Error) where
 
 import Data.Functor.Alt
@@ -27,7 +36,7 @@ throw msg = Failure [msg]
 
 infixr 1 <==<, >==>
 
--- Like @Control.Monad.'(>=>)'@ but allows us to chain error-prone
+-- Like 'Control.Monad.(>=>)' but allows us to chain error-prone
 -- computations even without a @Monad@ instance.
 (>==>) :: (a -> Error e b) -> (b -> Error e c) -> a -> Error e c
 f >==> g = \x -> f x `bindValidation` g

From dab0a6b4caab58ab70d2a7236a0f164dd1f92df9 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sun, 3 Oct 2021 04:26:21 +0200
Subject: [PATCH 25/36] docs

---
 src/Type.hs | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/src/Type.hs b/src/Type.hs
index ee3e663e..5d60f2a7 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -56,6 +56,13 @@ typecheck behvs = (S store:) . concat <$> traverse (splitBehaviour store) behvs
     -- Generic helper
     noDuplicates :: [(Pn,Id)] -> (Id -> String) -> Err ()
     noDuplicates xs errmsg = traverse_ (throw . fmap errmsg) . duplicatesBy ((==) `on` snd) $ xs
+      where
+        -- filters out duplicate entries in list based on a custom equality predicate.
+        duplicatesBy :: (a -> a -> Bool) -> [a] -> [a]
+        duplicatesBy _ [] = []
+        duplicatesBy f (y:ys) =
+          let e = [y | any (f y) ys]
+          in e <> duplicatesBy f ys
 
 --- Finds storage declarations from constructors
 lookupVars :: [U.RawBehaviour] -> Store
@@ -64,7 +71,7 @@ lookupVars = foldMap $ \case
   U.Definition _ contract _ _ (U.Creates assigns) _ _ _ ->
     Map.singleton contract . Map.fromList $ snd . fromAssign <$> assigns
 
--- | Extracts what we need to build a 'Store' and to verify that names are unique.
+-- | Extracts what we need to build a 'Store' and to verify that its names are unique.
 -- Kind of stupid return type but it makes it easier to use the same function
 -- at both places (without relying on custom functions on triples.)
 fromAssign :: U.Assign -> (Pn, (Id, SlotType))
@@ -72,13 +79,6 @@ fromAssign (U.AssignVal (U.StorageVar pn typ var) _) = (pn, (var, typ))
 fromAssign (U.AssignMany (U.StorageVar pn typ var) _) = (pn, (var, typ))
 fromAssign (U.AssignStruct _ _) = error "TODO: assignstruct"
 
--- | filters out duplicate entries in list based on a custom equality predicate.
-duplicatesBy :: (a -> a -> Bool) -> [a] -> [a]
-duplicatesBy _ [] = []
-duplicatesBy f (x:xs) =
-  let e = [x | any (f x) xs]
-  in e <> duplicatesBy f xs
-
 -- | The type checking environment. 
 data Env = Env
   { contract :: Id              -- ^ The name of the current contract.

From 6a72abd16e402109b6ec89eed8f5f05decd31914 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Wed, 13 Oct 2021 04:50:12 +0200
Subject: [PATCH 26/36] minor comment rephrasing

---
 src/Syntax/Types.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index 85528495..57c8dd8f 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -87,13 +87,12 @@ instance SingKind * where
   -- | We can demote a type variable @a@ to a value of type 'MType'
   type Demote * = MType
 
-  -- | We can go from any singleton type to the corresponding demoted type.
+  -- | Demotes @'SType' a@ to 'MType'.
   fromSing SInteger = Integer
   fromSing SBoolean = Boolean
   fromSing SByteStr = ByteStr
 
-  -- | We can go from any demoted type to the corresponding singleton type,
-  -- but need to hide its type variable when doing so.
+  -- | Promotes 'MType' to an existentially quantified 'SType'.
   toSing Integer = SomeSing SInteger
   toSing Boolean = SomeSing SBoolean
   toSing ByteStr = SomeSing SByteStr

From eb0c990fe4c9e8e737cb4e33a103c5164cff9e45 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 1 Nov 2021 23:22:01 +0100
Subject: [PATCH 27/36] Apply suggestions from code review

Co-authored-by: David Terry <6689924+d-xo@users.noreply.github.com>
---
 src/Coq.hs                 | 2 +-
 src/Syntax/TimeAgnostic.hs | 1 -
 2 files changed, 1 insertion(+), 2 deletions(-)

diff --git a/src/Coq.hs b/src/Coq.hs
index 48f19f11..1556e654 100644
--- a/src/Coq.hs
+++ b/src/Coq.hs
@@ -212,7 +212,7 @@ abiType a = error $ show a
 returnType :: TypedExp -> T.Text
 returnType (TExp SInteger _) = "Z"
 returnType (TExp SBoolean _) = "bool"
-returnType (TExp SByteStr _) = "bytestrings not supported"
+returnType (TExp SByteStr _) = error "bytestrings not supported"
 
 -- | default value for a given type
 -- this is used in cases where a value is not set in the constructor
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index d7b8463d..71f181ce 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -456,7 +456,6 @@ instance Typeable a => ToJSON (Exp a t) where
                                 , "arity"  .= Data.Aeson.Types.Number 3
                                 , "args"   .= Array (fromList [toJSON s, toJSON a, toJSON b])
                                 ]
-  --toJSON (ByVar a) = toJSON a
   toJSON (ByStr a) = toJSON a
   toJSON (ByLit a) = String . pack $ show a
   toJSON (ByEnv a) = String . pack $ show a

From b24087c189c17dcbb70cb10340088b70b5d254c8 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 1 Nov 2021 23:28:56 +0100
Subject: [PATCH 28/36] make `MType` a type synonym instead of an ADT

---
 src/SMT.hs          |  4 ++--
 src/Syntax.hs       |  2 +-
 src/Syntax/Types.hs | 44 +++++++++++++-------------------------------
 3 files changed, 16 insertions(+), 34 deletions(-)

diff --git a/src/SMT.hs b/src/SMT.hs
index 57cfadb9..a3eb2b3d 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -38,7 +38,7 @@ import Data.Maybe
 import Data.List
 import GHC.IO.Handle (Handle, hGetLine, hPutStr, hFlush)
 import Data.ByteString.UTF8 (fromString)
-import Data.Singletons (fromSing)
+import Data.Singletons (SomeSing(..))
 
 import Syntax
 import Syntax.Annotated
@@ -661,7 +661,7 @@ sType ByteStr = "String"
 
 -- | act -> smt2 type translation
 sType' :: TypedExp -> SMT2
-sType' (TExp t _) = sType . fromSing $ t
+sType' (TExp t _) = sType $ SomeSing t
 
 --- ** Variable Names ** ---
 
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 73d1dbeb..daa49211 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -204,7 +204,7 @@ ixsFromRewrite :: Rewrite t -> [TypedExp t]
 ixsFromRewrite = onRewrite ixsFromLocation ixsFromUpdate
 
 itemType :: TStorageItem a t -> MType
-itemType (Item t _ _ _) = fromSing t
+itemType (Item t _ _ _) = SomeSing t
 
 isMapping :: StorageLocation t -> Bool
 isMapping = not . null . ixsFromLocation
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index 57c8dd8f..1bebf7fe 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -26,12 +26,10 @@ import Type.Reflection
 import Data.ByteString    as Syntax.Types (ByteString)
 import EVM.ABI            as Syntax.Types (AbiType(..))
 
--- | Types understood by proving tools.
-data MType
-  = Integer
-  | Boolean
-  | ByteStr
-  deriving (Eq, Ord, Show, Read)
+type MType = SomeSing *
+pattern Integer = SomeSing SInteger
+pattern Boolean = SomeSing SBoolean
+pattern ByteStr = SomeSing SByteStr
 
 -- | Singleton types of the types understood by proving tools.
 data SType a where
@@ -56,13 +54,13 @@ class HasType a t where
   getType :: a -> SType t
 
 metaType :: AbiType -> MType
-metaType (AbiUIntType _)     = Integer
-metaType (AbiIntType  _)     = Integer
-metaType AbiAddressType      = Integer
-metaType AbiBoolType         = Boolean
-metaType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
-metaType AbiBytesDynamicType = ByteStr
-metaType AbiStringType       = ByteStr
+metaType (AbiUIntType _)     = SomeSing SInteger
+metaType (AbiIntType  _)     = SomeSing SInteger
+metaType AbiAddressType      = SomeSing SInteger
+metaType AbiBoolType         = SomeSing SBoolean
+metaType (AbiBytesType n)    = if n <= 32 then SomeSing SInteger else SomeSing SByteStr
+metaType AbiBytesDynamicType = SomeSing SByteStr
+metaType AbiStringType       = SomeSing SByteStr
 --metaType (AbiArrayDynamicType a) =
 --metaType (AbiArrayType        Int AbiType
 --metaType (AbiTupleType        (Vector AbiType)
@@ -81,31 +79,15 @@ instance SingI Integer    where sing = SInteger
 instance SingI Bool       where sing = SBoolean
 instance SingI ByteString where sing = SByteStr
 
--- | This instance allows us to go between 'MType', @'SType' a@ and @a@,
--- with @a :: '*'@.
-instance SingKind * where
-  -- | We can demote a type variable @a@ to a value of type 'MType'
-  type Demote * = MType
-
-  -- | Demotes @'SType' a@ to 'MType'.
-  fromSing SInteger = Integer
-  fromSing SBoolean = Boolean
-  fromSing SByteStr = ByteStr
-
-  -- | Promotes 'MType' to an existentially quantified 'SType'.
-  toSing Integer = SomeSing SInteger
-  toSing Boolean = SomeSing SBoolean
-  toSing ByteStr = SomeSing SByteStr
-
 -- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType' with a 'Typeable'
 -- instance.
 pattern FromAbi :: () => Typeable a => SType a -> AbiType
-pattern FromAbi t <- (metaType -> FromSing t@STypeable)
+pattern FromAbi t <- (metaType -> FromMeta t)
 {-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
 
 -- | Pattern match on an 'MType' is if it were an 'SType' with a 'Typeable' instance.
 pattern FromMeta :: () => Typeable a => SType a -> MType
-pattern FromMeta t <- FromSing t@STypeable
+pattern FromMeta t <- SomeSing t@STypeable
 {-# COMPLETE FromMeta #-}
 
 -- | Helper pattern to retrieve the 'Typeable' instance of an 'SType'.

From 5511d0f312d7e2ce18517039c19bee70cc0cbaca Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 1 Nov 2021 23:37:29 +0100
Subject: [PATCH 29/36] remove `Pn` from `Transition`

---
 src/Parse.y                                               | 3 ++-
 src/Syntax/Untyped.hs                                     | 2 +-
 src/Type.hs                                               | 2 +-
 tests/frontend/pass/array/array.act.parsed.hs             | 2 +-
 tests/frontend/pass/creation/createMultiple.act.parsed.hs | 2 +-
 tests/frontend/pass/dss/vat.act.parsed.hs                 | 2 +-
 tests/frontend/pass/multi/multi.act.parsed.hs             | 2 +-
 tests/frontend/pass/safemath/safemathraw.act.parsed.hs    | 2 +-
 tests/frontend/pass/smoke/smoke.act.parsed.hs             | 2 +-
 tests/frontend/pass/staticstore/staticstore.act.parsed.hs | 2 +-
 tests/frontend/pass/token/transfer.act.parsed.hs          | 2 +-
 11 files changed, 12 insertions(+), 11 deletions(-)

diff --git a/src/Parse.y b/src/Parse.y
index 727337a5..7841767d 100644
--- a/src/Parse.y
+++ b/src/Parse.y
@@ -163,7 +163,7 @@ Transition : 'behaviour' id 'of' id
              Interface
              list(Precondition)
              Cases
-             Ensures                                  { Transition (posn $2) (name $2) (name $4)
+             Ensures                                  { Transition (name $2) (name $4)
                                                         $5 $6 $7 $8 }
 
 Constructor : 'constructor' 'of' id
@@ -305,6 +305,7 @@ Expr : '(' Expr ')'                                   { $2 }
 {
 
 nowhere = AlexPn 0 0 0
+
 lastPos = AlexPn (-1) (-1) (-1)
 
 validsize :: Int -> Bool
diff --git a/src/Syntax/Untyped.hs b/src/Syntax/Untyped.hs
index 6749a558..ecdee10b 100644
--- a/src/Syntax/Untyped.hs
+++ b/src/Syntax/Untyped.hs
@@ -22,7 +22,7 @@ newtype Act = Main [RawBehaviour]
   deriving (Eq, Show)
 
 data RawBehaviour
-  = Transition Pn Id Id Interface [IffH] Cases Ensures
+  = Transition Id Id Interface [IffH] Cases Ensures
   | Definition Pn Id Interface [IffH] Creates [ExtStorage] Ensures Invariants
   deriving (Eq, Show)
 
diff --git a/src/Type.hs b/src/Type.hs
index 5d60f2a7..17a8d41d 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -118,7 +118,7 @@ mkEnv contract store decls = Env
 
 -- checks a transition given a typing of its storage variables
 splitBehaviour :: Store -> U.RawBehaviour -> Err [Claim]
-splitBehaviour store (U.Transition _ name contract iface@(Interface _ decls) iffs cases posts) =
+splitBehaviour store (U.Transition name contract iface@(Interface _ decls) iffs cases posts) =
   noIllegalWilds *>
   -- constrain integer calldata variables (TODO: other types)
   fmap concatMap (caseClaims
diff --git a/tests/frontend/pass/array/array.act.parsed.hs b/tests/frontend/pass/array/array.act.parsed.hs
index ab99d9fd..61401f1a 100644
--- a/tests/frontend/pass/array/array.act.parsed.hs
+++ b/tests/frontend/pass/array/array.act.parsed.hs
@@ -1 +1 @@
-[Transition (AlexPn 10 1 11) "f" "A" f(address[2] xs) [] (Direct (Post [] [] (Just (EUTEntry (AlexPn 53 4 9) "xs" [IntLit (AlexPn 56 4 12) 1])))) []]
+[Transition "f" "A" f(address[2] xs) [] (Direct (Post [] [] (Just (EUTEntry (AlexPn 53 4 9) "xs" [IntLit (AlexPn 56 4 12) 1])))) []]
diff --git a/tests/frontend/pass/creation/createMultiple.act.parsed.hs b/tests/frontend/pass/creation/createMultiple.act.parsed.hs
index afa3fe57..92ceec54 100644
--- a/tests/frontend/pass/creation/createMultiple.act.parsed.hs
+++ b/tests/frontend/pass/creation/createMultiple.act.parsed.hs
@@ -1 +1 @@
-[Definition (AlexPn 15 1 16) "B" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 60 5 11) address "a") (IntLit (AlexPn 65 5 16) 0)]) [] [] [],Transition (AlexPn 78 7 11) "create_a" "B" create_a() [Iff (AlexPn 114 10 1) [EEq (AlexPn 131 11 14) (EnvExp (AlexPn 121 11 4) Callvalue) (IntLit (AlexPn 134 11 17) 0)]] (Direct (Post [Rewrite (PEntry (AlexPn 148 14 4) "a" []) (ENewaddr (AlexPn 153 14 9) (EnvExp (AlexPn 161 14 17) This) (EnvExp (AlexPn 167 14 23) Nonce))] [ExtCreates "A" (ENewaddr (AlexPn 239 17 14) (EnvExp (AlexPn 247 17 22) This) (EnvExp (AlexPn 253 17 28) Nonce)) [AssignVal (StorageVar (AlexPn 268 18 9) uint256 "x") (IntLit (AlexPn 273 18 14) 1)]] Nothing)) []]
+[Definition (AlexPn 15 1 16) "B" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 60 5 11) address "a") (IntLit (AlexPn 65 5 16) 0)]) [] [] [],Transition "create_a" "B" create_a() [Iff (AlexPn 114 10 1) [EEq (AlexPn 131 11 14) (EnvExp (AlexPn 121 11 4) Callvalue) (IntLit (AlexPn 134 11 17) 0)]] (Direct (Post [Rewrite (PEntry (AlexPn 148 14 4) "a" []) (ENewaddr (AlexPn 153 14 9) (EnvExp (AlexPn 161 14 17) This) (EnvExp (AlexPn 167 14 23) Nonce))] [ExtCreates "A" (ENewaddr (AlexPn 239 17 14) (EnvExp (AlexPn 247 17 22) This) (EnvExp (AlexPn 253 17 28) Nonce)) [AssignVal (StorageVar (AlexPn 268 18 9) uint256 "x") (IntLit (AlexPn 273 18 14) 1)]] Nothing)) []]
diff --git a/tests/frontend/pass/dss/vat.act.parsed.hs b/tests/frontend/pass/dss/vat.act.parsed.hs
index 2d2246d3..5a27b5ad 100644
--- a/tests/frontend/pass/dss/vat.act.parsed.hs
+++ b/tests/frontend/pass/dss/vat.act.parsed.hs
@@ -1 +1 @@
-[Transition (AlexPn 454 17 11) "frob" "Vat" frob(bytes32 i, address u, address v, address w, int256 dink, int256 dart) [IffIn (AlexPn 546 20 1) uint256 [EUTEntry (AlexPn 572 22 5) "urns" [EUTEntry (AlexPn 577 22 10) "i" [],EUTEntry (AlexPn 580 22 13) "u" [],EAdd (AlexPn 587 22 20) (EUTEntry (AlexPn 583 22 16) "ink" []) (EUTEntry (AlexPn 589 22 22) "dink" [])],EUTEntry (AlexPn 598 23 5) "urns" [EUTEntry (AlexPn 603 23 10) "i" [],EUTEntry (AlexPn 606 23 13) "u" [],EAdd (AlexPn 613 23 20) (EUTEntry (AlexPn 609 23 16) "art" []) (EUTEntry (AlexPn 615 23 22) "dart" [])],EUTEntry (AlexPn 624 24 5) "ilks" [EUTEntry (AlexPn 629 24 10) "i" [],EAdd (AlexPn 639 24 20) (EUTEntry (AlexPn 632 24 13) "Art" []) (EUTEntry (AlexPn 641 24 22) "dart" [])],EMul (AlexPn 671 25 26) (EUTEntry (AlexPn 651 25 6) "ilks" [EUTEntry (AlexPn 656 25 11) "i" [],EAdd (AlexPn 663 25 18) (EUTEntry (AlexPn 659 25 14) "Art" []) (EUTEntry (AlexPn 665 25 20) "dart" [])]) (EUTEntry (AlexPn 673 25 28) "ilks" [EUTEntry (AlexPn 678 25 33) "i" [],EUTEntry (AlexPn 681 25 36) "rate" []]),EAdd (AlexPn 697 26 12) (EUTEntry (AlexPn 690 26 5) "dai" [EUTEntry (AlexPn 694 26 9) "w" []]) (EUTEntry (AlexPn 700 26 15) "ilks" [EUTEntry (AlexPn 705 26 20) "i" [],EMul (AlexPn 713 26 28) (EUTEntry (AlexPn 708 26 23) "rate" []) (EUTEntry (AlexPn 715 26 30) "dart" [])]),EAdd (AlexPn 730 27 10) (EUTEntry (AlexPn 725 27 5) "debt" []) (EUTEntry (AlexPn 733 27 13) "ilks" [EUTEntry (AlexPn 738 27 18) "i" [],EMul (AlexPn 746 27 26) (EUTEntry (AlexPn 741 27 21) "rate" []) (EUTEntry (AlexPn 748 27 28) "dart" [])])],IffIn (AlexPn 755 29 1) int256 [EUTEntry (AlexPn 780 31 5) "ilks" [EUTEntry (AlexPn 785 31 10) "i" [],EUTEntry (AlexPn 788 31 13) "rate" []],EUTEntry (AlexPn 797 32 5) "ilks" [EUTEntry (AlexPn 802 32 10) "i" [],EMul (AlexPn 810 32 18) (EUTEntry (AlexPn 805 32 13) "rate" []) (EUTEntry (AlexPn 812 32 20) "dart" [])]],Iff (AlexPn 818 34 1) [EEq (AlexPn 836 35 15) (EnvExp (AlexPn 826 35 5) Callvalue) (IntLit (AlexPn 839 35 18) 0),EEq (AlexPn 850 36 10) (EUTEntry (AlexPn 845 36 5) "live" []) (IntLit (AlexPn 853 36 13) 1),EUTEntry (AlexPn 859 37 5) "ilks" [EUTEntry (AlexPn 864 37 10) "i" [],ENeq (AlexPn 872 37 18) (EUTEntry (AlexPn 867 37 13) "rate" []) (IntLit (AlexPn 876 37 22) 0)],EOr (AlexPn 892 38 15) (ELEQ (AlexPn 887 38 10) (EUTEntry (AlexPn 882 38 5) "dart" []) (IntLit (AlexPn 890 38 13) 0)) (EMul (AlexPn 917 38 40) (EUTEntry (AlexPn 897 38 20) "ilks" [EUTEntry (AlexPn 902 38 25) "i" [],EAdd (AlexPn 909 38 32) (EUTEntry (AlexPn 905 38 28) "art" []) (EUTEntry (AlexPn 911 38 34) "dart" [])]) (EUTEntry (AlexPn 919 38 42) "ilks" [EUTEntry (AlexPn 924 38 47) "i" [],ELEQ (AlexPn 932 38 55) (EUTEntry (AlexPn 927 38 50) "rate" []) (EUTEntry (AlexPn 935 38 58) "ilks" [EUTEntry (AlexPn 940 38 63) "i" [],EAnd (AlexPn 948 38 71) (EUTEntry (AlexPn 943 38 66) "line" []) (EAdd (AlexPn 957 38 80) (EUTEntry (AlexPn 952 38 75) "debt" []) (EUTEntry (AlexPn 959 38 82) "ilks" [EUTEntry (AlexPn 964 38 87) "i" [],ELEQ (AlexPn 979 38 102) (EMul (AlexPn 972 38 95) (EUTEntry (AlexPn 967 38 90) "rate" []) (EUTEntry (AlexPn 974 38 97) "dart" [])) (EUTEntry (AlexPn 982 38 105) "line" [])]))])])),EOr (AlexPn 1004 39 17) (ELEQ (AlexPn 998 39 11) (EUTEntry (AlexPn 993 39 6) "dart" []) (IntLit (AlexPn 1001 39 14) 0)) (EAnd (AlexPn 1062 39 75) (EMul (AlexPn 1030 39 43) (EUTEntry (AlexPn 1010 39 23) "ilks" [EUTEntry (AlexPn 1015 39 28) "i" [],EAdd (AlexPn 1022 39 35) (EUTEntry (AlexPn 1018 39 31) "Art" []) (EUTEntry (AlexPn 1024 39 37) "dart" [])]) (EUTEntry (AlexPn 1032 39 45) "ilks" [EUTEntry (AlexPn 1037 39 50) "i" [],ELEQ (AlexPn 1045 39 58) (EUTEntry (AlexPn 1040 39 53) "rate" []) (EUTEntry (AlexPn 1048 39 61) "ilks" [EUTEntry (AlexPn 1053 39 66) "i" [],EUTEntry (AlexPn 1056 39 69) "line" []])])) (ELEQ (AlexPn 1096 39 109) (EAdd (AlexPn 1073 39 86) (EUTEntry (AlexPn 1068 39 81) "debt" []) (EUTEntry (AlexPn 1075 39 88) "ilks" [EUTEntry (AlexPn 1080 39 93) "i" [],EMul (AlexPn 1088 39 101) (EUTEntry (AlexPn 1083 39 96) "rate" []) (EUTEntry (AlexPn 1090 39 103) "dart" [])])) (EUTEntry (AlexPn 1099 39 112) "line" []))),EOr (AlexPn 1136 40 31) (EAnd (AlexPn 1121 40 16) (ELEQ (AlexPn 1116 40 11) (EUTEntry (AlexPn 1111 40 6) "dart" []) (IntLit (AlexPn 1119 40 14) 0)) (EGEQ (AlexPn 1130 40 25) (EUTEntry (AlexPn 1125 40 20) "dink" []) (IntLit (AlexPn 1133 40 28) 0))) (ELEQ (AlexPn 1181 40 76) (EMul (AlexPn 1165 40 60) (EUTEntry (AlexPn 1142 40 37) "urns" [EUTEntry (AlexPn 1147 40 42) "i" [],EUTEntry (AlexPn 1150 40 45) "u" [],EAdd (AlexPn 1157 40 52) (EUTEntry (AlexPn 1153 40 48) "art" []) (EUTEntry (AlexPn 1159 40 54) "dart" [])]) (EUTEntry (AlexPn 1167 40 62) "ilks" [EUTEntry (AlexPn 1172 40 67) "i" [],EUTEntry (AlexPn 1175 40 70) "rate" []])) (EMul (AlexPn 1209 40 104) (EUTEntry (AlexPn 1186 40 81) "urns" [EUTEntry (AlexPn 1191 40 86) "i" [],EUTEntry (AlexPn 1194 40 89) "u" [],EAdd (AlexPn 1201 40 96) (EUTEntry (AlexPn 1197 40 92) "ink" []) (EUTEntry (AlexPn 1203 40 98) "dink" [])]) (EUTEntry (AlexPn 1211 40 106) "ilks" [EUTEntry (AlexPn 1216 40 111) "i" [],EUTEntry (AlexPn 1219 40 114) "spot" []]))),EOr (AlexPn 1256 41 31) (EAnd (AlexPn 1241 41 16) (ELEQ (AlexPn 1236 41 11) (EUTEntry (AlexPn 1231 41 6) "dart" []) (IntLit (AlexPn 1239 41 14) 0)) (EGEQ (AlexPn 1250 41 25) (EUTEntry (AlexPn 1245 41 20) "dink" []) (IntLit (AlexPn 1253 41 28) 0))) (EOr (AlexPn 1272 41 47) (EEq (AlexPn 1262 41 37) (EUTEntry (AlexPn 1260 41 35) "u" []) (EnvExp (AlexPn 1265 41 40) Caller)) (EEq (AlexPn 1290 41 65) (EUTEntry (AlexPn 1275 41 50) "can" [EUTEntry (AlexPn 1279 41 54) "u" [],EnvExp (AlexPn 1282 41 57) Caller]) (IntLit (AlexPn 1293 41 68) 1))),EOr (AlexPn 1313 43 17) (ELEQ (AlexPn 1307 43 11) (EUTEntry (AlexPn 1302 43 6) "dink" []) (IntLit (AlexPn 1310 43 14) 0)) (EOr (AlexPn 1329 43 33) (EEq (AlexPn 1319 43 23) (EUTEntry (AlexPn 1317 43 21) "v" []) (EnvExp (AlexPn 1322 43 26) Caller)) (EEq (AlexPn 1347 43 51) (EUTEntry (AlexPn 1332 43 36) "Can" [EUTEntry (AlexPn 1336 43 40) "v" [],EnvExp (AlexPn 1339 43 43) Caller]) (IntLit (AlexPn 1350 43 54) 1))),EOr (AlexPn 1369 44 17) (EGEQ (AlexPn 1363 44 11) (EUTEntry (AlexPn 1358 44 6) "dart" []) (IntLit (AlexPn 1366 44 14) 0)) (EOr (AlexPn 1385 44 33) (EEq (AlexPn 1375 44 23) (EUTEntry (AlexPn 1373 44 21) "w" []) (EnvExp (AlexPn 1378 44 26) Caller)) (EEq (AlexPn 1403 44 51) (EUTEntry (AlexPn 1388 44 36) "Can" [EUTEntry (AlexPn 1392 44 40) "w" [],EnvExp (AlexPn 1395 44 43) Caller]) (IntLit (AlexPn 1406 44 54) 1)))]] (Direct (Post [Constant (PEntry (AlexPn 1423 48 5) "urns" [EUTEntry (AlexPn 1428 48 10) "i" [],EUTEntry (AlexPn 1431 48 13) "u" [],EImpl (AlexPn 1438 48 20) (EUTEntry (AlexPn 1434 48 16) "ink" []) (EUTEntry (AlexPn 1441 48 23) "urns" [EUTEntry (AlexPn 1446 48 28) "i" [],EUTEntry (AlexPn 1449 48 31) "u" [],EAdd (AlexPn 1456 48 38) (EUTEntry (AlexPn 1452 48 34) "ink" []) (EUTEntry (AlexPn 1458 48 40) "dink" [])])]),Constant (PEntry (AlexPn 1467 49 5) "urns" [EUTEntry (AlexPn 1472 49 10) "i" [],EUTEntry (AlexPn 1475 49 13) "u" [],EImpl (AlexPn 1482 49 20) (EUTEntry (AlexPn 1478 49 16) "art" []) (EUTEntry (AlexPn 1485 49 23) "urns" [EUTEntry (AlexPn 1490 49 28) "i" [],EUTEntry (AlexPn 1493 49 31) "u" [],EAdd (AlexPn 1500 49 38) (EUTEntry (AlexPn 1496 49 34) "art" []) (EUTEntry (AlexPn 1502 49 40) "dart" [])])]),Constant (PEntry (AlexPn 1511 50 5) "ilks" [EUTEntry (AlexPn 1516 50 10) "i" [],EImpl (AlexPn 1526 50 20) (EUTEntry (AlexPn 1519 50 13) "Art" []) (EUTEntry (AlexPn 1529 50 23) "ilks" [EUTEntry (AlexPn 1534 50 28) "i" [],EAdd (AlexPn 1541 50 35) (EUTEntry (AlexPn 1537 50 31) "Art" []) (EUTEntry (AlexPn 1543 50 37) "dart" [])])]),Rewrite (PEntry (AlexPn 1552 51 5) "gem" [EUTEntry (AlexPn 1556 51 9) "i" [],EUTEntry (AlexPn 1559 51 12) "v" []]) (ESub (AlexPn 1582 51 35) (EUTEntry (AlexPn 1570 51 23) "gem" [EUTEntry (AlexPn 1574 51 27) "i" [],EUTEntry (AlexPn 1577 51 30) "v" []]) (EUTEntry (AlexPn 1584 51 37) "dink" [])),Rewrite (PEntry (AlexPn 1593 52 5) "dai" [EUTEntry (AlexPn 1597 52 9) "w" []]) (EAdd (AlexPn 1618 52 30) (EUTEntry (AlexPn 1611 52 23) "dai" [EUTEntry (AlexPn 1615 52 27) "w" []]) (EUTEntry (AlexPn 1620 52 32) "ilks" [EUTEntry (AlexPn 1625 52 37) "i" [],EMul (AlexPn 1633 52 45) (EUTEntry (AlexPn 1628 52 40) "rate" []) (EUTEntry (AlexPn 1635 52 47) "dart" [])])),Rewrite (PEntry (AlexPn 1644 53 5) "debt" []) (EAdd (AlexPn 1669 53 30) (EUTEntry (AlexPn 1662 53 23) "debt" []) (EUTEntry (AlexPn 1671 53 32) "ilks" [EUTEntry (AlexPn 1676 53 37) "i" [],EMul (AlexPn 1684 53 45) (EUTEntry (AlexPn 1679 53 40) "rate" []) (EUTEntry (AlexPn 1686 53 47) "dart" [])]))] [] Nothing)) []]
+[Transition "frob" "Vat" frob(bytes32 i, address u, address v, address w, int256 dink, int256 dart) [IffIn (AlexPn 546 20 1) uint256 [EUTEntry (AlexPn 572 22 5) "urns" [EUTEntry (AlexPn 577 22 10) "i" [],EUTEntry (AlexPn 580 22 13) "u" [],EAdd (AlexPn 587 22 20) (EUTEntry (AlexPn 583 22 16) "ink" []) (EUTEntry (AlexPn 589 22 22) "dink" [])],EUTEntry (AlexPn 598 23 5) "urns" [EUTEntry (AlexPn 603 23 10) "i" [],EUTEntry (AlexPn 606 23 13) "u" [],EAdd (AlexPn 613 23 20) (EUTEntry (AlexPn 609 23 16) "art" []) (EUTEntry (AlexPn 615 23 22) "dart" [])],EUTEntry (AlexPn 624 24 5) "ilks" [EUTEntry (AlexPn 629 24 10) "i" [],EAdd (AlexPn 639 24 20) (EUTEntry (AlexPn 632 24 13) "Art" []) (EUTEntry (AlexPn 641 24 22) "dart" [])],EMul (AlexPn 671 25 26) (EUTEntry (AlexPn 651 25 6) "ilks" [EUTEntry (AlexPn 656 25 11) "i" [],EAdd (AlexPn 663 25 18) (EUTEntry (AlexPn 659 25 14) "Art" []) (EUTEntry (AlexPn 665 25 20) "dart" [])]) (EUTEntry (AlexPn 673 25 28) "ilks" [EUTEntry (AlexPn 678 25 33) "i" [],EUTEntry (AlexPn 681 25 36) "rate" []]),EAdd (AlexPn 697 26 12) (EUTEntry (AlexPn 690 26 5) "dai" [EUTEntry (AlexPn 694 26 9) "w" []]) (EUTEntry (AlexPn 700 26 15) "ilks" [EUTEntry (AlexPn 705 26 20) "i" [],EMul (AlexPn 713 26 28) (EUTEntry (AlexPn 708 26 23) "rate" []) (EUTEntry (AlexPn 715 26 30) "dart" [])]),EAdd (AlexPn 730 27 10) (EUTEntry (AlexPn 725 27 5) "debt" []) (EUTEntry (AlexPn 733 27 13) "ilks" [EUTEntry (AlexPn 738 27 18) "i" [],EMul (AlexPn 746 27 26) (EUTEntry (AlexPn 741 27 21) "rate" []) (EUTEntry (AlexPn 748 27 28) "dart" [])])],IffIn (AlexPn 755 29 1) int256 [EUTEntry (AlexPn 780 31 5) "ilks" [EUTEntry (AlexPn 785 31 10) "i" [],EUTEntry (AlexPn 788 31 13) "rate" []],EUTEntry (AlexPn 797 32 5) "ilks" [EUTEntry (AlexPn 802 32 10) "i" [],EMul (AlexPn 810 32 18) (EUTEntry (AlexPn 805 32 13) "rate" []) (EUTEntry (AlexPn 812 32 20) "dart" [])]],Iff (AlexPn 818 34 1) [EEq (AlexPn 836 35 15) (EnvExp (AlexPn 826 35 5) Callvalue) (IntLit (AlexPn 839 35 18) 0),EEq (AlexPn 850 36 10) (EUTEntry (AlexPn 845 36 5) "live" []) (IntLit (AlexPn 853 36 13) 1),EUTEntry (AlexPn 859 37 5) "ilks" [EUTEntry (AlexPn 864 37 10) "i" [],ENeq (AlexPn 872 37 18) (EUTEntry (AlexPn 867 37 13) "rate" []) (IntLit (AlexPn 876 37 22) 0)],EOr (AlexPn 892 38 15) (ELEQ (AlexPn 887 38 10) (EUTEntry (AlexPn 882 38 5) "dart" []) (IntLit (AlexPn 890 38 13) 0)) (EMul (AlexPn 917 38 40) (EUTEntry (AlexPn 897 38 20) "ilks" [EUTEntry (AlexPn 902 38 25) "i" [],EAdd (AlexPn 909 38 32) (EUTEntry (AlexPn 905 38 28) "art" []) (EUTEntry (AlexPn 911 38 34) "dart" [])]) (EUTEntry (AlexPn 919 38 42) "ilks" [EUTEntry (AlexPn 924 38 47) "i" [],ELEQ (AlexPn 932 38 55) (EUTEntry (AlexPn 927 38 50) "rate" []) (EUTEntry (AlexPn 935 38 58) "ilks" [EUTEntry (AlexPn 940 38 63) "i" [],EAnd (AlexPn 948 38 71) (EUTEntry (AlexPn 943 38 66) "line" []) (EAdd (AlexPn 957 38 80) (EUTEntry (AlexPn 952 38 75) "debt" []) (EUTEntry (AlexPn 959 38 82) "ilks" [EUTEntry (AlexPn 964 38 87) "i" [],ELEQ (AlexPn 979 38 102) (EMul (AlexPn 972 38 95) (EUTEntry (AlexPn 967 38 90) "rate" []) (EUTEntry (AlexPn 974 38 97) "dart" [])) (EUTEntry (AlexPn 982 38 105) "line" [])]))])])),EOr (AlexPn 1004 39 17) (ELEQ (AlexPn 998 39 11) (EUTEntry (AlexPn 993 39 6) "dart" []) (IntLit (AlexPn 1001 39 14) 0)) (EAnd (AlexPn 1062 39 75) (EMul (AlexPn 1030 39 43) (EUTEntry (AlexPn 1010 39 23) "ilks" [EUTEntry (AlexPn 1015 39 28) "i" [],EAdd (AlexPn 1022 39 35) (EUTEntry (AlexPn 1018 39 31) "Art" []) (EUTEntry (AlexPn 1024 39 37) "dart" [])]) (EUTEntry (AlexPn 1032 39 45) "ilks" [EUTEntry (AlexPn 1037 39 50) "i" [],ELEQ (AlexPn 1045 39 58) (EUTEntry (AlexPn 1040 39 53) "rate" []) (EUTEntry (AlexPn 1048 39 61) "ilks" [EUTEntry (AlexPn 1053 39 66) "i" [],EUTEntry (AlexPn 1056 39 69) "line" []])])) (ELEQ (AlexPn 1096 39 109) (EAdd (AlexPn 1073 39 86) (EUTEntry (AlexPn 1068 39 81) "debt" []) (EUTEntry (AlexPn 1075 39 88) "ilks" [EUTEntry (AlexPn 1080 39 93) "i" [],EMul (AlexPn 1088 39 101) (EUTEntry (AlexPn 1083 39 96) "rate" []) (EUTEntry (AlexPn 1090 39 103) "dart" [])])) (EUTEntry (AlexPn 1099 39 112) "line" []))),EOr (AlexPn 1136 40 31) (EAnd (AlexPn 1121 40 16) (ELEQ (AlexPn 1116 40 11) (EUTEntry (AlexPn 1111 40 6) "dart" []) (IntLit (AlexPn 1119 40 14) 0)) (EGEQ (AlexPn 1130 40 25) (EUTEntry (AlexPn 1125 40 20) "dink" []) (IntLit (AlexPn 1133 40 28) 0))) (ELEQ (AlexPn 1181 40 76) (EMul (AlexPn 1165 40 60) (EUTEntry (AlexPn 1142 40 37) "urns" [EUTEntry (AlexPn 1147 40 42) "i" [],EUTEntry (AlexPn 1150 40 45) "u" [],EAdd (AlexPn 1157 40 52) (EUTEntry (AlexPn 1153 40 48) "art" []) (EUTEntry (AlexPn 1159 40 54) "dart" [])]) (EUTEntry (AlexPn 1167 40 62) "ilks" [EUTEntry (AlexPn 1172 40 67) "i" [],EUTEntry (AlexPn 1175 40 70) "rate" []])) (EMul (AlexPn 1209 40 104) (EUTEntry (AlexPn 1186 40 81) "urns" [EUTEntry (AlexPn 1191 40 86) "i" [],EUTEntry (AlexPn 1194 40 89) "u" [],EAdd (AlexPn 1201 40 96) (EUTEntry (AlexPn 1197 40 92) "ink" []) (EUTEntry (AlexPn 1203 40 98) "dink" [])]) (EUTEntry (AlexPn 1211 40 106) "ilks" [EUTEntry (AlexPn 1216 40 111) "i" [],EUTEntry (AlexPn 1219 40 114) "spot" []]))),EOr (AlexPn 1256 41 31) (EAnd (AlexPn 1241 41 16) (ELEQ (AlexPn 1236 41 11) (EUTEntry (AlexPn 1231 41 6) "dart" []) (IntLit (AlexPn 1239 41 14) 0)) (EGEQ (AlexPn 1250 41 25) (EUTEntry (AlexPn 1245 41 20) "dink" []) (IntLit (AlexPn 1253 41 28) 0))) (EOr (AlexPn 1272 41 47) (EEq (AlexPn 1262 41 37) (EUTEntry (AlexPn 1260 41 35) "u" []) (EnvExp (AlexPn 1265 41 40) Caller)) (EEq (AlexPn 1290 41 65) (EUTEntry (AlexPn 1275 41 50) "can" [EUTEntry (AlexPn 1279 41 54) "u" [],EnvExp (AlexPn 1282 41 57) Caller]) (IntLit (AlexPn 1293 41 68) 1))),EOr (AlexPn 1313 43 17) (ELEQ (AlexPn 1307 43 11) (EUTEntry (AlexPn 1302 43 6) "dink" []) (IntLit (AlexPn 1310 43 14) 0)) (EOr (AlexPn 1329 43 33) (EEq (AlexPn 1319 43 23) (EUTEntry (AlexPn 1317 43 21) "v" []) (EnvExp (AlexPn 1322 43 26) Caller)) (EEq (AlexPn 1347 43 51) (EUTEntry (AlexPn 1332 43 36) "Can" [EUTEntry (AlexPn 1336 43 40) "v" [],EnvExp (AlexPn 1339 43 43) Caller]) (IntLit (AlexPn 1350 43 54) 1))),EOr (AlexPn 1369 44 17) (EGEQ (AlexPn 1363 44 11) (EUTEntry (AlexPn 1358 44 6) "dart" []) (IntLit (AlexPn 1366 44 14) 0)) (EOr (AlexPn 1385 44 33) (EEq (AlexPn 1375 44 23) (EUTEntry (AlexPn 1373 44 21) "w" []) (EnvExp (AlexPn 1378 44 26) Caller)) (EEq (AlexPn 1403 44 51) (EUTEntry (AlexPn 1388 44 36) "Can" [EUTEntry (AlexPn 1392 44 40) "w" [],EnvExp (AlexPn 1395 44 43) Caller]) (IntLit (AlexPn 1406 44 54) 1)))]] (Direct (Post [Constant (PEntry (AlexPn 1423 48 5) "urns" [EUTEntry (AlexPn 1428 48 10) "i" [],EUTEntry (AlexPn 1431 48 13) "u" [],EImpl (AlexPn 1438 48 20) (EUTEntry (AlexPn 1434 48 16) "ink" []) (EUTEntry (AlexPn 1441 48 23) "urns" [EUTEntry (AlexPn 1446 48 28) "i" [],EUTEntry (AlexPn 1449 48 31) "u" [],EAdd (AlexPn 1456 48 38) (EUTEntry (AlexPn 1452 48 34) "ink" []) (EUTEntry (AlexPn 1458 48 40) "dink" [])])]),Constant (PEntry (AlexPn 1467 49 5) "urns" [EUTEntry (AlexPn 1472 49 10) "i" [],EUTEntry (AlexPn 1475 49 13) "u" [],EImpl (AlexPn 1482 49 20) (EUTEntry (AlexPn 1478 49 16) "art" []) (EUTEntry (AlexPn 1485 49 23) "urns" [EUTEntry (AlexPn 1490 49 28) "i" [],EUTEntry (AlexPn 1493 49 31) "u" [],EAdd (AlexPn 1500 49 38) (EUTEntry (AlexPn 1496 49 34) "art" []) (EUTEntry (AlexPn 1502 49 40) "dart" [])])]),Constant (PEntry (AlexPn 1511 50 5) "ilks" [EUTEntry (AlexPn 1516 50 10) "i" [],EImpl (AlexPn 1526 50 20) (EUTEntry (AlexPn 1519 50 13) "Art" []) (EUTEntry (AlexPn 1529 50 23) "ilks" [EUTEntry (AlexPn 1534 50 28) "i" [],EAdd (AlexPn 1541 50 35) (EUTEntry (AlexPn 1537 50 31) "Art" []) (EUTEntry (AlexPn 1543 50 37) "dart" [])])]),Rewrite (PEntry (AlexPn 1552 51 5) "gem" [EUTEntry (AlexPn 1556 51 9) "i" [],EUTEntry (AlexPn 1559 51 12) "v" []]) (ESub (AlexPn 1582 51 35) (EUTEntry (AlexPn 1570 51 23) "gem" [EUTEntry (AlexPn 1574 51 27) "i" [],EUTEntry (AlexPn 1577 51 30) "v" []]) (EUTEntry (AlexPn 1584 51 37) "dink" [])),Rewrite (PEntry (AlexPn 1593 52 5) "dai" [EUTEntry (AlexPn 1597 52 9) "w" []]) (EAdd (AlexPn 1618 52 30) (EUTEntry (AlexPn 1611 52 23) "dai" [EUTEntry (AlexPn 1615 52 27) "w" []]) (EUTEntry (AlexPn 1620 52 32) "ilks" [EUTEntry (AlexPn 1625 52 37) "i" [],EMul (AlexPn 1633 52 45) (EUTEntry (AlexPn 1628 52 40) "rate" []) (EUTEntry (AlexPn 1635 52 47) "dart" [])])),Rewrite (PEntry (AlexPn 1644 53 5) "debt" []) (EAdd (AlexPn 1669 53 30) (EUTEntry (AlexPn 1662 53 23) "debt" []) (EUTEntry (AlexPn 1671 53 32) "ilks" [EUTEntry (AlexPn 1676 53 37) "i" [],EMul (AlexPn 1684 53 45) (EUTEntry (AlexPn 1679 53 40) "rate" []) (EUTEntry (AlexPn 1686 53 47) "dart" [])]))] [] Nothing)) []]
diff --git a/tests/frontend/pass/multi/multi.act.parsed.hs b/tests/frontend/pass/multi/multi.act.parsed.hs
index 31051583..23997bbe 100644
--- a/tests/frontend/pass/multi/multi.act.parsed.hs
+++ b/tests/frontend/pass/multi/multi.act.parsed.hs
@@ -1 +1 @@
-[Definition (AlexPn 15 1 16) "a" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 58 5 9) uint256 "x") (IntLit (AlexPn 63 5 14) 0)]) [] [] [],Definition (AlexPn 81 7 16) "B" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 124 11 9) uint256 "y") (IntLit (AlexPn 129 11 14) 0)]) [] [] [],Transition (AlexPn 143 14 11) "remote" "B" set_remote(uint256 z) [Iff (AlexPn 185 17 1) [EEq (AlexPn 202 18 14) (EnvExp (AlexPn 192 18 4) Callvalue) (IntLit (AlexPn 205 18 17) 0)]] (Direct (Post [] [ExtStorage "a" [Rewrite (PEntry (AlexPn 373 24 4) "x" []) (EUTEntry (AlexPn 378 24 9) "z" [])]] Nothing)) [],Transition (AlexPn 391 26 11) "multi" "B" set_remote(uint256 z) [Iff (AlexPn 432 29 1) [EEq (AlexPn 449 30 14) (EnvExp (AlexPn 439 30 4) Callvalue) (IntLit (AlexPn 452 30 17) 0)]] (Direct (Post [Rewrite (PEntry (AlexPn 520 34 4) "y" []) (IntLit (AlexPn 525 34 9) 1)] [ExtStorage "a" [Rewrite (PEntry (AlexPn 544 37 4) "x" []) (EUTEntry (AlexPn 549 37 9) "z" [])]] Nothing)) []]
+[Definition (AlexPn 15 1 16) "a" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 58 5 9) uint256 "x") (IntLit (AlexPn 63 5 14) 0)]) [] [] [],Definition (AlexPn 81 7 16) "B" constructor() [] (Creates [AssignVal (StorageVar (AlexPn 124 11 9) uint256 "y") (IntLit (AlexPn 129 11 14) 0)]) [] [] [],Transition "remote" "B" set_remote(uint256 z) [Iff (AlexPn 185 17 1) [EEq (AlexPn 202 18 14) (EnvExp (AlexPn 192 18 4) Callvalue) (IntLit (AlexPn 205 18 17) 0)]] (Direct (Post [] [ExtStorage "a" [Rewrite (PEntry (AlexPn 373 24 4) "x" []) (EUTEntry (AlexPn 378 24 9) "z" [])]] Nothing)) [],Transition "multi" "B" set_remote(uint256 z) [Iff (AlexPn 432 29 1) [EEq (AlexPn 449 30 14) (EnvExp (AlexPn 439 30 4) Callvalue) (IntLit (AlexPn 452 30 17) 0)]] (Direct (Post [Rewrite (PEntry (AlexPn 520 34 4) "y" []) (IntLit (AlexPn 525 34 9) 1)] [ExtStorage "a" [Rewrite (PEntry (AlexPn 544 37 4) "x" []) (EUTEntry (AlexPn 549 37 9) "z" [])]] Nothing)) []]
diff --git a/tests/frontend/pass/safemath/safemathraw.act.parsed.hs b/tests/frontend/pass/safemath/safemathraw.act.parsed.hs
index 221ce095..77130317 100644
--- a/tests/frontend/pass/safemath/safemathraw.act.parsed.hs
+++ b/tests/frontend/pass/safemath/safemathraw.act.parsed.hs
@@ -1 +1 @@
-[Transition (AlexPn 10 1 11) "add" "SafeAdd" add(uint256 x, uint256 y) [IffIn (AlexPn 62 4 1) uint256 [EAdd (AlexPn 90 6 7) (EUTEntry (AlexPn 88 6 5) "x" []) (EUTEntry (AlexPn 92 6 9) "y" [])],Iff (AlexPn 95 8 1) [EEq (AlexPn 114 10 15) (EnvExp (AlexPn 104 10 5) Callvalue) (IntLit (AlexPn 117 10 18) 0)]] (Direct (Post [] [] (Just (EAdd (AlexPn 130 12 11) (EUTEntry (AlexPn 128 12 9) "x" []) (EUTEntry (AlexPn 132 12 13) "y" []))))) []]
+[Transition "add" "SafeAdd" add(uint256 x, uint256 y) [IffIn (AlexPn 62 4 1) uint256 [EAdd (AlexPn 90 6 7) (EUTEntry (AlexPn 88 6 5) "x" []) (EUTEntry (AlexPn 92 6 9) "y" [])],Iff (AlexPn 95 8 1) [EEq (AlexPn 114 10 15) (EnvExp (AlexPn 104 10 5) Callvalue) (IntLit (AlexPn 117 10 18) 0)]] (Direct (Post [] [] (Just (EAdd (AlexPn 130 12 11) (EUTEntry (AlexPn 128 12 9) "x" []) (EUTEntry (AlexPn 132 12 13) "y" []))))) []]
diff --git a/tests/frontend/pass/smoke/smoke.act.parsed.hs b/tests/frontend/pass/smoke/smoke.act.parsed.hs
index dad23e13..aab798f5 100644
--- a/tests/frontend/pass/smoke/smoke.act.parsed.hs
+++ b/tests/frontend/pass/smoke/smoke.act.parsed.hs
@@ -1 +1 @@
-[Transition (AlexPn 10 1 11) "f" "A" f(uint256 x) [] (Direct (Post [] [] (Just (IntLit (AlexPn 46 4 9) 1)))) []]
+[Transition "f" "A" f(uint256 x) [] (Direct (Post [] [] (Just (IntLit (AlexPn 46 4 9) 1)))) []]
diff --git a/tests/frontend/pass/staticstore/staticstore.act.parsed.hs b/tests/frontend/pass/staticstore/staticstore.act.parsed.hs
index e6a3614d..5679ee77 100644
--- a/tests/frontend/pass/staticstore/staticstore.act.parsed.hs
+++ b/tests/frontend/pass/staticstore/staticstore.act.parsed.hs
@@ -1 +1 @@
-[Transition (AlexPn 10 1 11) "f" "C" f() [IffIn (AlexPn 32 4 1) uint256 [EAdd (AlexPn 60 6 7) (EUTEntry (AlexPn 58 6 5) "x" []) (EUTEntry (AlexPn 62 6 9) "y" [])]] (Direct (Post [Constant (PEntry (AlexPn 78 10 5) "x" []),Constant (PEntry (AlexPn 85 11 5) "y" [])] [] (Just (EAdd (AlexPn 98 13 11) (EUTEntry (AlexPn 96 13 9) "x" []) (EUTEntry (AlexPn 100 13 13) "y" []))))) []]
+[Transition "f" "C" f() [IffIn (AlexPn 32 4 1) uint256 [EAdd (AlexPn 60 6 7) (EUTEntry (AlexPn 58 6 5) "x" []) (EUTEntry (AlexPn 62 6 9) "y" [])]] (Direct (Post [Constant (PEntry (AlexPn 78 10 5) "x" []),Constant (PEntry (AlexPn 85 11 5) "y" [])] [] (Just (EAdd (AlexPn 98 13 11) (EUTEntry (AlexPn 96 13 9) "x" []) (EUTEntry (AlexPn 100 13 13) "y" []))))) []]
diff --git a/tests/frontend/pass/token/transfer.act.parsed.hs b/tests/frontend/pass/token/transfer.act.parsed.hs
index bcf83569..773aa094 100644
--- a/tests/frontend/pass/token/transfer.act.parsed.hs
+++ b/tests/frontend/pass/token/transfer.act.parsed.hs
@@ -1 +1 @@
-[Definition (AlexPn 15 1 16) "Token" constructor(string _symbol, string _name, string _version, uint256 _totalSupply) [] (Creates [AssignVal (StorageVar (AlexPn 128 6 10) string "name") (EUTEntry (AlexPn 144 6 26) "_name" []),AssignVal (StorageVar (AlexPn 159 7 10) string "symbol") (EUTEntry (AlexPn 175 7 26) "_symbol" []),AssignVal (StorageVar (AlexPn 193 8 11) uint256 "totalSupply") (EUTEntry (AlexPn 208 8 26) "_totalSupply" []),AssignMany (StorageVar (AlexPn 248 9 28) mapping(address => uint256) "balanceOf") [Defn (EnvExp (AlexPn 263 9 43) Caller) (EUTEntry (AlexPn 273 9 53) "_totalSupply" [])],AssignMany (StorageVar (AlexPn 330 10 44) mapping(address => mapping(address => uint256)) "allowance") []]) [] [] [EEq (AlexPn 373 14 15) (EUTEntry (AlexPn 361 14 3) "totalSupply" []) (EUTEntry (AlexPn 376 14 18) "_totalSupply" []),EEq (AlexPn 396 15 8) (EUTEntry (AlexPn 391 15 3) "name" []) (EUTEntry (AlexPn 399 15 11) "_name" []),EEq (AlexPn 414 16 10) (EUTEntry (AlexPn 407 16 3) "symbol" []) (EUTEntry (AlexPn 417 16 13) "_symbol" [])],Transition (AlexPn 437 19 11) "transfer" "Token" transfer(uint256 value, address to) [Iff (AlexPn 502 22 1) [EEq (AlexPn 519 24 13) (EnvExp (AlexPn 509 24 3) Callvalue) (IntLit (AlexPn 522 24 16) 0),ELEQ (AlexPn 532 25 9) (EUTEntry (AlexPn 526 25 3) "value" []) (EUTEntry (AlexPn 535 25 12) "balanceOf" [EnvExp (AlexPn 545 25 22) Caller]),EImpl (AlexPn 569 26 17) (ENeq (AlexPn 562 26 10) (EnvExp (AlexPn 555 26 3) Caller) (EUTEntry (AlexPn 566 26 14) "to" [])) (ELT (AlexPn 594 26 42) (EAdd (AlexPn 586 26 34) (EUTEntry (AlexPn 572 26 20) "balanceOf" [EUTEntry (AlexPn 582 26 30) "to" []]) (EUTEntry (AlexPn 588 26 36) "value" [])) (EExp (AlexPn 597 26 45) (IntLit (AlexPn 596 26 44) 2) (IntLit (AlexPn 598 26 46) 256)))]] (Branches [Case (AlexPn 603 28 1) (ENeq (AlexPn 615 28 13) (EnvExp (AlexPn 608 28 6) Caller) (EUTEntry (AlexPn 619 28 17) "to" [])) (Post [Rewrite (PEntry (AlexPn 640 32 6) "balanceOf" [EnvExp (AlexPn 650 32 16) Caller]) (ESub (AlexPn 679 32 45) (EUTEntry (AlexPn 661 32 27) "balanceOf" [EnvExp (AlexPn 671 32 37) Caller]) (EUTEntry (AlexPn 681 32 47) "value" [])),Rewrite (PEntry (AlexPn 692 33 6) "balanceOf" [EUTEntry (AlexPn 702 33 16) "to" []]) (EAdd (AlexPn 727 33 41) (EUTEntry (AlexPn 713 33 27) "balanceOf" [EUTEntry (AlexPn 723 33 37) "to" []]) (EUTEntry (AlexPn 729 33 43) "value" []))] [] (Just (IntLit (AlexPn 746 35 11) 1))),Case (AlexPn 749 37 1) (EEq (AlexPn 761 37 13) (EnvExp (AlexPn 754 37 6) Caller) (EUTEntry (AlexPn 764 37 16) "to" [])) (Post [Constant (PEntry (AlexPn 784 41 5) "balanceOf" [EnvExp (AlexPn 794 41 15) Caller]),Constant (PEntry (AlexPn 806 42 5) "balanceOf" [EUTEntry (AlexPn 816 42 15) "to" []])] [] (Just (IntLit (AlexPn 831 44 11) 1)))]) [],Transition (AlexPn 845 47 11) "transferFrom" "Token" transferFrom(address src, address dst, uint256 amount) [Iff (AlexPn 930 50 1) [ELEQ (AlexPn 944 52 10) (EUTEntry (AlexPn 937 52 3) "amount" []) (EUTEntry (AlexPn 947 52 13) "balanceOf" [EnvExp (AlexPn 957 52 23) Caller]),EImpl (AlexPn 982 53 18) (ENeq (AlexPn 974 53 10) (EUTEntry (AlexPn 967 53 3) "src" []) (EUTEntry (AlexPn 978 53 14) "dst" [])) (ELT (AlexPn 1009 53 45) (EAdd (AlexPn 1000 53 36) (EUTEntry (AlexPn 985 53 21) "balanceOf" [EUTEntry (AlexPn 995 53 31) "dst" []]) (EUTEntry (AlexPn 1002 53 38) "amount" [])) (EExp (AlexPn 1012 53 48) (IntLit (AlexPn 1011 53 47) 2) (IntLit (AlexPn 1013 53 49) 256))),EImpl (AlexPn 1034 54 18) (ENeq (AlexPn 1026 54 10) (EnvExp (AlexPn 1019 54 3) Caller) (EUTEntry (AlexPn 1030 54 14) "src" [])) (ELEQ (AlexPn 1039 54 23) (IntLit (AlexPn 1037 54 21) 0) (ESub (AlexPn 1065 54 49) (EUTEntry (AlexPn 1042 54 26) "allowance" [EUTEntry (AlexPn 1052 54 36) "src" [],EnvExp (AlexPn 1057 54 41) Caller]) (EUTEntry (AlexPn 1067 54 51) "amount" []))),EEq (AlexPn 1086 55 13) (EnvExp (AlexPn 1076 55 3) Callvalue) (IntLit (AlexPn 1089 55 16) 0)]] (Branches [Case (AlexPn 1092 57 1) (EAnd (AlexPn 1109 57 18) (ENeq (AlexPn 1101 57 10) (EUTEntry (AlexPn 1097 57 6) "src" []) (EUTEntry (AlexPn 1105 57 14) "dst" [])) (EEq (AlexPn 1120 57 29) (EnvExp (AlexPn 1113 57 22) Caller) (EUTEntry (AlexPn 1123 57 32) "src" []))) (Post [Constant (PEntry (AlexPn 1145 61 6) "balanceOf" [EnvExp (AlexPn 1155 61 16) Caller]),Constant (PEntry (AlexPn 1168 62 6) "allowance" [EUTEntry (AlexPn 1178 62 16) "src" [],EnvExp (AlexPn 1183 62 21) Caller]),Rewrite (PEntry (AlexPn 1196 63 6) "balanceOf" [EUTEntry (AlexPn 1206 63 16) "src" []]) (ESub (AlexPn 1229 63 39) (EUTEntry (AlexPn 1214 63 24) "balanceOf" [EUTEntry (AlexPn 1224 63 34) "src" []]) (EUTEntry (AlexPn 1231 63 41) "amount" [])),Rewrite (PEntry (AlexPn 1243 64 6) "balanceOf" [EUTEntry (AlexPn 1253 64 16) "dst" []]) (EAdd (AlexPn 1276 64 39) (EUTEntry (AlexPn 1261 64 24) "balanceOf" [EUTEntry (AlexPn 1271 64 34) "dst" []]) (EUTEntry (AlexPn 1278 64 41) "amount" []))] [] (Just (IntLit (AlexPn 1296 66 11) 1))),Case (AlexPn 1299 68 1) (EAnd (AlexPn 1335 68 37) (EAnd (AlexPn 1316 68 18) (ENeq (AlexPn 1308 68 10) (EUTEntry (AlexPn 1304 68 6) "src" []) (EUTEntry (AlexPn 1312 68 14) "dst" [])) (ENeq (AlexPn 1327 68 29) (EnvExp (AlexPn 1320 68 22) Caller) (EUTEntry (AlexPn 1331 68 33) "src" []))) (EEq (AlexPn 1362 68 64) (EUTEntry (AlexPn 1339 68 41) "allowance" [EUTEntry (AlexPn 1349 68 51) "src" [],EnvExp (AlexPn 1354 68 56) Caller]) (ESub (AlexPn 1371 68 73) (EExp (AlexPn 1366 68 68) (IntLit (AlexPn 1365 68 67) 2) (IntLit (AlexPn 1367 68 69) 256)) (IntLit (AlexPn 1373 68 75) 1)))) (Post [Constant (PEntry (AlexPn 1393 72 6) "balanceOf" [EnvExp (AlexPn 1403 72 16) Caller]),Constant (PEntry (AlexPn 1416 73 6) "allowance" [EUTEntry (AlexPn 1426 73 16) "src" [],EnvExp (AlexPn 1431 73 21) Caller]),Rewrite (PEntry (AlexPn 1444 74 6) "balanceOf" [EUTEntry (AlexPn 1454 74 16) "src" []]) (ESub (AlexPn 1477 74 39) (EUTEntry (AlexPn 1462 74 24) "balanceOf" [EUTEntry (AlexPn 1472 74 34) "src" []]) (EUTEntry (AlexPn 1479 74 41) "amount" [])),Rewrite (PEntry (AlexPn 1491 75 6) "balanceOf" [EUTEntry (AlexPn 1501 75 16) "dst" []]) (EAdd (AlexPn 1524 75 39) (EUTEntry (AlexPn 1509 75 24) "balanceOf" [EUTEntry (AlexPn 1519 75 34) "dst" []]) (EUTEntry (AlexPn 1526 75 41) "amount" []))] [] (Just (IntLit (AlexPn 1544 77 11) 1))),Case (AlexPn 1547 79 1) (EAnd (AlexPn 1583 79 37) (EAnd (AlexPn 1564 79 18) (ENeq (AlexPn 1556 79 10) (EUTEntry (AlexPn 1552 79 6) "src" []) (EUTEntry (AlexPn 1560 79 14) "dst" [])) (ENeq (AlexPn 1575 79 29) (EnvExp (AlexPn 1568 79 22) Caller) (EUTEntry (AlexPn 1579 79 33) "src" []))) (ELT (AlexPn 1610 79 64) (EUTEntry (AlexPn 1587 79 41) "allowance" [EUTEntry (AlexPn 1597 79 51) "src" [],EnvExp (AlexPn 1602 79 56) Caller]) (ESub (AlexPn 1618 79 72) (EExp (AlexPn 1613 79 67) (IntLit (AlexPn 1612 79 66) 2) (IntLit (AlexPn 1614 79 68) 256)) (IntLit (AlexPn 1620 79 74) 1)))) (Post [Constant (PEntry (AlexPn 1639 83 5) "balanceOf" [EnvExp (AlexPn 1649 83 15) Caller]),Rewrite (PEntry (AlexPn 1661 84 5) "allowance" [EUTEntry (AlexPn 1671 84 15) "src" [],EnvExp (AlexPn 1676 84 20) Caller]) (ESub (AlexPn 1710 84 54) (EUTEntry (AlexPn 1687 84 31) "allowance" [EUTEntry (AlexPn 1697 84 41) "src" [],EnvExp (AlexPn 1702 84 46) Caller]) (EUTEntry (AlexPn 1712 84 56) "amount" [])),Rewrite (PEntry (AlexPn 1723 85 5) "balanceOf" [EUTEntry (AlexPn 1733 85 15) "src" []]) (ESub (AlexPn 1764 85 46) (EUTEntry (AlexPn 1749 85 31) "balanceOf" [EUTEntry (AlexPn 1759 85 41) "src" []]) (EUTEntry (AlexPn 1766 85 48) "amount" [])),Rewrite (PEntry (AlexPn 1777 86 5) "balanceOf" [EUTEntry (AlexPn 1787 86 15) "dst" []]) (EAdd (AlexPn 1818 86 46) (EUTEntry (AlexPn 1803 86 31) "balanceOf" [EUTEntry (AlexPn 1813 86 41) "dst" []]) (EUTEntry (AlexPn 1820 86 48) "amount" []))] [] (Just (IntLit (AlexPn 1838 88 11) 1))),Case (AlexPn 1841 90 1) (EEq (AlexPn 1850 90 10) (EUTEntry (AlexPn 1846 90 6) "src" []) (EUTEntry (AlexPn 1853 90 13) "dst" [])) (Post [Constant (PEntry (AlexPn 1875 94 6) "balanceOf" [EnvExp (AlexPn 1885 94 16) Caller]),Constant (PEntry (AlexPn 1898 95 6) "allowance" [EUTEntry (AlexPn 1908 95 16) "src" [],EnvExp (AlexPn 1913 95 21) Caller]),Constant (PEntry (AlexPn 1926 96 6) "balanceOf" [EUTEntry (AlexPn 1936 96 16) "src" []]),Constant (PEntry (AlexPn 1946 97 6) "balanceOf" [EUTEntry (AlexPn 1956 97 16) "dst" []])] [] (Just (IntLit (AlexPn 1972 99 11) 1)))]) []]
+[Definition (AlexPn 15 1 16) "Token" constructor(string _symbol, string _name, string _version, uint256 _totalSupply) [] (Creates [AssignVal (StorageVar (AlexPn 128 6 10) string "name") (EUTEntry (AlexPn 144 6 26) "_name" []),AssignVal (StorageVar (AlexPn 159 7 10) string "symbol") (EUTEntry (AlexPn 175 7 26) "_symbol" []),AssignVal (StorageVar (AlexPn 193 8 11) uint256 "totalSupply") (EUTEntry (AlexPn 208 8 26) "_totalSupply" []),AssignMany (StorageVar (AlexPn 248 9 28) mapping(address => uint256) "balanceOf") [Defn (EnvExp (AlexPn 263 9 43) Caller) (EUTEntry (AlexPn 273 9 53) "_totalSupply" [])],AssignMany (StorageVar (AlexPn 330 10 44) mapping(address => mapping(address => uint256)) "allowance") []]) [] [] [EEq (AlexPn 373 14 15) (EUTEntry (AlexPn 361 14 3) "totalSupply" []) (EUTEntry (AlexPn 376 14 18) "_totalSupply" []),EEq (AlexPn 396 15 8) (EUTEntry (AlexPn 391 15 3) "name" []) (EUTEntry (AlexPn 399 15 11) "_name" []),EEq (AlexPn 414 16 10) (EUTEntry (AlexPn 407 16 3) "symbol" []) (EUTEntry (AlexPn 417 16 13) "_symbol" [])],Transition "transfer" "Token" transfer(uint256 value, address to) [Iff (AlexPn 502 22 1) [EEq (AlexPn 519 24 13) (EnvExp (AlexPn 509 24 3) Callvalue) (IntLit (AlexPn 522 24 16) 0),ELEQ (AlexPn 532 25 9) (EUTEntry (AlexPn 526 25 3) "value" []) (EUTEntry (AlexPn 535 25 12) "balanceOf" [EnvExp (AlexPn 545 25 22) Caller]),EImpl (AlexPn 569 26 17) (ENeq (AlexPn 562 26 10) (EnvExp (AlexPn 555 26 3) Caller) (EUTEntry (AlexPn 566 26 14) "to" [])) (ELT (AlexPn 594 26 42) (EAdd (AlexPn 586 26 34) (EUTEntry (AlexPn 572 26 20) "balanceOf" [EUTEntry (AlexPn 582 26 30) "to" []]) (EUTEntry (AlexPn 588 26 36) "value" [])) (EExp (AlexPn 597 26 45) (IntLit (AlexPn 596 26 44) 2) (IntLit (AlexPn 598 26 46) 256)))]] (Branches [Case (AlexPn 603 28 1) (ENeq (AlexPn 615 28 13) (EnvExp (AlexPn 608 28 6) Caller) (EUTEntry (AlexPn 619 28 17) "to" [])) (Post [Rewrite (PEntry (AlexPn 640 32 6) "balanceOf" [EnvExp (AlexPn 650 32 16) Caller]) (ESub (AlexPn 679 32 45) (EUTEntry (AlexPn 661 32 27) "balanceOf" [EnvExp (AlexPn 671 32 37) Caller]) (EUTEntry (AlexPn 681 32 47) "value" [])),Rewrite (PEntry (AlexPn 692 33 6) "balanceOf" [EUTEntry (AlexPn 702 33 16) "to" []]) (EAdd (AlexPn 727 33 41) (EUTEntry (AlexPn 713 33 27) "balanceOf" [EUTEntry (AlexPn 723 33 37) "to" []]) (EUTEntry (AlexPn 729 33 43) "value" []))] [] (Just (IntLit (AlexPn 746 35 11) 1))),Case (AlexPn 749 37 1) (EEq (AlexPn 761 37 13) (EnvExp (AlexPn 754 37 6) Caller) (EUTEntry (AlexPn 764 37 16) "to" [])) (Post [Constant (PEntry (AlexPn 784 41 5) "balanceOf" [EnvExp (AlexPn 794 41 15) Caller]),Constant (PEntry (AlexPn 806 42 5) "balanceOf" [EUTEntry (AlexPn 816 42 15) "to" []])] [] (Just (IntLit (AlexPn 831 44 11) 1)))]) [],Transition "transferFrom" "Token" transferFrom(address src, address dst, uint256 amount) [Iff (AlexPn 930 50 1) [ELEQ (AlexPn 944 52 10) (EUTEntry (AlexPn 937 52 3) "amount" []) (EUTEntry (AlexPn 947 52 13) "balanceOf" [EnvExp (AlexPn 957 52 23) Caller]),EImpl (AlexPn 982 53 18) (ENeq (AlexPn 974 53 10) (EUTEntry (AlexPn 967 53 3) "src" []) (EUTEntry (AlexPn 978 53 14) "dst" [])) (ELT (AlexPn 1009 53 45) (EAdd (AlexPn 1000 53 36) (EUTEntry (AlexPn 985 53 21) "balanceOf" [EUTEntry (AlexPn 995 53 31) "dst" []]) (EUTEntry (AlexPn 1002 53 38) "amount" [])) (EExp (AlexPn 1012 53 48) (IntLit (AlexPn 1011 53 47) 2) (IntLit (AlexPn 1013 53 49) 256))),EImpl (AlexPn 1034 54 18) (ENeq (AlexPn 1026 54 10) (EnvExp (AlexPn 1019 54 3) Caller) (EUTEntry (AlexPn 1030 54 14) "src" [])) (ELEQ (AlexPn 1039 54 23) (IntLit (AlexPn 1037 54 21) 0) (ESub (AlexPn 1065 54 49) (EUTEntry (AlexPn 1042 54 26) "allowance" [EUTEntry (AlexPn 1052 54 36) "src" [],EnvExp (AlexPn 1057 54 41) Caller]) (EUTEntry (AlexPn 1067 54 51) "amount" []))),EEq (AlexPn 1086 55 13) (EnvExp (AlexPn 1076 55 3) Callvalue) (IntLit (AlexPn 1089 55 16) 0)]] (Branches [Case (AlexPn 1092 57 1) (EAnd (AlexPn 1109 57 18) (ENeq (AlexPn 1101 57 10) (EUTEntry (AlexPn 1097 57 6) "src" []) (EUTEntry (AlexPn 1105 57 14) "dst" [])) (EEq (AlexPn 1120 57 29) (EnvExp (AlexPn 1113 57 22) Caller) (EUTEntry (AlexPn 1123 57 32) "src" []))) (Post [Constant (PEntry (AlexPn 1145 61 6) "balanceOf" [EnvExp (AlexPn 1155 61 16) Caller]),Constant (PEntry (AlexPn 1168 62 6) "allowance" [EUTEntry (AlexPn 1178 62 16) "src" [],EnvExp (AlexPn 1183 62 21) Caller]),Rewrite (PEntry (AlexPn 1196 63 6) "balanceOf" [EUTEntry (AlexPn 1206 63 16) "src" []]) (ESub (AlexPn 1229 63 39) (EUTEntry (AlexPn 1214 63 24) "balanceOf" [EUTEntry (AlexPn 1224 63 34) "src" []]) (EUTEntry (AlexPn 1231 63 41) "amount" [])),Rewrite (PEntry (AlexPn 1243 64 6) "balanceOf" [EUTEntry (AlexPn 1253 64 16) "dst" []]) (EAdd (AlexPn 1276 64 39) (EUTEntry (AlexPn 1261 64 24) "balanceOf" [EUTEntry (AlexPn 1271 64 34) "dst" []]) (EUTEntry (AlexPn 1278 64 41) "amount" []))] [] (Just (IntLit (AlexPn 1296 66 11) 1))),Case (AlexPn 1299 68 1) (EAnd (AlexPn 1335 68 37) (EAnd (AlexPn 1316 68 18) (ENeq (AlexPn 1308 68 10) (EUTEntry (AlexPn 1304 68 6) "src" []) (EUTEntry (AlexPn 1312 68 14) "dst" [])) (ENeq (AlexPn 1327 68 29) (EnvExp (AlexPn 1320 68 22) Caller) (EUTEntry (AlexPn 1331 68 33) "src" []))) (EEq (AlexPn 1362 68 64) (EUTEntry (AlexPn 1339 68 41) "allowance" [EUTEntry (AlexPn 1349 68 51) "src" [],EnvExp (AlexPn 1354 68 56) Caller]) (ESub (AlexPn 1371 68 73) (EExp (AlexPn 1366 68 68) (IntLit (AlexPn 1365 68 67) 2) (IntLit (AlexPn 1367 68 69) 256)) (IntLit (AlexPn 1373 68 75) 1)))) (Post [Constant (PEntry (AlexPn 1393 72 6) "balanceOf" [EnvExp (AlexPn 1403 72 16) Caller]),Constant (PEntry (AlexPn 1416 73 6) "allowance" [EUTEntry (AlexPn 1426 73 16) "src" [],EnvExp (AlexPn 1431 73 21) Caller]),Rewrite (PEntry (AlexPn 1444 74 6) "balanceOf" [EUTEntry (AlexPn 1454 74 16) "src" []]) (ESub (AlexPn 1477 74 39) (EUTEntry (AlexPn 1462 74 24) "balanceOf" [EUTEntry (AlexPn 1472 74 34) "src" []]) (EUTEntry (AlexPn 1479 74 41) "amount" [])),Rewrite (PEntry (AlexPn 1491 75 6) "balanceOf" [EUTEntry (AlexPn 1501 75 16) "dst" []]) (EAdd (AlexPn 1524 75 39) (EUTEntry (AlexPn 1509 75 24) "balanceOf" [EUTEntry (AlexPn 1519 75 34) "dst" []]) (EUTEntry (AlexPn 1526 75 41) "amount" []))] [] (Just (IntLit (AlexPn 1544 77 11) 1))),Case (AlexPn 1547 79 1) (EAnd (AlexPn 1583 79 37) (EAnd (AlexPn 1564 79 18) (ENeq (AlexPn 1556 79 10) (EUTEntry (AlexPn 1552 79 6) "src" []) (EUTEntry (AlexPn 1560 79 14) "dst" [])) (ENeq (AlexPn 1575 79 29) (EnvExp (AlexPn 1568 79 22) Caller) (EUTEntry (AlexPn 1579 79 33) "src" []))) (ELT (AlexPn 1610 79 64) (EUTEntry (AlexPn 1587 79 41) "allowance" [EUTEntry (AlexPn 1597 79 51) "src" [],EnvExp (AlexPn 1602 79 56) Caller]) (ESub (AlexPn 1618 79 72) (EExp (AlexPn 1613 79 67) (IntLit (AlexPn 1612 79 66) 2) (IntLit (AlexPn 1614 79 68) 256)) (IntLit (AlexPn 1620 79 74) 1)))) (Post [Constant (PEntry (AlexPn 1639 83 5) "balanceOf" [EnvExp (AlexPn 1649 83 15) Caller]),Rewrite (PEntry (AlexPn 1661 84 5) "allowance" [EUTEntry (AlexPn 1671 84 15) "src" [],EnvExp (AlexPn 1676 84 20) Caller]) (ESub (AlexPn 1710 84 54) (EUTEntry (AlexPn 1687 84 31) "allowance" [EUTEntry (AlexPn 1697 84 41) "src" [],EnvExp (AlexPn 1702 84 46) Caller]) (EUTEntry (AlexPn 1712 84 56) "amount" [])),Rewrite (PEntry (AlexPn 1723 85 5) "balanceOf" [EUTEntry (AlexPn 1733 85 15) "src" []]) (ESub (AlexPn 1764 85 46) (EUTEntry (AlexPn 1749 85 31) "balanceOf" [EUTEntry (AlexPn 1759 85 41) "src" []]) (EUTEntry (AlexPn 1766 85 48) "amount" [])),Rewrite (PEntry (AlexPn 1777 86 5) "balanceOf" [EUTEntry (AlexPn 1787 86 15) "dst" []]) (EAdd (AlexPn 1818 86 46) (EUTEntry (AlexPn 1803 86 31) "balanceOf" [EUTEntry (AlexPn 1813 86 41) "dst" []]) (EUTEntry (AlexPn 1820 86 48) "amount" []))] [] (Just (IntLit (AlexPn 1838 88 11) 1))),Case (AlexPn 1841 90 1) (EEq (AlexPn 1850 90 10) (EUTEntry (AlexPn 1846 90 6) "src" []) (EUTEntry (AlexPn 1853 90 13) "dst" [])) (Post [Constant (PEntry (AlexPn 1875 94 6) "balanceOf" [EnvExp (AlexPn 1885 94 16) Caller]),Constant (PEntry (AlexPn 1898 95 6) "allowance" [EUTEntry (AlexPn 1908 95 16) "src" [],EnvExp (AlexPn 1913 95 21) Caller]),Constant (PEntry (AlexPn 1926 96 6) "balanceOf" [EUTEntry (AlexPn 1936 96 16) "src" []]),Constant (PEntry (AlexPn 1946 97 6) "balanceOf" [EUTEntry (AlexPn 1956 97 16) "dst" []])] [] (Just (IntLit (AlexPn 1972 99 11) 1)))]) []]

From 6c0d335628a4ec84493edf6ee378031092fa08f7 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Tue, 2 Nov 2021 13:09:54 +0100
Subject: [PATCH 30/36] `MType` patterns and clearer `metaType` implementation

---
 src/Syntax/Types.hs | 20 +++++++++++++-------
 1 file changed, 13 insertions(+), 7 deletions(-)

diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index 1bebf7fe..5345dcab 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -27,8 +27,14 @@ import Data.ByteString    as Syntax.Types (ByteString)
 import EVM.ABI            as Syntax.Types (AbiType(..))
 
 type MType = SomeSing *
+
+pattern Integer :: MType
 pattern Integer = SomeSing SInteger
+
+pattern Boolean :: MType
 pattern Boolean = SomeSing SBoolean
+
+pattern ByteStr :: MType
 pattern ByteStr = SomeSing SByteStr
 
 -- | Singleton types of the types understood by proving tools.
@@ -54,13 +60,13 @@ class HasType a t where
   getType :: a -> SType t
 
 metaType :: AbiType -> MType
-metaType (AbiUIntType _)     = SomeSing SInteger
-metaType (AbiIntType  _)     = SomeSing SInteger
-metaType AbiAddressType      = SomeSing SInteger
-metaType AbiBoolType         = SomeSing SBoolean
-metaType (AbiBytesType n)    = if n <= 32 then SomeSing SInteger else SomeSing SByteStr
-metaType AbiBytesDynamicType = SomeSing SByteStr
-metaType AbiStringType       = SomeSing SByteStr
+metaType (AbiUIntType _)     = Integer
+metaType (AbiIntType  _)     = Integer
+metaType AbiAddressType      = Integer
+metaType AbiBoolType         = Boolean
+metaType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
+metaType AbiBytesDynamicType = ByteStr
+metaType AbiStringType       = ByteStr
 --metaType (AbiArrayDynamicType a) =
 --metaType (AbiArrayType        Int AbiType
 --metaType (AbiTupleType        (Vector AbiType)

From 7031b201aa372f751460eb0b4e1e7585ddd21faf Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Wed, 10 Nov 2021 17:24:11 +0100
Subject: [PATCH 31/36] simplifications, fewer constraints, COMPLETE patterns,
 ...

---
 src/SMT.hs                 | 51 ++++++++++++++------------------------
 src/Syntax/TimeAgnostic.hs | 34 ++++++++-----------------
 src/Syntax/Types.hs        | 24 ++++++++++--------
 3 files changed, 43 insertions(+), 66 deletions(-)

diff --git a/src/SMT.hs b/src/SMT.hs
index a3eb2b3d..badd5cbf 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MonadComprehensions #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 
 module SMT (
   Solver(..),
@@ -438,28 +439,21 @@ getCtorModel ctor solver = do
 -- | Gets a concrete value from the solver for the given storage location
 getStorageValue :: SolverInstance -> Id -> When -> StorageLocation -> IO (StorageLocation, TypedExp)
 getStorageValue solver ifaceName whn loc@(Loc typ _) = do
-  let name = if isMapping loc
-                then withInterface ifaceName
-                     $ select
-                        (nameFromLoc whn loc)
-                        (NonEmpty.fromList $ ixsFromLocation loc)
-                else nameFromLoc whn loc
   output <- getValue solver name
   -- TODO: handle errors here...
-  let val = case typ of
-              SInteger -> parseIntModel output
-              SBoolean -> parseBoolModel output
-              SByteStr -> parseBytesModel output
-  pure (loc, val)
+  pure (loc, parseModel typ output)
+  where
+    name = if isMapping loc
+            then withInterface ifaceName
+                 $ select
+                    (nameFromLoc whn loc)
+                    (NonEmpty.fromList $ ixsFromLocation loc)
+            else nameFromLoc whn loc
 
 -- | Gets a concrete value from the solver for the given calldata argument
 getCalldataValue :: SolverInstance -> Id -> Decl -> IO (Decl, TypedExp)
-getCalldataValue solver ifaceName decl@(Decl tp _) = do
-  output <- getValue solver $ nameFromDecl ifaceName decl
-  let val = case metaType tp of
-              Integer -> parseIntModel output
-              Boolean -> parseBoolModel output
-              ByteStr -> parseBytesModel output
+getCalldataValue solver ifaceName decl@(Decl (FromAbi tp) _) = do
+  val <- parseModel tp <$> getValue solver (nameFromDecl ifaceName decl)
   pure (decl, val)
 
 -- | Gets a concrete value from the solver for the given environment variable
@@ -467,32 +461,25 @@ getEnvironmentValue :: SolverInstance -> EthEnv -> IO (EthEnv, TypedExp)
 getEnvironmentValue solver env = do
   output <- getValue solver (prettyEnv env)
   let val = case lookup env defaultStore of
-              Just Integer -> parseIntModel output
-              Just Boolean -> parseBoolModel output
-              Just ByteStr -> parseBytesModel output
-              Nothing -> error $ "Internal Error: could not determine a type for" <> show env
+        Just (FromMeta typ) -> parseModel typ output
+        _ -> error $ "Internal Error: could not determine a type for" <> show env
   pure (env, val)
 
 -- | Calls `(get-value)` for the given identifier in the given solver instance.
 getValue :: SolverInstance -> String -> IO String
 getValue solver name = sendCommand solver $ "(get-value (" <> name <> "))"
 
--- | Parse the result of a call to getValue as an Int
-parseIntModel :: String -> TypedExp
-parseIntModel = _TExp . LitInt . read . parseSMTModel
-
--- | Parse the result of a call to getValue as a Bool
-parseBoolModel :: String -> TypedExp
-parseBoolModel = _TExp . LitBool . readBool . parseSMTModel
+-- | Parse the result of a call to getValue as the supplied type.
+parseModel :: SType a -> String -> TypedExp
+parseModel = \case
+  SInteger -> _TExp . LitInt  . read       . parseSMTModel
+  SBoolean -> _TExp . LitBool . readBool   . parseSMTModel
+  SByteStr -> _TExp . ByLit   . fromString . parseSMTModel
   where
     readBool "true" = True
     readBool "false" = False
     readBool s = error ("Could not parse " <> s <> "into a bool")
 
--- | Parse the result of a call to getValue as a Bytes
-parseBytesModel :: String -> TypedExp
-parseBytesModel = _TExp . ByLit . fromString . parseSMTModel
-
 -- | Extracts a string representation of the value in the output from a call to `(get-value)`
 parseSMTModel :: String -> String
 parseSMTModel s = if length s0Caps == 1
diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 71f181ce..6fed7d52 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -35,7 +35,7 @@ import Data.Aeson.Types
 import qualified Data.ByteString as BS
 import Data.List (genericTake,genericDrop)
 import Data.Map.Strict (Map)
-import Data.Singletons
+import Data.Singletons (SingI(..))
 import Data.String (fromString)
 import Data.Text (pack)
 import Data.Typeable
@@ -127,18 +127,14 @@ data Rewrite t
   deriving (Show, Eq)
 
 data StorageUpdate t
-  = forall a. Typeable a => Update (SType a) (TStorageItem a t) (Exp a t)
+  = forall a. Update (SType a) (TStorageItem a t) (Exp a t)
 deriving instance Show (StorageUpdate t)
 
-_Update :: Typeable a => TStorageItem a t -> Exp a t -> StorageUpdate t
+_Update :: TStorageItem a t -> Exp a t -> StorageUpdate t
 _Update item expr = Update (getType item) item expr
 
 instance Eq (StorageUpdate t) where
-  Update Sing i1 e1 == Update Sing i2 e2 = eqS i1 i2 && eqS e1 e2
-  u1 == u2 = error $ "Internal error: No singleton in StorageUpdate"
-                  <> "\nUpdate 1: " <> show u1
-                  <> "\nUpdate 2: " <> show u2
-  -- Ugly, stupid, but otherwise GHC compains about incomplete pattern...
+  Update SType i1 e1 == Update SType i2 e2 = eqS i1 i2 && eqS e1 e2
 
 data StorageLocation t
   = forall a. Loc (SType a) (TStorageItem a t)
@@ -148,11 +144,7 @@ _Loc :: TStorageItem a t -> StorageLocation t
 _Loc item = Loc (getType item) item
 
 instance Eq (StorageLocation t) where
-  Loc Sing i1 == Loc Sing i2 = eqS i1 i2
-  l1 == l2 = error $ "Internal error: No singleton in StorageLocation"
-                  <> "\nLocation 1: " <> show l1
-                  <> "\nLocation 2: " <> show l2
-  -- Ugly, stupid, but otherwise GHC compains about incomplete pattern...
+  Loc SType i1 == Loc SType i2 = eqS i1 i2
 
 -- | References to items in storage, either as a map lookup or as a reading of
 -- a simple variable. The third argument is a list of indices; it has entries iff
@@ -174,20 +166,16 @@ instance HasType (TStorageItem a t) a where
 
 -- | Expressions for which the return type is known.
 data TypedExp t
-  = forall a. Typeable a => TExp (SType a) (Exp a t)
+  = forall a. TExp (SType a) (Exp a t)
 deriving instance Show (TypedExp t)
 
 -- We could remove the 'SingI' constraint here if we also removed it from the
 -- 'HasType' instance for 'Exp'. But it's tedious and noisy and atm unnecessary.
-_TExp :: (Typeable a, SingI a) => Exp a t -> TypedExp t
+_TExp :: SingI a => Exp a t -> TypedExp t
 _TExp expr = TExp (getType expr) expr
 
 instance Eq (TypedExp t) where
-  TExp Sing e1 == TExp Sing e2 = eqS e1 e2
-  e1 == e2 = error $ "Internal error: No singleton in TypedExp"
-                  <> "\nExp 1: " <> show e1
-                  <> "\nExp 2: " <> show e2
-  -- Ugly, stupid, but otherwise GHC compains about incomplete pattern...
+  TExp SType e1 == TExp SType e2 = eqS e1 e2
 
 -- | Expressions parametrized by a timing `t` and a type `a`. `t` can be either `Timed` or `Untimed`.
 -- All storage entries within an `Exp a t` contain a value of type `Time t`.
@@ -233,7 +221,7 @@ data Exp (a :: *) (t :: Timing) where
   Eq  :: (Eq a, Typeable a) => Exp a t -> Exp a t -> Exp Bool t
   NEq :: (Eq a, Typeable a) => Exp a t -> Exp a t -> Exp Bool t
   ITE :: Exp Bool t -> Exp a t -> Exp a t -> Exp a t
-  Var :: Sing a -> Id -> Exp a t
+  Var :: SType a -> Id -> Exp a t
   TEntry :: Time t -> TStorageItem a t -> Exp a t
 deriving instance Show (Exp a t)
 
@@ -405,7 +393,7 @@ instance ToJSON (StorageLocation t) where
   toJSON (Loc _ a) = object ["location" .= toJSON a]
 
 instance ToJSON (StorageUpdate t) where
-  toJSON (Update _ a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
+  toJSON (Update SType a b) = object ["location" .= toJSON a ,"value" .= toJSON b]
 
 instance ToJSON (TStorageItem a t) where
   toJSON (Item t a b []) = object ["sort" .= pack (show t)
@@ -421,7 +409,7 @@ instance ToJSON (TypedExp t) where
   toJSON (TExp typ a) = object ["sort"       .= pack (show typ)
                                ,"expression" .= toJSON a]
 
-instance Typeable a => ToJSON (Exp a t) where
+instance ToJSON (Exp a t) where
   toJSON (Add a b) = symbol "+" a b
   toJSON (Sub a b) = symbol "-" a b
   toJSON (Exp a b) = symbol "^" a b
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index 5345dcab..ec328700 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -19,6 +19,7 @@ Description : Types that represent Act types, and functions and patterns to go b
 module Syntax.Types (module Syntax.Types) where
 
 import Data.Singletons
+import Data.Tuple.Extra (dupe)
 import Data.Type.Equality (TestEquality(..))
 import Data.Typeable hiding (TypeRep,typeRep)
 import Type.Reflection
@@ -37,6 +38,8 @@ pattern Boolean = SomeSing SBoolean
 pattern ByteStr :: MType
 pattern ByteStr = SomeSing SByteStr
 
+{-# COMPLETE Integer, Boolean, ByteStr #-}
+
 -- | Singleton types of the types understood by proving tools.
 data SType a where
   SInteger :: SType Integer
@@ -51,7 +54,7 @@ instance Show (SType a) where
     SByteStr -> "bytestring"
 
 instance TestEquality SType where
-  testEquality STypeable STypeable = eqT
+  testEquality SType SType = eqT
 
 eqS :: forall (a :: *) (b :: *) f t. (SingI a, SingI b, Eq (f a t)) => f a t -> f b t -> Bool
 eqS fa fb = maybe False (\Refl -> fa == fb) $ testEquality (sing @a) (sing @b)
@@ -85,21 +88,20 @@ instance SingI Integer    where sing = SInteger
 instance SingI Bool       where sing = SBoolean
 instance SingI ByteString where sing = SByteStr
 
--- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType' with a 'Typeable'
--- instance.
-pattern FromAbi :: () => Typeable a => SType a -> AbiType
+-- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType'.
+pattern FromAbi :: () => (SingI a, Typeable a) => SType a -> AbiType
 pattern FromAbi t <- (metaType -> FromMeta t)
 {-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
 
--- | Pattern match on an 'MType' is if it were an 'SType' with a 'Typeable' instance.
-pattern FromMeta :: () => Typeable a => SType a -> MType
-pattern FromMeta t <- SomeSing t@STypeable
+-- | Pattern match on an 'MType' is if it were an 'SType'.
+pattern FromMeta :: () => (SingI a, Typeable a) => SType a -> MType
+pattern FromMeta t <- SomeSing t@SType
 {-# COMPLETE FromMeta #-}
 
--- | Helper pattern to retrieve the 'Typeable' instance of an 'SType'.
-pattern STypeable :: () => Typeable a => SType a
-pattern STypeable <- (stypeRep -> TypeRep)
-{-# COMPLETE STypeable #-}
+-- | Helper pattern to retrieve the 'Typeable' and 'SingI' instances of an 'SType'.
+pattern SType :: () => (SingI a, Typeable a) => SType a
+pattern SType <- (dupe -> (Sing, stypeRep -> TypeRep))
+{-# COMPLETE SType #-}
 
 -- | Allows us to retrieve the 'TypeRep' of any 'SType', which in turn can be used
 -- to retrieve the 'Typeable' instance.

From 53b4e6fd45dbfd4684697c92cf6bee66c414f945 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Thu, 11 Nov 2021 00:58:54 +0100
Subject: [PATCH 32/36] remove custom instance reflection stuff

---
 src/Error.hs  | 37 +++++++++----------------------------
 src/Type.hs   | 26 ++++++++++++--------------
 src/act.cabal |  4 +---
 3 files changed, 22 insertions(+), 45 deletions(-)

diff --git a/src/Error.hs b/src/Error.hs
index fbfdce67..748cdba6 100644
--- a/src/Error.hs
+++ b/src/Error.hs
@@ -18,11 +18,9 @@ around modified chaining/branching behaviours.
 
 module Error (module Error) where
 
-import Data.Functor.Alt
+import Data.List (find)
 import Data.List.NonEmpty as NE
 import Data.Validation as Error
-import Data.Proxy
-import Data.Reflection
 
 import Syntax.Untyped (Pn)
 
@@ -44,28 +42,11 @@ f >==> g = \x -> f x `bindValidation` g
 (<==<) :: (b -> Error e c) -> (a -> Error e b) -> a -> Error e c
 (<==<) = flip (>==>)
 
--- | If there is no error at the supplied position, we accept this result and
--- do not attempt to run any later branches, even if there were other errors.
--- (The second argument looks intimidating but it simply demands that each
--- @'Error' e a@ branch is wrapped in 'A' before being passed to '(<!>)'.)
-notAtPosn :: Pn -> (forall s. Reifies s (Alt_ (Error e)) => A s (Error e) a) -> Error e a
-notAtPosn p = withAlt $ \case
-  Failure err -> if any ((p ==) . fst) err then id else const $ Failure err
-  res         -> const res
-
--- | Wraps any functor in a type that can be supplied a custom 'Alt' instance. 
-newtype A s f a = A { runA :: f a }
-  deriving Functor
-
--- | The type of custom 'Alt' instances.
-newtype Alt_ f = Alt_ { alt :: forall a. f a -> f a -> f a }
-
--- | Given a proof that we can reify a custom 'Alt' instance on the wrapped
--- functor, we can give it an actual 'Alt' instance (allows using '(<!>)').
-instance (Functor f, Reifies s (Alt_ f)) => Alt (A s f) where
-  A l <!> A r = A $ alt (reflect @s Proxy) l r
-
--- | The first argument is used as a custom 'Alt' instance when evaluating
--- a functor wrapped in 'A'.
-withAlt :: (forall a. f a -> f a -> f a) -> (forall s. Reifies s (Alt_ f) => A s f b) -> f b
-withAlt alt_ comp = reify (Alt_ alt_) $ \(_ :: Proxy s) -> runA @s comp
+-- | Runs through a list of error-prone computations and returns the first
+-- successful one, with the definition of "success" expanded to include
+-- failures which did not generate any error at the supplied position.
+notAtPosn :: Pn -> [Error e a] -> Maybe (Error e a)
+notAtPosn p = find valid
+  where
+    valid (Success _)    = True
+    valid (Failure errs) = all ((p /=) . fst) errs
diff --git a/src/Type.hs b/src/Type.hs
index 17a8d41d..3438bb63 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -23,7 +23,6 @@ import Control.Lens.Operators ((??))
 import Control.Monad.Writer
 import Data.List.Extra (snoc,unsnoc)
 import Data.Function (on)
-import Data.Functor.Alt
 import Data.Foldable
 import Data.Traversable
 
@@ -311,13 +310,12 @@ checkExpr env e (FromAbi typ) = TExp typ <$> inferExpr env e
 
 -- | Attempt to typecheck an untyped expression as any possible type.
 typedExp :: Typeable t => Env -> U.Expr -> Err (TypedExp t)
-typedExp env e = notAtPosn (getPosn e)
-    $ A (TExp SInteger <$> inferExpr env e)
-  <!> A (TExp SBoolean <$> inferExpr env e)
-  <!> A (TExp SByteStr <$> inferExpr env e)
-  <!> error "Internal error: typedExp" -- should never happen since e's constructor can always be given a type
-                                       -- (even though its children may not fit into that)
-                                       -- but this error is more informative than "expected ByteStr, got X"
+typedExp env e = fromMaybe (error $ "Internal error: Type.typedExp. Expr: " <> show e)
+                 $ notAtPosn (getPosn e)
+                 [ TExp SInteger <$> inferExpr env e
+                 , TExp SBoolean <$> inferExpr env e
+                 , TExp SByteStr <$> inferExpr env e
+                 ]
 
 -- | Attempts to construct an expression with the type and timing required by
 -- the caller. If this is impossible, an error is thrown instead.
@@ -376,12 +374,12 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
     -- our types. Those specializations are used in order to guide the
     -- typechecking of the two supplied expressions. Returns at first success.
     polycheck :: Typeable x => Pn -> (forall y. (Eq y, Typeable y) => Exp y t -> Exp y t -> Exp x t) -> U.Expr -> U.Expr -> Err (Exp a t)
-    polycheck pn cons e1 e2 = notAtPosn (getPosn e1)
-        $ A (check pn <*> (cons @Integer    <$> inferExpr env e1 <*> inferExpr env e2))
-      <!> A (check pn <*> (cons @Bool       <$> inferExpr env e1 <*> inferExpr env e2))
-      <!> A (check pn <*> (cons @ByteString <$> inferExpr env e1 <*> inferExpr env e2))
-      <!> error "Internal error: polycheck" -- should never happen since e1's constructor can always be given a type
-                                            -- (even though its children may not fit into that)
+    polycheck pn cons e1 e2 = fromMaybe (error $ "Internal error: Type.polycheck. Expr1: " <> show e1)
+      $ notAtPosn (getPosn e1)
+      [ check pn <*> (cons @Integer    <$> inferExpr env e1 <*> inferExpr env e2)
+      , check pn <*> (cons @Bool       <$> inferExpr env e1 <*> inferExpr env e2)
+      , check pn <*> (cons @ByteString <$> inferExpr env e1 <*> inferExpr env e2)
+      ]
 
     -- Try to construct a reference to a calldata variable or an item in storage.
     entry :: forall t0. Typeable t0 => Pn -> Time t0 -> Id -> [U.Expr] -> Err (Exp a t)
diff --git a/src/act.cabal b/src/act.cabal
index 2bed16ca..a2f5645b 100644
--- a/src/act.cabal
+++ b/src/act.cabal
@@ -32,10 +32,8 @@ common deps
                  ansi-wl-pprint   >= 0.6.9,
                  regex-tdfa,
                  validation       >= 1.1.1,
-                 semigroupoids    >= 5.2.2,
                  extra,
-                 singletons,
-                 reflection       >= 2.1.6
+                 singletons
   if flag(ci)
       ghc-options: -O2 -Wall -Werror -Wno-orphans -Wno-unticked-promoted-constructors
   else

From 5b384961546c2b4d140733c7a5d92c1ccd04efd3 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sun, 14 Nov 2021 22:42:56 +0100
Subject: [PATCH 33/36] fix CI errors

---
 .github/workflows/build.yml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
index 7add3748..0a364c77 100644
--- a/.github/workflows/build.yml
+++ b/.github/workflows/build.yml
@@ -18,10 +18,10 @@ jobs:
     runs-on: ${{ matrix.os }}
     steps:
       - uses: actions/checkout@v2
-      - uses: cachix/install-nix-action@07da2520eebede906fbeefa9dd0a2b635323909d # v12
+      - uses: cachix/install-nix-action@ef6c38c42ba153b4be4b764b71c87c1610896378 # v15
         with:
           skip_adding_nixpkgs_channel: false
-      - uses: cachix/cachix-action@6e4751ed42b22f60165d3f266cfa4cce66ae406d # v8
+      - uses: cachix/cachix-action@3db1a09d3a573d7b62801116405ad5aa0f59c904 # v10
         with:
           name: dapp
           skipPush: true

From 30e2571e6152dc4dec82e32e5ee4388c119efdc4 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Sun, 14 Nov 2021 23:14:48 +0100
Subject: [PATCH 34/36] restructure and rename defs in 'Syntax.Types'

---
 src/Enrich.hs       |  2 +-
 src/HEVM.hs         | 30 ++++++++---------
 src/SMT.hs          | 10 +++---
 src/Syntax.hs       |  2 +-
 src/Syntax/Types.hs | 78 ++++++++++++++++++++++++---------------------
 src/Type.hs         |  8 ++---
 src/test/Test.hs    |  4 +--
 7 files changed, 70 insertions(+), 64 deletions(-)

diff --git a/src/Enrich.hs b/src/Enrich.hs
index 4cffd450..7751d294 100644
--- a/src/Enrich.hs
+++ b/src/Enrich.hs
@@ -103,6 +103,6 @@ mkStorageBounds store refs = catMaybes $ mkBound <$> refs
     abiType (StorageValue typ) = typ
 
 mkCallDataBounds :: [Decl] -> [Exp Bool t]
-mkCallDataBounds = concatMap $ \(Decl typ name) -> case metaType typ of
+mkCallDataBounds = concatMap $ \(Decl typ name) -> case actType typ of
   Integer -> [bound typ (_Var name)]
   _ -> []
diff --git a/src/HEVM.hs b/src/HEVM.hs
index f980366a..af16a3ce 100644
--- a/src/HEVM.hs
+++ b/src/HEVM.hs
@@ -170,7 +170,7 @@ mkVmContext solcjson b@(Behaviour method _ c1 (Interface _ decls) _ _ updates _)
   in (ctx, res)
 
 
-makeVmEnv :: Behaviour -> VM -> Map Id SMType
+makeVmEnv :: Behaviour -> VM -> Map Id SActType
 makeVmEnv (Behaviour method _ c1 _ _ _ _ _) vm =
   fromList
     [ Caller    |- SymInteger (sFromIntegral $ saddressWord160 (view (state . caller) vm))
@@ -195,7 +195,7 @@ makeVmEnv (Behaviour method _ c1 _ _ _ _ _) vm =
     (|-) a b = (nameFromEnv c1 method a, b)
 
 -- | Locate the variables refered to in the act-spec in the vm
-locateStorage :: Ctx -> SolcJson -> Map Id Addr -> Method -> (VM,VM) -> Rewrite -> (Id, (SMType, SMType))
+locateStorage :: Ctx -> SolcJson -> Map Id Addr -> Method -> (VM,VM) -> Rewrite -> (Id, (SActType, SActType))
 locateStorage ctx solcjson contractMap method (pre, post) item =
   let item' = locFromRewrite item
       addr = get (contractFromRewrite item) contractMap
@@ -226,7 +226,7 @@ calculateSlot ctx solcjson loc =
      else foldl (\a b -> keccak' . SymbolicBuffer $ toBytes a <> toSymBytes b) slotword indexers
 
 
-locateCalldata :: Behaviour -> [Decl] -> Buffer -> Decl -> (Id, SMType)
+locateCalldata :: Behaviour -> [Decl] -> Buffer -> Decl -> (Id, SActType)
 locateCalldata b decls calldata' d@(Decl typ name) =
   if any (\(Decl typ' _) -> abiKind typ' /= Static) decls
   then error "dynamic calldata args currently unsupported"
@@ -239,7 +239,7 @@ locateCalldata b decls calldata' d@(Decl typ name) =
               ++ name ++ " in interface declaration"))
           (elemIndex d decls)
 
-    val = case metaType typ of
+    val = case actType typ of
       -- all integers are 32 bytes
       Integer -> let S _ w = readSWord offset calldata'
                  in SymInteger $ sFromIntegral w
@@ -247,8 +247,8 @@ locateCalldata b decls calldata' d@(Decl typ name) =
       Boolean -> SymBool $ readSWord offset calldata' ./= 0
       _ -> error "TODO: support bytes"
 
--- | Embed an SMType as a list of symbolic bytes
-toSymBytes :: SMType -> [SWord 8]
+-- | Embed an SActType as a list of symbolic bytes
+toSymBytes :: SActType -> [SWord 8]
 toSymBytes (SymInteger i) = toBytes (sFromIntegral i :: SWord 256)
 toSymBytes (SymBool i) = ite i (toBytes (1 :: SWord 256)) (toBytes (0 :: SWord 256))
 toSymBytes (SymBytes _) = error "unsupported"
@@ -290,7 +290,7 @@ keccak' (ConcreteBuffer bytes) = literal $ toSizzle $ wordValue $ keccakBlob byt
 data Ctx = Ctx ContractName Method Args HEVM.Storage HEVM.Env
   deriving (Show)
 
-data SMType
+data SActType
   = SymInteger (SBV Integer)
   | SymBool (SBV Bool)
   | SymBytes (SBV String)
@@ -298,11 +298,11 @@ data SMType
 
 type ContractName = Id
 type Method = Id
-type Args = Map Id SMType
-type Storage = Map Id (SMType, SMType)
-type Env = Map Id SMType
+type Args = Map Id SActType
+type Storage = Map Id (SActType, SActType)
+type Env = Map Id SActType
 
-symExp :: Ctx -> TypedExp -> SMType
+symExp :: Ctx -> TypedExp -> SActType
 symExp ctx (TExp t e) = case t of
   SInteger -> SymInteger $ symExpInt   ctx e
   SBoolean -> SymBool    $ symExpBool  ctx e
@@ -358,7 +358,7 @@ symExpBytes ctx@(Ctx c m args store environment) e = case e of
   ByEnv a -> get (nameFromEnv c m a) (catBytes environment)
   ITE x y z -> ite (symExpBool ctx x) (symExpBytes ctx y) (symExpBytes ctx z)
 
-timeStore :: When -> HEVM.Storage -> Map Id SMType
+timeStore :: When -> HEVM.Storage -> Map Id SActType
 timeStore Pre  s = fst <$> s
 timeStore Post s = snd <$> s
 
@@ -427,13 +427,13 @@ x @@ y = show x <> "_" <> show y
 get :: (Show a, Ord a, Show b) => a -> Map a b -> b
 get name vars = fromMaybe (error (show name <> " not found in " <> show vars)) $ Map.lookup name vars
 
-catInts :: Map Id SMType -> Map Id (SBV Integer)
+catInts :: Map Id SActType -> Map Id (SBV Integer)
 catInts m = Map.fromList [(name, i) | (name, SymInteger i) <- Map.toList m]
 
-catBools :: Map Id SMType -> Map Id (SBV Bool)
+catBools :: Map Id SActType -> Map Id (SBV Bool)
 catBools m = Map.fromList [(name, i) | (name, SymBool i) <- Map.toList m]
 
-catBytes :: Map Id SMType -> Map Id (SBV String)
+catBytes :: Map Id SActType -> Map Id (SBV String)
 catBytes m = Map.fromList [(name, i) | (name, SymBytes i) <- Map.toList m]
 
 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
diff --git a/src/SMT.hs b/src/SMT.hs
index badd5cbf..ed2bb59b 100644
--- a/src/SMT.hs
+++ b/src/SMT.hs
@@ -461,7 +461,7 @@ getEnvironmentValue :: SolverInstance -> EthEnv -> IO (EthEnv, TypedExp)
 getEnvironmentValue solver env = do
   output <- getValue solver (prettyEnv env)
   let val = case lookup env defaultStore of
-        Just (FromMeta typ) -> parseModel typ output
+        Just (FromAct typ) -> parseModel typ output
         _ -> error $ "Internal Error: could not determine a type for" <> show env
   pure (env, val)
 
@@ -534,7 +534,7 @@ declareStorageLocation (Loc _ item) = case ixsFromItem item of
 
 -- | produces an SMT2 expression declaring the given decl as a symbolic constant
 declareArg :: Id -> Decl -> SMT2
-declareArg behvName d@(Decl typ _) = constant (nameFromDecl behvName d) (metaType typ)
+declareArg behvName d@(Decl typ _) = constant (nameFromDecl behvName d) (actType typ)
 
 -- | produces an SMT2 expression declaring the given EthEnv as a symbolic constant
 declareEthEnv :: EthEnv -> SMT2
@@ -620,7 +620,7 @@ simplifyExponentiation a b = fromMaybe (error "Internal Error: no support for sy
     evalb = eval b -- TODO is this actually necessary to prevent double evaluation?
 
 -- | declare a constant in smt2
-constant :: Id -> MType -> SMT2
+constant :: Id -> ActType -> SMT2
 constant name tp = "(declare-const " <> name <> " " <> sType tp <> ")"
 
 -- | encode the given boolean expression as an assertion in smt2
@@ -628,7 +628,7 @@ mkAssert :: Id -> Exp Bool -> SMT2
 mkAssert c e = "(assert " <> withInterface c (expToSMT2 e) <> ")"
 
 -- | declare a (potentially nested) array in smt2
-array :: Id -> NonEmpty TypedExp -> MType -> SMT2
+array :: Id -> NonEmpty TypedExp -> ActType -> SMT2
 array name (hd :| tl) ret = "(declare-const " <> name <> " (Array " <> sType' hd <> " " <> valueDecl tl <> "))"
   where
     valueDecl [] = sType ret
@@ -641,7 +641,7 @@ select name (hd :| tl) = do
   foldM (\smt ix -> ["(select " <> smt <> " " <> ix' <> ")" | ix' <- typedExpToSMT2 ix]) inner tl
 
 -- | act -> smt2 type translation
-sType :: MType -> SMT2
+sType :: ActType -> SMT2
 sType Integer = "Int"
 sType Boolean = "Bool"
 sType ByteStr = "String"
diff --git a/src/Syntax.hs b/src/Syntax.hs
index daa49211..9ecb3ab9 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -203,7 +203,7 @@ ixsFromUpdate (Update _ item _) = ixsFromItem item
 ixsFromRewrite :: Rewrite t -> [TypedExp t]
 ixsFromRewrite = onRewrite ixsFromLocation ixsFromUpdate
 
-itemType :: TStorageItem a t -> MType
+itemType :: TStorageItem a t -> ActType
 itemType (Item t _ _ _) = SomeSing t
 
 isMapping :: StorageLocation t -> Bool
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index ec328700..cc8899f3 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -6,7 +6,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 -- These extensions should be removed once we remove the defs at the end of this file.
 {-# LANGUAGE RankNTypes, TypeApplications, StandaloneKindSignatures, PolyKinds #-}
@@ -27,19 +27,6 @@ import Type.Reflection
 import Data.ByteString    as Syntax.Types (ByteString)
 import EVM.ABI            as Syntax.Types (AbiType(..))
 
-type MType = SomeSing *
-
-pattern Integer :: MType
-pattern Integer = SomeSing SInteger
-
-pattern Boolean :: MType
-pattern Boolean = SomeSing SBoolean
-
-pattern ByteStr :: MType
-pattern ByteStr = SomeSing SByteStr
-
-{-# COMPLETE Integer, Boolean, ByteStr #-}
-
 -- | Singleton types of the types understood by proving tools.
 data SType a where
   SInteger :: SType Integer
@@ -56,26 +43,13 @@ instance Show (SType a) where
 instance TestEquality SType where
   testEquality SType SType = eqT
 
+-- | Compare equality of two things parametrized by types which have singletons.
 eqS :: forall (a :: *) (b :: *) f t. (SingI a, SingI b, Eq (f a t)) => f a t -> f b t -> Bool
 eqS fa fb = maybe False (\Refl -> fa == fb) $ testEquality (sing @a) (sing @b)
 
-class HasType a t where
-  getType :: a -> SType t
-
-metaType :: AbiType -> MType
-metaType (AbiUIntType _)     = Integer
-metaType (AbiIntType  _)     = Integer
-metaType AbiAddressType      = Integer
-metaType AbiBoolType         = Boolean
-metaType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
-metaType AbiBytesDynamicType = ByteStr
-metaType AbiStringType       = ByteStr
---metaType (AbiArrayDynamicType a) =
---metaType (AbiArrayType        Int AbiType
---metaType (AbiTupleType        (Vector AbiType)
-metaType _ = error "Syntax.Types.metaType: TODO"
-
 -- | For our purposes, the singleton of a type @a@ is always @'SType' a@.
+-- We need this to be able to use 'SomeSing' when implementing 'ActType'.
+
 -- Note that even though there only exist three different 'SType', this does
 -- not mean that the type family is partial. It simply means that the resulting
 -- type is uninhabited if the argument is neither 'Integer', 'Bool' nor
@@ -88,17 +62,49 @@ instance SingI Integer    where sing = SInteger
 instance SingI Bool       where sing = SBoolean
 instance SingI ByteString where sing = SByteStr
 
+-- | A non-indexed type whose inhabitants represent the types understood
+-- by proving tools. Implemented by an existentially quantified 'SType'.
+type ActType = SomeSing *
+
+pattern Integer :: ActType
+pattern Integer = SomeSing SInteger
+
+pattern Boolean :: ActType
+pattern Boolean = SomeSing SBoolean
+
+pattern ByteStr :: ActType
+pattern ByteStr = SomeSing SByteStr
+
+{-# COMPLETE Integer, Boolean, ByteStr #-}
+
+class HasType a t where
+  getType :: a -> SType t
+
+actType :: AbiType -> ActType
+actType (AbiUIntType _)     = Integer
+actType (AbiIntType  _)     = Integer
+actType AbiAddressType      = Integer
+actType AbiBoolType         = Boolean
+actType (AbiBytesType n)    = if n <= 32 then Integer else ByteStr
+actType AbiBytesDynamicType = ByteStr
+actType AbiStringType       = ByteStr
+--actType (AbiArrayDynamicType a) =
+--actType (AbiArrayType        Int AbiType
+--actType (AbiTupleType        (Vector AbiType)
+actType _ = error "Syntax.Types.actType: TODO"
+
 -- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType'.
 pattern FromAbi :: () => (SingI a, Typeable a) => SType a -> AbiType
-pattern FromAbi t <- (metaType -> FromMeta t)
+pattern FromAbi t <- (actType -> FromAct t)
 {-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
 
--- | Pattern match on an 'MType' is if it were an 'SType'.
-pattern FromMeta :: () => (SingI a, Typeable a) => SType a -> MType
-pattern FromMeta t <- SomeSing t@SType
-{-# COMPLETE FromMeta #-}
+-- | Pattern match on an 'ActType' is if it were an 'SType'.
+pattern FromAct :: () => (SingI a, Typeable a) => SType a -> ActType
+pattern FromAct t <- SomeSing t@SType
+{-# COMPLETE FromAct #-}
 
--- | Helper pattern to retrieve the 'Typeable' and 'SingI' instances of an 'SType'.
+-- | Helper pattern to retrieve the 'Typeable' and 'SingI' instances of the type
+-- represented by an 'SType'.
 pattern SType :: () => (SingI a, Typeable a) => SType a
 pattern SType <- (dupe -> (Sing, stypeRep -> TypeRep))
 {-# COMPLETE SType #-}
diff --git a/src/Type.hs b/src/Type.hs
index 3438bb63..73141e8a 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -83,11 +83,11 @@ data Env = Env
   { contract :: Id              -- ^ The name of the current contract.
   , store    :: Map Id SlotType -- ^ This contract's storage entry names and their types.
   , theirs   :: Store           -- ^ Mapping from contract names to a map of their entry names and their types.
-  , calldata :: Map Id MType    -- ^ The calldata var names and their types.
+  , calldata :: Map Id ActType    -- ^ The calldata var names and their types.
   }
 
 -- typing of eth env variables
-defaultStore :: [(EthEnv, MType)]
+defaultStore :: [(EthEnv, ActType)]
 defaultStore =
   [(Callvalue, Integer),
    (Caller, Integer),
@@ -113,7 +113,7 @@ mkEnv contract store decls = Env
   , calldata = abiVars
   }
  where
-   abiVars = Map.fromList $ map (\(Decl typ var) -> (var, metaType typ)) decls
+   abiVars = Map.fromList $ map (\(Decl typ var) -> (var, actType typ)) decls
 
 -- checks a transition given a typing of its storage variables
 splitBehaviour :: Store -> U.RawBehaviour -> Err [Claim]
@@ -386,7 +386,7 @@ inferExpr env@Env{contract,store,calldata} expr = case expr of
     entry pn timing name es = case (Map.lookup name store, Map.lookup name calldata) of
       (Nothing, Nothing) -> throw (pn, "Unknown variable " <> name)
       (Just _, Just _)   -> throw (pn, "Ambiguous variable " <> name)
-      (Nothing, Just (FromMeta varType)) ->
+      (Nothing, Just (FromAct varType)) ->
         if isTimed timing then throw (pn, "Calldata var cannot be pre/post")
         else check pn ?? Var varType name
       (Just (StorageValue a), Nothing)      -> checkEntry a []
diff --git a/src/test/Test.hs b/src/test/Test.hs
index 080a9e54..cf2b888b 100644
--- a/src/test/Test.hs
+++ b/src/test/Test.hs
@@ -128,7 +128,7 @@ mkDecls (Names ints bools bytes) = mapM mkDecl names
     prepare typ ns = (,typ) <$> ns
 
 
-genType :: MType -> ExpoGen AbiType
+genType :: ActType -> ExpoGen AbiType
 genType typ = case typ of
   Integer -> oneof [ AbiUIntType <$> validIntSize
                    , AbiIntType <$> validIntSize
@@ -216,7 +216,7 @@ genExpInt names n = do
         subExpBool = genExpBool names (n `div` 2)
 
 
-selectName :: MType -> Names -> ExpoGen String
+selectName :: ActType -> Names -> ExpoGen String
 selectName typ (Names ints bools bytes) = do
   let names = case typ of
                 Integer -> ints

From 5241996511c0beea41de03abc05cb9ec6045c3de Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 15 Nov 2021 00:13:11 +0100
Subject: [PATCH 35/36] GADT instead of existential types

---
 src/Syntax/TimeAgnostic.hs | 11 ++++++-----
 src/Syntax/Types.hs        |  2 +-
 2 files changed, 7 insertions(+), 6 deletions(-)

diff --git a/src/Syntax/TimeAgnostic.hs b/src/Syntax/TimeAgnostic.hs
index 6fed7d52..a9f6d00f 100644
--- a/src/Syntax/TimeAgnostic.hs
+++ b/src/Syntax/TimeAgnostic.hs
@@ -10,7 +10,8 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 {-|
 Module      : Syntax.TimeAgnostic
@@ -126,8 +127,8 @@ data Rewrite t
   | Rewrite (StorageUpdate t)
   deriving (Show, Eq)
 
-data StorageUpdate t
-  = forall a. Update (SType a) (TStorageItem a t) (Exp a t)
+data StorageUpdate (t :: Timing) where
+  Update :: SType a -> TStorageItem a t -> Exp a t -> StorageUpdate t
 deriving instance Show (StorageUpdate t)
 
 _Update :: TStorageItem a t -> Exp a t -> StorageUpdate t
@@ -136,8 +137,8 @@ _Update item expr = Update (getType item) item expr
 instance Eq (StorageUpdate t) where
   Update SType i1 e1 == Update SType i2 e2 = eqS i1 i2 && eqS e1 e2
 
-data StorageLocation t
-  = forall a. Loc (SType a) (TStorageItem a t)
+data StorageLocation (t :: Timing) where
+  Loc :: SType a -> TStorageItem a t -> StorageLocation t
 deriving instance Show (StorageLocation t)
 
 _Loc :: TStorageItem a t -> StorageLocation t
diff --git a/src/Syntax/Types.hs b/src/Syntax/Types.hs
index cc8899f3..8a6ccfbf 100644
--- a/src/Syntax/Types.hs
+++ b/src/Syntax/Types.hs
@@ -96,7 +96,7 @@ actType _ = error "Syntax.Types.actType: TODO"
 -- | Pattern match on an 'EVM.ABI.AbiType' is if it were an 'SType'.
 pattern FromAbi :: () => (SingI a, Typeable a) => SType a -> AbiType
 pattern FromAbi t <- (actType -> FromAct t)
-{-# COMPLETE FromAbi #-} -- We promise that the pattern covers all cases of AbiType.
+{-# COMPLETE FromAbi #-}
 
 -- | Pattern match on an 'ActType' is if it were an 'SType'.
 pattern FromAct :: () => (SingI a, Typeable a) => SType a -> ActType

From b90f163d3f87aed8c78413bbcab90f11d6f64926 Mon Sep 17 00:00:00 2001
From: Jack Ek <2727556+kjekac@users.noreply.github.com>
Date: Mon, 15 Nov 2021 00:13:26 +0100
Subject: [PATCH 36/36] `enrich` outside of `compile`

---
 src/CLI.hs       | 16 +++++++---------
 src/Enrich.hs    | 18 +++++++++---------
 src/test/Test.hs |  2 +-
 3 files changed, 17 insertions(+), 19 deletions(-)

diff --git a/src/CLI.hs b/src/CLI.hs
index 5ec28bf5..ed10d066 100644
--- a/src/CLI.hs
+++ b/src/CLI.hs
@@ -122,7 +122,7 @@ parse' f = do
 type' :: FilePath -> IO ()
 type' f = do
   contents <- readFile f
-  validation (prettyErrs contents) (B.putStrLn . encode) (compile True contents)
+  validation (prettyErrs contents) (B.putStrLn . encode) (enrich <$> compile contents)
 
 prove :: FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
 prove file' solver' smttimeout' debug' = do
@@ -134,7 +134,7 @@ prove file' solver' smttimeout' debug' = do
       Just _ -> error "unrecognized solver"
     config = SMT.SMTConfig (parseSolver solver') (fromMaybe 20000 smttimeout') debug'
   contents <- readFile file'
-  proceed contents (compile True contents) $ \claims -> do
+  proceed contents (enrich <$> compile contents) $ \claims -> do
     let
       catModels results = [m | Sat m <- results]
       catErrors results = [e | e@SMT.Error {} <- results]
@@ -187,7 +187,7 @@ prove file' solver' smttimeout' debug' = do
 coq' :: FilePath -> IO()
 coq' f = do
   contents <- readFile f
-  proceed contents (compile True contents) $ \claims ->
+  proceed contents (enrich <$> compile contents) $ \claims ->
     TIO.putStr $ coq claims
 
 k :: FilePath -> FilePath -> Maybe [(Id, String)] -> Maybe String -> Bool -> Maybe String -> IO ()
@@ -196,7 +196,7 @@ k spec' soljson' gas' storage' extractbin' out' = do
   solContents  <- readFile soljson'
   let kOpts = KOptions (maybe mempty Map.fromList gas') storage' extractbin'
       errKSpecs = do
-        behvs <- toEither $ behvsFromClaims <$> compile True specContents
+        behvs <- toEither $ behvsFromClaims . enrich <$> compile specContents
         (sources, _, _) <- validate [(nowhere, "Could not read sol.json")]
                               (Solidity.readJSON . pack) solContents
         for behvs (makekSpec sources kOpts) ^. revalidate
@@ -210,7 +210,7 @@ hevm :: FilePath -> FilePath -> Maybe Text -> Maybe Integer -> Bool -> IO ()
 hevm spec' soljson' solver' smttimeout' smtdebug' = do
   specContents <- readFile spec'
   solContents  <- readFile soljson'
-  let preprocess = do behvs <- behvsFromClaims <$> compile True specContents
+  let preprocess = do behvs <- behvsFromClaims . enrich <$> compile specContents
                       (sources, _, _) <- validate [(nowhere, "Could not read sol.json")]
                         (Solidity.readJSON . pack) solContents
                       pure (behvs, sources)
@@ -265,10 +265,8 @@ runSMTWithTimeOut solver' maybeTimeout debug' sym
 proceed :: Validate err => String -> err (NonEmpty (Pn, String)) a -> (a -> IO ()) -> IO ()
 proceed contents comp continue = validation (prettyErrs contents) continue (comp ^. revalidate)
 
-compile :: Bool -> String -> Error String [Claim]
-compile shouldEnrich = pure . fmap annotate . enrich' <==< typecheck <==< parse . lexer
-  where
-    enrich' = if shouldEnrich then enrich else id
+compile :: String -> Error String [Claim]
+compile = pure . fmap annotate <==< typecheck <==< parse . lexer
 
 prettyErrs :: Traversable t => String -> t (Pn, String) -> IO ()
 prettyErrs contents errs = mapM_ prettyErr errs >> exitFailure
diff --git a/src/Enrich.hs b/src/Enrich.hs
index 7751d294..57dbec38 100644
--- a/src/Enrich.hs
+++ b/src/Enrich.hs
@@ -10,7 +10,7 @@ import qualified Data.Map.Strict as Map (lookup)
 import EVM.Solidity (SlotType(..))
 
 import Syntax
-import Syntax.Typed
+import Syntax.Annotated
 import Type (bound, defaultStore)
 
 -- | Adds extra preconditions to non constructor behaviours based on the types of their variables
@@ -48,7 +48,7 @@ enrichBehaviour store behv@(Behaviour _ _ _ (Interface _ decls) pre _ stateUpdat
 
 -- | Adds type bounds for calldata, environment vars, and storage vars
 enrichInvariant :: Store -> Constructor -> Invariant -> Invariant
-enrichInvariant store (Constructor _ _ (Interface _ decls) _ _ _ _) inv@(Invariant _ preconds storagebounds predicate) =
+enrichInvariant store (Constructor _ _ (Interface _ decls) _ _ _ _) inv@(Invariant _ preconds storagebounds (predicate,_)) =
   inv { _ipreconditions = preconds', _istoragebounds = storagebounds' }
     where
       preconds' = preconds
@@ -57,10 +57,10 @@ enrichInvariant store (Constructor _ _ (Interface _ decls) _ _ _ _) inv@(Invaria
       storagebounds' = storagebounds
                        <> mkStorageBounds store (Constant <$> locsFromExp predicate)
 
-mkEthEnvBounds :: [EthEnv] -> [Exp Bool t]
+mkEthEnvBounds :: [EthEnv] -> [Exp Bool]
 mkEthEnvBounds vars = catMaybes $ mkBound <$> nub vars
   where
-    mkBound :: EthEnv -> Maybe (Exp Bool t)
+    mkBound :: EthEnv -> Maybe (Exp Bool)
     mkBound e = case lookup e defaultStore of
       Just Integer -> Just $ bound (toAbiType e) (IntEnv e)
       _ -> Nothing
@@ -82,16 +82,16 @@ mkEthEnvBounds vars = catMaybes $ mkBound <$> nub vars
       Nonce -> AbiUIntType 256
 
 -- | extracts bounds from the AbiTypes of Integer values in storage
-mkStorageBounds :: Store -> [Rewrite] -> [Exp Bool Untimed]
+mkStorageBounds :: Store -> [Rewrite] -> [Exp Bool]
 mkStorageBounds store refs = catMaybes $ mkBound <$> refs
   where
-    mkBound :: Rewrite -> Maybe (Exp Bool Untimed)
+    mkBound :: Rewrite -> Maybe (Exp Bool)
     mkBound (Constant (Loc SInteger item)) = Just $ fromItem item
     mkBound (Rewrite (Update SInteger item _)) = Just $ fromItem item
     mkBound _ = Nothing
 
-    fromItem :: TStorageItem Integer Untimed -> Exp Bool Untimed
-    fromItem item@(Item _ contract name _) = bound (abiType $ slotType contract name) (TEntry Neither item)
+    fromItem :: TStorageItem Integer -> Exp Bool
+    fromItem item@(Item _ contract name _) = bound (abiType $ slotType contract name) (TEntry Pre item)
 
     slotType :: Id -> Id -> SlotType
     slotType contract name = let
@@ -102,7 +102,7 @@ mkStorageBounds store refs = catMaybes $ mkBound <$> refs
     abiType (StorageMapping _ typ) = typ
     abiType (StorageValue typ) = typ
 
-mkCallDataBounds :: [Decl] -> [Exp Bool t]
+mkCallDataBounds :: [Decl] -> [Exp Bool]
 mkCallDataBounds = concatMap $ \(Decl typ name) -> case actType typ of
   Integer -> [bound typ (_Var name)]
   _ -> []
diff --git a/src/test/Test.hs b/src/test/Test.hs
index cf2b888b..22e3629e 100644
--- a/src/test/Test.hs
+++ b/src/test/Test.hs
@@ -52,7 +52,7 @@ main = defaultMain $ testGroup "act"
       -}
       [ testProperty "roundtrip" . withExponents $ do
           behv@(Behaviour name _ contract iface preconds _ _ _) <- sized genBehv
-          let actual = compile False $ prettyBehaviour behv
+          let actual = compile $ prettyBehaviour behv
               expected = if null preconds then
                   [ S Map.empty, B behv ]
                 else