packages feed

fay 0.23.1.2 → 0.23.1.3

raw patch · 29 files changed

+2590/−34 lines, 29 filesdep +data-lens-lightdep +traverse-with-classdep +type-eqdep −haskell-namesdep −haskell-packagesdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: data-lens-light, traverse-with-class, type-eq

Dependencies removed: haskell-names, haskell-packages

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -2,6 +2,10 @@  See full history at: <https://github.com/faylang/fay/commits> +#### 0.23.1.3++* Inline parts of `haskell-names 0.4.1` and `haskell-packages` to drop transitive dependencies on Cabal and other packages.+ #### 0.23.1.2  * Allow filepath 1.4.*
fay.cabal view
@@ -1,5 +1,5 @@ name:                fay-version:             0.23.1.2+version:             0.23.1.3 synopsis:            A compiler for Fay, a Haskell subset that compiles to JavaScript. description:         Fay is a proper subset of Haskell which is type-checked                      with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad,@@ -30,6 +30,7 @@   CHANGELOG.md   LICENSE   README.md+  src/haskell-names/LICENSE   -- Examples   examples/*.hs   examples/*.html@@ -73,7 +74,9 @@  library   ghc-options:       -O2 -Wall-  hs-source-dirs:    src+  hs-source-dirs:+    src+    src/haskell-names   exposed-modules:     Fay     Fay.Compiler@@ -97,6 +100,7 @@     Fay.Compiler.Import     Fay.Compiler.InitialPass     Fay.Compiler.Misc+    Fay.Compiler.ModuleT     Fay.Compiler.Optimizer     Fay.Compiler.Packages     Fay.Compiler.Pattern@@ -112,18 +116,34 @@     Fay.Types.Js     Fay.Types.ModulePath     Fay.Types.Printer+    Language.Haskell.Names+    Language.Haskell.Names.Annotated+    Language.Haskell.Names.Exports+    Language.Haskell.Names.GetBound+    Language.Haskell.Names.GlobalSymbolTable+    Language.Haskell.Names.Imports+    Language.Haskell.Names.LocalSymbolTable+    Language.Haskell.Names.ModuleSymbols+    Language.Haskell.Names.Open.Base+    Language.Haskell.Names.Open.Derived+    Language.Haskell.Names.Open.Instances+    Language.Haskell.Names.RecordWildcards+    Language.Haskell.Names.Recursive+    Language.Haskell.Names.ScopeUtils+    Language.Haskell.Names.SyntaxUtils+    Language.Haskell.Names.Types     Paths_fay+   build-depends:       base >= 4 && < 4.9     , aeson > 0.6 && < 0.9     , bytestring < 0.11     , containers < 0.6     , data-default < 0.6+    , data-lens-light < 0.2     , directory < 1.3     , filepath < 1.5     , ghc-paths < 0.2-    , haskell-names >= 0.3.1 && < 0.5-    , haskell-packages == 0.2.3.1 || > 0.2.3.2 && < 0.3     , haskell-src-exts >= 1.16 && < 1.17     , language-ecmascript >= 0.15 && < 0.18     , mtl < 2.3@@ -138,6 +158,8 @@     , time >= 1 && < 1.6     , transformers >= 0.3 && < 0.4 || > 0.4.1 && < 0.5     , transformers-compat >= 0.3 && < 0.5+    , traverse-with-class < 0.3+    , type-eq < 0.6     , uniplate >= 1.6.11 && < 1.7     , unordered-containers < 0.3     , utf8-string < 1.1
src/Fay/Compiler.hs view
@@ -47,7 +47,7 @@  import qualified Data.Set                        as S import           Language.Haskell.Exts.Annotated hiding (name)-import           Language.Haskell.Names+import           Language.Haskell.Names (annotateModule)  -------------------------------------------------------------------------------- -- Top level entry points
src/Fay/Compiler/Exp.hs view
@@ -31,7 +31,7 @@ import           Control.Monad.RWS               (asks, gets) import qualified Data.Char                       as Char import           Language.Haskell.Exts.Annotated hiding (alt, binds, name, op)-import           Language.Haskell.Names+import           Language.Haskell.Names (Scoped (Scoped), NameInfo (RecExpWildcard))  -- | Compile Haskell expression. compileExp :: S.Exp -> Compile JsExp
src/Fay/Compiler/InitialPass.hs view
@@ -23,7 +23,7 @@ import           Control.Monad.RWS import qualified Data.Map                        as M import           Language.Haskell.Exts.Annotated hiding (name, var)-import qualified Language.Haskell.Names          as HN+import qualified Language.Haskell.Names          as HN (getInterfaces)  -- | Preprocess and collect all information needed during code generation. initialPass :: FilePath -> Compile ()
src/Fay/Compiler/Misc.hs view
@@ -10,25 +10,25 @@  import           Fay.Compiler.Prelude +import           Fay.Compiler.ModuleT            (runModuleT) import           Fay.Compiler.PrimOp-import           Fay.Compiler.QName                (unname)+import           Fay.Compiler.QName              (unname) import           Fay.Config-import qualified Fay.Exts                          as F-import           Fay.Exts.NoAnnotation             (unAnn)-import qualified Fay.Exts.NoAnnotation             as N-import qualified Fay.Exts.Scoped                   as S+import qualified Fay.Exts                        as F+import           Fay.Exts.NoAnnotation           (unAnn)+import qualified Fay.Exts.NoAnnotation           as N+import qualified Fay.Exts.Scoped                 as S import           Fay.Types  import           Control.Monad.Except-import           Control.Monad.RWS                 (asks, gets, modify, runRWST)-import qualified Data.Map                          as M-import           Data.Version                      (parseVersion)-import           Distribution.HaskellSuite.Modules-import           Language.Haskell.Exts.Annotated   hiding (name)-import           Language.Haskell.Names+import           Control.Monad.RWS               (asks, gets, modify, runRWST)+import           Data.Version                    (parseVersion)+import           Language.Haskell.Exts.Annotated hiding (name)+import           Language.Haskell.Names          (GName (GName), NameInfo (GlobalValue, LocalValue, ScopeError),+                                                  OrigName, Scoped (Scoped), origGName, origName) import           System.IO-import           System.Process                    (readProcess)-import           Text.ParserCombinators.ReadP      (readP_to_S)+import           System.Process                  (readProcess)+import           Text.ParserCombinators.ReadP    (readP_to_S)  -- | Wrap an expression in a thunk. thunk :: JsExp -> JsExp@@ -268,7 +268,7 @@   -> CompileState   -> Compile a   -> IO (Either CompileError (a,CompileState,CompileWriter))-runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty+runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state'))  -- | Runs compilation for a single module. runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a
+ src/Fay/Compiler/ModuleT.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-}+module Fay.Compiler.ModuleT+  (+  -- * Module monad+  -- | When you need to resolve modules, you work in a 'ModuleT' monad (or+  -- another monad that is an instance of 'MonadModule') and use the+  -- 'getModuleInfo' function.+  --+  -- It finds an installed module by its name and reads (and caches) its+  -- info from the info file. Then you run a 'ModuleT' monadic action+  -- using 'evalModuleT' or 'runModuleT'.+  --+  -- To run a 'ModuleT' action you'll also need to provide the set of+  -- packages (represented by their 'InstalledPackageInfo') in which to+  -- search for modules. You can get such a set from either+  -- 'getInstalledPackages' or 'readPackagesInfo', depending on your use+  -- case.+    ModuleT+  , getModuleInfo+  , runModuleT+  , MonadModule (..)+  -- * Module names+  , ModName (..)+  ) where++import           Control.Applicative+import           Control.Monad.Reader+import           Control.Monad.State+import           Control.Monad.Writer+import qualified Data.Char            as Char (isAlphaNum, isUpper)+import qualified Data.Map             as Map++-- ModuleName extracted from Cabal, (c) 2008 Duncan Coutts, Licensed as BSD3+newtype ModuleName = ModuleName [String]+  deriving (Eq, Ord, Show)++fromString :: String -> ModuleName+fromString string+  | all validModuleComponent components' = ModuleName components'+  | otherwise                            = error $ "ModuleName.fromString: invalid module name " ++ show string++  where+    components' = split string++    split cs = case break (=='.') cs of+      (chunk,[])     -> chunk : []+      (chunk,_:rest) -> chunk : split rest++    validModuleComponent :: String -> Bool+    validModuleComponent []     = False+    validModuleComponent (c:cs) = Char.isUpper c+                           && all validModuleChar cs++    validModuleChar :: Char -> Bool+    validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''+++-- | This class defines the interface that is used by 'getModuleInfo', so+-- that you can use it in monads other than 'ModuleT'.+--+-- You don't typically have to define your own instances of this class, but+-- here are a couple of cases when you might:+--+-- * A pure (non-'MonadIO') mockup module monad for testing purposes+--+-- * A transformer over 'ModuleT'+--+-- * You need a more complex way to retrieve the module info+class Monad m => MonadModule m where+  -- | The type of module info+  type ModuleInfo m+  lookupInCache :: ModName n => n -> m (Maybe (ModuleInfo m))+  insertInCache :: ModName n => n -> ModuleInfo m -> m ()++  -- | Read the module info, given a list of search paths and the module+  -- name+  readModuleInfo :: ModName n => [FilePath] -> n -> m (ModuleInfo m)++-- | Different libraries (Cabal, haskell-src-exts, ...) use different types+-- to represent module names. Hence this class.+class ModName n where+  modToString :: n -> String++instance ModName String where+  modToString = id++-- | Convert module name from arbitrary representation to Cabal's one+convertModuleName :: ModName n => n -> ModuleName+convertModuleName = fromString . modToString++-- | Tries to find the module in the current set of packages, then find the+-- module's info file, and reads and caches its contents.+--+-- Returns 'Nothing' if the module could not be found in the current set of+-- packages. If the module is found, but something else goes wrong (e.g.+-- there's no info file for it), an exception is thrown.+getModuleInfo :: (MonadModule m, ModName n) => n -> m (Maybe (ModuleInfo m))+getModuleInfo = lookupInCache++-- | A standard module monad transformer.+--+-- @i@ is the type of module info, @m@ is the underlying monad.+newtype ModuleT i m a =+  ModuleT (+    (StateT (Map.Map ModuleName i)+            (ReaderT ([FilePath] -> ModuleName -> m i) m) a))+  deriving (Functor, Applicative, Monad)++instance MonadTrans (ModuleT i) where+  lift = ModuleT . lift . lift++instance MonadIO m => MonadIO (ModuleT i m) where+  liftIO = ModuleT . liftIO++instance (Functor m, Monad m) => MonadModule (ModuleT i m) where+  type ModuleInfo (ModuleT i m) = i+  lookupInCache n = ModuleT $ Map.lookup (convertModuleName n) <$> get+  insertInCache n i = ModuleT $ modify $ Map.insert (convertModuleName n) i+  readModuleInfo dirs mod' =+    lift =<< ModuleT ask <*> pure dirs <*> pure (convertModuleName mod')++-- | Run a 'ModuleT' action+runModuleT+  :: (Monad m, Monoid i)+  => ModuleT i m a -- ^ the monadic action to run+  -> m (a, Map.Map ModuleName i)+  -- ^ return value, plus all cached module infos (that is, the initial set+  -- plus all infos that have been read by the action itself)+runModuleT (ModuleT a) =+  runReaderT (runStateT a Map.empty) (\_ _ -> return mempty)
src/Fay/Compiler/Pattern.hs view
@@ -18,7 +18,7 @@ import           Control.Monad.Except import           Control.Monad.Reader import           Language.Haskell.Exts.Annotated hiding (name)-import           Language.Haskell.Names+import           Language.Haskell.Names (Scoped (Scoped), NameInfo (RecPatWildcard))  -- | Compile the given pattern against the given expression. compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]
src/Fay/Compiler/State.hs view
@@ -12,7 +12,7 @@ import qualified Data.Map               as M import           Data.Set               (Set) import qualified Data.Set               as S-import           Language.Haskell.Names+import           Language.Haskell.Names (sv_origName, Symbols (Symbols), SymValueInfo (SymValue, SymMethod, SymSelector, SymConstructor), OrigName, sv_typeName)  -- | Get all non local identifiers that should be exported in the JS module scope. getNonLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)
src/Fay/Exts/Scoped.hs view
@@ -3,7 +3,7 @@ import qualified Fay.Exts                        as F  import qualified Language.Haskell.Exts.Annotated as A-import qualified Language.Haskell.Names          as HN+import qualified Language.Haskell.Names          as HN (Scoped (Scoped), NameInfo (None))   type X = HN.Scoped A.SrcSpanInfo
src/Fay/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies               #-} @@ -40,9 +40,10 @@   , mkModulePathFromQName   ) where +import           Fay.Compiler.ModuleT import           Fay.Config-import qualified Fay.Exts.NoAnnotation             as N-import qualified Fay.Exts.Scoped                   as S+import qualified Fay.Exts.NoAnnotation   as N+import qualified Fay.Exts.Scoped         as S import           Fay.Types.CompileError import           Fay.Types.CompileResult import           Fay.Types.FFI@@ -53,13 +54,12 @@ #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative #endif-import           Control.Monad.Except              (ExceptT, MonadError)-import           Control.Monad.Identity            (Identity)+import           Control.Monad.Except    (ExceptT, MonadError)+import           Control.Monad.Identity  (Identity) import           Control.Monad.RWS-import           Data.Map                          (Map)-import           Data.Set                          (Set)-import           Distribution.HaskellSuite.Modules-import           Language.Haskell.Names            (Symbols)+import           Data.Map                (Map)+import           Data.Set                (Set)+import           Language.Haskell.Names  (Symbols)  -------------------------------------------------------------------------------- -- Compiler types@@ -121,7 +121,6 @@   type ModuleInfo Compile = Symbols   lookupInCache        = liftModuleT . lookupInCache   insertInCache n m    = liftModuleT $ insertInCache n m-  getPackages          = liftModuleT getPackages   readModuleInfo fps n = liftModuleT $ readModuleInfo fps n  liftModuleT :: ModuleT Symbols IO a -> Compile a
+ src/haskell-names/LICENSE view
@@ -0,0 +1,3 @@+Forked from haskell-names+Licensed as BSD3+Authors: Roman Cheplyaka, Lennart Augustsson
+ src/haskell-names/Language/Haskell/Names.hs view
@@ -0,0 +1,17 @@+module Language.Haskell.Names+  (+  -- * Core functions+    annotateModule+  , getInterfaces+  -- * Types+  , SymValueInfo(..)+  , Symbols(..)+  , Scoped(..)+  , NameInfo(..)+  , GName(..)+  , OrigName(..)+  , HasOrigName(..)+  ) where++import Language.Haskell.Names.Types (Symbols (..), SymValueInfo (..), Scoped (..), NameInfo (..), GName (..), OrigName (..), HasOrigName (..))+import Language.Haskell.Names.Recursive (getInterfaces, annotateModule)
+ src/haskell-names/Language/Haskell/Names/Annotated.hs view
@@ -0,0 +1,102 @@+-- This module uses the open recursion interface+-- ("Language.Haskell.Names.Open") to annotate the AST with binding+-- information.+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances  #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+module Language.Haskell.Names.Annotated+  ( Scoped (..)+  , NameInfo (..)+  , annotate+  ) where++import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable  as Local+import           Language.Haskell.Names.Open.Base+import           Language.Haskell.Names.Open.Instances    ()+import           Language.Haskell.Names.RecordWildcards+import           Language.Haskell.Names.Types++import           Control.Applicative+import           Data.Lens.Light+import           Data.Proxy+import           Data.Typeable                            (Typeable)+import           Language.Haskell.Exts.Annotated+import           Type.Eq++annotate+  :: forall a l .+     (Resolvable (a (Scoped l)), Functor a, Typeable l)+  => Scope -> a l -> a (Scoped l)+annotate sc = annotateRec (Proxy :: Proxy l) sc . fmap (Scoped None)++annotateRec+  :: forall a l .+     (Typeable l, Resolvable a)+  => Proxy l -> Scope -> a -> a+annotateRec _ sc a = go sc a where+  go :: forall a . Resolvable a => Scope -> a -> a+  go sc a+    | ReferenceV <- getL nameCtx sc+    , Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq+      = lookupValue (fmap sLoc a) sc <$ a+    | ReferenceT <- getL nameCtx sc+    , Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq+      = lookupType (fmap sLoc a) sc <$ a+    | BindingV <- getL nameCtx sc+    , Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq+      = Scoped ValueBinder (sLoc . ann $ a) <$ a+    | 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 (lookupValue (sLoc <$> 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++lookupValue :: QName l -> Scope -> Scoped l+lookupValue qn sc = Scoped nameInfo (ann qn)+  where+    nameInfo =+      case Local.lookupValue qn $ getL lTable sc of+        Right r -> LocalValue r+        _ ->+          case Global.lookupValue qn $ getL gTable sc of+            Global.Result r -> GlobalValue r+            Global.Error e -> ScopeError e+            Global.Special -> None++lookupType :: QName l -> Scope -> Scoped l+lookupType qn sc = Scoped nameInfo (ann qn)+  where+    nameInfo =+      case Global.lookupType qn $ getL gTable sc of+        Global.Result r -> GlobalType r+        Global.Error e -> ScopeError e+        Global.Special -> None
+ src/haskell-names/Language/Haskell/Names/Exports.hs view
@@ -0,0 +1,140 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE TypeFamilies     #-}+module Language.Haskell.Names.Exports+  ( processExports+  ) where++import           Fay.Compiler.ModuleT+import           Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.ModuleSymbols+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types             (Error (..), GName (..), ModuleNameS, NameInfo (..),+                                                           Scoped (..), Symbols (..), mkTy, mkVal, st_origName)++import           Control.Applicative+import           Control.Arrow+import           Control.Monad+import           Control.Monad.Writer+import           Data.Data+import qualified Data.Map                                 as Map+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts.Annotated++processExports+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, Eq l)+  => Global.Table+  -> Module l+  -> m (Maybe (ExportSpecList (Scoped l)), Symbols)+processExports tbl m =+  case getExportSpecList m of+    Nothing ->+      return (Nothing, moduleSymbols tbl m)+    Just exp ->+      liftM (first Just) $ resolveExportSpecList tbl exp++resolveExportSpecList+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => Global.Table+  -> ExportSpecList l+  -> m (ExportSpecList (Scoped l), Symbols)+resolveExportSpecList tbl (ExportSpecList l specs) =+  liftM (first $ ExportSpecList $ none l) $+  runWriterT $+  mapM (WriterT . resolveExportSpec tbl) specs++resolveExportSpec+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => Global.Table+  -> ExportSpec l+  -> m (ExportSpec (Scoped l), Symbols)+resolveExportSpec tbl exp =+  case exp of+    EVar l ns@(NoNamespace {}) qn -> return $+      case Global.lookupValue qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let s = mkVal i+          in+            (EVar (Scoped (Export s) l)+              (noScope ns)+              (Scoped (GlobalValue i) <$> qn), s)+        Global.Special {} -> error "Global.Special in export list?"+    EVar _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME+    EAbs l qn -> return $+      case Global.lookupType qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let s = mkTy i+          in+            (EAbs (Scoped (Export s) l)+              (Scoped (GlobalType i) <$> qn), s)+        Global.Special {} -> error "Global.Special in export list?"+    EThingAll l qn -> return $+      case Global.lookupType qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let+            subs = mconcat+              [ mkVal info+              | info <- allValueInfos+              , Just n' <- return $ sv_parent info+              , n' == st_origName i ]+            s = mkTy i <> subs+          in+            ( EThingAll (Scoped (Export s) l) (Scoped (GlobalType i) <$> qn)+            , s+            )+        Global.Special {} -> error "Global.Special in export list?"+    EThingWith l qn cns -> return $+      case Global.lookupType qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let+            (cns', subs) =+              resolveCNames+                (Global.toSymbols tbl)+                (st_origName i)+                (\cn -> ENotInScope (UnQual (ann cn) (unCName cn))) -- FIXME better error+                cns+            s = mkTy i <> subs+          in+            ( EThingWith (Scoped (Export s) l) (Scoped (GlobalType i) <$> qn) cns'+            , s+            )+        Global.Special {} -> error "Global.Special in export list?"+    EModuleContents _ (ModuleName _ mod) ->+      -- FIXME ambiguity check+      let+        filterByPrefix+          :: Ord i+          => ModuleNameS+          -> Map.Map GName (Set.Set i)+          -> Set.Set i+        filterByPrefix prefix m =+          Set.unions+            [ i | (GName { gModule = prefix' }, i) <- Map.toList m, prefix' == prefix ]++        filterEntities+          :: Ord i+          => Map.Map GName (Set.Set i)+          -> Set.Set i+        filterEntities ents =+          Set.intersection+            (filterByPrefix mod ents)+            (filterByPrefix ""  ents)++        eVals = filterEntities $ Global.values tbl+        eTyps = filterEntities $ Global.types tbl++        s = Symbols eVals eTyps+      in+        return (Scoped (Export s) <$> exp, s)+  where+    allValueInfos =+      Set.toList $ Map.foldl' Set.union Set.empty $ Global.values tbl
+ src/haskell-names/Language/Haskell/Names/GetBound.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE NamedFieldPuns         #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE UndecidableInstances   #-}+module Language.Haskell.Names.GetBound+  ( GetBound(..)+  ) where++import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.RecordWildcards+import           Language.Haskell.Names.SyntaxUtils++import           Control.Applicative+import           Data.Data+import           Data.Generics.Uniplate.Data+import           Language.Haskell.Exts.Annotated++-- | 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{} -> []+      ClosedTypeFamDecl{} -> []+      MinimalPragma{} -> []++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 _l conName mbFieldDecls _ty) =+      -- GADT constructor name+      [conName] +++      -- GADT selector names+      [ fieldName+      | Just fieldDecls <- return mbFieldDecls+      , FieldDecl _l' fieldNames _fieldTy <- fieldDecls+      , fieldName <- fieldNames+      ]++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{} -> []+      ClsDefSig{} -> []++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 _ qn) = [qNameToName qn]+      getRecVars elidedFields (PFieldWildcard l) = map (l <$) elidedFields++getBoundSign :: Decl l -> [Name l]+getBoundSign (TypeSig _ ns _) = ns+getBoundSign _ = []
+ src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | This module is designed to be imported qualified.+module Language.Haskell.Names.GlobalSymbolTable+  ( Table+  , empty+  , Result(..)+  , lookupValue+  , lookupType+  , fromLists+  , types+  , values+  , toSymbols+  ) where++import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Control.Applicative                hiding (empty)+import           Control.Arrow+import           Data.Data+import           Data.Lens.Light+import qualified Data.Map                           as Map+import           Data.Monoid+import qualified Data.Set                           as Set+import           Language.Haskell.Exts.Annotated    as HSE++-- | Global symbol table — contains global names+data Table =+  Table+    (Map.Map GName (Set.Set (SymValueInfo OrigName)))+    (Map.Map GName (Set.Set (SymTypeInfo  OrigName)))+    deriving (Eq, Ord, Show, Data, Typeable)++valLens :: Lens Table (Map.Map GName (Set.Set (SymValueInfo OrigName)))+valLens = lens (\(Table vs _) -> vs) (\vs (Table _ ts) -> Table vs ts)++tyLens :: Lens Table (Map.Map GName (Set.Set (SymTypeInfo OrigName)))+tyLens = lens (\(Table _ ts) -> ts) (\ts (Table vs _) -> Table vs ts)++instance Monoid Table where+  mempty = empty+  mappend (Table vs1 ts1) (Table vs2 ts2) =+    Table (j vs1 vs2) (j ts1 ts2)+    where+      j :: (Ord i, Ord k)+        => Map.Map k (Set.Set i)+        -> Map.Map k (Set.Set i)+        -> Map.Map k (Set.Set i)+      j = Map.unionWith Set.union++toGName :: QName l -> GName+toGName (UnQual _ n) = GName "" (nameToString n)+toGName (Qual _ (ModuleName _ m) n) = GName m (nameToString n)+toGName (HSE.Special _ _) = error "toGName: Special"++empty :: Table+empty = Table Map.empty Map.empty++lookupL+  :: HasOrigName i+  => Lens Table (Map.Map GName (Set.Set (i OrigName)))+  -> QName l+  -> Table+  -> Result l (i OrigName)+lookupL _ (HSE.Special {}) _ =+  Language.Haskell.Names.GlobalSymbolTable.Special+lookupL lens qn tbl =+  case Set.toList <$> (Map.lookup (toGName qn) $ getL lens tbl) of+    Nothing -> Error $ ENotInScope qn+    Just [] -> Error $ ENotInScope qn+    Just [i] -> Result i+    Just is -> Error $ EAmbiguous qn (map origName is)++data Result l a+  = Result a+  | Error (Error l)+  | Special++lookupValue :: QName l -> Table -> Result l (SymValueInfo OrigName)+lookupValue = lookupL valLens++lookupType :: QName l -> Table -> Result l (SymTypeInfo OrigName)+lookupType  = lookupL tyLens++fromMaps+  :: Map.Map GName (Set.Set (SymValueInfo OrigName))+  -> Map.Map GName (Set.Set (SymTypeInfo  OrigName))+  -> Table+fromMaps = Table++fromLists+  :: ([(GName, SymValueInfo OrigName)],+      [(GName, SymTypeInfo OrigName)])+  -> Table+fromLists (vs, ts) =+  fromMaps+    (Map.fromListWith Set.union $ map (second Set.singleton) vs)+    (Map.fromListWith Set.union $ map (second Set.singleton) ts)++values :: Table -> Map.Map GName (Set.Set (SymValueInfo OrigName))+types  :: Table -> Map.Map GName (Set.Set (SymTypeInfo  OrigName))+values = getL valLens+types = getL tyLens++toSymbols :: Table -> Symbols+toSymbols tbl =+  Symbols+    (gather $ values tbl)+    (gather $ types  tbl)+  where+    gather :: Ord a => Map.Map k (Set.Set a) -> Set.Set a+    gather = Map.foldl' Set.union Set.empty
+ src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot view
@@ -0,0 +1,10 @@+module Language.Haskell.Names.GlobalSymbolTable where++import Data.Data++data Table+instance Eq   Table+instance Ord  Table+instance Show Table+instance Data Table+instance Typeable Table
+ src/haskell-names/Language/Haskell/Names/Imports.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies  #-}+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-orphans #-} -- ModName (ModuleName l)+module Language.Haskell.Names.Imports (processImports) where++import           Fay.Compiler.ModuleT+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Control.Applicative+import           Control.Arrow+import           Control.Monad.Writer+import           Data.Either+import           Data.Foldable                            (fold, foldMap)+import           Data.Lens.Light+import qualified Data.Map                                 as Map+import           Data.Maybe+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts.Annotated++instance ModName (ModuleName l) where+  modToString (ModuleName _ s) = s++preludeName :: String+preludeName = "Prelude"++processImports+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => ExtensionSet+  -> [ImportDecl l]+  -> m ([ImportDecl (Scoped l)], Global.Table)+processImports exts importDecls = do++  (annotated, tbl) <- runWriterT $ mapM (WriterT . processImport) importDecls++  let+    isPreludeImported = not . null $+      [ () | ImportDecl { importModule = ModuleName _ modName } <- importDecls+           , modName == preludeName ]++    importPrelude =+      ImplicitPrelude `Set.member` exts &&+      not isPreludeImported++  tbl' <-+    if not importPrelude+      then return tbl+      else do+        -- FIXME currently we don't have a way to signal an error when+        -- Prelude cannot be found+        syms <- fold `liftM` getModuleInfo preludeName+        return $ tbl <>+          computeSymbolTable+            False -- not qualified+            (ModuleName () preludeName)+            syms++  return (annotated, tbl')++processImport+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => ImportDecl l+  -> m (ImportDecl (Scoped l), Global.Table)+processImport imp = do+  mbi <- getModuleInfo (importModule imp)+  case mbi of+    Nothing ->+      let e = EModNotFound (importModule imp)+      in return (scopeError e imp, Global.empty)+    Just syms -> return $ resolveImportDecl syms imp++resolveImportDecl+  :: Symbols+  -> ImportDecl l+  -> (ImportDecl (Scoped l), Global.Table)+resolveImportDecl syms (ImportDecl l mod qual src impSafe pkg mbAs mbSpecList) =+  let+    (mbSpecList', impSyms) =+      (fmap fst &&& maybe syms snd) $+        resolveImportSpecList mod syms <$> mbSpecList+    tbl = computeSymbolTable qual (fromMaybe mod mbAs) impSyms+    info =+      case mbSpecList' of+        Just sl | Scoped (ScopeError e) _ <- ann sl ->+          ScopeError e+        _ -> Import tbl+  in+    (ImportDecl+      (Scoped info l)+      (Scoped (ImportPart syms) <$> mod)+      qual+      src+      impSafe+      pkg+      (fmap noScope mbAs)+      mbSpecList'+    , tbl)++resolveImportSpecList+  :: ModuleName l+  -> Symbols+  -> ImportSpecList l+  -> (ImportSpecList (Scoped l), Symbols)+resolveImportSpecList mod allSyms (ImportSpecList l isHiding specs) =+  let specs' = map (resolveImportSpec mod isHiding allSyms) specs+      mentionedSyms = mconcat $ rights $ map ann2syms specs'+      importedSyms = computeImportedSymbols isHiding allSyms mentionedSyms+      newAnn = Scoped (ImportPart importedSyms) l+  in+    (ImportSpecList newAnn isHiding specs', importedSyms)++-- | This function takes care of the possible 'hiding' clause+computeImportedSymbols+  :: Bool+  -> Symbols -- ^ all symbols+  -> Symbols -- ^ mentioned symbols+  -> Symbols -- ^ imported symbols+computeImportedSymbols isHiding (Symbols vs ts) mentionedSyms =+  case isHiding of+    False -> mentionedSyms+    True ->+      let+        Symbols hvs hts = mentionedSyms+        allTys = symbolMap st_origName ts+        hidTys = symbolMap st_origName hts+        allVls = symbolMap sv_origName vs+        hidVls = symbolMap sv_origName hvs+      in+        Symbols+          (Set.fromList $ Map.elems $ allVls Map.\\ hidVls)+          (Set.fromList $ Map.elems $ allTys Map.\\ hidTys)++symbolMap+  :: Ord s+  => (a -> s)+  -> Set.Set a+  -> Map.Map s a+symbolMap f is = Map.fromList [(f i, i) | i <- Set.toList is]++resolveImportSpec+  :: ModuleName l+  -> Bool+  -> Symbols+  -> ImportSpec l+  -> ImportSpec (Scoped l)+-- NB: this can be made more efficient+resolveImportSpec mod isHiding syms spec =+  case spec of+    IVar _ (NoNamespace {}) n ->+      let+        matches = mconcat $+          -- Strictly speaking, the isConstructor check is unnecessary+          -- because constructors are lexically different from anything+          -- else.+          [ mkVal info+          | info <- vs+          , not (isConstructor info)+          , sv_origName info ~~ n]+      in+        checkUnique+          (ENotExported Nothing n mod)+          matches+          spec+    -- FIXME think about data families etc.+    IVar _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME+    IAbs _ n+      | isHiding ->+          -- This is a bit special. 'C' may match both types/classes and+          -- data constructors.+          -- FIXME Still check for uniqueness?+          let+            Symbols vlMatches tyMatches =+              mconcat [ mkVal info | info <- vs, sv_origName info ~~ n]+              <>+              mconcat [ mkTy info | info <- ts, st_origName info ~~ n]+          in+            if Set.null tyMatches && Set.null vlMatches+              then+                scopeError (ENotExported Nothing n mod) spec+              else+                Scoped (ImportPart (Symbols vlMatches tyMatches)) <$> spec+      | otherwise ->+          let+            matches = mconcat+              [mkTy info | info <- ts, st_origName info ~~ n]+          in+            checkUnique+              (ENotExported Nothing n mod)+              matches+              spec++    -- FIXME+    -- What about things like:+    -- head(..)+    -- String(..)+    -- ?+    IThingAll l n ->+      let+        matches = [ info | info <- ts, st_origName info ~~ n]+        subs = mconcat+          [ mkVal info+          | n <- matches+          , info <- vs+          , Just n' <- return $ sv_parent info+          , n' == st_origName n ]+        n' =+          checkUnique+            (ENotExported Nothing n mod)+            (foldMap mkTy matches)+            n+        in+          case ann n' of+            e@(Scoped ScopeError{} _) -> IThingAll e n'+            _ ->+              IThingAll+                (Scoped+                  (ImportPart (subs <> foldMap mkTy matches))+                  l+                )+                n'++    IThingWith l n cns ->+      let+        matches = [info | info <- ts, st_origName info ~~ n]+        n' =+          checkUnique+            (ENotExported Nothing n mod)+            (foldMap mkTy matches)+            n+        typeName = st_origName $ head matches -- should be safe+        (cns', cnSyms) =+          resolveCNames+            syms+            typeName+            (\cn -> ENotExported (Just n) (unCName cn) mod)+            cns+      in+        IThingWith+          (Scoped+            (ImportPart (cnSyms <> foldMap mkTy matches))+            l+          )+          n'+          cns'+  where+    (~~) :: OrigName -> Name l -> Bool+    OrigName { origGName = GName { gName = n } } ~~ n' = n == nameToString n'++    isConstructor :: SymValueInfo n -> Bool+    isConstructor SymConstructor {} = True+    isConstructor _ = False++    vs = Set.toList $ syms^.valSyms+    ts = Set.toList $ syms^.tySyms++ann2syms :: Annotated a => a (Scoped l) -> Either (Error l) (Symbols)+ann2syms a =+  case ann a of+    Scoped (ScopeError e) _ -> Left e+    Scoped (ImportPart syms) _ -> Right syms+    _ -> Left $ EInternal "ann2syms"++checkUnique+  :: Functor f =>+  Error l ->+  Symbols ->+  f l ->+  f (Scoped l)+checkUnique notFound syms@(Symbols vs ts) f =+  case Set.size vs + Set.size ts of+    0 -> scopeError notFound f+    1 -> Scoped (ImportPart syms) <$> f+    -- there should be no clashes, and it should be checked elsewhere+    _ -> scopeError (EInternal "ambiguous import") f
+ src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs view
@@ -0,0 +1,32 @@+-- | This module is designed to be imported qualified.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Language.Haskell.Names.LocalSymbolTable+  ( Table+  , empty+  , lookupValue+  , addValue+  ) where++import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import qualified Data.Map                           as Map+import           Data.Monoid+import           Language.Haskell.Exts.Annotated++-- | Local symbol table — contains locally bound names+newtype Table = Table (Map.Map NameS SrcLoc)+  deriving Monoid++addValue :: SrcInfo l => Name l -> Table -> Table+addValue n (Table vs) =+  Table (Map.insert (nameToString n) (getPointLoc $ ann n) vs)++lookupValue :: QName l -> Table -> Either (Error l) SrcLoc+lookupValue qn@(UnQual _ n) (Table vs) =+  maybe (Left $ ENotInScope qn) Right $+    Map.lookup (nameToString n) vs+lookupValue qn _ = Left $ ENotInScope qn++empty :: Table+empty = Table Map.empty
+ src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs view
@@ -0,0 +1,162 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+module Language.Haskell.Names.ModuleSymbols+  ( moduleSymbols+  , moduleTable+  )+  where++import           Language.Haskell.Exts.Annotated+import           Language.Haskell.Names.GetBound+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Control.Monad+import           Data.Data+import           Data.Either+import           Data.Lens.Light+import qualified Data.Map                                 as Map+import           Data.Maybe+import           Data.Monoid+import qualified Data.Set                                 as Set++-- | 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)++-- | 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 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+  :: forall l . (Eq l, Data l)+  => Global.Table -- ^ the import table for this module+  -> ModuleName l+  -> Decl l+  -> [Either (SymValueInfo OrigName) (SymTypeInfo OrigName)]+getTopDeclSymbols impTbl mdl d =+  map (either (Left . fmap OrigName) (Right . fmap OrigName)) $+  case d of+    TypeDecl _ dh _ ->+      let tn = hname dh+      in  [ Right (SymType        { st_origName = tn, st_fixity = Nothing })]++    TypeFamDecl _ dh _ ->+      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 _ ->+      -- FIXME: We shouldn't create selectors for fields with existential type variables!+      let+        dq = hname dh++        cons :: Constructors+        cons = do -- list monad+          GadtDecl _ cn (fromMaybe [] -> fields) _ty <- gadtDecls+          return (void cn , [void f | FieldDecl _ fNames _ <- fields, f <- fNames])++        infos = constructorsToInfos dq cons+      in+          Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos++    DataFamDecl _ _ dh _ ->+      let tn = hname dh+      in [Right (SymDataFam { st_origName = tn, st_fixity = Nothing })]++    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 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 impTbl p ]++    ForImp _ _ _ _ fn _ ->+      [ Left  (SymValue { sv_origName = qname fn, sv_fixity = Nothing }) ]++    _ -> []+  where+    ModuleName _ smdl = mdl+    qname = GName smdl . nameToString+    hname = qname . getDeclHeadName+    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+          ]
+ src/haskell-names/Language/Haskell/Names/Open/Base.hs view
@@ -0,0 +1,152 @@+-- | This module provides a more flexible way to process Haskell code —+-- using an open-recursive traversal.+--+-- You can look at "Language.Haskell.Exts.Annotated" source as an example+-- of how to use this module.+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances  #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}+module Language.Haskell.Names.Open.Base+  ( Resolvable (..)+  , intro+  , mergeLocalScopes+  , alg+  , Scope (..)+  , setWcNames+  , gTable+  , exprV+  , exprT+  , rmap+  , wcNames+  , nameCtx+  , NameContext (..)+  , initialScope+  , binderV+  , Alg (..)+  , binderT+  , defaultRtraverse+  , lTable+  ) where++import           Language.Haskell.Names.GetBound+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable  as Local+import           Language.Haskell.Names.RecordWildcards++import           Control.Applicative+import           Control.Monad.Identity+import           Data.Generics.Traversable+import           Data.Lens.Light+import           Data.List+import           Data.Monoid+import           Data.Typeable+import           GHC.Exts                                 (Constraint)+import           Language.Haskell.Exts.Annotated++-- | Describes how we should treat names in the current context+data NameContext+  = BindingT+  | BindingV+  | ReferenceT+  | ReferenceV+  | Other++-- | Contains information about the node's enclosing scope. Can be+-- accessed through the lenses: 'gTable', 'lTable', 'nameCtx', 'wcNames'.+data Scope = Scope+  { _gTable  :: Global.Table+  , _lTable  :: Local.Table+  , _nameCtx :: NameContext+  , _wcNames :: WcNames+  }++makeLens ''Scope++-- | Create an initial scope+initialScope :: Global.Table -> Scope+initialScope tbl = Scope tbl Local.empty Other []++-- | Merge local tables of two scopes. The other fields of the scopes are+-- assumed to be the same.+mergeLocalScopes :: Scope -> Scope -> Scope+mergeLocalScopes sc1 sc2 =+  modL lTable (<> sc2 ^. lTable) sc1++-- | The algebra for 'rtraverse'. It's newtype-wrapped because an implicit+-- parameter cannot be polymorphic.+newtype Alg w = Alg+  { runAlg :: forall d . Resolvable d => d -> Scope -> w d }++alg :: (?alg :: Alg w, Resolvable d) => d -> Scope -> w d+alg = runAlg ?alg++data ConstraintProxy (p :: * -> Constraint) = ConstraintProxy++defaultRtraverse+  :: (GTraversable Resolvable a, Applicative f, ?alg :: Alg f)+  => a -> Scope -> f a+defaultRtraverse a sc =+  let ?c = ConstraintProxy :: ConstraintProxy Resolvable+  in gtraverse (\a -> alg a sc) a++-- | A type that implements 'Resolvable' provides a way to perform+-- a shallow scope-aware traversal.++-- There is a generic implementation, 'defaultRtraverse', which is based on+-- 'GTraversable'. It can be used when there the scope of all the immediate+-- children is the same as the scope of the current node.+--+-- We use 'Typeable' here rather than a class-based approach.+-- Otherwise, hand-written instances would carry extremely long lists of+-- constraints, saying that the subterms satisfy the user-supplied class.+class Typeable a => Resolvable a where+  rtraverse+    :: (Applicative f, ?alg :: Alg f)+    => a -> Scope -> f a++instance (Typeable a, GTraversable Resolvable a) => Resolvable a where+  rtraverse = defaultRtraverse++-- | Analogous to 'gmap', but for 'Resolvable'+rmap+  :: Resolvable a+  => (forall b. Resolvable b => Scope -> b -> b)+  -> Scope -> a -> a+rmap f sc =+  let ?alg = Alg $ \a sc -> Identity (f sc a)+  in runIdentity . flip rtraverse sc++intro :: (SrcInfo l, GetBound a l) => a -> Scope -> Scope+intro node sc =+  modL lTable+    (\tbl -> foldl' (flip Local.addValue) tbl $+      getBound (sc ^. gTable) node)+    sc++setNameCtx :: NameContext -> Scope -> Scope+setNameCtx = setL nameCtx++setWcNames :: WcNames -> Scope -> Scope+setWcNames = setL wcNames++binderV :: Scope -> Scope+binderV = setNameCtx BindingV++binderT :: Scope -> Scope+binderT = setNameCtx BindingT++exprV :: Scope -> Scope+exprV = setNameCtx ReferenceV++exprT :: Scope -> Scope+exprT = setNameCtx ReferenceT
+ src/haskell-names/Language/Haskell/Names/Open/Derived.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}+module Language.Haskell.Names.Open.Derived where++import           Data.Generics.Traversable.TH+import           Language.Haskell.Exts.Annotated++deriveGTraversable ''ModuleName+deriveGTraversable ''SpecialCon+deriveGTraversable ''QName+deriveGTraversable ''Name+deriveGTraversable ''Boxed+deriveGTraversable ''IPName+deriveGTraversable ''QOp+deriveGTraversable ''Op+deriveGTraversable ''CName+deriveGTraversable ''Module+deriveGTraversable ''ModuleHead+deriveGTraversable ''ExportSpecList+deriveGTraversable ''ExportSpec+deriveGTraversable ''ImportDecl+deriveGTraversable ''ImportSpecList+deriveGTraversable ''ImportSpec+deriveGTraversable ''Assoc+deriveGTraversable ''Decl+deriveGTraversable ''Annotation+deriveGTraversable ''DataOrNew+deriveGTraversable ''DeclHead+deriveGTraversable ''InstHead+deriveGTraversable ''InstRule+deriveGTraversable ''Deriving+deriveGTraversable ''Binds+deriveGTraversable ''IPBind+deriveGTraversable ''Match+deriveGTraversable ''QualConDecl+deriveGTraversable ''ConDecl+deriveGTraversable ''FieldDecl+deriveGTraversable ''GadtDecl+deriveGTraversable ''ClassDecl+deriveGTraversable ''InstDecl+deriveGTraversable ''BangType+deriveGTraversable ''Rhs+deriveGTraversable ''GuardedRhs+deriveGTraversable ''Type+deriveGTraversable ''TyVarBind+deriveGTraversable ''Kind+deriveGTraversable ''FunDep+deriveGTraversable ''Context+deriveGTraversable ''Asst+deriveGTraversable ''Literal+deriveGTraversable ''Exp+deriveGTraversable ''XName+deriveGTraversable ''XAttr+deriveGTraversable ''Bracket+deriveGTraversable ''Splice+deriveGTraversable ''Safety+deriveGTraversable ''CallConv+deriveGTraversable ''ModulePragma+deriveGTraversable ''Tool+deriveGTraversable ''Activation+deriveGTraversable ''Rule+deriveGTraversable ''RuleVar+deriveGTraversable ''WarningText+deriveGTraversable ''Pat+deriveGTraversable ''PXAttr+deriveGTraversable ''RPatOp+deriveGTraversable ''RPat+deriveGTraversable ''PatField+deriveGTraversable ''Stmt+deriveGTraversable ''QualStmt+deriveGTraversable ''FieldUpdate+deriveGTraversable ''Alt+deriveGTraversable ''Promoted+deriveGTraversable ''BooleanFormula+deriveGTraversable ''TypeEqn+deriveGTraversable ''Overlap+deriveGTraversable ''Sign+deriveGTraversable ''Namespace
+ src/haskell-names/Language/Haskell/Names/Open/Instances.hs view
@@ -0,0 +1,362 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}++-- MonoLocalBinds extension prevents premature generalization, which+-- results in the "default" instance being picked.+{-# LANGUAGE MonoLocalBinds        #-}+module Language.Haskell.Names.Open.Instances () where++import           Language.Haskell.Names.GetBound+import           Language.Haskell.Names.Open.Base+import           Language.Haskell.Names.Open.Derived    ()+import           Language.Haskell.Names.RecordWildcards+import           Language.Haskell.Names.Types++import           Control.Applicative+import qualified Data.Data                              as D+import           Data.Lens.Light+import           Data.List+import qualified Data.Traversable                       as T+import           Data.Typeable+import           Language.Haskell.Exts.Annotated++c :: Applicative w => c -> w c+c = pure++(<|)+  :: (Applicative w, Resolvable b, ?alg :: Alg w)+  => w (b -> c) -> (b, Scope) -> w c+(<|) k (b, sc) = k <*> alg b sc+infixl 4 <|++(-:) :: Scope -> a -> (a, Scope)+sc -: b = (b, sc)+infix 5 -:++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Decl l) where+  rtraverse e sc =+    case e of+      -- N.B. We do not add pat to the local scope.+      --+      -- If this is a top-level binding, then we shouldn't do so, lest+      -- global values are marked as local.+      -- (see https://github.com/haskell-suite/haskell-names/issues/35)+      --+      -- If this is a local binding, then we have already introduced these+      -- variables when processing the enclosing Binds.+      PatBind l pat rhs mbWhere ->+        let+          scWithWhere = intro mbWhere sc+        in+        c PatBind+          <| sc                -: l+          <| sc                -: pat+          <| exprV scWithWhere -: rhs+          <| sc                -: mbWhere+      -- FunBind consists of Matches, which we handle below anyway.+      TypeSig l names ty ->+        c TypeSig+          <| sc       -: l+          <| exprV sc -: names+          <| sc       -: ty+      _ -> defaultRtraverse e sc++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Type l) where+  rtraverse e sc = defaultRtraverse e (exprT sc)++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (DeclHead l) where+  rtraverse e sc =+    case e of+      DHead l name ->+        c DHead+          <| sc -: l+          <| binderT sc -: name+      DHInfix l v1 name ->+        c DHInfix+          <| sc -: l+          <| sc -: v1+          <| binderT sc -: name+      _ -> defaultRtraverse e sc++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (ConDecl l) where+  rtraverse e sc =+    case e of+      ConDecl l name tys ->+        c ConDecl+          <| sc -: l+          <| binderV sc -: name+          <| sc -: tys+      InfixConDecl l t1 name t2 ->+        c InfixConDecl+          <| sc -: l+          <| sc -: t1+          <| binderV sc -: name+          <| sc -: t2+      RecDecl l name fields ->+        c RecDecl+          <| sc -: l+          <| binderV sc -: name+          <| sc -: fields+++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (FieldDecl l) where+  rtraverse e sc =+    case e of+      FieldDecl l name tys ->+        c FieldDecl+          <| sc -: l+          <| binderV sc -: name+          <| sc -: tys++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Pat l) where+  rtraverse e sc =+    case e of+      PVar l name ->+        c PVar+          <| sc         -: l+          <| binderV sc -: name+      PNPlusK l name i ->+        c PNPlusK+          <| sc         -: l+          <| binderV sc -: name+          <| sc         -: i+      PInfixApp l pat1 name pat2 ->+        c PInfixApp+          <| sc       -: l+          <| sc       -: pat1+          <| exprV sc -: name+          <| sc       -: pat2+      PApp l qn pat ->+        c PApp+          <| sc       -: l+          <| 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+          <| scWc     -: pfs+      PAsPat l n pat ->+        c PAsPat+          <| sc         -: l+          <| binderV sc -: n+          <| sc         -: pat+      PViewPat l exp pat ->+        c PViewPat+          <| sc       -: l+          <| exprV sc -: exp+          <| sc       -: pat+      _ -> defaultRtraverse e sc++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (PatField l) where+  rtraverse e sc =+    case e of+      PFieldPat l qn pat ->+        c PFieldPat+          <| sc       -: l+          <| exprV sc -: qn+          <| sc       -: pat+      PFieldPun l qn ->+        c PFieldPun+          <| sc -: l+          <| exprV sc -: qn+      -- 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+-- note [Nested pattern scopes]), statements.+chain+  :: ( Resolvable (a l)+     , GetBound (a l) l+     , Applicative w+     , SrcInfo l+     , D.Data l+     , ?alg :: Alg w)+  => [a l] -> Scope -> (w [a l], Scope)+chain pats sc =+  case pats of+    [] -> (pure [], sc)+    p:ps ->+      let+        sc' = intro p sc+        p' = alg p sc+        (ps', sc'') = chain ps sc'+      in ((:) <$> p' <*> ps', sc'')++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Match l) where+  rtraverse e sc =+    case e of+      Match l name pats rhs mbWhere ->+        -- f x y z = ...+        --   where ...+        let+          (pats', scWithPats) = chain pats sc+          scWithWhere = intro mbWhere scWithPats+        in+        c Match+          <| sc                -: l+          <| binderV sc        -: name+          <*> pats' -- has been already traversed+          <| exprV scWithWhere -: rhs+          <| scWithPats        -: mbWhere+      InfixMatch l pat1 name patsRest rhs mbWhere ->+        let+          equivalentMatch = Match l name (pat1:patsRest) rhs mbWhere+          back (Match l name (pat1:patsRest) rhs mbWhere) =+            InfixMatch l pat1 name patsRest rhs mbWhere+          back _ = error "InfixMatch"+        in back <$> rtraverse equivalentMatch sc++-- NB: there is an inefficiency here (and in similar places), because we+-- call intro on the same subtree several times. Maybe tackle it later.+instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Binds l) where+  rtraverse e sc =+    case e of+      BDecls l decls ->+        let scWithBinds = intro decls sc+        in+        c BDecls+          <| sc          -: l+          <| scWithBinds -: decls+      _ -> defaultRtraverse e sc++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Exp l) where+  rtraverse e sc =+    case e of+      Let l bnds body ->+        let scWithBinds = intro bnds sc+        in+        c Let+          <| sc          -: l+          <| scWithBinds -: bnds+          <| scWithBinds -: body++      Lambda l pats body ->+        let (pats', scWithPats) = chain pats sc+        in+        c Lambda+          <|  sc         -: l+          <*> pats'+          <|  scWithPats -: body++      ListComp l e stmts ->+        let (stmts', scWithStmts) = chain stmts sc+        in+        c ListComp+          <|  sc -: l+          <|  scWithStmts -: e+          <*> stmts'++      ParComp l e stmtss ->+        let+          (stmtss', scsWithStmts) =+            unzip $ map (\stmts -> chain stmts sc) stmtss+          scWithAllStmtss = foldl1' mergeLocalScopes scsWithStmts+        in+        c ParComp+          <|  sc -: l+          <|  scWithAllStmtss -: e+          <*> T.sequenceA stmtss'++      Proc l pat e ->+        let scWithPat = intro pat sc+        in+        c Proc+          <| 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++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Alt l) where+  rtraverse e sc =+    case e of+      Alt l pat guardedAlts mbWhere ->+        let+          scWithPat = intro pat sc+          scWithBinds = intro mbWhere scWithPat+        in+        c Alt+          <| sc -: l+          <| sc -: pat+          <| scWithBinds -: guardedAlts+          <| scWithBinds -: mbWhere++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (GuardedRhs l) where+  rtraverse e sc =+    case e of+      GuardedRhs l stmts exp ->+        let (stmts', scWithStmts) = chain stmts sc+        in+        c GuardedRhs+          <|  sc -: l+          <*> stmts'+          <|  scWithStmts -: exp++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable [Stmt l] where+  rtraverse e sc =+    fst $ chain e sc++instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (QualStmt l) where+  rtraverse e sc =+    case e of+      QualStmt {} -> defaultRtraverse e sc+      _ -> error "haskell-names: TransformListComp is not supported yet"++{-+Note [Nested pattern scopes]+~~~~~~~~~~~~~~~~~~~~~~++When we resolve a group of patterns, their scopes nest.++Most of the time, this is not important, but there are two exceptions:+1. ScopedTypeVariables++Example: f (x :: a) (y :: a) = ...++The first 'a' is a binder, the second — a reference.++2. View patterns++An expression inside a view pattern may reference the variables bound+earlier.++Example: f x (find (< x) -> Just y) = ...+-}++-- Some road-block Resolvable instances+instance Typeable a => Resolvable (Scoped a) where+  rtraverse = flip $ const pure+instance Resolvable SrcSpan where+  rtraverse = flip $ const pure+instance Resolvable SrcSpanInfo where+  rtraverse = flip $ const pure
+ src/haskell-names/Language/Haskell/Names/RecordWildcards.hs view
@@ -0,0 +1,145 @@+-- Wildcards are tricky, they deserve a module of their own+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternGuards  #-}+{-# LANGUAGE TupleSections  #-}+module Language.Haskell.Names.RecordWildcards+  ( patWcNames+  , wcFieldName+  , WcNames+  , expWcNames+  , wcFieldOrigName+  ) where++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.Types++import           Control.Monad+import qualified Data.Map                                 as Map+import           Data.Maybe+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts.Annotated++-- | 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 _ qn -> Just $ qNameToName qn+    PFieldWildcard {} -> Nothing++nameOfUpdField :: FieldUpdate l -> Maybe (Name l)+nameOfUpdField pf =+  case pf of+    FieldUpdate _ qn _ -> Just $ qNameToName qn+    FieldPun _ qn -> Just $ qNameToName qn+    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
+ src/haskell-names/Language/Haskell/Names/Recursive.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+module Language.Haskell.Names.Recursive+  ( computeInterfaces+  , getInterfaces+  , annotateModule+  ) where++import           Fay.Compiler.ModuleT+import           Language.Haskell.Names.Annotated+import           Language.Haskell.Names.Exports+import           Language.Haskell.Names.Imports+import           Language.Haskell.Names.ModuleSymbols+import           Language.Haskell.Names.Open.Base+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Control.Monad                        hiding (forM_)+import           Data.Data                            (Data)+import           Data.Foldable+import           Data.Graph                           (flattenSCC, stronglyConnComp)+import           Data.Maybe+import           Data.Monoid+import qualified Data.Set                             as Set+import           Language.Haskell.Exts.Annotated+++-- | Take a set of modules and return a list of sets, where each sets for+-- a strongly connected component in the import graph.+-- The boolean determines if imports using @SOURCE@ are taken into account.+groupModules :: forall l . [Module l] -> [[Module l]]+groupModules modules =+  map flattenSCC $ stronglyConnComp $ map mkNode modules+  where+    mkNode :: Module l -> (Module l, ModuleName (), [ModuleName ()])+    mkNode m =+      ( m+      , dropAnn $ getModuleName m+      , map (dropAnn . importModule) $ getImports m+      )++-- | Annotate a module with scoping information. This assumes that all+-- module dependencies have been resolved and cached — usually you need+-- to run 'computeInterfaces' first, unless you have one module in+-- isolation.+annotateModule+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Eq l)+  => Language -- ^ base language+  -> [Extension] -- ^ global extensions (e.g. specified on the command line)+  -> Module l -- ^ input module+  -> m (Module (Scoped l)) -- ^ output (annotated) module+annotateModule lang exts mod@(Module lm mh os is ds) = do+  let extSet = moduleExtensions lang exts mod+  (imp, impTbl) <- processImports extSet is+  let tbl = moduleTable impTbl mod+  (exp, _syms) <- processExports tbl mod++  let+    lm' = none lm+    os' = fmap noScope os+    is' = imp+    ds' = annotate (initialScope tbl) `map` ds++    mh' = flip fmap mh $ \(ModuleHead lh n mw _me) ->+      let+        lh' = none lh+        n'  = noScope n+        mw' = fmap noScope mw+        me' = exp+      in ModuleHead lh' n' mw' me'++  return $ Module lm' mh' os' is' ds'++annotateModule _ _ _ = error "annotateModule: non-standard modules are not supported"++-- | Compute interfaces for a set of mutually recursive modules and write+-- the results to the cache. Return the set of import/export errors.+findFixPoint+  :: (Ord l, Data l, MonadModule m, ModuleInfo m ~ Symbols)+  => [(Module l, ExtensionSet)]+      -- ^ module and all extensions with which it is to be compiled.+      -- Use 'moduleExtensions' to build this list.+  -> m (Set.Set (Error l))+findFixPoint mods = go mods (map (const mempty) mods) where+  go mods syms = do+    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 tbl = moduleTable impTbl m+      (exp, syms) <- processExports tbl m+      return (syms, foldMap getErrors imp <> foldMap getErrors exp)+    if syms' == syms+      then return $ mconcat errors+      else go mods syms'++-- | 'computeInterfaces' takes a list of possibly recursive modules and+-- computes the interface of each module. The computed interfaces are+-- written into the @m@'s cache and are available to further computations+-- in this monad.+--+-- Returns the set of import/export errors. Note that the interfaces are+-- registered in the cache regardless of whether there are any errors, but+-- if there are errors, the interfaces may be incomplete.+computeInterfaces+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)+  => Language -- ^ base language+  -> [Extension] -- ^ global extensions (e.g. specified on the command line)+  -> [Module l] -- ^ input modules+  -> m (Set.Set (Error l)) -- ^ errors in export or import lists+computeInterfaces lang exts =+  liftM fold . mapM findFixPoint . map supplyExtensions . groupModules+    where+    supplyExtensions = map $ \m -> (m, moduleExtensions lang exts m)++-- | Like 'computeInterfaces', but also returns a list of interfaces, one+-- per module and in the same order+getInterfaces+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)+  => Language -- ^ base language+  -> [Extension] -- ^ global extensions (e.g. specified on the command line)+  -> [Module l] -- ^ input modules+  -> m ([Symbols], Set.Set (Error l)) -- ^ output modules, and errors in export or import lists+getInterfaces lang exts mods = do+  errs <- computeInterfaces lang exts mods+  ifaces <- forM mods $ \mod ->+    let modName = getModuleName mod in+    fromMaybe (error $ msg modName) `liftM` lookupInCache modName+  return (ifaces, errs)+  where+    msg modName = "getInterfaces: module " ++ modToString modName ++ " is not in the cache"
+ src/haskell-names/Language/Haskell/Names/ScopeUtils.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+module Language.Haskell.Names.ScopeUtils+  ( computeSymbolTable+  , noScope+  , none+  , resolveCNames+  , scopeError+  , sv_parent+  ) where++import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Control.Applicative+import           Control.Arrow+import           Data.Lens.Light+import           Data.Monoid+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts.Annotated++scopeError :: Functor f => Error l -> f l -> f (Scoped l)+scopeError e f = Scoped (ScopeError e) <$> f++none :: l -> Scoped l+none = Scoped None++noScope :: (Annotated a) => a l -> a (Scoped l)+noScope = fmap none++sv_parent :: SymValueInfo n -> Maybe n+sv_parent (SymSelector { sv_typeName = n }) = Just n+sv_parent (SymConstructor { sv_typeName = n }) = Just n+sv_parent (SymMethod { sv_className = n }) = Just n+sv_parent _ = Nothing++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+computeSymbolTable qual (ModuleName _ mod) syms =+  Global.fromLists $+    if qual+      then renamed+      else renamed <> unqualified+  where+    vs = Set.toList $ syms^.valSyms+    ts = Set.toList $ syms^.tySyms+    renamed = renameSyms mod+    unqualified = renameSyms ""+    renameSyms mod = (map (rename mod) vs, map (rename mod) ts)+    rename :: HasOrigName i => ModuleNameS -> i OrigName -> (GName, i OrigName)+    rename m v = ((origGName . origName $ v) { gModule = m }, v)++resolveCName+  :: Symbols+  -> OrigName+  -> (CName l -> Error l) -- ^ error for "not found" condition+  -> CName l+  -> (CName (Scoped l), Symbols)+resolveCName syms parent notFound cn =+  let+    vs =+      [ info+      | info <- Set.toList $ syms^.valSyms+      , let name = gName . origGName $ sv_origName info+      , nameToString (unCName cn) == name+      , Just p <- return $ sv_parent info+      , p == parent+      ]+  in+    case vs of+      [] -> (scopeError (notFound cn) cn, mempty)+      [i] -> (Scoped (GlobalValue i) <$> cn, mkVal i)+      _ -> (scopeError (EInternal "resolveCName") cn, mempty)++resolveCNames+  :: Symbols+  -> OrigName+  -> (CName l -> Error l) -- ^ error for "not found" condition+  -> [CName l]+  -> ([CName (Scoped l)], Symbols)+resolveCNames syms orig notFound =+  second mconcat . unzip . map (resolveCName syms orig notFound)
+ src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs view
@@ -0,0 +1,135 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+module Language.Haskell.Names.SyntaxUtils+  ( dropAnn+  , getModuleName+  , getImports+  , getExportSpecList+  , getDeclHeadName+  , getModuleDecls+  , nameToString+  , stringToName+  , qNameToName+  , unCName+  , getErrors+  , moduleExtensions+  ) where++import           Language.Haskell.Names.Types++import           Data.Char+import           Data.Either+import           Data.Foldable+import           Data.Maybe+import qualified Data.Set                        as Set+import           Language.Haskell.Exts.Annotated++dropAnn :: (Functor a) => a l -> a ()+dropAnn = fmap (const ())++getModuleName :: Module l -> ModuleName l+getModuleName (Module _ (Just (ModuleHead _ mn _ _)) _ _ _) = mn+getModuleName (XmlPage _ mn _ _ _ _ _) = mn+getModuleName (XmlHybrid _ (Just (ModuleHead _ mn _ _)) _ _ _ _ _ _ _) = mn+getModuleName m = main_mod (ann m)++getImports :: Module l -> [ImportDecl l]+getImports (Module _ _ _ is _) = is+getImports (XmlPage _ _ _ _ _ _ _) = []+getImports (XmlHybrid _ _ _ is _ _ _ _ _) = is++getModuleDecls :: Module l -> [Decl l]+getModuleDecls (Module _ _ _ _ ds) = ds+getModuleDecls (XmlPage _ _ _ _ _ _ _) = []+getModuleDecls (XmlHybrid _ _ _ _ ds _ _ _ _) = ds++getExportSpecList :: Module l -> Maybe (ExportSpecList l)+getExportSpecList m = me where ModuleHead _ _ _ me = getModuleHead m++getModuleHead :: Module l -> ModuleHead l+getModuleHead (Module _ (Just mh) _ _ _) = mh+getModuleHead (XmlHybrid _ (Just mh) _ _ _ _ _ _ _) = mh+getModuleHead m = ModuleHead l (main_mod l) Nothing (Just (ExportSpecList l [EVar l (NoNamespace l) (UnQual l (Ident l "main"))]))+  where l = ann m++qNameToName :: QName l -> Name l+qNameToName (UnQual _ n) = n+qNameToName (Qual _ _ n) = n+qNameToName (Special l s) = Ident l (specialConToString s)++getDeclHeadName :: DeclHead l -> Name l+getDeclHeadName dh =+  case dh of+    DHead _ n -> n+    DHInfix _ _ n -> n+    DHParen _ dh' -> getDeclHeadName dh'+    DHApp _ dh' _ -> getDeclHeadName dh'++----------------------------------------------------++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 _)            = "()"+specialConToString (ListCon _)            = "[]"+specialConToString (FunCon _)             = "->"+specialConToString (TupleCon _ Boxed n)   = replicate (n-1) ','+specialConToString (TupleCon _ Unboxed n) = '#':replicate (n-1) ','+specialConToString (Cons _)               = ":"+specialConToString (UnboxedSingleCon _)   = "#"++unCName :: CName l -> Name l+unCName (VarName _ n) = n+unCName (ConName _ n) = n++getErrors :: (Ord l, Foldable a) => a (Scoped l) -> Set.Set (Error l)+getErrors = foldl' f Set.empty+  where+    f errors (Scoped (ScopeError e) _) = Set.insert e errors+    f errors _ = errors++-- | Compute the extension set for the given module, based on the global+-- preferences (e.g. specified on the command line) and module's LANGUAGE+-- pragmas.+moduleExtensions+  :: Language    -- ^ base language+  -> [Extension] -- ^ global extensions+  -> Module l+  -> ExtensionSet+moduleExtensions globalLang globalExts mod =+  let+    (mbModLang, modExts) = getModuleExtensions mod+    lang = fromMaybe globalLang mbModLang+    kexts = toExtensionList lang (globalExts ++ modExts)+  in Set.fromList kexts++getModuleExtensions :: Module l -> (Maybe Language, [Extension])+getModuleExtensions mod =+  let+    names =+      [ name+      | let+          pragmas =+            case mod of+              Module _ _ pragmas _ _ -> pragmas+              XmlPage _ _ pragmas _ _ _ _ -> pragmas+              XmlHybrid _ _ pragmas _ _ _ _ _ _ -> pragmas+      , LanguagePragma _ names <- pragmas+      , Ident _ name <- names+      ]++    classified :: [Either Language Extension]+    classified =+      flip map names $ \name ->+        case (parseExtension name, classifyLanguage name) of+          (e, UnknownLanguage {}) -> Right e+          (_, l) -> Left l++    (langs, exts) = partitionEithers classified+  in+    (if null langs then Nothing else Just $ last langs, exts)
+ src/haskell-names/Language/Haskell/Names/Types.hs view
@@ -0,0 +1,290 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE StandaloneDeriving #-}+module Language.Haskell.Names.Types+  ( Error (..)+  , ExtensionSet+  , GName (..)+  , HasOrigName (..)+  , ModuleNameS+  , NameInfo (..)+  , NameS+  , OrigName (..)+  , Scoped (..)+  , SymTypeInfo (..)+  , SymValueInfo (..)+  , Symbols (..)+  , mkTy+  , mkVal+  , ppError+  , ppGName+  , ppOrigName+  , sLoc+  , tySyms+  , valSyms+  ) where++import {-# SOURCE #-} qualified Language.Haskell.Names.GlobalSymbolTable as Global++import           Data.Data+import           Data.Foldable                            as F+import           Data.Lens.Light+import           Data.Monoid+import qualified Data.Set                                 as Set+import           Data.Traversable+import           Language.Haskell.Exts.Annotated+import           Text.Printf++type ExtensionSet = Set.Set KnownExtension++-- | Repesents the symbol's fixity+type SymFixity = (Assoc (), Int)++-- | Information about a value-level entitity+data SymValueInfo name+    = SymValue+      { sv_origName :: name+      , sv_fixity   :: Maybe SymFixity+      }+      -- ^ value or function+    | SymMethod+      { sv_origName  :: name+      , sv_fixity    :: Maybe SymFixity+      , sv_className :: name+      }+      -- ^ class method+    | SymSelector+      { sv_origName     :: name+      , sv_fixity       :: Maybe SymFixity+      , sv_typeName     :: name+      , sv_constructors :: [name]+      }+      -- ^ record field selector+    | SymConstructor+      { sv_origName :: name+      , sv_fixity   :: Maybe SymFixity+      , sv_typeName :: name+      }+      -- ^ data constructor+    deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)++-- | Information about a type-level entitity+data SymTypeInfo name+    = SymType+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ type synonym+    | SymData+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ data type+    | SymNewType+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ newtype+    | SymTypeFam+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ type family+    | SymDataFam+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ data family+    | SymClass+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ type class+    deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)++class HasOrigName i where+  origName :: i n -> n++instance HasOrigName SymValueInfo where+  origName = sv_origName++instance HasOrigName SymTypeInfo where+  origName = st_origName++-- | The set of symbols (entities) exported by a single module. Contains+-- the sets of value-level and type-level entities.+data Symbols = Symbols (Set.Set (SymValueInfo OrigName)) (Set.Set (SymTypeInfo OrigName))+  deriving (Eq, Ord, Show, Data, Typeable)++instance Monoid Symbols where+  mempty = Symbols mempty mempty+  mappend (Symbols s1 t1) (Symbols s2 t2) =+    Symbols (s1 `mappend` s2) (t1 `mappend` t2)++valSyms :: Lens Symbols (Set.Set (SymValueInfo OrigName))+valSyms = lens (\(Symbols vs _) -> vs) (\vs (Symbols _ ts) -> Symbols vs ts)++tySyms :: Lens Symbols (Set.Set (SymTypeInfo OrigName))+tySyms = lens (\(Symbols _ ts) -> ts) (\ts (Symbols vs _) -> Symbols vs ts)++mkVal :: SymValueInfo OrigName -> Symbols+mkVal i = Symbols (Set.singleton i) mempty++mkTy :: SymTypeInfo OrigName -> Symbols+mkTy i = Symbols mempty (Set.singleton i)++-- | String representing an unqualified entity name+type NameS = String+-- | String representing a module name+type ModuleNameS = String++-- | Possibly qualified name. If the name is not qualified,+-- 'ModuleNameS' is the empty string.+data GName = GName+  { gModule :: ModuleNameS+  , gName   :: NameS+  }+  deriving (Eq, Ord, Show, Data, Typeable)++-- | Display a 'GName'+ppGName :: GName -> String+ppGName (GName mod name) = printf "%s.%s" mod name++-- # if !MIN_VERSION_Cabal(1,17,0)+-- deriving instance Typeable PackageIdentifier+-- deriving instance Data PackageIdentifier+-- deriving instance Typeable PackageName+-- deriving instance Data PackageName+-- deriving instance Data Version+-- # endif++-- | Qualified name, where 'ModuleNameS' points to the module where the+-- name was originally defined. The module part is never empty.+--+-- Also contains name and version of the package where it was defined. If+-- it's 'Nothing', then the entity is defined in the \"current\" package.+data OrigName = OrigName+  { origGName :: GName+  }+  deriving (Eq, Ord, Show, Data, Typeable)++-- | Display an 'OrigName'+ppOrigName :: OrigName -> String+ppOrigName (OrigName gname) = ppGName gname++-- | A pair of the name information and original annotation. Used as an+-- annotation type for AST.+data Scoped l = Scoped (NameInfo l) l+  deriving (Functor, Foldable, Traversable, Show, Typeable, Data, Eq, Ord)++data NameInfo l+    = GlobalValue (SymValueInfo OrigName) -- ^ global value+    | GlobalType  (SymTypeInfo  OrigName) -- ^ global type+    | LocalValue  SrcLoc -- ^ local value, and location where it is bound+    | TypeVar     SrcLoc -- ^ type variable, and location where it is bound+    | ValueBinder -- ^ here the value name is bound+    | TypeBinder  -- ^ here the type name is defined+    | Import      Global.Table+      -- ^ @import@ declaration, and the table of symbols that it+      -- introduces+    | ImportPart  Symbols+      -- ^ 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)+      -- ^ scope error+    deriving (Functor, Foldable, Traversable, Show, Typeable, Data, Eq, Ord)++data Error l+  = ENotInScope (QName l) -- FIXME annotate with namespace (types/values)+    -- ^ name is not in scope+  | EAmbiguous (QName l) [OrigName]+    -- ^ name is ambiguous+  | ETypeAsClass (QName l)+    -- ^ type is used where a type class is expected+  | EClassAsType (QName l)+    -- ^ type class is used where a type is expected+  | ENotExported+      (Maybe (Name l)) --+      (Name l)         --+      (ModuleName l)+    -- ^ Attempt to explicitly import a name which is not exported (or,+    -- possibly, does not even exist). For example:+    --+    -- >import Prelude(Bool(Right))+    --+    -- The fields are:+    --+    -- 1. optional parent in the import list, e.g. @Bool@ in @Bool(Right)@+    --+    -- 2. the name which is not exported+    --+    -- 3. the module which does not export the name+  | EModNotFound (ModuleName l)+    -- ^ module not found+  | EInternal String+    -- ^ internal error+  deriving (Data, Typeable, Show, Functor, Foldable, Traversable, Eq, Ord)++-- | Display an error.+--+-- Note: can span multiple lines; the trailing newline is included.+ppError :: SrcInfo l => Error l -> String+ppError e =+  case e of+    ENotInScope qn -> printf "%s: not in scope: %s\n"+      (ppLoc qn)+      (prettyPrint qn)+    EAmbiguous qn names ->+      printf "%s: ambiguous name %s\nIt may refer to:\n"+        (ppLoc qn)+        (prettyPrint qn)+      +++        F.concat (map (printf "  %s\n" . ppOrigName) names)+    ETypeAsClass qn ->+      printf "%s: type %s is used where a class is expected\n"+        (ppLoc qn)+        (prettyPrint qn)+    EClassAsType qn ->+      printf "%s: class %s is used where a type is expected\n"+        (ppLoc qn)+        (prettyPrint qn)+    ENotExported _mbParent name mod ->+      printf "%s: %s does not export %s\n"+        (ppLoc name)+        (prettyPrint mod)+        (prettyPrint name)+        -- FIXME: make use of mbParent+    EModNotFound mod ->+      printf "%s: module not found: %s\n"+        (ppLoc mod)+        (prettyPrint mod)+    EInternal s -> printf "Internal error: %s\n" s++  where+    ppLoc :: (Annotated a, SrcInfo l) => a l -> String+    ppLoc = prettyPrint . getPointLoc . ann++instance (SrcInfo l) => SrcInfo (Scoped l) where+    toSrcInfo l1 ss l2 = Scoped None $ toSrcInfo l1 ss l2+    fromSrcInfo = Scoped None . fromSrcInfo+    getPointLoc = getPointLoc . sLoc+    fileName = fileName . sLoc+    startLine = startLine . sLoc+    startColumn = startColumn . sLoc++sLoc :: Scoped l -> l+sLoc (Scoped _ l) = l