diff --git a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs index aad32ab6ca52..e34076bca9f9 100644 --- a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs +++ b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs @@ -12,6 +12,7 @@ module DA.Daml.Compiler.DataDependencies import DA.Pretty hiding (first) import Control.Applicative +import Control.Lens hiding ((<.>)) import Control.Monad import Control.Monad.State.Strict import Data.Bifunctor (first) @@ -53,6 +54,7 @@ import "ghc-lib-parser" TysWiredIn import qualified DA.Daml.LF.Ast as LF import qualified DA.Daml.LF.Ast.Type as LF import qualified DA.Daml.LF.Ast.Alpha as LF +import DA.Daml.LF.Ast.Util import qualified DA.Daml.LF.TypeChecker.Check as LF import qualified DA.Daml.LF.TypeChecker.Env as LF import qualified DA.Daml.LF.TypeChecker.Error as LF @@ -365,6 +367,7 @@ generateSrcFromLf env = noLoc mod , valueDecls , interfaceDecls , fixityDecls + , patsynDecls ] instDecls <- sequence instanceDecls pure $ decls <> catMaybes instDecls @@ -388,6 +391,20 @@ generateSrcFromLf env = noLoc mod qualNameToSynName :: LFC.QualName -> LF.TypeSynName qualNameToSynName (LFC.QualName (LF.Qualified {LF.qualObject})) = LF.TypeSynName $ T.split (=='.') $ T.pack $ occNameString qualObject + mkWrappedRdrNameQual + :: (Located RdrName -> IEWrappedName RdrName) + -> LFC.QualName + -> Gen (LIEWrappedName RdrName) + mkWrappedRdrNameQual f = fmap (noLoc . f . noLoc) . mkRdrNameQual + + mkRdrNameQual :: LFC.QualName -> Gen RdrName + mkRdrNameQual (LFC.QualName q) = do + ghcMod <- genModule env (LF.qualPackage q) (LF.qualModule q) + pure $ mkOrig ghcMod (LF.qualObject q) + + mkFieldLblRdrNameQual :: FieldLbl LFC.QualName -> Gen (Located (FieldLbl RdrName)) + mkFieldLblRdrNameQual = fmap noLoc . traverse mkRdrNameQual + allExports :: Gen [LIE GhcPs] allExports = sequence $ do LF.DefValue {dvalBinder=(name, ty)} <- NM.toList . LF.moduleValues $ envMod env @@ -401,31 +418,20 @@ generateSrcFromLf env = noLoc mod mkLIE = fmap (fmap noLoc) . \case LFC.ExportInfoVal name -> pure $ IEVar NoExt - <$> mkWrappedRdrName IEName name + <$> mkWrappedRdrNameQual IEName name + LFC.ExportInfoPattern name -> + pure $ IEVar NoExt + <$> mkWrappedRdrNameQual IEPattern name -- Classes that are duplicated in non-data-dependencies are replaced with re-exports of the other class -- (for compatibility with old stdlibs) -- As such, we do not want to export definitions that have already been re-exported/replaced LFC.ExportInfoTC name _ _ | qualNameToSynName name `MS.member` classReexportMap -> [] LFC.ExportInfoTC name pieces fields -> pure $ IEThingWith NoExt - <$> mkWrappedRdrName IEType name + <$> mkWrappedRdrNameQual IEType name <*> pure NoIEWildcard - <*> mapM (mkWrappedRdrName IEName) pieces - <*> mapM mkFieldLblRdrName fields - - mkWrappedRdrName :: - (Located RdrName -> IEWrappedName RdrName) - -> LFC.QualName - -> Gen (LIEWrappedName RdrName) - mkWrappedRdrName f = fmap (noLoc . f . noLoc) . mkRdrName - - mkRdrName :: LFC.QualName -> Gen RdrName - mkRdrName (LFC.QualName q) = do - ghcMod <- genModule env (LF.qualPackage q) (LF.qualModule q) - pure $ mkOrig ghcMod (LF.qualObject q) - - mkFieldLblRdrName :: FieldLbl LFC.QualName -> Gen (Located (FieldLbl RdrName)) - mkFieldLblRdrName = fmap noLoc . traverse mkRdrName + <*> mapM (mkWrappedRdrNameQual IEName) pieces + <*> mapM mkFieldLblRdrNameQual fields -- We only reexport self (i.e. module Self) when not using explicit exports selfReexport :: [Gen (LIE GhcPs)] @@ -594,6 +600,71 @@ generateSrcFromLf env = noLoc mod let lvalD = noLoc . ValD noExt <$> mkStubBind env lname lfType [ lsigD, lvalD ] + -- TODO: + -- add record matching support <- some struct with the ordered list of record field names + -- add minimal tag support <- some struct representing the set of pragmas + + -- Converts + -- ...constraints => ...args -> returntype + -- to + -- (constraints, args, returntype) + getConstraintsAndTypeArgs :: LF.Type -> ([LF.Type], [LF.Type], LF.Type) + getConstraintsAndTypeArgs = \case + (arg LF.:-> t) + | isConstraint arg -> let (consts, args, ret) = getConstraintsAndTypeArgs t in (arg : consts, args, ret) + | otherwise -> let (consts, args, ret) = getConstraintsAndTypeArgs t in (consts, arg : args, ret) + t -> ([], [], t) + + -- Reads the type arguments, value arguments and match type of a pattern via its $mP type + -- See patsynDecls for more detail on $mP + extractPatSynTypeData :: LF.Type -> Maybe ([(LF.TypeVarName, LF.Kind)], [LF.Type], LF.Type) + extractPatSynTypeData (view _TForalls -> (tyargs, getConstraintsAndTypeArgs -> (_, matchtype : builder : _, _))) = + pure (drop 2 tyargs, snd3 $ getConstraintsAndTypeArgs builder, matchtype) + extractPatSynTypeData _ = Nothing + + -- Pattern implementations are replaced by the original def, as per any other stub + -- however pattern stubs need a valid pattern for the given types in the stubs, there is no "Undefined" type + -- We use view patterns and explicitly bidirectional patterns to avoid this problem + -- pattern P a b <...> <- (undefined -> (a, b, <...>)) where P a b <...> = undefined + -- This appeases the type checker + -- We identify pattern synonyms by searching for definitions of this form + -- $mP : forall (rep : *) (r : *) (<...tyargs> : *). -> (<...args> -> r) -> (Void# -> r) -> r + -- which represents the following pattern: + -- pattern P : forall <...tyargs> : <...args> -> + -- We determine if a pattern has a builder by existing of a $bP value + -- There may also be a $mfieldsP which gives field names for record synonyms + -- TODO: decode $completeMatch definitions into pragmas + patsynDecls :: [Gen (LHsDecl GhcPs)] + patsynDecls = do + LF.DefValue {dvalBinder=(LF.ExprValName (T.stripPrefix "$m" -> Just name), extractPatSynTypeData -> Just (tyargs, args, matchtype))} <- NM.toList $ LF.moduleValues $ envMod env + let mBuilder = NM.lookup (LF.ExprValName $ "$b" <> name) $ LF.moduleValues $ envMod env + mFieldNames = do + LF.DefValue {dvalBinder=(_, LFC.decodeFieldNames -> Just labels)} <- + NM.lookup (LF.ExprValName $ "$mfields" <> name) $ LF.moduleValues $ envMod env + pure $ traverse mkRdrNameQual labels + sigDef :: Gen (LHsDecl GhcPs) = do + t <- convType env reexportedClasses $ mkTForalls tyargs $ mkTFuns args matchtype + pure $ noLoc . SigD noExt . PatSynSig noExt [mkRdrName name] $ HsIB noExt $ noLoc t + patDef :: Gen (LHsDecl GhcPs) = do + errCall <- mkErrorCall env "patsyn bind" + let builderStub = mkMatchGroup FromSource [mkSimpleMatch (FunRhs (mkRdrName name) Prefix NoSrcStrict) [nlWildPat | _ <- args] errCall] + (argConType, argNames) <- + case mFieldNames of + Just getNames -> do + names <- fmap noLoc <$> getNames + pure (RecCon $ (\name -> RecordPatSynField name name) <$> names, names) + Nothing -> do + let argNames = (\c -> mkRdrName $ T.pack [c]) <$> take (length args) ['a'..] + pure (PrefixCon argNames, argNames) + pure $ noLoc . ValD noExt . PatSynBind noExt $ PSB + noExt + (mkRdrName name) + argConType + (ParPat noExt $ noLoc $ ViewPat noExt errCall (TuplePat noExt [VarPat noExt name | name <- argNames] Boxed)) + (if isJust mBuilder then ExplicitBidirectional builderStub else Unidirectional) + + [sigDef, patDef] + -- | Generate instance declarations from dictionary functions. instanceDecls :: [Gen (Maybe (LHsDecl GhcPs))] instanceDecls = do @@ -1224,6 +1295,7 @@ generateSrcPkgFromLf envConfig pkg = do , "{-# LANGUAGE AllowAmbiguousTypes #-}" , "{-# LANGUAGE MagicHash #-}" , "{-# LANGUAGE DatatypeContexts #-}" + , "{-# LANGUAGE PatternSynonyms #-}" , "{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-methods -Wno-deprecations -Wno-x-crypto -Wno-x-exceptions #-}" ] diff --git a/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs index b1cf2f2e0eb9..e8fdd7f05621 100644 --- a/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs +++ b/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs @@ -117,10 +117,12 @@ import Data.Tuple.Extra import Data.Ratio import "ghc-lib" GHC import "ghc-lib" GhcPlugins as GHC hiding ((<>), notNull) +import "ghc-lib-parser" ConLike (ConLike (..)) import "ghc-lib-parser" InstEnv (ClsInst(..)) import "ghc-lib-parser" Pair hiding (swap) import "ghc-lib-parser" PrelNames import "ghc-lib-parser" TysPrim +import "ghc-lib-parser" PatSyn import "ghc-lib-parser" TyCoRep import "ghc-lib-parser" Class (classHasFds, classMinimalDef, classOpItems) import qualified "ghc-lib-parser" Name @@ -229,6 +231,8 @@ data ModuleContents = ModuleContents , mcDepOrphanModules :: [GHC.Module] , mcExports :: [GHC.AvailInfo] , mcFixities :: [(OccName, GHC.Fixity)] + , mcPatternSynonymFieldNames :: MS.Map VariantConName [GHC.Name] + , mcCompleteMatches :: [LFCompleteMatch GHC.Name] } data ChoiceData = ChoiceData @@ -275,6 +279,11 @@ extractModuleContents env@Env{..} coreModule modIface details = do mcDepOrphanModules = getDepOrphanModules modIface mcExports = md_exports details mcFixities = mi_fixities modIface + mcPatternSynonymFieldNames = + MS.fromList $ do + AConLike (PatSynCon syn) <- mcTypeDefs + pure (VariantConName $ T.pack $ getOccString $ patSynName syn, flSelector <$> patSynFieldLabels syn) + mcCompleteMatches = completeMatchToLf <$> md_complete_sigs details ModuleContents {..} @@ -759,6 +768,7 @@ convertModuleContents env mc = do templates <- convertTemplateDefs env mc exceptions <- convertExceptionDefs env mc interfaces <- convertInterfaces env mc + patsynMetadata <- convertPatternSynonymMetadata env mc let fixities = convertFixities mc defs = types @@ -768,6 +778,7 @@ convertModuleContents env mc = do ++ interfaces ++ depOrphanModules ++ fixities + ++ patsynMetadata -- Exports need to know what is defined to know if it should export it exports <- convertExports env mc defs pure $ defs ++ exports @@ -953,6 +964,20 @@ convertFixities = zipWith mkFixityDef [0..] . mcFixities (fixityName i) (encodeFixityInfo fixityInfo) +-- Encodes pattern synonym record field names and complete pragmas to metadata stubs +convertPatternSynonymMetadata :: Env -> ModuleContents -> ConvertM [Definition] +convertPatternSynonymMetadata env mc = do + fieldDefs <- forM (MS.toList $ mcPatternSynonymFieldNames mc) $ \(name, unqualFieldNames) -> do + fieldNames <- traverse convertQualName unqualFieldNames + pure $ DValue $ mkMetadataStub (ExprValName $ "$mfields" <> unVariantConName name) $ encodeFieldNames fieldNames + matchDefs <- forM (zip [0..] (mcCompleteMatches mc)) $ \(i :: Int, unqualMatch) -> do + match <- traverse convertQualName unqualMatch + pure $ DValue $ mkMetadataStub (ExprValName $ "$completeMatch" <> T.pack (show i)) $ encodeLFCompleteMatch match + pure $ fieldDefs <> matchDefs + where + convertQualName :: GHC.Name -> ConvertM QualName + convertQualName = fmap QualName . convertQualified getOccName env + convertExports :: SdkVersioned => Env -> ModuleContents -> [Definition] -> ConvertM [Definition] convertExports env mc existingDefs = do let externalReExportInfos = filter (isReExportName . GHC.availName) (mcExports mc) @@ -965,7 +990,7 @@ convertExports env mc existingDefs = do if isPrimOrStdlib then pure reExportDefs else do - let externalExportInfos = filter (isExportName . GHC.availName) (mcExports mc) \\ externalReExportInfos + let externalExportInfos = filter isExportAvail (mcExports mc) \\ externalReExportInfos exportInfos <- mapM availInfoToExportInfo externalExportInfos let exportDefs = zipWith mkExportDef (exportName <$> [0..]) exportInfos pure $ explicitExportsDef : reExportDefs <> exportDefs @@ -991,14 +1016,21 @@ convertExports env mc existingDefs = do isLocallyUndefined name | nameIsLocalOrFrom thisModule name = not $ getOccText name `elem` localExportables isLocallyUndefined _ = False - isExportName :: Name -> Bool - isExportName name = not $ + isExportAvail :: GHC.AvailInfo -> Bool + isExportAvail avail@(GHC.availName -> name) = not $ isSystemName name || isWiredInName name - || isLocallyUndefined name + || (isLocallyUndefined name && not (availInfoIsPatternSynonym avail)) + + -- Value level (i.e. Avail, over AvailTC) data named (as per isDataOcc) definitions are always pattern synonyms + availInfoIsPatternSynonym :: GHC.AvailInfo -> Bool + availInfoIsPatternSynonym (GHC.Avail name) = isDataOcc (getOccName name) + availInfoIsPatternSynonym _ = False availInfoToExportInfo :: GHC.AvailInfo -> ConvertM ExportInfo availInfoToExportInfo = \case + avail | availInfoIsPatternSynonym avail -> ExportInfoPattern + <$> convertQualName (GHC.availName avail) GHC.Avail name -> ExportInfoVal <$> convertQualName name GHC.AvailTC name pieces fields -> ExportInfoTC diff --git a/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/MetadataEncoding.hs b/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/MetadataEncoding.hs index 241d40a4a02a..007aeb9d100b 100644 --- a/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/MetadataEncoding.hs +++ b/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/MetadataEncoding.hs @@ -44,6 +44,13 @@ module DA.Daml.LFConversion.MetadataEncoding -- * Type Synonyms , encodeTypeSynonym , decodeTypeSynonym + -- * Pattern Synonyms + , LFCompleteMatch (..) + , encodeFieldNames + , encodeLFCompleteMatch + , decodeFieldNames + , decodeLFCompleteMatch + , completeMatchToLf ) where import Safe (readMay) @@ -60,6 +67,7 @@ import qualified "ghc-lib-parser" BasicTypes as GHC import qualified "ghc-lib-parser" BooleanFormula as BF import qualified "ghc-lib-parser" Class as GHC import qualified "ghc-lib-parser" FieldLabel as GHC +import qualified "ghc-lib-parser" HscTypes as GHC import qualified "ghc-lib-parser" Name as GHC import qualified "ghc-lib-parser" SrcLoc as GHC import "ghc-lib-parser" FastString (FastString) @@ -264,6 +272,7 @@ newtype QualName = QualName (LF.Qualified GHC.OccName) -- | Identical to Avail.AvailInfo, but with QualName instead of GHC.Name. data ExportInfo = ExportInfoVal QualName + | ExportInfoPattern QualName | ExportInfoTC QualName [QualName] [FieldLbl QualName] deriving (Eq) @@ -271,6 +280,8 @@ encodeExportInfo :: ExportInfo -> LF.Type encodeExportInfo = \case ExportInfoVal qualName -> TEncodedCon "ExportInfoVal" (encodeExportInfoVal qualName) + ExportInfoPattern qualName -> + TEncodedCon "ExportInfoPattern" (encodeExportInfoVal qualName) ExportInfoTC qualName pieces fields -> TEncodedCon "ExportInfoTC" (encodeExportInfoTC qualName pieces fields) @@ -308,6 +319,24 @@ encodeExportInfoTC name pieces fields = encodeTypeList id , encodeTypeList (encodeFieldLbl encodeQualName) fields ] +encodeFieldNames :: [QualName] -> LF.Type +encodeFieldNames = encodeTypeList encodeQualName + +data LFCompleteMatch name = LFCompleteMatch + { matchers :: [name] + , subject :: name + } + deriving (Foldable, Functor, Traversable) + +completeMatchToLf :: GHC.CompleteMatch -> LFCompleteMatch GHC.Name +completeMatchToLf (GHC.CompleteMatch matchers subject) = LFCompleteMatch {..} + +encodeLFCompleteMatch :: LFCompleteMatch QualName -> LF.Type +encodeLFCompleteMatch LFCompleteMatch {..} = encodeTypeList id + [ encodeQualName subject + , encodeTypeList encodeQualName matchers + ] + encodeFieldLbl :: (a -> LF.Type) -> FieldLbl a -> LF.Type encodeFieldLbl encodeSelector field = encodeTypeList id [ encodeFastString (GHC.flLabel field) @@ -327,6 +356,8 @@ decodeExportInfo :: LF.Type -> Maybe ExportInfo decodeExportInfo = \case TEncodedCon "ExportInfoVal" t -> decodeExportInfoVal t + TEncodedCon "ExportInfoPattern" t -> + decodeExportInfoPattern t TEncodedCon "ExportInfoTC" t -> do decodeExportInfoTC t _ -> Nothing @@ -365,12 +396,18 @@ decodeFastString = \case TEncodedStr s -> Just (fsFromText s) _ -> Nothing -decodeExportInfoVal :: LF.Type -> Maybe ExportInfo -decodeExportInfoVal t = do +decodeExportInfoNamed :: (QualName -> ExportInfo) -> LF.Type -> Maybe ExportInfo +decodeExportInfoNamed f t = do [name] <- decodeTypeList Just t - ExportInfoVal + f <$> decodeQualName name +decodeExportInfoVal :: LF.Type -> Maybe ExportInfo +decodeExportInfoVal = decodeExportInfoNamed ExportInfoVal + +decodeExportInfoPattern :: LF.Type -> Maybe ExportInfo +decodeExportInfoPattern = decodeExportInfoNamed ExportInfoPattern + decodeExportInfoTC :: LF.Type -> Maybe ExportInfo decodeExportInfoTC t = do [name, pieces, fields] <- decodeTypeList Just t @@ -379,6 +416,16 @@ decodeExportInfoTC t = do <*> decodeTypeList decodeQualName pieces <*> decodeTypeList (decodeFieldLbl decodeQualName) fields +decodeFieldNames :: LF.Type -> Maybe [QualName] +decodeFieldNames = decodeTypeList decodeQualName + +decodeLFCompleteMatch :: LF.Type -> Maybe (LFCompleteMatch QualName) +decodeLFCompleteMatch t = do + [subject, matchers] <- decodeTypeList Just t + LFCompleteMatch + <$> decodeTypeList decodeQualName matchers + <*> decodeQualName subject + decodeFieldLbl :: (LF.Type -> Maybe a) -> LF.Type -> Maybe (FieldLbl a) decodeFieldLbl decodeSelector t = do [label, isOverloaded, selector] <- decodeTypeList Just t diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs index 5a3278c605db..5573a0b6f81b 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs @@ -655,6 +655,7 @@ buildLfPackageGraph = , LFC.QualName (LF.Qualified { LF.qualPackage }) <- [ case export of LFC.ExportInfoVal name -> name + LFC.ExportInfoPattern name -> name LFC.ExportInfoTC name _ _ -> name ] ]