From 6108aa1b646e694abb05900e80019e7453365497 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Nov 2017 11:46:48 -0500 Subject: [PATCH 01/14] Define ConstructorName using advanced overlap. --- src/Data/Syntax/Algebra.hs | 35 ++++++++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index 816310a99..3f3b61e94 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -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,32 @@ instance ToJSONFields ConstructorLabel where toJSONFields (ConstructorLabel s) = [ "category" .= decodeUtf8 s ] -class ConstructorName f where - constructorName :: f a -> String +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 + +data Strategy = Default | Custom + +type family ConstructorNameStrategy syntax where + ConstructorNameStrategy (Union _) = '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 From 004a0390a7fa6c9d9c789a9f8533a9752c151273 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Nov 2017 11:47:49 -0500 Subject: [PATCH 02/14] Generalize someParser over the syntax types. --- src/Parser.hs | 18 +++++++++--------- src/Semantic.hs | 5 +++-- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 099163982..1e62f9f02 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -53,26 +53,26 @@ 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 + SomeParser :: ApplyAll typeclasses syntax => { unSomeParser :: Parser (Term syntax (Record Location)) } -> SomeParser typeclasses -- | 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. diff --git a/src/Semantic.hs b/src/Semantic.hs index 3e741c7a7..732c51232 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -17,6 +17,7 @@ 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 @@ -53,7 +54,7 @@ parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob) >>= render (renderToCTerm blob) (JSONTermRenderer, lang) - | Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[ConstructorName, Foldable, Functor]) -> + | Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[ConstructorName, Functor, ToJSONFields1]) -> parse parser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob) | Just syntaxParser <- lang >>= syntaxParserForLanguage -> parse syntaxParser blob >>= decorate syntaxIdentifierAlgebra >>= render (renderJSONTerm blob) @@ -103,7 +104,7 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms (renderToCDiff blobs) (JSONDiffRenderer, lang) - | Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, Show1, Traversable]) -> + | Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, Show1, ToJSONFields1, Traversable]) -> run (parse parser) diffTerms (renderJSONDiff blobs) | Just syntaxParser <- lang >>= syntaxParserForLanguage -> run (decorate syntaxIdentifierAlgebra <=< parse syntaxParser) diffSyntaxTerms (renderJSONDiff blobs) From 5ff0f21583a92a7e59dea75acdc93f2ffed9e980 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Nov 2017 12:19:00 -0500 Subject: [PATCH 03/14] :fire: unSomeParser. --- src/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parser.hs b/src/Parser.hs index 1e62f9f02..8d2a10ee5 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -61,7 +61,7 @@ type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> * -- -- 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 syntax => { unSomeParser :: Parser (Term syntax (Record Location)) } -> SomeParser typeclasses + SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax (Record Location)) -> SomeParser typeclasses -- | 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. -- From 6c5cb81b363d7f987d63fe095d16f2ec2ee17146 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Nov 2017 12:19:06 -0500 Subject: [PATCH 04/14] Export ApplyAll. --- src/Parser.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Parser.hs b/src/Parser.hs index 8d2a10ee5..76101e637 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -3,6 +3,7 @@ module Parser ( Parser(..) , SomeParser(..) , someParser +, ApplyAll -- Syntax parsers , syntaxParserForLanguage -- À la carte parsers From e1ee3264a10177c001810cbdedcd467612b01553 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Nov 2017 13:05:17 -0500 Subject: [PATCH 05/14] Generalize SomeParser over the annotation type. --- src/Parser.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 76101e637..5f7511e3f 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -61,8 +61,8 @@ type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (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 syntax => Parser (Term syntax (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. -- @@ -75,9 +75,9 @@ someParser :: ( ApplyAll typeclasses (Union JSON.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. + => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. + -> Language -- ^ The 'Language' to select. + -> 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) From 82681016951061ae96ac45bb43f25b5e6552b978 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Nov 2017 14:21:26 -0500 Subject: [PATCH 06/14] Define an eliminator for SomeParser. --- src/Parser.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index 5f7511e3f..2972324d9 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -3,6 +3,7 @@ module Parser ( Parser(..) , SomeParser(..) , someParser +, withParser , ApplyAll -- Syntax parsers , syntaxParserForLanguage @@ -87,6 +88,9 @@ someParser _ Python = Just (SomeParser pythonParser) someParser _ Ruby = Just (SomeParser rubyParser) someParser _ TypeScript = Just (SomeParser typescriptParser) +withParser :: SomeParser typeclasses ann -> (forall syntax . ApplyAll typeclasses syntax => Parser (Term syntax ann) -> a) -> a +withParser (SomeParser parser) with = with parser + -- | Return a 'Language'-specific 'Parser', if one exists. syntaxParserForLanguage :: Language -> Maybe (Parser (Term Syntax (Record DefaultFields))) syntaxParserForLanguage language = case language of From 8c2bf9fe590a69271b521fdb1faaa483edd88494 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 16:09:09 -0500 Subject: [PATCH 07/14] Sort Data.Bifoldable up. --- src/Semantic.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic.hs b/src/Semantic.hs index 732c51232..c7776fe50 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -12,6 +12,7 @@ import Control.Exception import Control.Monad ((<=<)) import Control.Monad.Error.Class import Data.Align.Generic +import Data.Bifoldable import Data.Blob import Data.ByteString (ByteString) import Data.Diff @@ -19,7 +20,6 @@ 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 From 75bfb1903dca14a9ddeff4d9101f5b425b09c3b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 16:10:39 -0500 Subject: [PATCH 08/14] Refactor parseBlob to abstract over syntax only once. --- src/Semantic.hs | 40 +++++++++++++++------------------------- 1 file changed, 15 insertions(+), 25 deletions(-) diff --git a/src/Semantic.hs b/src/Semantic.hs index c7776fe50..393b4b40b 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -9,7 +9,7 @@ module Semantic import Algorithm (Diffable) import Control.Exception -import Control.Monad ((<=<)) +import Control.Monad ((<=<), (>=>)) import Control.Monad.Error.Class import Data.Align.Generic import Data.Bifoldable @@ -46,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, Functor, ToJSONFields1]) -> - 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) From 5dc52688df4d33c90989f6844859e727b1f8c522 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 16:42:32 -0500 Subject: [PATCH 09/14] Refactor diffBlobPair to abstract over the syntax type only once. --- src/Semantic.hs | 65 +++++++++++++++++++++++-------------------------- 1 file changed, 30 insertions(+), 35 deletions(-) diff --git a/src/Semantic.hs b/src/Semantic.hs index c8ebf212d..151685614 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -9,7 +9,7 @@ module Semantic import Algorithm (Diffable) import Control.Exception -import Control.Monad ((<=<), (>=>)) +import Control.Monad ((>=>)) import Control.Monad.Error.Class import Data.Align.Generic import Data.Bifoldable @@ -72,52 +72,47 @@ 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, ToJSONFields1, 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 + , language `notElem` + [ Language.JSX + , Language.JavaScript + , Language.Markdown + , Language.Python + , Language.Ruby + , Language.TypeScript + ] + = Nothing + | otherwise = Just language + + 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 From 10ba1e46b741309277e6c031d6fa52d98c5fdf05 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 16:50:12 -0500 Subject: [PATCH 10/14] Refactor qualify to use guard. --- src/Semantic.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Semantic.hs b/src/Semantic.hs index 151685614..56e8a2662 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -9,7 +9,7 @@ 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 @@ -93,18 +93,16 @@ diffBlobPair renderer blobs (_, Blob { blobLanguage = Just lang, blobPath = path }) -> (path, Just lang) (Blob { blobPath = path }, _) -> (path, Nothing) - qualify language - | OldToCDiffRenderer <- renderer - , language `notElem` - [ Language.JSX + 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 ] - = Nothing - | otherwise = Just language 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 From e5726442ab51fbe5b4e09e8e4c83a4c89a538b0a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 16:53:36 -0500 Subject: [PATCH 11/14] :memo: ConstructorName. --- src/Data/Syntax/Algebra.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index 3f3b61e94..bd35f5218 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -121,6 +121,9 @@ instance ToJSONFields ConstructorLabel where toJSONFields (ConstructorLabel s) = [ "category" .= decodeUtf8 s ] +-- | 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 From 5a49d4451685af91b9298244cc3fb29480122c49 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 16:55:33 -0500 Subject: [PATCH 12/14] Specialize for [] with a CustomConstructorName instance. --- src/Data/Syntax/Algebra.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index bd35f5218..b5241da3e 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -136,11 +136,15 @@ class CustomConstructorName syntax where instance Apply ConstructorName fs => CustomConstructorName (Union fs) where customConstructorName = apply (Proxy :: Proxy ConstructorName) constructorName +instance CustomConstructorName [] where + customConstructorName _ = "" + data Strategy = Default | Custom type family ConstructorNameStrategy syntax where ConstructorNameStrategy (Union _) = 'Custom - ConstructorNameStrategy syntax = 'Default + ConstructorNameStrategy [] = 'Custom + ConstructorNameStrategy syntax = 'Default class ConstructorNameWithStrategy (strategy :: Strategy) syntax where constructorNameWithStrategy :: proxy strategy -> syntax a -> String @@ -163,6 +167,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 From f970aeddc7e2b50ddd8cd4c53df329875f2cbbf5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 16:58:47 -0500 Subject: [PATCH 13/14] Label the empty list like before. --- src/Data/Syntax/Algebra.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index b5241da3e..2922beb56 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -137,7 +137,8 @@ instance Apply ConstructorName fs => CustomConstructorName (Union fs) where customConstructorName = apply (Proxy :: Proxy ConstructorName) constructorName instance CustomConstructorName [] where - customConstructorName _ = "" + customConstructorName [] = "[]" + customConstructorName _ = "" data Strategy = Default | Custom From 2e7da5e2c19aebea08d1f23037b7c4d0ddb5bdf6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 22 Nov 2017 17:05:26 -0500 Subject: [PATCH 14/14] :fire: withParser. --- src/Parser.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 2972324d9..5f7511e3f 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -3,7 +3,6 @@ module Parser ( Parser(..) , SomeParser(..) , someParser -, withParser , ApplyAll -- Syntax parsers , syntaxParserForLanguage @@ -88,9 +87,6 @@ someParser _ Python = Just (SomeParser pythonParser) someParser _ Ruby = Just (SomeParser rubyParser) someParser _ TypeScript = Just (SomeParser typescriptParser) -withParser :: SomeParser typeclasses ann -> (forall syntax . ApplyAll typeclasses syntax => Parser (Term syntax ann) -> a) -> a -withParser (SomeParser parser) with = with parser - -- | Return a 'Language'-specific 'Parser', if one exists. syntaxParserForLanguage :: Language -> Maybe (Parser (Term Syntax (Record DefaultFields))) syntaxParserForLanguage language = case language of