TC: handle all const value types

src/Pact/Typechecker.hs

@@ -881,6 +881,19 @@ notEmpty :: MonadThrow m => Info -> String -> [a] -> m [a]
 notEmpty i msg [] = die i msg
 notEmpty _ _ as = return as
 
+-- | Safely return 'Term Name' to 'Term Ref' for value types and consts
+hoistValueTerm :: MonadThrow m => Term Name -> m (Term Ref)
+hoistValueTerm (TLiteral l i) = pure $ TLiteral l i
+hoistValueTerm (TList vs ty i) =
+  TList <$> traverse hoistValueTerm vs <*> traverse hoistValueTerm ty <*> pure i
+hoistValueTerm (TObject o i) = TObject <$> traverse bottom o <*> pure i
+  where
+    bottom n = die i $ "Unexpected reference in value context: " <> showPretty n
+hoistValueTerm (TGuard g i) = TGuard <$> traverse hoistValueTerm g <*> pure i
+hoistValueTerm (TModRef m i) = pure $ TModRef m i
+hoistValueTerm (TConst a n v m i) =
+  TConst <$> traverse hoistValueTerm a <*> pure n <*> traverse hoistValueTerm v <*> pure m <*> pure i
+hoistValueTerm t = die (getInfo t) $ "Unexpected term in value context: " <> showPretty t
 
 -- | Build ASTs from terms.
 toAST :: Term (Either Ref (AST Node)) -> TC (AST Node)
@@ -897,21 +910,9 @@ toAST TModRef{..} = do
 
   n <- trackNode ty tcid
   return $ ModRef n (_modRefName _tModRef) (_modRefSpec _tModRef)
-toAST (TVar v i) = case v of -- value position only, TApp has its own resolver
+toAST (TVar v _i) = case v of -- value position only, TApp has its own resolver
   (Left (Ref r)) -> toAST (fmap Left r)
-  (Left (Direct t)) ->
-    case t of
-      TLiteral {..} ->
-        -- Handle references to pre-evaluated constants:
-        trackPrim _tInfo (litToPrim _tLiteral) (PrimLit _tLiteral)
-      TConst{..} -> case _tModule of
-        -- if modulename is nothing, it's a builtin
-        Nothing -> toAST $ return $ Left (Direct $ constTerm _tConstVal)
-        _ -> die i $ "Non-native constant value in native context: " <> showPretty t
-      TGuard{..} -> do
-        g <- traverse (toAST . return . Left . Direct) _tGuard
-        trackPrim _tInfo (TyGuard $ Just $ guardTypeOf _tGuard) (PrimGuard g)
-      _ -> die i $ "Native in value context: " <> showPretty t
+  (Left (Direct t)) -> hoistValueTerm t >>= toAST . fmap Left
   (Right t) -> return t
 
 toAST (TApp Term.App{..} _) = do

tests/TypecheckSpec.hs

@@ -125,7 +125,7 @@ customFunChecks :: Text -> SpecWith TCResult
 customFunChecks name = case name of
   "tests/pact/tc.repl.tc-update-partial" -> do
     -- TODO top levels don't get inferred return type, so we have to dig in here
-    it (show name ++ ":specializes partial type") $ \(tl, _) -> do
+    it (unpack name ++ ":specializes partial type") $ \(tl, _) -> do
       shouldBe
         (preview (tlFun . fBody . _head . aNode . aTy . tySchemaPartial) tl)
         (Just $ PartialSchema $ Set.singleton "name")

tests/pact/tc.repl

@@ -54,6 +54,14 @@
 
   (defconst FOUR (+ 2 2))
 
+  (defconst LIST (enumerate 0 10))
+
+  (defconst MODREF tc-test-impl)
+
+  (defconst OBJ (tc-test-inner))
+
+  (defconst GUARD (keyset-ref-guard 'keyset))
+
   (deftable persons:{person})
 
   (defun tc-add-person (person)
@@ -271,6 +279,10 @@
     "test compliant modrefs with varying impl lists"
     (tc-eq-modref tc-test-impl tc-test-impl-both)
     )
+
+  (defun tc-native-const:bool ()
+    "test handling of native consts"
+    (= 0 CHARSET_ASCII))
 )
 
 (create-table persons)