Properly propagate pkgMap through the TS code generator

Author: jared

lambda-buffers-codegen/src/LambdaBuffers/Codegen/Typescript/Print.hs

@@ -37,8 +37,8 @@ import Proto.Codegen qualified as P
 printModule :: MonadPrint m => Ts.PkgMap -> m (Doc ann, Set Text)
 printModule pkgMap = do
   ctx <- ask
-  tyDefDocs <- printTyDefs (ctx ^. Print.ctxModule)
-  instDocs <- printInstances
+  tyDefDocs <- printTyDefs pkgMap (ctx ^. Print.ctxModule)
+  instDocs <- printInstances pkgMap
   st <- get
 
   let modDoc =
@@ -84,10 +84,11 @@ printModule pkgMap = do
           (st ^. Print.stValueImports)
   return (modDoc, pkgDeps)
 
-printTyDefs :: MonadPrint m => PC.Module -> m [Doc ann]
-printTyDefs m = for (toList $ m ^. #typeDefs) printTyDef
+printTyDefs :: MonadPrint m => Ts.PkgMap -> PC.Module -> m [Doc ann]
+printTyDefs pkgMap m = for (toList $ m ^. #typeDefs) $ printTyDef pkgMap
 
 tsClassImplPrinters ::
+  Ts.PkgMap ->
   Map
     Ts.QClassName
     ( PC.ModuleName ->
@@ -96,37 +97,37 @@ tsClassImplPrinters ::
       PC.Ty ->
       Either P.InternalError (Doc ann, Set Ts.QValName)
     )
-tsClassImplPrinters =
+tsClassImplPrinters pkgMap =
   Map.fromList
     [
       ( tsEqClass
-      , printDeriveEq
+      , printDeriveEq pkgMap
       )
     ,
       ( tsIsPlutusDataClass
-      , printDeriveIsPlutusData
+      , printDeriveIsPlutusData pkgMap
       )
     ,
       ( tsJsonClass
-      , printDeriveJson
+      , printDeriveJson pkgMap
       )
     ]
 
-printInstances :: MonadPrint m => m [Doc ann]
-printInstances = do
+printInstances :: MonadPrint m => Ts.PkgMap -> m [Doc ann]
+printInstances pkgMap = do
   ci <- asks (view Print.ctxCompilerInput)
   m <- asks (view Print.ctxModule)
   let iTyDefs = PC.indexTyDefs ci
   foldrM
     ( \d instDocs -> do
-        instDocs' <- printDerive iTyDefs d
+        instDocs' <- printDerive pkgMap iTyDefs d
         return $ instDocs' <> instDocs
     )
     mempty
     (toList $ m ^. #derives)
 
-printDerive :: MonadPrint m => PC.TyDefs -> PC.Derive -> m [Doc ann]
-printDerive iTyDefs d = do
+printDerive :: MonadPrint m => Ts.PkgMap -> PC.TyDefs -> PC.Derive -> m [Doc ann]
+printDerive pkgMap iTyDefs d = do
   mn <- asks (view $ Print.ctxModule . #moduleName)
   let qcn = PC.qualifyClassRef mn (d ^. #constraint . #classRef)
   classes <- asks (view $ Print.ctxConfig . C.cfgClasses)
@@ -137,16 +138,16 @@ printDerive iTyDefs d = do
         pqcns
         ( \pqcn -> do
             Print.importClass pqcn
-            printTsQClassImpl mn iTyDefs pqcn d
+            printTsQClassImpl pkgMap mn iTyDefs pqcn d
         )
 
-printTsQClassImpl :: MonadPrint m => PC.ModuleName -> PC.TyDefs -> Ts.QClassName -> PC.Derive -> m (Doc ann)
-printTsQClassImpl mn iTyDefs hqcn d =
-  case Map.lookup hqcn tsClassImplPrinters of
+printTsQClassImpl :: MonadPrint m => Ts.PkgMap -> PC.ModuleName -> PC.TyDefs -> Ts.QClassName -> PC.Derive -> m (Doc ann)
+printTsQClassImpl pkgMap mn iTyDefs hqcn d =
+  case Map.lookup hqcn (tsClassImplPrinters pkgMap) of
     Nothing -> throwInternalError (d ^. #constraint . #sourceInfo) ("Missing capability to print the Typescript type class " <> show hqcn)
     Just implPrinter -> do
       let ty = d ^. #constraint . #argument
-      mkInstanceDoc <- printExportInstanceDecl hqcn ty
+      mkInstanceDoc <- printExportInstanceDecl pkgMap hqcn ty
       case implPrinter mn iTyDefs mkInstanceDoc ty of
         Left err -> throwInternalError (d ^. #constraint . #sourceInfo) ("Failed printing the implementation for " <> (show hqcn <> "\nGot error: " <> show err))
         Right (instanceDefsDoc, valImps) -> do
@@ -241,13 +242,13 @@ printImports selfModName pkgMap lbTyImports tsTyImports classImps ruleImps valIm
     importQualified :: (Doc ann, Doc ann) -> Doc ann
     importQualified (pkg, mn) = "import" <+> "*" <+> "as" <+> mn <+> "from" <+> squotes pkg
 
-{- | `collectPackageDeps pkgMap lbTyImports hsTyImports classImps ruleImps valImps` collects all the package dependencies.
+{- | `collectPackageDeps pkgMap lbTyImports tsTyImports classImps ruleImps valImps` collects all the package dependencies.
  Note that LB `lbTyImports` and `ruleImps` are wired by the user (as the user decides on the package name for their schemas).
 -}
 collectPackageDeps :: Ts.PkgMap -> Set PC.QTyName -> Set Ts.QTyName -> Set Ts.QClassName -> Set (PC.InfoLess PC.ModuleName) -> Set Ts.QValName -> Set Text
-collectPackageDeps pkgMap lbTyImports hsTyImports classImps ruleImps valImps =
+collectPackageDeps pkgMap lbTyImports tsTyImports classImps ruleImps valImps =
   let deps =
-        Set.fromList [Ts.pkgNameToText pkgName | (Just pkgName, _, _) <- toList hsTyImports]
+        Set.fromList [Ts.pkgNameToText pkgName | (Just pkgName, _, _) <- toList tsTyImports]
           `Set.union` Set.fromList [Ts.pkgNameToText pkgName | (pkgName, _, _) <- toList classImps]
           `Set.union` Set.fromList [Ts.pkgNameToText pkgName | (Just (pkgName, _), _) <- toList valImps]
           `Set.union` Set.fromList

lambda-buffers-codegen/src/LambdaBuffers/Codegen/Typescript/Print/Derive.hs

@@ -43,19 +43,19 @@ lamTy2PCTy = \case
     -- Note(jaredponn): hopefully this never happens...
     Nothing
 
-instanceDictIdent :: Ts.QClassName -> PC.Ty -> Text
-instanceDictIdent className ty =
+instanceDictIdent :: Ts.PkgMap -> Ts.QClassName -> PC.Ty -> Text
+instanceDictIdent pkgMap className ty =
   Lens.view (dict . Lens.to (PrettyPrinter.Text.renderStrict . layoutPretty defaultLayoutOptions)) $
-    printInstanceDict className ty
+    printInstanceDict pkgMap className ty
 
-lvEqBuiltins :: LV.PrintRead Builtin
-lvEqBuiltins = LV.MkPrintRead $ \(tys, refName) ->
+lvEqBuiltins :: Ts.PkgMap -> LV.PrintRead Builtin
+lvEqBuiltins pkgMap = LV.MkPrintRead $ \(tys, refName) ->
   case (refName, tys) of
     ("eq", [ty]) -> do
       ty' <- lamTy2PCTy ty
       return $
         OverloadedBuiltin
-          (Ts.primValName $ instanceDictIdent tsEqClass ty')
+          (Ts.primValName $ instanceDictIdent pkgMap tsEqClass ty')
           0 -- index in the list of substitutions for the type we're overloading on
           ".eq"
     ("true", _) -> Just $ Builtin $ Ts.primValName "true"
@@ -73,12 +73,12 @@ neqClassMethodName = Ts.MkValueName "neq"
 tsEqClass :: Ts.QClassName
 tsEqClass = (Ts.MkPackageName "lbr-prelude", Ts.MkModuleName "LbrPrelude", Ts.MkClassName "Eq")
 
-printDeriveEq :: PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> Either P.InternalError (Doc ann, Set Ts.QValName)
-printDeriveEq mn iTyDefs mkExportInstanceDeclDoc ty = do
+printDeriveEq :: Ts.PkgMap -> PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> Either P.InternalError (Doc ann, Set Ts.QValName)
+printDeriveEq pkgMap mn iTyDefs mkExportInstanceDeclDoc ty = do
   eqValE <- deriveEqImpl mn iTyDefs ty
   neqValE <- deriveNeqImpl mn iTyDefs ty
-  (eqImplDoc, eqImports) <- LV.runPrint lvEqBuiltins (printValueE eqValE)
-  (neqImplDoc, neqImports) <- LV.runPrint lvEqBuiltins (printValueE neqValE)
+  (eqImplDoc, eqImports) <- LV.runPrint (lvEqBuiltins pkgMap) (printValueE eqValE)
+  (neqImplDoc, neqImports) <- LV.runPrint (lvEqBuiltins pkgMap) (printValueE neqValE)
   let eqValueDefDoc =
         align $
           vsep
@@ -90,21 +90,21 @@ printDeriveEq mn iTyDefs mkExportInstanceDeclDoc ty = do
     , Set.map (Lens.view qualifiedValName) $ eqImports <> neqImports
     )
 
-lvPlutusDataBuiltins :: LV.PrintRead Builtin
-lvPlutusDataBuiltins = LV.MkPrintRead $ \(tys, refName) ->
+lvPlutusDataBuiltins :: Ts.PkgMap -> LV.PrintRead Builtin
+lvPlutusDataBuiltins pkgMap = LV.MkPrintRead $ \(tys, refName) ->
   case (refName, tys) of
     ("toPlutusData", [ty]) -> do
       ty' <- lamTy2PCTy ty
       return $
         OverloadedBuiltin
-          (Ts.primValName $ instanceDictIdent tsIsPlutusDataClass ty')
+          (Ts.primValName $ instanceDictIdent pkgMap tsIsPlutusDataClass ty')
           0 -- index in the list of substitutions for the type we're overloading on
           ".toData"
     ("fromPlutusData", [ty]) -> do
       ty' <- lamTy2PCTy ty
       return $
         OverloadedBuiltin
-          (Ts.primValName $ instanceDictIdent tsIsPlutusDataClass ty')
+          (Ts.primValName $ instanceDictIdent pkgMap tsIsPlutusDataClass ty')
           0 -- index in the list of substitutions for the type we're overloading on
           ".fromData"
     ("casePlutusData", _) -> Just $ Builtin $ Ts.normalValName "lbr-plutus/Runtime.js" "LbrPlutusRuntime" "casePlutusData"
@@ -125,13 +125,13 @@ fromPlutusDataClassMethodName = Ts.MkValueName "fromData"
 tsIsPlutusDataClass :: Ts.QClassName
 tsIsPlutusDataClass = (Ts.MkPackageName "lbr-plutus/PlutusData.js", Ts.MkModuleName "LbrPlutusPD", Ts.MkClassName "IsPlutusData")
 
-printDeriveIsPlutusData :: PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> Either P.InternalError (Doc ann, Set Ts.QValName)
-printDeriveIsPlutusData mn iTyDefs mkExportInstanceDeclDoc ty = do
+printDeriveIsPlutusData :: Ts.PkgMap -> PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> Either P.InternalError (Doc ann, Set Ts.QValName)
+printDeriveIsPlutusData pkgMap mn iTyDefs mkExportInstanceDeclDoc ty = do
   toPlutusDataValE <- deriveToPlutusDataImpl mn iTyDefs ty
   fromPlutusDataValE <- deriveFromPlutusDataImpl mn iTyDefs ty
 
-  (toDataImplDoc, toDataImports) <- LV.runPrint lvPlutusDataBuiltins (printValueE toPlutusDataValE)
-  (fromDataImplDoc, fromDataImports) <- LV.runPrint lvPlutusDataBuiltins (printValueE fromPlutusDataValE)
+  (toDataImplDoc, toDataImports) <- LV.runPrint (lvPlutusDataBuiltins pkgMap) (printValueE toPlutusDataValE)
+  (fromDataImplDoc, fromDataImports) <- LV.runPrint (lvPlutusDataBuiltins pkgMap) (printValueE fromPlutusDataValE)
 
   let valueDefDoc =
         align $
@@ -148,21 +148,21 @@ tsJsonClass :: Ts.QClassName
 tsJsonClass = (Ts.MkPackageName "lbr-prelude", Ts.MkModuleName "LbrPrelude", Ts.MkClassName "Json")
 
 -- | LambdaBuffers.Codegen.LamVal.Json specification printing
-lvJsonBuiltins :: LV.PrintRead Builtin
-lvJsonBuiltins = LV.MkPrintRead $ \(tys, refName) ->
+lvJsonBuiltins :: Ts.PkgMap -> LV.PrintRead Builtin
+lvJsonBuiltins pkgMap = LV.MkPrintRead $ \(tys, refName) ->
   case (refName, tys) of
     ("toJson", [ty]) -> do
       ty' <- lamTy2PCTy ty
       return $
         OverloadedBuiltin
-          (Ts.primValName $ instanceDictIdent tsJsonClass ty')
+          (Ts.primValName $ instanceDictIdent pkgMap tsJsonClass ty')
           0 -- index in the list of substitutions for the type we're overloading on
           ".toJson"
     ("fromJson", [ty]) -> do
       ty' <- lamTy2PCTy ty
       return $
         OverloadedBuiltin
-          (Ts.primValName (instanceDictIdent tsJsonClass ty'))
+          (Ts.primValName (instanceDictIdent pkgMap tsJsonClass ty'))
           0 -- index in the list of substitutions for the type we're overloading on
           ".fromJson"
     ("jsonObject", _) -> return $ Builtin $ Ts.normalValName "lbr-prelude" "LbrPrelude" "jsonObject"
@@ -176,7 +176,7 @@ lvJsonBuiltins = LV.MkPrintRead $ \(tys, refName) ->
             "lbr-prelude"
             "LbrPrelude"
             ( PrettyPrinter.Text.renderStrict . layoutPretty defaultLayoutOptions $
-                "caseJsonConstructor" <> surround (Typescript.Print.Ty.printTyInner ty') langle rangle
+                "caseJsonConstructor" <> surround (Typescript.Print.Ty.printTyInner pkgMap ty') langle rangle
             )
     ("caseJsonArray", _) -> return $ Builtin $ Ts.normalValName "lbr-prelude" "LbrPrelude" "caseJsonArray"
     ("caseJsonObject", _) -> return $ Builtin $ Ts.normalValName "lbr-prelude" "LbrPrelude" "caseJsonObject"
@@ -192,12 +192,12 @@ toJsonClassMethodName = Ts.MkValueName "toJson"
 fromJsonClassMethodName :: Ts.ValueName
 fromJsonClassMethodName = Ts.MkValueName "fromJson"
 
-printDeriveJson :: PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> Either P.InternalError (Doc ann, Set Ts.QValName)
-printDeriveJson mn iTyDefs mkExportInstanceDeclDoc ty = do
+printDeriveJson :: Ts.PkgMap -> PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> Either P.InternalError (Doc ann, Set Ts.QValName)
+printDeriveJson pkgMap mn iTyDefs mkExportInstanceDeclDoc ty = do
   toJsonValE <- deriveToJsonImpl mn iTyDefs ty
-  (toJsonImplDoc, impsA) <- LV.runPrint lvJsonBuiltins (printValueE toJsonValE)
+  (toJsonImplDoc, impsA) <- LV.runPrint (lvJsonBuiltins pkgMap) (printValueE toJsonValE)
   fromJsonValE <- deriveFromJsonImpl mn iTyDefs ty
-  (fromJsonImplDoc, impsB) <- LV.runPrint lvJsonBuiltins (printValueE fromJsonValE)
+  (fromJsonImplDoc, impsB) <- LV.runPrint (lvJsonBuiltins pkgMap) (printValueE fromJsonValE)
 
   let valueDefDoc =
         align $

lambda-buffers-codegen/src/LambdaBuffers/Codegen/Typescript/Print/InstanceDef.hs

@@ -79,8 +79,8 @@ $(Lens.TH.makeLenses ''InstanceDict)
   given in 4.3.2 of
   https://www.haskell.org/onlinereport/haskell2010/haskellch4.html#x10-630004.1
 -}
-printInstanceDict :: forall ann. Ts.QClassName -> PC.Ty -> InstanceDict (Doc ann)
-printInstanceDict qcn ty =
+printInstanceDict :: forall ann. Ts.PkgMap -> Ts.QClassName -> PC.Ty -> InstanceDict (Doc ann)
+printInstanceDict pkgMap qcn ty =
   let go :: PC.Ty -> InstanceDict (Doc ann)
       go (PC.TyVarI PC.TyVar {PC.varName = varName}) =
         ArgumentInstanceDict $ "dict" <> printVarName varName
@@ -90,7 +90,7 @@ printInstanceDict qcn ty =
             tyRefDoc = case tyRef of
               PC.LocalI PC.LocalRef {PC.tyName = tyName} -> pretty $ Lens.view #name tyName
               PC.ForeignI foreignRef ->
-                printTsQTyNameKey (Ts.fromLbForeignRef foreignRef)
+                printTsQTyNameKey (Ts.fromLbForeignRef pkgMap foreignRef)
          in TopLevelInstanceDict
               (mconcat [qClassNameDoc, brackets tyRefDoc])
               qClassNameDoc
@@ -99,10 +99,10 @@ printInstanceDict qcn ty =
 
 -- Prints e.g.
 -- Eq<$a>
-printInstanceType :: Ts.QClassName -> PC.Ty -> Doc ann
-printInstanceType qcn ty =
+printInstanceType :: Ts.PkgMap -> Ts.QClassName -> PC.Ty -> Doc ann
+printInstanceType pkgMap qcn ty =
   let crefDoc = printTsQClassName qcn
-      tyDoc = printTyInner ty
+      tyDoc = printTyInner pkgMap ty
    in crefDoc <> surround tyDoc langle rangle
 
 {- | Prints an instance context argument e.g.
@@ -112,19 +112,19 @@ printInstanceType qcn ty =
 
  dict$a : Eq<$a>
 -}
-printInstanceContextArg :: Ts.QClassName -> PC.Ty -> Doc ann
-printInstanceContextArg qcn ty =
-  Lens.view dict (printInstanceDict qcn ty)
+printInstanceContextArg :: Ts.PkgMap -> Ts.QClassName -> PC.Ty -> Doc ann
+printInstanceContextArg pkgMap qcn ty =
+  Lens.view dict (printInstanceDict pkgMap qcn ty)
     <+> ":"
-    <+> printInstanceType qcn ty
+    <+> printInstanceType pkgMap qcn ty
 
 -- Prints e.g.
 -- > <$a,$b>(dict$a : Eq<$a>, dict$b : Eq<$b>)
-printInstanceContext :: Ts.QClassName -> [PC.Ty] -> Doc ann
-printInstanceContext hsQClassName tys =
+printInstanceContext :: Ts.PkgMap -> Ts.QClassName -> [PC.Ty] -> Doc ann
+printInstanceContext pkgMap hsQClassName tys =
   align . group $
-    encloseSep langle rangle comma (map printTyInner tys)
-      <> encloseSep lparen rparen comma (printInstanceContextArg hsQClassName <$> tys)
+    encloseSep langle rangle comma (map (printTyInner pkgMap) tys)
+      <> encloseSep lparen rparen comma (printInstanceContextArg pkgMap hsQClassName <$> tys)
 
 collectInstanceDeclTypeVars :: PC.Ty -> [PC.Ty]
 collectInstanceDeclTypeVars = collectTyVars
@@ -141,12 +141,12 @@ collectVars' collected (PC.TyAppI (PC.TyApp _ args _)) = collected `Set.union` (
 collectVars' collected _ = collected
 
 -- See the INVARIANT note below
-printExportInstanceDecl :: MonadPrint m => Ts.QClassName -> PC.Ty -> m (Doc ann -> Doc ann)
-printExportInstanceDecl tsQClassName ty = do
+printExportInstanceDecl :: MonadPrint m => Ts.PkgMap -> Ts.QClassName -> PC.Ty -> m (Doc ann -> Doc ann)
+printExportInstanceDecl pkgMap tsQClassName ty = do
   let
-    instanceType = printInstanceType tsQClassName ty
+    instanceType = printInstanceType pkgMap tsQClassName ty
 
-    lhsInstanceDecl = printInstanceDict tsQClassName ty
+    lhsInstanceDecl = printInstanceDict pkgMap tsQClassName ty
 
     instanceDeclTypeVars = collectInstanceDeclTypeVars ty
 
@@ -192,15 +192,16 @@ printExportInstanceDecl tsQClassName ty = do
           , lbrace
           , indent 2 $
               vsep
-                [ "export" <+> "interface" <+> (printTsUnqualifiedQClassName tsQClassName <> "Instances")
+                [ -- TODO(jaredponn): typeclasses probably aren't supported..
+                  "export" <+> "interface" <+> (printTsUnqualifiedQClassName tsQClassName <> "Instances")
                 , lbrace
                 , indent 2 $
                     vsep
                       [ brackets tyDoc
                           <+> colon
                           <+> case instanceDeclTypeVars of
                             [] -> instanceType
-                            _ -> printInstanceContext tsQClassName instanceDeclTypeVars <+> "=>" <+> instanceType
+                            _ -> printInstanceContext pkgMap tsQClassName instanceDeclTypeVars <+> "=>" <+> instanceType
                       ]
                 , rbrace
                 ]
@@ -213,7 +214,7 @@ printExportInstanceDecl tsQClassName ty = do
               [] -> dictDoc <+> equals <+> bodyDoc
               _ ->
                 vsep
-                  [ dictDoc <+> equals <+> "function" <> printInstanceContext tsQClassName instanceDeclTypeVars <+> colon <+> instanceType
+                  [ dictDoc <+> equals <+> "function" <> printInstanceContext pkgMap tsQClassName instanceDeclTypeVars <+> colon <+> instanceType
                   , indent 2 $
                       vsep
                         [ lbrace