haskell-names 0.2.1 → 0.3

raw patch · 18 files changed

+562/−193 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +26/−0
• haskell-names.cabal +4/−2
• src/Language/Haskell/Names/Annotated.hs +25/−0
• src/Language/Haskell/Names/Exports.hs +2/−2
• src/Language/Haskell/Names/GetBound.hs +140/−0
• src/Language/Haskell/Names/GlobalSymbolTable.hs +0/−2
• src/Language/Haskell/Names/Imports.hs +1/−1
• src/Language/Haskell/Names/Interfaces.hs +7/−3
• src/Language/Haskell/Names/ModuleSymbols.hs +119/−55
• src/Language/Haskell/Names/Open.hs +4/−0
• src/Language/Haskell/Names/Open/Base.hs +16/−6
• src/Language/Haskell/Names/Open/Instances.hs +31/−4
• src/Language/Haskell/Names/RecordWildcards.hs +136/−0
• src/Language/Haskell/Names/Recursive.hs +2/−4
• src/Language/Haskell/Names/ScopeUtils.hs +6/−4
• src/Language/Haskell/Names/SyntaxUtils.hs +5/−106
• src/Language/Haskell/Names/Types.hs +12/−1
• tests/run.hs +26/−3

@@ -1,6 +1,32 @@ Changes ======= +Version 0.3+-----------++This release brings support for record puns and wildcards.++### Interface file format changes++For field selectors, the new field `constructors` is added. It contains a list+of constructors that contain that field.++### API changes++* The `sv_constructors` field is added to `SymSelector`+* Add `Language.Haskell.Names.SyntaxUtils.stringToName`+* The class `GetBound` is moved to a new module,+  `Language.Haskell.Names.GetBound`. Its method, `getBound`, now has a new+  argument, the global symbol table+* `NameInfo` got two more constructors to annotate wildcards,+  `RecPatWildcard` and `RecExpWildcard`+* `Scope` now has a new field of type `WcNames`, which can be accessed+  through the `wcNames` lens. This is needed for record wildcards+  resolution.+* Add field selectors to `GName`+* Don't export `GName` and `OrigName` from `GlobalSymbolTable`++ Version 0.2.1 ------------- 

@@ -1,5 +1,5 @@ Name:                   haskell-names-Version:                0.2.1+Version:                0.3 License:                BSD3 Author:                 Roman Cheplyaka, Lennart Augustsson Maintainer:             Roman Cheplyaka <roma@ro-che.info>@@ -235,7 +235,7 @@ source-repository this   type:     git   location: git://github.com/haskell-suite/haskell-names.git-  tag:      v0.2.1+  tag:      v0.3  Library   Default-Language: Haskell2010@@ -269,6 +269,7 @@                         Language.Haskell.Names.Exports                         Language.Haskell.Names.ModuleSymbols                         Language.Haskell.Names.SyntaxUtils+                        Language.Haskell.Names.GetBound    Other-modules:                         Language.Haskell.Names.Open.Base@@ -276,6 +277,7 @@                         Language.Haskell.Names.Open.Derived                         Language.Haskell.Names.Recursive                         Language.Haskell.Names.Types+                        Language.Haskell.Names.RecordWildcards                         Language.Haskell.Names.ScopeUtils                         Paths_haskell_names 

@@ -11,6 +11,7 @@   ) where  import Language.Haskell.Names.Types+import Language.Haskell.Names.RecordWildcards import Language.Haskell.Names.Open.Base import Language.Haskell.Names.Open.Instances () import qualified Language.Haskell.Names.GlobalSymbolTable as Global@@ -49,8 +50,32 @@     | BindingT <- getL nameCtx sc     , Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq       = Scoped TypeBinder (sLoc . ann $ a) <$ a+    | Just (Eq :: FieldUpdate (Scoped l) :~: a) <- dynamicEq+      = case a of+          FieldPun l n -> FieldPun l (lookupUnqualValue n sc <$ n)+          FieldWildcard l ->+            let+              namesUnres = sc ^. wcNames+              resolve n =+                let Scoped info _ = lookupValue (sLoc l <$ UnQual () n) sc+                in info+              namesRes =+                map+                  (\f -> (wcFieldOrigName f, resolve $ wcFieldName f))+                  namesUnres+            in FieldWildcard $ Scoped (RecExpWildcard namesRes) (sLoc l)+          _ -> rmap go sc a+    | Just (Eq :: PatField (Scoped l) :~: a) <- dynamicEq+    , PFieldWildcard l <- a+      = PFieldWildcard $+          Scoped+            (RecPatWildcard $ map wcFieldOrigName $ sc ^. wcNames)+            (sLoc l)     | otherwise       = rmap go sc a++lookupUnqualValue :: Name (Scoped l) -> Scope -> Scoped l+lookupUnqualValue n = lookupValue (UnQual (sLoc $ ann n) (sLoc <$> n))  lookupValue :: QName l -> Scope -> Scoped l lookupValue qn sc = Scoped nameInfo (ann qn)

