diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ See full history at: +#### 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.* diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -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 diff --git a/src/Fay/Compiler.hs b/src/Fay/Compiler.hs --- a/src/Fay/Compiler.hs +++ b/src/Fay/Compiler.hs @@ -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 diff --git a/src/Fay/Compiler/Exp.hs b/src/Fay/Compiler/Exp.hs --- a/src/Fay/Compiler/Exp.hs +++ b/src/Fay/Compiler/Exp.hs @@ -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 diff --git a/src/Fay/Compiler/InitialPass.hs b/src/Fay/Compiler/InitialPass.hs --- a/src/Fay/Compiler/InitialPass.hs +++ b/src/Fay/Compiler/InitialPass.hs @@ -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 () diff --git a/src/Fay/Compiler/Misc.hs b/src/Fay/Compiler/Misc.hs --- a/src/Fay/Compiler/Misc.hs +++ b/src/Fay/Compiler/Misc.hs @@ -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 diff --git a/src/Fay/Compiler/ModuleT.hs b/src/Fay/Compiler/ModuleT.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/ModuleT.hs @@ -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) diff --git a/src/Fay/Compiler/Pattern.hs b/src/Fay/Compiler/Pattern.hs --- a/src/Fay/Compiler/Pattern.hs +++ b/src/Fay/Compiler/Pattern.hs @@ -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] diff --git a/src/Fay/Compiler/State.hs b/src/Fay/Compiler/State.hs --- a/src/Fay/Compiler/State.hs +++ b/src/Fay/Compiler/State.hs @@ -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) diff --git a/src/Fay/Exts/Scoped.hs b/src/Fay/Exts/Scoped.hs --- a/src/Fay/Exts/Scoped.hs +++ b/src/Fay/Exts/Scoped.hs @@ -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 diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -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 diff --git a/src/haskell-names/LICENSE b/src/haskell-names/LICENSE new file mode 100644 --- /dev/null +++ b/src/haskell-names/LICENSE @@ -0,0 +1,3 @@ +Forked from haskell-names +Licensed as BSD3 +Authors: Roman Cheplyaka, Lennart Augustsson diff --git a/src/haskell-names/Language/Haskell/Names.hs b/src/haskell-names/Language/Haskell/Names.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names.hs @@ -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) diff --git a/src/haskell-names/Language/Haskell/Names/Annotated.hs b/src/haskell-names/Language/Haskell/Names/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Annotated.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Exports.hs b/src/haskell-names/Language/Haskell/Names/Exports.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Exports.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/GetBound.hs b/src/haskell-names/Language/Haskell/Names/GetBound.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/GetBound.hs @@ -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 _ = [] diff --git a/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Imports.hs b/src/haskell-names/Language/Haskell/Names/Imports.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Imports.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs b/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs b/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs @@ -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 + ] diff --git a/src/haskell-names/Language/Haskell/Names/Open/Base.hs b/src/haskell-names/Language/Haskell/Names/Open/Base.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Open/Base.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Open/Derived.hs b/src/haskell-names/Language/Haskell/Names/Open/Derived.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Open/Derived.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Open/Instances.hs b/src/haskell-names/Language/Haskell/Names/Open/Instances.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Open/Instances.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs b/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Recursive.hs b/src/haskell-names/Language/Haskell/Names/Recursive.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Recursive.hs @@ -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" diff --git a/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs b/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs @@ -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) diff --git a/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs b/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs @@ -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) diff --git a/src/haskell-names/Language/Haskell/Names/Types.hs b/src/haskell-names/Language/Haskell/Names/Types.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Types.hs @@ -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