Merge branch 'master' into union-unity

src/Data/Syntax/Assignment.hs

@@ -60,22 +60,28 @@
 --
 --   Therefore, in addition to the rule of thumb for committed choices (see above), try to match 'Regular' symbols up front, and only match 'Anonymous' ones in the middle of a chain. That will ensure that you don’t have to make redundant effort to explicitly skip 'Anonymous' nodes ahead of multiple alternatives, and can instead rely on them being automatically skipped except when explicitly required.
 module Data.Syntax.Assignment
+-- Types
 ( Assignment
 , Location
 , AST
+-- Combinators
 , location
 , Data.Syntax.Assignment.project
 , symbol
 , source
 , children
+, while
+-- Results
 , Result(..)
 , Error(..)
 , ErrorCause(..)
 , showError
 , showExpectation
+-- Running
 , assign
 , assignBy
 , runAssignment
+-- Implementation details (for testing)
 , AssignmentState(..)
 , makeState
 ) where
@@ -140,6 +146,13 @@ source = withFrozenCallStack $ Source `Then` return
 children :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a
 children forEach = withFrozenCallStack $ Children forEach `Then` return
 
+-- | Collect a list of values until one fails a predicate.
+while :: (Alternative m, Monad m) => (a -> Bool) -> m a -> m [a]
+while predicate step = many $ do
+  result <- step
+  guard (predicate result)
+  pure result
+
 
 -- | A location specified as possibly-empty intervals of bytes and line/column positions.
 type Location = '[Info.Range, Info.SourceSpan]

src/Data/Syntax/Markup.hs

@@ -23,6 +23,12 @@ newtype Paragraph a = Paragraph [a]
 instance Eq1 Paragraph where liftEq = genericLiftEq
 instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec
 
+data Section a = Section { sectionHeading :: a, sectionContent :: [a] }
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Section where liftEq = genericLiftEq
+instance Show1 Section where liftShowsPrec = genericLiftShowsPrec
+
 data Heading a = Heading { headingLevel :: Int, headingContent :: [a] }
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 

src/Language/Markdown/Syntax.hs

@@ -17,7 +17,7 @@ import qualified Data.Text as Text
 import Data.Union
 import GHC.Stack
 import Language.Markdown as Grammar (Grammar(..))
-import Prologue hiding (Location, link, list)
+import Prologue hiding (Location, link, list, section)
 import qualified Term
 
 type Syntax =
@@ -28,6 +28,7 @@ type Syntax =
    , Markup.HTMLBlock
    , Markup.OrderedList
    , Markup.Paragraph
+   , Markup.Section
    , Markup.ThematicBreak
    , Markup.UnorderedList
    -- Inline elements
@@ -55,7 +56,7 @@ assignment = makeTerm <$> symbol Document <*> children (Markup.Document <$> many
 -- Block elements
 
 blockElement :: Assignment
-blockElement = paragraph <|> list <|> heading <|> blockQuote <|> codeBlock <|> thematicBreak <|> htmlBlock
+blockElement = paragraph <|> list <|> blockQuote <|> codeBlock <|> thematicBreak <|> htmlBlock <|> section
 
 paragraph :: Assignment
 paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement)
