Merge the Decorators module into Data.Syntax.Algebra.

semantic-diff.cabal

@@ -44,7 +44,6 @@ library
                      , Data.Syntax.Statement
                      , Data.Syntax.Type
                      , Data.Term
-                     , Decorators
                      , Files
                      , Info
                      , Interpreter

src/Data/Syntax/Algebra.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeOperators #-}
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 module Data.Syntax.Algebra
 ( FAlgebra
 , RAlgebra
@@ -7,21 +7,27 @@ module Data.Syntax.Algebra
 , identifierAlgebra
 , syntaxIdentifierAlgebra
 , cyclomaticComplexityAlgebra
+, ConstructorLabel(..)
+, constructorNameAndConstantFields
+, constructorLabel
 ) where
 
 import Data.Aeson
 import Data.Bifunctor (second)
-import Data.ByteString (ByteString)
+import Data.ByteString.Char8 (ByteString, pack, unpack)
 import Data.Foldable (asum)
+import Data.Functor.Classes (Show1 (liftShowsPrec))
 import Data.Functor.Foldable
 import Data.JSON.Fields
 import Data.Record
+import Data.Proxy
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
 import qualified Data.Syntax.Statement as Statement
 import Data.Term
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Union
+import GHC.Generics
 import qualified Syntax as S
 
 -- | An F-algebra on some carrier functor 'f'.
@@ -92,3 +98,46 @@ cyclomaticComplexityAlgebra (In _ union) = case union of
   _ | Just Statement.Return{} <- prj union -> succ (sum union)
   _ | Just Statement.Yield{} <- prj union -> succ (sum union)
   _ -> sum union
+
+-- | Compute a 'ByteString' label for a 'Show1'able 'Term'.
+--
+--   This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that
+--   constant fields will be included and parametric fields will not be.
+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)
+
+
+newtype ConstructorLabel = ConstructorLabel ByteString
+
+instance Show ConstructorLabel where
+  showsPrec _ (ConstructorLabel s) = showString (unpack s)
+
+instance ToJSONFields ConstructorLabel where
+  toJSONFields (ConstructorLabel s) = [ "category" .= decodeUtf8 s ]
+
+
+class ConstructorName f where
+  constructorName :: f a -> String
+
+instance (Generic1 f, GConstructorName (Rep1 f)) => ConstructorName f where
+  constructorName = gconstructorName . from1
+
+
+class GConstructorName f where
+  gconstructorName :: f a -> String
+
+instance GConstructorName f => GConstructorName (M1 D c f) where
+  gconstructorName = gconstructorName . unM1
+
+instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g) where
+  gconstructorName (L1 l) = gconstructorName l
+  gconstructorName (R1 r) = gconstructorName r
+
+instance Constructor c => GConstructorName (M1 C c f) where
+  gconstructorName x = case conName x of
+                        ":" -> ""
+                        n -> n

src/Decorators.hs

@@ -1,59 +0,0 @@
-{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-}
-module Decorators
-( ConstructorLabel(..)
-, constructorNameAndConstantFields
-, constructorLabel
-) where
-
-import Data.Aeson
-import Data.ByteString.Char8 (ByteString, pack, unpack)
-import Data.Functor.Classes (Show1 (liftShowsPrec))
-import Data.JSON.Fields
-import Data.Proxy
-import Data.Term
-import Data.Text.Encoding (decodeUtf8)
-import Data.Union
-import GHC.Generics
-
--- | Compute a 'ByteString' label for a 'Show1'able 'Term'.
---
---   This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that
---   constant fields will be included and parametric fields will not be.
-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)
-
-
-newtype ConstructorLabel = ConstructorLabel ByteString
-
-instance Show ConstructorLabel where
-  showsPrec _ (ConstructorLabel s) = showString (unpack s)
-
-instance ToJSONFields ConstructorLabel where
-  toJSONFields (ConstructorLabel s) = [ "category" .= decodeUtf8 s ]
-
-
-class ConstructorName f where
-  constructorName :: f a -> String
-
-instance (Generic1 f, GConstructorName (Rep1 f)) => ConstructorName f where
-  constructorName = gconstructorName . from1
-
-
-class GConstructorName f where
-  gconstructorName :: f a -> String
-
-instance GConstructorName f => GConstructorName (M1 D c f) where
-  gconstructorName = gconstructorName . unM1
-
-instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g) where
-  gconstructorName (L1 l) = gconstructorName l
-  gconstructorName (R1 r) = gconstructorName r
-
-instance Constructor c => GConstructorName (M1 C c f) where
-  gconstructorName x = case conName x of
-                        ":" -> ""
-                        n -> n

src/Interpreter.hs

@@ -16,12 +16,12 @@ import Data.Hashable (Hashable)
 import Data.Maybe (fromMaybe, isJust)
 import Data.Record
 import qualified Data.Syntax as Syntax
+import Data.Syntax.Algebra
 import qualified Data.Syntax.Declaration as Declaration
 import Data.Term
 import Data.Text (Text)
 import Data.These
 import Data.Union
-import Decorators
 import Info hiding (Empty, Return)
 import RWS
 import Syntax (Syntax(Leaf))

src/Semantic.hs

@@ -18,7 +18,6 @@ import Data.Output
 import Data.Record
 import Data.Syntax.Algebra
 import Data.Term
-import Decorators
 import Info
 import Interpreter
 import qualified Language
@@ -49,7 +48,7 @@ parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of
   (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob)
   (JSONTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob)
   (JSONTermRenderer, Just Language.Ruby) -> parse rubyParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob)
-  (JSONTermRenderer, _) -> parse syntaxParser blob >>= decorate identifierAlgebra >>= render (renderJSONTerm blob)
+  (JSONTermRenderer, _) -> parse syntaxParser blob >>= decorate syntaxIdentifierAlgebra >>= render (renderJSONTerm blob)
   (SExpressionTermRenderer, Just Language.JSON) -> parse jsonParser blob >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel
   (SExpressionTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel
   (SExpressionTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel
@@ -81,7 +80,7 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
   (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffTerms (renderJSONDiff blobs)
   (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffTerms (renderJSONDiff blobs)
   (JSONDiffRenderer, Just Language.Ruby) -> run (parse rubyParser) diffTerms (renderJSONDiff blobs)
-  (JSONDiffRenderer, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffSyntaxTerms (renderJSONDiff blobs)
+  (JSONDiffRenderer, _) -> run (decorate syntaxIdentifierAlgebra <=< parse syntaxParser) diffSyntaxTerms (renderJSONDiff blobs)
   (PatchDiffRenderer, Just Language.JSON) -> run (parse jsonParser) diffTerms (renderPatch blobs)
   (PatchDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffTerms (renderPatch blobs)
   (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffTerms (renderPatch blobs)

test/Data/RandomWalkSimilarity/Spec.hs

@@ -7,10 +7,10 @@ import Data.Diff
 import Data.Functor.Listable (ListableSyntax)
 import Data.Record
 import qualified Data.Syntax as Syntax
+import Data.Syntax.Algebra
 import Data.Term
 import Data.These
 import Data.Union
-import Decorators
 import Interpreter
 import RWS
 import Test.Hspec