1
1
mirror of https://github.com/github/semantic.git synced 2024-12-29 18:06:14 +03:00
This commit is contained in:
Patrick Thomson 2018-05-31 00:10:45 -04:00
parent c4897c57c6
commit c4c92053de
4 changed files with 6 additions and 64 deletions

View File

@ -1,59 +0,0 @@
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.IdentifierName
( IdentifierName(..)
, IdentifierLabel(..)
, identifierLabel
) where
import Data.Abstract.Name (unName)
import Data.Aeson
import Data.JSON.Fields
import Data.Sum
import qualified Data.Syntax
import Data.Term
import Prologue
-- | Compute a 'IdentifierLabel' label for a 'Term'.
identifierLabel :: IdentifierName syntax => TermF syntax a b -> Maybe IdentifierLabel
identifierLabel (In _ s) = IdentifierLabel <$> identifierName s
newtype IdentifierLabel = IdentifierLabel Text
deriving (Show)
instance ToJSONFields IdentifierLabel where
toJSONFields (IdentifierLabel s) = [ "name" .= s ]
-- | A typeclass to retrieve the name of syntax identifiers.
--
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap; see also src/Analysis/Declaration.hs for discussion of the details of the mechanism.
class IdentifierName syntax where
identifierName :: syntax a -> Maybe Text
instance (IdentifierNameStrategy syntax ~ strategy, IdentifierNameWithStrategy strategy syntax) => IdentifierName syntax where
identifierName = identifierNameWithStrategy (Proxy :: Proxy strategy)
class CustomIdentifierName syntax where
customIdentifierName :: syntax a -> Maybe Text
instance Apply IdentifierName fs => CustomIdentifierName (Sum fs) where
customIdentifierName = apply @IdentifierName identifierName
instance CustomIdentifierName Data.Syntax.Identifier where
customIdentifierName (Data.Syntax.Identifier name) = Just (unName name)
data Strategy = Default | Custom
type family IdentifierNameStrategy syntax where
IdentifierNameStrategy (Sum _) = 'Custom
IdentifierNameStrategy Data.Syntax.Identifier = 'Custom
IdentifierNameStrategy syntax = 'Default
class IdentifierNameWithStrategy (strategy :: Strategy) syntax where
identifierNameWithStrategy :: proxy strategy -> syntax a -> Maybe Text
instance IdentifierNameWithStrategy 'Default syntax where
identifierNameWithStrategy _ _ = Nothing
instance (CustomIdentifierName syntax) => IdentifierNameWithStrategy 'Custom syntax where
identifierNameWithStrategy _ = customIdentifierName

View File

@ -167,6 +167,8 @@ symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then`
rawSource :: HasCallStack => Assignment ast grammar ByteString rawSource :: HasCallStack => Assignment ast grammar ByteString
rawSource = tracing Source `Then` return rawSource = tracing Source `Then` return
-- | A rule to produce a node's source as Text. Fails if the node's source
-- can't be parsed as UTF-8.
source :: HasCallStack => Assignment ast grammar Text source :: HasCallStack => Assignment ast grammar Text
source = rawSource >>= \b -> case decodeUtf8' b of source = rawSource >>= \b -> case decodeUtf8' b of
Right t -> pure t Right t -> pure t

View File

@ -1,7 +1,5 @@
module Control.Abstract.Primitive where module Control.Abstract.Primitive where
import Prologue
import Control.Abstract.Addressable import Control.Abstract.Addressable
import Control.Abstract.Context import Control.Abstract.Context
import Control.Abstract.Environment import Control.Abstract.Environment
@ -11,7 +9,8 @@ import Control.Abstract.Value
import Data.Abstract.Name import Data.Abstract.Name
import Data.Semigroup.Reducer hiding (unit) import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower import Data.Semilattice.Lower
import qualified Data.Text as T import Data.Text (pack, unpack)
import Prologue
builtin :: ( HasCallStack builtin :: ( HasCallStack
, Member (Allocator address value) effects , Member (Allocator address value) effects

View File

@ -41,7 +41,7 @@ resolveGoImport (ImportPath path Relative) = do
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path) paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
case paths of case paths of
[] -> throwResumable $ GoImportError path [] -> throwResumable $ GoImportError path
_ -> pure paths _ -> pure paths
resolveGoImport (ImportPath path NonRelative) = do resolveGoImport (ImportPath path NonRelative) = do
package <- T.unpack . unName . Package.packageName <$> currentPackage package <- T.unpack . unName . Package.packageName <$> currentPackage
trace ("attempting to resolve " <> show path <> " for package " <> package) trace ("attempting to resolve " <> show path <> " for package " <> package)
@ -50,7 +50,7 @@ resolveGoImport (ImportPath path NonRelative) = do
-- First two are source, next is package name, remaining are path to package -- First two are source, next is package name, remaining are path to package
-- (e.g. github.com/golang/<package>/path...). -- (e.g. github.com/golang/<package>/path...).
(_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs) (_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs)
_ -> throwResumable $ GoImportError path _ -> throwResumable $ GoImportError path
-- | Import declarations (symbols are added directly to the calling environment). -- | Import declarations (symbols are added directly to the calling environment).
-- --