@@ -24,7 +24,7 @@ processExports tbl m =   case getExportSpecList m of     Nothing ->-      return (Nothing, moduleSymbols m)+      return (Nothing, moduleSymbols tbl m)     Just exp ->       liftM (first Just) $ resolveExportSpecList tbl exp @@ -106,7 +106,7 @@           -> Set.Set i         filterByPrefix prefix m =           Set.unions-            [ i | (GName prefix' _, i) <- Map.toList m, prefix' == prefix ]+            [ i | (GName { gModule = prefix' }, i) <- Map.toList m, prefix' == prefix ]          filterEntities           :: Ord i

@@ -0,0 +1,140 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,+             FlexibleInstances, UndecidableInstances, NamedFieldPuns,+             ScopedTypeVariables #-}+module Language.Haskell.Names.GetBound+  ( GetBound(..)+  ) where++import Data.Generics.Uniplate.Data+import Data.Data+import Control.Applicative++import Language.Haskell.Exts.Annotated+import Language.Haskell.Names.RecordWildcards+import qualified Language.Haskell.Names.GlobalSymbolTable as Global++-- | Get bound value identifiers.+class GetBound a l | a -> l where+    -- | For record wildcards we need to know which fields the given+    -- constructor has. So we pass the global table for that.+    getBound :: Global.Table -> a -> [Name l]++-- XXX account for shadowing?+instance (GetBound a l) => GetBound [a] l where+    getBound ctx xs = concatMap (getBound ctx) xs++instance (GetBound a l) => GetBound (Maybe a) l where+    getBound ctx = maybe [] (getBound ctx)++instance (GetBound a l, GetBound b l) => GetBound (a, b) l where+    getBound ctx (a, b) = getBound ctx a ++ getBound ctx b++instance (Data l) => GetBound (Binds l) l where+    getBound ctx e = case e of+      BDecls _ ds -> getBound ctx ds+      IPBinds _ _ -> []  -- XXX doesn't bind regular identifiers++instance (Data l) => GetBound (Decl l) l where+    getBound ctx e = case e of+      TypeDecl{} -> []+      TypeFamDecl{} -> []+      DataDecl _ _ _ _ ds _ -> getBound ctx ds+      GDataDecl _ _ _ _ _ ds _ -> getBound ctx ds+      DataFamDecl{} -> []+      TypeInsDecl{} -> []+      DataInsDecl _ _ _ ds _ -> getBound ctx ds+      GDataInsDecl _ _ _ _ ds _ -> getBound ctx ds+      ClassDecl _ _ _ _ mds -> getBound ctx mds+      InstDecl{} -> []+      DerivDecl{} -> []+      InfixDecl{} -> []+      DefaultDecl{} -> []+      SpliceDecl{} -> []+      TypeSig{} -> []+      FunBind _ [] -> error "getBound: FunBind []"+      FunBind _ (Match _ n _ _ _ : _) -> [n]+      FunBind _ (InfixMatch _ _ n _ _ _ : _) -> [n]+      PatBind _ p _ _ _ -> getBound ctx p+      ForImp _ _ _ _ n _ -> [n]+      ForExp _ _ _ n _ -> [n]+      RulePragmaDecl{} -> []+      DeprPragmaDecl{} -> []+      WarnPragmaDecl{} -> []+      InlineSig{} -> []+      SpecSig{} -> []+      SpecInlineSig{} -> []+      InstSig{} -> []+      AnnPragma{} -> []+      InlineConlikeSig{} -> []++instance (Data l) => GetBound (QualConDecl l) l where+    getBound ctx (QualConDecl _ _ _ d) = getBound ctx d++instance (Data l) => GetBound (GadtDecl l) l where+    getBound _ctx (GadtDecl _ n _) = [n]++instance (Data l) => GetBound (ConDecl l) l where+    getBound ctx e = case e of+      ConDecl _ n _ -> [n]+      InfixConDecl _ _ n _ -> [n]+      RecDecl _ n fs -> n : getBound ctx fs++instance (Data l) => GetBound (FieldDecl l) l where+    getBound _ctx (FieldDecl _ ns _) = ns++instance (Data l) => GetBound (ClassDecl l) l where+    getBound _ctx e = case e of+      ClsDecl _ d -> getBoundSign d+      ClsDataFam{} -> []+      ClsTyFam{} -> []+      ClsTyDef{} -> []++instance (Data l) => GetBound (Match l) l where+    getBound _ctx e = case e of+      Match _ n _ _ _ -> [n]+      InfixMatch _ _ n _ _ _ -> [n]++instance (Data l) => GetBound (Stmt l) l where+  getBound ctx e =+    case e of+      Generator _ pat _ -> getBound ctx pat+      LetStmt _ bnds    -> getBound ctx bnds+      RecStmt _ stmts   -> getBound ctx stmts+      Qualifier {} -> []++instance (Data l) => GetBound (QualStmt l) l where+  getBound ctx e =+    case e of+      QualStmt _ stmt -> getBound ctx stmt+      _ -> []++instance (Data l) => GetBound (Pat l) l where+  getBound gt p =+    [ n | p' <- universe $ transform dropExp p, n <- varp p' ]++    where++      varp (PVar _ n) = [n]+      varp (PAsPat _ n _) = [n]+      varp (PNPlusK _ n _) = [n]+      varp (PRec _ con fs) =+        [ n+        | -- (lazily) compute elided fields for the case when 'f' below is a wildcard+          let elidedFields = map wcFieldName $ patWcNames gt con fs+        , f <- fs+        , n <- getRecVars elidedFields f+        ]+      varp _ = []++      -- must remove nested Exp so universe doesn't descend into them+      dropExp (PViewPat _ _ x) = x+      dropExp x = x++      getRecVars :: [Name ()] -> PatField l -> [Name l]+      getRecVars _ PFieldPat {} = [] -- this is already found by the generic algorithm+      getRecVars _ (PFieldPun _ n) = [n]+      getRecVars elidedFields (PFieldWildcard l) = map (l <$) elidedFields++getBoundSign :: Decl l -> [Name l]+getBoundSign (TypeSig _ ns _) = ns+getBoundSign _ = []

@@ -2,8 +2,6 @@ -- | This module is designed to be imported qualified. module Language.Haskell.Names.GlobalSymbolTable   ( Table-  , GName-  , OrigName   , empty   , Result(..)   , lookupValue

@@ -247,7 +247,7 @@           cns'   where     (~~) :: OrigName -> Name l -> Bool-    OrigName _ (GName _ n) ~~ n' = n == nameToString n'+    OrigName { origGName = GName { gName = n } } ~~ n' = n == nameToString n'      isConstructor :: SymValueInfo n -> Bool     isConstructor SymConstructor {} = True

@@ -81,8 +81,9 @@         SymValue {} -> []         SymMethod { sv_className = cls } ->           [("class", toJSON cls)]-        SymSelector { sv_typeName = ty } ->-          [("type", toJSON ty)]+        SymSelector { sv_typeName = ty, sv_constructors = cons } ->+          [("type", toJSON ty)+          ,("constructors", toJSON cons)]         SymConstructor { sv_typeName = ty } ->           [("type", toJSON ty)] @@ -102,7 +103,10 @@     case entity :: String of       "value" -> return $ SymValue name fixity       "method" -> SymMethod name fixity <$> v .: "class"-      "selector" -> SymSelector name fixity <$> v .: "type"+      "selector" ->+        SymSelector name fixity+          <$> v .: "type"+          <*> v .: "constructors"       "constructor" -> SymConstructor name fixity <$> v .: "type"       _ -> mzero 

@@ -1,93 +1,157 @@+{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Names.ModuleSymbols   ( moduleSymbols   , moduleTable   )   where -import Data.List import Data.Maybe import Data.Either import Data.Lens.Common import Data.Monoid import Data.Data import qualified Data.Set as Set-import Language.Haskell.Exts.Annotated+import qualified Data.Map as Map+import Control.Monad +import Language.Haskell.Exts.Annotated import Language.Haskell.Names.Types import qualified Language.Haskell.Names.GlobalSymbolTable as Global import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.ScopeUtils+import Language.Haskell.Names.GetBound -moduleTable :: (Eq l, Data l) => Module l -> Global.Table-moduleTable m =-  computeSymbolTable False (getModuleName m) (moduleSymbols m)+-- | Compute module's global table. It contains both the imported entities+-- and the global entities defined in this module.+moduleTable+  :: (Eq l, Data l)+  => Global.Table -- ^ the import table for this module+  -> Module l+  -> Global.Table+moduleTable impTbl m =+  impTbl <>+  computeSymbolTable False (getModuleName m) (moduleSymbols impTbl m) -moduleSymbols :: (Eq l, Data l) => Module l -> Symbols-moduleSymbols m =+-- | Compute the symbols that are defined in the given module.+--+-- The import table is needed to resolve possible top-level record+-- wildcard bindings, such as+--+-- >A {..} = foo+moduleSymbols+  :: (Eq l, Data l)+  => Global.Table -- ^ the import table for this module+  -> Module l+  -> Symbols+moduleSymbols impTbl m =   let (vs,ts) =         partitionEithers $           concatMap-            (getTopDeclSymbols $ getModuleName m)+            (getTopDeclSymbols impTbl $ getModuleName m)             (getModuleDecls m)   in     setL valSyms (Set.fromList vs) $     setL tySyms  (Set.fromList ts) mempty +type TypeName = GName+type ConName = Name ()+type SelectorName = Name ()+type Constructors = [(ConName, [SelectorName])]+ -- Extract names that get bound by a top level declaration. getTopDeclSymbols-  :: (Eq l, Data l)-  => ModuleName l+  :: forall l . (Eq l, Data l)+  => Global.Table -- ^ the import table for this module+  -> ModuleName l   -> Decl l   -> [Either (SymValueInfo OrigName) (SymTypeInfo OrigName)]-getTopDeclSymbols mdl d =+getTopDeclSymbols impTbl mdl d =   map (either (Left . fmap toOrig) (Right . fmap toOrig)) $   case d of     TypeDecl _ dh _ ->-        let tn = hname dh-        in  [ Right (SymType        { st_origName = qname tn, st_fixity = Nothing })]+      let tn = hname dh+      in  [ Right (SymType        { st_origName = tn, st_fixity = Nothing })]+     TypeFamDecl _ dh _ ->-        let tn = hname dh-        in  [ Right (SymTypeFam     { st_origName = qname tn, st_fixity = Nothing })]-    DataDecl _ dataOrNew _ dh _ _ ->-        let dn = hname dh-            dq = qname dn-            (cs, fs) = partition isCon $ getBound d-            as = cs ++ nub fs  -- Ignore multiple selectors for now-            dataOrNewCon = case dataOrNew of DataType {} -> SymData; NewType {} -> SymNewType-        in    Right (dataOrNewCon dq Nothing) :-            [ if isCon cn then-              Left  (SymConstructor { sv_origName = qname cn, sv_fixity = Nothing, sv_typeName = dq }) else-              Left  (SymSelector    { sv_origName = qname cn, sv_fixity = Nothing, sv_typeName = dq })-            | cn <- as ]-    GDataDecl _ dataOrNew _ dh _ _ _ ->-        let dn = hname dh-            cq = qname dn-            (cs, fs) = partition isCon $ getBound d-            as = cs ++ nub fs  -- Ignore multiple selectors for now-            dataOrNewCon = case dataOrNew of DataType {} -> SymData; NewType {} -> SymNewType-        in    Right (dataOrNewCon cq Nothing) :-            [ if isCon cn then-              Left  (SymConstructor { sv_origName = qname cn, sv_fixity = Nothing, sv_typeName = cq }) else-              Left  (SymSelector    { sv_origName = qname cn, sv_fixity = Nothing, sv_typeName = cq })-            | cn <- as ]-    ClassDecl _ _ _ _ mds ->-        let ms = getBound d-            cn = getDeclHeadName d-            cq = qname cn-            cdecls = fromMaybe [] mds-        in    Right (SymClass       { st_origName = cq,       st_fixity = Nothing }) :-            [ Right (SymTypeFam     { st_origName = qname dn, st_fixity = Nothing }) | ClsTyFam   _   dh _ <- cdecls, let dn = hname dh ] ++-            [ Right (SymDataFam     { st_origName = qname tn, st_fixity = Nothing }) | ClsDataFam _ _ dh _ <- cdecls, let tn = hname dh ] ++-            [ Left  (SymMethod      { sv_origName = qname mn, sv_fixity = Nothing, sv_className = cq }) | mn <- ms ]+      let tn = hname dh+      in  [ Right (SymTypeFam     { st_origName = tn, st_fixity = Nothing })]++    DataDecl _ dataOrNew _ dh qualConDecls _ ->+      let+        cons :: Constructors+        cons = do -- list monad+          QualConDecl _ _ _ conDecl <- qualConDecls+          case conDecl of+            ConDecl _ n _ -> return (void n, [])+            InfixConDecl _ _ n _ -> return (void n, [])+            RecDecl _ n fields ->+              return (void n , [void f | FieldDecl _ fNames _ <- fields, f <- fNames])++        dq = hname dh++        infos = constructorsToInfos dq cons++      in+        Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos++    GDataDecl _ dataOrNew _ dh _ gadtDecls _ ->+      -- As of 1.14.0, HSE doesn't support GADT records.+      -- When it does, this code should be rewritten similarly to the+      -- DataDecl case.+      -- (Also keep in mind that GHC doesn't create selectors for fields+      -- with existential type variables.)+      let+        dq = hname dh+      in+          Right (dataOrNewCon dataOrNew dq Nothing) :+        [ Left (SymConstructor { sv_origName = qname cn, sv_fixity = Nothing, sv_typeName = dq })+        | GadtDecl _ cn _ <- gadtDecls+        ]++    ClassDecl _ _ dh _ mds ->+      let+        ms = getBound impTbl d+        cq = hname dh+        cdecls = fromMaybe [] mds+      in+          Right (SymClass   { st_origName = cq,       st_fixity = Nothing }) :+        [ Right (SymTypeFam { st_origName = hname dh, st_fixity = Nothing }) | ClsTyFam   _   dh _ <- cdecls ] +++        [ Right (SymDataFam { st_origName = hname dh, st_fixity = Nothing }) | ClsDataFam _ _ dh _ <- cdecls ] +++        [ Left  (SymMethod  { sv_origName = qname mn, sv_fixity = Nothing, sv_className = cq }) | mn <- ms ]+     FunBind _ ms ->-        let vn : _ = getBound ms-        in  [ Left  (SymValue       { sv_origName = qname vn, sv_fixity = Nothing }) ]+      let vn : _ = getBound impTbl ms+      in  [ Left  (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) ]+     PatBind _ p _ _ _ ->-            [ Left  (SymValue       { sv_origName = qname vn, sv_fixity = Nothing }) | vn <- getBound p ]+      [ Left  (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) | vn <- getBound impTbl p ]+     ForImp _ _ _ _ fn _ ->-            [ Left  (SymValue       { sv_origName = qname fn, sv_fixity = Nothing }) ]-    _ ->    []-  where ModuleName _ smdl = mdl-        qname = GName smdl . nameToString-        hname = fst . splitDeclHead-        toOrig = OrigName Nothing+      [ Left  (SymValue { sv_origName = qname fn, sv_fixity = Nothing }) ]++    _ -> []+  where+    ModuleName _ smdl = mdl+    qname = GName smdl . nameToString+    hname = qname . fst . splitDeclHead+    toOrig = OrigName Nothing+    dataOrNewCon dataOrNew = case dataOrNew of DataType {} -> SymData; NewType {} -> SymNewType++    constructorsToInfos :: TypeName -> Constructors -> [SymValueInfo GName]+    constructorsToInfos ty cons = conInfos ++ selInfos+      where+        conInfos =+          [ SymConstructor { sv_origName = qname con, sv_fixity = Nothing, sv_typeName = ty }+          | (con, _) <- cons+          ]++        selectorsMap :: Map.Map SelectorName [ConName]+        selectorsMap =+          Map.unionsWith (++) . flip map cons $ \(c, fs) ->+            Map.unionsWith (++) . flip map fs $ \f ->+              Map.singleton f [c]++        selInfos =+          [ (SymSelector { sv_origName = qname f, sv_fixity = Nothing, sv_typeName = ty, sv_constructors = map qname fCons })+          | (f, fCons) <- Map.toList selectorsMap+          ]

@@ -9,9 +9,13 @@   , gTable   , lTable   , nameCtx+  , WcNames+  , WcField(..)+  , wcNames   )   where  import Language.Haskell.Names.Open.Base import Language.Haskell.Names.Open.Instances () import Language.Haskell.Names.Open.Derived ()+import Language.Haskell.Names.RecordWildcards

@@ -4,7 +4,8 @@  import qualified Language.Haskell.Names.GlobalSymbolTable as Global import qualified Language.Haskell.Names.LocalSymbolTable as Local-import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.GetBound+import Language.Haskell.Names.RecordWildcards import Language.Haskell.Exts.Annotated import Control.Applicative import Control.Monad.Identity@@ -26,12 +27,13 @@   { _gTable :: Global.Table   , _lTable :: Local.Table   , _nameCtx :: NameContext+  , _wcNames :: WcNames   }  makeLens ''Scope  initialScope :: Global.Table -> Scope-initialScope tbl = Scope tbl Local.empty Other+initialScope tbl = Scope tbl Local.empty Other []  newtype Alg w = Alg   { runAlg :: forall d . Resolvable d => d -> Scope -> w d }@@ -69,12 +71,20 @@   in runIdentity . flip rtraverse sc  intro :: (SrcInfo l, GetBound a l) => a -> Scope -> Scope-intro node =-  modL lTable $-    \tbl -> foldl' (flip Local.addValue) tbl $ getBound node+intro node sc =+  modL lTable+    (\tbl -> foldl' (flip Local.addValue) tbl $+      getBound (sc ^. gTable) node)+    sc  setNameCtx :: NameContext -> Scope -> Scope-setNameCtx ctx = setL nameCtx ctx+setNameCtx = setL nameCtx++setWcNames :: WcNames -> Scope -> Scope+setWcNames = setL wcNames++getWcNames :: Scope -> WcNames+getWcNames = getL wcNames  binderV :: Scope -> Scope binderV = setNameCtx BindingV

@@ -12,11 +12,13 @@ import Language.Haskell.Names.Types import Language.Haskell.Names.Open.Base import Language.Haskell.Names.Open.Derived ()-import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.GetBound+import Language.Haskell.Names.RecordWildcards import Language.Haskell.Exts.Annotated import qualified Data.Data as D import Control.Applicative import Data.Typeable+import Data.Lens.Common  c :: Applicative w => c -> w c c = pure@@ -133,10 +135,14 @@           <| exprV sc -: qn           <| sc       -: pat       PRec l qn pfs ->+        let+          scWc =+            setWcNames (patWcNames (sc ^. gTable) qn pfs) sc+        in         c PRec           <| sc       -: l           <| exprV sc -: qn-          <| sc       -: pfs+          <| scWc     -: pfs       PAsPat l n pat ->         c PAsPat           <| sc         -: l@@ -157,8 +163,13 @@           <| sc       -: l           <| exprV sc -: qn           <| sc       -: pat-      PFieldPun {} -> error "haskell-names: field puns are not supported"-      PFieldWildcard {} -> error "haskell-names: record wildcards are not supported"+      PFieldPun l n ->+        c PFieldPun+          <| sc -: l+          <| binderV sc -: n+      -- In future we might want to annotate PFieldWildcard with the names+      -- it introduces.+      PFieldWildcard {} -> defaultRtraverse e sc  -- | Chain a sequence of nodes where every node may introduce some -- variables into scope for the subsequent nodes. Examples: patterns (see@@ -254,6 +265,22 @@           <| sc -: l           <| sc -: pat           <| scWithPat -: e++      RecConstr l qn fields ->+        let+          scWc =+            setWcNames+              (expWcNames+                (sc ^. gTable)+                (sc ^. lTable)+                qn+                fields)+              sc+        in+        c RecConstr+          <| sc   -: l+          <| sc   -: qn+          <| scWc -: fields        _ -> defaultRtraverse e sc 

@@ -0,0 +1,136 @@+-- Wildcards are tricky, they deserve a module of their own+{-# LANGUAGE NamedFieldPuns, TupleSections #-}+module Language.Haskell.Names.RecordWildcards where++import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe+import Control.Monad++import Language.Haskell.Exts.Annotated+import Language.Haskell.Names.Types+import Language.Haskell.Names.SyntaxUtils+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable as Local++-- | Information about the names being introduced by a record wildcard+--+-- During resolving traversal, we always (lazily) construct this list when+-- we process PRec or RecConstr, even if it doesn't contain a wildcard.+--+-- Then, if the pattern or construction actually contains a wildcard, we use the computed value.+type WcNames = [WcField]++-- | Information about a field in the wildcard+data WcField = WcField+  { wcFieldName :: Name ()+    -- ^ the field's simple name+  , wcFieldOrigName :: OrigName+    -- ^ the field's original name+  , wcExistsGlobalValue :: Bool+    -- ^ whether there is a global value in scope with the same name as+    -- the field but different from the field selector+  }++getElidedFields+  :: Global.Table+  -> QName l+  -> [Name l] -- mentioned field names+  -> WcNames+getElidedFields gt con fields =+  let+    givenFieldNames :: Map.Map (Name ()) ()+    givenFieldNames =+      Map.fromList . map ((, ()) . void) $ fields++    -- FIXME must report error when the constructor cannot be+    -- resolved+    (mbConOrigName, mbTypeOrigName) =+      case Global.lookupValue con gt of+        Global.Result info@SymConstructor{} ->+          (Just $ sv_origName info, Just $ sv_typeName info)+        _ -> (Nothing, Nothing)++    allValueInfos :: Set.Set (SymValueInfo OrigName)+    allValueInfos = Set.unions $ Map.elems $ Global.values gt++    ourFieldInfos :: Set.Set (SymValueInfo OrigName)+    ourFieldInfos =+      case mbConOrigName of+        Nothing -> Set.empty+        Just conOrigName ->+          flip Set.filter allValueInfos $ \v ->+            case v of+              SymSelector { sv_constructors }+                | conOrigName `elem` sv_constructors -> True+              _ -> False++    existsGlobalValue :: Name () -> Bool+    existsGlobalValue name =+      case Global.lookupValue (UnQual () name) gt of+        Global.Result info+          | Just typeOrigName <- mbTypeOrigName+          , SymSelector {} <- info+          , sv_typeName info == typeOrigName+            -> False -- this is the field selector+          | otherwise -> True -- exists, but not this field's selector+        _ -> False -- doesn't exist or ambiguous++    ourFieldNames :: Map.Map (Name ()) WcField+    ourFieldNames =+      Map.fromList $+      map+        (+          (\orig ->+            let name = stringToName . gName . origGName $ orig in+            (name, ) $+              WcField+              { wcFieldName = name+              , wcFieldOrigName = orig+              , wcExistsGlobalValue = existsGlobalValue name+              }+          ) . sv_origName+        )+        $ Set.toList ourFieldInfos++  in Map.elems $ ourFieldNames `Map.difference` givenFieldNames++nameOfPatField :: PatField l -> Maybe (Name l)+nameOfPatField pf =+  case pf of+    PFieldPat _ qn _ -> Just $ qNameToName qn+    PFieldPun _ n -> Just n+    PFieldWildcard {} -> Nothing++nameOfUpdField :: FieldUpdate l -> Maybe (Name l)+nameOfUpdField pf =+  case pf of+    FieldUpdate _ qn _ -> Just $ qNameToName qn+    FieldPun _ n -> Just n+    FieldWildcard {} -> Nothing++patWcNames+  :: Global.Table+  -> QName l+  -> [PatField l]+  -> WcNames+patWcNames gt con patfs =+  getElidedFields gt con $+  mapMaybe nameOfPatField patfs++expWcNames+  :: Global.Table+  -> Local.Table+  -> QName l+  -> [FieldUpdate l]+  -> WcNames+expWcNames gt lt con patfs =+  filter isInScope $+  getElidedFields gt con $+  mapMaybe nameOfUpdField patfs+  where+    isInScope field+      | Right {} <- Local.lookupValue qn lt = True+      | otherwise = wcExistsGlobalValue field+      where+        qn = UnQual () $ wcFieldName field

@@ -51,8 +51,7 @@ annotateModule lang exts mod@(Module lm mh os is ds) = do   let extSet = moduleExtensions lang exts mod   (imp, impTbl) <- processImports extSet is-  let ownTbl = moduleTable mod-      tbl = impTbl <> ownTbl+  let tbl = moduleTable impTbl mod   (exp, _syms) <- processExports tbl mod    let@@ -86,8 +85,7 @@     forM_ (zip syms mods) $ \(s,(m, _)) -> insertInCache (getModuleName m) s     (syms', errors) <- liftM unzip $ forM mods $ \(m, extSet) -> do       (imp, impTbl) <- processImports extSet $ getImports m-      let ownTbl = moduleTable m-          tbl = impTbl <> ownTbl+      let tbl = moduleTable impTbl m       (exp, syms) <- processExports tbl m       return (syms, foldMap getErrors imp <> foldMap getErrors exp)     if syms' == syms

@@ -39,6 +39,10 @@  computeSymbolTable   :: Bool+    -- ^ If 'True' (\"qualified\"), then only the qualified names are+    -- inserted.+    --+    -- If 'False', then both qualified and unqualified names are insterted.   -> ModuleName l   -> Symbols   -> Global.Table@@ -54,9 +58,7 @@     unqualified = renameSyms ""     renameSyms mod = (map (rename mod) vs, map (rename mod) ts)     rename :: HasOrigName i => ModuleNameS -> i OrigName -> (GName, i OrigName)-    rename m v =-      let OrigName _pkg (GName _ n) = origName v-      in (GName m n, v)+    rename m v = ((origGName . origName $ v) { gModule = m }, v)  resolveCName   :: Symbols@@ -69,7 +71,7 @@     vs =       [ info       | info <- Set.toList $ syms^.valSyms-      , let GName _ name = origGName $ sv_origName info+      , let name = gName . origGName $ sv_origName info       , nameToString (unCName cn) == name       , Just p <- return $ sv_parent info       , p == parent

@@ -1,4 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} module Language.Haskell.Names.SyntaxUtils   ( dropAnn   , setAnn@@ -9,10 +8,10 @@   , getDeclHeadName   , getModuleDecls   , isTypeDecl-  , GetBound(..)   , opName   , isCon   , nameToString+  , stringToName   , specialConToString   , qNameToName   , unCName@@ -23,10 +22,8 @@   ) where import Prelude hiding (concatMap) import Data.Char-import Data.Data import Data.Maybe import Data.Either-import Data.Generics.Uniplate.Data import Data.Foldable import qualified Data.Set as Set import Language.Haskell.Exts.Annotated@@ -94,108 +91,6 @@  ---------------------------------------------------- --- Get bound value identifiers.-class GetBound a l | a -> l where-    getBound :: a -> [Name l]---- XXX account for shadowing?-instance (GetBound a l) => GetBound [a] l where-    getBound xs = concatMap getBound xs--instance (GetBound a l) => GetBound (Maybe a) l where-    getBound Nothing = []-    getBound (Just x) = getBound x--instance (GetBound a l, GetBound b l) => GetBound (a, b) l where-    getBound (a, b) = getBound a ++ getBound b--instance (Data l) => GetBound (Binds l) l where-    getBound (BDecls _ ds) = getBound ds-    getBound (IPBinds _ _) = []  -- XXX doesn't bind regular identifiers--instance (Data l) => GetBound (Decl l) l where-    getBound (TypeDecl{}) = []-    getBound (TypeFamDecl{}) = []-    getBound (DataDecl _ _ _ _ ds _) = getBound ds-    getBound (GDataDecl _ _ _ _ _ ds _) = getBound ds-    getBound (DataFamDecl{}) = []-    getBound (TypeInsDecl{}) = []-    getBound (DataInsDecl _ _ _ ds _) = getBound ds-    getBound (GDataInsDecl _ _ _ _ ds _) = getBound ds-    getBound (ClassDecl _ _ _ _ mds) = getBound mds-    getBound (InstDecl{}) = []-    getBound (DerivDecl{}) = []-    getBound (InfixDecl{}) = []-    getBound (DefaultDecl{}) = []-    getBound (SpliceDecl{}) = []-    getBound (TypeSig{}) = []-    getBound (FunBind _ []) = error "getBound: FunBind []"-    getBound (FunBind _ (Match _ n _ _ _ : _)) = [n]-    getBound (FunBind _ (InfixMatch _ _ n _ _ _ : _)) = [n]-    getBound (PatBind _ p _ _ _) = getBound p-    getBound (ForImp _ _ _ _ n _) = [n]-    getBound (ForExp _ _ _ n _) = [n]-    getBound (RulePragmaDecl{}) = []-    getBound (DeprPragmaDecl{}) = []-    getBound (WarnPragmaDecl{}) = []-    getBound (InlineSig{}) = []-    getBound (SpecSig{}) = []-    getBound (SpecInlineSig{}) = []-    getBound (InstSig{}) = []-    getBound (AnnPragma{}) = []-    getBound (InlineConlikeSig{}) = []--instance (Data l) => GetBound (QualConDecl l) l where-    getBound (QualConDecl _ _ _ d) = getBound d--instance (Data l) => GetBound (GadtDecl l) l where-    getBound (GadtDecl _ n _) = [n]--instance (Data l) => GetBound (ConDecl l) l where-    getBound (ConDecl _ n _) = [n]-    getBound (InfixConDecl _ _ n _) = [n]-    getBound (RecDecl _ n fs) = n : getBound fs--instance (Data l) => GetBound (FieldDecl l) l where-    getBound (FieldDecl _ ns _) = ns--instance (Data l) => GetBound (ClassDecl l) l where-    getBound (ClsDecl _ d) = getBoundSign d-    getBound (ClsDataFam{}) = []-    getBound (ClsTyFam{}) = []-    getBound (ClsTyDef{}) = []--instance (Data l) => GetBound (Match l) l where-    getBound (Match _ n _ _ _) = [n]-    getBound (InfixMatch _ _ n _ _ _) = [n]--instance (Data l) => GetBound (Stmt l) l where-  getBound e =-    case e of-      Generator _ pat _ -> getBound pat-      LetStmt _ bnds    -> getBound bnds-      RecStmt _ stmts   -> getBound stmts-      Qualifier {} -> []--instance (Data l) => GetBound (QualStmt l) l where-  getBound e =-    case e of-      QualStmt _ stmt -> getBound stmt-      _ -> []--getBoundSign :: Decl l -> [Name l]-getBoundSign (TypeSig _ ns _) = ns-getBoundSign _ = []--instance (Data l) => GetBound (Pat l) l where-    getBound p = [ n | p' <- universe $ transform dropExp p, n <- varp p' ]-        where varp (PVar _ n) = [n]-              varp (PAsPat _ n _) = [n]-              varp (PNPlusK _ n _) = [n]-              varp _ = []-              dropExp (PViewPat _ _ x) = x  -- must remove nested Exp so universe doesn't descend into them-              dropExp x = x- isTypeDecl :: Decl l -> Bool isTypeDecl (TypeDecl _ _ _) = True isTypeDecl (TypeFamDecl _ _ _) = True@@ -216,6 +111,10 @@ nameToString :: Name l -> String nameToString (Ident _ s) = s nameToString (Symbol _ s) = s++stringToName :: String -> Name ()+stringToName s@(c:_) | isSymbol c = Symbol () s+stringToName s = Ident () s  specialConToString :: SpecialCon l -> String specialConToString (UnitCon _)            = "()"

@@ -40,6 +40,7 @@       { sv_origName :: name       , sv_fixity :: Maybe SymFixity       , sv_typeName :: name+      , sv_constructors :: [name]       }       -- ^ record field selector     | SymConstructor@@ -122,7 +123,10 @@  -- | Possibly qualified name. If the name is not qualified, -- 'ModuleNameS' is the empty string.-data GName = GName ModuleNameS NameS+data GName = GName+  { gModule :: ModuleNameS+  , gName :: NameS+  }   deriving (Eq, Ord, Show, Data, Typeable)  -- | Display a 'GName'@@ -173,6 +177,13 @@       -- ^ part of an @import@ declaration     | Export      Symbols       -- ^ @export@ declaration, and the symbols it exports+    | RecPatWildcard [OrigName]+      -- ^ wildcard in a record pattern. The list contains resolved names+      -- of the fields that are brought in scope by this pattern.+    | RecExpWildcard [(OrigName, NameInfo l)]+      -- ^ wildcard in a record construction expression. The list contains+      -- resolved names of the fields and information about values+      -- assigned to those fields.     | None       -- ^ no annotation     | ScopeError  (Error l)

@@ -10,6 +10,7 @@ import System.FilePath.Find import System.Exit import Data.Monoid+import Data.List hiding (find) import qualified Data.Map as Map import qualified Data.Set as Set import Control.Monad.Identity@@ -41,6 +42,8 @@  main = defaultMain . testGroup "Tests" =<< tests +goldenTest name = goldenVsFileDiff name (\ref new -> ["diff", "-u", ref, new])+ -- All tests are created in the same ModuleT session. This means that -- export tests are available for import in subsequent tests (because of -- the getIfaces call). However, import tests are not registered in the@@ -67,7 +70,7 @@ ----------------------------------------------------- -- {{{ exportTest file iface =-  goldenVsFile file golden out run+  goldenTest file golden out run   where     golden = file <.> "golden"     out = file <.> "out"@@ -95,7 +98,7 @@ -- {{{ importTest :: FilePath -> Global.Table -> TestTree importTest file tbl =-  goldenVsFile file golden out run+  goldenTest file golden out run   where     golden = file <.> "golden"     out = file <.> "out"@@ -132,6 +135,14 @@ instance TestAnn (Name (Scoped SrcSpan)) where   getAnn n = Just (nameToString n, ann n) +instance TestAnn (PatField (Scoped SrcSpan)) where+  getAnn (PFieldWildcard l) = Just ("..", l)+  getAnn _ = Nothing++instance TestAnn (FieldUpdate (Scoped SrcSpan)) where+  getAnn (FieldWildcard l) = Just ("..", l)+  getAnn _ = Nothing+ instance GTraversable (Rec TestAnn) (Scoped SrcSpan) where   gtraverse _ x = pure x @@ -151,7 +162,7 @@   in go  -- Actual tests-annotationTest file annotatedMod = goldenVsFile file golden out run+annotationTest file annotatedMod = goldenTest file golden out run   where     golden = file <.> "golden"     out = file <.> "out"@@ -208,6 +219,18 @@     (formatOrigin info) formatInfo ValueBinder = "a value bound here" formatInfo TypeBinder = "a type or class defined here"+formatInfo (RecPatWildcard names) =+  printf+    "a record pattern wildcard which brings the following fields: %s"+    (intercalate ", " $ map ppOrigName names)+formatInfo (RecExpWildcard names) =+  printf+    "a record construction wildcard which assigns the following fields: %s"+    $ intercalate ", "+      [ printf "%s = (%s)" (ppOrigName field) valueDesc+      | (field, vinfo) <- names+      , let valueDesc = formatInfo vinfo+      ] formatInfo (ScopeError (ENotInScope {})) = "not in scope" formatInfo None = "none" formatInfo i = error $ "tests/run.hs: formatInfo: " ++ show i