wasp-lang/wasp
1
1
Fork 0
mirror of https://github.com/wasp-lang/wasp.git synced 2024-11-23 19:29:17 +03:00
Code Issues Projects Releases Wiki Activity

Better type error messages (and context). (#400)

Browse Source 
- Enriched Parser.AST, TypeChecker.AST and TypeError with Ctx.
This commit is contained in:
Martin Šošić 2022-01-08 23:50:48 +01:00 committed by GitHub
parent cdee0ff0d3
commit 82bec83769
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
34 changed files with 940 additions and 498 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
waspc/README.md
View File

@ -234,6 +234,8 @@ Not only that, but Haskell build tools don't have a good support for mixing them
Tests are run with `stack test`.
You can do `stack test --coverage` to see the coverage.
To run individual test, you can do `stack test --test-arguments "-p \"Some test description to match\""`.
We don't yet have any integration (e2e) tests, but we plan to add them at some point.
For now, best way is to manually run a Wasp app with `wasp start` and try stuff out.

6
waspc/src/Wasp/Analyzer.hs
View File

@ -112,8 +112,7 @@ module Wasp.Analyzer
analyze,
takeDecls,
AnalyzeError (..),
getErrorMessage,
getErrorSourcePosition,
getErrorMessageAndCtx,
SourcePosition (..),
)
where
@ -123,8 +122,7 @@ import Control.Monad ((>=>))
import Wasp.Analyzer.AnalyzeError
( AnalyzeError (..),
SourcePosition (..),
getErrorMessage,
getErrorSourcePosition,
getErrorMessageAndCtx,
)
import Wasp.Analyzer.Evaluator (Decl, evaluate, takeDecls)
import Wasp.Analyzer.Parser (parse)

22
waspc/src/Wasp/Analyzer/AnalyzeError.hs
View File

