mirror of
https://github.com/github/semantic.git
synced 2024-11-28 10:15:55 +03:00
Merge pull request #1445 from github/existential-syntax-without-the-fire
Existential syntax (without the 🔥)
This commit is contained in:
Rob Rix
GitHub
commit
b6c3147706
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Data.Syntax.Algebra
|
||||
( FAlgebra
|
||||
, RAlgebra
|
||||
@ -108,8 +108,8 @@ constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString
|
||||
constructorNameAndConstantFields (In _ f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")
|
||||
|
||||
-- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's.
|
||||
constructorLabel :: Apply ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel
|
||||
constructorLabel (In _ u) = ConstructorLabel $ pack (apply (Proxy :: Proxy ConstructorName) constructorName u)
|
||||
constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel
|
||||
constructorLabel (In _ s) = ConstructorLabel $ pack (constructorName s)
|
||||
|
||||
|
||||
newtype ConstructorLabel = ConstructorLabel ByteString
|
||||
@ -121,11 +121,40 @@ instance ToJSONFields ConstructorLabel where
|
||||
toJSONFields (ConstructorLabel s) = [ "category" .= decodeUtf8 s ]
|
||||
|
||||
|
||||
class ConstructorName f where
|
||||
constructorName :: f a -> String
|
||||
-- | A typeclass to retrieve the name of the data constructor for a value.
|
||||
--
|
||||
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap; see also src/Renderer/TOC.hs for discussion of the details of the mechanism.
|
||||
class ConstructorName syntax where
|
||||
constructorName :: syntax a -> String
|
||||
|
||||
instance (Generic1 f, GConstructorName (Rep1 f)) => ConstructorName f where
|
||||
constructorName = gconstructorName . from1
|
||||
instance (ConstructorNameStrategy syntax ~ strategy, ConstructorNameWithStrategy strategy syntax) => ConstructorName syntax where
|
||||
constructorName = constructorNameWithStrategy (Proxy :: Proxy strategy)
|
||||
|
||||
class CustomConstructorName syntax where
|
||||
customConstructorName :: syntax a -> String
|
||||
|
||||
instance Apply ConstructorName fs => CustomConstructorName (Union fs) where
|
||||
customConstructorName = apply (Proxy :: Proxy ConstructorName) constructorName
|
||||
|
||||
instance CustomConstructorName [] where
|
||||
customConstructorName [] = "[]"
|
||||
customConstructorName _ = ""
|
||||
|
||||
data Strategy = Default | Custom
|
||||
|
||||
type family ConstructorNameStrategy syntax where
|
||||
ConstructorNameStrategy (Union _) = 'Custom
|
||||
ConstructorNameStrategy [] = 'Custom
|
||||
ConstructorNameStrategy syntax = 'Default
|
||||
|
||||
class ConstructorNameWithStrategy (strategy :: Strategy) syntax where
|
||||
constructorNameWithStrategy :: proxy strategy -> syntax a -> String
|
||||
|
||||
instance (Generic1 syntax, GConstructorName (Rep1 syntax)) => ConstructorNameWithStrategy 'Default syntax where
|
||||
constructorNameWithStrategy _ = gconstructorName . from1
|
||||
|
||||
instance CustomConstructorName syntax => ConstructorNameWithStrategy 'Custom syntax where
|
||||
constructorNameWithStrategy _ = customConstructorName
|
||||
|
||||
|
||||
class GConstructorName f where
|
||||
@ -139,6 +168,4 @@ instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g)
|
||||
gconstructorName (R1 r) = gconstructorName r
|
||||
|
||||
instance Constructor c => GConstructorName (M1 C c f) where
|
||||
gconstructorName x = case conName x of
|
||||
":" -> ""
|
||||
n -> n
|
||||
gconstructorName = conName
|
||||
|
||||
@ -3,6 +3,7 @@ module Parser
|
||||
( Parser(..)
|
||||
, SomeParser(..)
|
||||
, someParser
|
||||
, ApplyAll
|
||||
-- Syntax parsers
|
||||
, syntaxParserForLanguage
|
||||
-- À la carte parsers
|
||||
@ -53,30 +54,30 @@ data Parser term where
|
||||
MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
|
||||
|
||||
-- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question.
|
||||
type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (functors :: [* -> *]) :: Constraint where
|
||||
ApplyAll (typeclass ': typeclasses) functors = (Apply typeclass functors, ApplyAll typeclasses functors)
|
||||
ApplyAll '[] functors = ()
|
||||
type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
|
||||
ApplyAll (typeclass ': typeclasses) syntax = (typeclass syntax, ApplyAll typeclasses syntax)
|
||||
ApplyAll '[] syntax = ()
|
||||
|
||||
-- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
|
||||
--
|
||||
-- This enables us to abstract over the details of the specific syntax types in cases where we can describe all the requirements on the syntax with a list of typeclasses.
|
||||
data SomeParser typeclasses where
|
||||
SomeParser :: ApplyAll typeclasses fs => { unSomeParser :: Parser (Term (Union fs) (Record Location)) } -> SomeParser typeclasses
|
||||
data SomeParser typeclasses ann where
|
||||
SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax ann) -> SomeParser typeclasses ann
|
||||
|
||||
-- | Construct a 'SomeParser' given a proxy for a list of typeclasses and the 'Language' to be parsed, all of which must be satisfied by all of the types in the syntaxes of our supported languages.
|
||||
--
|
||||
-- This can be used to perform operations uniformly over terms produced by blobs with different 'Language's, and which therefore have different types in general. For example, given some 'Blob', we can parse and 'show' the parsed & assigned 'Term' like so:
|
||||
--
|
||||
-- > case someParser (Proxy :: Proxy '[Show1]) (blobLanguage language) of { Just (SomeParser parser) -> runTask (parse parser blob) >>= putStrLn . show ; _ -> return () }
|
||||
someParser :: ( ApplyAll typeclasses JSON.Syntax
|
||||
, ApplyAll typeclasses Markdown.Syntax
|
||||
, ApplyAll typeclasses Python.Syntax
|
||||
, ApplyAll typeclasses Ruby.Syntax
|
||||
, ApplyAll typeclasses TypeScript.Syntax
|
||||
someParser :: ( ApplyAll typeclasses (Union JSON.Syntax)
|
||||
, ApplyAll typeclasses (Union Markdown.Syntax)
|
||||
, ApplyAll typeclasses (Union Python.Syntax)
|
||||
, ApplyAll typeclasses (Union Ruby.Syntax)
|
||||
, ApplyAll typeclasses (Union TypeScript.Syntax)
|
||||
)
|
||||
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
|
||||
-> Language -- ^ The 'Language' to select.
|
||||
-> Maybe (SomeParser typeclasses) -- ^ 'Maybe' a 'SomeParser' abstracting the syntax type to be produced.
|
||||
-> Maybe (SomeParser typeclasses (Record Location)) -- ^ 'Maybe' a 'SomeParser' abstracting the syntax type to be produced.
|
||||
someParser _ Go = Nothing
|
||||
someParser _ JavaScript = Just (SomeParser typescriptParser)
|
||||
someParser _ JSON = Just (SomeParser jsonParser)
|
||||
|
||||
104
src/Semantic.hs
104
src/Semantic.hs
@ -9,16 +9,17 @@ module Semantic
|
||||
|
||||
import Algorithm (Diffable)
|
||||
import Control.Exception
|
||||
import Control.Monad ((<=<))
|
||||
import Control.Monad ((>=>), guard)
|
||||
import Control.Monad.Error.Class
|
||||
import Data.Align.Generic
|
||||
import Data.Bifoldable
|
||||
import Data.Blob
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Diff
|
||||
import Data.Functor.Both as Both
|
||||
import Data.Functor.Classes
|
||||
import Data.JSON.Fields
|
||||
import Data.Output
|
||||
import Data.Bifoldable
|
||||
import Data.Record
|
||||
import Data.Syntax.Algebra
|
||||
import Data.Term
|
||||
@ -45,32 +46,22 @@ parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . f
|
||||
|
||||
-- | A task to parse a 'Blob' and render the resulting 'Term'.
|
||||
parseBlob :: TermRenderer output -> Blob -> Task output
|
||||
parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of
|
||||
(ToCTermRenderer, lang)
|
||||
| Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[HasDeclaration, Foldable, Functor]) ->
|
||||
parse parser blob >>= decorate (declarationAlgebra blob) >>= render (renderToCTerm blob)
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob) >>= render (renderToCTerm blob)
|
||||
parseBlob renderer blob@Blob{..}
|
||||
| Just (SomeParser parser) <- blobLanguage >>= someParser (Proxy :: Proxy '[ConstructorName, HasDeclaration, Foldable, Functor, ToJSONFields1])
|
||||
= parse parser blob >>= case renderer of
|
||||
ToCTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToCTerm blob)
|
||||
JSONTermRenderer -> decorate constructorLabel >=> render (renderJSONTerm blob)
|
||||
SExpressionTermRenderer -> decorate constructorLabel . (Nil <$) >=> render renderSExpressionTerm
|
||||
TagsTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)
|
||||
|
||||
(JSONTermRenderer, lang)
|
||||
| Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[ConstructorName, Foldable, Functor]) ->
|
||||
parse parser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob)
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
parse syntaxParser blob >>= decorate syntaxIdentifierAlgebra >>= render (renderJSONTerm blob)
|
||||
| Just parser <- blobLanguage >>= syntaxParserForLanguage
|
||||
= parse parser blob >>= case renderer of
|
||||
ToCTermRenderer -> decorate (syntaxDeclarationAlgebra blob) >=> render (renderToCTerm blob)
|
||||
JSONTermRenderer -> decorate syntaxIdentifierAlgebra >=> render (renderJSONTerm blob)
|
||||
SExpressionTermRenderer -> render renderSExpressionTerm . fmap keepCategory
|
||||
TagsTermRenderer -> decorate (syntaxDeclarationAlgebra blob) >=> render (renderToTags blob)
|
||||
|
||||
(SExpressionTermRenderer, lang)
|
||||
| Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[ConstructorName, Foldable, Functor]) ->
|
||||
parse parser blob >>= decorate constructorLabel . (Nil <$) >>= render renderSExpressionTerm
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
parse syntaxParser blob >>= render renderSExpressionTerm . fmap keepCategory
|
||||
|
||||
(TagsTermRenderer, lang)
|
||||
| Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[HasDeclaration, Foldable, Functor]) ->
|
||||
parse parser blob >>= decorate (declarationAlgebra blob) >>= render (renderToTags blob)
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob) >>= render (renderToTags blob)
|
||||
|
||||
_ -> throwError (SomeException (NoParserForLanguage blobPath blobLanguage))
|
||||
| otherwise = throwError (SomeException (NoParserForLanguage blobPath blobLanguage))
|
||||
|
||||
data NoParserForLanguage = NoParserForLanguage FilePath (Maybe Language.Language)
|
||||
deriving (Eq, Exception, Ord, Show, Typeable)
|
||||
@ -81,52 +72,45 @@ diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair rendere
|
||||
|
||||
-- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
|
||||
diffBlobPair :: DiffRenderer output -> Both Blob -> Task output
|
||||
diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
|
||||
(OldToCDiffRenderer, lang)
|
||||
| elem lang $ fmap Just [
|
||||
Language.JSX,
|
||||
Language.JavaScript,
|
||||
Language.Markdown,
|
||||
Language.Python,
|
||||
Language.Ruby,
|
||||
Language.TypeScript
|
||||
]
|
||||
, Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, HasDeclaration, Show1, Traversable]) ->
|
||||
run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms (renderToCDiff blobs)
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms (renderToCDiff blobs)
|
||||
diffBlobPair renderer blobs
|
||||
| Just (SomeParser parser) <- effectiveLanguage >>= qualify >>= someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Show1, ToJSONFields1, Traversable])
|
||||
= case renderer of
|
||||
OldToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms renderToCDiff
|
||||
ToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms renderToCDiff
|
||||
JSONDiffRenderer -> run ( parse parser) diffTerms renderJSONDiff
|
||||
SExpressionDiffRenderer -> run ( parse parser >=> decorate constructorLabel . (Nil <$)) diffTerms (const renderSExpressionDiff)
|
||||
|
||||
(ToCDiffRenderer, lang)
|
||||
| Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, HasDeclaration, Show1, Traversable]) ->
|
||||
run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms (renderToCDiff blobs)
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms (renderToCDiff blobs)
|
||||
| Just parser <- effectiveLanguage >>= syntaxParserForLanguage
|
||||
= case renderer of
|
||||
OldToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms renderToCDiff
|
||||
ToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms renderToCDiff
|
||||
JSONDiffRenderer -> run ( parse parser >=> decorate syntaxIdentifierAlgebra) diffSyntaxTerms renderJSONDiff
|
||||
SExpressionDiffRenderer -> run ( parse parser >=> pure . fmap keepCategory) diffSyntaxTerms (const renderSExpressionDiff)
|
||||
|
||||
(JSONDiffRenderer, lang)
|
||||
| Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, Show1, Traversable]) ->
|
||||
run (parse parser) diffTerms (renderJSONDiff blobs)
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
run (decorate syntaxIdentifierAlgebra <=< parse syntaxParser) diffSyntaxTerms (renderJSONDiff blobs)
|
||||
|
||||
(SExpressionDiffRenderer, lang)
|
||||
| Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, Foldable, Functor, GAlign, Show1, Traversable]) ->
|
||||
run (decorate constructorLabel . (Nil <$) <=< parse parser) diffTerms renderSExpressionDiff
|
||||
| Just syntaxParser <- lang >>= syntaxParserForLanguage ->
|
||||
run (fmap (fmap keepCategory) . parse syntaxParser) diffSyntaxTerms renderSExpressionDiff
|
||||
|
||||
_ -> throwError (SomeException (NoParserForLanguage effectivePath effectiveLanguage))
|
||||
| otherwise = throwError (SomeException (NoParserForLanguage effectivePath effectiveLanguage))
|
||||
where (effectivePath, effectiveLanguage) = case runJoin blobs of
|
||||
(Blob { blobLanguage = Just lang, blobPath = path }, _) -> (path, Just lang)
|
||||
(_, Blob { blobLanguage = Just lang, blobPath = path }) -> (path, Just lang)
|
||||
(Blob { blobPath = path }, _) -> (path, Nothing)
|
||||
|
||||
run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Diff syntax ann ann -> output) -> Task output
|
||||
qualify language | OldToCDiffRenderer <- renderer = guard (language `elem` aLaCarteLanguages) *> Just language
|
||||
| otherwise = Just language
|
||||
aLaCarteLanguages
|
||||
= [ Language.JSX
|
||||
, Language.JavaScript
|
||||
, Language.Markdown
|
||||
, Language.Python
|
||||
, Language.Ruby
|
||||
, Language.TypeScript
|
||||
]
|
||||
|
||||
run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Both Blob -> Diff syntax ann ann -> output) -> Task output
|
||||
run parse diff renderer = do
|
||||
terms <- distributeFor blobs parse
|
||||
time "diff" languageTag $ do
|
||||
diff <- runBothWith (diffTermPair blobs diff) terms
|
||||
writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
|
||||
render renderer diff
|
||||
render (renderer blobs) diff
|
||||
where
|
||||
showLanguage = pure . (,) "language" . show
|
||||
languageTag = let (a, b) = runJoin blobs
|
||||
|
||||
Loading…
Reference in New Issue
Block a user