From dd9e6819e0bee4b0a0f7a898edd79e5dbbb1c688 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Jun 2017 11:41:31 -0400 Subject: [PATCH 1/5] Bump effects for Data.Union instances. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index de7961dd6..c47eace16 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit de7961dd6884565dfc9e45309a0c56539a00af17 +Subproject commit c47eace1669cd185286feb336be1a67a28761f5a From 40a6dc3e82edd84d407d0da6e511ddf57ba6f0b0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Jun 2017 11:42:01 -0400 Subject: [PATCH 2/5] Define GAlign instances for Data.Union. --- src/Data/Align/Generic.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Data/Align/Generic.hs b/src/Data/Align/Generic.hs index d6df432be..eedf195f1 100644 --- a/src/Data/Align/Generic.hs +++ b/src/Data/Align/Generic.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DefaultSignatures, TypeOperators #-} +{-# LANGUAGE DataKinds, DefaultSignatures, TypeOperators #-} module Data.Align.Generic where import Control.Monad import Data.Align import Data.These +import Data.Union import GHC.Generics import Prologue @@ -29,6 +30,20 @@ instance GAlign Maybe where instance GAlign Identity where galignWith f (Identity a) (Identity b) = Just (Identity (f (These a b))) +instance (GAlign f, GAlign (Union fs)) => GAlign (Union (f ': fs)) where + galign u1 u2 = case (decompose u1, decompose u2) of + (Left u1', Left u2') -> weaken <$> galign u1' u2' + (Right r1, Right r2) -> inj <$> galign r1 r2 + _ -> Nothing + galignWith f u1 u2 = case (decompose u1, decompose u2) of + (Left u1', Left u2') -> weaken <$> galignWith f u1' u2' + (Right r1, Right r2) -> inj <$> galignWith f r1 r2 + _ -> Nothing + +instance GAlign (Union '[]) where + galign _ _ = Nothing + galignWith _ _ _ = Nothing + -- | Implements a function suitable for use as the definition of 'galign' for 'Align'able functors. galignAlign :: Align f => f a -> f b -> Maybe (f (These a b)) galignAlign a = Just . align a From 5deba93c3e1fc88ee1fb391297487e7f1fb2065f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Jun 2017 11:42:57 -0400 Subject: [PATCH 3/5] Migrate everything over to Data.Union. --- src/Data/Syntax/Algebra.hs | 6 +++--- src/Data/Syntax/Literal.hs | 3 +-- src/Language/Python/Syntax.hs | 4 ++-- src/Language/Ruby/Syntax.hs | 8 ++++---- src/Parser.hs | 11 +++++------ src/Renderer/JSON.hs | 7 ++++--- src/Renderer/TOC.hs | 8 ++++---- src/Semantic.hs | 2 +- 8 files changed, 24 insertions(+), 25 deletions(-) diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index ca8f0fe4e..ed15792ff 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -9,11 +9,11 @@ module Data.Syntax.Algebra ) where import Data.Functor.Foldable -import Data.Functor.Union import Data.Record import qualified Data.Syntax as Syntax import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Statement as Statement +import Data.Union import Prologue import Term @@ -41,7 +41,7 @@ newtype Identifier = Identifier ByteString -- | Produce the identifier for a given term, if any. -- -- Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not. -identifierAlgebra :: (InUnion fs Syntax.Identifier, InUnion fs Declaration.Method, InUnion fs Declaration.Class, Traversable (Union fs)) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier) +identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Traversable (Union fs)) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier) identifierAlgebra (_ :< union) = case union of _ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s) _ | Just Declaration.Class{..} <- prj union -> classIdentifier @@ -57,7 +57,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int -- TODO: Explicit returns at the end of methods should only count once. -- TODO: Anonymous functions should not increase parent scope’s complexity. -- TODO: Inner functions should not increase parent scope’s complexity. -cyclomaticComplexityAlgebra :: (InUnion fs Declaration.Method, InUnion fs Statement.Return, InUnion fs Statement.Yield, Traversable (Union fs)) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity +cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Traversable (Union fs)) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity cyclomaticComplexityAlgebra (_ :< union) = case union of _ | Just Declaration.Method{} <- prj union -> succ (sum union) _ | Just Statement.Return{} <- prj union -> succ (sum union) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index cabbde891..ec715d5b9 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -4,7 +4,7 @@ module Data.Syntax.Literal where import Data.Align.Generic import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Show.Generic -import Data.Functor.Union +import Data.Union import GHC.Generics import Prologue hiding (Set) @@ -132,4 +132,3 @@ instance Show1 Set where liftShowsPrec = genericLiftShowsPrec -- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”? -- TODO: Function literals (lambdas, procs, anonymous functions, what have you). -- TODO: Regexp literals. - diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 158849b9d..81897d111 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -10,7 +10,6 @@ module Language.Python.Syntax import Data.Align.Generic import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Show.Generic -import Data.Functor.Union import qualified Data.Syntax as Syntax import Data.Syntax.Assignment hiding (Error) import qualified Data.Syntax.Assignment as Assignment @@ -19,6 +18,7 @@ import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement +import Data.Union import GHC.Generics import GHC.Stack import Language.Python.Grammar as Grammar @@ -319,7 +319,7 @@ comprehension = makeTerm <$> symbol GeneratorExpression <*> children (comprehen conditionalExpression :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) conditionalExpression = makeTerm <$> symbol ConditionalExpression <*> children (expression >>= \ thenBranch -> expression >>= \ conditional -> Statement.If conditional thenBranch <$> (expression <|> emptyTerm)) -makeTerm :: HasCallStack => InUnion Syntax' f => a -> f (Term Syntax a) -> Term Syntax a +makeTerm :: HasCallStack => f :< Syntax' => a -> f (Term Syntax a) -> Term Syntax a makeTerm a f = cofree (a :< inj f) emptyTerm :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index a03c3fb14..c02b8bfb2 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds, TypeOperators #-} module Language.Ruby.Syntax ( assignment , Syntax @@ -7,7 +7,6 @@ module Language.Ruby.Syntax , Error ) where -import Data.Functor.Union import qualified Data.Syntax as Syntax import Data.Syntax.Assignment hiding (Error) import qualified Data.Syntax.Assignment as Assignment @@ -16,6 +15,7 @@ import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Expression as Expression import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Statement as Statement +import Data.Union import GHC.Stack import Language.Ruby.Grammar as Grammar import Prologue hiding (for, get, Location, state, unless) @@ -149,10 +149,10 @@ literal = makeTerm <$> symbol Grammar.True <*> (Literal.true <$ source) <|> makeTerm <$> symbol Symbol <*> (Literal.Symbol <$> source) <|> makeTerm <$> symbol Range <*> children (Literal.Range <$> statement <*> statement) -- FIXME: represent the difference between .. and ... -invert :: (InUnion fs Expression.Boolean, HasCallStack) => Assignment (Node grammar) (Term (Union fs) Location) -> Assignment (Node grammar) (Term (Union fs) Location) +invert :: (Expression.Boolean :< fs, HasCallStack) => Assignment (Node grammar) (Term (Union fs) Location) -> Assignment (Node grammar) (Term (Union fs) Location) invert term = makeTerm <$> location <*> fmap Expression.Not term -makeTerm :: (InUnion fs f, HasCallStack) => a -> f (Term (Union fs) a) -> (Term (Union fs) a) +makeTerm :: (f :< fs, HasCallStack) => a -> f (Term (Union fs) a) -> (Term (Union fs) a) makeTerm a f = cofree $ a :< inj f emptyTerm :: HasCallStack => Assignment (Node Grammar) (Term Syntax Location) diff --git a/src/Parser.hs b/src/Parser.hs index 975260534..e73bff180 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables #-} +{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-} module Parser where -import Data.Functor.Union import Data.Record import qualified Data.Syntax as Syntax import Data.Syntax.Assignment -import Data.Functor.Union (inj) import qualified Data.Text as T +import Data.Union import Info hiding (Empty, Go) import Language import Language.Markdown @@ -32,7 +31,7 @@ data Parser term where -- | A parser producing 'AST' using a 'TS.Language'. ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST grammar) -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. Assignment errors will result in a top-level 'Syntax.Error' node. - AssignmentParser :: (Bounded grammar, Enum grammar, Eq grammar, Show grammar, Symbol grammar, InUnion fs (Syntax.Error (Error grammar)), Traversable (Union fs)) + AssignmentParser :: (Bounded grammar, Enum grammar, Eq grammar, Show grammar, Symbol grammar, Syntax.Error (Error grammar) :< fs, Traversable (Union fs)) => Parser (AST grammar) -- ^ A parser producing 'AST'. -> Assignment (Node grammar) (Term (Union fs) Location) -- ^ An assignment from 'AST' onto 'Term's. -> Parser (Term (Union fs) Location) -- ^ A parser of 'Term's. @@ -80,10 +79,10 @@ runParser parser = case parser of where showSGRCode = showString . setSGRCode withSGRCode code s = showSGRCode code . s . showSGRCode [] -errorTerm :: InUnion fs (Syntax.Error (Error grammar)) => Source -> Maybe (Error grammar) -> Term (Union fs) Location +errorTerm :: Syntax.Error (Error grammar) :< fs => Source -> Maybe (Error grammar) -> Term (Union fs) Location errorTerm source err = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error (fromMaybe (Error (SourcePos 0 0) (UnexpectedEndOfInput [])) err))) -termErrors :: (InUnion fs (Syntax.Error (Error grammar)), Functor (Union fs), Foldable (Union fs)) => Term (Union fs) a -> [Error grammar] +termErrors :: (Syntax.Error (Error grammar) :< fs, Functor (Union fs), Foldable (Union fs)) => Term (Union fs) a -> [Error grammar] termErrors = cata $ \ (_ :< s) -> case s of _ | Just (Syntax.Error err) <- prj s -> [err] _ -> fold s diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 58ad2bac7..bb0e62639 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -10,9 +10,9 @@ import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) import Data.Aeson as A hiding (json) import Data.Bifunctor.Join import Data.Functor.Both (Both) -import Data.Functor.Union import qualified Data.Map as Map import Data.Record +import Data.Union import Info import Language import Patch @@ -104,8 +104,9 @@ instance ToJSON recur => ToJSONFields (Syntax leaf recur) where toJSONFields syntax = [ "children" .= toList syntax ] instance (Foldable f, ToJSON a, ToJSONFields (Union fs a)) => ToJSONFields (Union (f ': fs) a) where - toJSONFields (Here f) = [ "children" .= toList f ] - toJSONFields (There fs) = toJSONFields fs + toJSONFields u = case decompose u of + Left u' -> toJSONFields u' + Right r -> [ "children" .= toList r ] instance ToJSONFields (Union '[] a) where toJSONFields _ = [] diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index e88e09746..a782a9705 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, RankNTypes #-} +{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, RankNTypes, TypeOperators #-} module Renderer.TOC ( renderToC , diffTOC @@ -20,12 +20,12 @@ import Data.Align (crosswalk) import Data.Functor.Both hiding (fst, snd) import qualified Data.Functor.Both as Both import Data.Functor.Listable -import Data.Functor.Union import Data.Proxy +import Data.Record import Data.Text (toLower) import Data.Text.Listable import Data.These -import Data.Record +import Data.Union import Diff import Info import Patch @@ -99,7 +99,7 @@ syntaxDeclarationAlgebra source r = case tailF r of where getSource = toText . flip Source.slice source . byteRange . extract -- | Compute 'Declaration's for methods and functions. -declarationAlgebra :: (InUnion fs Declaration.Function, InUnion fs Declaration.Method, InUnion fs (Syntax.Error error), Show error, Functor (Union fs), HasField fields Range) +declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error error :< fs, Show error, Functor (Union fs), HasField fields Range) => Proxy error -> Source -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) diff --git a/src/Semantic.hs b/src/Semantic.hs index 984563354..fd8b14cb3 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -11,10 +11,10 @@ import Algorithm hiding (diff) import Data.Align.Generic (GAlign) import Data.Functor.Both as Both import Data.Functor.Classes (Eq1, Show1) -import Data.Functor.Union import Data.Proxy import Data.Record import qualified Data.Syntax.Declaration as Declaration +import Data.Union import Diff import Info import Interpreter From 8284bccbfe5c91a5aed457b046a6a41d6601f788 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Jun 2017 11:43:18 -0400 Subject: [PATCH 4/5] :fire: Data.Functor.Union. --- semantic-diff.cabal | 1 - src/Data/Functor/Union.hs | 126 -------------------------------------- 2 files changed, 127 deletions(-) delete mode 100644 src/Data/Functor/Union.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 02e3a95c1..88fde6181 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -25,7 +25,6 @@ library , Data.Functor.Classes.Eq.Generic , Data.Functor.Classes.Show.Generic , Data.Functor.Listable - , Data.Functor.Union , Data.Mergeable , Data.Mergeable.Generic , Data.Record diff --git a/src/Data/Functor/Union.hs b/src/Data/Functor/Union.hs deleted file mode 100644 index 765c95107..000000000 --- a/src/Data/Functor/Union.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, PolyKinds, TypeFamilies, TypeOperators #-} -module Data.Functor.Union -( Union(..) -, wrapU -, unwrapU -, InUnion(..) -, weaken -) where - -import Data.Align.Generic -import Data.Functor.Classes -import Data.Kind -import GHC.Show -import Prologue - --- | N-ary union of type constructors. -data Union (ts :: [k -> *]) (a :: k) where - -- | An element of the first type in the union’s list. - Here :: f a -> Union (f ': ts) a - -- | An element of a later type in the union’s list. - There :: Union ts a -> Union (f ': ts) a - --- | Embed a functor in a union and lift the union into a free monad. -wrapU :: (MonadFree (Union fs) m, InUnion fs f) => f (m a) -> m a -wrapU = wrap . inj - --- | Unwrap a cofree comonad and project a functor from the resulting union. -unwrapU :: (ComonadCofree (Union fs) w, InUnion fs f) => w a -> Maybe (f (w a)) -unwrapU = prj . unwrap - - -strengthen :: Union '[f] a -> f a -strengthen (Here f) = f -strengthen _ = panic "strengthening an empty union by some catastrophic failure of typechecking & assumptions" - -weaken :: Union fs a -> Union (f ': fs) a -weaken = There - - --- Classes - -class InUnion (fs :: [* -> *]) (f :: * -> *) where - inj :: f a -> Union fs a - prj :: Union fs a -> Maybe (f a) - -type family Superset (combine :: [k] -> k -> Constraint) (fs :: [k]) (gs :: [k]) :: Constraint where - Superset combine fs (g ': gs) = (combine fs g, Superset combine fs gs) - Superset combine fs '[] = () - - --- Instances - -instance {-# OVERLAPPABLE #-} InUnion (f ': fs) f where - inj = Here - prj (Here f) = Just f - prj _ = Nothing - -instance {-# OVERLAPPABLE #-} InUnion fs f => InUnion (g ': fs) f where - inj f = There (inj f) - prj (There fs) = prj fs - prj _ = Nothing - - -instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f ': fs)) where - foldMap f (Here r) = foldMap f r - foldMap f (There t) = foldMap f t - -instance Foldable (Union '[]) where - foldMap _ _ = mempty - - -instance Functor f => Functor (Union '[f]) where - fmap f = Here . fmap f . strengthen - -instance (Functor f, Functor (Union (g ': hs))) => Functor (Union (f ': g ': hs)) where - fmap f (Here e) = Here (fmap f e) - fmap f (There t) = There (fmap f t) - - -instance Traversable f => Traversable (Union '[f]) where - traverse f = fmap Here . traverse f . strengthen - -instance (Traversable f, Traversable (Union (g ': hs))) => Traversable (Union (f ': g ': hs)) where - traverse f (Here r) = Here <$> traverse f r - traverse f (There t) = There <$> traverse f t - - -instance (Eq (f a), Eq (Union fs a)) => Eq (Union (f ': fs) a) where - Here f1 == Here f2 = f1 == f2 - There fs1 == There fs2 = fs1 == fs2 - _ == _ = False - -instance Eq (Union '[] a) where - _ == _ = False - - -instance (Show (f a), Show (Union fs a)) => Show (Union (f ': fs) a) where - showsPrec d s = case s of - Here f -> showsPrec d f - There fs -> showsPrec d fs - -instance Show (Union '[] a) where - showsPrec _ _ = identity - -instance (Eq1 f, Eq1 (Union fs)) => Eq1 (Union (f ': fs)) where - liftEq eq (Here f) (Here g) = liftEq eq f g - liftEq eq (There f) (There g) = liftEq eq f g - liftEq _ _ _ = False - -instance Eq1 (Union '[]) where - liftEq _ _ _ = False -- We can never get here anyway. - -instance (Show1 f, Show1 (Union fs)) => Show1 (Union (f ': fs)) where - liftShowsPrec sp sl d (Here f) = liftShowsPrec sp sl d f - liftShowsPrec sp sl d (There f) = liftShowsPrec sp sl d f - -instance Show1 (Union '[]) where - liftShowsPrec _ _ _ _ = identity - -instance (GAlign f, GAlign (Union fs)) => GAlign (Union (f ': fs)) where - galignWith f (Here a) (Here b) = Here <$> galignWith f a b - galignWith f (There a) (There b) = There <$> galignWith f a b - galignWith _ _ _ = Nothing - -instance GAlign (Union '[]) where - galignWith _ _ _ = Nothing From 15f7f81b5433a53eb531d191ceb15928d487f64e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Jun 2017 13:18:44 -0400 Subject: [PATCH 5/5] InUnion -> :< --- src/Renderer/TOC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index df6045985..923c02659 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -114,7 +114,7 @@ declarationAlgebra proxy source r where getSource = toText . flip Source.slice source . byteRange . extract -- | Compute 'Declaration's with the headings of 'Markup.Section's. -markupSectionAlgebra :: (InUnion fs Markup.Section, InUnion fs (Syntax.Error error), HasField fields Range, Show error, Functor (Union fs)) +markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error error :< fs, HasField fields Range, Show error, Functor (Union fs)) => Proxy error -> Source -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)