From eaece7951a54d2b8b2eb57118d1f5176c3687073 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 11:35:13 -0400 Subject: [PATCH 01/27] Define sourceLineRanges in terms of sourceLineRangesWithin. --- src/Data/Source.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index d28c7c778..29589164b 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -106,8 +106,7 @@ sourceLines source -- | Compute the 'Range's of each line in a 'Source'. sourceLineRanges :: Source -> [Range] -sourceLineRanges = drop 1 . scanl toRange (Range 0 0) . sourceLines - where toRange previous source = Range (end previous) $ end previous + sourceLength source +sourceLineRanges source = sourceLineRangesWithin (totalRange source) source -- | Compute the 'Range's of each line in a 'Range' of a 'Source'. sourceLineRangesWithin :: Range -> Source -> [Range] From 3b1c2644f273b1216bc41a17bd3bde2652d3776a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 11:47:38 -0400 Subject: [PATCH 02/27] Use ord to define sourceLines. --- src/Data/Source.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index 29589164b..e8a9ea51e 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -27,6 +27,7 @@ module Data.Source ) where import qualified Data.ByteString as B +import Data.Char (ord) import Data.List (span) import Data.Range import Data.Span @@ -99,7 +100,7 @@ breakSource predicate (Source text) = let (start, remainder) = B.break predicate sourceLines :: Source -> [Source] sourceLines source | nullSource source = [ source ] - | otherwise = case breakSource (== toEnum (fromEnum '\n')) source of + | otherwise = case breakSource (== toEnum (ord '\n')) source of (line, rest) | nullSource rest -> [ line ] | otherwise -> (line <> "\n") : sourceLines (dropSource 1 rest) From 35baa874d5b68e4a53727a8a2ebd36ce739df5fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 11:58:17 -0400 Subject: [PATCH 03/27] Define sourceLineRangesWithin without constructing intermediate sources. --- src/Data/Source.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index e8a9ea51e..17e93581d 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -111,8 +111,7 @@ sourceLineRanges source = sourceLineRangesWithin (totalRange source) source -- | Compute the 'Range's of each line in a 'Range' of a 'Source'. sourceLineRangesWithin :: Range -> Source -> [Range] -sourceLineRangesWithin range = drop 1 . scanl toRange (Range (start range) (start range)) . sourceLines . slice range - where toRange previous source = Range (end previous) $ end previous + sourceLength source +sourceLineRangesWithin range = uncurry (zipWith Range) . ((start range:) &&& (<> [ end range ])) . fmap (+ succ (start range)) . B.elemIndices (toEnum (ord '\n')) . sourceBytes . slice range -- Conversion From b9143d40ea9319d511aa784e39d7d55148c778c3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 12:02:27 -0400 Subject: [PATCH 04/27] Define sourceLines in terms of sourceLineRanges. --- src/Data/Source.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index 17e93581d..be3c7671e 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -98,12 +98,7 @@ breakSource predicate (Source text) = let (start, remainder) = B.break predicate -- | Split the contents of the source after newlines. sourceLines :: Source -> [Source] -sourceLines source - | nullSource source = [ source ] - | otherwise = case breakSource (== toEnum (ord '\n')) source of - (line, rest) - | nullSource rest -> [ line ] - | otherwise -> (line <> "\n") : sourceLines (dropSource 1 rest) +sourceLines source = (`slice` source) <$> sourceLineRanges source -- | Compute the 'Range's of each line in a 'Source'. sourceLineRanges :: Source -> [Range] From 8e57a0b88bc0d251a085ab6c42d1dcf97f4bf863 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 12:02:38 -0400 Subject: [PATCH 05/27] :fire: breakSource. --- src/Data/Source.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index be3c7671e..7f3162f38 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -91,11 +91,6 @@ takeSource i = Source . take . sourceBytes -- Splitting --- | Split the source into the longest prefix of elements that do not satisfy the predicate and the rest without copying. -breakSource :: (Word8 -> Bool) -> Source -> (Source, Source) -breakSource predicate (Source text) = let (start, remainder) = B.break predicate text in (Source start, Source remainder) - - -- | Split the contents of the source after newlines. sourceLines :: Source -> [Source] sourceLines source = (`slice` source) <$> sourceLineRanges source From aed530b79b4e20c23a43ee0114676207f30c6fd4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 12:03:27 -0400 Subject: [PATCH 06/27] Correct some misalignment. --- src/Data/Source.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index 7f3162f38..bb5ffcae3 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -120,13 +120,13 @@ spanToRangeInLineRanges lineRanges Span{..} = Range start end -- | Compute the 'Span' corresponding to a given byte 'Range' in a 'Source'. rangeToSpan :: Source -> Range -> Span rangeToSpan source (Range rangeStart rangeEnd) = Span startPos endPos - where startPos = Pos (firstLine + 1) (rangeStart - start firstRange + 1) + where startPos = Pos (firstLine + 1) (rangeStart - start firstRange + 1) endPos = Pos (firstLine + length lineRanges) (rangeEnd - start lastRange + 1) firstLine = length before (before, rest) = span ((< rangeStart) . end) (sourceLineRanges source) (lineRanges, _) = span ((<= rangeEnd) . start) rest Just firstRange = getFirst (foldMap (First . Just) lineRanges) - Just lastRange = getLast (foldMap (Last . Just) lineRanges) + Just lastRange = getLast (foldMap (Last . Just) lineRanges) -- Instances From 8284540ba01adc894282c7baa7e7892df9e05249 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 12:10:37 -0400 Subject: [PATCH 07/27] Quote the reference to ByteString. --- src/Data/Source.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index bb5ffcae3..3c9e157a7 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -36,7 +36,7 @@ import qualified Data.Text as T import Prologue import Test.LeanCheck --- | The contents of a source file, represented as a ByteString. +-- | The contents of a source file, represented as a 'ByteString'. newtype Source = Source { sourceBytes :: B.ByteString } deriving (Eq, IsString, Show) From 6b3f35c04605c68e55c27de48cd51677712d2a13 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 12:32:43 -0400 Subject: [PATCH 08/27] Compute spanToRangeInLineRanges in constant time. --- src/Data/Source.hs | 18 +++++++++++------- src/Language/Markdown.hs | 2 +- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index 3c9e157a7..38e318659 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -21,11 +21,13 @@ module Data.Source -- Conversion , spanToRange , spanToRangeInLineRanges +, sourceLineRangesByLineNumber , rangeToSpan -- Listable , ListableByteString(..) ) where +import Data.Array import qualified Data.ByteString as B import Data.Char (ord) import Data.List (span) @@ -108,14 +110,16 @@ sourceLineRangesWithin range = uncurry (zipWith Range) . ((start range:) &&& (<> -- | Compute the byte 'Range' corresponding to a given 'Span' in a 'Source'. spanToRange :: Source -> Span -> Range -spanToRange source = spanToRangeInLineRanges (sourceLineRanges source) +spanToRange source = spanToRangeInLineRanges (sourceLineRangesByLineNumber source) -spanToRangeInLineRanges :: [Range] -> Span -> Range -spanToRangeInLineRanges lineRanges Span{..} = Range start end - where start = pred (sumLengths leadingRanges + posColumn spanStart) - end = start + sumLengths (take (posLine spanEnd - posLine spanStart) remainingRanges) + (posColumn spanEnd - posColumn spanStart) - (leadingRanges, remainingRanges) = splitAt (pred (posLine spanStart)) lineRanges - sumLengths = sum . fmap rangeLength +spanToRangeInLineRanges :: Array Int Range -> Span -> Range +spanToRangeInLineRanges lineRanges Span{..} = Range + (start (lineRanges ! posLine spanStart) + pred (posColumn spanStart)) + (start (lineRanges ! posLine spanEnd) + pred (posColumn spanEnd)) + +sourceLineRangesByLineNumber :: Source -> Array Int Range +sourceLineRangesByLineNumber source = listArray (1, length lineRanges) lineRanges + where lineRanges = sourceLineRanges source -- | Compute the 'Span' corresponding to a given byte 'Range' in a 'Source'. rangeToSpan :: Source -> Range -> Span diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index 4e6d93788..a3bb79671 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -46,7 +46,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos endLine (succ endColumn)) - lineRanges = sourceLineRanges source + lineRanges = sourceLineRangesByLineNumber source toGrammar :: NodeType -> Grammar toGrammar DOCUMENT{} = Document From af48c1d68455c048dc98c34e7961dee8236a4a9b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 12:44:00 -0400 Subject: [PATCH 09/27] Simplify the line by line parser. --- src/Parser.hs | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 624dbf93c..af48b0820 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -16,7 +16,6 @@ import Data.Record import Data.Source as Source import qualified Data.Syntax as Syntax import Data.Syntax.Assignment -import qualified Data.Text as T import Data.Union import Info hiding (Empty, Go) import Language @@ -105,12 +104,5 @@ termErrors = cata $ \ (_ :< s) -> case s of -- | A fallback parser that treats a file simply as rows of strings. lineByLineParser :: Source -> IO (SyntaxTerm Text DefaultFields) -lineByLineParser source = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of - (leaves, _) -> cofree <$> leaves - where - lines = sourceLines source - root children = (sourceRange :. Program :. rangeToSpan source sourceRange :. Nil) :< Indexed children - sourceRange = totalRange source - leaf byteIndex line = (Range byteIndex (byteIndex + T.length line) :. Program :. rangeToSpan source (Range byteIndex (byteIndex + T.length line)) :. Nil) :< Leaf line - annotateLeaves (accum, byteIndex) line = - (accum <> [ leaf byteIndex (toText line) ] , byteIndex + sourceLength line) +lineByLineParser source = pure . cofree $ (totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source)) + where toLine line range = cofree $ (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source)) From 1beabcdbdc4a76dd47fc6f211df8bd0ccdd13999 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 12:44:11 -0400 Subject: [PATCH 10/27] The line by line parser is pure. --- src/Parser.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index af48b0820..bee6db6b9 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -92,7 +92,7 @@ runParser parser = case parser of Nothing -> pure (errorTerm source err) TreeSitterParser language tslanguage -> treeSitterParser language tslanguage MarkdownParser -> pure . cmarkParser - LineByLineParser -> lineByLineParser + LineByLineParser -> pure . lineByLineParser 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 (Pos 0 0) (UnexpectedEndOfInput [])) err))) @@ -103,6 +103,6 @@ termErrors = cata $ \ (_ :< s) -> case s of _ -> fold s -- | A fallback parser that treats a file simply as rows of strings. -lineByLineParser :: Source -> IO (SyntaxTerm Text DefaultFields) -lineByLineParser source = pure . cofree $ (totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source)) +lineByLineParser :: Source -> SyntaxTerm Text DefaultFields +lineByLineParser source = cofree $ (totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source)) where toLine line range = cofree $ (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source)) From 78b607ddbcf760c01e076e9a0b30599cb59c6add Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 14:22:31 -0400 Subject: [PATCH 11/27] :fire: redundant parens. --- src/Language/Markdown/Syntax.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 16ba1df5e..e4da925b4 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -62,7 +62,7 @@ paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) list :: Assignment -list = (cofree .) . (:<) <$> symbol List <*> (project (\ (((CMark.LIST CMark.ListAttributes{..}) :. _) :< _) -> case listType of +list = (cofree .) . (:<) <$> symbol List <*> (project (\ ((CMark.LIST CMark.ListAttributes{..} :. _) :< _) -> case listType of CMark.BULLET_LIST -> inj . Markup.UnorderedList CMark.ORDERED_LIST -> inj . Markup.OrderedList) <*> children (many item)) @@ -81,7 +81,7 @@ blockQuote :: Assignment blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) codeBlock :: Assignment -codeBlock = makeTerm <$> symbol CodeBlock <*> (Markup.Code <$> project (\ (((CMark.CODE_BLOCK language _) :. _) :< _) -> nullText language) <*> source) +codeBlock = makeTerm <$> symbol CodeBlock <*> (Markup.Code <$> project (\ ((CMark.CODE_BLOCK language _ :. _) :< _) -> nullText language) <*> source) thematicBreak :: Assignment thematicBreak = makeTerm <$> symbol ThematicBreak <*> (Markup.ThematicBreak <$ source) @@ -105,10 +105,10 @@ text :: Assignment text = makeTerm <$> symbol Text <*> (Markup.Text <$> source) link :: Assignment -link = makeTerm <$> symbol Link <*> (uncurry Markup.Link <$> project (\ (((CMark.LINK url title) :. _) :< _) -> (toS url, nullText title))) <* source +link = makeTerm <$> symbol Link <*> (uncurry Markup.Link <$> project (\ ((CMark.LINK url title :. _) :< _) -> (toS url, nullText title))) <* source image :: Assignment -image = makeTerm <$> symbol Image <*> (uncurry Markup.Image <$> project (\ (((CMark.IMAGE url title) :. _) :< _) -> (toS url, nullText title))) <* source +image = makeTerm <$> symbol Image <*> (uncurry Markup.Image <$> project (\ ((CMark.IMAGE url title :. _) :< _) -> (toS url, nullText title))) <* source code :: Assignment code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source) From a182406b6b57da6f19a4719aae1a700baf8358af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 14:25:43 -0400 Subject: [PATCH 12/27] Fewer parens. --- src/Language/Markdown/Syntax.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index e4da925b4..f6bed6da6 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -84,7 +84,7 @@ codeBlock :: Assignment codeBlock = makeTerm <$> symbol CodeBlock <*> (Markup.Code <$> project (\ ((CMark.CODE_BLOCK language _ :. _) :< _) -> nullText language) <*> source) thematicBreak :: Assignment -thematicBreak = makeTerm <$> symbol ThematicBreak <*> (Markup.ThematicBreak <$ source) +thematicBreak = makeTerm <$> symbol ThematicBreak <*> pure Markup.ThematicBreak <* source htmlBlock :: Assignment htmlBlock = makeTerm <$> symbol HTMLBlock <*> (Markup.HTMLBlock <$> source) @@ -114,10 +114,10 @@ code :: Assignment code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source) lineBreak :: Assignment -lineBreak = makeTerm <$> symbol LineBreak <*> (Markup.LineBreak <$ source) +lineBreak = makeTerm <$> symbol LineBreak <*> pure Markup.LineBreak <* source softBreak :: Assignment -softBreak = makeTerm <$> symbol SoftBreak <*> (Markup.LineBreak <$ source) +softBreak = makeTerm <$> symbol SoftBreak <*> pure Markup.LineBreak <* source -- Implementation details From 854e4fbcc2ccec8eba44f8eb26d5fd2c66891d30 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 14:28:31 -0400 Subject: [PATCH 13/27] Change how some comments are listed. --- src/Data/Syntax/Assignment.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index e68b6f536..f06c5f010 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -128,13 +128,13 @@ location = Location `Then` return -- | Zero-width projection of the current node. -- --- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (project f *> b)' is fine, but 'many (project f)' is not. +-- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. @many (project f *> b)@ is fine, but @many (project f)@ is not. project :: HasCallStack => (forall x. Base ast x -> a) -> Assignment ast grammar a project projection = Project projection `Then` return -- | Zero-width match of a node with the given symbol, producing the current node’s location. -- --- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (symbol A *> b)' is fine, but 'many (symbol A)' is not. +-- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. @many (symbol A *> b)@ is fine, but @many (symbol A)@ is not. symbol :: (Enum grammar, Eq grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location) symbol s = withFrozenCallStack $ Choose (IntMap.singleton (fromEnum s) ()) `Then` (const location) @@ -248,7 +248,7 @@ runAssignment toRecord = iterFreer run . fmap ((pure .) . (,)) Result _ (Just (a, state')) -> yield a (advanceState (rtail . toRecord) state' { stateNodes = stateNodes }) Result err Nothing -> Result err Nothing (Choose choices, node : _) | Just symbol :. _ <- toRecord (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state - -- Nullability: some rules, e.g. 'pure a' and 'many a', should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input. + -- Nullability: some rules, e.g. @pure a@ and @many a@, should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input. (Alt a b, _) -> yield a state <|> yield b state (Throw e, _) -> Result (Just e) Nothing (Catch during handler, _) -> case yield during state of From 04bde799fd91b24cd90f81d32411426ba24638a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 14:33:10 -0400 Subject: [PATCH 14/27] Eta-reduce. --- src/Data/Syntax/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index f06c5f010..4bda68646 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -284,7 +284,7 @@ data AssignmentState ast = AssignmentState deriving (Eq, Show) makeState :: Source.Source -> [ast] -> AssignmentState ast -makeState source nodes = AssignmentState 0 (Info.Pos 1 1) source nodes +makeState = AssignmentState 0 (Info.Pos 1 1) -- Instances From 81b8ab22b9551963c10c631d628bb13098c76d8c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 14:36:41 -0400 Subject: [PATCH 15/27] :fire: some redundant parens. --- src/Data/Syntax/Assignment.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 4bda68646..8140deffa 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -184,9 +184,9 @@ data ErrorCause grammar printError :: Show grammar => Source.Source -> Error grammar -> IO () printError source error@Error{..} = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . (showPos Nothing errorPos) . showString ": " $ "" - withSGRCode [SetColor Foreground Vivid Red] . putStrErr . (showString "error") . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" - withSGRCode [SetColor Foreground Vivid Green] . putStrErr . (showChar '^') . showChar '\n' . showString (prettyCallStack callStack) $ "" + withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . showPos Nothing errorPos . showString ": " $ "" + withSGRCode [SetColor Foreground Vivid Red] . putStrErr . showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" + withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' . showString (prettyCallStack callStack) $ "" where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s From 7d7e41221e1cf74acef3ffc5aba396150db78536 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 14:37:34 -0400 Subject: [PATCH 16/27] Reformat a little. --- src/Data/Syntax/Assignment.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 8140deffa..c970b8fcc 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -182,12 +182,10 @@ data ErrorCause grammar -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Source.Source -> Error grammar -> IO () -printError source error@Error{..} - = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . showPos Nothing errorPos . showString ": " $ "" - withSGRCode [SetColor Foreground Vivid Red] . putStrErr . showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" - withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' . showString (prettyCallStack callStack) $ "" - +printError source error@Error{..} = do + withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . showPos Nothing errorPos . showString ": " $ "" + withSGRCode [SetColor Foreground Vivid Red] . putStrErr . showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" + withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' . showString (prettyCallStack callStack) $ "" where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) From 3278506866f3c49631f11ff5e694f4a6dd1a0f14 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 14:59:00 -0400 Subject: [PATCH 17/27] Simplify how images and links are projected. --- src/Language/Markdown/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index f6bed6da6..fd6999ec5 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -105,10 +105,10 @@ text :: Assignment text = makeTerm <$> symbol Text <*> (Markup.Text <$> source) link :: Assignment -link = makeTerm <$> symbol Link <*> (uncurry Markup.Link <$> project (\ ((CMark.LINK url title :. _) :< _) -> (toS url, nullText title))) <* source +link = makeTerm <$> symbol Link <*> project (\ ((CMark.LINK url title :. _) :< _) -> Markup.Link (toS url) (nullText title)) <* source image :: Assignment -image = makeTerm <$> symbol Image <*> (uncurry Markup.Image <$> project (\ ((CMark.IMAGE url title :. _) :< _) -> (toS url, nullText title))) <* source +image = makeTerm <$> symbol Image <*> project (\ ((CMark.IMAGE url title :. _) :< _) -> Markup.Image (toS url) (nullText title)) <* source code :: Assignment code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source) From d44684cd4e80bfb2be7d7b1ad38efbeada7e5696 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 15:01:00 -0400 Subject: [PATCH 18/27] Simplify how sections and code blocks are projected. --- src/Language/Markdown/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index fd6999ec5..e4d788691 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -71,7 +71,7 @@ item = makeTerm <$> symbol Item <*> children (many blockElement) 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)) + where heading = makeTerm <$> symbol Heading <*> (project (\ ((CMark.HEADING level :. _) :< _) -> Markup.Heading 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 @@ -81,7 +81,7 @@ blockQuote :: Assignment blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) codeBlock :: Assignment -codeBlock = makeTerm <$> symbol CodeBlock <*> (Markup.Code <$> project (\ ((CMark.CODE_BLOCK language _ :. _) :< _) -> nullText language) <*> source) +codeBlock = makeTerm <$> symbol CodeBlock <*> (project (\ ((CMark.CODE_BLOCK language _ :. _) :< _) -> Markup.Code (nullText language)) <*> source) thematicBreak :: Assignment thematicBreak = makeTerm <$> symbol ThematicBreak <*> pure Markup.ThematicBreak <* source From 5d75659c6e251ecb788e1bc211604a830ec9bc3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 15:22:58 -0400 Subject: [PATCH 19/27] Define spanToRange tacitly. --- src/Data/Source.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index 38e318659..5f036b37e 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -110,7 +110,7 @@ sourceLineRangesWithin range = uncurry (zipWith Range) . ((start range:) &&& (<> -- | Compute the byte 'Range' corresponding to a given 'Span' in a 'Source'. spanToRange :: Source -> Span -> Range -spanToRange source = spanToRangeInLineRanges (sourceLineRangesByLineNumber source) +spanToRange = spanToRangeInLineRanges . sourceLineRangesByLineNumber spanToRangeInLineRanges :: Array Int Range -> Span -> Range spanToRangeInLineRanges lineRanges Span{..} = Range From f2b6cdb223ce8f52d5e5dc213f35b08865ae30db Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 15:46:07 -0400 Subject: [PATCH 20/27] Deal with nonsensical end lines. --- src/Language/Markdown.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index a3bb79671..3e196bf4e 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -44,7 +44,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT span = maybe withinSpan toSpan position in cofree $ (t :. range :. span :. Nil) :< (toTerm range span <$> children) - toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos endLine (succ endColumn)) + toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ endColumn)) lineRanges = sourceLineRangesByLineNumber source From 4a00ee3e23f1523d7118f89c5e46e75ebf0f2875 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 15:55:51 -0400 Subject: [PATCH 21/27] Make sure the end column makes sense. --- src/Language/Markdown.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index 3e196bf4e..aa74f29b3 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -44,7 +44,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT span = maybe withinSpan toSpan position in cofree $ (t :. range :. span :. Nil) :< (toTerm range span <$> children) - toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ endColumn)) + toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) lineRanges = sourceLineRangesByLineNumber source From 1bbb252738eb0a288ff41fa710bb2c0735d5e6f8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 16:44:00 -0400 Subject: [PATCH 22/27] Return is the left-identity of alternation. --- src/Data/Syntax/Assignment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index c970b8fcc..0e07f89e9 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -292,6 +292,7 @@ instance Enum grammar => Alternative (Assignment ast grammar) where empty = Empty `Then` return (<|>) :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a a <|> b = case (a, b) of + (Return a, _) -> pure a (_, Empty `Then` _) -> a (Empty `Then` _, _) -> b (Choose choices1 `Then` continue1, Choose choices2 `Then` continue2) -> Choose (IntMap.union (fmap continue1 choices1) (fmap continue2 choices2)) `Then` identity From 7df59da28117a65cd654554a6cf972a84e47eb62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 16:51:00 -0400 Subject: [PATCH 23/27] Frame the <|> rule in terms of the choices along each side. --- src/Data/Syntax/Assignment.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 0e07f89e9..30085b5a6 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -291,12 +291,12 @@ instance Enum grammar => Alternative (Assignment ast grammar) where empty :: HasCallStack => Assignment ast grammar a empty = Empty `Then` return (<|>) :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a - a <|> b = case (a, b) of - (Return a, _) -> pure a - (_, Empty `Then` _) -> a - (Empty `Then` _, _) -> b - (Choose choices1 `Then` continue1, Choose choices2 `Then` continue2) -> Choose (IntMap.union (fmap continue1 choices1) (fmap continue2 choices2)) `Then` identity - _ -> wrap $ Alt a b + Return a <|> _ = Return a + a <|> b | Just c <- (liftA2 (<>) `on` choices) a b = Choose c `Then` identity + | otherwise = wrap $ Alt a b + where choices (Choose choices `Then` continue) = Just (continue <$> choices) + choices (Empty `Then` _) = Just mempty + choices _ = Nothing instance Show grammar => Show1 (AssignmentF ast grammar) where liftShowsPrec sp sl d a = case a of From eaa4423decedd57953f4b3373944f50ca1be43f5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 17:10:04 -0400 Subject: [PATCH 24/27] Define a Many rule. --- src/Data/Syntax/Assignment.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 30085b5a6..9bd68f899 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -115,6 +115,7 @@ data AssignmentF ast grammar a where Source :: HasCallStack => AssignmentF ast grammar ByteString Children :: HasCallStack => Assignment ast grammar a -> AssignmentF ast grammar a Choose :: HasCallStack => IntMap.IntMap a -> AssignmentF ast grammar a + Many :: HasCallStack => Assignment ast grammar a -> AssignmentF ast grammar [a] Alt :: HasCallStack => a -> a -> AssignmentF ast grammar a Empty :: HasCallStack => AssignmentF ast grammar a Throw :: HasCallStack => Error grammar -> AssignmentF ast grammar a @@ -246,6 +247,8 @@ runAssignment toRecord = iterFreer run . fmap ((pure .) . (,)) Result _ (Just (a, state')) -> yield a (advanceState (rtail . toRecord) state' { stateNodes = stateNodes }) Result err Nothing -> Result err Nothing (Choose choices, node : _) | Just symbol :. _ <- toRecord (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state + (Many _, []) -> yield [] state + (Many rule, _) -> uncurry yield (runMany rule state) -- Nullability: some rules, e.g. @pure a@ and @many a@, should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input. (Alt a b, _) -> yield a state <|> yield b state (Throw e, _) -> Result (Just e) Nothing @@ -261,6 +264,10 @@ runAssignment toRecord = iterFreer run . fmap ((pure .) . (,)) Choose choices -> choiceSymbols choices _ -> [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices + runMany :: Assignment ast grammar v -> AssignmentState ast -> ([v], AssignmentState ast) + runMany rule state = case runAssignment toRecord rule state of + Result _ (Just (a, state')) -> first (a :) (runMany rule state') + _ -> ([], state) dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Maybe grammar) -> AssignmentState ast -> AssignmentState ast dropAnonymous toSymbol state = state { stateNodes = dropWhile ((`notElem` [Just Regular, Nothing]) . fmap symbolType . toSymbol . F.project) (stateNodes state) } @@ -297,6 +304,8 @@ instance Enum grammar => Alternative (Assignment ast grammar) where where choices (Choose choices `Then` continue) = Just (continue <$> choices) choices (Empty `Then` _) = Just mempty choices _ = Nothing + many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a] + many a = Many a `Then` return instance Show grammar => Show1 (AssignmentF ast grammar) where liftShowsPrec sp sl d a = case a of @@ -305,6 +314,7 @@ instance Show grammar => Show1 (AssignmentF ast grammar) where Source -> showString "Source" . showChar ' ' . sp d "" Children a -> showsUnaryWith (liftShowsPrec sp sl) "Children" d a Choose choices -> showsUnaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) "Choose" d (IntMap.toList choices) + Many a -> showsUnaryWith (liftShowsPrec (\ d a -> sp d [a]) (sl . pure)) "Many" d a Alt a b -> showsBinaryWith sp sp "Alt" d a b Empty -> showString "Empty" Throw e -> showsUnaryWith showsPrec "Throw" d e From 2be307e967dc0da38f386f9bc2f4ea51f5475ad7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 17:16:57 -0400 Subject: [PATCH 25/27] `many` participates in committed choice. --- src/Data/Syntax/Assignment.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 9bd68f899..a84d59570 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -301,8 +301,10 @@ instance Enum grammar => Alternative (Assignment ast grammar) where Return a <|> _ = Return a a <|> b | Just c <- (liftA2 (<>) `on` choices) a b = Choose c `Then` identity | otherwise = wrap $ Alt a b - where choices (Choose choices `Then` continue) = Just (continue <$> choices) + where choices :: Assignment ast grammar a -> Maybe (IntMap (Assignment ast grammar a)) + choices (Choose choices `Then` continue) = Just (continue <$> choices) choices (Empty `Then` _) = Just mempty + choices (Many rule `Then` continue) = fmap (const (Many rule `Then` continue)) <$> choices rule choices _ = Nothing many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a] many a = Many a `Then` return From fe29a865c3060daec2159246a82b50cc2b1ac21f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 17:30:57 -0400 Subject: [PATCH 26/27] :fire: redundant hidden symbols. --- test/Data/Syntax/Assignment/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 90e361c7b..78b6a00d7 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -3,7 +3,7 @@ module Data.Syntax.Assignment.Spec where import Data.ByteString.Char8 as B (words, length) import Data.Record -import Data.Source hiding (source, length) +import Data.Source import Data.Syntax.Assignment import Info import Prologue From 2fe08397ee5550c2008656371fe49dac18115d61 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Jun 2017 17:30:41 -0400 Subject: [PATCH 27/27] :fire: redundant imports. --- test/CommandSpec.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/CommandSpec.hs b/test/CommandSpec.hs index 32cefffed..7922a547b 100644 --- a/test/CommandSpec.hs +++ b/test/CommandSpec.hs @@ -4,7 +4,6 @@ import Command import Data.Blob import Data.Functor.Both as Both import Data.Maybe -import Data.Source import Data.String import Language import Prologue hiding (readFile, toList)