@ -1,13 +1,15 @@
{-# LANGUAGE LambdaCase #-}
module Wasp.Analyzer.AnalyzeError
( AnalyzeError (..),
getErrorMessage,
getErrorSourcePosition,
getErrorMessageAndCtx,
SourcePosition (..),
)
where
import Control.Arrow (first)
import qualified Wasp.Analyzer.Evaluator.EvaluationError as EE
import Wasp.Analyzer.Parser (SourcePosition (..))
import Wasp.Analyzer.Parser (Ctx, SourcePosition (..))
import qualified Wasp.Analyzer.Parser.ParseError as PE
import qualified Wasp.Analyzer.TypeChecker.TypeError as TE
import Wasp.Util (indent)
@ -18,12 +20,8 @@ data AnalyzeError
| EvaluationError EE.EvaluationError
deriving (Show, Eq)
getErrorMessage :: AnalyzeError -> String
getErrorMessage (ParseError e) = "Parse error:\n" ++ indent 2 (PE.getErrorMessage e)
getErrorMessage (TypeError e) = "Type error:\n" ++ error "TODO"
getErrorMessage (EvaluationError e) = "Evaluation error:\n" ++ error "TODO"
getErrorSourcePosition :: AnalyzeError -> SourcePosition
getErrorSourcePosition (ParseError e) = PE.getSourcePosition e
getErrorSourcePosition (TypeError e) = error "TODO"
getErrorSourcePosition (EvaluationError e) = error "TODO"
getErrorMessageAndCtx :: AnalyzeError -> (String, Ctx)
getErrorMessageAndCtx = \case
ParseError e -> first (("Parse error:\n" ++) . indent 2) $ PE.getErrorMessageAndCtx e
TypeError e -> first (("Type error:\n" ++) . indent 2) $ TE.getErrorMessageAndCtx e
EvaluationError _e -> error "TODO"

8
waspc/src/Wasp/Analyzer/Evaluator.hs
View File

@ -22,11 +22,11 @@ import Wasp.AppSpec.Core.Decl (Decl, takeDecls)
evaluate :: TD.TypeDefinitions -> AST.TypedAST -> Either EvaluationError [Decl]
evaluate typeDefs (AST.TypedAST stmts) = runExcept $ flip runReaderT typeDefs $ evalStateT (evalStmts stmts) H.empty
evalStmts :: [AST.TypedStmt] -> Eval [Decl]
evalStmts :: [AST.WithCtx AST.TypedStmt] -> Eval [Decl]
evalStmts = traverse evalStmt
evalStmt :: AST.TypedStmt -> Eval Decl
evalStmt (AST.Decl name param (Type.DeclType declTypeName)) = do
evalStmt :: AST.WithCtx AST.TypedStmt -> Eval Decl
evalStmt (AST.WithCtx _ctx (AST.Decl name param (Type.DeclType declTypeName))) = do
declType <-
asks
( fromMaybe
@ -38,6 +38,6 @@ evalStmt (AST.Decl name param (Type.DeclType declTypeName)) = do
case TD.dtEvaluate declType typeDefs bindings name param of
Left err -> throwError err
Right decl -> modify (H.insert name decl) >> return decl
evalStmt AST.Decl {} = error "impossible: Decl statement has non-Decl type after type checking"
evalStmt (AST.WithCtx _ AST.Decl {}) = error "impossible: Decl statement has non-Decl type after type checking"
type Eval a = StateT Bindings (ReaderT TD.TypeDefinitions (Except EvaluationError)) a

2
waspc/src/Wasp/Analyzer/Evaluator/Evaluation/TypedDictExpr.hs
View File

@ -11,4 +11,4 @@ import qualified Wasp.Analyzer.TypeChecker.AST as TypedAST
-- be created from a "TypedDictExprEvaluation" with the "dict" combinator.
type TypedDictExprEvaluation a = Evaluation TypedDictEntries a
newtype TypedDictEntries = TypedDictEntries [(String, TypedAST.TypedExpr)]
newtype TypedDictEntries = TypedDictEntries [(String, TypedAST.WithCtx TypedAST.TypedExpr)]

6
waspc/src/Wasp/Analyzer/Evaluator/Evaluation/TypedDictExpr/Combinators.hs
View File

@ -12,13 +12,15 @@ import Wasp.Analyzer.Evaluator.Evaluation.Internal (evaluation, runEvaluation)
import Wasp.Analyzer.Evaluator.Evaluation.TypedDictExpr (TypedDictEntries (..), TypedDictExprEvaluation)
import Wasp.Analyzer.Evaluator.Evaluation.TypedExpr (TypedExprEvaluation)
import qualified Wasp.Analyzer.Evaluator.EvaluationError as EvaluationError
import Wasp.Analyzer.TypeChecker.AST (withCtx)
import qualified Wasp.Analyzer.TypeChecker.AST as TypedAST
-- | An evaluation that runs a "TypedDictExprEvaluation". Expects a "Dict" expression and
-- uses its entries to run the "TypedDictExprEvaluation".
dict :: TypedDictExprEvaluation a -> TypedExprEvaluation a
dict dictEvalutor = evaluation $ \(typeDefs, bindings) -> \case
TypedAST.Dict entries _ -> runEvaluation dictEvalutor typeDefs bindings $ TypedDictEntries entries
dict dictEvaluator = evaluation $ \(typeDefs, bindings) -> withCtx $ \_ctx -> \case
TypedAST.Dict entries _ ->
runEvaluation dictEvaluator typeDefs bindings $ TypedDictEntries entries
expr -> Left $ EvaluationError.ExpectedDictType $ TypedAST.exprType expr
-- | A dictionary evaluation that requires the field to exist.

2
waspc/src/Wasp/Analyzer/Evaluator/Evaluation/TypedExpr.hs
View File

@ -6,4 +6,4 @@ where
import Wasp.Analyzer.Evaluator.Evaluation.Internal (Evaluation)
import qualified Wasp.Analyzer.TypeChecker.AST as TypedAST
type TypedExprEvaluation a = Evaluation TypedAST.TypedExpr a
type TypedExprEvaluation a = Evaluation (TypedAST.WithCtx TypedAST.TypedExpr) a

25
waspc/src/Wasp/Analyzer/Evaluator/Evaluation/TypedExpr/Combinators.hs
View File

@ -23,6 +23,7 @@ import Wasp.Analyzer.Evaluator.Evaluation.Internal (evaluation, evaluation', run
import Wasp.Analyzer.Evaluator.Evaluation.TypedExpr (TypedExprEvaluation)
import qualified Wasp.Analyzer.Evaluator.EvaluationError as EvaluationError
import qualified Wasp.Analyzer.Type as T
import Wasp.Analyzer.TypeChecker.AST (withCtx)
import qualified Wasp.Analyzer.TypeChecker.AST as TypedAST
import qualified Wasp.Analyzer.TypeDefinitions as TD
import Wasp.AppSpec.Core.Ref (Ref)
@ -32,34 +33,34 @@ import qualified Wasp.AppSpec.JSON as AppSpec.JSON
-- | An evaluation that expects a "StringLiteral".
string :: TypedExprEvaluation String
string = evaluation' $ \case
string = evaluation' . withCtx $ \_ctx -> \case
TypedAST.StringLiteral str -> pure str
expr -> Left $ EvaluationError.ExpectedType T.StringType (TypedAST.exprType expr)
-- | An evaluation that expects an "IntegerLiteral" or "DoubleLiteral". A
-- "DoubleLiteral" is rounded to the nearest whole number.
integer :: TypedExprEvaluation Integer
integer = evaluation' $ \case
integer = evaluation' . withCtx $ \_ctx -> \case
TypedAST.IntegerLiteral i -> pure i
TypedAST.DoubleLiteral x -> pure $ round x
expr -> Left $ EvaluationError.ExpectedType T.NumberType (TypedAST.exprType expr)
-- | An evaluation that expects a "IntegerLiteral" or "DoubleLiteral".
double :: TypedExprEvaluation Double
double = evaluation' $ \case
double = evaluation' . withCtx $ \_ctx -> \case
TypedAST.IntegerLiteral i -> pure $ fromIntegral i
TypedAST.DoubleLiteral x -> pure x
expr -> Left $ EvaluationError.ExpectedType T.NumberType (TypedAST.exprType expr)
-- | An evaluation that expects a "BoolLiteral".
bool :: TypedExprEvaluation Bool
bool = evaluation' $ \case
bool = evaluation' . withCtx $ \_ctx -> \case
TypedAST.BoolLiteral b -> pure b
expr -> Left $ EvaluationError.ExpectedType T.BoolType (TypedAST.exprType expr)
-- | An evaluation that expects a "Var" bound to a "Decl" of type "a".
declRef :: forall a. TD.IsDeclType a => TypedExprEvaluation (Ref a)
declRef = evaluation' $ \case
declRef = evaluation' . withCtx $ \_ctx -> \case
TypedAST.Var varName varType ->
case varType of
T.DeclType declTypeName | declTypeName == expectedDeclTypeName -> pure $ Ref.Ref varName
@ -75,14 +76,14 @@ declRef = evaluation' $ \case
-- | An evaluation that expects a "Var" bound to an "EnumType" for "a".
enum :: forall a. TD.IsEnumType a => TypedExprEvaluation a
enum = evaluation' $ \case
enum = evaluation' . withCtx $ \_ctx -> \case
TypedAST.Var var _ -> TD.enumEvaluate @a var
expr -> Left $ EvaluationError.ExpectedType (T.EnumType $ TD.etName $ TD.enumType @a) (TypedAST.exprType expr)
-- | An evaluation that expects a "List" and runs the inner evaluation on each
-- item in the list.
list :: TypedExprEvaluation a -> TypedExprEvaluation [a]
list elemEvaluation = evaluation $ \(typeDefs, bindings) -> \case
list elemEvaluation = evaluation $ \(typeDefs, bindings) -> withCtx $ \_ctx -> \case
TypedAST.List values _ ->
left (EvaluationError.WithContext EvaluationError.InList) $
mapM (runEvaluation elemEvaluation typeDefs bindings) values
@ -94,7 +95,7 @@ tuple2 ::
TypedExprEvaluation t1 ->
TypedExprEvaluation t2 ->
TypedExprEvaluation (t1, t2)
tuple2 eval1 eval2 = evaluation $ \(typeDefs, bindings) -> \case
tuple2 eval1 eval2 = evaluation $ \(typeDefs, bindings) -> withCtx $ \_ctx -> \case
TypedAST.Tuple (v1, v2, []) _ ->
left (EvaluationError.WithContext EvaluationError.InTuple) $ do
v1' <- runEvaluation eval1 typeDefs bindings v1
@ -109,7 +110,7 @@ tuple3 ::
TypedExprEvaluation t2 ->
TypedExprEvaluation t3 ->
TypedExprEvaluation (t1, t2, t3)
tuple3 eval1 eval2 eval3 = evaluation $ \(typeDefs, bindings) -> \case
tuple3 eval1 eval2 eval3 = evaluation $ \(typeDefs, bindings) -> withCtx $ \_ctx -> \case
TypedAST.Tuple (v1, v2, [v3]) _ ->
left (EvaluationError.WithContext EvaluationError.InTuple) $ do
v1' <- runEvaluation eval1 typeDefs bindings v1
@ -126,7 +127,7 @@ tuple4 ::
TypedExprEvaluation t3 ->
TypedExprEvaluation t4 ->
TypedExprEvaluation (t1, t2, t3, t4)
tuple4 eval1 eval2 eval3 eval4 = evaluation $ \(typeDefs, bindings) -> \case
tuple4 eval1 eval2 eval3 eval4 = evaluation $ \(typeDefs, bindings) -> withCtx $ \_ctx -> \case
TypedAST.Tuple (v1, v2, [v3, v4]) _ ->
left (EvaluationError.WithContext EvaluationError.InTuple) $ do
v1' <- runEvaluation eval1 typeDefs bindings v1
@ -138,12 +139,12 @@ tuple4 eval1 eval2 eval3 eval4 = evaluation $ \(typeDefs, bindings) -> \case
-- | An evaluation that expects an "ExtImport".
extImport :: TypedExprEvaluation AppSpec.ExtImport.ExtImport
extImport = evaluation' $ \case
extImport = evaluation' . withCtx $ \_ctx -> \case
TypedAST.ExtImport name file -> pure $ AppSpec.ExtImport.ExtImport name file
expr -> Left $ EvaluationError.ExpectedType T.ExtImportType (TypedAST.exprType expr)
-- | An evaluation that expects a "JSON".
json :: TypedExprEvaluation AppSpec.JSON.JSON
json = evaluation' $ \case
json = evaluation' . withCtx $ \_ctx -> \case
TypedAST.JSON str -> pure $ AppSpec.JSON.JSON str
expr -> Left $ EvaluationError.ExpectedType (T.QuoterType "json") (TypedAST.exprType expr)

8
waspc/src/Wasp/Analyzer/Parser.hs
View File

@ -16,6 +16,12 @@ module Wasp.Analyzer.Parser
AST (..),
Stmt (..),
Expr (..),
WithCtx (..),
withCtx,
ctxFromPos,
getCtxPos,
fromWithCtx,
Ctx (..),
Identifier,
ExtImportName (..),
ParseError (..),
@ -28,9 +34,11 @@ where
import Control.Monad.Except (runExcept)
import Control.Monad.State (evalStateT)
import Wasp.Analyzer.Parser.AST
import Wasp.Analyzer.Parser.Ctx (Ctx (..), WithCtx (..), ctxFromPos, fromWithCtx, getCtxPos, withCtx)
import Wasp.Analyzer.Parser.Monad (initialState)
import Wasp.Analyzer.Parser.ParseError
import qualified Wasp.Analyzer.Parser.Parser as P
import Wasp.Analyzer.Parser.SourcePosition (SourcePosition (..))
import Wasp.Analyzer.Parser.Token
parse :: String -> Either ParseError AST

35
waspc/src/Wasp/Analyzer/Parser/AST.hs
View File

@ -7,24 +7,29 @@ module Wasp.Analyzer.Parser.AST
)
where
import Wasp.Analyzer.Parser.Ctx
import Wasp.AppSpec.ExtImport (ExtImportName (..))
newtype AST = AST {astStmts :: [Stmt]} deriving (Eq, Show)
newtype AST = AST {astStmts :: [WithCtx Stmt]} deriving (Eq, Show)
-- Decl <declType> <name> <body>
data Stmt = Decl Identifier Identifier Expr deriving (Eq, Show)
data Expr
= Dict [(Identifier, Expr)]
| List [Expr]
| Tuple (Expr, Expr, [Expr])
| StringLiteral String
| IntegerLiteral Integer
| DoubleLiteral Double
| BoolLiteral Bool
| ExtImport ExtImportName String
| Var Identifier
| Quoter Identifier String
data Stmt
= -- | Decl <declType> <declName> <declBody>
Decl Identifier Identifier (WithCtx Expr)
deriving (Eq, Show)
{- ORMOLU_DISABLE -}
data Expr
= Dict [(Identifier, WithCtx Expr)]
| List [WithCtx Expr]
| Tuple (WithCtx Expr, WithCtx Expr, [WithCtx Expr])
| StringLiteral String
| IntegerLiteral Integer
| DoubleLiteral Double
| BoolLiteral Bool
| ExtImport ExtImportName String
| Var Identifier
| Quoter Identifier String
deriving (Eq, Show)
{- ORMOLU_ENABLE -}
type Identifier = String

37
waspc/src/Wasp/Analyzer/Parser/Ctx.hs Normal file
View File

@ -0,0 +1,37 @@
{-# LANGUAGE DeriveFunctor #-}
module Wasp.Analyzer.Parser.Ctx
( WithCtx (..),
withCtx,
Ctx (..),
ctxFromPos,
getCtxPos,
fromWithCtx,
)
where
import Wasp.Analyzer.Parser.SourcePosition (SourcePosition)
data WithCtx a = WithCtx Ctx a
deriving (Eq, Show, Functor)
withCtx :: (Ctx -> a -> b) -> WithCtx a -> b
withCtx f (WithCtx ctx x) = f ctx x
-- | Gives parsing context to AST nodes -> e.g. source position from which they originated.
-- TODO: Instead of having just SourcePosition, it would be better to have SourceRegion, since errors
-- usually refer to a region and not just one position/char in the code.
-- This is captured in an issue https://github.com/wasp-lang/wasp/issues/404 .
data Ctx = Ctx
{ ctxSourcePosition :: SourcePosition
}
deriving (Show, Eq)
ctxFromPos :: SourcePosition -> Ctx
ctxFromPos pos = Ctx {ctxSourcePosition = pos}
getCtxPos :: Ctx -> SourcePosition
getCtxPos = ctxSourcePosition
fromWithCtx :: WithCtx a -> a
fromWithCtx (WithCtx _ a) = a

11
waspc/src/Wasp/Analyzer/Parser/Lexer.x
View File

@ -125,10 +125,13 @@ lexer parseToken = do
putInput input'
lexer parseToken
AlexToken input' tokenLength action -> do
-- Token is made before `updatePosition` so that its `tokenPosition` points to
-- the start of the token's lexeme.
token <- action $ take tokenLength remainingSource
updatePosition $ take tokenLength remainingSource
-- Creating token and remembering its position via setPositionOfLastScannedTokenToCurrent
-- are done before `updatePosition`, while current parser position still points to
-- the start of the token's lexeme, to ensure that position gets used.
let lexeme = take tokenLength remainingSource
token <- action lexeme
setPositionOfLastScannedTokenToCurrent
updatePosition lexeme
putInput input'
parseToken token

12
waspc/src/Wasp/Analyzer/Parser/Monad.hs
View File

@ -5,6 +5,7 @@ module Wasp.Analyzer.Parser.Monad
initialState,
Parser,
updatePosition,
setPositionOfLastScannedTokenToCurrent,
putInput,
setStartCode,
ParserInput,
@ -16,7 +17,7 @@ import Control.Monad.Except (Except)
import Control.Monad.State.Lazy (StateT, get, modify)
import Data.Word (Word8)
import Wasp.Analyzer.Parser.ParseError (ParseError)
import Wasp.Analyzer.Parser.Token (SourcePosition (..))
import Wasp.Analyzer.Parser.SourcePosition (SourcePosition (..))
type Parser a = StateT ParserState (Except ParseError) a
@ -31,6 +32,11 @@ updatePosition parsedSourcePiece = do
calcNewPosition ('\n' : cs) (SourcePosition line _) = calcNewPosition cs $ SourcePosition (line + 1) 1
calcNewPosition (_ : cs) (SourcePosition line col) = calcNewPosition cs $ SourcePosition line (col + 1)
setPositionOfLastScannedTokenToCurrent :: Parser ()
setPositionOfLastScannedTokenToCurrent = do
position <- parserSourcePosition <$> get
modify $ \s -> s {lastScannedTokenSourcePosition = position}
putInput :: ParserInput -> Parser ()
putInput input = modify $ \s -> s {parserRemainingInput = input}
@ -39,6 +45,9 @@ setStartCode startCode = modify $ \s -> s {parserLexerStartCode = startCode}
data ParserState = ParserState
{ parserSourcePosition :: SourcePosition,
-- | Source position of the start of the last token that was scanned by Alex.
-- Note that token first gets scanned by Alex, and then it gets parsed by Happy.
lastScannedTokenSourcePosition :: SourcePosition,
parserRemainingInput :: ParserInput,
parserLexerStartCode :: LexerStartCode
}
@ -56,6 +65,7 @@ initialState :: String -> ParserState
initialState source =
ParserState
{ parserSourcePosition = SourcePosition 1 1,
lastScannedTokenSourcePosition = SourcePosition 1 1,
-- NOTE: We use '\n' here as dummy value to start with.
parserRemainingInput = ('\n', ('\n', []), source),
parserLexerStartCode = DefaultStartCode

45
waspc/src/Wasp/Analyzer/Parser/ParseError.hs
View File

@ -1,13 +1,14 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module Wasp.Analyzer.Parser.ParseError
( ParseError (..),
getErrorMessage,
getSourcePosition,
getErrorMessageAndCtx,
)
where
import Wasp.Analyzer.Parser.Token
import Wasp.Analyzer.Parser.Ctx (Ctx, ctxFromPos)
import Wasp.Analyzer.Parser.SourcePosition (SourcePosition)
import Wasp.Analyzer.Parser.Token (Token (..))
data ParseError
= -- | A lexical error representing an invalid character. It means that lexer
@ -26,21 +27,21 @@ data ParseError
QuoterDifferentTags (String, SourcePosition) (String, SourcePosition)
deriving (Eq, Show)
getErrorMessage :: ParseError -> String
getErrorMessage (UnexpectedChar unexpectedChar _) =
"Unexpected character: " ++ [unexpectedChar]
getErrorMessage (UnexpectedToken unexpectedToken expectedTokens) =
unexpectedTokenMessage
++ if not (null expectedTokens) then "\n" ++ expectedTokensMessage else ""
where
unexpectedTokenMessage = "Unexpected token: " ++ tokenLexeme unexpectedToken
expectedTokensMessage =
"Expected one of the following tokens instead: "
++ unwords expectedTokens
getErrorMessage (QuoterDifferentTags (ltag, _) (rtag, _)) =
"Quoter tags don't match: {=" ++ ltag ++ " ... " ++ rtag ++ "=}"
getSourcePosition :: ParseError -> SourcePosition
getSourcePosition (UnexpectedChar _ pos) = pos
getSourcePosition (UnexpectedToken Token {tokenPosition} _) = tokenPosition
getSourcePosition (QuoterDifferentTags _ (_, rpos)) = rpos
getErrorMessageAndCtx :: ParseError -> (String, Ctx)
getErrorMessageAndCtx = \case
UnexpectedChar unexpectedChar pos ->
( "Unexpected character: " ++ [unexpectedChar],
ctxFromPos pos
)
UnexpectedToken unexpectedToken expectedTokens ->
( let unexpectedTokenMessage = "Unexpected token: " ++ tokenLexeme unexpectedToken
expectedTokensMessage =
"Expected one of the following tokens instead: "
++ unwords expectedTokens
in unexpectedTokenMessage ++ if not (null expectedTokens) then "\n" ++ expectedTokensMessage else "",
ctxFromPos $ tokenPosition unexpectedToken
)
QuoterDifferentTags (ltag, _) (rtag, rpos) ->
( "Quoter tags don't match: {=" ++ ltag ++ " ... " ++ rtag ++ "=}",
ctxFromPos rpos
)

106
waspc/src/Wasp/Analyzer/Parser/Parser.y
View File

@ -10,7 +10,9 @@ module Wasp.Analyzer.Parser.Parser
import Wasp.Analyzer.Parser.Lexer
import Wasp.Analyzer.Parser.AST
import Wasp.Analyzer.Parser.Ctx (WithCtx (..), Ctx (..), ctxFromPos)
import Wasp.Analyzer.Parser.Token
import Wasp.Analyzer.Parser.SourcePosition (SourcePosition (..))
import Wasp.Analyzer.Parser.ParseError
import Wasp.Analyzer.Parser.Monad (Parser, initialState, ParserState (..))
import Control.Monad.State.Lazy (get)
@ -56,80 +58,102 @@ import Control.Monad.Except (throwError)
double { Token { tokenType = TDouble $$ } }
'{=' { Token { tokenType = TLQuote $$ } }
quoted { Token { tokenType = TQuoted $$ } }
'=}' { Token { tokenType = TRQuote $$ } }
identifier { Token { tokenType = TIdentifier $$ } }
'=}' { Token { tokenType = TRQuote $$ } }
id { Token { tokenType = TIdentifier $$ } }
%%
-- Grammar rules
Wasp :: { AST }
: Stmt { AST [$1] }
| Wasp Stmt { AST $ astStmts $1 ++ [$2] }
Stmts :: { AST }
: StmtWithCtx { AST [$1] }
| Stmts StmtWithCtx { AST $ astStmts $1 ++ [$2] }
StmtWithCtx :: { WithCtx Stmt }
: ctx Stmt { WithCtx $1 $2 }
Stmt :: { Stmt }
: Decl { $1 }
Decl :: { Stmt }
: identifier identifier Expr { Decl $1 $2 $3 }
: id id ExprWithCtx { Decl $1 $2 $3 }
ExprWithCtx :: { WithCtx Expr }
: ctx Expr { WithCtx $1 $2 }
Expr :: { Expr }
: Dict { $1 }
| List { $1 }
| Tuple { $1 }
: Dict { $1 }
| List { $1 }
| Tuple { $1 }
| Extimport { $1 }
| Quoter { $1 }
| string { StringLiteral $1 }
| int { IntegerLiteral $1 }
| double { DoubleLiteral $1 }
| true { BoolLiteral True }
| false { BoolLiteral False }
| identifier { Var $1 }
| Quoter { $1 }
| string { StringLiteral $1 }
| int { IntegerLiteral $1 }
| double { DoubleLiteral $1 }
| true { BoolLiteral True }
| false { BoolLiteral False }
| id { Var $1 }
Dict :: { Expr }
: '{' DictEntries '}' { Dict $2 }
: '{' DictEntries '}' { Dict $2 }
| '{' DictEntries ',' '}' { Dict $2 }
| '{' '}' { Dict [] }
DictEntries :: { [(Identifier, Expr)] }
: DictEntry { [$1] }
| '{' '}' { Dict [] }
DictEntries :: { [(Identifier, WithCtx Expr)] }
: DictEntry { [$1] }
| DictEntries ',' DictEntry { $1 ++ [$3] }
DictEntry :: { (Identifier, Expr) }
: identifier ':' Expr { ($1, $3) }
DictEntry :: { (Identifier, WithCtx Expr) }
: id ':' ExprWithCtx { ($1, $3) }
List :: { Expr }
: '[' ListVals ']' { List $2 }
: '[' ListVals ']' { List $2 }
| '[' ListVals ',' ']' { List $2 }
| '[' ']' { List [] }
ListVals :: { [Expr] }
: Expr { [$1] }
| ListVals ',' Expr { $1 ++ [$3] }
| '[' ']' { List [] }
ListVals :: { [WithCtx Expr] }
: ExprWithCtx { [$1] }
| ListVals ',' ExprWithCtx { $1 ++ [$3] }
-- We don't allow tuples shorter than 2 elements,
-- since they are not useful + this way we avoid
-- ambiguity between tuple with single element and expression
-- wrapped in parenthesis for purpose of grouping.
Tuple :: { Expr }
: '(' TupleVals ')' { Tuple $2 }
: '(' TupleVals ')' { Tuple $2 }
| '(' TupleVals ',' ')' { Tuple $2 }
TupleVals :: { (Expr, Expr, [Expr]) }
: Expr ',' Expr { ($1, $3, []) }
| TupleVals ',' Expr { (\(a, b, c) -> (a, b, c ++ [$3])) $1 }
TupleVals :: { (WithCtx Expr, WithCtx Expr, [WithCtx Expr]) }
: ExprWithCtx ',' ExprWithCtx { ($1, $3, []) }
| TupleVals ',' ExprWithCtx { (\(a, b, c) -> (a, b, c ++ [$3])) $1 }
Extimport :: { Expr }
: import Name from string { ExtImport $2 $4 }
Name :: { ExtImportName }
: identifier { ExtImportModule $1 }
| '{' identifier '}' { ExtImportField $2 }
: id { ExtImportModule $1 }
| '{' id '}' { ExtImportField $2 }
Quoter :: { Expr }
: SourcePosition '{=' Quoted SourcePosition '=}' {% if $2 /= $5
then throwError $ QuoterDifferentTags ($2, $1) ($5, $4)
else return $ Quoter $2 $3
}
: pos '{=' Quoted pos '=}' {% if $2 /= $5
then throwError $ QuoterDifferentTags ($2, $1) ($5, $4)
else return $ Quoter $2 $3
}
Quoted :: { String }
: quoted { $1 }
: quoted { $1 }
| Quoted quoted { $1 ++ $2 }
SourcePosition :: { SourcePosition }
: {- empty -} {% fmap parserSourcePosition get }
-- Special production that returns the position of the token that will get scanned after it.
-- NOTE(martin): You might wonder why does it use position of the last scanned (therefore *previous*)
-- token to get the position of the token that should be scanned *after* this production?
-- That sounds like it is getting position of one token too early, right? The trick is that Happy
-- always keeps one lookahead token in reserve, so it is actually always one token ahead of what we
-- would expect. Therefore getting the position of the last scanned token actually gives us the position
-- of the token that follows.
pos :: { SourcePosition }
: {- empty -} {% fmap lastScannedTokenSourcePosition get }
-- Special production that returns the current parsing context.
ctx :: { Ctx }
: pos { ctxFromPos $1 }
{
parseError :: (Token, [String]) -> Parser a
@ -155,6 +179,6 @@ prettyShowGrammarToken = \case
"'{='" -> "{=<identifier>"
"quoted" -> "<quoted>"
"'=}'" -> "<identifier>=}"
"identifier" -> "<identifier>"
"id" -> "<identifier>"
s -> s
}

8
waspc/src/Wasp/Analyzer/Parser/SourcePosition.hs Normal file
View File

@ -0,0 +1,8 @@
module Wasp.Analyzer.Parser.SourcePosition
( SourcePosition (..),
)
where
-- | The first character on the first line is at position @Position 1 1@
-- @SourcePosition <line> <column>@
data SourcePosition = SourcePosition Int Int deriving (Eq, Show)

3
waspc/src/Wasp/Analyzer/Parser/Token.hs
View File

@ -1,7 +1,6 @@
module Wasp.Analyzer.Parser.Token where
-- | The first character on the first line is at position @Position 1 1@
data SourcePosition = SourcePosition Int Int deriving (Eq, Show)
import Wasp.Analyzer.Parser.SourcePosition (SourcePosition)
data TokenType
= TLParen

2
waspc/src/Wasp/Analyzer/StdTypeDefinitions/Entity.hs
View File

@ -22,7 +22,7 @@ instance IsDeclType Entity where
Decl.makeDecl @Entity declName <$> declEvaluate typeDefinitions bindings expr
}
declEvaluate _ _ expr = case expr of
declEvaluate _ _ (TC.AST.WithCtx _ctx expr) = case expr of
TC.AST.PSL pslString ->
left (ER.ParseError . ER.EvaluationParseErrorParsec) $
makeEntity <$> Parsec.parse Wasp.Psl.Parser.Model.body "" pslString

23
waspc/src/Wasp/Analyzer/Type.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE LambdaCase #-}
module Wasp.Analyzer.Type
( Type (..),
DictEntryType (..),
@ -6,6 +8,7 @@ module Wasp.Analyzer.Type
where
import qualified Data.HashMap.Strict as H
import Data.List (intercalate)
-- | All possible types in Wasp.
data Type
@ -24,7 +27,25 @@ data Type
| BoolType
| ExtImportType
| QuoterType String
deriving (Eq, Show)
deriving (Eq)
instance Show Type where
show = \case
DeclType typeName -> typeName ++ " (declaration type)"
EnumType typeName -> typeName ++ " (enum type)"
DictType keyValueMap ->
let showEntry (k, v) = " " ++ k ++ ": " ++ show v
in case H.toList keyValueMap of
[entry] -> "{" ++ showEntry entry ++ "}"
entries -> "{\n" ++ intercalate ",\n" (map ((" " ++) . showEntry) entries) ++ "\n}"
ListType typ -> "[" ++ show typ ++ "]"
EmptyListType -> "[]"
TupleType (t1, t2, ts) -> "(" ++ (intercalate ", " $ show <$> (t1 : t2 : ts)) ++ ")"
StringType -> "string"
NumberType -> "number"
BoolType -> "bool"
ExtImportType -> "external import"
QuoterType tag -> "{=" ++ tag ++ " " ++ tag ++ "=}"
-- | The type of an entry in a `Dict`.
data DictEntryType

5
waspc/src/Wasp/Analyzer/TypeChecker.hs
View File

@ -9,10 +9,13 @@ module Wasp.Analyzer.TypeChecker
TypedAST (..),
TypedStmt (..),
TypedExpr (..),
WithCtx (..),
-- ** Errors
TypeError (..),
TypeCoerceReason (..),
TypeCoercionError (..),
TypeCoercionErrorReason (..),
getErrorMessageAndCtx,
-- * Type Checking Functions
typeCheck,

40
waspc/src/Wasp/Analyzer/TypeChecker/AST.hs
View File

@ -4,32 +4,40 @@ module Wasp.Analyzer.TypeChecker.AST
TypedExpr (..),
Identifier,
ExtImportName (..),
WithCtx (..),
withCtx,
exprType,
)
where
import Wasp.Analyzer.Parser (ExtImportName (..), Identifier)
import Wasp.Analyzer.Parser.Ctx (WithCtx (..), withCtx)
import Wasp.Analyzer.Type
newtype TypedAST = TypedAST {typedStmts :: [TypedStmt]} deriving (Eq, Show)
newtype TypedAST = TypedAST {typedStmts :: [WithCtx TypedStmt]} deriving (Eq, Show)
data TypedStmt = Decl Identifier TypedExpr Type deriving (Eq, Show)
data TypedExpr
= Dict [(Identifier, TypedExpr)] Type
| List [TypedExpr] Type
| Tuple (TypedExpr, TypedExpr, [TypedExpr]) Type
| StringLiteral String
| IntegerLiteral Integer
| DoubleLiteral Double
| BoolLiteral Bool
| ExtImport ExtImportName String
| Var Identifier Type
| -- TODO: When adding quoters to TypeDefinitions, these JSON/PSL variants will have to be changed
JSON String
| PSL String
data TypedStmt
= -- | Decl <declName> <declBody> <declType>
Decl Identifier (WithCtx TypedExpr) Type
deriving (Eq, Show)
{- ORMOLU_DISABLE -}
data TypedExpr
= Dict [(Identifier, WithCtx TypedExpr)] Type
| List [WithCtx TypedExpr] Type
| Tuple (WithCtx TypedExpr, WithCtx TypedExpr, [WithCtx TypedExpr]) Type
| StringLiteral String
| IntegerLiteral Integer
| DoubleLiteral Double
| BoolLiteral Bool
| ExtImport ExtImportName String
| Var Identifier Type
| -- TODO: When adding quoters to TypeDefinitions, these JSON/PSL variants will have to be changed
JSON String
| PSL String
deriving (Eq, Show)
{- ORMOLU_ENABLE -}
-- | Given a @TypedExpr@, determines its @Type@.
exprType :: TypedExpr -> Type
exprType (Dict _ t) = t

288
waspc/src/Wasp/Analyzer/TypeChecker/Internal.hs
View File

@ -37,7 +37,8 @@ where
import Control.Arrow (left, second)
import Control.Monad (foldM, void)
import qualified Data.HashMap.Strict as M
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, toList)
import Data.Maybe (fromJust)
import Wasp.Analyzer.Parser (AST)
import qualified Wasp.Analyzer.Parser as P
import Wasp.Analyzer.Type
@ -45,7 +46,7 @@ import Wasp.Analyzer.TypeChecker.AST
import Wasp.Analyzer.TypeChecker.Monad
import Wasp.Analyzer.TypeChecker.TypeError
import qualified Wasp.Analyzer.TypeDefinitions as TD
import Wasp.Util.Control.Monad (foldM1, foldMapM')
import Wasp.Util.Control.Monad (foldMapM')
check :: AST -> TypeChecker TypedAST
check ast = hoistDeclarations ast >> checkAST ast
@ -53,78 +54,82 @@ check ast = hoistDeclarations ast >> checkAST ast
hoistDeclarations :: AST -> TypeChecker ()
hoistDeclarations (P.AST stmts) = mapM_ hoistDeclaration stmts
where
hoistDeclaration :: P.Stmt -> TypeChecker ()
hoistDeclaration (P.Decl typeName ident _) = setType ident $ DeclType typeName
hoistDeclaration :: P.WithCtx P.Stmt -> TypeChecker ()
hoistDeclaration (P.WithCtx _ (P.Decl typeName ident _)) =
setType ident $ DeclType typeName
checkAST :: AST -> TypeChecker TypedAST
checkAST (P.AST stmts) = TypedAST <$> mapM checkStmt stmts
checkStmt :: P.Stmt -> TypeChecker TypedStmt
checkStmt (P.Decl typeName name expr) =
checkStmt :: P.WithCtx P.Stmt -> TypeChecker (WithCtx TypedStmt)
checkStmt (P.WithCtx ctx (P.Decl typeName name expr)) =
lookupDeclType typeName >>= \case
Nothing -> throw $ NoDeclarationType typeName
Nothing -> throw $ NoDeclarationType ctx typeName
Just (TD.DeclType _ expectedType _) -> do
-- Decides whether the argument to the declaration has the correct type
mTypedExpr <- weaken expectedType <$> inferExprType expr
case mTypedExpr of
Left e -> throw e
Right typedExpr -> return $ Decl name typedExpr (DeclType typeName)
Left e -> throw $ WeakenError ctx e
Right typedExpr -> return $ WithCtx ctx $ Decl name typedExpr (DeclType typeName)
-- | Determine the type of an expression, following the inference rules described in
-- the wasplang document. Some these rules are referenced by name in the comments
-- the wasplang document. Some of these rules are referenced by name in the comments
-- of the following functions using [Brackets].
inferExprType :: P.Expr -> TypeChecker TypedExpr
inferExprType (P.StringLiteral s) = return $ StringLiteral s
inferExprType (P.IntegerLiteral i) = return $ IntegerLiteral i
inferExprType (P.DoubleLiteral d) = return $ DoubleLiteral d
inferExprType (P.BoolLiteral b) = return $ BoolLiteral b
inferExprType (P.ExtImport n s) = return $ ExtImport n s
inferExprType (P.Var ident) =
lookupType ident >>= \case
Nothing -> throw $ UndefinedIdentifier ident
Just typ -> return $ Var ident typ
-- For now, the two quoter types are hardcoded here, it is an error to use a different one
-- TODO: this will change when quoters are added to "Analyzer.TypeDefinitions"
inferExprType (P.Quoter "json" s) = return $ JSON s
inferExprType (P.Quoter "psl" s) = return $ PSL s
inferExprType (P.Quoter tag _) = throw $ QuoterUnknownTag tag
-- The type of a list is the unified type of its values.
-- This poses a problem for empty lists, there is not enough information to choose a type.
-- TODO: fix this in the future, probably by adding an additional phase to resolve type variables
-- that would be assigned here
inferExprType (P.List values) = do
typedValues <- mapM inferExprType values
case unify <$> nonEmpty typedValues of
-- Apply [EmptyList]
Nothing -> return $ List [] EmptyListType
Just (Left e) ->
throw e
Just (Right (unifiedValues, unifiedType)) ->
return $ List (toList unifiedValues) (ListType unifiedType)
-- Apply [Dict], and also check that there are no duplicate keys in the dictionary
inferExprType (P.Dict entries) = do
typedEntries <- mapM (\(k, v) -> (k,) <$> inferExprType v) entries
dictType <-
foldM insertIfUniqueElseThrow M.empty $
second (DictRequired . exprType) <$> typedEntries
return $ Dict typedEntries (DictType dictType)
inferExprType :: P.WithCtx P.Expr -> TypeChecker (WithCtx TypedExpr)
inferExprType = P.withCtx $ \ctx -> \case
P.StringLiteral s -> return $ WithCtx ctx $ StringLiteral s
P.IntegerLiteral s -> return $ WithCtx ctx $ IntegerLiteral s
P.DoubleLiteral s -> return $ WithCtx ctx $ DoubleLiteral s
P.BoolLiteral s -> return $ WithCtx ctx $ BoolLiteral s
P.ExtImport n s -> return $ WithCtx ctx $ ExtImport n s
P.Var ident ->
lookupType ident >>= \case
Nothing -> throw $ UndefinedIdentifier ctx ident
Just typ -> return $ WithCtx ctx $ Var ident typ
-- For now, the two quoter types are hardcoded here, it is an error to use a different one
-- TODO: this will change when quoters are added to "Analyzer.TypeDefinitions".
P.Quoter "json" s -> return $ WithCtx ctx $ JSON s
P.Quoter "psl" s -> return $ WithCtx ctx $ PSL s
P.Quoter tag _ -> throw $ QuoterUnknownTag ctx tag
-- The type of a list is the unified type of its values.
-- This poses a problem for empty lists, there is not enough information to choose a type.
-- TODO: Fix this in the future, probably by adding an additional phase to resolve type variables
-- that would be assigned here.
P.List values -> do
typedValues <- mapM inferExprType values
case unify ctx <$> nonEmpty typedValues of
-- Apply [EmptyList].
Nothing -> return $ WithCtx ctx $ List [] EmptyListType
Just (Left e) -> throw e
Just (Right (unifiedValues, unifiedType)) ->
return $ WithCtx ctx $ List (toList unifiedValues) (ListType unifiedType)
-- Apply [Dict], and also check that there are no duplicate keys in the dictionary.
P.Dict entries -> do
typedEntries <- mapM (\(key, expr) -> (key,) <$> inferExprType expr) entries
dictType <-
foldM (insertIfUniqueElseThrow ctx) M.empty $
second (withCtx . const $ DictRequired . exprType) <$> typedEntries
return $ WithCtx ctx $ Dict typedEntries (DictType dictType)
P.Tuple (value1, value2, restOfValues) -> do
typedValue1 <- inferExprType value1
typedValue2 <- inferExprType value2
typedRestOfValues <- mapM inferExprType restOfValues
let typedValues = (typedValue1, typedValue2, typedRestOfValues)
let tupleType =
TupleType
( exprType' typedValue1,
exprType' typedValue2,
exprType' <$> typedRestOfValues
)
return $ WithCtx ctx $ Tuple typedValues tupleType
where
insertIfUniqueElseThrow :: M.HashMap Identifier v -> (Identifier, v) -> TypeChecker (M.HashMap Identifier v)
insertIfUniqueElseThrow m (key, value)
| key `M.member` m = throw $ DictDuplicateField key
exprType' :: WithCtx TypedExpr -> Type
exprType' = exprType . P.fromWithCtx
insertIfUniqueElseThrow :: P.Ctx -> M.HashMap Identifier v -> (Identifier, v) -> TypeChecker (M.HashMap Identifier v)
insertIfUniqueElseThrow ctx m (key, value)
| key `M.member` m = throw $ DictDuplicateField ctx key
| otherwise = return $ M.insert key value m
inferExprType (P.Tuple (value1, value2, restOfValues)) = do
typedValue1 <- inferExprType value1
typedValue2 <- inferExprType value2
typedRestOfValues <- mapM inferExprType restOfValues
let typedValues = (typedValue1, typedValue2, typedRestOfValues)
let tupleType =
TupleType
( exprType typedValue1,
exprType typedValue2,
exprType <$> typedRestOfValues
)
return $ Tuple typedValues tupleType
-- | Finds the strongest common type for all of the given expressions, "common" meaning
-- all the expressions can be typed with it and "strongest" meaning it is as specific
@ -133,74 +138,69 @@ inferExprType (P.Tuple (value1, value2, restOfValues)) = do
--
-- The following property is gauranteed:
--
-- * If @unify exprs == Right (exprs', commonType)@ then @all ((==commonType) . exprType) exprs'@
-- * IF @unify ctx exprs == Right (exprs', commonType)@
-- THEN @all ((==commonType) . exprType . fromWithCtx) exprs'@
--
-- __Examples__
--
-- >>> unify (StringLiteral "a" :| DoubleLiteral 6.28)
-- Left $ UnifyError ReasonUncoercable StringType NumberType
--
-- >>> unify (Dict [("a", IntegerLiteral 2) _ :| Dict [] _)
-- Right (Dict [("a", IntegerLiteral 2)] _ :| Dict [] _, DictType (M.singleton "a" (DictOptional NumberType)))
unify :: NonEmpty TypedExpr -> Either TypeError (NonEmpty TypedExpr, Type)
unify exprs = do
superType <- foldM1 unifyTypes (exprType <$> exprs)
(,superType) <$> mapM (weaken superType) exprs
-- First argument, `Ctx`, is the context of the top level structure or smth that contains all these expressions.
unify :: P.Ctx -> NonEmpty (WithCtx TypedExpr) -> Either TypeError (NonEmpty (WithCtx TypedExpr), Type)
unify ctx texprs@((WithCtx _ texprFirst) :| texprsRest) = do
superType <-
left (UnificationError ctx) $
foldM unifyTypes (exprType texprFirst) texprsRest
left (WeakenError ctx) $
(,superType) <$> mapM (weaken superType) texprs
-- unify (expr :| []) = Right (expr :| [], exprType expr)
-- unify (expr :| exprs) = do
-- superType <- foldM unifyTypes (exprType expr) $ fmap exprType exprs
-- fmap (,superType) $ mapM (weaken superType) $ expr :| exprs
-- | @unifyTypes s t@ finds the strongest type that both @s@ and @t@ are a sub-type of.
--
-- __Examples__
--
-- >>> unifyTypes StringType StringType
-- Right StringType
--
-- >>> unifyTypes (DictType $ M.empty) (DictType $ M.singleton "a" (DictRequired NumberType))
-- Right (DictType (M.singleton "a" (DictOptional NumberType)))
unifyTypes :: Type -> Type -> Either TypeError Type
unifyTypes type1 type2
| type1 == type2 = Right type1
-- | @unifyTypes t texpr@ finds the strongest type that both type @t@ and
-- type of typed expression @texpr@ are a sub-type of.
-- NOTE: The reason it operates on Type and TypedExpr and not just two Types is that
-- having a TypedExpr allows us to report the source position when we encounter a type error.
-- Anyway unification always happens for some typed expressions, so this makes sense.
unifyTypes :: Type -> WithCtx TypedExpr -> Either TypeCoercionError Type
unifyTypes typ (WithCtx _ texpr) | typ == exprType texpr = Right typ
-- Apply [AnyList]: an empty list can unify with any other list
unifyTypes EmptyListType typ@(ListType _) = Right typ
unifyTypes typ@(ListType _) EmptyListType = Right typ
unifyTypes EmptyListType (WithCtx _ (List _ typ)) = Right typ
unifyTypes typ@(ListType _) (WithCtx _ (List _ EmptyListType)) = Right typ
-- Two non-empty lists unify only if their inner types unify
unifyTypes type1@(ListType elemType1) type2@(ListType elemType2) =
annotateError $ ListType <$> unifyTypes elemType1 elemType2
unifyTypes typ@(ListType list1ElemType) texpr@(WithCtx _ (List (list2ElemTexpr1 : _) (ListType _))) =
-- NOTE: We use first element from the typed list (list2ElemTexpr1) as a "sample" to run unification against.
-- This is ok because this list is already typed, so we know all other elements have the same type.
-- We could have alternatively picked any other element from that list.
annotateError $ ListType <$> unifyTypes list1ElemType list2ElemTexpr1
where
annotateError = left (\e -> UnificationError (ReasonList e) type1 type2)
annotateError = left (TypeCoercionError texpr typ . ReasonList)
-- Declarations and enums can not unify with anything
unifyTypes type1@(DeclType _) type2 = Left $ UnificationError ReasonDecl type1 type2
unifyTypes type1@(EnumType _) type2 = Left $ UnificationError ReasonEnum type1 type2
unifyTypes t@(DeclType _) texpr = Left $ TypeCoercionError texpr t ReasonDecl
unifyTypes t@(EnumType _) texpr = Left $ TypeCoercionError texpr t ReasonEnum
-- The unification of two dictionaries is defined by the [DictNone] and [DictSome] rules
unifyTypes type1@(DictType entryTypes1) type2@(DictType entryTypes2) = do
let keys = M.keysSet entryTypes1 <> M.keysSet entryTypes2
unifyTypes t@(DictType dict1EntryTypes) texpr@(WithCtx _ (Dict dict2Entries (DictType dict2EntryTypes))) = do
let keys = M.keysSet dict1EntryTypes <> M.keysSet dict2EntryTypes
unifiedType <- foldMapM' (\key -> M.singleton key <$> unifyEntryTypesForKey key) keys
return $ DictType unifiedType
where
unifyEntryTypesForKey :: String -> Either TypeError DictEntryType
unifyEntryTypesForKey key = annotateError key $ case (M.lookup key entryTypes1, M.lookup key entryTypes2) of
(Nothing, Nothing) ->
error "impossible: unifyTypes.unifyEntryTypesForKey should be called with only the keys of entryTypes1 and entryTypes2"
-- [DictSome] on s, [DictNone] on t
(Just sType, Nothing) ->
Right $ DictOptional $ dictEntryType sType
-- [DictNone] on s, [DictSome] on t
(Nothing, Just tType) ->
Right $ DictOptional $ dictEntryType tType
-- Both require @key@, so it must be a required entry of the unified entry types
(Just (DictRequired sType), Just (DictRequired tType)) ->
DictRequired <$> unifyTypes sType tType
-- One of s or t has @key@ optionally, so it must be an optional entry of the unified entry types
(Just sType, Just tType) ->
DictOptional <$> unifyTypes (dictEntryType sType) (dictEntryType tType)
unifyEntryTypesForKey :: String -> Either TypeCoercionError DictEntryType
unifyEntryTypesForKey key =
annotateError key $
case (M.lookup key dict1EntryTypes, M.lookup key dict2EntryTypes) of
(Nothing, Nothing) ->
error $
"impossible: unifyTypes.unifyEntryTypesForKey should be called"
++ "with only the keys of entryTypes1 and entryTypes2"
-- [DictSome] on s, [DictNone] on t
(Just sType, Nothing) ->
Right $ DictOptional $ dictEntryType sType
-- [DictNone] on s, [DictSome] on t
(Nothing, Just tType) ->
Right $ DictOptional $ dictEntryType tType
-- Both require @key@, so it must be a required entry of the unified entry types
(Just (DictRequired sType), Just (DictRequired _)) ->
DictRequired <$> unifyTypes sType (fromJust $ lookup key dict2Entries)
-- One of s or t has @key@ optionally, so it must be an optional entry of the unified entry types
(Just sType, Just _) ->
DictOptional <$> unifyTypes (dictEntryType sType) (fromJust $ lookup key dict2Entries)
annotateError :: String -> Either TypeError a -> Either TypeError a
annotateError k = left (\e -> UnificationError (ReasonDictWrongKeyType k e) type1 type2)
unifyTypes type1 type2 = Left $ UnificationError ReasonUncoercable type1 type2
annotateError :: String -> Either TypeCoercionError a -> Either TypeCoercionError a
annotateError key = left (TypeCoercionError texpr t . ReasonDictWrongKeyType key)
unifyTypes t texpr = Left $ TypeCoercionError texpr t ReasonUncoercable
-- | Converts a typed expression from its current type to the given weaker type, "weaker"
-- meaning it is a super-type of the original type. If that is possible, it returns the
@ -208,52 +208,52 @@ unifyTypes type1 type2 = Left $ UnificationError ReasonUncoercable type1 type2
--
-- The following property is guaranteed:
--
-- * If @weaken typ expr == Right expr'@ then @exprType expr' == typ@
-- * If @weaken typ expr == Right expr'@ then @(exprType . fromWithCtx) expr' == typ@
--
-- When a @Left@ value is returned, then @expr@ can not be typed as @typ@.
weaken :: Type -> TypedExpr -> Either TypeError TypedExpr
weaken type' expr
| exprType expr == type' = Right expr
weaken :: Type -> WithCtx TypedExpr -> Either TypeCoercionError (WithCtx TypedExpr)
weaken t texprwc@(WithCtx _ texpr)
| exprType texpr == t = Right texprwc
-- Apply [AnyList]: An empty list can be weakened to any list type
weaken type'@(ListType _) (List [] EmptyListType) = return $ List [] type'
-- A non-empty list can be weakened to @typ@ if
-- - @typ@ is of the form @ListType type'@
-- - Every value in the list can be weakened to @type'@
weaken type'@(ListType elemType') expr@(List elems _) = do
elems' <- annotateError $ mapM (weaken elemType') elems
return $ List elems' type'
weaken t@(ListType _) (WithCtx ctx (List [] EmptyListType)) = return $ WithCtx ctx $ List [] t
-- A non-empty list can be weakened to type @t@ if
-- - @t@ is of the form @ListType elemType@
-- - Every value in the list can be weakened to type @elemType@
weaken t@(ListType elemType) texprwc@(WithCtx ctx ((List elems _))) = do
elems' <- annotateError $ mapM (weaken elemType) elems
return $ WithCtx ctx $ List elems' t
where
annotateError = left (\e -> WeakenError (ReasonList e) expr elemType')
weaken (DictType entryTypes') expr@(Dict entries _) = do
annotateError = left (TypeCoercionError texprwc elemType . ReasonList)
weaken t@(DictType entryTypes) texprwc@(WithCtx ctx (Dict entries _)) = do
entries' <- mapM weakenEntry entries
mapM_ ensureExprSatisifiesEntryType $ M.toList entryTypes'
return $ Dict entries' $ DictType entryTypes'
mapM_ ensureExprSatisifiesEntryType $ M.toList entryTypes
return $ WithCtx ctx $ Dict entries' t
where
-- Tries to apply [DictSome] and [DictNone] rules to the entries of the dict
weakenEntry :: (String, TypedExpr) -> Either TypeError (Identifier, TypedExpr)
weakenEntry (key, value) = case M.lookup key entryTypes' of
weakenEntry :: (Identifier, WithCtx TypedExpr) -> Either TypeCoercionError (Identifier, WithCtx TypedExpr)
weakenEntry (key, value) = case M.lookup key entryTypes of
-- @key@ is missing from @typ'@ => extra keys are not allowed
Nothing -> Left $ WeakenError (ReasonDictExtraKey key) expr (DictType entryTypes')
Nothing -> Left $ TypeCoercionError texprwc t (ReasonDictExtraKey key)
-- @key@ is required and present => only need to weaken the value's type
Just (DictRequired valueTyp) -> (key,) <$> annotateError key (weaken valueTyp value)
Just (DictRequired valueTyp) -> (key,) <$> annotateKeyTypeError key (weaken valueTyp value)
-- @key@ is optional and present => weaken value's type + use [DictSome]
Just (DictOptional valueTyp) -> (key,) <$> annotateError key (weaken valueTyp value)
Just (DictOptional valueTyp) -> (key,) <$> annotateKeyTypeError key (weaken valueTyp value)
-- Checks that all DictRequired entries in typ' exist in entries
ensureExprSatisifiesEntryType :: (String, DictEntryType) -> Either TypeError ()
ensureExprSatisifiesEntryType :: (Identifier, DictEntryType) -> Either TypeCoercionError ()
ensureExprSatisifiesEntryType (key, DictOptional typ) = case lookup key entries of
-- @key@ is optional and missing => use [DictNone]
Nothing -> Right ()
-- @key@ is optional and present => weaken the value's type + use [DictSome]
Just entryVal -> void $ annotateError key $ weaken typ entryVal
Just entryVal -> void $ annotateKeyTypeError key $ weaken typ entryVal
ensureExprSatisifiesEntryType (key, DictRequired typ) = case lookup key entries of
-- @key@ is required and missing => not allowed
Nothing -> Left $ WeakenError (ReasonDictNoKey key) expr (DictType entryTypes')
Nothing -> Left $ TypeCoercionError texprwc t (ReasonDictNoKey key)
-- @key@ is required and present => only need to weaken value's type
Just entryVal -> void $ annotateError key $ weaken typ entryVal
Just entryVal -> void $ annotateKeyTypeError key $ weaken typ entryVal
-- Wraps a ReasonDictWrongKeyType error around a type error
annotateError :: String -> Either TypeError a -> Either TypeError a
annotateError k = left (\e -> WeakenError (ReasonDictWrongKeyType k e) expr (DictType entryTypes'))
annotateKeyTypeError :: String -> Either TypeCoercionError a -> Either TypeCoercionError a
annotateKeyTypeError key = left (TypeCoercionError texprwc t . ReasonDictWrongKeyType key)
-- All other cases can not be weakened
weaken typ' expr = Left $ WeakenError ReasonUncoercable expr typ'
weaken typ' expr = Left $ TypeCoercionError expr typ' ReasonUncoercable

108
waspc/src/Wasp/Analyzer/TypeChecker/TypeError.hs
View File

@ -1,38 +1,60 @@
{-# LANGUAGE LambdaCase #-}
module Wasp.Analyzer.TypeChecker.TypeError
( TypeError (..),
TypeCoerceReason (..),
TypeCoercionErrorReason (..),
TypeCoercionError (..),
getErrorMessageAndCtx,
)
where
-- TODO:
-- TypeErrors are not detailed enough for the final version, missing is:
-- 1. Reporting multiple type errors:
-- This can be incrementally improved, e.g.
-- 1. improve to 1 error per statement
-- 2. improve to multiple errors per list/per dictionray
-- 2. Position information:
-- The start position in the source and end position should be recorded. (3) may
-- affect this, since it may be hard to say exactly where a unification or
-- weaken error happened.
-- 3. Informative error messages:
-- Make user-readable messages from all errors, and special care into explaining
-- unification and weaken errors (users shouldn't have to know what unification
-- and weakening is).
import Control.Arrow (first)
import Data.List (intercalate)
import Wasp.Analyzer.Parser.Ctx (Ctx)
import Wasp.Analyzer.Type
import Wasp.Analyzer.TypeChecker.AST
import Wasp.Util (concatPrefixAndText, concatShortPrefixAndText, indent)
{- ORMOLU_DISABLE -}
data TypeError
= UnificationError TypeCoerceReason Type Type
| WeakenError TypeCoerceReason TypedExpr Type
| NoDeclarationType String
| UndefinedIdentifier String
| QuoterUnknownTag String
| DictDuplicateField String
-- | Type coercion error that occurs when trying to "unify" the type T1 of typed expression with some other type T2.
-- If there is a super type that both T2 and T1 can be safely coerced to, "unify" will succeed, but if not,
-- we get this error.
-- We use "unify" in the TypeChecker when trying to infer the common type for typed expressions that we know
-- should be of the same type (e.g. for elements in the list).
= UnificationError Ctx TypeCoercionError
-- | Type coercion error that occurs when trying to "weaken" the typed expression from its type T1 to some type T2.
-- If T2 is super type of T1 and T1 can be safely coerced to T2, "weaken" will succeed, but if not, we get this error.
-- We use "weaken" in the TypeChecker when trying to match inferred type of typed expression with some expected type.
| WeakenError Ctx TypeCoercionError
| NoDeclarationType Ctx TypeName
| UndefinedIdentifier Ctx Identifier
| QuoterUnknownTag Ctx QuoterTag
| DictDuplicateField Ctx DictFieldName
deriving (Eq, Show)
{- ORMOLU_ENABLE -}
type TypeName = String
type QuoterTag = String
type DictFieldName = String
getErrorMessageAndCtx :: TypeError -> (String, Ctx)
getErrorMessageAndCtx = \case
(NoDeclarationType pos typeName) -> ("Unknown declaration type: " ++ typeName, pos)
(UndefinedIdentifier pos identifier) -> ("Undefined identifier: " ++ identifier, pos)
(QuoterUnknownTag pos quoterTag) -> ("Unknown quoter tag: " ++ quoterTag, pos)
(DictDuplicateField pos dictFieldName) -> ("Duplicate dictionary field: " ++ dictFieldName, pos)
(UnificationError _ e) -> getUnificationErrorMessageAndCtx e
(WeakenError _ e) -> getWeakenErrorMessageAndCtx e
-- TypeCoercionError <typed expression> <type which we tried to coerce the typed expression to/with> <reason>
data TypeCoercionError = TypeCoercionError (WithCtx TypedExpr) Type (TypeCoercionErrorReason TypeCoercionError)
deriving (Eq, Show)
-- | Describes a reason that a @UnificationError@ or @WeakenError@ happened
data TypeCoerceReason
data TypeCoercionErrorReason e
= -- | A coercion involving a DeclType and a different type happened. For example,
-- @unifyTypes (DeclType "foo") (DeclType "bar")@ and
-- @unifyTypes (DeclType "foo") StringType@ would use this reason.
@ -43,11 +65,47 @@ data TypeCoerceReason
| -- | There is no relationship between the types in the coercion
ReasonUncoercable
| -- | A coercion of the type contained in a list failed
ReasonList TypeError
ReasonList e
| -- | A coercion failed because a dictionary was missing a key
ReasonDictNoKey String
| -- | A coercion failed because a dictionary contained an extra key
ReasonDictExtraKey String
| -- | A coercion failed because two dictionaries had uncoercable types for a key
ReasonDictWrongKeyType String TypeError
ReasonDictWrongKeyType String e
deriving (Eq, Show)
getTypeCoercionErrorMessageAndCtx :: (Type -> TypedExpr -> String) -> TypeCoercionError -> (String, Ctx)
getTypeCoercionErrorMessageAndCtx getUncoercableTypesMsg (TypeCoercionError (WithCtx ctx texpr) t reason) =
case reason of
ReasonList e ->
first (("For list element:\n" ++) . indent 2) $
getTypeCoercionErrorMessageAndCtx getUncoercableTypesMsg e
ReasonDictWrongKeyType key e ->
first ((("For dictionary field '" ++ key ++ "':\n") ++) . indent 2) $
getTypeCoercionErrorMessageAndCtx getUncoercableTypesMsg e
ReasonDictNoKey key -> ("Missing required dictionary field '" ++ key ++ "'", ctx)
ReasonDictExtraKey key -> ("Unexpected dictionary field '" ++ key ++ "'", ctx)
ReasonDecl -> uncoercableTypesMsgAndCtx
ReasonEnum -> uncoercableTypesMsgAndCtx
ReasonUncoercable -> uncoercableTypesMsgAndCtx
where
uncoercableTypesMsgAndCtx = (getUncoercableTypesMsg t texpr, ctx)
getUnificationErrorMessageAndCtx :: TypeCoercionError -> (String, Ctx)
getUnificationErrorMessageAndCtx = getTypeCoercionErrorMessageAndCtx $
\t texpr ->
intercalate
"\n"
[ "Can't mix the following types:",
concatShortPrefixAndText " - " (show t),
concatShortPrefixAndText " - " (show $ exprType texpr)
]
getWeakenErrorMessageAndCtx :: TypeCoercionError -> (String, Ctx)
getWeakenErrorMessageAndCtx = getTypeCoercionErrorMessageAndCtx $
\t texpr ->
intercalate
"\n"
[ concatPrefixAndText "Expected type: " (show t),
concatPrefixAndText "Actual type: " (show $ exprType texpr)
]

4
waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsDeclType.hs
View File

@ -8,7 +8,7 @@ where
import Data.Typeable (Typeable)
import Wasp.Analyzer.Evaluator.Bindings (Bindings)
import Wasp.Analyzer.Evaluator.EvaluationError (EvaluationError)
import Wasp.Analyzer.TypeChecker.AST (TypedExpr)
import Wasp.Analyzer.TypeChecker.AST (TypedExpr, WithCtx)
import Wasp.Analyzer.TypeDefinitions.Internal (DeclType, TypeDefinitions)
import qualified Wasp.AppSpec.Core.Decl as AppSpecDecl
@ -47,4 +47,4 @@ class (Typeable a, AppSpecDecl.IsDecl a) => IsDeclType a where
-- and @4@ is declaration body.
-- @declEvaluate@ function would then be called somewhat like:
-- @declEvaluate @Test typeDefs bindings (NumberLiteral 4)@
declEvaluate :: TypeDefinitions -> Bindings -> TypedExpr -> Either EvaluationError a
declEvaluate :: TypeDefinitions -> Bindings -> WithCtx TypedExpr -> Either EvaluationError a

4
waspc/src/Wasp/Analyzer/TypeDefinitions/Internal.hs
View File

@ -9,7 +9,7 @@ import qualified Data.HashMap.Strict as M
import Wasp.Analyzer.Evaluator.Bindings (Bindings, DeclName)
import Wasp.Analyzer.Evaluator.EvaluationError (EvaluationError)
import Wasp.Analyzer.Type (Type)
import Wasp.Analyzer.TypeChecker.AST (TypedExpr)
import Wasp.Analyzer.TypeChecker.AST (TypedExpr, WithCtx)
import Wasp.AppSpec.Core.Decl (Decl)
-- | Describes a specific declaration type in Wasp.
@ -25,7 +25,7 @@ data DeclType = DeclType
--
-- Check @declEvaluate@ of @IsDeclType@ typeclass for more information,
-- since @dtEvaluate@ is really a value-level version of @declEvaluate@.
dtEvaluate :: TypeDefinitions -> Bindings -> DeclName -> TypedExpr -> Either EvaluationError Decl
dtEvaluate :: TypeDefinitions -> Bindings -> DeclName -> WithCtx TypedExpr -> Either EvaluationError Decl
}
-- | Describes a specific enum type in Wasp.

53
waspc/src/Wasp/Util.hs
View File

@ -6,6 +6,8 @@ module Wasp.Util
headSafe,
jsonSet,
indent,
concatShortPrefixAndText,
concatPrefixAndText,
)
where
@ -49,3 +51,54 @@ jsonSet _ _ _ = error "Input JSON must be an object"
indent :: Int -> String -> String
indent numSpaces = intercalate "\n" . map (replicate numSpaces ' ' ++) . splitOn "\n"
-- | Given a prefix and text, concatenates them in the following manner:
-- <prefix> <text_line_1>
-- <text_line_2>
-- ...
-- <text_line_N>
--
-- __Examples__
--
-- @
-- >>> putStrLn $ concatShortPrefixAndText "Log: " "Written to file foo.txt"
-- Log: Written to file foo.txt
-- @
--
-- @
-- >>> putStrLn $ concatShortPrefixAndText "Log: " "Written to file foo.txt\nWritten to file bar.txt"
-- Log: Written to file foo.txt
-- Written to file bar.txt
-- @
concatShortPrefixAndText :: String -> String -> String
concatShortPrefixAndText prefix "" = prefix
concatShortPrefixAndText prefix text =
let (l : ls) = lines text
in prefix ++ l ++ if null ls then "" else "\n" ++ indent (length prefix) (intercalate "\n" ls)
-- | Given a prefix and text, concatenates them in the following manner:
-- - If just one line of text:
-- <prefix> <one_and_only_line_of_text>
-- - If multiple lines of text:
-- <prefix>
-- <text_line_1>
-- <text_line_2>
-- ...
-- <text_line_N>
--
-- __Examples__
--
-- @
-- >>> putStrLn $ concatPrefixAndText "Log messages from the somelog.txt file: " "Written to file foo.txt"
-- Log messages from the somelog.txt file: Written to file foo.txt
-- @
--
-- @
-- >>> putStrLn $ concatPrefixAndText "Log messages from the somelog.txt file:" "Written to file foo.txt\nWritten to file bar.txt"
-- Log messages from the somelog.txt file:
-- Written to file foo.txt
-- Written to file bar.txt
-- @
concatPrefixAndText :: String -> String -> String
concatPrefixAndText prefix text =
if length (lines text) <= 1 then prefix ++ text else prefix ++ "\n" ++ indent 2 text

2
waspc/test/Analyzer/EvaluatorTest.hs
View File

@ -84,7 +84,7 @@ data SemanticVersion = SemanticVersion Int Int Int
instance HasCustomEvaluation SemanticVersion where
waspType = T.StringType
evaluation = E.evaluation' $ \case
evaluation = E.evaluation' . TypedAST.withCtx $ \_ctx -> \case
TypedAST.StringLiteral str -> case splitOn "." str of
[major, minor, patch] ->
maybe

57
waspc/test/Analyzer/Parser/ParseErrorTest.hs
View File

@ -1,5 +1,6 @@
module Analyzer.Parser.ParseErrorTest where
import Analyzer.TestUtil (ctx, pos)
import Test.Tasty.Hspec
import Wasp.Analyzer.Parser.ParseError
import Wasp.Analyzer.Parser.Token
@ -7,39 +8,31 @@ import Wasp.Analyzer.Parser.Token
spec_ParseErrorTest :: Spec
spec_ParseErrorTest = do
describe "Analyzer.Parser.ParseError" $ do
let unexpectedCharError = UnexpectedChar '!' (SourcePosition 2 42)
unexpectedTokenErrorNoSuggestions =
UnexpectedToken (Token TLCurly (SourcePosition 2 3) "{") []
unexpectedTokenErrorWithSuggestions =
UnexpectedToken
(Token TRCurly (SourcePosition 100 18) "}")
["<identifier>", ","]
quoterDifferentTagsError =
QuoterDifferentTags
("foo", SourcePosition 1 5)
("bar", SourcePosition 1 20)
describe "getErrorMessage returns human readable error message" $ do
it "for UnexpectedChar error" $ do
getErrorMessage unexpectedCharError `shouldBe` "Unexpected character: !"
it "for UnexpectedToken error" $ do
getErrorMessage unexpectedTokenErrorNoSuggestions
`shouldBe` "Unexpected token: {"
getErrorMessage unexpectedTokenErrorWithSuggestions
`shouldBe` ( "Unexpected token: }\n"
++ "Expected one of the following tokens instead: <identifier> ,"
)
it "for QuoterDifferentTags error" $ do
getErrorMessage quoterDifferentTagsError
`shouldBe` "Quoter tags don't match: {=foo ... bar=}"
describe "getErrorMessageAndCtx returns a human readable error message and the correct position" $ do
let unexpectedCharError = UnexpectedChar '!' (pos 2 42)
unexpectedTokenErrorNoSuggestions =
UnexpectedToken (Token TLCurly (pos 2 3) "{") []
unexpectedTokenErrorWithSuggestions =
UnexpectedToken
(Token TRCurly (pos 100 18) "}")
["<identifier>", ","]
quoterDifferentTagsError =
QuoterDifferentTags
("foo", pos 1 5)
("bar", pos 1 20)
describe "getSourcePosition returns correct position" $ do
it "for UnexpectedChar error" $ do
getSourcePosition unexpectedCharError `shouldBe` SourcePosition 2 42
getErrorMessageAndCtx unexpectedCharError `shouldBe` ("Unexpected character: !", ctx 2 42)
it "for UnexpectedToken error" $ do
getSourcePosition unexpectedTokenErrorNoSuggestions
`shouldBe` SourcePosition 2 3
getSourcePosition unexpectedTokenErrorWithSuggestions
`shouldBe` SourcePosition 100 18
getErrorMessageAndCtx unexpectedTokenErrorNoSuggestions
`shouldBe` ("Unexpected token: {", ctx 2 3)
getErrorMessageAndCtx unexpectedTokenErrorWithSuggestions
`shouldBe` ( "Unexpected token: }\n"
++ "Expected one of the following tokens instead: <identifier> ,",
ctx 100 18
)
it "for QuoterDifferentTags error" $ do
getSourcePosition quoterDifferentTagsError
`shouldBe` SourcePosition 1 20
getErrorMessageAndCtx quoterDifferentTagsError
`shouldBe` ("Quoter tags don't match: {=foo ... bar=}", ctx 1 20)

171
waspc/test/Analyzer/ParserTest.hs
View File

@ -1,5 +1,6 @@
module Analyzer.ParserTest where
import Analyzer.TestUtil
import Data.Either (isLeft)
import Test.Tasty.Hspec
import Wasp.Analyzer.Parser
@ -23,21 +24,24 @@ spec_Parser = do
]
let ast =
AST
[ Decl "test" "Decl" $
Dict
[ ("string", StringLiteral "Hello Wasp =}"),
("escapedString", StringLiteral "Look, a \""),
("integer", IntegerLiteral 42),
("real", DoubleLiteral 3.14),
("yes", BoolLiteral True),
("no", BoolLiteral False),
("ident", Var "Wasp"),
( "innerDict",
Dict
[ ("innerDictReal", DoubleLiteral 2.17)
]
)
]
[ wctx 1 1 $
Decl "test" "Decl" $
wctx 1 11 $
Dict
[ ("string", wctx 2 11 $ StringLiteral "Hello Wasp =}"),
("escapedString", wctx 3 18 $ StringLiteral "Look, a \""),
("integer", wctx 4 12 $ IntegerLiteral 42),
("real", wctx 5 9 $ DoubleLiteral 3.14),
("yes", wctx 6 8 $ BoolLiteral True),
("no", wctx 7 7 $ BoolLiteral False),
("ident", wctx 8 10 $ Var "Wasp"),
( "innerDict",
wctx 9 14 $
Dict
[ ("innerDictReal", wctx 9 31 $ DoubleLiteral 2.17)
]
)
]
]
parse source `shouldBe` Right ast
@ -51,33 +55,47 @@ spec_Parser = do
]
let ast =
AST
[ Decl "test" "Imports" $
Dict
[ ("module", ExtImport (ExtImportModule "Page") "page.jsx"),
("field", ExtImport (ExtImportField "Page") "page.jsx")
]
[ wctx 1 1 $
Decl "test" "Imports" $
wctx 1 14 $
Dict
[ ("module", wctx 2 11 $ ExtImport (ExtImportModule "Page") "page.jsx"),
("field", wctx 3 10 $ ExtImport (ExtImportField "Page") "page.jsx")
]
]
parse source `shouldBe` Right ast
it "Parses unary lists" $ do
let source = "test Decl [ 1 ]"
let ast = AST [Decl "test" "Decl" $ List [IntegerLiteral 1]]
let ast = AST [wctx 1 1 $ Decl "test" "Decl" $ wctx 1 11 $ List [wctx 1 13 $ IntegerLiteral 1]]
parse source `shouldBe` Right ast
it "Parses lists of multiple elements" $ do
let source = "test Decl [ 1, 2, 3 ]"
let ast = AST [Decl "test" "Decl" $ List [IntegerLiteral 1, IntegerLiteral 2, IntegerLiteral 3]]
let ast =
AST
[ wctx 1 1 $
Decl "test" "Decl" $
wctx 1 11 $
List
[ wctx 1 13 $ IntegerLiteral 1,
wctx 1 16 $ IntegerLiteral 2,
wctx 1 19 $ IntegerLiteral 3
]
]
parse source `shouldBe` Right ast
it "Parses empty dictionaries and lists" $ do
let source = "test Decl { dict: {}, list: [] }"
let ast =
AST
[ Decl "test" "Decl" $
Dict
[ ("dict", Dict []),
("list", List [])
]
[ wctx 1 1 $
Decl "test" "Decl" $
wctx 1 11 $
Dict
[ ("dict", wctx 1 19 $ Dict []),
("list", wctx 1 29 $ List [])
]
]
parse source `shouldBe` Right ast
@ -90,9 +108,11 @@ spec_Parser = do
]
let ast =
AST
[ Decl "test" "Decl" $
Dict
[("list", List [IntegerLiteral 1])]
[ wctx 1 1 $
Decl "test" "Decl" $
wctx 1 11 $
Dict
[("list", wctx 2 9 $ List [wctx 2 11 $ IntegerLiteral 1])]
]
parse source `shouldBe` Right ast
@ -106,32 +126,40 @@ spec_Parser = do
]
let ast =
AST
[ Decl "test" "Pair" $
Tuple
( IntegerLiteral 1,
StringLiteral "foo",
[]
),
Decl "test" "Triple" $
Tuple
( IntegerLiteral 1,
StringLiteral "foo",
[IntegerLiteral 2]
),
Decl "test" "Quadruple" $
Tuple
( IntegerLiteral 1,
StringLiteral "foo",
[ IntegerLiteral 2,
BoolLiteral True
]
),
Decl "test" "TrailingComma" $
Tuple
( IntegerLiteral 42,
IntegerLiteral 314,
[]
)
[ wctx 1 1 $
Decl "test" "Pair" $
wctx 1 11 $
Tuple
( wctx 1 12 $ IntegerLiteral 1,
wctx 1 15 $ StringLiteral "foo",
[]
),
wctx 2 1 $
Decl "test" "Triple" $
wctx 2 13 $
Tuple
( wctx 2 14 $ IntegerLiteral 1,
wctx 2 17 $ StringLiteral "foo",
[wctx 2 24 $ IntegerLiteral 2]
),
wctx 3 1 $
Decl "test" "Quadruple" $
wctx 3 16 $
Tuple
( wctx 3 17 $ IntegerLiteral 1,
wctx 3 20 $ StringLiteral "foo",
[ wctx 3 27 $ IntegerLiteral 2,
wctx 3 30 $ BoolLiteral True
]
),
wctx 4 1 $
Decl "test" "TrailingComma" $
wctx 4 20 $
Tuple
( wctx 4 21 $ IntegerLiteral 42,
wctx 4 25 $ IntegerLiteral 314,
[]
)
]
parse source `shouldBe` Right ast
@ -142,7 +170,13 @@ spec_Parser = do
" id Int @id",
"psl=}"
]
let ast = AST [Decl "test" "PSL" $ Quoter "psl" "\n id Int @id\n"]
let ast =
AST
[ wctx 1 1 $
Decl "test" "PSL" $
wctx 1 10 $
Quoter "psl" "\n id Int @id\n"
]
parse source `shouldBe` Right ast
it "Parses quoted JSON" $ do
@ -152,7 +186,12 @@ spec_Parser = do
" \"key\": \"value\"",
"json=}"
]
let ast = AST [Decl "test" "JSON" $ Quoter "json" "\n \"key\": \"value\"\n"]
let ast =
AST
[ wctx 1 1 $
Decl "test" "JSON" $
wctx 1 11 $ Quoter "json" "\n \"key\": \"value\"\n"
]
parse source `shouldBe` Right ast
it "Parses multiple quoters" $ do
@ -167,8 +206,8 @@ spec_Parser = do
]
let ast =
AST
[ Decl "test" "JSON" $ Quoter "json" "\n \"key\": \"value\"\n",
Decl "test" "JSON2" $ Quoter "json" "\n \"key\": \"value\"\n"
[ wctx 1 1 $ Decl "test" "JSON" $ wctx 1 11 $ Quoter "json" "\n \"key\": \"value\"\n",
wctx 4 1 $ Decl "test" "JSON2" $ wctx 4 12 $ Quoter "json" "\n \"key\": \"value\"\n"
]
parse source `shouldBe` Right ast
@ -180,13 +219,13 @@ spec_Parser = do
parse "test Case1 {=foo {=foo foo=} foo=}" `shouldSatisfy` isLeft
parse "test Case2 {=foo foo=} foo=}" `shouldSatisfy` isLeft
parse "test Case3 {=foo {=foo foo=}"
`shouldBe` Right (AST [Decl "test" "Case3" $ Quoter "foo" " {=foo "])
`shouldBe` Right (AST [wctx 1 1 $ Decl "test" "Case3" $ wctx 1 12 $ Quoter "foo" " {=foo "])
parse "test Case4 {=foo {=bar foo=}"
`shouldBe` Right (AST [Decl "test" "Case4" $ Quoter "foo" " {=bar "])
`shouldBe` Right (AST [wctx 1 1 $ Decl "test" "Case4" $ wctx 1 12 $ Quoter "foo" " {=bar "])
parse "test Case5 {=foo bar=} foo=}"
`shouldBe` Right (AST [Decl "test" "Case5" $ Quoter "foo" " bar=} "])
`shouldBe` Right (AST [wctx 1 1 $ Decl "test" "Case5" $ wctx 1 12 $ Quoter "foo" " bar=} "])
parse "test Case6 {=foo {=bar bar=} foo=}"
`shouldBe` Right (AST [Decl "test" "Case6" $ Quoter "foo" " {=bar bar=} "])
`shouldBe` Right (AST [wctx 1 1 $ Decl "test" "Case6" $ wctx 1 12 $ Quoter "foo" " {=bar bar=} "])
it "Requires dictionaries to have an ending bracket" $ do
let source = "test Decl {"
@ -210,8 +249,8 @@ spec_Parser = do
]
let ast =
AST
[ Decl "constant" "Pi" $ DoubleLiteral 3.14159,
Decl "constant" "E" $ DoubleLiteral 2.71828
[ wctx 1 1 $ Decl "constant" "Pi" $ wctx 1 13 $ DoubleLiteral 3.14159,
wctx 2 1 $ Decl "constant" "E" $ wctx 2 13 $ DoubleLiteral 2.71828
]
parse source `shouldBe` Right ast

16
waspc/test/Analyzer/TestUtil.hs Normal file
View File

@ -0,0 +1,16 @@
module Analyzer.TestUtil where
import qualified Wasp.Analyzer.Parser as P
import qualified Wasp.Analyzer.TypeChecker as T
pos :: Int -> Int -> P.SourcePosition
pos line column = P.SourcePosition line column
ctx :: Int -> Int -> P.Ctx
ctx line column = P.ctxFromPos $ P.SourcePosition line column
wctx :: Int -> Int -> a -> P.WithCtx a
wctx line column = P.WithCtx (ctx line column)
fromWithCtx :: P.WithCtx T.TypedExpr -> T.TypedExpr
fromWithCtx = P.fromWithCtx

205
waspc/test/Analyzer/TypeChecker/InternalTest.hs
View File

@ -1,5 +1,6 @@
module Analyzer.TypeChecker.InternalTest where
import Analyzer.TestUtil (ctx, fromWithCtx, wctx)
import qualified Data.HashMap.Strict as H
import Data.List.NonEmpty (NonEmpty ((:|)))
import Test.Tasty.Hspec
@ -34,109 +35,125 @@ chooseType =
QuoterType "psl"
]
inferExprType' :: Bindings -> P.Expr -> Either TypeError TypedExpr
inferExprType' :: Bindings -> P.WithCtx P.Expr -> Either TypeError (WithCtx TypedExpr)
inferExprType' bindings expr = runWithBound bindings TD.empty $ inferExprType expr
test :: String -> P.Expr -> Either TypeError Type -> SpecWith (Arg Expectation)
test :: String -> P.WithCtx P.Expr -> Either TypeError Type -> SpecWith (Arg Expectation)
test name expr expected = it name $ do
let actual = exprType <$> inferExprType' H.empty expr
let actual = exprType . fromWithCtx <$> inferExprType' H.empty expr
actual `shouldBe` expected
testSuccess :: String -> P.Expr -> Type -> SpecWith (Arg Expectation)
testSuccess :: String -> P.WithCtx P.Expr -> Type -> SpecWith (Arg Expectation)
testSuccess name expr = test name expr . Right
testFail :: String -> P.Expr -> TypeError -> SpecWith (Arg Expectation)
testFail :: String -> P.WithCtx P.Expr -> TypeError -> SpecWith (Arg Expectation)
testFail name expr = test name expr . Left
spec_Internal :: Spec
spec_Internal = do
describe "Analyzer.TypeChecker.Internal" $ do
describe "unify" $ do
let ctx1 = ctx 1 1
ctx2 = ctx 1 10
ctx3 = ctx 2 5
ctx4 = ctx 2 12
ctx5 = ctx 2 20
ctx6 = ctx 3 3
ctx7 = ctx 3 11
wctx2 = WithCtx ctx2
wctx3 = WithCtx ctx3
wctx4 = WithCtx ctx4
wctx5 = WithCtx ctx5
wctx6 = WithCtx ctx6
wctx7 = WithCtx ctx7
it "Doesn't affect 2 expressions of the same type" $ do
property $ \(a, b) ->
let initial = IntegerLiteral a :| [DoubleLiteral b]
actual = unify initial
let initial = wctx2 (IntegerLiteral a) :| [wctx3 $ DoubleLiteral b]
actual = unify ctx1 initial
in actual == Right (initial, NumberType)
it "Unifies two same-typed dictionaries to their original type" $ do
let typ = DictType $ H.fromList [("a", DictRequired BoolType), ("b", DictOptional NumberType)]
let a = Dict [("a", BoolLiteral True), ("b", IntegerLiteral 2)] typ
let b = Dict [("a", BoolLiteral True), ("b", DoubleLiteral 3.14)] typ
unify (a :| [b])
`shouldBe` Right (a :| [b], typ)
let a = wctx2 $ Dict [("a", wctx3 $ BoolLiteral True), ("b", wctx4 $ IntegerLiteral 2)] typ
let b = wctx5 $ Dict [("a", wctx6 $ BoolLiteral True), ("b", wctx7 $ DoubleLiteral 3.14)] typ
let texprs = a :| [b]
unify ctx1 texprs
`shouldBe` Right (texprs, typ)
it "Unifies an empty dict and a dict with one property" $ do
let a = Dict [] (DictType H.empty)
let b = Dict [("a", BoolLiteral True)] $ DictType $ H.singleton "a" $ DictRequired BoolType
let expected = DictType $ H.singleton "a" $ DictOptional BoolType
fmap (fmap exprType . fst) (unify (a :| [b]))
`shouldBe` Right (expected :| [expected])
let a = wctx2 $ Dict [] (DictType H.empty)
let b = wctx3 $ Dict [("a", wctx4 $ BoolLiteral True)] (DictType $ H.singleton "a" $ DictRequired BoolType)
let expectedType = DictType $ H.singleton "a" $ DictOptional BoolType
fmap (fmap (exprType . fromWithCtx) . fst) (unify ctx1 (a :| [b]))
`shouldBe` Right (expectedType :| [expectedType])
it "Is idempotent when unifying an empty dict and a singleton dict" $ do
let a = Dict [] (DictType H.empty)
let b = Dict [("a", BoolLiteral True)] $ DictType $ H.singleton "a" $ DictRequired BoolType
unify (a :| [b]) `shouldBe` (unify (a :| [b]) >>= unify . fst)
let a = wctx2 $ Dict [] (DictType H.empty)
let b = wctx3 $ Dict [("a", wctx4 $ BoolLiteral True)] $ DictType $ H.singleton "a" $ DictRequired BoolType
unify ctx1 (a :| [b]) `shouldBe` (unify ctx1 (a :| [b]) >>= unify ctx1 . fst)
it "Unifies an empty list with any other list" $ do
let a = List [] EmptyListType
let b = List [StringLiteral "a"] (ListType StringType)
let a = wctx2 $ List [] EmptyListType
let b = wctx3 $ List [wctx4 $ StringLiteral "a"] (ListType StringType)
let expected = ListType StringType
fmap (fmap exprType . fst) (unify (a :| [b]))
fmap (fmap (exprType . fromWithCtx) . fst) (unify ctx1 (a :| [b]))
`shouldBe` Right (expected :| [expected])
describe "inferExprType" $ do
testSuccess "Types string literals as StringType" (P.StringLiteral "string") StringType
testSuccess "Types integer literals as NumberType" (P.IntegerLiteral 42) NumberType
testSuccess "Types double literals as NumberType" (P.DoubleLiteral 3.14) NumberType
testSuccess "Types bool literals as BoolType" (P.BoolLiteral True) BoolType
testSuccess "Types string literals as StringType" (wctx 1 1 $ P.StringLiteral "string") StringType
testSuccess "Types integer literals as NumberType" (wctx 1 1 $ P.IntegerLiteral 42) NumberType
testSuccess "Types double literals as NumberType" (wctx 1 1 $ P.DoubleLiteral 3.14) NumberType
testSuccess "Types bool literals as BoolType" (wctx 1 1 $ P.BoolLiteral True) BoolType
testSuccess
"Types external imports as ExtImportType"
(P.ExtImport (P.ExtImportModule "Main") "main.js")
(wctx 1 1 $ P.ExtImport (P.ExtImportModule "Main") "main.js")
ExtImportType
testSuccess "Types quoted json as JSONType" (P.Quoter "json" "\"key\": \"value\"") (QuoterType "json")
testSuccess "Types quoted psl as PSLType" (P.Quoter "psl" "id Int @id") (QuoterType "psl")
testSuccess "Types quoted json as JSONType" (wctx 1 1 $ P.Quoter "json" "\"key\": \"value\"") (QuoterType "json")
testSuccess "Types quoted psl as PSLType" (wctx 1 1 $ P.Quoter "psl" "id Int @id") (QuoterType "psl")
testFail
"Fails to type check quoters with tag besides json or psl"
(P.Quoter "toml" "key = \"value\"")
(QuoterUnknownTag "toml")
(wctx 1 1 $ P.Quoter "toml" "key = \"value\"")
(QuoterUnknownTag (ctx 1 1) "toml")
it "Types identifier as the type in the bindings" $ do
forAll chooseType $ \typ ->
let bindings = H.singleton "var" typ
actual = exprType <$> inferExprType' bindings (P.Var "var")
actual = exprType . fromWithCtx <$> inferExprType' bindings (wctx 1 1 $ P.Var "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 <$> inferExprType' bindings (P.Var "pi")
let expected = Left $ UndefinedIdentifier "pi"
let actual = exprType . fromWithCtx <$> inferExprType' bindings (wctx 1 1 $ P.Var "pi")
let expected = Left $ UndefinedIdentifier (ctx 1 1) "pi"
actual `shouldBe` expected
testSuccess
"Type checks a dictionary"
(P.Dict [("a", P.IntegerLiteral 5), ("b", P.StringLiteral "string")])
(wctx 1 1 $ P.Dict [("a", wctx 2 5 $ P.IntegerLiteral 5), ("b", wctx 3 5 $ P.StringLiteral "string")])
(DictType $ H.fromList [("a", DictRequired NumberType), ("b", DictRequired StringType)])
testFail
"Fails to type check a dictionary with duplicated keys"
(P.Dict [("a", P.IntegerLiteral 5), ("a", P.IntegerLiteral 6)])
(DictDuplicateField "a")
(wctx 1 1 $ P.Dict [("a", wctx 2 5 $ P.IntegerLiteral 5), ("a", wctx 3 5 $ P.IntegerLiteral 6)])
(DictDuplicateField (ctx 1 1) "a")
testSuccess
"Type checks an empty list as EmptyListType"
(P.List [])
(wctx 1 1 $ P.List [])
EmptyListType
testSuccess
"Type checks a list where all elements have the same type"
(P.List [P.IntegerLiteral 5, P.DoubleLiteral 1.6])
(wctx 1 1 $ P.List [wctx 1 10 $ P.IntegerLiteral 5, wctx 1 20 $ P.DoubleLiteral 1.6])
(ListType NumberType)
testFail
"Fails to type check a list containing strings and numbers"
(P.List [P.IntegerLiteral 5, P.StringLiteral "4"])
(UnificationError ReasonUncoercable NumberType StringType)
(wctx 1 1 $ P.List [wctx 1 10 $ P.IntegerLiteral 5, wctx 1 20 $ P.StringLiteral "4"])
(UnificationError (ctx 1 1) $ TypeCoercionError (wctx 1 20 $ StringLiteral "4") NumberType ReasonUncoercable)
testSuccess
"Type checks a list of dictionaries that unify but have different types"
( P.List
[ P.Dict [("a", P.IntegerLiteral 5)],
P.Dict [],
P.Dict [("b", P.StringLiteral "string")]
]
( wctx 1 1 $
P.List
[ wctx 2 2 $ P.Dict [("a", wctx 2 10 $ P.IntegerLiteral 5)],
wctx 3 2 $ P.Dict [],
wctx 4 2 $ P.Dict [("b", wctx 4 10 $ P.StringLiteral "string")]
]
)
( ListType $
DictType $
@ -147,50 +164,84 @@ spec_Internal = do
)
testFail
"Fails to type check a list of dictionaries that do not unify"
( P.List
[ P.Dict [("a", P.IntegerLiteral 5)],
P.Dict [("a", P.StringLiteral "string")]
]
( wctx 1 1 $
P.List
[ wctx 2 2 $ P.Dict [("a", wctx 2 10 $ P.IntegerLiteral 5)],
wctx 3 2 $ P.Dict [("a", wctx 3 10 $ P.StringLiteral "string")]
]
)
( UnificationError
(ReasonDictWrongKeyType "a" (UnificationError ReasonUncoercable NumberType StringType))
(DictType $ H.singleton "a" (DictRequired NumberType))
(DictType $ H.singleton "a" (DictRequired StringType))
( UnificationError (ctx 1 1) $
TypeCoercionError
( wctx 3 2 $
Dict
[("a", wctx 3 10 $ StringLiteral "string")]
(DictType $ H.singleton "a" (DictRequired StringType))
)
(DictType $ H.singleton "a" (DictRequired NumberType))
( ReasonDictWrongKeyType
"a"
( TypeCoercionError
(wctx 3 10 $ StringLiteral "string")
NumberType
ReasonUncoercable
)
)
)
describe "Type checks a tuple" $ do
testSuccess
"When tuple is a pair"
(P.Tuple (P.IntegerLiteral 5, P.StringLiteral "string", []))
( wctx 1 1 $
P.Tuple
( wctx 2 2 $ P.IntegerLiteral 5,
wctx 2 10 $ P.StringLiteral "string",
[]
)
)
(TupleType (NumberType, StringType, []))
testSuccess
"When tuple is a triple"
(P.Tuple (P.IntegerLiteral 5, P.StringLiteral "string", [P.IntegerLiteral 2]))
( wctx 1 1 $
P.Tuple
( wctx 2 2 $ P.IntegerLiteral 5,
wctx 2 10 $ P.StringLiteral "string",
[wctx 2 20 $ P.IntegerLiteral 2]
)
)
(TupleType (NumberType, StringType, [NumberType]))
describe "checkStmt" $ do
it "Type checks existing declaration type with correct argument" $ do
let ast = P.Decl "string" "App" (P.StringLiteral "Wasp")
let typeDefs = TD.TypeDefinitions {TD.declTypes = H.singleton "string" (TD.DeclType "string" StringType undefined), TD.enumTypes = H.empty}
let actual = run typeDefs $ checkStmt ast
let expected = Right $ Decl "App" (StringLiteral "Wasp") (DeclType "string")
actual `shouldBe` expected
it "Fails to type check non-existant declaration type" $ do
let ast = P.Decl "string" "App" (P.StringLiteral "Wasp")
let actual = run TD.empty $ checkStmt ast
actual `shouldBe` Left (NoDeclarationType "string")
it "Fails to type check existing declaration type with incorrect argument" $ do
let ast = P.Decl "string" "App" (P.IntegerLiteral 5)
let ast = wctx 1 1 $ P.Decl "string" "App" $ wctx 2 3 $ P.StringLiteral "Wasp"
let typeDefs =
TD.TypeDefinitions
{ TD.declTypes = H.singleton "string" (TD.DeclType "string" StringType undefined),
TD.enumTypes = H.empty
}
let actual = run typeDefs $ checkStmt ast
let expectedError = WeakenError ReasonUncoercable (IntegerLiteral 5) StringType
let expected = Right $ wctx 1 1 $ Decl "App" (wctx 2 3 $ StringLiteral "Wasp") (DeclType "string")
actual `shouldBe` expected
it "Fails to type check non-existant declaration type" $ do
let ast = wctx 1 1 $ P.Decl "string" "App" $ wctx 2 3 $ P.StringLiteral "Wasp"
let actual = run TD.empty $ checkStmt ast
actual `shouldBe` Left (NoDeclarationType (ctx 1 1) "string")
it "Fails to type check existing declaration type with incorrect argument" $ do
let ast = wctx 1 1 $ P.Decl "string" "App" $ wctx 2 3 $ P.IntegerLiteral 5
let typeDefs =
TD.TypeDefinitions
{ TD.declTypes = H.singleton "string" (TD.DeclType "string" StringType undefined),
TD.enumTypes = H.empty
}
let actual = run typeDefs $ checkStmt ast
let expectedError =
WeakenError (ctx 1 1) $
TypeCoercionError
(wctx 2 3 $ IntegerLiteral 5)
StringType
ReasonUncoercable
actual `shouldBe` Left expectedError
it "Type checks declaration with dict type with an argument that unifies to the correct type" $ do
let ast = P.Decl "maybeString" "App" (P.Dict [("val", P.StringLiteral "Wasp")])
let ast = wctx 1 1 $ P.Decl "maybeString" "App" $ wctx 2 3 $ P.Dict [("val", wctx 2 10 $ P.StringLiteral "Wasp")]
let typeDefs =
TD.TypeDefinitions
{ TD.declTypes =
@ -204,11 +255,13 @@ spec_Internal = do
let actual = run typeDefs $ checkStmt ast
let expected =
Right $
Decl
"App"
( Dict
[("val", StringLiteral "Wasp")]
(DictType $ H.singleton "val" (DictOptional StringType))
)
(DeclType "maybeString")
wctx 1 1 $
Decl
"App"
( wctx 2 3 $
Dict
[("val", wctx 2 10 $ StringLiteral "Wasp")]
(DictType $ H.singleton "val" (DictOptional StringType))
)
(DeclType "maybeString")
actual `shouldBe` expected

27
waspc/test/Analyzer/TypeCheckerTest.hs
View File

@ -1,5 +1,6 @@
module Analyzer.TypeCheckerTest where
import Analyzer.TestUtil (ctx, wctx)
import Data.Either (isRight)
import qualified Data.HashMap.Strict as H
import Test.Tasty.Hspec
@ -16,8 +17,8 @@ spec_TypeChecker = do
it "Type checks a simple, well-typed example" $ do
let ast =
P.AST
[ P.Decl "app" "Todo" (P.Dict [("title", P.StringLiteral "Todo App")]),
P.Decl "app" "Trello" (P.Dict [("title", P.StringLiteral "Trello Clone")])
[ wctx 1 1 $ P.Decl "app" "Todo" (wctx 2 1 $ P.Dict [("title", wctx 3 2 $ P.StringLiteral "Todo App")]),
wctx 4 1 $ P.Decl "app" "Trello" (wctx 5 2 $ P.Dict [("title", wctx 6 3 $ P.StringLiteral "Trello Clone")])
]
let typeDefs =
TD.TypeDefinitions
@ -39,14 +40,16 @@ spec_TypeChecker = do
let actual = typeCheck typeDefs ast
actual `shouldSatisfy` isRight
it "Fails to type check a simple, ill-typed example" $ do
let ast = P.AST [P.Decl "string" "App" (P.IntegerLiteral 5)]
let ast = P.AST [wctx 1 1 $ P.Decl "string" "App" $ wctx 2 2 $ P.IntegerLiteral 5]
let typeDefs =
TD.TypeDefinitions
{ TD.declTypes = H.singleton "string" (TD.DeclType "string" StringType undefined),
TD.enumTypes = H.empty
}
let actual = typeCheck typeDefs ast
let expectedError = WeakenError ReasonUncoercable (IntegerLiteral 5) StringType
let expectedError =
WeakenError (ctx 1 1) $
TypeCoercionError (wctx 2 2 $ IntegerLiteral 5) StringType ReasonUncoercable
actual `shouldBe` Left expectedError
it "Properly hoists declarations" $ do
let mAst = P.parse "llnode Head { value: 2, next: Tail } llnode Tail { value: 3 }"
@ -64,22 +67,30 @@ spec_TypeChecker = do
let actual = typeCheck typeDefs ast
actual `shouldSatisfy` isRight
it "Type checks an existing enum value" $ do
let ast = P.AST [P.Decl "food" "Cucumber" (P.Var "Dill")]
let ast = P.AST [wctx 1 1 $ P.Decl "food" "Cucumber" $ wctx 1 30 $ P.Var "Dill"]
let typeDefs =
TD.TypeDefinitions
{ TD.declTypes = H.singleton "food" (TD.DeclType "food" (EnumType "flavor") undefined),
TD.enumTypes = H.singleton "flavor" (TD.EnumType "flavor" ["Fresh", "Dill"])
}
let actual = typeCheck typeDefs ast
let expected = Right $ TypedAST [Decl "Cucumber" (Var "Dill" (EnumType "flavor")) (DeclType "food")]
let expected =
Right $
TypedAST
[ wctx 1 1 $ Decl "Cucumber" (wctx 1 30 $ Var "Dill" (EnumType "flavor")) (DeclType "food")
]
actual `shouldBe` expected
it "Type checks an empty list in a declaration" $ do
let ast = P.AST [P.Decl "rooms" "Bedrooms" (P.List [])]
let ast = P.AST [wctx 1 1 $ P.Decl "rooms" "Bedrooms" $ wctx 1 30 $ P.List []]
let typeDefs =
TD.TypeDefinitions
{ TD.declTypes = H.singleton "rooms" (TD.DeclType "rooms" (ListType StringType) undefined),
TD.enumTypes = H.empty
}
let actual = typeCheck typeDefs ast
let expected = Right $ TypedAST [Decl "Bedrooms" (List [] (ListType StringType)) (DeclType "rooms")]
let expected =
Right $
TypedAST
[ wctx 1 1 $ Decl "Bedrooms" (wctx 1 30 $ List [] (ListType StringType)) (DeclType "rooms")
]
actual `shouldBe` expected

75
waspc/test/AnalyzerTest.hs
View File

@ -2,7 +2,9 @@
module AnalyzerTest where
import Analyzer.TestUtil (ctx)
import Data.Either (isRight)
import Data.List (intercalate)
import Test.Tasty.Hspec
import Wasp.Analyzer
import qualified Wasp.Analyzer.TypeChecker as TC
@ -170,9 +172,10 @@ spec_Analyzer = do
it "Returns a type error if unexisting declaration is referenced" $ do
let source =
unlines
[ "route HomeRoute { path: \"/\", page: NonExistentPage }"
[ "route HomeRoute { path: \"/\", page: NonExistentPage }"
]
takeDecls @Route <$> analyze source `shouldBe` Left (TypeError $ TC.UndefinedIdentifier "NonExistentPage")
takeDecls @Route <$> analyze source
`shouldBe` Left (TypeError $ TC.UndefinedIdentifier (ctx 1 36) "NonExistentPage")
it "Returns a type error if referenced declaration is of wrong type" $ do
let source =
@ -189,6 +192,74 @@ spec_Analyzer = do
]
isRight (analyze source) `shouldBe` True
describe "Returns correct error message" $ do
let errorMessageShouldBe analyzeResult (c, msg) = case analyzeResult of
Right _ -> error "Test failed: expected AnalyzerError."
Left e -> getErrorMessageAndCtx e `shouldBe` (msg, c)
it "For nested unexpected type error" $ do
let source =
unlines
[ "app MyApp {",
" title: \"My app\",",
" dependencies: [",
" { name: \"bar\", version: 13 },",
" { name: \"foo\", version: 14 }",
" ]",
"}"
]
analyze source
`errorMessageShouldBe` ( ctx 4 29,
intercalate
"\n"
[ "Type error:",
" For dictionary field 'dependencies':",
" For list element:",
" For dictionary field 'version':",
" Expected type: string",
" Actual type: number"
]
)
it "For nested unification type error" $ do
let source =
unlines
[ "app MyApp {",
" title: \"My app\",",
" dependencies: [",
" { name: \"bar\", version: 13 },",
" { name: \"foo\", version: \"1.2.3\" }",
" ]",
"}"
]
analyze source
`errorMessageShouldBe` ( ctx 5 29,
intercalate
"\n"
[ "Type error:",
" For dictionary field 'version':",
" Can't mix the following types:",
" - number",
" - string"
]
)
it "For redundant dictionary field" $ do
let source =
unlines
[ "app MyApp {",
" ttle: \"My app\",",
"}"
]
analyze source
`errorMessageShouldBe` ( ctx 1 11,
intercalate
"\n"
[ "Type error:",
" Unexpected dictionary field 'ttle'"
]
)
isAnalyzerOutputTypeError :: Either AnalyzeError a -> Bool
isAnalyzerOutputTypeError (Left (TypeError _)) = True
isAnalyzerOutputTypeError _ = False

20
waspc/test/UtilTest.hs
View File

@ -71,3 +71,23 @@ spec_indent = do
indent 3 "foo\nbar" `shouldBe` " foo\n bar"
it "when text is already somewhat indented" $ do
indent 4 " foo\n bar" `shouldBe` " foo\n bar"
spec_concatShortPrefixAndText :: Spec
spec_concatShortPrefixAndText = do
describe "concatShortPrefixAndText should" $ do
it "return prefix if text is empty" $ do
concatShortPrefixAndText "--" "" `shouldBe` "--"
it "directly concat if text has single line" $ do
concatShortPrefixAndText " - " "foo" `shouldBe` " - foo"
it "align the rest of the lines in text with the first line" $ do
concatShortPrefixAndText " - " "foo\nbar" `shouldBe` " - foo\n bar"
spec_concatPrefixAndText :: Spec
spec_concatPrefixAndText = do
describe "concatPrefixAndText should" $ do
it "return prefix if text is empty" $ do
concatPrefixAndText "some prefix: " "" `shouldBe` "some prefix: "
it "directly concat if text has single line" $ do
concatPrefixAndText "prefix: " "foo" `shouldBe` "prefix: foo"
it "put all the text below the prefix, indented for 2 spaces, if text has multiple lines" $ do
concatPrefixAndText "prefix: " "foo\nbar" `shouldBe` "prefix: \n foo\n bar"