Add support for pattern synonyms across data-deps

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> : *). <matchtype> -> (<...args> -> r) -> (Void# -> r) -> r
+    -- which represents the following pattern:
+    -- pattern P : forall <...tyargs> : <...args> -> <matchtype>
+    -- 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<N> 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 #-}"
         ]
 

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

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,13 +272,16 @@ 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)
 
 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

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
                   ]
               ]