diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index fad020717..d466cbd7b 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -132,7 +132,7 @@ data AssignmentF ast grammar a where Put :: State ast -> AssignmentF ast grammar () End :: HasCallStack => AssignmentF ast grammar () Location :: HasCallStack => AssignmentF ast grammar (Record Location) - Project :: HasCallStack => (forall x. F.Base ast x -> a) -> AssignmentF ast grammar a + Project :: HasCallStack => AssignmentF ast grammar (F.Base ast ()) Source :: HasCallStack => AssignmentF ast grammar ByteString Children :: HasCallStack => Assignment ast grammar a -> AssignmentF ast grammar a Advance :: HasCallStack => AssignmentF ast grammar () @@ -150,8 +150,8 @@ location :: HasCallStack => Assignment ast grammar (Record Location) location = withFrozenCallStack $ Location `Then` return -- | Zero-width projection of the current node. -project :: HasCallStack => (forall x. F.Base ast x -> a) -> Assignment ast grammar a -project projection = withFrozenCallStack $ Project projection `Then` return +project :: HasCallStack => Assignment ast grammar (F.Base ast ()) +project = Project `Then` return -- | Zero-width match of a node with the given symbol, producing the current node’s location. symbol :: (Bounded grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location) @@ -252,7 +252,7 @@ runAssignment toNode source = \ assignment state -> go assignment state >>= requ run assignment yield initialState = assignment `seq` expectedSymbols `seq` state `seq` maybe (anywhere Nothing) (atNode . F.project) (listToMaybe stateNodes) where atNode node = case assignment of Location -> yield (nodeLocation (toNode node)) state - Project projection -> yield (projection node) state + Project -> yield (() <$ node) state Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode node)) source)) (advance state) Children child -> do (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive @@ -385,7 +385,7 @@ instance (Show grammar, Show ast) => Show1 (AssignmentF ast grammar) where End -> showString "End" . showChar ' ' . sp d () Advance -> showString "Advance" . showChar ' ' . sp d () Location -> showString "Location" . sp d (Info.Range 0 0 :. Info.Span (Info.Pos 1 1) (Info.Pos 1 1) :. Nil) - Project projection -> showsUnaryWith (const (const (showChar '_'))) "Project" d projection + Project -> showString "Project" Source -> showString "Source" . showChar ' ' . sp d "" Children a -> showsUnaryWith (liftShowsPrec sp sl) "Children" d a Choose symbols choices -> showsBinaryWith showsPrec (const (liftShowList sp sl)) "Choose" d symbols (IntMap.toList choices) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 2711499dd..ea966fc83 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -68,16 +68,16 @@ paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) list :: Assignment -list = (:<) <$> symbol List <*> (project (\ (Node (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) _ _ Term.:< _) -> case listType of +list = (:<) <$> symbol List <*> ((\ (Node (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) _ _ Term.:< _) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList - CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) <*> children (many item)) + CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) <$> project <*> children (many item)) item :: Assignment item = makeTerm <$> symbol Item <*> children (many blockElement) section :: Assignment section = makeTerm <$> symbol Heading <*> (heading >>= \ headingTerm -> Markup.Section (level headingTerm) headingTerm <$> while (((<) `on` level) headingTerm) blockElement) - where heading = makeTerm <$> symbol Heading <*> (project (\ (Node (CMarkGFM.HEADING level) _ _ Term.:< _) -> Markup.Heading level) <*> children (many inlineElement)) + where heading = makeTerm <$> symbol Heading <*> ((\ (Node (CMarkGFM.HEADING level) _ _ Term.:< _) -> Markup.Heading level) <$> project <*> 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 @@ -87,7 +87,7 @@ blockQuote :: Assignment blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) codeBlock :: Assignment -codeBlock = makeTerm <$> symbol CodeBlock <*> (project (\ (Node (CMarkGFM.CODE_BLOCK language _) _ _ Term.:< _) -> Markup.Code (nullText language)) <*> source) +codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (Node (CMarkGFM.CODE_BLOCK language _) _ _ Term.:< _) -> Markup.Code (nullText language)) <$> project <*> source) thematicBreak :: Assignment thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak @@ -125,10 +125,10 @@ htmlInline :: Assignment htmlInline = makeTerm <$> symbol HTMLInline <*> (Markup.HTMLBlock <$> source) link :: Assignment -link = makeTerm <$> symbol Link <*> project (\ (Node (CMarkGFM.LINK url title) _ _ Term.:< _) -> Markup.Link (encodeUtf8 url) (nullText title)) <* source +link = makeTerm <$> symbol Link <*> ((\ (Node (CMarkGFM.LINK url title) _ _ Term.:< _) -> Markup.Link (encodeUtf8 url) (nullText title)) <$> project) <* advance image :: Assignment -image = makeTerm <$> symbol Image <*> project (\ (Node (CMarkGFM.IMAGE url title) _ _ Term.:< _) -> Markup.Image (encodeUtf8 url) (nullText title)) <* source +image = makeTerm <$> symbol Image <*> ((\ (Node (CMarkGFM.IMAGE url title) _ _ Term.:< _) -> Markup.Image (encodeUtf8 url) (nullText title)) <$> project) <* advance code :: Assignment code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source)