Merge pull request #1150 from github/union-unity

Union unity

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

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

src/Data/Functor/Union.hs

@@ -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

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)

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.
-

src/Language/Markdown/Syntax.hs

@@ -8,13 +8,13 @@ module Language.Markdown.Syntax
 ) where
 
 import qualified CMark
-import Data.Functor.Union
 import Data.Record
 import Data.Syntax.Assignment hiding (Assignment, Error)
 import qualified Data.Syntax.Assignment as Assignment
 import qualified Data.Syntax.Markup as Markup
 import qualified Data.Syntax as Syntax
 import qualified Data.Text as Text
+import Data.Union
 import GHC.Stack
 import Language.Markdown as Grammar (Grammar(..))
 import Prologue hiding (Location, link, list, section)
@@ -122,7 +122,7 @@ softBreak = makeTerm <$> symbol SoftBreak <*> (Markup.LineBreak <$ source)
 
 -- Implementation details
 
-makeTerm :: (InUnion fs f, HasCallStack) => a -> f (Term.Term (Union fs) a) -> Term.Term (Union fs) a
+makeTerm :: (f :< fs, HasCallStack) => a -> f (Term.Term (Union fs) a) -> Term.Term (Union fs) a
 makeTerm a f = cofree $ a :< inj f
 
 nullText :: Text.Text -> Maybe ByteString

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 Data.Record
 import qualified Data.Syntax as Syntax
 import Data.Syntax.Assignment hiding (Assignment, Error)
@@ -20,6 +19,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
@@ -354,7 +354,7 @@ comprehension =  makeTerm <$> symbol GeneratorExpression <*> children (comprehen
 conditionalExpression :: Assignment
 conditionalExpression = makeTerm <$> symbol ConditionalExpression <*> children (expression >>= \ thenBranch -> expression >>= \ conditional -> Statement.If conditional thenBranch <$> (expression <|> emptyTerm))
 
-makeTerm :: (HasCallStack, InUnion fs f) => a -> f (Term.Term (Union fs) a) -> Term.Term (Union fs) a
+makeTerm :: (HasCallStack, f :< fs) => a -> f (Term.Term (Union fs) a) -> Term.Term (Union fs) a
 makeTerm a f = cofree (a :< inj f)
 
 emptyTerm :: Assignment

src/Language/Ruby/Syntax.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, RankNTypes #-}
+{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-}
 module Language.Ruby.Syntax
 ( assignment
 , Syntax
@@ -7,7 +7,6 @@ module Language.Ruby.Syntax
 , Term
 ) where
 
-import Data.Functor.Union
 import Data.Record
 import qualified Data.Syntax as Syntax
 import Data.Syntax.Assignment hiding (Assignment, Error)
@@ -17,6 +16,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)
@@ -151,10 +151,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.Assignment ast grammar (Term.Term (Union fs) (Record Location)) -> Assignment.Assignment ast grammar (Term.Term (Union fs) (Record Location))
+invert :: (Expression.Boolean :< fs, HasCallStack) => Assignment.Assignment ast grammar (Term.Term (Union fs) (Record Location)) -> Assignment.Assignment ast grammar (Term.Term (Union fs) (Record Location))
 invert term = makeTerm <$> location <*> fmap Expression.Not term
 
-makeTerm :: (InUnion fs f, HasCallStack) => a -> f (Term.Term (Union fs) a) -> Term.Term (Union fs) a
+makeTerm :: (f :< fs, HasCallStack) => a -> f (Term.Term (Union fs) a) -> Term.Term (Union fs) a
 makeTerm a f = cofree $ a :< inj f
 
 emptyTerm :: Assignment

src/Parser.hs

@@ -2,13 +2,12 @@
 module Parser where
 
 import qualified CMark
-import Data.Functor.Union
 import Data.Record
 import qualified Data.Syntax as Syntax
 import Data.Syntax.Assignment
 import Data.Functor.Foldable hiding (fold, Nil)
-import Data.Functor.Union (inj)
 import qualified Data.Text as T
+import Data.Union
 import Info hiding (Empty, Go)
 import Language
 import Language.Markdown
@@ -35,7 +34,7 @@ data Parser term where
   -- | A parser producing 'AST' using a 'TS.Language'.
   ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (Cofree [] (Record (Maybe grammar ': Location)))
   -- | 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), Recursive ast, Foldable (Base ast))
+  AssignmentParser :: (Bounded grammar, Enum grammar, Eq grammar, Show grammar, Symbol grammar, Syntax.Error (Error grammar) :< fs, Traversable (Union fs), Recursive ast, Foldable (Base ast))
                    => Parser ast                                                   -- ^ A parser producing AST.
                    -> (forall x. Base ast x -> Record (Maybe grammar ': Location)) -- ^ A function extracting the symbol and location.
                    -> Assignment ast grammar (Term (Union fs) (Record Location))   -- ^ An assignment from AST onto 'Term's.
@@ -88,10 +87,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) (Record Location)
+errorTerm :: Syntax.Error (Error grammar) :< fs => Source -> Maybe (Error grammar) -> Term (Union fs) (Record 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

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 u = case decompose u of
-  toJSONFields (There fs) = toJSONFields fs
+    Left u' -> toJSONFields u'
+    Right r -> [ "children" .= toList r ]
 
 instance ToJSONFields (Union '[] a) where
   toJSONFields _ = []

src/Renderer/TOC.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, RankNTypes #-}
+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, RankNTypes, TypeOperators #-}
 module Renderer.TOC
 ( renderToC
 , diffTOC
@@ -21,12 +21,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
@@ -102,7 +102,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)
@@ -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)

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

vendor/effects

@@ -1 +1 @@
-Subproject commit de7961dd6884565dfc9e45309a0c56539a00af17
+Subproject commit c47eace1669cd185286feb336be1a67a28761f5a