Add TH generation for IsDeclType, IsEnumType instances

waspc/package.yaml

@@ -71,6 +71,7 @@ library:
     - array # Used by code generated by Alex for src/Analyzer/Parser/Lexer.x
     - mtl
     - strong-path
+    - template-haskell
 
 executables:
   wasp:

waspc/src/Analyzer/Evaluator/Combinators.hs

@@ -15,12 +15,13 @@ module Analyzer.Evaluator.Combinators
     maybeField,
     list,
     build,
+    Transform,
+    TransformDict,
   )
 where
 
 import Analyzer.Evaluator.Decl
 import Analyzer.Evaluator.EvaluationError
-import Analyzer.Type
 import Analyzer.TypeChecker.AST (TypedExpr (..))
 import qualified Analyzer.TypeDefinitions as TD
 import qualified Data.HashMap.Internal.Strict as H

waspc/src/Analyzer/Evaluator/TH.hs

@@ -0,0 +1,204 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Analyzer.Evaluator.TH (makeDecl, makeEnum) where
+
+import Analyzer.Evaluator.Combinators
+import qualified Analyzer.Type as T
+import Analyzer.TypeDefinitions.Class
+import qualified Data.HashMap.Strict as H
+import Language.Haskell.TH
+import Util (toLowerFirst)
+
+-- ========================================
+-- IsDeclType generation
+-- ========================================
+
+makeDecl :: Name -> Q [Dec]
+makeDecl ty = do
+  (TyConI tyCon) <- reify ty
+  (tyConName, con) <- case tyCon of
+    (DataD _ nm [] _ [con] _) -> pure (nm, con)
+    (NewtypeD _ nm [] _ con _) -> pure (nm, con)
+    _ -> fail "Invalid name for makeDecl"
+  let instanceType = conT ''IsDeclType `appT` conT tyConName
+  instanceDecs <- genDecl con
+  sequence [instanceD (return []) instanceType instanceDecs]
+
+genDecl :: Con -> Q [DecQ]
+genDecl (NormalC nm [(_, typ)]) = genPrimDecl nm typ
+genDecl (NormalC nm _) = fail $ "Too many non-record values in makeDecl for " ++ show nm
+genDecl (RecC nm recs) = genRecDecl nm $ map (\(recNm, _, typ) -> (recNm, typ)) recs
+genDecl _ = fail "makeDecl on non-decl type"
+
+-- For simple decls, i.e. @data Simple = Simple Int@
+
+genPrimDecl :: Name -> Type -> Q [DecQ]
+genPrimDecl nm typ = do
+  let declTypeNameD = funD 'declTypeName [clause [] (normalB $ litE $ stringL $ toLowerFirst $ nameBase nm) []]
+  let declTypeBodyTypeD = funD 'declTypeBodyType [clause [] (normalB $ genTypeE typ) []]
+  let declTypeFromASTD =
+        funD
+          'declTypeFromAST
+          [ clause
+              []
+              ( normalB $
+                  varE 'build `appE` infixE (Just $ conE nm) (varE '(<$>)) (Just $ genTransformE typ)
+              )
+              []
+          ]
+  pure [declTypeNameD, declTypeBodyTypeD, declTypeFromASTD]
+
+genTypeE :: Type -> ExpQ
+genTypeE typ =
+  waspKindOfType typ >>= \case
+    KString -> conE 'T.StringType
+    KInteger -> conE 'T.NumberType
+    KDouble -> conE 'T.NumberType
+    KBool -> conE 'T.BoolType
+    KList elemType -> conE 'T.ListType `appE` genTypeE elemType
+    KDecl -> conE 'T.DeclType `appE` (varE 'declTypeName `appTypeE` pure typ)
+    KEnum -> conE 'T.EnumType `appE` (varE 'enumTypeName `appTypeE` pure typ)
+    KOptional _ -> fail "Maybe only allowed in record fields"
+
+genTransformE :: Type -> ExpQ
+genTransformE typ =
+  waspKindOfType typ >>= \case
+    KString -> varE 'string
+    KInteger -> varE 'integer
+    KDouble -> varE 'double
+    KBool -> varE 'bool
+    KList elemType -> varE 'list `appE` genTransformE elemType
+    KDecl -> varE 'decl `appTypeE` pure typ
+    KEnum -> varE 'enum `appTypeE` pure typ
+    KOptional _ -> fail "Maybe only allowed in record fields"
+
+-- For decls with record constructors, i.e. @data Fields = Fields { a :: String, b :: String }
+
+genRecDecl :: Name -> [(Name, Type)] -> Q [DecQ]
+genRecDecl nm recs = do
+  let declTypeNameD = funD 'declTypeName [clause [] (normalB $ litE $ stringL $ toLowerFirst $ nameBase nm) []]
+  -- recs is reversed to make sure the applications for transformDictE are in the right order
+  (dictEntryTypesE, transformDictE) <- genRecEntryTypesAndTransform nm $ reverse recs
+  let dictTypeE = conE 'T.DictType `appE` (varE 'H.fromList `appE` dictEntryTypesE)
+  let transformE = varE 'dict `appE` transformDictE
+  let declTypeBodyTypeD = funD 'declTypeBodyType [clause [] (normalB dictTypeE) []]
+  let declTypeFromASTD = funD 'declTypeFromAST [clause [] (normalB $ varE 'build `appE` transformE) []]
+  pure [declTypeNameD, declTypeBodyTypeD, declTypeFromASTD]
+
+genRecEntryTypesAndTransform :: Name -> [(Name, Type)] -> Q (ExpQ, ExpQ)
+genRecEntryTypesAndTransform conNm [] = pure (listE [], varE 'pure `appE` conE conNm)
+genRecEntryTypesAndTransform conNm ((recNm, typ) : rest) = do
+  (restDictType, restTransform) <- genRecEntryTypesAndTransform conNm rest
+  let thisDictType =
+        infixE
+          (Just $ tupE [litE $ stringL $ nameBase recNm, genFieldTypeE typ])
+          (conE '(:))
+          (Just restDictType)
+  let thisTransform = infixE (Just restTransform) (varE '(<*>)) (Just $ genTransformDictE recNm typ)
+  pure (thisDictType, thisTransform)
+
+genFieldTypeE :: Type -> ExpQ
+genFieldTypeE typ =
+  waspKindOfType typ >>= \case
+    KOptional elemType -> conE 'T.DictOptional `appE` genTypeE elemType
+    _ -> conE 'T.DictRequired `appE` genTypeE typ
+
+genTransformDictE :: Name -> Type -> ExpQ
+genTransformDictE recNm typ =
+  waspKindOfType typ >>= \case
+    KOptional elemType -> varE 'maybeField `appE` recNmE `appE` genTransformE elemType
+    _ -> varE 'field `appE` recNmE `appE` genTransformE typ
+  where
+    recNmE = litE $ stringL $ nameBase recNm
+
+data WaspKind
+  = KString
+  | KInteger
+  | KDouble
+  | KBool
+  | KList Type
+  | KDecl
+  | KEnum
+  | KOptional Type
+
+waspKindOfType :: Type -> Q WaspKind
+waspKindOfType typ = do
+  typIsDecl <- isInstance ''IsDeclType [typ]
+  typIsEnum <- isInstance ''IsEnumType [typ]
+  if typIsDecl
+    then pure KDecl
+    else
+      if typIsEnum
+        then pure KEnum
+        else case typ of
+          ConT nm
+            | nm == ''String -> pure KString
+            | nm == ''Integer -> pure KInteger
+            | nm == ''Double -> pure KDouble
+            | nm == ''Bool -> pure KBool
+          ListT `AppT` elemType -> pure (KList elemType)
+          ConT nm `AppT` elemType | nm == ''Maybe -> pure (KOptional elemType)
+          _ -> fail $ "No translation to wasp type for type " ++ show typ
+
+-- if typIsPrim
+--   then pure Primitive
+--   else
+--     if typIsDecl
+--       then pure Decl
+--       else
+--         if typIsEnum
+--           then pure Enum
+--           else case typ of
+--             ConT conNm `AppT` typ' | conNm == ''Maybe -> pure $ Optional typ'
+--             _ -> pure None
+
+-- ========================================
+-- IsEnumType generation
+-- ========================================
+
+makeEnum :: Name -> Q [Dec]
+makeEnum ty = do
+  (TyConI tyCon) <- reify ty
+  (tyConName, cons) <- case tyCon of
+    (DataD _ nm [] _ cons _) -> pure (nm, cons)
+    (NewtypeD _ nm [] _ con _) -> pure (nm, [con])
+    _ -> fail "Invalid name for makeEnum"
+  let instanceType = conT ''IsEnumType `appT` conT tyConName
+  conNames <- enumConNames cons
+  sequence [instanceD (return []) instanceType (genEnum tyConName conNames)]
+
+genEnum :: Name -> [Name] -> [DecQ]
+genEnum tyConName cons =
+  [ genEnumName tyConName,
+    genEnumVariants cons,
+    genEnumFromVariants cons
+  ]
+
+genEnumName :: Name -> DecQ
+genEnumName tyConName = do
+  let enumTypeNameExp = litE $ stringL $ toLowerFirst $ nameBase tyConName
+  let enumTypeNameClause = clause [] (normalB enumTypeNameExp) []
+  funD 'enumTypeName [enumTypeNameClause]
+
+genEnumVariants :: [Name] -> DecQ
+genEnumVariants conNames = do
+  let variantsExp = listE $ map (litE . stringL . nameBase) conNames
+  let variantsClause = clause [] (normalB variantsExp) []
+  funD 'enumTypeVariants [variantsClause]
+
+genEnumFromVariants :: [Name] -> DecQ
+genEnumFromVariants conNames = do
+  let clauses = map genClause conNames
+  let leftClause = clause [varP $ mkName "x"] (normalB $ conE 'Left `appE` litE (stringL "Invalid variant for enum")) []
+  funD 'enumTypeFromVariant (clauses ++ [leftClause])
+  where
+    genClause :: Name -> ClauseQ
+    genClause nm = clause [litP $ stringL (nameBase nm)] (normalB $ conE 'Right `appE` conE nm) []
+
+enumConNames :: [Con] -> Q [Name]
+enumConNames = mapM conName
+  where
+    conName (NormalC nm []) = pure nm
+    conName _ = fail "Enum variant should have only one value"

waspc/test/Analyzer/EvaluatorTest.hs

@@ -1,11 +1,12 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Analyzer.EvaluatorTest where
 
 import Analyzer.Evaluator
-import Analyzer.Evaluator.Combinators
+import Analyzer.Evaluator.TH
 import Analyzer.Parser (parse)
 import Analyzer.Type
 import Analyzer.TypeChecker
@@ -20,22 +21,20 @@ fromRight (Left e) = error $ show e
 
 newtype Simple = Simple String deriving (Eq, Show, Data)
 
-instance TD.IsDeclType Simple where
+makeDecl ''Simple
-  declTypeName = "simple"
-  declTypeBodyType = StringType
-  declTypeFromAST = build $ Simple <$> string
 
 data Fields = Fields {a :: String, b :: Maybe Double} deriving (Eq, Show, Data)
 
-instance TD.IsDeclType Fields where
+makeDecl ''Fields
-  declTypeName = "fields"
-  declTypeBodyType = DictType $ H.fromList [("a", DictRequired StringType), ("b", DictOptional NumberType)]
-  declTypeFromAST = build $ dict $ Fields <$> field "a" string <*> maybeField "b" double
 
 data Person = Person {name :: String, age :: Integer} deriving (Eq, Show, Data)
 
+makeDecl ''Person
+
 data BusinessType = Manufacturer | Seller | Store deriving (Eq, Show, Data)
 
+makeEnum ''BusinessType
+
 data Business = Business
   { employees :: [Person],
     worth :: Double,
@@ -44,37 +43,7 @@ data Business = Business
   }
   deriving (Eq, Show, Data)
 
-instance TD.IsDeclType Person where
+makeDecl ''Business
-  declTypeName = "person"
-  declTypeBodyType = DictType $ H.fromList [("name", DictRequired StringType), ("age", DictRequired NumberType)]
-  declTypeFromAST = build $ dict $ Person <$> field "name" string <*> field "age" integer
-
-instance TD.IsEnumType BusinessType where
-  enumTypeName = "businessType"
-  enumTypeVariants = ["Manufacturer", "Seller", "Store"]
-  enumTypeFromVariant "Manufacturer" = Right Manufacturer
-  enumTypeFromVariant "Seller" = Right Seller
-  enumTypeFromVariant "Store" = Right Store
-  enumTypeFromVariant _ = error "invalid IsEnumType instance for BusinessType"
-
-instance TD.IsDeclType Business where
-  declTypeName = "business"
-  declTypeBodyType =
-    DictType $
-      H.fromList
-        [ ("employees", DictRequired $ ListType $ DeclType "person"),
-          ("worth", DictRequired NumberType),
-          ("businessType", DictRequired $ EnumType "businessType"),
-          ("location", DictOptional StringType)
-        ]
-  declTypeFromAST =
-    build $
-      dict $
-        Business
-          <$> field "employees" (list decl)
-          <*> field "worth" double
-          <*> field "businessType" enum
-          <*> maybeField "location" string
 
 spec_Evaluator :: Spec
 spec_Evaluator = do