@@ -68,8 +69,13 @@ list = (cofree .) . (:<) <$> symbol List <*> (project (\ (((CMark.LIST CMark.Lis
 item :: Assignment
 item = makeTerm <$> symbol Item <*> children (many blockElement)
 
-heading :: Assignment
-heading = makeTerm <$> symbol Heading <*> (Markup.Heading <$> project (\ ((CMark.HEADING level :. _) :< _) -> level) <*> children (many inlineElement))
+section :: Assignment
+section = makeTerm <$> symbol Heading <*> (heading >>= \ headingTerm -> Markup.Section headingTerm <$> while (((<) `on` level) headingTerm) blockElement)
+  where heading = makeTerm <$> symbol Heading <*> (Markup.Heading <$> project (\ ((CMark.HEADING level :. _) :< _) -> level) <*> children (many inlineElement))
+        level term = case term of
+          _ | Just section <- prj (unwrap term) -> level (Markup.sectionHeading section)
+          _ | Just heading <- prj (unwrap term) -> Markup.headingLevel heading
+          _ -> maxBound
 
 blockQuote :: Assignment
 blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement)

src/Language/Ruby/Syntax.hs

@@ -90,7 +90,7 @@ statement  = handleError
           <|> exit Statement.Continue Next
           <|> if'
           <|> unless
-          <|> while
+          <|> Language.Ruby.Syntax.while
           <|> until
           <|> for
           <|> literal

src/Renderer.hs

@@ -9,6 +9,7 @@ module Renderer
 , renderJSONTerm
 , renderToC
 , declarationAlgebra
+, markupSectionAlgebra
 , syntaxDeclarationAlgebra
 , identifierAlgebra
 , Summaries(..)

src/Renderer/TOC.hs

@@ -8,6 +8,7 @@ module Renderer.TOC
 , Declaration(..)
 , declaration
 , declarationAlgebra
+, markupSectionAlgebra
 , syntaxDeclarationAlgebra
 , Entry(..)
 , tableOfContentsBy
@@ -37,6 +38,7 @@ import Syntax as S
 import Data.Syntax.Algebra (RAlgebra)
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
+import qualified Data.Syntax.Markup as Markup
 import Term
 
 data Summaries = Summaries { changes, errors :: !(Map Text [Value]) }
@@ -74,6 +76,7 @@ isValidSummary _ = True
 data Declaration
   = MethodDeclaration   { declarationIdentifier :: Text }
   | FunctionDeclaration { declarationIdentifier :: Text }
+  | SectionDeclaration  { declarationIdentifier :: Text }
   | ErrorDeclaration    { declarationIdentifier :: Text }
   deriving (Eq, Generic, NFData, Show)
 
@@ -110,6 +113,17 @@ declarationAlgebra proxy source r
   | otherwise = Nothing
   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))
+                     => Proxy error
+                     -> Source
+                     -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
+markupSectionAlgebra proxy source r
+  | Just (Markup.Section (heading, _) _) <- prj (tailF r) = Just $ SectionDeclaration (getSource heading)
+  | Just (Syntax.Error err) <- prj (tailF r) = Just $ ErrorDeclaration (show (err `asProxyTypeOf` proxy))
+  | otherwise = Nothing
+  where getSource = toText . flip Source.slice source . byteRange . extract
+
 
 -- | An entry in a table of contents.
 data Entry a
@@ -179,6 +193,7 @@ toCategoryName :: Declaration -> Text
 toCategoryName declaration = case declaration of
   FunctionDeclaration _ -> "Function"
   MethodDeclaration _ -> "Method"
+  SectionDeclaration _ -> "Section"
   ErrorDeclaration _ -> "ParseError"
 
 instance Listable Declaration where

src/Semantic.hs

@@ -19,6 +19,7 @@ import Diff
 import Info
 import Interpreter
 import qualified Language
+import qualified Language.Markdown.Syntax as Markdown
 import qualified Language.Python.Syntax as Python
 import Patch
 import Parser
@@ -62,8 +63,8 @@ diffBlobPairs renderer = fmap toS . distributeFoldMap (diffBlobPair renderer) .
 -- | A task to parse a pair of 'SourceBlob's, diff them, and render the 'Diff'.
 diffBlobPair :: DiffRenderer output -> Both SourceBlob -> Task output
 diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
-  (ToCDiffRenderer, Just Language.Markdown) -> pure mempty
-  (ToCDiffRenderer, Just Language.Python) -> run (\ source -> parse pythonParser source  >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToC blobs)
+  (ToCDiffRenderer, Just Language.Markdown) -> run (\ source -> parse markdownParser source >>= decorate (markupSectionAlgebra (Proxy :: Proxy Markdown.Error) source)) diffLinearly (renderToC blobs)
+  (ToCDiffRenderer, Just Language.Python) -> run (\ source -> parse pythonParser source >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToC blobs)
   (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms (renderToC blobs)
   (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderJSONDiff blobs)
   (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderJSONDiff blobs)