diff --git a/haskell-names.cabal b/haskell-names.cabal --- a/haskell-names.cabal +++ b/haskell-names.cabal @@ -1,5 +1,5 @@ Name: haskell-names -Version: 0.1.2 +Version: 0.2 License: BSD3 Author: Roman Cheplyaka, Lennart Augustsson Maintainer: Roman Cheplyaka @@ -232,7 +232,7 @@ source-repository this type: git location: git://github.com/haskell-suite/haskell-names.git - tag: v0.1.2 + tag: v0.2 Library Default-Language: Haskell2010 diff --git a/src/Language/Haskell/Names.hs b/src/Language/Haskell/Names.hs --- a/src/Language/Haskell/Names.hs +++ b/src/Language/Haskell/Names.hs @@ -20,6 +20,7 @@ , Error(..) , ppError , SymFixity + , HasOrigName(..) ) where import Language.Haskell.Names.Types diff --git a/src/Language/Haskell/Names/Annotated.hs b/src/Language/Haskell/Names/Annotated.hs --- a/src/Language/Haskell/Names/Annotated.hs +++ b/src/Language/Haskell/Names/Annotated.hs @@ -37,8 +37,18 @@ annotateRec _ sc a = go sc a where go :: forall a . Resolvable a => Scope -> a -> a go sc a - | Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq + | 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 | otherwise = rmap go sc a @@ -53,3 +63,12 @@ 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/Language/Haskell/Names/Open.hs b/src/Language/Haskell/Names/Open.hs --- a/src/Language/Haskell/Names/Open.hs +++ b/src/Language/Haskell/Names/Open.hs @@ -1,6 +1,7 @@ -- Public interface for open resolution module Language.Haskell.Names.Open ( Resolvable(..) + , Alg(..) , rmap , Scope , NameContext(..) diff --git a/src/Language/Haskell/Names/Open/Base.hs b/src/Language/Haskell/Names/Open/Base.hs --- a/src/Language/Haskell/Names/Open/Base.hs +++ b/src/Language/Haskell/Names/Open/Base.hs @@ -15,7 +15,12 @@ import Data.Typeable import GHC.Exts (Constraint) -data NameContext = Binding | Reference | Other +data NameContext + = BindingT + | BindingV + | ReferenceT + | ReferenceV + | Other -- ^ we don't expect names in this context data Scope = Scope { _gTable :: Global.Table @@ -25,8 +30,8 @@ makeLens ''Scope -initialScope :: Scope -initialScope = Scope Global.empty Local.empty Reference +initialScope :: Global.Table -> Scope +initialScope tbl = Scope tbl Local.empty Other newtype Alg w = Alg { runAlg :: forall d . Resolvable d => d -> Scope -> w d } @@ -71,5 +76,14 @@ setNameCtx :: NameContext -> Scope -> Scope setNameCtx ctx = setL nameCtx ctx -binder :: Scope -> Scope -binder = setNameCtx Binding +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/Language/Haskell/Names/Open/Derived.hs b/src/Language/Haskell/Names/Open/Derived.hs --- a/src/Language/Haskell/Names/Open/Derived.hs +++ b/src/Language/Haskell/Names/Open/Derived.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, ConstraintKinds, UndecidableInstances #-} module Language.Haskell.Names.Open.Derived where diff --git a/src/Language/Haskell/Names/Open/Instances.hs b/src/Language/Haskell/Names/Open/Instances.hs --- a/src/Language/Haskell/Names/Open/Instances.hs +++ b/src/Language/Haskell/Names/Open/Instances.hs @@ -40,13 +40,119 @@ scWithWhere = intro mbWhere scWithPat in c PatBind - <| sc -: l - <| sc -: pat - <| sc -: mbType - <| scWithWhere -: rhs - <| scWithPat -: mbWhere + <| sc -: l + <| sc -: pat + <| sc -: mbType + <| exprV scWithWhere -: rhs + <| scWithPat -: 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 tyVars -> + c DHead + <| sc -: l + <| binderT sc -: name + <| sc -: tyVars + DHInfix l v1 name v2 -> + c DHInfix + <| sc -: l + <| sc -: v1 + <| binderT sc -: name + <| sc -: v2 + _ -> 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 -> + c PRec + <| sc -: l + <| exprV sc -: qn + <| sc -: 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 {} -> error "haskell-names: field puns are not supported" + PFieldWildcard {} -> error "haskell-names: record wildcards are not supported" + -- | 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. @@ -79,11 +185,11 @@ scWithWhere = intro mbWhere scWithPats in c Match - <| sc -: l - <| binder sc -: name + <| sc -: l + <| binderV sc -: name <*> pats' -- has been already traversed - <| scWithWhere -: rhs - <| scWithPats -: mbWhere + <| exprV scWithWhere -: rhs + <| scWithPats -: mbWhere InfixMatch l pat1 name patsRest rhs mbWhere -> let equivalentMatch = Match l name (pat1:patsRest) rhs mbWhere diff --git a/src/Language/Haskell/Names/Recursive.hs b/src/Language/Haskell/Names/Recursive.hs --- a/src/Language/Haskell/Names/Recursive.hs +++ b/src/Language/Haskell/Names/Recursive.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} module Language.Haskell.Names.Recursive ( computeInterfaces , getInterfaces @@ -21,17 +21,17 @@ import Language.Haskell.Names.ModuleSymbols import Language.Haskell.Names.Exports import Language.Haskell.Names.Imports -import qualified Language.Haskell.Names.LocalSymbolTable as Local import Language.Haskell.Names.Open.Base import Language.Haskell.Names.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 :: [Module l] -> [[Module l]] +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 @@ -59,7 +59,7 @@ lm' = none lm os' = fmap noScope os is' = imp - ds' = annotate (Scope tbl Local.empty Reference) `map` ds + ds' = annotate (initialScope tbl) `map` ds mh' = flip fmap mh $ \(ModuleHead lh n mw _me) -> let diff --git a/src/Language/Haskell/Names/ScopeUtils.hs b/src/Language/Haskell/Names/ScopeUtils.hs --- a/src/Language/Haskell/Names/ScopeUtils.hs +++ b/src/Language/Haskell/Names/ScopeUtils.hs @@ -17,9 +17,6 @@ none :: l -> Scoped l none = Scoped None -binder :: l -> Scoped l -binder = Scoped Binder - noScope :: (Annotated a) => a l -> a (Scoped l) noScope = fmap none diff --git a/src/Language/Haskell/Names/SyntaxUtils.hs b/src/Language/Haskell/Names/SyntaxUtils.hs --- a/src/Language/Haskell/Names/SyntaxUtils.hs +++ b/src/Language/Haskell/Names/SyntaxUtils.hs @@ -191,6 +191,7 @@ getBound p = [ n | p' <- universe $ transform dropExp p, n <- varp p' ] where varp (PVar _ n) = [n] varp (PAsPat _ n _) = [n] + varp (PNPlusK _ n _) = [n] varp _ = [] dropExp (PViewPat _ _ x) = x -- must remove nested Exp so universe doesn't descend into them dropExp x = x diff --git a/src/Language/Haskell/Names/Types.hs b/src/Language/Haskell/Names/Types.hs --- a/src/Language/Haskell/Names/Types.hs +++ b/src/Language/Haskell/Names/Types.hs @@ -10,11 +10,13 @@ import qualified Data.Set as Set import {-# SOURCE #-} qualified Language.Haskell.Names.GlobalSymbolTable as Global import Distribution.Package -import Data.Version import Distribution.Text import Data.Foldable as F import Data.Traversable import Text.Printf +#if ! MIN_VERSION_Cabal(1,17,0) +import Data.Version +#endif type ExtensionSet = Set.Set KnownExtension @@ -162,7 +164,8 @@ | 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 - | Binder -- ^ here the name 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 diff --git a/tests/run.hs b/tests/run.hs --- a/tests/run.hs +++ b/tests/run.hs @@ -1,5 +1,7 @@ +-- vim:fdm=marker:foldtext=foldtext() {-# LANGUAGE FlexibleInstances, OverlappingInstances, ImplicitParams, - MultiParamTypeClasses #-} + MultiParamTypeClasses, FlexibleContexts #-} +-- Imports {{{ import Test.Tasty hiding (defaultMain) import Test.Tasty.Golden import Test.Tasty.Golden.Manage @@ -13,7 +15,7 @@ import Control.Monad.Identity import Control.Applicative import Control.Monad.Trans -import Text.Show.Pretty +import Text.Show.Pretty (ppShow) import Text.Printf import qualified Data.Foldable as F @@ -32,15 +34,21 @@ import Data.Generics.Traversable import Data.Proxy +-- }}} +-- Common definitions {{{ type MT = ModuleT Symbols IO main = defaultMain . testGroup "Tests" =<< tests +-- All tests are created in the same ModuleT session. This means that +-- export tests are available for import in subsequent tests (because of +-- the getIfaces call). However, import tests are not registered in the +-- monad, so they are not available for import. + tests = liftM concat . sequence $ - [ evalNamesModuleT (sequence [exportTests, importTests]) [] - , sequence [annotationTests] + [ evalNamesModuleT (sequence [exportTests, importTests, annotationTests]) [] ] parseAndPrepare file = @@ -50,9 +58,14 @@ exts = [DisableExtension ImplicitPrelude] getIfaces = getInterfaces lang exts +getTestFiles :: MonadIO m => FilePath -> m [FilePath] +getTestFiles dir = liftIO $ find (return True) (extension ==? ".hs") dir +-- }}} + ----------------------------------------------------- -- Export test: parse a source file, dump its symbols ----------------------------------------------------- +-- {{{ exportTest file iface = goldenVsFile file golden out run where @@ -62,7 +75,7 @@ exportTests :: MT TestTree exportTests = do - testFiles <- liftIO $ find (return True) (extension ==? ".hs") "tests/exports" + testFiles <- getTestFiles "tests/exports" parsed <- liftIO $ mapM parseAndPrepare testFiles (ifaces, errors) <- getIfaces parsed @@ -74,10 +87,12 @@ exitFailure return $ testGroup "exports" $ zipWith exportTest testFiles ifaces +-- }}} ---------------------------------------------------------- -- Import test: parse a source file, dump its global table ---------------------------------------------------------- +-- {{{ importTest :: FilePath -> Global.Table -> TestTree importTest file tbl = goldenVsFile file golden out run @@ -95,13 +110,16 @@ importTests :: MT TestTree importTests = do - testFiles <- liftIO $ find (return True) (extension ==? ".hs") "tests/imports" + testFiles <- getTestFiles "tests/imports" filesAndTables <- forM testFiles $ \file -> (,) file <$> getGlobalTable file return $ testGroup "imports" $ map (uncurry importTest) filesAndTables +-- }}} ------------------------------------------------------------------ -- Annotation test: parse the source, annotate it and pretty-print ------------------------------------------------------------------ +-- {{{ +-- Code to retrieve annotations from the AST using GTraversable class TestAnn a where getAnn :: a -> Maybe (String, Scoped SrcSpan) @@ -111,6 +129,9 @@ instance TestAnn (QName (Scoped SrcSpan)) where getAnn qn = Just (nameToString . qNameToName $ qn, ann qn) +instance TestAnn (Name (Scoped SrcSpan)) where + getAnn n = Just (nameToString n, ann n) + instance GTraversable (Rec TestAnn) (Scoped SrcSpan) where gtraverse _ x = pure x @@ -129,23 +150,29 @@ go a = one a ++ gfoldMap go a in go -annotationTest file = goldenVsFile file golden out run +-- Actual tests +annotationTest file annotatedMod = goldenVsFile file golden out run where golden = file <.> "golden" out = file <.> "out" run = do - mod <- parseAndPrepare file - let annotatedMod = annotate initialScope mod - -- writeFile out $ ppShow $ fmap void annotatedMod - writeFile out $ printAnns annotatedMod + liftIO $ writeFile out $ printAnns annotatedMod +getAnnotated file = do + mod <- liftIO $ parseAndPrepare file + annotateModule lang exts mod + annotationTests = do - testFiles <- find (return True) (extension ==? ".hs") "tests/annotations" - return $ testGroup "annotations" $ map annotationTest testFiles + testFiles <- getTestFiles "tests/annotations" + filesAndMods <- forM testFiles $ \file -> (,) file <$> getAnnotated file + return $ testGroup "annotations" $ + map (uncurry annotationTest) filesAndMods +-- }}} ----------------------- -- Formatting utilities ----------------------- +-- {{{ formatLoc :: SrcInfo l => l -> String formatLoc srcInfo = let loc = getPointLoc srcInfo in @@ -153,11 +180,37 @@ (srcLine loc) (srcColumn loc) +formatValueNamespace SymValue {} = "value" +formatValueNamespace SymMethod {} = "method" +formatValueNamespace SymSelector {} = "selector" +formatValueNamespace SymConstructor {} = "constructor" + +formatTypeNamespace SymType {} = "type synonym" +formatTypeNamespace SymData {} = "data type" +formatTypeNamespace SymNewType {} = "newtype" +formatTypeNamespace SymTypeFam {} = "type family" +formatTypeNamespace SymDataFam {} = "data family" +formatTypeNamespace SymClass {} = "type class" + +formatOrigin :: HasOrigName i => i OrigName -> String +formatOrigin = ppOrigName . origName + formatInfo :: NameInfo SrcSpan -> String formatInfo (LocalValue loc) = printf "a local value defined at %s" $ formatLoc loc +formatInfo (GlobalValue info) = + printf "a global %s, %s" + (formatValueNamespace info) + (formatOrigin info) +formatInfo (GlobalType info) = + printf "a global %s, %s" + (formatTypeNamespace info) + (formatOrigin info) +formatInfo ValueBinder = "a value bound here" +formatInfo TypeBinder = "a type or class defined here" formatInfo (ScopeError (ENotInScope {})) = "not in scope" formatInfo None = "none" +formatInfo i = error $ "tests/run.hs: formatInfo: " ++ show i formatAnn :: String -> Scoped SrcSpan -> String formatAnn name (Scoped info loc) = @@ -165,3 +218,4 @@ name (formatLoc loc) (formatInfo info) +-- }}}