From ae985ef4e51c0eaf23cd14d27b3fc14da04bd0ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 27 Nov 2017 14:45:13 -0500 Subject: [PATCH] Factor ConstructorName into its own module. --- semantic-diff.cabal | 3 +- src/Analysis/ConstructorName.hs | 78 +++++++++++++++++++++++++++++++++ src/Analysis/Decorator.hs | 66 ---------------------------- src/Semantic.hs | 3 +- 4 files changed, 82 insertions(+), 68 deletions(-) create mode 100644 src/Analysis/ConstructorName.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index f6a1c4dad..27ed1793d 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -15,7 +15,8 @@ library hs-source-dirs: src exposed-modules: -- Analyses & term annotations - Analysis.Decorator + Analysis.ConstructorName + , Analysis.Decorator -- Semantic assignment , Assigning.Assignment , Assigning.Assignment.Table diff --git a/src/Analysis/ConstructorName.hs b/src/Analysis/ConstructorName.hs new file mode 100644 index 000000000..180c6dc0d --- /dev/null +++ b/src/Analysis/ConstructorName.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +module Analysis.ConstructorName +( ConstructorName(..) +, ConstructorLabel(..) +, constructorLabel +) where + +import Data.Aeson +import Data.ByteString.Char8 (ByteString, pack, unpack) +import Data.JSON.Fields +import Data.Proxy +import Data.Term +import Data.Text.Encoding (decodeUtf8) +import Data.Union +import GHC.Generics + +-- | Compute a 'ConstructorLabel' label for a 'Term'. +constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel +constructorLabel (In _ s) = ConstructorLabel $ pack (constructorName s) + + +newtype ConstructorLabel = ConstructorLabel ByteString + +instance Show ConstructorLabel where + showsPrec _ (ConstructorLabel s) = showString (unpack s) + +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/Rendering/TOC.hs for discussion of the details of the mechanism. +class ConstructorName syntax where + constructorName :: syntax a -> String + +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 + 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 = conName diff --git a/src/Analysis/Decorator.hs b/src/Analysis/Decorator.hs index ab001be1b..15180b13f 100644 --- a/src/Analysis/Decorator.hs +++ b/src/Analysis/Decorator.hs @@ -3,10 +3,7 @@ module Analysis.Decorator ( decoratorWithAlgebra , syntaxIdentifierAlgebra , cyclomaticComplexityAlgebra -, ConstructorName(..) -, ConstructorLabel(..) , constructorNameAndConstantFields -, constructorLabel ) where import Data.Aeson @@ -82,66 +79,3 @@ cyclomaticComplexityAlgebra (In _ union) = case union of -- 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 :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel -constructorLabel (In _ s) = ConstructorLabel $ pack (constructorName s) - - -newtype ConstructorLabel = ConstructorLabel ByteString - -instance Show ConstructorLabel where - showsPrec _ (ConstructorLabel s) = showString (unpack s) - -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 - -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 - 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 = conName diff --git a/src/Semantic.hs b/src/Semantic.hs index e074f575b..19b827a19 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -7,7 +7,8 @@ module Semantic , diffTermPair ) where -import Analysis.Decorator +import Analysis.ConstructorName (ConstructorName, constructorLabel) +import Analysis.Decorator (syntaxIdentifierAlgebra) import Control.Exception import Control.Monad ((>=>), guard) import Control.Monad.Error.Class