github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-27 17:05:33 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #469 from github/traversty

Browse Source 
Traversable1 instances for AST datatypes
This commit is contained in:
Patrick Thomson 2020-02-04 23:16:13 -05:00 committed by GitHub
commit 4da8b83975
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
33 changed files with 365 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@ -9,13 +9,13 @@ packages: .
semantic-go
semantic-java
semantic-json
semantic-parse
semantic-python
semantic-ruby
semantic-scope-graph
semantic-tsx
semantic-typescript
semantic-tags
semantic-scope-graph
-- Packages brought in from other repos instead of hackage
-- ATTENTION: remember to update cabal.project.ci when bumping SHAs here!

4
cabal.project.ci
View File

@ -9,6 +9,7 @@ packages: .
semantic-go
semantic-java
semantic-json
semantic-parse
semantic-python
semantic-ruby
semantic-scope-graph
@ -59,6 +60,9 @@ package semantic-java
package semantic-json
ghc-options: -Werror
package semantic-parse
ghc-options: -Werror
package semantic-python
ghc-options: -Werror

1
script/ghci-flags
View File

@ -53,6 +53,7 @@ function flags {
echo "-isemantic-go/src"
echo "-isemantic-java/src"
echo "-isemantic-json/src"
echo "-isemantic-parse/src"
echo "-isemantic-python/src"
echo "-isemantic-python/test"
echo "-isemantic-ruby/src"

29
semantic-ast/semantic-ast.cabal
View File

@ -37,7 +37,11 @@ common haskell
library
import: haskell
exposed-modules: Marshal.JSON
exposed-modules:
AST.Element
AST.Traversable1
AST.Traversable1.Class
Marshal.JSON
-- other-modules:
@ -49,7 +53,6 @@ library
, tree-sitter ^>= 0.8
, semantic-source ^>= 0.0.2
, template-haskell ^>= 2.15
, tree-sitter-python ^>= 0.8.1
, bytestring ^>= 0.10.8.2
, optparse-applicative >= 0.14.3 && < 0.16
, pretty-simple ^>= 3.1.0.0
@ -57,25 +60,3 @@ library
hs-source-dirs: src
default-language: Haskell2010
executable semantic-ast
import: haskell
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: base
, semantic-ast
, tree-sitter
, semantic-source
, tree-sitter-python
, bytestring
, optparse-applicative
, pretty-simple
, aeson
, bytestring
, aeson-pretty
, semantic-python
, text
hs-source-dirs: app
default-language: Haskell2010

0
semantic-tags/src/AST/Element.hs → semantic-ast/src/AST/Element.hs
View File

75
semantic-ast/src/AST/Traversable1.hs Normal file
View File

@ -0,0 +1,75 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module AST.Traversable1
( module AST.Traversable1.Class
, for1
, traverse1_
, for1_
, foldMap1
, Generics(..)
) where
import AST.Traversable1.Class
import Data.Functor (void)
import Data.Functor.Const
import Data.Monoid (Ap (..))
import GHC.Generics
for1
:: forall c t f a b
. (Traversable1 c t, Applicative f)
=> t a
-> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> f (t b)
for1 t f g = traverse1 @c f g t
traverse1_
:: forall c t f a a' a''
. (Traversable1 c t, Applicative f)
=> (a -> f a')
-> (forall t' . c t' => t' a -> f a'')
-> t a
-> f ()
traverse1_ f g = getAp . foldMap1 @c (Ap . void . f) (Ap . void . g)
for1_
:: forall c t f a a' a''
. (Traversable1 c t, Applicative f)
=> t a
-> (a -> f a')
-> (forall t' . c t' => t' a -> f a'')
-> f ()
for1_ t f g = getAp $ foldMap1 @c (Ap . void . f) (Ap . void . g) t
foldMap1 :: forall c t b a . (Traversable1 c t, Monoid b) => (a -> b) -> (forall t' . c t' => t' a -> b) -> t a -> b
foldMap1 f g = getConst . traverse1 @c (Const . f) (Const . g)
-- | @'Generics' t@ has a 'Traversable1' instance when @'Rep1' t@ has a 'GTraversable1' instance, making this convenient for applying 'traverse1' to 'Generic1' types lacking 'Traversable1' instances:
--
-- @
-- 'getGenerics' '<$>' 'traverse1' f g ('Generics' t) = 'to1' '<$>' 'gtraverse1' f g ('from1' t)
-- @
--
-- It further defines its 'Foldable', 'Functor', and 'Traversable' instances using 'Traversable1', making it suitable for deriving with @-XDerivingVia@.
newtype Generics t a = Generics { getGenerics :: t a }
instance (Generic1 t, GTraversable1 Foldable (Rep1 t)) => Foldable (Generics t) where
foldMap = foldMapDefault1
instance (Generic1 t, GTraversable1 Functor (Rep1 t)) => Functor (Generics t) where
fmap = fmapDefault1
instance (Generic1 t, GTraversable1 Foldable (Rep1 t), GTraversable1 Functor (Rep1 t), GTraversable1 Traversable (Rep1 t)) => Traversable (Generics t) where
traverse = traverseDefault1
instance (Generic1 t, GTraversable1 c (Rep1 t)) => Traversable1 c (Generics t) where
traverse1 f g = fmap (Generics . to1) . gtraverse1 @c f g . from1 . getGenerics

100
semantic-ast/src/AST/Traversable1/Class.hs Normal file
View File

@ -0,0 +1,100 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module defines the 'Traversable1' class and its generic derivation using 'GTraversable1'. Note that any changes to this file will require recompilation of all of the AST modules, which is quite expensive; thus, most additions should be made in "AST.Traversable1" instead, and that that module should not be imported by the AST modules.
module AST.Traversable1.Class
( Traversable1(..)
, foldMapDefault1
, fmapDefault1
, traverseDefault1
, GTraversable1(..)
) where
import Data.Functor.Const
import Data.Functor.Identity
import GHC.Generics
-- | Simultaneous traversal of subterms of kind @*@ and @* -> *@ in an 'Applicative' context.
--
-- 'Traversable1' can express any combination of first- and second-order mapping, folding, and traversal.
--
-- Note that the @1@ suffix is used in the manner of 'Data.Functor.Classes.Show1' or 'Generic1', rather than 'foldr1'; it’s a higher-order traversal which is simultaneously able to traverse (and alter) annotations.
class Traversable1 c t where
-- | Map annotations of kind @*@ and heterogeneously-typed subterms of kind @* -> *@ under some constraint @c@ into an 'Applicative' context. The constraint is necessary to operate on otherwise universally-quantified subterms, since otherwise there would be insufficient information to inspect them at all.
--
-- No proxy is provided for the constraint @c@; instead, @-XTypeApplications@ should be used. E.g. here we ignore the annotations and print all the @* -> *@ subterms using 'Show1':
--
-- @
-- 'traverse1' \@'Data.Functor.Classes.Show1' 'pure' (\ t -> t '<$' 'putStrLn' ('Data.Functor.Classes.showsPrec1' 0 t ""))
-- @
--
-- Note that this traversal is non-recursive: any recursion through subterms must be performed by the second function argument.
traverse1
:: Applicative f
=> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> t a
-> f (t b)
default traverse1
:: (Applicative f, Generic1 t, GTraversable1 c (Rep1 t))
=> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> t a
-> f (t b)
traverse1 f g = fmap to1 . gtraverse1 @c f g . from1
-- | This function may be used as a value for 'foldMap' in a 'Foldable' instance.
foldMapDefault1 :: (Traversable1 Foldable t, Monoid b) => (a -> b) -> t a -> b
foldMapDefault1 f = getConst . traverse1 @Foldable (Const . f) (Const . foldMap f)
-- | This function may be used as a value for 'fmap' in a 'Functor' instance.
fmapDefault1 :: Traversable1 Functor t => (a -> b) -> t a -> t b
fmapDefault1 f = runIdentity . traverse1 @Functor (Identity . f) (Identity . fmap f)
-- | This function may be used as a value for 'traverse' in a 'Traversable' instance.
traverseDefault1 :: (Traversable1 Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
traverseDefault1 f = traverse1 @Traversable f (traverse f)
class GTraversable1 c t where
-- | Generically map annotations and subterms of kind @* -> *@ into an 'Applicative' context.
gtraverse1
:: Applicative f
=> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> t a
-> f (t b)
instance GTraversable1 c f => GTraversable1 c (M1 i c' f) where
gtraverse1 f g = fmap M1 . gtraverse1 @c f g . unM1
instance (GTraversable1 c f, GTraversable1 c g) => GTraversable1 c (f :*: g) where
gtraverse1 f g (l :*: r) = (:*:) <$> gtraverse1 @c f g l <*> gtraverse1 @c f g r
instance (GTraversable1 c f, GTraversable1 c g) => GTraversable1 c (f :+: g) where
gtraverse1 f g (L1 l) = L1 <$> gtraverse1 @c f g l
gtraverse1 f g (R1 r) = R1 <$> gtraverse1 @c f g r
instance GTraversable1 c (K1 R t) where
gtraverse1 _ _ (K1 k) = pure (K1 k)
instance GTraversable1 c Par1 where
gtraverse1 f _ (Par1 a) = Par1 <$> f a
instance c t => GTraversable1 c (Rec1 t) where
gtraverse1 _ g (Rec1 t) = Rec1 <$> g t
instance (Traversable f, GTraversable1 c g) => GTraversable1 c (f :.: g) where
gtraverse1 f g = fmap Comp1 . traverse (gtraverse1 @c f g) . unComp1
instance GTraversable1 c U1 where
gtraverse1 _ _ _ = pure U1

1
semantic-codegen/semantic-codegen.cabal
View File

@ -50,6 +50,7 @@ library
, bytestring ^>= 0.10.8.2
, tree-sitter ^>= 0.8
, fused-effects ^>= 1.0
, semantic-ast
, semantic-source ^>= 0.0.2
, template-haskell ^>= 2.15
, text ^>= 1.2.3.1

48
semantic-codegen/src/AST/GenerateSyntax.hs
View File

@ -9,6 +9,10 @@ module AST.GenerateSyntax
, astDeclarationsForLanguage
) where
import AST.Deserialize (Children (..), Datatype (..), DatatypeName (..), Field (..), Multiple (..), Named (..), Required (..), Type (..))
import AST.Token
import AST.Traversable1.Class
import qualified AST.Unmarshal as TS
import Data.Aeson hiding (String)
import Data.Foldable
import Data.List
@ -22,12 +26,9 @@ import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax as TH
import System.Directory
import System.FilePath.Posix
import AST.Deserialize (Children (..), Datatype (..), DatatypeName (..), Field (..), Multiple (..), Named (..), Required (..), Type (..))
import qualified TreeSitter.Language as TS
import TreeSitter.Node
import TreeSitter.Symbol (TSSymbol, toHaskellCamelCaseIdentifier, toHaskellPascalCaseIdentifier)
import AST.Token
import qualified AST.Unmarshal as TS
-- | Derive Haskell datatypes from a language and its @node-types.json@ file.
--
@ -52,7 +53,7 @@ astDeclarationsForLanguage language filePath = do
getAllSymbols :: Ptr TS.Language -> IO [(String, Named)]
getAllSymbols language = do
count <- TS.ts_language_symbol_count language
mapM getSymbol [(0 :: TSSymbol) .. fromIntegral (pred count)]
traverse getSymbol [(0 :: TSSymbol) .. fromIntegral (pred count)]
where
getSymbol i = do
cname <- TS.ts_language_symbol_name language i
@ -71,21 +72,31 @@ syntaxDatatype language allSymbols datatype = skipDefined $ do
let fieldName = mkName ("get" <> nameStr)
con <- recC name [TH.varBangType fieldName (TH.bangType strictness (pure types' `appT` varT typeParameterName))]
hasFieldInstance <- makeHasFieldInstance (conT name) (varT typeParameterName) (varE fieldName)
traversalInstances <- makeTraversalInstances (conT name)
pure
( NewtypeD [] name [PlainTV typeParameterName] Nothing con [deriveGN, deriveStockClause, deriveAnyClassClause]
: hasFieldInstance)
( NewtypeD [] name [PlainTV typeParameterName] Nothing con [deriveGN, deriveStockClause, deriveAnyClassClause]
: hasFieldInstance
<> traversalInstances)
ProductType (DatatypeName datatypeName) named children fields -> do
con <- ctorForProductType datatypeName typeParameterName children fields
result <- symbolMatchingInstance allSymbols name named datatypeName
pure $ generatedDatatype name [con] typeParameterName:result
symbolMatchingInstance <- symbolMatchingInstance allSymbols name named datatypeName
traversalInstances <- makeTraversalInstances (conT name)
pure
( generatedDatatype name [con] typeParameterName
: symbolMatchingInstance
<> traversalInstances)
-- Anonymous leaf types are defined as synonyms for the `Token` datatype
LeafType (DatatypeName datatypeName) Anonymous -> do
tsSymbol <- runIO $ withCStringLen datatypeName (\(s, len) -> TS.ts_language_symbol_for_name language s len False)
pure [ TySynD name [] (ConT ''Token `AppT` LitT (StrTyLit datatypeName) `AppT` LitT (NumTyLit (fromIntegral tsSymbol))) ]
LeafType (DatatypeName datatypeName) Named -> do
con <- ctorForLeafType (DatatypeName datatypeName) typeParameterName
result <- symbolMatchingInstance allSymbols name Named datatypeName
pure $ generatedDatatype name [con] typeParameterName:result
symbolMatchingInstance <- symbolMatchingInstance allSymbols name Named datatypeName
traversalInstances <- makeTraversalInstances (conT name)
pure
( generatedDatatype name [con] typeParameterName
: symbolMatchingInstance
<> traversalInstances)
where
-- Skip generating datatypes that have already been defined (overridden) in the module where the splice is running.
skipDefined m = do
@ -93,12 +104,23 @@ syntaxDatatype language allSymbols datatype = skipDefined $ do
if isLocal then pure [] else m
name = mkName nameStr
nameStr = toNameString (datatypeNameStatus datatype) (getDatatypeName (AST.Deserialize.datatypeName datatype))
deriveStockClause = DerivClause (Just StockStrategy) [ ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic, ConT ''Foldable, ConT ''Functor, ConT ''Traversable, ConT ''Generic1]
deriveAnyClassClause = DerivClause (Just AnyclassStrategy) [ConT ''TS.Unmarshal]
deriveStockClause = DerivClause (Just StockStrategy) [ ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic, ConT ''Generic1]
deriveAnyClassClause = DerivClause (Just AnyclassStrategy) [ConT ''TS.Unmarshal, ConT ''Traversable1 `AppT` VarT (mkName "someConstraint")]
deriveGN = DerivClause (Just NewtypeStrategy) [ConT ''TS.SymbolMatching]
generatedDatatype name cons typeParameterName = DataD [] name [PlainTV typeParameterName] Nothing cons [deriveStockClause, deriveAnyClassClause]
makeTraversalInstances :: TypeQ -> Q [Dec]
makeTraversalInstances ty =
[d|
instance Foldable $ty where
foldMap = foldMapDefault1
instance Functor $ty where
fmap = fmapDefault1
instance Traversable $ty where
traverse = traverseDefault1
|]
makeHasFieldInstance :: TypeQ -> TypeQ -> ExpQ -> Q [Dec]
makeHasFieldInstance ty param elim =
[d|instance HasField "ann" $(ty `appT` param) $param where
@ -126,7 +148,7 @@ debugPrefix (name, Anonymous) = "_" <> name
-- | Build Q Constructor for product types (nodes with fields)
ctorForProductType :: String -> Name -> Maybe Children -> [(String, Field)] -> Q Con
ctorForProductType constructorName typeParameterName children fields = ctorForTypes constructorName lists where
lists = annotation : fieldList ++ childList
lists = annotation : fieldList <> childList
annotation = ("ann", varT typeParameterName)
fieldList = map (fmap toType) fields
childList = toList $ fmap toTypeChild children

1
semantic-go/semantic-go.cabal
View File

@ -24,6 +24,7 @@ common haskell
, fused-effects ^>= 1.0
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast
, semantic-codegen
, semantic-core ^>= 0.0
, semantic-source ^>= 0.0.2

2
semantic-go/src/Language/Go/AST.hs
View File

@ -18,4 +18,4 @@ import Prelude hiding (False, Float, Integer, Rational, String, True)
import AST.GenerateSyntax
import qualified Language.Go.Grammar as Grammar
astDeclarationsForLanguage Grammar.tree_sitter_go "../../../vendor/tree-sitter-go/src/node-types.json"
astDeclarationsForLanguage Grammar.tree_sitter_go "../../../vendor/tree-sitter-go/src/node-types.json"

12
semantic-go/src/Language/Go/Tags.hs
View File

@ -9,16 +9,16 @@ module Language.Go.Tags
) where
import AST.Element
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
import Control.Effect.Writer
import Data.Text as Text
import GHC.Generics
import qualified Language.Go.AST as Go
import Source.Loc
import Source.Source as Source
import Tags.Tag
import qualified Tags.Tagging.Precise as Tags
import AST.Token
class ToTags t where
tags
@ -30,8 +30,7 @@ class ToTags t where
default tags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
@ -72,12 +71,11 @@ instance ToTags (Token sym n) where tags _ = pure ()
gtags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
gtags = Tags.traverse1_ @ToTags (const (pure ())) tags . Tags.Generics
gtags = traverse1_ @ToTags (const (pure ())) tags
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> Kind -> Loc -> Range -> m ()
yieldTag name kind loc range = do

1
semantic-java/semantic-java.cabal
View File

@ -27,6 +27,7 @@ library
build-depends:
base >= 4.13 && < 5
, fused-effects ^>= 1.0
, semantic-ast
, semantic-codegen
, semantic-source ^>= 0.0.2
, semantic-tags ^>= 0.0

2
semantic-java/src/Language/Java/AST.hs
View File

@ -18,4 +18,4 @@ import AST.GenerateSyntax
import qualified Language.Java.Grammar as Grammar
import AST.Token
astDeclarationsForLanguage Grammar.tree_sitter_java "../../../vendor/tree-sitter-java/src/node-types.json"
astDeclarationsForLanguage Grammar.tree_sitter_java "../../../vendor/tree-sitter-java/src/node-types.json"

13
semantic-java/src/Language/Java/Tags.hs
View File

@ -8,16 +8,17 @@ module Language.Java.Tags
( ToTags(..)
) where
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
import Control.Effect.Writer
import GHC.Generics
import GHC.Generics ((:+:)(..))
import qualified Language.Java.AST as Java
import Source.Loc
import Source.Range
import Source.Source as Source
import Tags.Tag
import qualified Tags.Tagging.Precise as Tags
import AST.Token
class ToTags t where
tags
@ -29,8 +30,7 @@ class ToTags t where
default tags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
@ -80,12 +80,11 @@ instance ToTags Java.MethodInvocation where
gtags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
gtags = Tags.traverse1_ @ToTags (const (pure ())) tags . Tags.Generics
gtags = traverse1_ @ToTags (const (pure ())) tags
instance ToTags Java.AnnotatedType
instance ToTags Java.Annotation

5
semantic-parse/CHANGELOG.md Normal file
View File

@ -0,0 +1,5 @@
# Revision history for semantic-parse
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

21
semantic-parse/LICENSE Normal file
View File

@ -0,0 +1,21 @@
MIT License
Copyright (c) 2019 GitHub
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

15
semantic-ast/README.md → semantic-parse/README.md
View File

@ -1,28 +1,25 @@
# semantic-ast
# semantic-parse
This package has two goals:
1. Develop a library that will produce ASTs;
2. Provide a command line tool that will output ASTs in supported formats.
This package provides a command line tool that will output ASTs in supported formats.
#### CLI
To output ASTs, run the `semantic-ast` command, specifying two mandatory options: 1) the format you'd like to return (ex., `Show`, `JSON`, etc.) and 2) the option specifying whether the source code will be passed in directly via command line (using `--sourceString`) or via providing the file path `--sourceFile`.
To output ASTs, run the `semantic-parse` command, specifying two mandatory options: 1) the format you'd like to return (ex., `Show`, `JSON`, etc.) and 2) the option specifying whether the source code will be passed in directly via command line (using `--sourceString`) or via providing the file path `--sourceFile`.
Filepath:
```
semantic-ast --format [FORMAT] --sourceFile [FILEPATH]
semantic-parse --format [FORMAT] --sourceFile [FILEPATH]
```
Source string:
```
semantic-ast --format [FORMAT] --sourceString [SOURCE]
semantic-parse --format [FORMAT] --sourceString [SOURCE]
```
An example command is:
```
semantic-ast -- --format Show --sourceString "a"
semantic-parse -- --format Show --sourceString "a"
```
This will generate an AST

2
semantic-parse/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

0
semantic-ast/app/Main.hs → semantic-parse/app/Main.hs
View File

57
semantic-parse/semantic-parse.cabal Normal file
View File

@ -0,0 +1,57 @@
cabal-version: 2.4
-- Initial package description 'semantic-ast.cabal' generated by 'cabal
-- init'. For further documentation, see
-- http://haskell.org/cabal/users-guide/
name: semantic-parse
version: 0.1.0.0
-- synopsis:
-- description:
-- bug-reports:
license: MIT
license-file: LICENSE
author: The Semantic Authors
maintainer: opensource+semantic@github.com
copyright: (c) 2019 GitHub, Inc.
category: Language
extra-source-files: CHANGELOG.md
tested-with: GHC == 8.6.5
common haskell
default-language: Haskell2010
ghc-options:
-Weverything
-Wno-missing-local-signatures
-Wno-missing-import-lists
-Wno-implicit-prelude
-Wno-safe
-Wno-unsafe
-Wno-name-shadowing
-Wno-monomorphism-restriction
-Wno-missed-specialisations
-Wno-all-missed-specialisations
-Wno-star-is-type
if (impl(ghc >= 8.8))
ghc-options: -Wno-missing-deriving-strategies
executable semantic-parse
import: haskell
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: base
, semantic-ast
, tree-sitter
, semantic-source
, tree-sitter-python ^>= 0.8.1
, bytestring
, optparse-applicative
, pretty-simple
, aeson
, bytestring
, aeson-pretty
, semantic-python
, text
hs-source-dirs: app
default-language: Haskell2010

1
semantic-python/semantic-python.cabal
View File

@ -25,6 +25,7 @@ common haskell
, fused-syntax
, parsers ^>= 0.12.10
, semantic-analysis ^>= 0
, semantic-ast
, semantic-core ^>= 0.0
, semantic-codegen
, semantic-source ^>= 0.0.2

15
semantic-python/src/Language/Python/Tags.hs
View File

@ -10,19 +10,19 @@ module Language.Python.Tags
) where
import AST.Element
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
import Control.Effect.Writer
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (listToMaybe)
import Data.Text as Text
import GHC.Generics
import qualified Language.Python.AST as Py
import Source.Loc
import Source.Range
import Source.Source as Source
import Tags.Tag
import qualified Tags.Tagging.Precise as Tags
import AST.Token
class ToTags t where
tags
@ -34,8 +34,7 @@ class ToTags t where
default tags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
@ -50,8 +49,7 @@ instance ToTags (Token sym n) where tags _ = pure ()
keywordFunctionCall
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc -> Loc -> Range -> Text -> m ()
keywordFunctionCall t loc range name = yieldTag name Function loc range Nothing >> gtags t
@ -127,12 +125,11 @@ docComment _ _ = Nothing
gtags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
gtags = Tags.traverse1_ @ToTags (const (pure ())) tags . Tags.Generics
gtags = traverse1_ @ToTags (const (pure ())) tags
instance ToTags Py.AliasedImport
instance ToTags Py.ArgumentList

1
semantic-ruby/semantic-ruby.cabal
View File

@ -24,6 +24,7 @@ common haskell
, fused-effects ^>= 1.0
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast
, semantic-codegen
, semantic-core ^>= 0.0
, semantic-source ^>= 0.0.2

2
semantic-ruby/src/Language/Ruby/AST.hs
View File

@ -18,4 +18,4 @@ import Prelude hiding (False, Float, Integer, Rational, String, True)
import AST.GenerateSyntax
import qualified Language.Ruby.Grammar as Grammar
astDeclarationsForLanguage Grammar.tree_sitter_ruby "../../../vendor/tree-sitter-ruby/src/node-types.json"
astDeclarationsForLanguage Grammar.tree_sitter_ruby "../../../vendor/tree-sitter-ruby/src/node-types.json"

27
semantic-ruby/src/Language/Ruby/Tags.hs
View File

@ -12,21 +12,21 @@ module Language.Ruby.Tags
) where
import AST.Element
import AST.Token
import AST.Traversable1
import qualified AST.Unmarshal as TS
import Control.Effect.Reader
import Control.Effect.State
import Control.Effect.Writer
import Control.Monad
import Data.Foldable
import Data.Text as Text
import GHC.Generics
import qualified Language.Ruby.AST as Rb
import Source.Loc
import Source.Range as Range
import Source.Source as Source
import Tags.Tag
import qualified Tags.Tagging.Precise as Tags
import AST.Token
import qualified AST.Unmarshal as TS
class ToTags t where
tags
@ -40,8 +40,7 @@ class ToTags t where
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Has (State [Text]) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
@ -89,7 +88,7 @@ instance ToTags Rb.Class where
where
range' = case extraChildren of
Prj Rb.Superclass { ann = Loc { byteRange = Range { end }}} : _ -> Range start end
_ -> Range start (getEnd expr)
_ -> Range start (getEnd expr)
getEnd = Range.end . byteRange . TS.gann
yield name = yieldTag name Class loc range' >> gtags t
@ -106,7 +105,7 @@ instance ToTags Rb.SingletonClass where
where
range' = case extraChildren of
x : _ -> Range start (getStart x)
_ -> range
_ -> range
getStart = Range.start . byteRange . TS.gann
yield name = yieldTag name Class loc range' >> gtags t
@ -123,7 +122,7 @@ instance ToTags Rb.Module where
where
range' = case extraChildren of
x : _ -> Range start (getStart x)
_ -> Range start (getEnd expr)
_ -> Range start (getEnd expr)
getEnd = Range.end . byteRange . TS.gann
getStart = Range.start . byteRange . TS.gann
yield name = yieldTag name Module loc range' >> gtags t
@ -132,8 +131,7 @@ yieldMethodNameTag
:: ( Has (State [Text]) sig m
, Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
) => t Loc -> Loc -> Range -> Rb.MethodName Loc -> m ()
yieldMethodNameTag t loc range (Rb.MethodName expr) = enterScope True $ case expr of
Prj Rb.Identifier { text = name } -> yield name
@ -165,7 +163,7 @@ instance ToTags Rb.Method where
where
range' = case parameters of
Just Rb.MethodParameters { ann = Loc { byteRange = Range { end } }} -> Range start end
_ -> Range start (getEnd name)
_ -> Range start (getEnd name)
getEnd = Range.end . byteRange . TS.gann
instance ToTags Rb.SingletonMethod where
@ -177,7 +175,7 @@ instance ToTags Rb.SingletonMethod where
where
range' = case parameters of
Just Rb.MethodParameters { ann = Loc { byteRange = Range { end } }} -> Range start end
_ -> Range start (getEnd name)
_ -> Range start (getEnd name)
getEnd = Range.end . byteRange . TS.gann
instance ToTags Rb.Block where
@ -336,12 +334,11 @@ gtags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Has (State [Text]) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
gtags = Tags.traverse1_ @ToTags (const (pure ())) tags . Tags.Generics
gtags = traverse1_ @ToTags (const (pure ())) tags
-- instance ToTags Rb.Alias
instance ToTags Rb.Arg

1
semantic-tags/semantic-tags.cabal
View File

@ -20,7 +20,6 @@ tested-with: GHC == 8.6.5
library
exposed-modules:
AST.Element
Tags.Tag
Tags.Tagging.Precise
build-depends:

160
semantic-tags/src/Tags/Tagging/Precise.hs
View File

@ -1,40 +1,16 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Tags.Tagging.Precise
( Tags
, ToTags(..)
, yield
, runTagging
, firstLine
, Traversable1(..)
, for1
, traverse1_
, for1_
, foldMap1
, foldMapDefault1
, fmapDefault1
, traverseDefault1
, GTraversable1(..)
, Generics(..)
) where
import Control.Carrier.Reader
import Control.Carrier.Writer.Strict
import Data.Functor (void)
import Data.Functor.Const
import Data.Functor.Identity
import Data.Monoid (Ap (..), Endo (..))
import Data.Monoid (Endo (..))
import Data.Text as Text (Text, take, takeWhile, stripEnd)
import GHC.Generics
import Prelude hiding (span)
import Source.Loc (Loc (..))
import Source.Source as Source
@ -64,137 +40,3 @@ runTagging source
-- | Slices a range out of 'Source' and gives back the first line of source up to 180 characters.
firstLine :: Source -> Range -> Text
firstLine src = Text.stripEnd . Text.take 180 . Text.takeWhile (/= '\n') . Source.toText . slice src
-- FIXME: move Traversable1 into semantic-ast.
-- FIXME: derive Traversable1 instances for TH-generated syntax types.
-- | Simultaneous traversal of subterms of kind @*@ and @* -> *@ in an 'Applicative' context.
--
-- 'Traversable1' can express any combination of first- and second-order mapping, folding, and traversal.
--
-- Note that the @1@ suffix is used in the manner of 'Data.Functor.Classes.Show1' or 'Generic1', rather than 'foldr1'; it’s a higher-order traversal which is simultaneously able to traverse (and alter) annotations.
class Traversable1 c t where
-- | Map annotations of kind @*@ and heterogeneously-typed subterms of kind @* -> *@ under some constraint @c@ into an 'Applicative' context. The constraint is necessary to operate on otherwise universally-quantified subterms, since otherwise there would be insufficient information to inspect them at all.
--
-- No proxy is provided for the constraint @c@; instead, @-XTypeApplications@ should be used. E.g. here we ignore the annotations and print all the @* -> *@ subterms using 'Show1':
--
-- @
-- 'traverse1' \@'Data.Functor.Classes.Show1' 'pure' (\ t -> t '<$' 'putStrLn' ('Data.Functor.Classes.showsPrec1' 0 t ""))
-- @
--
-- Note that this traversal is non-recursive: any recursion through subterms must be performed by the second function argument.
traverse1
:: Applicative f
=> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> t a
-> f (t b)
default traverse1
:: (Applicative f, Generic1 t, GTraversable1 c (Rep1 t))
=> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> t a
-> f (t b)
traverse1 f g = fmap to1 . gtraverse1 @c f g . from1
for1
:: forall c t f a b
. (Traversable1 c t, Applicative f)
=> t a
-> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> f (t b)
for1 t f g = traverse1 @c f g t
traverse1_
:: forall c t f a a' a''
. (Traversable1 c t, Applicative f)
=> (a -> f a')
-> (forall t' . c t' => t' a -> f a'')
-> t a
-> f ()
traverse1_ f g = getAp . foldMap1 @c (Ap . void . f) (Ap . void . g)
for1_
:: forall c t f a a' a''
. (Traversable1 c t, Applicative f)
=> t a
-> (a -> f a')
-> (forall t' . c t' => t' a -> f a'')
-> f ()
for1_ t f g = getAp $ foldMap1 @c (Ap . void . f) (Ap . void . g) t
foldMap1 :: forall c t b a . (Traversable1 c t, Monoid b) => (a -> b) -> (forall t' . c t' => t' a -> b) -> t a -> b
foldMap1 f g = getConst . traverse1 @c (Const . f) (Const . g)
-- | This function may be used as a value for 'foldMap' in a 'Foldable' instance.
foldMapDefault1 :: (Traversable1 Foldable t, Monoid b) => (a -> b) -> t a -> b
foldMapDefault1 f = foldMap1 @Foldable f (foldMap f)
-- | This function may be used as a value for 'fmap' in a 'Functor' instance.
fmapDefault1 :: Traversable1 Functor t => (a -> b) -> t a -> t b
fmapDefault1 f = runIdentity . traverse1 @Functor (Identity . f) (Identity . fmap f)
-- | This function may be used as a value for 'traverse' in a 'Traversable' instance.
traverseDefault1 :: (Traversable1 Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
traverseDefault1 f = traverse1 @Traversable f (traverse f)
-- FIXME: move GTraversable1 into semantic-ast.
class GTraversable1 c t where
-- | Generically map annotations and subterms of kind @* -> *@ into an 'Applicative' context.
gtraverse1
:: Applicative f
=> (a -> f b)
-> (forall t' . c t' => t' a -> f (t' b))
-> t a
-> f (t b)
instance GTraversable1 c f => GTraversable1 c (M1 i c' f) where
gtraverse1 f g = fmap M1 . gtraverse1 @c f g . unM1
instance (GTraversable1 c f, GTraversable1 c g) => GTraversable1 c (f :*: g) where
gtraverse1 f g (l :*: r) = (:*:) <$> gtraverse1 @c f g l <*> gtraverse1 @c f g r
instance (GTraversable1 c f, GTraversable1 c g) => GTraversable1 c (f :+: g) where
gtraverse1 f g (L1 l) = L1 <$> gtraverse1 @c f g l
gtraverse1 f g (R1 r) = R1 <$> gtraverse1 @c f g r
instance GTraversable1 c (K1 R t) where
gtraverse1 _ _ (K1 k) = pure (K1 k)
instance GTraversable1 c Par1 where
gtraverse1 f _ (Par1 a) = Par1 <$> f a
instance c t => GTraversable1 c (Rec1 t) where
gtraverse1 _ g (Rec1 t) = Rec1 <$> g t
instance (Traversable f, GTraversable1 c g) => GTraversable1 c (f :.: g) where
gtraverse1 f g = fmap Comp1 . traverse (gtraverse1 @c f g) . unComp1
instance GTraversable1 c U1 where
gtraverse1 _ _ _ = pure U1
-- | @'Generics' t@ has a 'Traversable1' instance when @'Rep1' t@ has a 'GTraversable1' instance, making this convenient for applying 'traverse1' to 'Generic1' types lacking 'Traversable1' instances:
--
-- @
-- 'getGenerics' '<$>' 'traverse1' f g ('Generics' t) = 'to1' '<$>' 'gtraverse1' f g ('from1' t)
-- @
--
-- It further defines its 'Foldable', 'Functor', and 'Traversable' instances using 'Traversable1', making it suitable for deriving with @-XDerivingVia@.
newtype Generics t a = Generics { getGenerics :: t a }
instance (Generic1 t, GTraversable1 Foldable (Rep1 t)) => Foldable (Generics t) where
foldMap = foldMapDefault1
instance (Generic1 t, GTraversable1 Functor (Rep1 t)) => Functor (Generics t) where
fmap = fmapDefault1
instance (Generic1 t, GTraversable1 Foldable (Rep1 t), GTraversable1 Functor (Rep1 t), GTraversable1 Traversable (Rep1 t)) => Traversable (Generics t) where
traverse = traverseDefault1
instance (Generic1 t, GTraversable1 c (Rep1 t)) => Traversable1 c (Generics t) where
traverse1 f g = fmap (Generics . to1) . gtraverse1 @c f g . from1 . getGenerics

1
semantic-tsx/semantic-tsx.cabal
View File

@ -24,6 +24,7 @@ common haskell
, fused-effects ^>= 1.0
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast
, semantic-codegen
, semantic-core ^>= 0.0
, semantic-source ^>= 0.0.2

2
semantic-tsx/src/Language/TSX/AST.hs
View File

@ -18,4 +18,4 @@ import Prelude hiding (False, Float, Integer, String, True)
import AST.GenerateSyntax
import qualified TreeSitter.TSX as Grammar
astDeclarationsForLanguage Grammar.tree_sitter_tsx "../../../vendor/tree-sitter-typescript/tsx/src/node-types.json"
astDeclarationsForLanguage Grammar.tree_sitter_tsx "../../../vendor/tree-sitter-typescript/tsx/src/node-types.json"

14
semantic-tsx/src/Language/TSX/Tags.hs
View File

@ -10,17 +10,17 @@ module Language.TSX.Tags
) where
import AST.Element
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
import Control.Effect.Writer
import Data.Foldable
import Data.Text as Text
import GHC.Generics
import qualified Language.TSX.AST as Tsx
import Source.Loc
import Source.Source as Source
import Tags.Tag
import qualified Tags.Tagging.Precise as Tags
import AST.Token
class ToTags t where
tags
@ -32,8 +32,7 @@ class ToTags t where
default tags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
@ -110,7 +109,7 @@ instance ToTags Tsx.Module where
Prj Tsx.Identifier { text } -> yield text
-- TODO: Handle NestedIdentifiers and Strings
-- Prj Tsx.NestedIdentifier { extraChildren } -> match
_ -> gtags t
_ -> gtags t
yield text = yieldTag text Module loc byteRange >> gtags t
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
@ -122,12 +121,11 @@ instance ToTags (Token sym n) where tags _ = pure ()
gtags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
gtags = Tags.traverse1_ @ToTags (const (pure ())) tags . Tags.Generics
gtags = traverse1_ @ToTags (const (pure ())) tags
-- These are all valid, but point to built-in functions (e.g. require) that a la
-- carte doesn't display and since we have nothing to link to yet (can't

1
semantic-typescript/semantic-typescript.cabal
View File

@ -24,6 +24,7 @@ common haskell
, fused-effects ^>= 1.0
, fused-syntax
, parsers ^>= 0.12.10
, semantic-ast
, semantic-codegen
, semantic-core ^>= 0.0
, semantic-source ^>= 0.0.2

14
semantic-typescript/src/Language/TypeScript/Tags.hs
View File

@ -10,17 +10,17 @@ module Language.TypeScript.Tags
) where
import AST.Element
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
import Control.Effect.Writer
import Data.Foldable
import Data.Text as Text
import GHC.Generics
import qualified Language.TypeScript.AST as Ts
import Source.Loc
import Source.Source as Source
import Tags.Tag
import qualified Tags.Tagging.Precise as Tags
import AST.Token
class ToTags t where
tags
@ -32,8 +32,7 @@ class ToTags t where
default tags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
@ -103,7 +102,7 @@ instance ToTags Ts.Module where
Prj Ts.Identifier { text } -> yield text
-- TODO: Handle NestedIdentifiers and Strings
-- Prj Tsx.NestedIdentifier { extraChildren } -> match
_ -> gtags t
_ -> gtags t
yield text = yieldTag text Module loc byteRange >> gtags t
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
@ -115,12 +114,11 @@ instance ToTags (Token sym n) where tags _ = pure ()
gtags
:: ( Has (Reader Source) sig m
, Has (Writer Tags.Tags) sig m
, Generic1 t
, Tags.GTraversable1 ToTags (Rep1 t)
, Traversable1 ToTags t
)
=> t Loc
-> m ()
gtags = Tags.traverse1_ @ToTags (const (pure ())) tags . Tags.Generics
gtags = traverse1_ @ToTags (const (pure ())) tags
-- These are all valid, but point to built-in functions (e.g. require) that a la
-- carte doesn't display and since we have nothing to link to yet (can't