diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs index e6277ae698..bc7f960ac9 100644 --- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs +++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs @@ -79,7 +79,6 @@ module DA.Daml.LFConversion , sourceLocToRange ) where -import DA.Daml.LF.Simplifier (freeVarsStep) import DA.Daml.LFConversion.Primitives import DA.Daml.LFConversion.UtilGHC import DA.Daml.LFConversion.UtilLF @@ -88,7 +87,6 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.GHC.Util -import Control.Applicative import Control.Lens import Control.Monad.Except import Control.Monad.Extra @@ -98,7 +96,6 @@ import Control.Monad.State.Strict import DA.Daml.LF.Ast as LF import Data.Data hiding (TyCon) import Data.Foldable (foldlM) -import Data.Functor.Foldable import Data.Int import Data.List.Extra import qualified Data.Map.Strict as MS @@ -156,9 +153,6 @@ data Env = Env {envLFModuleName :: LF.ModuleName ,envGHCModuleName :: GHC.ModuleName ,envModuleUnitId :: GHC.UnitId - ,envBindings :: MS.Map Var (GHC.Expr Var) - ,envChoices :: MS.Map String [GHC.Expr Var] - ,envKeys :: MS.Map String [GHC.Expr Var] ,envDefaultMethods :: Set.Set Name ,envAliases :: MS.Map Var LF.Expr ,envPkgMap :: MS.Map GHC.UnitId T.Text @@ -166,19 +160,6 @@ data Env = Env ,envNewtypes :: [(GHC.Type, (TyCon, Coercion))] } -envFindBind :: Env -> Var -> ConvertM (GHC.Expr Var) -envFindBind Env{..} var = - case MS.lookup var envBindings of - Nothing -> conversionError errMsg - Just v -> pure v - where errMsg = "Looking for local binding failed when looking up " ++ prettyPrint var ++ ", available " ++ prettyPrint (MS.keys envBindings) - -envFindChoices :: Env -> String -> [GHC.Expr Var] -envFindChoices Env{..} x = fromMaybe [] $ MS.lookup x envChoices - -envFindKeys :: Env -> String -> [GHC.Expr Var] -envFindKeys Env{..} x = fromMaybe [] $ MS.lookup x envKeys - -- v is an alias for x envInsertAlias :: Var -> LF.Expr -> Env -> Env envInsertAlias v x env = env{envAliases = MS.insert v x (envAliases env)} @@ -259,20 +240,6 @@ convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing) thisUnitId = GHC.moduleUnitId $ cm_module x lfModName = convertModuleName ghcModName flags = LF.daml12FeatureFlags - binds = concat [case x' of NonRec a b -> [(a,b)]; Rec xs -> xs | x' <- cm_binds x] - bindings = MS.fromList binds - choices = MS.fromListWith (++) - [(is x', [b]) - | (a,b) <- binds - , DFunId _ <- [idDetails a] - , TypeCon (QIsTpl "Choice") [TypeCon x' [],_,_] <- [varType a] - ] - keys = MS.fromListWith (++) - [(is x', [b]) - | (a,b) <- binds - , DFunId _ <- [idDetails a] - , TypeCon (QIsTpl "TemplateKey") [TypeCon x' [],_] <- [varType a] - ] newtypes = [ (wrappedT, (t, mkUnbranchedAxInstCo Representational co [] [])) | ATyCon t <- eltsUFM (cm_types x) @@ -283,9 +250,6 @@ convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing) { envLFModuleName = lfModName , envGHCModuleName = ghcModName , envModuleUnitId = thisUnitId - , envBindings = bindings - , envChoices = choices - , envKeys = keys , envDefaultMethods = defMeths , envAliases = MS.empty , envPkgMap = pkgMap @@ -299,29 +263,6 @@ isTypeableInfo (NonRec name _) = any (`isPrefixOf` getOccString name) ["$krep", isTypeableInfo _ = False -convertTemplate :: Env -> GHC.Expr Var -> ConvertM [Definition] -convertTemplate env (Var (QIsTpl "C:Template") `App` Type (TypeCon ty []) - `App` ensure `App` signatories `App` observer `App` agreement `App` _create `App` _fetch `App` _archive) - = do - tplSignatories <- applyTplParam <$> convertExpr env signatories - tplChoices <- fmap (\cs -> NM.fromList (archiveChoice tplSignatories : cs)) (choices tplSignatories) - tplObservers <- applyTplParam <$> convertExpr env observer - tplPrecondition <- applyTplParam <$> convertExpr env ensure - tplAgreement <- applyTplParam <$> convertExpr env agreement - tplKey <- keys >>= \case - [] -> return Nothing - [x] -> return (Just x) - _:_ -> conversionError ("multiple keys found for template " ++ prettyPrint ty) - pure [DTemplate Template{..}] - where - applyTplParam e = e `ETmApp` EVar tplParam - choices signatories = mapM (convertChoice env signatories) $ envFindChoices env $ is ty - keys = mapM (convertKey env) $ envFindKeys env $ is ty - tplLocation = Nothing - tplTypeCon = mkTypeCon [is ty] - tplParam = mkVar "this" -convertTemplate _ x = unsupported "Template definition with unexpected form" x - convertGenericTemplate :: Env -> GHC.Expr Var -> ConvertM (Template, LF.Expr) convertGenericTemplate env x | (dictCon, args) <- collectArgs x @@ -438,92 +379,11 @@ convertGenericTemplate env x res = mkVar "res" convertGenericTemplate env x = unhandled "generic template" x -archiveChoice :: LF.Expr -> TemplateChoice -archiveChoice signatories = TemplateChoice{..} - where - chcLocation = Nothing - chcName = mkChoiceName "Archive" - chcReturnType = TUnit - chcConsuming = True - chcControllers = signatories - chcUpdate = EUpdate $ UPure TUnit EUnit - chcSelfBinder = mkVar "self" - chcArgBinder = (mkVar "arg", TUnit) - data Consuming = PreConsuming | NonConsuming | PostConsuming deriving (Eq) -convertChoice :: Env -> LF.Expr -> GHC.Expr Var -> ConvertM TemplateChoice -convertChoice env signatories - (Var (QIsTpl "C:Choice") `App` - Type tmpl@(TypeCon tmplTyCon []) `App` - Type (TypeCon chc []) `App` - Type result `App` - _templateDict `App` - consuming `App` - Var controller `App` - choice `App` _exercise) = do - consumption <- f (10 :: Int) consuming - let chcConsuming = consumption == PreConsuming -- Runtime should auto-archive? - argType <- convertType env $ TypeCon chc [] - let chcArgBinder = (mkVar "arg", argType) - tmplType <- convertType env tmpl - tmplTyCon' <- convertQualified env tmplTyCon - chcReturnType <- convertType env result - controllerExpr <- envFindBind env controller >>= convertExpr env - let chcControllers = case controllerExpr of - -- NOTE(MH): We drop the second argument to `controllerExpr` when - -- it is unused. This is necessary to make sure that a - -- non-flexible controller expression does not mention the choice - -- argument `argVar`. - ETmLam thisBndr (ETmLam argBndr body) - | fst argBndr `Set.notMember` cata freeVarsStep body -> - ETmLam thisBndr body `ETmApp` thisVar - _ -> controllerExpr `ETmApp` thisVar `ETmApp` argVar - expr <- fmap (\u -> u `ETmApp` thisVar `ETmApp` selfVar `ETmApp` argVar) (convertExpr env choice) - let chcUpdate = - if consumption /= PostConsuming then expr - else - -- NOTE(SF): Support for 'postconsuming' choices. The idea - -- is to evaluate the user provided choice body and - -- following that, archive. That is, in pseduo-code, we are - -- going for an expression like this: - -- expr this self arg >>= \res -> - -- archive signatories self >>= \_ -> - -- return res - let archive = EUpdate $ UExercise tmplTyCon' (mkChoiceName "Archive") selfVar (Just signatories) EUnit - in EUpdate $ UBind (Binding (mkVar "res", chcReturnType) expr) $ - EUpdate $ UBind (Binding (mkVar "_", TUnit) archive) $ - EUpdate $ UPure chcReturnType (EVar $ mkVar "res") - pure TemplateChoice{..} - where - chcLocation = Nothing - chcName = mkChoiceName $ occNameString $ nameOccName $ getName chc - chcSelfBinder = mkVar "self" - thisVar = EVar (mkVar "this") - selfVar = EVar (mkVar "self") - argVar = EVar (mkVar "arg") - - f i (App a _) = f i a - f i (Tick _ e) = f i e - f i (VarIs "$dmconsuming") = pure PreConsuming - f i (Var (QIsTpl "preconsuming")) = pure PreConsuming - f i (Var (QIsTpl "nonconsuming")) = pure NonConsuming - f i (Var (QIsTpl "postconsuming")) = pure PostConsuming - f i (Var x) | i > 0 = f (i-1) =<< envFindBind env x -- only required to see through the automatic default - f _ x = unsupported "Unexpected definition of 'consuming'. Expected either absent, 'preconsuming', 'postconsuming' or 'nonconsuming'" x -convertChoice _ _ x = unhandled "Choice body" x - -convertKey :: Env -> GHC.Expr Var -> ConvertM TemplateKey -convertKey env o@(Var (QIsTpl "C:TemplateKey") `App` Type tmpl `App` Type keyType `App` _templateDict `App` Var key `App` Var maintainer `App` _fetch `App` _lookup) = do - keyType <- convertType env keyType - key <- envFindBind env key >>= convertExpr env - maintainer <- envFindBind env maintainer >>= convertExpr env - pure $ TemplateKey keyType (key `ETmApp` EVar (mkVar "this")) maintainer -convertKey _ o = unhandled "Template key definition" o - convertTypeDef :: Env -> TyThing -> ConvertM [Definition] convertTypeDef env (ATyCon t) | GHC.moduleNameString (GHC.moduleName (nameModule (getName t))) == "DA.Internal.LF" @@ -589,9 +449,6 @@ convertCtors env (Ctors name tys cs) = do convertBind :: Env -> CoreBind -> ConvertM [Definition] convertBind env (NonRec name x) - | DFunId _ <- idDetails name - , TypeCon (QIsTpl "Template") [t] <- varType name - = withRange (convNameLoc name) $ liftA2 (++) (convertTemplate env x) (convertBind2 env (NonRec name x)) | DFunId _ <- idDetails name , TypeCon (Is tplInst) _ <- varType name , "Instance" `isSuffixOf` tplInst @@ -1429,6 +1286,3 @@ mkPure env monad dict t x = do `ETmApp` dict' `ETyApp` t `ETmApp` x - -pattern QIsTpl :: NamedThing a => String -> a -pattern QIsTpl x <- QIs "DA.Internal.Template" x