haskell-names 0.1.2 → 0.2

raw patch · 12 files changed

+236/−40 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• haskell-names.cabal +2/−2
• src/Language/Haskell/Names.hs +1/−0
• src/Language/Haskell/Names/Annotated.hs +20/−1
• src/Language/Haskell/Names/Open.hs +1/−0
• src/Language/Haskell/Names/Open/Base.hs +19/−5
• src/Language/Haskell/Names/Open/Derived.hs +1/−1
• src/Language/Haskell/Names/Open/Instances.hs +115/−9
• src/Language/Haskell/Names/Recursive.hs +4/−4
• src/Language/Haskell/Names/ScopeUtils.hs +0/−3
• src/Language/Haskell/Names/SyntaxUtils.hs +1/−0
• src/Language/Haskell/Names/Types.hs +5/−2
• tests/run.hs +67/−13

@@ -1,5 +1,5 @@ Name:                   haskell-names-Version:                0.1.2+Version:                0.2 License:                BSD3 Author:                 Roman Cheplyaka, Lennart Augustsson Maintainer:             Roman Cheplyaka <roma@ro-che.info>@@ -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

@@ -20,6 +20,7 @@   , Error(..)   , ppError   , SymFixity+  , HasOrigName(..)   ) where  import Language.Haskell.Names.Types

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

@@ -1,6 +1,7 @@ -- Public interface for open resolution module Language.Haskell.Names.Open   ( Resolvable(..)+  , Alg(..)   , rmap   , Scope   , NameContext(..)

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

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

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

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

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

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

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

@@ -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)+-- }}}