Merge branch 'faster-union-instance-compilation' into delimited-control

src/Algorithm.hs

@@ -2,12 +2,13 @@
 module Algorithm where
 
 import Control.Applicative (liftA2)
-import Control.Monad (guard)
+import Control.Monad (guard, join)
 import Control.Monad.Free.Freer
 import Data.Function (on)
 import Data.Functor.Both
 import Data.Functor.Classes
 import Data.Maybe
+import Data.Proxy
 import Data.These
 import Data.Union
 import Diff
@@ -100,21 +101,13 @@ class Diffable f where
 -- Right is the "head" of the Union. 'weaken' relaxes the Union to allow the possible
 -- diff terms from the "rest" of the Union, and 'inj' adds the diff terms into the Union.
 -- NB: If Left or Right Syntax terms in our Union don't match, we fail fast by returning Nothing.
-instance (Diffable f, Diffable (Union fs)) => Diffable (Union (f ': fs)) where
-  algorithmFor u1 u2 = case (decompose u1, decompose u2) of
-    (Left l1, Left l2) -> fmap weaken <$> algorithmFor l1 l2
-    (Right r1, Right r2) -> fmap inj <$> algorithmFor r1 r2
-    _ -> Nothing
+instance Apply1 Diffable fs => Diffable (Union fs) where
+  algorithmFor u1 u2 = join (apply1_2' (Proxy :: Proxy Diffable) (\ reinj f1 f2 -> fmap reinj <$> algorithmFor f1 f2) u1 u2)
 
 -- | Diff two list parameters using RWS.
 instance Diffable [] where
   algorithmFor a b = Just (byRWS a b)
 
--- | Diffing an empty Union is technically impossible because Union '[] uninhabited.
--- This instance is included because GHC cannot prove that.
-instance Diffable (Union '[]) where
-  algorithmFor _ _ = Nothing
-
 -- | A generic type class for diffing two terms defined by the Generic1 interface.
 class Diffable' f where
   algorithmFor' :: f term -> f term -> Maybe (Algorithm term diff (f diff))

src/Data/Align/Generic.hs

@@ -4,6 +4,7 @@ module Data.Align.Generic where
 import Control.Monad
 import Data.Align
 import Data.Functor.Identity
+import Data.Proxy
 import Data.These
 import Data.Union
 import GHC.Generics
@@ -27,11 +28,8 @@ 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
-  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 (Apply1 GAlign fs) => GAlign (Union fs) where
+  galignWith f = (join .) . apply1_2' (Proxy :: Proxy GAlign) (\ inj -> (fmap inj .) . galignWith f)
 
 instance GAlign (Union '[]) where
   galignWith _ _ _ = Nothing

src/Data/Syntax/Algebra.hs

@@ -43,7 +43,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 :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Traversable (Union fs)) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier)
+identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply1 Foldable fs, Apply1 Functor 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
@@ -59,7 +59,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 :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Traversable (Union fs)) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity
+cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply1 Foldable fs, Apply1 Functor 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/Decorators.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, TypeOperators #-}
+{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-}
 module Decorators
 ( ConstructorLabel(..)
 , constructorNameAndConstantFields
@@ -8,6 +8,7 @@ module Decorators
 import Data.Aeson
 import Data.ByteString.Char8 (ByteString, pack, unpack)
 import Data.Functor.Classes (Show1 (liftShowsPrec))
+import Data.Proxy
 import Data.Text.Encoding (decodeUtf8)
 import Data.Union
 import GHC.Generics
@@ -22,8 +23,8 @@ constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString
 constructorNameAndConstantFields (_ :< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")
 
 -- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's.
-constructorLabel :: ConstructorName f => TermF f a b -> ConstructorLabel
-constructorLabel (_ :< f) = ConstructorLabel $ pack (constructorName f)
+constructorLabel :: Apply1 ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel
+constructorLabel (_ :< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u)
 
 
 newtype ConstructorLabel = ConstructorLabel ByteString
@@ -38,22 +39,21 @@ instance ToJSONFields ConstructorLabel where
 class ConstructorName f where
   constructorName :: f a -> String
 
-instance (Generic1 f, ConstructorName (Rep1 f), ConstructorName (Union fs)) => ConstructorName (Union (f ': fs)) where
-  constructorName union = case decompose union of
-    Left rest -> constructorName rest
-    Right f -> constructorName (from1 f)
+instance (Generic1 f, GConstructorName (Rep1 f)) => ConstructorName f where
+  constructorName = gconstructorName . from1
 
-instance ConstructorName (Union '[]) where
-  constructorName _ = ""
 
-instance ConstructorName f => ConstructorName (M1 D c f) where
-  constructorName = constructorName . unM1
+class GConstructorName f where
+  gconstructorName :: f a -> String
 
-instance Constructor c => ConstructorName (M1 C c f) where
-  constructorName x = case conName x of
+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
-
-instance (ConstructorName f, ConstructorName g) => ConstructorName (f :+: g) where
-  constructorName (L1 l) = constructorName l
-  constructorName (R1 r) = constructorName r

src/Renderer/JSON.hs

@@ -19,6 +19,7 @@ import Data.Foldable (toList)
 import Data.Functor.Both (Both)
 import qualified Data.Map as Map
 import Data.Output
+import Data.Proxy
 import Data.Record
 import Data.Semigroup ((<>))
 import Data.Text (pack, Text)
@@ -110,10 +111,8 @@ instance ToJSON a => ToJSONFields [a] where
 instance ToJSON recur => ToJSONFields (Syntax recur) where
   toJSONFields syntax = [ "children" .= toList syntax ]
 
-instance (Foldable f, ToJSON a, ToJSONFields (Union fs a)) => ToJSONFields (Union (f ': fs) a) where
-  toJSONFields u = case decompose u of
-    Left u' -> toJSONFields u'
-    Right r -> [ "children" .= toList r ]
+instance (Apply1 Foldable fs, ToJSON a) => ToJSONFields (Union fs a) where
+  toJSONFields = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])
 
 instance ToJSONFields (Union '[] a) where
   toJSONFields _ = []

src/Renderer/TOC.hs

@@ -119,7 +119,7 @@ syntaxDeclarationAlgebra Blob{..} (a :< r) = case r of
   where getSource = toText . flip Source.slice blobSource . byteRange . extract
 
 -- | Compute 'Declaration's for methods and functions.
-declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Functor (Union fs), HasField fields Range)
+declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply1 Functor fs, HasField fields Range)
                    => Blob
                    -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
 declarationAlgebra blob@Blob{..} (_ :< r)
@@ -130,7 +130,7 @@ declarationAlgebra blob@Blob{..} (_ :< r)
   where getSource = toText . flip Source.slice blobSource . byteRange
 
 -- | Compute 'Declaration's with the headings of 'Markup.Section's.
-markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, Functor (Union fs), Foldable (Union fs))
+markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, Apply1 Functor fs, Apply1 Foldable fs)
                      => Blob
                      -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
 markupSectionAlgebra blob@Blob{..} (_ :< r)

vendor/effects

@@ -1 +1 @@
-Subproject commit 4ed36cb52f60e4d6b692515aa05c493ffcb320bc
+Subproject commit 1322c6657bb589458ed33f526b83c83eb53b0ec0