Implement type checking of literal expressions

Type checks literal expressions + variables. Tests are included for all of
these cases as well.

waspc/src/Analyzer/Type.hs

@@ -1,9 +1,4 @@
-module Analyzer.Type
-  ( Type (..),
-    DictEntryType (..),
-    dictEntryRequired,
-  )
-where
+module Analyzer.Type where
 
 -- | All possible types in Wasp.
 data Type
@@ -16,11 +11,13 @@ data Type
   | BoolType
   | ExtImportType
   | QuoterType String
+  deriving (Eq, Show)
 
 -- | The type of an entry in a `Dict`.
 data DictEntryType
   = DictEntry {dictEntryName :: String, dictEntryType :: Type}
   | DictOptionalEntry {dictEntryName :: String, dictEntryType :: Type}
+  deriving (Eq, Show)
 
 -- | Determines whether the entry must be present in an instance of its parent
 --   `Dict` type.

waspc/src/Analyzer/TypeChecker.hs

@@ -1,53 +1,105 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Analyzer.TypeChecker
   ( TypedAST (..),
     TypedStmt (..),
     TypedExpr (..),
-    TypeError,
+    TypeError (..),
+    unify,
+    checkExpr,
     exprType,
     typeCheck,
   )
 where
 
-import Analyzer.Parser (AST, ExtImportName, Ident)
-import Analyzer.Type (Type (..))
+import Analyzer.Parser (AST)
+import qualified Analyzer.Parser as P
+import Analyzer.Type
+import Analyzer.TypeChecker.AST
+  ( TypeError (..),
+    TypedAST (..),
+    TypedExpr (..),
+    TypedStmt (..),
+    exprType,
+  )
+import Analyzer.TypeChecker.Internal
 import Analyzer.TypeDefinitions (TypeDefinitions)
 
