Merge pull request #1445 from github/existential-syntax-without-the-fire

Existential syntax (without the 🔥)

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 :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel
-constructorLabel (In _ u) = ConstructorLabel $ pack (apply (Proxy :: Proxy ConstructorName) constructorName u)
+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
+-- | A typeclass to retrieve the name of the data constructor for a value.
-  constructorName :: f a -> String
+--
+--   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
+instance (ConstructorNameStrategy syntax ~ strategy, ConstructorNameWithStrategy strategy syntax) => ConstructorName syntax where
-  constructorName = gconstructorName . from1
+  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
+  gconstructorName = conName
-                        ":" -> ""
-                        n -> n

src/Parser.hs

@@ -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
+type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
-  ApplyAll (typeclass ': typeclasses) functors = (Apply typeclass functors, ApplyAll typeclasses functors)
+  ApplyAll (typeclass ': typeclasses) syntax = (typeclass syntax, ApplyAll typeclasses syntax)
-  ApplyAll '[] functors = ()
+  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
+data SomeParser typeclasses ann where
-  SomeParser :: ApplyAll typeclasses fs => { unSomeParser :: Parser (Term (Union fs) (Record Location)) } -> SomeParser typeclasses
+  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
+someParser :: ( ApplyAll typeclasses (Union JSON.Syntax)
-              , ApplyAll typeclasses Markdown.Syntax
+              , ApplyAll typeclasses (Union Markdown.Syntax)
-              , ApplyAll typeclasses Python.Syntax
+              , ApplyAll typeclasses (Union Python.Syntax)
-              , ApplyAll typeclasses Ruby.Syntax
+              , ApplyAll typeclasses (Union Ruby.Syntax)
-              , ApplyAll typeclasses TypeScript.Syntax
+              , ApplyAll typeclasses (Union TypeScript.Syntax)
               )
-           => proxy typeclasses              -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
+           => proxy typeclasses                                -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-           -> Language                       -- ^ The 'Language' to select.
+           -> 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)

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
+parseBlob renderer blob@Blob{..}
-  (ToCTermRenderer, lang)
+  | Just (SomeParser parser) <- blobLanguage >>= someParser (Proxy :: Proxy '[ConstructorName, HasDeclaration, Foldable, Functor, ToJSONFields1])
-    | Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[HasDeclaration, Foldable, Functor]) ->
+  = parse parser blob >>= case renderer of
-      parse parser blob >>= decorate (declarationAlgebra blob) >>= render (renderToCTerm blob)
+    ToCTermRenderer         -> decorate (declarationAlgebra blob)   >=> render (renderToCTerm  blob)
-    | Just syntaxParser <- lang >>= syntaxParserForLanguage ->
+    JSONTermRenderer        -> decorate constructorLabel            >=> render (renderJSONTerm blob)
-      parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob) >>= render (renderToCTerm blob)
+    SExpressionTermRenderer -> decorate constructorLabel . (Nil <$) >=> render renderSExpressionTerm
+    TagsTermRenderer        -> decorate (declarationAlgebra blob)   >=> render (renderToTags blob)
 
-  (JSONTermRenderer, lang)
+  | Just parser <- blobLanguage >>= syntaxParserForLanguage
-    | Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[ConstructorName, Foldable, Functor]) ->
+  = parse parser blob >>= case renderer of
-      parse parser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob)
+    ToCTermRenderer         -> decorate (syntaxDeclarationAlgebra blob) >=> render (renderToCTerm blob)
-    | Just syntaxParser <- lang >>= syntaxParserForLanguage ->
+    JSONTermRenderer        -> decorate syntaxIdentifierAlgebra         >=> render (renderJSONTerm blob)
-      parse syntaxParser blob >>= decorate syntaxIdentifierAlgebra >>= render (renderJSONTerm blob)
+    SExpressionTermRenderer ->                                              render renderSExpressionTerm . fmap keepCategory
+    TagsTermRenderer        -> decorate (syntaxDeclarationAlgebra blob) >=> render (renderToTags blob)
 
-  (SExpressionTermRenderer, lang)
+  | otherwise = throwError (SomeException (NoParserForLanguage blobPath blobLanguage))
-    | 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))
 
 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
+diffBlobPair renderer blobs
-  (OldToCDiffRenderer, lang)
+  | Just (SomeParser parser) <- effectiveLanguage >>= qualify >>= someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Show1, ToJSONFields1, Traversable])
-    | elem lang $ fmap Just [
+  = case renderer of
-        Language.JSX,
+    OldToCDiffRenderer      -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))   diffTerms renderToCDiff
-        Language.JavaScript,
+    ToCDiffRenderer         -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))   diffTerms renderToCDiff
-        Language.Markdown,
+    JSONDiffRenderer        -> run (          parse parser)                                               diffTerms renderJSONDiff
-        Language.Python,
+    SExpressionDiffRenderer -> run (          parse parser      >=> decorate constructorLabel . (Nil <$)) diffTerms (const renderSExpressionDiff)
-        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)
 
-  (ToCDiffRenderer, lang)
+  | Just parser <- effectiveLanguage >>= syntaxParserForLanguage
-    | Just (SomeParser parser) <- lang >>= someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, HasDeclaration, Show1, Traversable]) ->
+  = case renderer of
-      run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms (renderToCDiff blobs)
+    OldToCDiffRenderer      -> run (\ blob -> parse parser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms renderToCDiff
-    | Just syntaxParser <- lang >>= syntaxParserForLanguage ->
+    ToCDiffRenderer         -> run (\ blob -> parse parser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms renderToCDiff
-      run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffSyntaxTerms (renderToCDiff blobs)
+    JSONDiffRenderer        -> run (          parse parser      >=> decorate syntaxIdentifierAlgebra)         diffSyntaxTerms renderJSONDiff
+    SExpressionDiffRenderer -> run (          parse parser      >=> pure . fmap keepCategory)                 diffSyntaxTerms (const renderSExpressionDiff)
 
-  (JSONDiffRenderer, lang)
+  | otherwise = throwError (SomeException (NoParserForLanguage effectivePath effectiveLanguage))
-    | 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))
   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