Merge branch 'master' into ruby-assignment-fixes

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/Data/Syntax/Markup.hs

@@ -66,6 +66,24 @@ data HTMLBlock a = HTMLBlock ByteString
 instance Eq1 HTMLBlock where liftEq = genericLiftEq
 instance Show1 HTMLBlock where liftShowsPrec = genericLiftShowsPrec
 
+newtype Table a = Table [a]
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Table where liftEq = genericLiftEq
+instance Show1 Table where liftShowsPrec = genericLiftShowsPrec
+
+newtype TableRow a = TableRow [a]
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 TableRow where liftEq = genericLiftEq
+instance Show1 TableRow where liftShowsPrec = genericLiftShowsPrec
+
+newtype TableCell a = TableCell [a]
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 TableCell where liftEq = genericLiftEq
+instance Show1 TableCell where liftShowsPrec = genericLiftShowsPrec
+
 
 -- Inline elements
 
@@ -110,3 +128,9 @@ data LineBreak a = LineBreak
 
 instance Eq1 LineBreak where liftEq = genericLiftEq
 instance Show1 LineBreak where liftShowsPrec = genericLiftShowsPrec
+
+newtype Strikethrough a = Strikethrough [a]
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Strikethrough where liftEq = genericLiftEq
+instance Show1 Strikethrough where liftShowsPrec = genericLiftShowsPrec

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/Language/Markdown/Syntax.hs

@@ -33,6 +33,9 @@ type Syntax =
    , Markup.Section
    , Markup.ThematicBreak
    , Markup.UnorderedList
+   , Markup.Table
+   , Markup.TableRow
+   , Markup.TableCell
    -- Inline elements
    , Markup.Code
    , Markup.Emphasis
@@ -41,6 +44,7 @@ type Syntax =
    , Markup.Link
    , Markup.Strong
    , Markup.Text
+   , Markup.Strikethrough
    -- Assignment errors; cmark does not provide parse errors.
    , Syntax.Error
    , []
@@ -57,7 +61,7 @@ assignment = makeTerm <$> symbol Document <*> children (Markup.Document <$> many
 -- Block elements
 
 blockElement :: Assignment
-blockElement = paragraph <|> list <|> blockQuote <|> codeBlock <|> thematicBreak <|> htmlBlock <|> section
+blockElement = paragraph <|> list <|> blockQuote <|> codeBlock <|> thematicBreak <|> htmlBlock <|> section <|> table
 
 paragraph :: Assignment
 paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement)
@@ -90,11 +94,19 @@ thematicBreak = makeTerm <$> symbol ThematicBreak <*> pure Markup.ThematicBreak
 htmlBlock :: Assignment
 htmlBlock = makeTerm <$> symbol HTMLBlock <*> (Markup.HTMLBlock <$> source)
 
+table :: Assignment
+table = makeTerm <$> symbol Table <*> children (Markup.Table <$> many tableRow)
+
+tableRow :: Assignment
+tableRow = makeTerm <$> symbol TableRow <*> children (Markup.TableRow <$> many tableCell)
+
+tableCell :: Assignment
+tableCell = makeTerm <$> symbol TableCell <*> children (Markup.TableCell <$> many inlineElement)
 
 -- Inline elements
 
 inlineElement :: Assignment
-inlineElement = strong <|> emphasis <|> text <|> link <|> htmlInline <|> image <|> code <|> lineBreak <|> softBreak
+inlineElement = strong <|> emphasis <|> strikethrough <|> text <|> link <|> htmlInline <|> image <|> code <|> lineBreak <|> softBreak
 
 strong :: Assignment
 strong = makeTerm <$> symbol Strong <*> children (Markup.Strong <$> many inlineElement)
@@ -102,6 +114,9 @@ strong = makeTerm <$> symbol Strong <*> children (Markup.Strong <$> many inlineE
 emphasis :: Assignment
 emphasis = makeTerm <$> symbol Emphasis <*> children (Markup.Emphasis <$> many inlineElement)
 
+strikethrough :: Assignment
+strikethrough = makeTerm <$> symbol Strikethrough <*> children (Markup.Strikethrough <$> many inlineElement)
+
 text :: Assignment
 text = makeTerm <$> symbol Text <*> (Markup.Text <$> source)
 

src/Parser.hs

@@ -42,7 +42,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 :: (Enum grammar, Eq grammar, Show grammar, Symbol grammar, Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs), Recursive ast, Foldable (Base ast))
+  AssignmentParser :: (Enum grammar, Eq grammar, Show grammar, Symbol grammar, Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs, Recursive ast, Foldable (Base ast))
                    => Parser ast                                                 -- ^ A parser producing AST.
                    -> (forall x. Base ast x -> Node grammar)                     -- ^ A function extracting the symbol and location.
                    -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's.

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

@@ -118,7 +118,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{..} (a :< r)
@@ -129,7 +129,7 @@ declarationAlgebra Blob{..} (a :< 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{..} (a :< r)

vendor/effects

@@ -1 +1 @@
-Subproject commit 4ed36cb52f60e4d6b692515aa05c493ffcb320bc
+Subproject commit 90c6c9b2aa7ac3b5bcc0a5e5df730692b105b69c