From 880cd39226b3dcd36148be02aab803b74abf52b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20=C5=A0o=C5=A1i=C4=87?= Date: Tue, 7 Dec 2021 14:44:01 +0100 Subject: [PATCH] Added support for custom evaluation to Analyzer. (#375) --- waspc/package.yaml | 1 + .../src/Wasp/Analyzer/Evaluator/Evaluation.hs | 4 +- .../Analyzer/Evaluator/EvaluationError.hs | 17 +- .../Analyzer/StdTypeDefinitions/Entity.hs | 6 +- waspc/src/Wasp/Analyzer/TypeDefinitions.hs | 3 +- .../Class/HasCustomEvaluation.hs | 20 ++ .../{Class.hs => Class/IsDeclType.hs} | 49 ++-- .../TypeDefinitions/Class/IsEnumType.hs | 31 ++ .../Wasp/Analyzer/TypeDefinitions/TH/Decl.hs | 274 +++++++++++------- waspc/src/Wasp/AppSpec/App.hs | 12 - waspc/test/Analyzer/EvaluatorTest.hs | 74 ++++- 11 files changed, 330 insertions(+), 161 deletions(-) create mode 100644 waspc/src/Wasp/Analyzer/TypeDefinitions/Class/HasCustomEvaluation.hs rename waspc/src/Wasp/Analyzer/TypeDefinitions/{Class.hs => Class/IsDeclType.hs} (50%) create mode 100644 waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsEnumType.hs diff --git a/waspc/package.yaml b/waspc/package.yaml index 0a41c0fd1..ee0329e04 100644 --- a/waspc/package.yaml +++ b/waspc/package.yaml @@ -141,3 +141,4 @@ tests: - path - unordered-containers - strong-path + - split diff --git a/waspc/src/Wasp/Analyzer/Evaluator/Evaluation.hs b/waspc/src/Wasp/Analyzer/Evaluator/Evaluation.hs index 2943ccec4..84e96cbc4 100644 --- a/waspc/src/Wasp/Analyzer/Evaluator/Evaluation.hs +++ b/waspc/src/Wasp/Analyzer/Evaluator/Evaluation.hs @@ -30,9 +30,11 @@ -- @Page { title = "Home", author = Nothing, content = "Hello world" }@ module Wasp.Analyzer.Evaluator.Evaluation ( runEvaluation, + evaluation, + evaluation', module Wasp.Analyzer.Evaluator.Evaluation.Combinators, ) where import Wasp.Analyzer.Evaluator.Evaluation.Combinators -import Wasp.Analyzer.Evaluator.Evaluation.Internal (runEvaluation) +import Wasp.Analyzer.Evaluator.Evaluation.Internal (evaluation, evaluation', runEvaluation) diff --git a/waspc/src/Wasp/Analyzer/Evaluator/EvaluationError.hs b/waspc/src/Wasp/Analyzer/Evaluator/EvaluationError.hs index b8a848027..9c36c95b6 100644 --- a/waspc/src/Wasp/Analyzer/Evaluator/EvaluationError.hs +++ b/waspc/src/Wasp/Analyzer/Evaluator/EvaluationError.hs @@ -1,10 +1,11 @@ module Wasp.Analyzer.Evaluator.EvaluationError ( EvaluationError (..), EvaluationErrorContext (..), + EvaluationParseError (..), ) where -import Text.Parsec (ParseError) +import qualified Text.Parsec import Wasp.Analyzer.Type (Type) data EvaluationError @@ -20,9 +21,10 @@ data EvaluationError InvalidEnumVariant String String | -- | "MissingField fieldName" MissingField String - | -- | In case when evaluation includes parsing with Parsec and it fails. - ParseError ParseError - | WithContext EvaluationErrorContext EvaluationError + | -- | In case when evaluation includes parsing and it fails. + ParseError EvaluationParseError + | -- | Not an actual error, but a wrapper that provides additional context. + WithContext EvaluationErrorContext EvaluationError deriving (Show, Eq) data EvaluationErrorContext @@ -32,3 +34,10 @@ data EvaluationErrorContext | -- | ForVariable varName ForVariable String deriving (Show, Eq) + +data EvaluationParseError + = -- | In case when evaluation includes parsing with Parsec and it fails. + EvaluationParseErrorParsec Text.Parsec.ParseError + | -- | In case when evaluation does some general parsing and it fails. + EvaluationParseError String + deriving (Show, Eq) diff --git a/waspc/src/Wasp/Analyzer/StdTypeDefinitions/Entity.hs b/waspc/src/Wasp/Analyzer/StdTypeDefinitions/Entity.hs index d5515d74f..12aded943 100644 --- a/waspc/src/Wasp/Analyzer/StdTypeDefinitions/Entity.hs +++ b/waspc/src/Wasp/Analyzer/StdTypeDefinitions/Entity.hs @@ -5,7 +5,7 @@ module Wasp.Analyzer.StdTypeDefinitions.Entity () where import Control.Arrow (left) import qualified Text.Parsec as Parsec -import qualified Wasp.Analyzer.Evaluator.EvaluationError as EvaluationError +import qualified Wasp.Analyzer.Evaluator.EvaluationError as ER import qualified Wasp.Analyzer.Type as Type import qualified Wasp.Analyzer.TypeChecker.AST as TC.AST import Wasp.Analyzer.TypeDefinitions (DeclType (..), IsDeclType (..)) @@ -24,6 +24,6 @@ instance IsDeclType Entity where declEvaluate _ _ expr = case expr of TC.AST.PSL pslString -> - left EvaluationError.ParseError $ + left (ER.ParseError . ER.EvaluationParseErrorParsec) $ makeEntity <$> Parsec.parse Wasp.Psl.Parser.Model.body "" pslString - _ -> Left $ EvaluationError.ExpectedType (Type.QuoterType "psl") (TC.AST.exprType expr) + _ -> Left $ ER.ExpectedType (Type.QuoterType "psl") (TC.AST.exprType expr) diff --git a/waspc/src/Wasp/Analyzer/TypeDefinitions.hs b/waspc/src/Wasp/Analyzer/TypeDefinitions.hs index d677a4ad0..a7a2a1890 100644 --- a/waspc/src/Wasp/Analyzer/TypeDefinitions.hs +++ b/waspc/src/Wasp/Analyzer/TypeDefinitions.hs @@ -19,7 +19,8 @@ module Wasp.Analyzer.TypeDefinitions where import qualified Data.HashMap.Strict as M -import Wasp.Analyzer.TypeDefinitions.Class +import Wasp.Analyzer.TypeDefinitions.Class.IsDeclType +import Wasp.Analyzer.TypeDefinitions.Class.IsEnumType import Wasp.Analyzer.TypeDefinitions.Internal empty :: TypeDefinitions diff --git a/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/HasCustomEvaluation.hs b/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/HasCustomEvaluation.hs new file mode 100644 index 000000000..a9ef00df0 --- /dev/null +++ b/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/HasCustomEvaluation.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Wasp.Analyzer.TypeDefinitions.Class.HasCustomEvaluation + ( HasCustomEvaluation (..), + ) +where + +import Data.Typeable (Typeable) +import Wasp.Analyzer.Evaluator.Evaluation.TypedExpr (TypedExprEvaluation) +import Wasp.Analyzer.Type (Type) + +-- | For a Haskell type @a@, provides its Wasp @Type@ (via @waspType@ function) +-- | and its @Evaluation@ (via @evaluation@ function) that evaluates from +-- | @waspType@ into @a@. +-- | This class can be useful when using @makeDeclType@, since @makeDeclType@ checks +-- | for types with this class and if they have it, it uses their custom evaluation +-- | instead of trying to figure out their evaluation on its own. +class (Typeable a) => HasCustomEvaluation a where + waspType :: Type + evaluation :: TypedExprEvaluation a diff --git a/waspc/src/Wasp/Analyzer/TypeDefinitions/Class.hs b/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsDeclType.hs similarity index 50% rename from waspc/src/Wasp/Analyzer/TypeDefinitions/Class.hs rename to waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsDeclType.hs index 1770fe5ef..425ee9503 100644 --- a/waspc/src/Wasp/Analyzer/TypeDefinitions/Class.hs +++ b/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsDeclType.hs @@ -1,8 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module Wasp.Analyzer.TypeDefinitions.Class +module Wasp.Analyzer.TypeDefinitions.Class.IsDeclType ( IsDeclType (..), - IsEnumType (..), ) where @@ -10,52 +9,42 @@ 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.TypeDefinitions.Internal (DeclType, EnumType, TypeDefinitions) +import Wasp.Analyzer.TypeDefinitions.Internal (DeclType, TypeDefinitions) import qualified Wasp.AppSpec.Core.Decl as AppSpecDecl -- | Marks Haskell type as a representation of a specific Wasp declaration type. --- This is supposed to be used on types from Wasp AST (the IR between Analyzer and Generator) +-- This is supposed to be used on types from @AppSpec@ (the main Wasp IR) -- in order to enrich them with information on how are they to be analyzed -- (and therefore make them part of the Wasp language). -- +-- To put it very practically, if you make a Haskell type (usually from @AppSpec@) +-- an instance of this class, and if you add it to "Wasp.Analyzer.StdTypeDefinitions", +-- you are telling Analyzer that there is a new declaration type in Wasp language with +-- name, Wasp type and evaluation from that Wasp type into Haskell type as specified +-- by this instance, and therefore you just added a new declaration type to the +-- Wasp language and Analyzer will include it in the final result it produces. +-- -- NOTE: If this Haskell type satisfies certain requirements, the IsDeclType instance for it --- can be automatically derived from its shape by using 'Analyzer.Evaluator.TH.makeDeclType'. +-- can be automatically derived from its shape by using +-- 'Wasp.Analyzer.TypeDefinitions.TH.makeDeclType'. class (Typeable a, AppSpecDecl.IsDecl a) => IsDeclType a where declType :: DeclType - -- | Evaluates a given Wasp "TypedExpr" to a value of this type, assuming it is of - -- declaration type described by (dtBodyType . declType) and (dtName . declType) (otherwise throws an error). + -- | Evaluates a given Wasp "TypedExpr" to a value of type @a@, assuming given + -- typed expression is of declaration type described by @dtBodyType . declType@ + -- and @dtName . declType@ (otherwise throws an error). -- -- For @declEvaluate typeDefs bindings declBodyExpr@: -- - "typeDefs" is the type definitions used in the Analyzer -- - "bindings" contains the values of all the declarations evaluated so far - -- - "declBodyExpr" is the expression describing declaration body, that should be evaluated by this function + -- - "declBodyExpr" is the expression describing declaration body, + -- that should be evaluated by this function -- -- __Examples__ -- -- Imagine that we have Wasp code @test Example 4@, and we have @instance IsDeclType Test@. - -- Here, @test@ is declaration type name, @Example@ is declaration name, and @4@ is declaration body. + -- Here, @test@ is declaration type name, @Example@ is declaration name, + -- 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 - --- | Marks Haskell type as a representation of a specific Wasp enum type. --- Analogous to IsDeclType, but for enums. --- --- NOTE: If this Haskell type satisfies certain requirements, the IsEnumType instance for it --- can be automatically derived from its shape by using 'Analyzer.Evaluator.TH.makeEnumType'. -class Typeable a => IsEnumType a where - enumType :: EnumType - - -- | Converts a string to a Haskell value of this type. - -- - -- @mapM_ enumEvaluate (etVariants enumType) == Right ()@ should be true - -- for all instances of "IsEnumType". - -- - -- __Examples__ - -- - -- >>> data Example = Foo | Bar - -- >>> instance IsEnumType Example where {- omitted -} - -- >>> enumEvaluate "Foo" - -- Foo - enumEvaluate :: String -> Either EvaluationError a diff --git a/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsEnumType.hs b/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsEnumType.hs new file mode 100644 index 000000000..9b3d7355d --- /dev/null +++ b/waspc/src/Wasp/Analyzer/TypeDefinitions/Class/IsEnumType.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Wasp.Analyzer.TypeDefinitions.Class.IsEnumType + ( IsEnumType (..), + ) +where + +import Data.Typeable (Typeable) +import Wasp.Analyzer.Evaluator.EvaluationError (EvaluationError) +import Wasp.Analyzer.TypeDefinitions.Internal (EnumType) + +-- | Marks Haskell type as a representation of a specific Wasp enum type. +-- Analogous to IsDeclType, but for enums. +-- +-- NOTE: If this Haskell type satisfies certain requirements, the IsEnumType instance for it +-- can be automatically derived from its shape by using 'Analyzer.Evaluator.TH.makeEnumType'. +class Typeable a => IsEnumType a where + enumType :: EnumType + + -- | Converts a string to a Haskell value of this type. + -- + -- @mapM_ enumEvaluate (etVariants enumType) == Right ()@ should be true + -- for all instances of "IsEnumType". + -- + -- __Examples__ + -- + -- >>> data Example = Foo | Bar + -- >>> instance IsEnumType Example where {- omitted -} + -- >>> enumEvaluate "Foo" + -- Foo + enumEvaluate :: String -> Either EvaluationError a diff --git a/waspc/src/Wasp/Analyzer/TypeDefinitions/TH/Decl.hs b/waspc/src/Wasp/Analyzer/TypeDefinitions/TH/Decl.hs index 4c5b4ed32..d75216661 100644 --- a/waspc/src/Wasp/Analyzer/TypeDefinitions/TH/Decl.hs +++ b/waspc/src/Wasp/Analyzer/TypeDefinitions/TH/Decl.hs @@ -11,37 +11,89 @@ import Control.Applicative ((<|>)) import qualified Data.HashMap.Strict as H import Language.Haskell.TH import Language.Haskell.TH.Syntax (VarBangType) -import Wasp.Analyzer.Evaluator.Evaluation +import qualified Wasp.Analyzer.Evaluator.Evaluation as E import qualified Wasp.Analyzer.Type as T import Wasp.Analyzer.TypeDefinitions (DeclType (..), EnumType (..), IsDeclType (..), IsEnumType (..)) +import Wasp.Analyzer.TypeDefinitions.Class.HasCustomEvaluation (HasCustomEvaluation) +import qualified Wasp.Analyzer.TypeDefinitions.Class.HasCustomEvaluation as HasCustomEvaluation import Wasp.Analyzer.TypeDefinitions.TH.Common import Wasp.AppSpec.Core.Decl (makeDecl) import Wasp.AppSpec.Core.Ref (Ref) import qualified Wasp.AppSpec.ExtImport as AppSpec.ExtImport import qualified Wasp.AppSpec.JSON as AppSpec.JSON --- | @makeDeclType ''Type@ writes an @IsDeclType@ instance for @Type@. A type --- error is raised if @Type@ does not fit the criteria described below. +-- | @makeDeclType ''T@ generates an @IsDeclType@ instance for Haskell type @T@. +-- A type error is raised if @T@ does not fit the criteria described below, which are +-- required for @makeDeclType@ to be able to automatically generate @IsDeclType@ +-- instance for a type @T@. -- --- Requirements on @Type@ for this to work: --- - The type must be an ADT with one constructor. --- - The type must have just one field OR use record syntax (in which case it can have multiple fields). +-- Requirements on the shape of type @T@ for this to work: +-- - type @T@ must be an ADT with one constructor, which must have +-- just one field OR use record syntax (in which case it can have multiple record fields). +-- - type @T@ must have no type parameters. +-- Therefore, some valid types based on this would be: +-- - `data T = Foo String` +-- - `data T = Foo { a :: String, b :: Int }` +-- while some invalid types would be: +-- - `data T = Foo String | Bar Int` +-- - `data T = Foo String Int` +-- - `data T a = Foo a` -- --- Properties that hold for @Type@ and its generated @IsDeclType@ instance: --- - For the rest of the bullet points below, let's say that --- @let bodyType = dtBodyType (declType \@Type)@. --- - If @Type@ uses record syntax, then --- - @bodyType@ is a @Dict@ --- - If and only if there is a key @x@ in @bodyType@, --- then @Type@ has a record @x@ with the same type. --- - If a key @x@ is optional, then the record @x@ in @Type@ is a @Maybe@. --- - If @Type@ is a simple ADT (not record) with one field, then @bodyType@ maps to the type of that field. --- - @dtName (declType \@Type) == "type"@ -> the name of declaration type is the same as the name of @Type@ --- but with the first letter changed to lowercase. +-- Further, there are requirements/limitations as to which types can @T@ contain in itself +-- (be it as a type of the record field or as a type of the data constructor field). +-- They can be: +-- - Primitive: @String@, @Integer@, @Double@, @Bool@. +-- - @[a]@ where @a@ is an accepted type itself. +-- - @Maybe a@ (but only as a type of a record field) where @a@ is an accepted type itself. +-- - A few special types from AppSpec: +-- - 'Wasp.AppSpec.ExtImport.ExtImport' +-- - 'Wasp.AppSpec.JSON.JSON' +-- - @Wasp.AppSpec.Core.Ref a@ where @a@ is an instance of @IsDeclType@. +-- - A type that implements an @IsEnumType@ instance. +-- - A type with just one data constructor that is a record, and whose record field types +-- are all accepted types. +-- - A type that implements a @HasCustomEvaluation@ instance. +-- Place in implementation that is a source of truth for this is 'waspKindOfHaskellType'. +-- +-- If all of the above requirements are met, @IsDeclType@ instance is generated. +-- Main parts of that instance are Wasp type ('Wasp.Analyzer.Type.Type') +-- of the declaration body (referred to as @WT@ from now on) and the evaluator +-- that evalutes from that Wasp type @WT@ into Haskell type @T@. +-- We can also describe @WT@ with @let WT = dtBodyType (declType \@T)@. +-- For the user of @makeDeclType@, it is important to understand how +-- @makeDeclType@ determines @WT@ based on the @T@, since @WT@ then determines +-- how will this new declaration type (that we described with @T@) manifest +-- in the Wasp language itself. +-- +-- @WT@ is determined based on @T@ in the following manner: +-- - If @T@ is a record, then @WT@ is a @Dict@ with the same field keys as @T@ has, +-- and field types are determined as described below. recursively in this same manner. +-- Only exception is if type of field in record @T@ is @Maybe a@ -> in that case +-- type of corresponding field in @Dict@ @WT@ is determined from @a@ but field is +-- marked as optional (otherwise it is required). +-- - If @T@ is a simple ADT (not record) with just one field, then @WT@ is determined +-- directly from the type of that one field. +-- - When determining how types of fields (in record or in simple ADT) from @T@ map +-- to parts of @WT@, following approach is used: +-- - Primitives, list, ExtImport, JSON, enum, decl ref -> all those are pretty +-- straight-forwardly mapped onto corresponding types from `Wasp.Analyzer.Type`. +-- - Type of record field in @T@ maps to required field in @WT@ @Dict@ of +-- type that maps per rules mentioned above/below. +-- Only exception is if type of field in record @T@ is @Maybe a@ -> in that case +-- type of corresponding field in @Dict@ @WT@ is determined from @a@ but field is +-- marked as optional (otherwise it is required). +-- - If type of field is a record itself, then it is maped in a same way as +-- @T@ would be mapped -> as a @Dict@ with the same fields as the record. +-- Therefore this results in nested dictionaries. +-- - For types that have an instance of @HasCustomEvaluation@, +-- its @waspType@ method is directly used to obtain the Wasp type. +-- This allows us to take control over how Wasp type is determined for this specific +-- sub-part of @T@. +-- +-- Finally, it is important to mention that name of the declaration type is the same +-- as the name of @T@ but with first letter changed to lowercase: +-- @dtName (declType \@MyType) == "myType"@ -- --- One way to summarize the crux of properties above is to say: If given @Type@ is a simple ADT with one field, --- it is translated into a declaration which has body corresponding to that field. If instead @Type@ --- is a record, it is translated into a declaration whose body is a dictionary with same fields as the record. -- -- __Examples__ -- @@ -110,18 +162,19 @@ makeIsDeclTypeInstanceDefinition _ _ = fail "makeDeclType expects given type to recordFieldsToNameTypePairs :: [VarBangType] -> [(Name, Type)] recordFieldsToNameTypePairs = map $ \(fieldName, _, fieldType) -> (fieldName, fieldType) --- | Create an "IsDeclType" instance for types that have a single data constructor which has a single value, e.g. @data Type = Type x@. +-- | Create an "IsDeclType" instance for types that have a single data constructor which has a single value, +-- e.g. @data Type = Type x@. genIsDeclTypeInstanceDefinitionFromNormalDataConstructor :: Name -> Name -> Type -> Q [DecQ] genIsDeclTypeInstanceDefinitionFromNormalDataConstructor typeName dataConstructorName dataConstructorType = do - let evaluateE = [|runEvaluation $ $(conE dataConstructorName) <$> $(genEvaluationExprForHaskellType dataConstructorType)|] - let bodyTypeE = genWaspTypeFromHaskellType dataConstructorType + (bodyTypeE, evaluationE) <- genWaspTypeAndEvaluationForHaskellType dataConstructorType + let evaluateE = [|E.runEvaluation $ $(conE dataConstructorName) <$> $evaluationE|] pure $ genIsDeclTypeInstanceDefinition typeName dataConstructorName bodyTypeE evaluateE -- | For decls with record constructors, i.e. @data Fields = Fields { a :: String, b :: String } genIsDeclTypeInstanceDefinitionFromRecordDataConstructor :: Name -> Name -> [(Name, Type)] -> Q [DecQ] genIsDeclTypeInstanceDefinitionFromRecordDataConstructor typeName dataConstructorName fields = do - (dictTypeE, dictEvaluationE) <- genDictTypeAndEvaluationForRecord dataConstructorName fields - let evaluateE = [|runEvaluation $dictEvaluationE|] + (dictTypeE, dictEvaluationE) <- genDictWaspTypeAndEvaluationForRecord dataConstructorName fields + let evaluateE = [|E.runEvaluation $dictEvaluationE|] let bodyTypeE = dictTypeE pure $ genIsDeclTypeInstanceDefinition typeName dataConstructorName bodyTypeE evaluateE @@ -142,96 +195,61 @@ genIsDeclTypeInstanceDefinition typeName dataConstructorName bodyTypeE evaluateE genFunc 'declEvaluate evaluateE ] ---------------- Dict ------------------ +--------------- Kind, Wasp Type and Evaluation of a Haskell type ------------------ --- | Given a record data constructor name and fields, return the evaluation that evaluates --- Wasp dictionary into the given record, and also return the type of such Wasp dictionary. --- First member of returned couple is type, second is evaluation. -genDictTypeAndEvaluationForRecord :: Name -> [(Name, Type)] -> Q (ExpQ, ExpQ) -genDictTypeAndEvaluationForRecord dataConName fields = do - (dictEntryTypesE, dictEvaluationE) <- genDictEntriesTypeAndEvaluationForRecord dataConName fields - return - ( [|T.DictType $ H.fromList $dictEntryTypesE|], - [|dict $dictEvaluationE|] - ) +type WaspTypeExpQ = ExpQ -genDictEntriesTypeAndEvaluationForRecord :: Name -> [(Name, Type)] -> Q (ExpQ, ExpQ) -genDictEntriesTypeAndEvaluationForRecord dataConstructorName fields = - go $ reverse fields -- Reversing enables us to apply evaluations in right order. - where - go [] = pure (listE [], [|pure|] `appE` conE dataConstructorName) - go ((fieldName, fieldType) : restOfFields) = do - (restDictType, restEvaluation) <- go restOfFields - let thisDictTypeE = - [| - ($(nameToStringLiteralExpr fieldName), $(genDictEntryTypeFromHaskellType fieldType)) : - $restDictType - |] - let thisEvaluationE = [|$restEvaluation <*> $(genDictEntryEvaluationForRecordField fieldName fieldType)|] - pure (thisDictTypeE, thisEvaluationE) +type EvaluationExpQ = ExpQ --- | Write a @DictEntryType@ that corresponds to a given a Haskell type. -genDictEntryTypeFromHaskellType :: Type -> ExpQ -genDictEntryTypeFromHaskellType typ = - waspKindOfType typ >>= \case - KOptional elemType -> [|T.DictOptional $(genWaspTypeFromHaskellType elemType)|] - _ -> [|T.DictRequired $(genWaspTypeFromHaskellType typ)|] - --- | "genDictEvaluationE fieldName typ" writes a "DictEvaluation" for a haskell record field --- named "fieldName" with a value "typ". -genDictEntryEvaluationForRecordField :: Name -> Type -> ExpQ -genDictEntryEvaluationForRecordField fieldName fieldType = - waspKindOfType fieldType >>= \case - KOptional elemType -> [|maybeField $(nameToStringLiteralExpr fieldName) $(genEvaluationExprForHaskellType elemType)|] - _ -> [|field $(nameToStringLiteralExpr fieldName) $(genEvaluationExprForHaskellType fieldType)|] - ----------------------------------------- - ---------------- Types ------------------ - --- | Haskell type -> Wasp type. -genWaspTypeFromHaskellType :: Type -> ExpQ -genWaspTypeFromHaskellType typ = - waspKindOfType typ >>= \case - KString -> [|T.StringType|] - KInteger -> [|T.NumberType|] - KDouble -> [|T.NumberType|] - KBool -> [|T.BoolType|] - KList elemType -> [|T.ListType $(genWaspTypeFromHaskellType elemType)|] - KImport -> [|T.ExtImportType|] - KJSON -> [|T.QuoterType "json"|] - KDeclRef t -> [|T.DeclType $ dtName $ declType @ $(pure t)|] - KEnum -> [|T.EnumType $ etName $ enumType @ $(pure typ)|] +-- | For a given Haskell type @typ@, generates two TH expressions: +-- one that is a Wasp @Type@, and another that is @Evaluation@ that evaluates from that Wasp @Type@ +-- into a given Haskell type @typ@. +genWaspTypeAndEvaluationForHaskellType :: Type -> Q (WaspTypeExpQ, EvaluationExpQ) +genWaspTypeAndEvaluationForHaskellType typ = + waspKindOfHaskellType typ >>= \case + KString -> return ([|T.StringType|], [|E.string|]) + KInteger -> return ([|T.NumberType|], [|E.integer|]) + KDouble -> return ([|T.NumberType|], [|E.double|]) + KBool -> return ([|T.BoolType|], [|E.bool|]) + KList elemHaskellType -> do + (elemWaspType, elemEvaluation) <- genWaspTypeAndEvaluationForHaskellType elemHaskellType + return ([|T.ListType $(elemWaspType)|], [|E.list $(elemEvaluation)|]) + KImport -> return ([|T.ExtImportType|], [|E.extImport|]) + KJSON -> return ([|T.QuoterType "json"|], [|E.json|]) + KDeclRef t -> + return + ( [|T.DeclType $ dtName $ declType @ $(pure t)|], + [|E.declRef @ $(pure t)|] + ) + KEnum -> + return + ( [|T.EnumType $ etName $ enumType @ $(pure typ)|], + [|E.enum @ $(pure typ)|] + ) + KRecord dataConName fields -> genDictWaspTypeAndEvaluationForRecord dataConName fields + KCustomEvaluation -> + return + ( [|HasCustomEvaluation.waspType @ $(pure typ)|], + [|HasCustomEvaluation.evaluation @ $(pure typ)|] + ) KOptional _ -> fail "Maybe is only allowed in record fields" - KRecord dataConName fields -> - fst =<< genDictTypeAndEvaluationForRecord dataConName fields - --- | Generates an expression that is @Evaluation@ that evaluates to a given Haskell type. -genEvaluationExprForHaskellType :: Type -> ExpQ -genEvaluationExprForHaskellType typ = - waspKindOfType typ >>= \case - KString -> [|string|] - KInteger -> [|integer|] - KDouble -> [|double|] - KBool -> [|bool|] - KList elemType -> [|list $(genEvaluationExprForHaskellType elemType)|] - KImport -> [|extImport|] - KJSON -> [|json|] - KDeclRef t -> [|declRef @ $(pure t)|] - KEnum -> [|enum @ $(pure typ)|] - KOptional _ -> fail "Maybe is only allowed in record fields" - KRecord dataConName fields -> - snd =<< genDictTypeAndEvaluationForRecord dataConName fields -- | Find the "WaspKind" of a Haskell type. -waspKindOfType :: Type -> Q WaspKind -waspKindOfType typ = do +-- Wasp Kind is really just an intermediate representation that captures +-- information we will need to later determine Wasp type and Evaluation for +-- this Haskell type, which will be used to evaluate type-checked AST. +waspKindOfHaskellType :: Type -> Q WaspKind +waspKindOfHaskellType typ = do maybeDeclRefKind <- tryCastingToDeclRefKind typ maybeEnumKind <- tryCastingToEnumKind typ + maybeCustomEvaluationKind <- tryCastingToCustomEvaluationKind typ maybeRecordKind <- tryCastingToRecordKind typ maybe (fail $ "No translation to wasp type for type " ++ show typ) return $ maybeDeclRefKind <|> maybeEnumKind + -- NOTE: It is important that @maybeCustomEvaluationKind@ is before @maybeRecordKind@, + -- since having a custom evaluation should override typical record evalution, if type is a record. + <|> maybeCustomEvaluationKind <|> maybeRecordKind <|> case typ of ConT name @@ -265,6 +283,11 @@ waspKindOfType typ = do _ -> Nothing tryCastingToRecordKind _ = return Nothing + tryCastingToCustomEvaluationKind :: Type -> Q (Maybe WaspKind) + tryCastingToCustomEvaluationKind t = do + hasInstance <- isInstance ''HasCustomEvaluation [t] + return $ if hasInstance then Just KCustomEvaluation else Nothing + -- | An intermediate mapping between Haskell types and Wasp types, we use it internally -- in this module when generating @Types@, @Evaluation@, @DictEntryTypes@, and @DictEvaluation@ -- so that we have easier time when figuring out what we are dealing with. @@ -284,5 +307,48 @@ data WaspKind | -- | Type that has a single data constructor that is a record. -- KRecord KRecord Name [(Name, Type)] + | KCustomEvaluation ---------------------------------------- +---------- Kind, Wasp Type and Evaluation of a Haskell Record as a Wasp Dict ------------- + +-- | Given a record data constructor name and fields, return the evaluation that evaluates +-- Wasp dictionary into the given record, and also return the type of such Wasp dictionary. +-- First member of returned couple is type, second is evaluation. +genDictWaspTypeAndEvaluationForRecord :: Name -> [(Name, Type)] -> Q (WaspTypeExpQ, EvaluationExpQ) +genDictWaspTypeAndEvaluationForRecord dataConName fields = do + (dictEntryTypesE, dictEvaluationE) <- genDictEntriesWaspTypeAndEvaluationForRecord dataConName fields + return + ( [|T.DictType $ H.fromList $dictEntryTypesE|], + [|E.dict $dictEvaluationE|] + ) + +genDictEntriesWaspTypeAndEvaluationForRecord :: Name -> [(Name, Type)] -> Q (WaspTypeExpQ, EvaluationExpQ) +genDictEntriesWaspTypeAndEvaluationForRecord dataConstructorName fields = + go $ reverse fields -- Reversing enables us to apply evaluations in right order. + where + go [] = pure (listE [], [|pure|] `appE` conE dataConstructorName) + go ((fieldName, fieldType) : restOfFields) = do + (fieldWaspType, fieldEvaluation) <- genDictEntryWaspTypeAndEvaluationForRecordField fieldName fieldType + (restWaspType, restEvaluation) <- go restOfFields + pure + ( [|($(nameToStringLiteralExpr fieldName), $fieldWaspType) : $restWaspType|], + [|$restEvaluation <*> $fieldEvaluation|] + ) + +-- | For a given Haskell record field (name and type), generate Wasp Type and +-- Evaluation from that Wasp Type into given record field. +genDictEntryWaspTypeAndEvaluationForRecordField :: Name -> Type -> Q (WaspTypeExpQ, EvaluationExpQ) +genDictEntryWaspTypeAndEvaluationForRecordField fieldName fieldType = + waspKindOfHaskellType fieldType >>= \case + KOptional elemType -> do + (waspType, evaluation) <- genWaspTypeAndEvaluationForHaskellType elemType + return + ( [|T.DictOptional $(waspType)|], + [|E.maybeField $(nameToStringLiteralExpr fieldName) $(evaluation)|] + ) + _ -> do + (waspType, evaluation) <- genWaspTypeAndEvaluationForHaskellType fieldType + return + ( [|T.DictRequired $(waspType)|], + [|E.field $(nameToStringLiteralExpr fieldName) $(evaluation)|] + ) diff --git a/waspc/src/Wasp/AppSpec/App.hs b/waspc/src/Wasp/AppSpec/App.hs index 094264501..bc3c7cc4e 100644 --- a/waspc/src/Wasp/AppSpec/App.hs +++ b/waspc/src/Wasp/AppSpec/App.hs @@ -18,18 +18,6 @@ data App = App -- | NOTE: This is new. Before, `dependencies` was a standalone declaration and it was a {=json json=}, -- while now it is a [{ name :: String, version :: String }]. - -- TODO: We might want to look into making this nicer in the future - -- -> maybe change how it is represented in the wasp lang, e.g. make it just a list of strings, - -- while here it would still be what it is or it would be parsed even more. - -- We could make this work by supporting manual definition of how Dependency evaluates / what is its type. - -- So, similar like we have IsDeclType instance for declarations, we could have similar abstraction for - -- sub-types like these, and we would inject it into Analyzer and it would be defined manually. - -- A way this might work: in Evaluator, we would check when the type matches the one we have this custom logic for, - -- probably in the function that figures out the Kind of the type, and then we would based on that use - -- evaluator provided for that type. This means we can provide this custom sort of logic per specific type from - -- AppSpec, but not for type + context in which it is. However, that should be enough, I don't think that is a problem. - -- If knowledge of context is important then it is best to just manually define the parent type's evaluation. - -- TODO: Make a github issue for this (TODO above)? dependencies :: Maybe [Dependency] } deriving (Show, Eq, Data) diff --git a/waspc/test/Analyzer/EvaluatorTest.hs b/waspc/test/Analyzer/EvaluatorTest.hs index a37781ea1..ea55dee53 100644 --- a/waspc/test/Analyzer/EvaluatorTest.hs +++ b/waspc/test/Analyzer/EvaluatorTest.hs @@ -1,16 +1,24 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module Analyzer.EvaluatorTest where import Data.Data (Data) +import Data.List.Split (splitOn) import Test.Tasty.Hspec +import Text.Read (readMaybe) import Wasp.Analyzer.Evaluator +import qualified Wasp.Analyzer.Evaluator.Evaluation as E +import qualified Wasp.Analyzer.Evaluator.EvaluationError as EvaluationError import Wasp.Analyzer.Parser (parse) +import qualified Wasp.Analyzer.Type as T import Wasp.Analyzer.TypeChecker (typeCheck) +import qualified Wasp.Analyzer.TypeChecker.AST as TypedAST import qualified Wasp.Analyzer.TypeDefinitions as TD +import Wasp.Analyzer.TypeDefinitions.Class.HasCustomEvaluation (HasCustomEvaluation (..)) import Wasp.Analyzer.TypeDefinitions.TH import Wasp.AppSpec.Core.Decl (IsDecl) import Wasp.AppSpec.Core.Ref (Ref (..)) @@ -21,18 +29,24 @@ fromRight :: Show a => Either a b -> b fromRight (Right x) = x fromRight (Left e) = error $ show e +------- Simple ------- + newtype Simple = Simple String deriving (Eq, Show, Data) instance IsDecl Simple makeDeclType ''Simple +------- Fields ------- + data Fields = Fields {a :: String, b :: Maybe Double} deriving (Eq, Show, Data) instance IsDecl Fields makeDeclType ''Fields +------ Business ------ + data Person = Person {name :: String, age :: Integer} deriving (Eq, Show, Data) instance IsDecl Person @@ -43,12 +57,6 @@ data BusinessType = Manufacturer | Seller | Store deriving (Eq, Show, Data) makeEnumType ''BusinessType -data Special = Special {imps :: [ExtImport], json :: JSON} deriving (Eq, Show) - -instance IsDecl Special - -makeDeclType ''Special - data Business = Business { employees :: [Ref Person], worth :: Double, @@ -61,6 +69,53 @@ instance IsDecl Business makeDeclType ''Business +-------- Special -------- + +data Special = Special {imps :: [ExtImport], json :: JSON} deriving (Eq, Show) + +instance IsDecl Special + +makeDeclType ''Special + +------ HasCustomEvaluation ------ + +data SemanticVersion = SemanticVersion Int Int Int + deriving (Eq, Show, Data) + +instance HasCustomEvaluation SemanticVersion where + waspType = T.StringType + evaluation = E.evaluation' $ \case + TypedAST.StringLiteral str -> case splitOn "." str of + [major, minor, patch] -> + maybe + ( Left $ + EvaluationError.ParseError $ + EvaluationError.EvaluationParseError + "Failed parsing semantic version -> some part is not int" + ) + pure + $ do + majorInt <- readMaybe @Int major + minorInt <- readMaybe @Int minor + patchInt <- readMaybe @Int patch + return $ SemanticVersion majorInt minorInt patchInt + _ -> + Left $ + EvaluationError.ParseError $ + EvaluationError.EvaluationParseError $ + "Failed parsing semantic version -> it doesn't have 3 comma separated parts." + expr -> Left $ EvaluationError.ExpectedType T.StringType (TypedAST.exprType expr) + +data Custom = Custom + {version :: SemanticVersion} + deriving (Eq, Show, Data) + +instance IsDecl Custom + +makeDeclType ''Custom + +-------------------------------- + eval :: TD.TypeDefinitions -> [String] -> Either EvaluationError [Decl] eval typeDefs source = evaluate typeDefs $ fromRight $ typeCheck typeDefs $ fromRight $ parse $ unlines source @@ -112,6 +167,7 @@ spec_Evaluator = do " json: {=json \"key\": 1 json=}", "}" ] + fmap takeDecls (eval typeDefs source) `shouldBe` Right [ ( "Test", @@ -120,3 +176,9 @@ spec_Evaluator = do (JSON " \"key\": 1 ") ) ] + + it "Evaluates a declaration with a field that has custom evaluation" $ do + let typeDefs = TD.addDeclType @Custom $ TD.empty + let decls = eval typeDefs ["custom Test { version: \"1.2.3\" }"] + fmap takeDecls decls + `shouldBe` Right [("Test", Custom {version = SemanticVersion 1 2 3})]