+-- | @isSuperType sup sub@ returns @True@ if @sup@ is a super type of @sub@.
+--
+--   ==== __Examples__
+--
+--   >>> isSuperType NumberType NumberType
+--   True
+--
+--   >>> isSuperType NumberType StringType
+--   False
+--
+--   >>> let maybe = DictType [DictOptionalEntry "a" NumberType]
+--   >>> let none = DictType []
+--   >>> let just = DictType [DictEntry "a" NumberType]
+--   >>> (isSuperType maybe none, isSuperType maybe just)
+--   (True, True)
+isSuperType :: Type -> Type -> Bool
+isSuperType sup sub
+  | sup == sub = True
+  | otherwise = case (sup, sub) of
+    (DictType entries', DictType entries) -> False
+    (ListType typ', ListType typ) -> isSuperType typ' typ
+
+-- | @unify exprs@ will attempt to find the least general type @typ@ such that
+--   every @expr@ in @exprs@ is a sub-type of @typ@. It returns a modified structure
+--   where each typed expression is given the generalized type.
+--
+--   The structure @exprs@ must be non-empty.
+unify :: (Traversable f) => f TypedExpr -> T (f TypedExpr)
+unify exprs = do
+  typ <- findLeastGeneralType exprs
+  generalize typ exprs
+  where
+    findLeastGeneralType :: (Traversable f) => f TypedExpr -> T Type
+    findLeastGeneralType = return . foldr1 (error "findLeastGeneralType not implemented") . fmap exprType
+
+    generalize :: (Functor f) => Type -> f TypedExpr -> T (f TypedExpr)
+    generalize sup = error "generalize not implemented"
+
+-- | Create bindings for all declarations in the file to allow recursive
+--   or out-of-lexical-order references.
+hoistDeclarations :: AST -> T ()
+hoistDeclarations (P.AST stmts) = mapM_ hoistDeclaration stmts
+  where
+    hoistDeclaration :: P.Stmt -> T ()
+    -- Todo: check that typName is a real DeclType
+    hoistDeclaration (P.Decl typName ident _) = setType ident $ DeclType typName
+
+-- | Determine the type of an expression
+checkExpr :: P.Expr -> T TypedExpr
+checkExpr (P.StringLiteral s) = return $ StringLiteral s
+checkExpr (P.IntegerLiteral i) = return $ IntegerLiteral i
+checkExpr (P.DoubleLiteral d) = return $ DoubleLiteral d
+checkExpr (P.BoolLiteral b) = return $ BoolLiteral b
+checkExpr (P.ExtImport n s) = return $ ExtImport n s
+checkExpr (P.Identifier ident) =
+  lookupType ident >>= \case
+    Nothing -> throw $ TypeError $ "Undefined identifier '" ++ ident ++ "'"
+    Just typ -> return $ Var ident typ
+checkExpr (P.Quoter "json" s) = return $ JSON s
+checkExpr (P.Quoter "psl" s) = return $ PSL s
+checkExpr (P.Quoter tag _) = throw $ TypeError $ "Unknown Quoter tag '" ++ tag ++ "'"
+checkExpr (P.Dict entries) = error "dict type check unimplemented"
+checkExpr (P.List entries) = error "list type check unimplemented"
+
+-- | Checks that statements have valid types
+checkStmt :: P.Stmt -> T TypedStmt
+checkStmt (P.Decl typName _ expr) = error "check decl unimplemented"
+
+checkAST :: AST -> T TypedAST
+checkAST (P.AST stmts) = TypedAST <$> mapM checkStmt stmts
+
+check :: AST -> T TypedAST
+check ast = hoistDeclarations ast >> checkAST ast
+
 -- | Checks that an AST conforms to the type rules of Wasp and produces a
 --   an AST labelled with type information.
 typeCheck :: TypeDefinitions -> AST -> Either TypeError TypedAST
-typeCheck _ _ = Right $ TypedAST {typedStmts = []}
-
--- TODO: instead of having separate AST for type checker, give `Parser.AST` a
--- "content" type argument that type information can be attached to
-
-newtype TypedAST = TypedAST {typedStmts :: [TypedStmt]}
-
-data TypedStmt = Decl Ident TypedExpr Type
-
-data TypedExpr
-  = Dict [(Ident, TypedExpr)] Type
-  | List [TypedExpr] Type
-  | StringLiteral String
-  | IntegerLiteral Integer
-  | DoubleLiteral Double
-  | BoolLiteral Bool
-  | ExtImport ExtImportName String
-  | Identifier Ident Type
-  | -- TODO: What type to represent these?
-    JSON String
-  | PSL String
-
--- | Given a `TypedExpr`, determines its `Type`.
-exprType :: TypedExpr -> Type
-exprType (Dict _ t) = t
-exprType (List _ t) = t
-exprType (StringLiteral _) = StringType
-exprType (IntegerLiteral _) = NumberType
-exprType (DoubleLiteral _) = NumberType
-exprType (BoolLiteral _) = BoolType
-exprType (ExtImport _ _) = ExtImportType
-exprType (Identifier _ t) = t
-exprType (JSON _) = QuoterType "json"
-exprType (PSL _) = QuoterType "psl"
-
-data TypeError
+typeCheck _ ast = runT $ check ast

waspc/src/Analyzer/TypeChecker/AST.hs

@@ -0,0 +1,44 @@
+module Analyzer.TypeChecker.AST
+  ( TypedAST (..),
+    TypedStmt (..),
+    TypedExpr (..),
+    exprType,
+    TypeError (..),
+  )
+where
+
+import Analyzer.Parser (ExtImportName, Ident)
+import Analyzer.Type
+
+newtype TypedAST = TypedAST {typedStmts :: [TypedStmt]} deriving (Eq, Show)
+
+data TypedStmt = Decl Ident TypedExpr Type deriving (Eq, Show)
+
+data TypedExpr
+  = Dict [(Ident, TypedExpr)] Type
+  | List [TypedExpr] Type
+  | StringLiteral String
+  | IntegerLiteral Integer
+  | DoubleLiteral Double
+  | BoolLiteral Bool
+  | ExtImport ExtImportName String
+  | Var Ident Type
+  | -- TODO: What type to represent these?
+    JSON String
+  | PSL String
+  deriving (Eq, Show)
+
+-- | Given a @TypedExpr@, determines its @Type@.
+exprType :: TypedExpr -> Type
+exprType (Dict _ t) = t
+exprType (List _ t) = t
+exprType (StringLiteral _) = StringType
+exprType (IntegerLiteral _) = NumberType
+exprType (DoubleLiteral _) = NumberType
+exprType (BoolLiteral _) = BoolType
+exprType (ExtImport _ _) = ExtImportType
+exprType (Var _ t) = t
+exprType (JSON _) = QuoterType "json"
+exprType (PSL _) = QuoterType "psl"
+
+data TypeError = TypeError String deriving (Eq, Show)

waspc/src/Analyzer/TypeChecker/Internal.hs

@@ -0,0 +1,27 @@
+module Analyzer.TypeChecker.Internal where
+
+import Analyzer.Parser.AST
+import Analyzer.Type
+import Analyzer.TypeChecker.AST
+import Control.Monad.Except
+import Control.Monad.State
+import qualified Data.HashMap.Strict as H
+
+type Bindings = H.HashMap Ident Type
+
+type T a = StateT Bindings (Except TypeError) a
+
+lookupType :: Ident -> T (Maybe Type)
+lookupType ident = gets $ H.lookup ident
+
+setType :: Ident -> Type -> T ()
+setType ident typ = modify $ H.insert ident typ
+
+throw :: TypeError -> T a
+throw = throwError
+
+runTWithBound :: Bindings -> T a -> Either TypeError a
+runTWithBound bindings t = runExcept $ evalStateT t bindings
+
+runT :: T a -> Either TypeError a
+runT = runTWithBound H.empty

waspc/test/Analyzer/TypeCheckerTest.hs

@@ -0,0 +1,72 @@
+module Analyzer.TypeCheckerTest where
+
+import qualified Analyzer.Parser as P
+import Analyzer.Type
+import Analyzer.TypeChecker
+import Analyzer.TypeChecker.Internal (Bindings, runTWithBound)
+import qualified Data.HashMap.Strict as H
+import Test.Tasty.Hspec
+import Test.Tasty.QuickCheck
+
+chooseType :: Gen Type
+chooseType =
+  elements
+    [ StringType,
+      NumberType,
+      BoolType,
+      ExtImportType,
+      QuoterType "json",
+      QuoterType "psl"
+    ]
+
+checkExpr' :: Bindings -> P.Expr -> Either TypeError TypedExpr
+checkExpr' bindings expr = runTWithBound bindings $ checkExpr expr
+
+spec_Parser :: Spec
+spec_Parser = do
+  describe "Analyzer.TypeChecker" $ do
+    describe "checkExpr" $ do
+      it "Types string literals as StringType" $ do
+        let actual = exprType <$> checkExpr' H.empty (P.StringLiteral "string")
+        let expected = Right StringType
+        actual `shouldBe` expected
+      it "Types integer literals as NumberType" $ do
+        let actual = exprType <$> checkExpr' H.empty (P.IntegerLiteral 42)
+        let expected = Right NumberType
+        actual `shouldBe` expected
+      it "Types double literals as NumberType" $ do
+        let actual = exprType <$> checkExpr' H.empty (P.DoubleLiteral 3.14)
+        let expected = Right NumberType
+        actual `shouldBe` expected
+      it "Types bool literals as BoolType" $ do
+        let actual = exprType <$> checkExpr' H.empty (P.BoolLiteral True)
+        let expected = Right BoolType
+        actual `shouldBe` expected
+      it "Types external imports as ExtImportType" $ do
+        let actual = exprType <$> checkExpr' H.empty (P.ExtImport (P.ExtImportModule "Main") "main.js")
+        let expected = Right ExtImportType
+        actual `shouldBe` expected
+
+      it "Types quoted json as JSONType" $ do
+        let actual = exprType <$> checkExpr' H.empty (P.Quoter "json" "\"field\": \"value\"")
+        let expected = Right $ QuoterType "json"
+        actual `shouldBe` expected
+      it "Types quoted psl as PSLType" $ do
+        let actual = exprType <$> checkExpr' H.empty (P.Quoter "psl" "id Int @id")
+        let expected = Right $ QuoterType "psl"
+        actual `shouldBe` expected
+      it "Fails to type check quoters with tag besides json or psl" $ do
+        let actual = checkExpr' H.empty (P.Quoter "toml" "field = \"value\"")
+        let expected = Left $ TypeError "Unknown Quoter tag 'toml'"
+        actual `shouldBe` expected
+
+      it "Types identifier as the type in the bindings" $ do
+        forAll chooseType $ \typ ->
+          let bindings = H.singleton "var" typ
+              actual = exprType <$> checkExpr' bindings (P.Identifier "var")
+           in actual == Right typ
+      it "Fails to type check identifiers not given a type in the bindings" $ do
+        let bindings = H.empty
+        let actual = exprType <$> checkExpr' bindings (P.Identifier "pi")
+        let expected = Left $ TypeError "Undefined identifier 'pi'"
+        actual `shouldBe` expected