From ae84abc4aabe346fe830f4b10e89937954a799cb Mon Sep 17 00:00:00 2001 From: jared <> Date: Thu, 30 Nov 2023 17:24:50 -0700 Subject: [PATCH] Generalize the code generators builtin table symbol table lookup by changing `newtype PrintRead qvn = MkPrintRead { builtins :: Map ValueName qvn }` to `newtype PrintRead qvn = MkPrintRead { builtins :: Ref -> Maybe qvn }` s.t. the generated `qvn` may be influenced by the types it is instantiated with. --- .../Codegen/Haskell/Print/Derive.hs | 95 ++++++++++--------- .../Codegen/LamVal/MonadPrint.hs | 17 ++-- .../Codegen/Plutarch/Print/Derive.hs | 55 +++++------ .../Codegen/Purescript/Print/Derive.hs | 79 +++++++-------- .../Test/LambdaBuffers/Codegen/Plutarch.hs | 2 +- 5 files changed, 125 insertions(+), 123 deletions(-) diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Print/Derive.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Print/Derive.hs index e2c79221..7c8e78c6 100644 --- a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Print/Derive.hs +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Print/Derive.hs @@ -8,7 +8,6 @@ import Data.Set (Set) import LambdaBuffers.Codegen.Haskell.Print (MonadPrint) import LambdaBuffers.Codegen.Haskell.Print.LamVal (printValueE) import LambdaBuffers.Codegen.Haskell.Print.Syntax qualified as H -import LambdaBuffers.Codegen.LamVal qualified as LV import LambdaBuffers.Codegen.LamVal.Eq (deriveEqImpl) import LambdaBuffers.Codegen.LamVal.Json (deriveFromJsonImpl, deriveToJsonImpl) import LambdaBuffers.Codegen.LamVal.MonadPrint qualified as LV @@ -55,14 +54,15 @@ hsClassImplPrinters = eqClassMethodName :: H.ValueName eqClassMethodName = H.MkValueName "==" -lvEqBuiltinsBase :: Map LV.ValueName (H.CabalPackageName, H.ModuleName, H.ValueName) -lvEqBuiltinsBase = - Map.fromList - [ ("eq", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "==")) - , ("and", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "&&")) - , ("true", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "True")) - , ("false", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "False")) - ] +lvEqBuiltinsBase :: LV.PrintRead (H.CabalPackageName, H.ModuleName, H.ValueName) +lvEqBuiltinsBase = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("eq", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "==")) + , ("and", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "&&")) + , ("true", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "True")) + , ("false", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "False")) + ] printDeriveEqBase :: MonadPrint m => PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> m (Doc ann) printDeriveEqBase mn iTyDefs mkInstanceDoc ty = do @@ -76,14 +76,15 @@ printDeriveEqBase mn iTyDefs mkInstanceDoc ty = do for_ imps Print.importValue return instanceDoc -lvEqBuiltinsPlutusTx :: Map LV.ValueName (H.CabalPackageName, H.ModuleName, H.ValueName) -lvEqBuiltinsPlutusTx = - Map.fromList - [ ("eq", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Eq", H.MkValueName "==")) - , ("and", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Bool", H.MkValueName "&&")) - , ("true", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Bool", H.MkValueName "True")) - , ("false", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Bool", H.MkValueName "False")) - ] +lvEqBuiltinsPlutusTx :: LV.PrintRead (H.CabalPackageName, H.ModuleName, H.ValueName) +lvEqBuiltinsPlutusTx = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("eq", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Eq", H.MkValueName "==")) + , ("and", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Bool", H.MkValueName "&&")) + , ("true", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Bool", H.MkValueName "True")) + , ("false", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Bool", H.MkValueName "False")) + ] printDeriveEqPlutusTx :: MonadPrint m => PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> m (Doc ann) printDeriveEqPlutusTx mn iTyDefs mkInstanceDoc ty = do @@ -100,19 +101,20 @@ printDeriveEqPlutusTx mn iTyDefs mkInstanceDoc ty = do printInlineable :: H.ValueName -> Doc ann printInlineable valName = "{-# INLINABLE" <+> H.printHsValName valName <+> "#-}" -lvPlutusDataBuiltins :: Map LV.ValueName H.QValName -lvPlutusDataBuiltins = - Map.fromList - [ ("toPlutusData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx", H.MkValueName "toBuiltinData")) - , ("fromPlutusData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx", H.MkValueName "fromBuiltinData")) - , ("casePlutusData", (H.MkCabalPackageName "lbr-plutus", H.MkModuleName "LambdaBuffers.Runtime.Plutus", H.MkValueName "casePlutusData")) - , ("integerData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Builtins", H.MkValueName "mkI")) - , ("constrData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Builtins", H.MkValueName "mkConstr")) - , ("listData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Builtins", H.MkValueName "mkList")) - , ("succeedParse", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Maybe", H.MkValueName "Just")) - , ("failParse", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Maybe", H.MkValueName "Nothing")) - , ("bindParse", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Prelude", H.MkValueName ">>=")) - ] +lvPlutusDataBuiltins :: LV.PrintRead H.QValName +lvPlutusDataBuiltins = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("toPlutusData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx", H.MkValueName "toBuiltinData")) + , ("fromPlutusData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx", H.MkValueName "fromBuiltinData")) + , ("casePlutusData", (H.MkCabalPackageName "lbr-plutus", H.MkModuleName "LambdaBuffers.Runtime.Plutus", H.MkValueName "casePlutusData")) + , ("integerData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Builtins", H.MkValueName "mkI")) + , ("constrData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Builtins", H.MkValueName "mkConstr")) + , ("listData", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Builtins", H.MkValueName "mkList")) + , ("succeedParse", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Maybe", H.MkValueName "Just")) + , ("failParse", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Maybe", H.MkValueName "Nothing")) + , ("bindParse", (H.MkCabalPackageName "plutus-tx", H.MkModuleName "PlutusTx.Prelude", H.MkValueName ">>=")) + ] toPlutusDataClassMethodName :: H.ValueName toPlutusDataClassMethodName = H.MkValueName "toBuiltinData" @@ -152,22 +154,23 @@ printDeriveFromPlutusData mn iTyDefs mkInstanceDoc ty = do return instanceDoc -- | LambdaBuffers.Codegen.LamVal.Json specification printing -lvJsonBuiltins :: Map LV.ValueName H.QValName -lvJsonBuiltins = - Map.fromList - [ ("toJson", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "toJson")) - , ("fromJson", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "fromJson")) - , ("jsonObject", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonObject")) - , ("jsonConstructor", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonConstructor")) - , ("jsonArray", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonArray")) - , ("caseJsonConstructor", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "caseJsonConstructor")) - , ("caseJsonArray", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "caseJsonArray")) - , ("caseJsonObject", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "caseJsonObject")) - , ("jsonField", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonField")) - , ("succeedParse", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "return")) - , ("failParse", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "fail")) - , ("bindParse", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName ">>=")) - ] +lvJsonBuiltins :: LV.PrintRead H.QValName +lvJsonBuiltins = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("toJson", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "toJson")) + , ("fromJson", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "fromJson")) + , ("jsonObject", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonObject")) + , ("jsonConstructor", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonConstructor")) + , ("jsonArray", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonArray")) + , ("caseJsonConstructor", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "caseJsonConstructor")) + , ("caseJsonArray", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "caseJsonArray")) + , ("caseJsonObject", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "caseJsonObject")) + , ("jsonField", (H.MkCabalPackageName "lbr-prelude", H.MkModuleName "LambdaBuffers.Runtime.Prelude", H.MkValueName "jsonField")) + , ("succeedParse", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "return")) + , ("failParse", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName "fail")) + , ("bindParse", (H.MkCabalPackageName "base", H.MkModuleName "Prelude", H.MkValueName ">>=")) + ] toJsonClassMethodName :: H.ValueName toJsonClassMethodName = H.MkValueName "toJson" diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/LamVal/MonadPrint.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/LamVal/MonadPrint.hs index 6e4f1c3a..916556ca 100644 --- a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/LamVal/MonadPrint.hs +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/LamVal/MonadPrint.hs @@ -1,12 +1,10 @@ -module LambdaBuffers.Codegen.LamVal.MonadPrint (MonadPrint, runPrint, freshArg, resolveRef, importValue) where +module LambdaBuffers.Codegen.LamVal.MonadPrint (MonadPrint, PrintRead (MkPrintRead), runPrint, freshArg, resolveRef, importValue) where import Control.Lens ((&), (.~)) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Except (Except, runExcept) import Control.Monad.RWS (RWST (runRWST)) import Control.Monad.RWS.Class (MonadRWS, asks, gets, modify) -import Data.Map (Map) -import Data.Map qualified as Map import Data.ProtoLens (Message (defMessage)) import Data.Set (Set) import Data.Set qualified as Set @@ -17,9 +15,8 @@ import Proto.Codegen qualified as P import Proto.Codegen_Fields qualified as P newtype PrintRead qvn = MkPrintRead - { builtins :: Map ValueName qvn + { builtins :: Ref -> Maybe qvn } - deriving stock (Show) data PrintState qvn = MkPrintState { currentVar :: Int @@ -36,9 +33,9 @@ type MonadPrint m qvn = (MonadRWS (PrintRead qvn) () (PrintState qvn) m, MonadEr type PrintM qvn = RWST (PrintRead qvn) () (PrintState qvn) (Except PrintError) -runPrint :: Ord qvn => Map ValueName qvn -> PrintM qvn (Doc ann) -> Either PrintError (Doc ann, Set qvn) +runPrint :: Ord qvn => PrintRead qvn -> PrintM qvn (Doc ann) -> Either PrintError (Doc ann, Set qvn) runPrint lamValBuiltins printer = - let p = runExcept $ runRWST printer (MkPrintRead lamValBuiltins) (MkPrintState 0 mempty) + let p = runExcept $ runRWST printer lamValBuiltins (MkPrintState 0 mempty) in case p of Left err -> Left err Right (doc, st, _) -> Right (doc, valueImports st) @@ -61,8 +58,8 @@ importValue qvn = modify (\(MkPrintState curr imps) -> MkPrintState curr (Set.in TODO(bladyjoker): Output all necessary implementations from the Compiler and report on missing. -} resolveRef :: MonadPrint m qvn => Ref -> m qvn -resolveRef (_, refName) = do +resolveRef ref = do bs <- asks builtins - case Map.lookup refName bs of - Nothing -> throwInternalError $ "LamVal builtin mapping for " <> show refName <> " not configured." + case bs ref of + Nothing -> throwInternalError $ "LamVal builtin mapping for " <> show (snd ref :: ValueName) <> " instantiated with types " <> show (fst ref) <> " not configured." Just qvn -> return qvn diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Plutarch/Print/Derive.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Plutarch/Print/Derive.hs index 000a8d40..ecd472e2 100644 --- a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Plutarch/Print/Derive.hs +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Plutarch/Print/Derive.hs @@ -12,7 +12,6 @@ import LambdaBuffers.Codegen.Haskell.Print.InstanceDef qualified as HsSyntax import LambdaBuffers.Codegen.Haskell.Print.LamVal qualified as HsLamVal import LambdaBuffers.Codegen.Haskell.Print.Syntax qualified as HsSyntax import LambdaBuffers.Codegen.Haskell.Print.TyDef qualified as HsTyDef -import LambdaBuffers.Codegen.LamVal qualified as LV import LambdaBuffers.Codegen.LamVal.MonadPrint qualified as LV import LambdaBuffers.Codegen.LamVal.PlutusData (deriveFromPlutusDataImplPlutarch, deriveToPlutusDataImplPlutarch) import LambdaBuffers.Codegen.Plutarch.Print.LamVal qualified as PlLamVal @@ -109,19 +108,20 @@ printDerivePIsData _mn _iTyDefs mkInstanceDoc _ty = do let instanceDoc = mkInstanceDoc (align $ vsep [pdataImpl, pfromDataImpl]) return instanceDoc -lvPlutusDataBuiltinsForPlutusType :: Map LV.ValueName HsSyntax.QValName -lvPlutusDataBuiltinsForPlutusType = - Map.fromList - [ ("toPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "toPlutusData")) - , ("fromPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfromPlutusDataPlutusType")) - , ("casePlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pcasePlutusData")) - , ("integerData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "integerData")) - , ("constrData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "constrData")) - , ("listData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "listData")) - , ("succeedParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "psucceedParse")) - , ("failParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfailParse")) - , ("bindParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pbindParse")) - ] +lvPlutusDataBuiltinsForPlutusType :: LV.PrintRead HsSyntax.QValName +lvPlutusDataBuiltinsForPlutusType = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("toPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "toPlutusData")) + , ("fromPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfromPlutusDataPlutusType")) + , ("casePlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pcasePlutusData")) + , ("integerData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "integerData")) + , ("constrData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "constrData")) + , ("listData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "listData")) + , ("succeedParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "psucceedParse")) + , ("failParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfailParse")) + , ("bindParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pbindParse")) + ] printDerivePlutusType :: MonadPrint m => PC.ModuleName -> PC.TyDefs -> (Doc ann -> Doc ann) -> PC.Ty -> m (Doc ann) printDerivePlutusType mn iTyDefs _mkInstanceDoc ty = do @@ -196,19 +196,20 @@ printPlutusTypeInstanceDef ty implDefDoc = do printValueDef :: HsSyntax.ValueName -> Doc ann -> Doc ann printValueDef valName valDoc = HsSyntax.printHsValName valName <+> equals <+> valDoc -lvPlutusDataBuiltinsForPTryFrom :: Map LV.ValueName HsSyntax.QValName -lvPlutusDataBuiltinsForPTryFrom = - Map.fromList - [ ("toPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "toPlutusData")) - , ("fromPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfromPlutusDataPTryFrom")) - , ("casePlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pcasePlutusData")) - , ("integerData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "integerData")) - , ("constrData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "constrData")) - , ("listData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "listData")) - , ("succeedParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "psucceedParse")) - , ("failParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfailParse")) - , ("bindParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pbindParse")) - ] +lvPlutusDataBuiltinsForPTryFrom :: LV.PrintRead HsSyntax.QValName +lvPlutusDataBuiltinsForPTryFrom = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("toPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "toPlutusData")) + , ("fromPlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfromPlutusDataPTryFrom")) + , ("casePlutusData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pcasePlutusData")) + , ("integerData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "integerData")) + , ("constrData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "constrData")) + , ("listData", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "listData")) + , ("succeedParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "psucceedParse")) + , ("failParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pfailParse")) + , ("bindParse", (HsSyntax.MkCabalPackageName "lbr-plutarch", HsSyntax.MkModuleName "LambdaBuffers.Runtime.Plutarch.LamVal", HsSyntax.MkValueName "pbindParse")) + ] {- | PTryFrom instance implementation. diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Purescript/Print/Derive.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Purescript/Print/Derive.hs index d6872cb0..4072cb9a 100644 --- a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Purescript/Print/Derive.hs +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Purescript/Print/Derive.hs @@ -1,9 +1,7 @@ module LambdaBuffers.Codegen.Purescript.Print.Derive (printDeriveEq, printDeriveToPlutusData, printDeriveFromPlutusData, printDeriveJson) where -import Data.Map (Map) import Data.Map qualified as Map import Data.Set (Set) -import LambdaBuffers.Codegen.LamVal qualified as LV import LambdaBuffers.Codegen.LamVal.Eq (deriveEqImpl) import LambdaBuffers.Codegen.LamVal.Json (deriveFromJsonImpl, deriveToJsonImpl) import LambdaBuffers.Codegen.LamVal.MonadPrint qualified as LV @@ -15,14 +13,15 @@ import LambdaBuffers.ProtoCompat qualified as PC import Prettyprinter (Doc, align, equals, vsep, (<+>)) import Proto.Codegen qualified as P -lvEqBuiltins :: Map LV.ValueName Purs.QValName -lvEqBuiltins = - Map.fromList - [ ("eq", Purs.normalValName "prelude" "Prelude" "==") - , ("and", Purs.normalValName "prelude" "Prelude" "&&") - , ("true", Purs.primValName "true") - , ("false", Purs.primValName "false") - ] +lvEqBuiltins :: LV.PrintRead Purs.QValName +lvEqBuiltins = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("eq", Purs.normalValName "prelude" "Prelude" "==") + , ("and", Purs.normalValName "prelude" "Prelude" "&&") + , ("true", Purs.primValName "true") + , ("false", Purs.primValName "false") + ] eqClassMethodName :: Purs.ValueName eqClassMethodName = Purs.MkValueName "eq" @@ -34,19 +33,20 @@ printDeriveEq mn iTyDefs mkInstanceDoc ty = do let instanceDoc = mkInstanceDoc (printValueDef eqClassMethodName implDoc) return (instanceDoc, imports) -lvPlutusDataBuiltins :: Map LV.ValueName Purs.QValName -lvPlutusDataBuiltins = - Map.fromList - [ ("toPlutusData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.ToData" "toData") - , ("fromPlutusData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.FromData" "fromData") - , ("casePlutusData", Purs.normalValName "lbr-plutus" "LambdaBuffers.Runtime.Plutus" "casePlutusData") - , ("integerData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.Types.PlutusData" "Integer") - , ("constrData", Purs.normalValName "lbr-plutus" "LambdaBuffers.Runtime.Plutus" "pdConstr") - , ("listData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.Types.PlutusData" "List") - , ("succeedParse", Purs.normalValName "maybe" "Data.Maybe" "Just") - , ("failParse", Purs.normalValName "maybe" "Data.Maybe" "Nothing") - , ("bindParse", Purs.normalValName "prelude" "Prelude" ">>=") - ] +lvPlutusDataBuiltins :: LV.PrintRead Purs.QValName +lvPlutusDataBuiltins = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("toPlutusData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.ToData" "toData") + , ("fromPlutusData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.FromData" "fromData") + , ("casePlutusData", Purs.normalValName "lbr-plutus" "LambdaBuffers.Runtime.Plutus" "casePlutusData") + , ("integerData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.Types.PlutusData" "Integer") + , ("constrData", Purs.normalValName "lbr-plutus" "LambdaBuffers.Runtime.Plutus" "pdConstr") + , ("listData", Purs.normalValName "cardano-transaction-lib" "Ctl.Internal.Types.PlutusData" "List") + , ("succeedParse", Purs.normalValName "maybe" "Data.Maybe" "Just") + , ("failParse", Purs.normalValName "maybe" "Data.Maybe" "Nothing") + , ("bindParse", Purs.normalValName "prelude" "Prelude" ">>=") + ] toPlutusDataClassMethodName :: Purs.ValueName toPlutusDataClassMethodName = Purs.MkValueName "toData" @@ -78,22 +78,23 @@ printValueDef :: Purs.ValueName -> Doc ann -> Doc ann printValueDef valName valDoc = printPursValName valName <+> equals <+> valDoc -- | LambdaBuffers.Codegen.LamVal.Json specification printing -lvJsonBuiltins :: Map LV.ValueName Purs.QValName -lvJsonBuiltins = - Map.fromList - [ ("toJson", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "toJson") - , ("fromJson", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "fromJson") - , ("jsonObject", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonObject") - , ("jsonConstructor", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonConstructor") - , ("jsonArray", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonArray") - , ("caseJsonConstructor", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "caseJsonConstructor") - , ("caseJsonArray", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "caseJsonArray") - , ("caseJsonObject", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "caseJsonObject") - , ("jsonField", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonField") - , ("succeedParse", Purs.normalValName "either" "Data.Either" "Right") - , ("failParse", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "fail") - , ("bindParse", Purs.normalValName "prelude" "Prelude" ">>=") - ] +lvJsonBuiltins :: LV.PrintRead Purs.QValName +lvJsonBuiltins = LV.MkPrintRead $ \(_ty, refName) -> + Map.lookup refName $ + Map.fromList + [ ("toJson", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "toJson") + , ("fromJson", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "fromJson") + , ("jsonObject", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonObject") + , ("jsonConstructor", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonConstructor") + , ("jsonArray", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonArray") + , ("caseJsonConstructor", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "caseJsonConstructor") + , ("caseJsonArray", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "caseJsonArray") + , ("caseJsonObject", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "caseJsonObject") + , ("jsonField", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "jsonField") + , ("succeedParse", Purs.normalValName "either" "Data.Either" "Right") + , ("failParse", Purs.normalValName "lbr-prelude" "LambdaBuffers.Runtime.Prelude" "fail") + , ("bindParse", Purs.normalValName "prelude" "Prelude" ">>=") + ] toJsonClassMethodName :: Purs.ValueName toJsonClassMethodName = Purs.MkValueName "toJson" diff --git a/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen/Plutarch.hs b/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen/Plutarch.hs index a4c94223..4ba36724 100644 --- a/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen/Plutarch.hs +++ b/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen/Plutarch.hs @@ -175,7 +175,7 @@ testLamValInterpretation = let interpret = LamVal.runPrint - (Map.singleton "fooRef" (HsSyntax.MkCabalPackageName "foo-pkg", HsSyntax.MkModuleName "Foo", HsSyntax.MkValueName "fooRef")) + (LamVal.MkPrintRead $ \(_ty, refName) -> Map.lookup refName $ Map.singleton "fooRef" (HsSyntax.MkCabalPackageName "foo-pkg", HsSyntax.MkModuleName "Foo", HsSyntax.MkValueName "fooRef")) . PlLamVal.printValueE tcs :: [TestTree] tcs =