From 07edce5bfc607245484e72a72e6117b6bbf0779f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 11:05:58 -0400 Subject: [PATCH 001/154] Bump freer-cofreer to `master`. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 59011e056..4e58a003d 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -9,7 +9,7 @@ module Interpreter ) where import Algorithm -import Control.Monad.Free.Freer +import Control.Monad.Free.Freer hiding (cutoff) import Data.Align.Generic import Data.Functor.Both import Data.Functor.Classes (Eq1) From d1b3cc5c067cc4610beaa706255da781edb15271 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 11:08:01 -0400 Subject: [PATCH 002/154] :fire: runAlgorithm/runAlgorithmSteps. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit These have been subsumed by freer-cofreer’s runFreer & freerSteps. --- src/Interpreter.hs | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 4e58a003d..91c18dcae 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -4,8 +4,6 @@ module Interpreter , decoratingWith , diffTermsWith , comparableByConstructor -, runAlgorithm -, runAlgorithmSteps ) where import Algorithm @@ -44,7 +42,7 @@ diffTermsWith :: forall f fields . (Traversable f, GAlign f, Eq1 f, HasField fie -> ComparabilityRelation f fields -- ^ A relation on terms used to determine comparability and equality. -> Both (Term f (Record fields)) -- ^ A pair of terms. -> Diff f (Record fields) -- ^ The resulting diff. -diffTermsWith refine comparable (Join (a, b)) = runAlgorithm decompose (diff a b) +diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) where decompose :: AlgorithmF (Term f (Record fields)) (Diff f (Record fields)) result -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) result decompose step = case step of Diff t1 t2 -> refine t1 t2 @@ -62,24 +60,6 @@ getLabel (h :< t) = (Info.category h, case t of Leaf s -> Just s _ -> Nothing) --- | Run an Algorithm to completion by repeated application of a stepping operation and return its result. -runAlgorithm :: forall f result - . (forall x. f x -> Freer f x) - -> Freer f result - -> result -runAlgorithm decompose = go - where go :: Freer f x -> x - go = iterFreer (\ algorithm yield -> yield (go (decompose algorithm))) - --- | Run an Algorithm to completion by repeated application of a stepping operation, returning the list of steps taken up to and including the final result. -runAlgorithmSteps :: (forall x. f x -> Freer f x) - -> Freer f result - -> [Freer f result] -runAlgorithmSteps decompose = go - where go algorithm = case algorithm of - Return a -> [Return a] - step `Then` yield -> algorithm : go (decompose step >>= yield) - -- | Construct an algorithm to diff a pair of terms. algorithmWithTerms :: SyntaxTerm leaf fields From 03862a33f56e5e346a948779a9becb260c88a5b3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 11:37:54 -0400 Subject: [PATCH 003/154] Define a Message type for logging. --- src/Semantic/Task.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index d32f37142..20c3c8a5f 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -2,6 +2,7 @@ module Semantic.Task ( Task , RAlgebra +, Message(..) , Differ , readBlobs , readBlobPairs @@ -44,6 +45,13 @@ data TaskF output where -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' type Task = Freer TaskF +-- | A log message at a specific level. +data Message + = Error ByteString + | Warning ByteString + | Debug ByteString + deriving (Eq, Show) + -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. type Differ f a = Both (Term f a) -> Diff f a From 6c272105a403936ddb5a45364864a7d14c57cc58 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 11:38:02 -0400 Subject: [PATCH 004/154] Format messages as ByteStrings. --- src/Semantic/Task.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 20c3c8a5f..7993b12f8 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -52,6 +52,11 @@ data Message | Debug ByteString deriving (Eq, Show) +formatMessage :: Message -> ByteString +formatMessage (Error s) = "error: " <> s <> "\n" +formatMessage (Warning s) = "warning: " <> s <> "\n" +formatMessage (Debug s) = "debug: " <> s <> "\n" + -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. type Differ f a = Both (Term f a) -> Diff f a From e2a21addf2afbde6148b8656a5c75a71b74157ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 11:38:17 -0400 Subject: [PATCH 005/154] Log messages to stderr. --- src/Semantic/Task.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 7993b12f8..6c06c6fc4 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -7,6 +7,7 @@ module Semantic.Task , readBlobs , readBlobPairs , writeToOutput +, writeLog , parse , decorate , diff @@ -36,6 +37,7 @@ data TaskF output where ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF () + WriteLog :: Message -> TaskF () Parse :: Parser term -> Blob -> TaskF term Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields))) Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a) @@ -76,6 +78,11 @@ writeToOutput :: Either Handle FilePath -> ByteString -> Task () writeToOutput path contents = WriteToOutput path contents `Then` return +-- | A 'Task' which logs a message at a specific log level to stderr. +writeLog :: Message -> Task () +writeLog message = WriteLog message `Then` return + + -- | A 'Task' which parses a 'Blob' with the given 'Parser'. parse :: Parser term -> Blob -> Task term parse parser blob = Parse parser blob `Then` return @@ -117,6 +124,7 @@ runTask = iterFreerA $ \ task yield -> case task of ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield + WriteLog message -> B.hPutStr stderr (formatMessage message) >>= yield Parse parser blob -> runParser parser blob >>= yield Decorate algebra term -> yield (decoratorWithAlgebra algebra term) Diff differ terms -> yield (differ terms) From 6a04e3843b14abf606b3c3da2bea6ead3078590e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 11:42:06 -0400 Subject: [PATCH 006/154] Sort the import of Files down. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 6c06c6fc4..c39009b36 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -18,7 +18,6 @@ module Semantic.Task , runTask ) where -import qualified Files import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import Control.Monad.Free.Freer @@ -28,6 +27,7 @@ import Data.Functor.Both as Both import Data.Record import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import Diff +import qualified Files import Language import Parser import Prologue From 007fdd0e5cadd05bce9efffc8c26d41d8e6c28d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 12:09:06 -0400 Subject: [PATCH 007/154] Define runTask using foldFreer. --- src/Semantic/Task.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index c39009b36..71d98a841 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -120,13 +120,13 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) -- | Execute a 'Task', yielding its result value in 'IO'. runTask :: Task a -> IO a -runTask = iterFreerA $ \ task yield -> case task of - ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield - ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield - WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield - WriteLog message -> B.hPutStr stderr (formatMessage message) >>= yield - Parse parser blob -> runParser parser blob >>= yield - Decorate algebra term -> yield (decoratorWithAlgebra algebra term) - Diff differ terms -> yield (differ terms) - Render renderer input -> yield (renderer input) - Distribute tasks -> Async.mapConcurrently runTask tasks >>= yield . withStrategy (parTraversable rseq) +runTask = foldFreer $ \ task -> case task of + ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source + ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source + WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents + WriteLog message -> B.hPutStr stderr (formatMessage message) + Parse parser blob -> runParser parser blob + Decorate algebra term -> pure (decoratorWithAlgebra algebra term) + Diff differ terms -> pure (differ terms) + Render renderer input -> pure (renderer input) + Distribute tasks -> Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq) From 86169b6eb6d3ab2eea45b1237ac4266f9a9338d3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 12:10:06 -0400 Subject: [PATCH 008/154] Define informational messages. --- src/Semantic/Task.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 71d98a841..361ef35c3 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -51,12 +51,14 @@ type Task = Freer TaskF data Message = Error ByteString | Warning ByteString + | Info ByteString | Debug ByteString deriving (Eq, Show) formatMessage :: Message -> ByteString formatMessage (Error s) = "error: " <> s <> "\n" formatMessage (Warning s) = "warning: " <> s <> "\n" +formatMessage (Info s) = "info: " <> s <> "\n" formatMessage (Debug s) = "debug: " <> s <> "\n" -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. From 8b4db1d3e84a173886cae264bfd0845bdbc38f89 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 12:10:34 -0400 Subject: [PATCH 009/154] Define a record selector for message content. --- src/Semantic/Task.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 361ef35c3..4cab9bd10 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -49,10 +49,10 @@ type Task = Freer TaskF -- | A log message at a specific level. data Message - = Error ByteString - | Warning ByteString - | Info ByteString - | Debug ByteString + = Error { messageContent :: ByteString } + | Warning { messageContent :: ByteString } + | Info { messageContent :: ByteString } + | Debug { messageContent :: ByteString } deriving (Eq, Show) formatMessage :: Message -> ByteString From b51da4519ed00df1ff8fe46b10cb734584f6565a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 12:13:50 -0400 Subject: [PATCH 010/154] Log from a serializing background thread. --- semantic-diff.cabal | 1 + src/Semantic/Task.hs | 36 ++++++++++++++++++++++++++---------- 2 files changed, 27 insertions(+), 10 deletions(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index df043eb8b..b7d7ccc6e 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -110,6 +110,7 @@ library , recursion-schemes , semigroups , split + , stm-chans , template-haskell , text >= 1.2.1.3 , these diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 4cab9bd10..cf30db21d 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -18,6 +18,7 @@ module Semantic.Task , runTask ) where +import Control.Concurrent.STM.TMQueue import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import Control.Monad.Free.Freer @@ -122,13 +123,28 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) -- | Execute a 'Task', yielding its result value in 'IO'. runTask :: Task a -> IO a -runTask = foldFreer $ \ task -> case task of - ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source - ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source - WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents - WriteLog message -> B.hPutStr stderr (formatMessage message) - Parse parser blob -> runParser parser blob - Decorate algebra term -> pure (decoratorWithAlgebra algebra term) - Diff differ terms -> pure (differ terms) - Render renderer input -> pure (renderer input) - Distribute tasks -> Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq) +runTask task = do + logQueue <- newTMQueueIO + logging <- async (writeThread logQueue) + + result <- foldFreer (\ task -> case task of + ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source + ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source + WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents + WriteLog message -> atomically (writeTMQueue logQueue message) + Parse parser blob -> runParser parser blob + Decorate algebra term -> pure (decoratorWithAlgebra algebra term) + Diff differ terms -> pure (differ terms) + Render renderer input -> pure (renderer input) + Distribute tasks -> Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) + task + atomically (closeTMQueue logQueue) + wait logging + pure result + where writeThread queue = do + message <- atomically (readTMQueue queue) + case message of + Just message -> do + B.hPutStr stderr (formatMessage message) + writeThread queue + _ -> pure () From d886ba21f0bf1a072455f4bb16e08e18b4ebf62d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:06:14 -0400 Subject: [PATCH 011/154] Run tasks by refinement, writing log messages for each one. --- src/Semantic/Task.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index cf30db21d..5e4858935 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -127,16 +127,16 @@ runTask task = do logQueue <- newTMQueueIO logging <- async (writeThread logQueue) - result <- foldFreer (\ task -> case task of - ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source - ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source - WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents - WriteLog message -> atomically (writeTMQueue logQueue message) - Parse parser blob -> runParser parser blob - Decorate algebra term -> pure (decoratorWithAlgebra algebra term) - Diff differ terms -> pure (differ terms) - Render renderer input -> pure (renderer input) - Distribute tasks -> Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) + result <- runFreerM (\ task -> case task of + ReadBlobs source -> writeLog (Info "ReadBlobs") *> pure (either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source) + ReadBlobPairs source -> writeLog (Info "ReadBlobPairs") *> pure (either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source) + WriteToOutput destination contents -> writeLog (Info "WriteToOutput") *> pure (either B.hPutStr B.writeFile destination contents) + WriteLog message -> pure (atomically (writeTMQueue logQueue message)) + Parse parser blob -> writeLog (Info "Parse") *> pure (runParser parser blob) + Decorate algebra term -> writeLog (Info "Decorate") *> pure (pure (decoratorWithAlgebra algebra term)) + Diff differ terms -> writeLog (Info "Diff") *> pure (pure (differ terms)) + Render renderer input -> writeLog (Info "Render") *> pure (pure (renderer input)) + Distribute tasks -> writeLog (Info "Distribute") *> pure (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq))) task atomically (closeTMQueue logQueue) wait logging From 5e4f221585e0a952d1c3ac93aa9fe0ff3cd9bb8a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:09:51 -0400 Subject: [PATCH 012/154] Define a MonadIO instance for Task. --- src/Semantic/Task.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 5e4858935..4d2464c46 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -19,6 +19,7 @@ module Semantic.Task ) where import Control.Concurrent.STM.TMQueue +import Control.Monad.IO.Class import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import Control.Monad.Free.Freer @@ -44,6 +45,7 @@ data TaskF output where Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a) Render :: Renderer input output -> input -> TaskF output Distribute :: Traversable t => t (Task output) -> TaskF (t output) + LiftIO :: IO a -> TaskF a -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' type Task = Freer TaskF @@ -136,7 +138,8 @@ runTask task = do Decorate algebra term -> writeLog (Info "Decorate") *> pure (pure (decoratorWithAlgebra algebra term)) Diff differ terms -> writeLog (Info "Diff") *> pure (pure (differ terms)) Render renderer input -> writeLog (Info "Render") *> pure (pure (renderer input)) - Distribute tasks -> writeLog (Info "Distribute") *> pure (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq))) + Distribute tasks -> writeLog (Info "Distribute") *> pure (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) + LiftIO action -> pure action) task atomically (closeTMQueue logQueue) wait logging @@ -148,3 +151,7 @@ runTask task = do B.hPutStr stderr (formatMessage message) writeThread queue _ -> pure () + + +instance MonadIO Task where + liftIO action = LiftIO action `Then` return From 0109f340ed2c8f8af5e7787e89774e4cd2beb3d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:15:54 -0400 Subject: [PATCH 013/154] Lift the operations in Files to MonadIO. --- src/Files.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Files.hs b/src/Files.hs index 874e5ee08..1bfc734f3 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables #-} module Files ( readFile , readBlobPairsFromHandle @@ -7,6 +7,7 @@ module Files ) where import Control.Exception (catch, IOException) +import Control.Monad.IO.Class import Data.Aeson import Data.These import Data.Functor.Both @@ -21,9 +22,9 @@ import Prelude (fail) import System.FilePath -- | Read a utf8-encoded file to a 'Blob'. -readFile :: FilePath -> Maybe Language -> IO Blob.Blob +readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob readFile path language = do - raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) + raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw) -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported. @@ -31,7 +32,7 @@ languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . toS . takeExtension -- | Read JSON encoded blob pairs from a handle. -readBlobPairsFromHandle :: Handle -> IO [Both Blob.Blob] +readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob] readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where toBlobPairs BlobDiff{..} = toBlobPair <$> blobs @@ -39,16 +40,16 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs))) -- | Read JSON encoded blobs from a handle. -readBlobsFromHandle :: Handle -> IO [Blob.Blob] +readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs -readFromHandle :: FromJSON a => Handle -> IO a +readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a readFromHandle h = do - input <- BL.hGetContents h + input <- liftIO $ BL.hGetContents h case decode input of Just d -> pure d - Nothing -> die ("invalid input on " <> show h <> ", expecting JSON") + Nothing -> liftIO $ die ("invalid input on " <> show h <> ", expecting JSON") toBlob :: Blob -> Blob.Blob toBlob Blob{..} = Blob.sourceBlob path language' (fromText content) From e6bb7d6863c71f08e80010533be52dbe4368d76e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:28:04 -0400 Subject: [PATCH 014/154] Lift actions into IO. --- src/Semantic/Task.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 4d2464c46..f24ea2cd6 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -130,15 +130,15 @@ runTask task = do logging <- async (writeThread logQueue) result <- runFreerM (\ task -> case task of - ReadBlobs source -> writeLog (Info "ReadBlobs") *> pure (either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source) - ReadBlobPairs source -> writeLog (Info "ReadBlobPairs") *> pure (either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source) - WriteToOutput destination contents -> writeLog (Info "WriteToOutput") *> pure (either B.hPutStr B.writeFile destination contents) - WriteLog message -> pure (atomically (writeTMQueue logQueue message)) - Parse parser blob -> writeLog (Info "Parse") *> pure (runParser parser blob) - Decorate algebra term -> writeLog (Info "Decorate") *> pure (pure (decoratorWithAlgebra algebra term)) - Diff differ terms -> writeLog (Info "Diff") *> pure (pure (differ terms)) - Render renderer input -> writeLog (Info "Render") *> pure (pure (renderer input)) - Distribute tasks -> writeLog (Info "Distribute") *> pure (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) + ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source + ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source + WriteToOutput destination contents -> writeLog (Info "WriteToOutput") *> (pure <$> liftIO (either B.hPutStr B.writeFile destination contents)) + WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) + Parse parser blob -> pure <$ writeLog (Info "Parse") <*> liftIO (runParser parser blob) + Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) + Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) + Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) + Distribute tasks -> pure <$ writeLog (Info "Distribute") <*> (liftIO (Async.mapConcurrently runTask tasks) >>= pure . withStrategy (parTraversable rseq)) LiftIO action -> pure action) task atomically (closeTMQueue logQueue) From 3c0ed9029f1f0879312c7706f7ff02ba65b5b287 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:34:01 -0400 Subject: [PATCH 015/154] Rename writeThread to sink. --- src/Semantic/Task.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index f24ea2cd6..55274a3e8 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -127,7 +127,7 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) runTask :: Task a -> IO a runTask task = do logQueue <- newTMQueueIO - logging <- async (writeThread logQueue) + logging <- async (sink logQueue) result <- runFreerM (\ task -> case task of ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source @@ -144,12 +144,12 @@ runTask task = do atomically (closeTMQueue logQueue) wait logging pure result - where writeThread queue = do + where sink queue = do message <- atomically (readTMQueue queue) case message of Just message -> do B.hPutStr stderr (formatMessage message) - writeThread queue + sink queue _ -> pure () From 4f8a42650dc2d46d3505d167f64d62272433bc93 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:34:51 -0400 Subject: [PATCH 016/154] Run Tasks using foldFreer. --- src/Semantic/Task.hs | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 55274a3e8..916f7c73b 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -127,19 +127,20 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) runTask :: Task a -> IO a runTask task = do logQueue <- newTMQueueIO + let logMessage message = atomically (writeTMQueue logQueue message) logging <- async (sink logQueue) - result <- runFreerM (\ task -> case task of - ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source - ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source - WriteToOutput destination contents -> writeLog (Info "WriteToOutput") *> (pure <$> liftIO (either B.hPutStr B.writeFile destination contents)) - WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) - Parse parser blob -> pure <$ writeLog (Info "Parse") <*> liftIO (runParser parser blob) - Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) - Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) - Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) - Distribute tasks -> pure <$ writeLog (Info "Distribute") <*> (liftIO (Async.mapConcurrently runTask tasks) >>= pure . withStrategy (parTraversable rseq)) - LiftIO action -> pure action) + result <- foldFreer (\ task -> case task of + ReadBlobs source -> logMessage (Info "ReadBlobs") *> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source + ReadBlobPairs source -> logMessage (Info "ReadBlobPairs") *> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source + WriteToOutput destination contents -> logMessage (Info "WriteToOutput") *> either B.hPutStr B.writeFile destination contents + WriteLog message -> logMessage message + Parse parser blob -> logMessage (Info "Parse") *> runParser parser blob + Decorate algebra term -> logMessage (Info "Decorate") *> pure (decoratorWithAlgebra algebra term) + Diff differ terms -> logMessage (Info "Diff") *> pure (differ terms) + Render renderer input -> logMessage (Info "Render") *> pure (renderer input) + Distribute tasks -> logMessage (Info "Distribute") *> (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) + LiftIO action -> action) task atomically (closeTMQueue logQueue) wait logging From 4be8ad55d1e6a8a05515e074c283488512239781 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:35:36 -0400 Subject: [PATCH 017/154] :fire: redundant parens. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 916f7c73b..e0df928a4 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -139,7 +139,7 @@ runTask task = do Decorate algebra term -> logMessage (Info "Decorate") *> pure (decoratorWithAlgebra algebra term) Diff differ terms -> logMessage (Info "Diff") *> pure (differ terms) Render renderer input -> logMessage (Info "Render") *> pure (renderer input) - Distribute tasks -> logMessage (Info "Distribute") *> (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) + Distribute tasks -> logMessage (Info "Distribute") *> Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq) LiftIO action -> action) task atomically (closeTMQueue logQueue) From d575ca6dcefb5c6fdc5fb039de7fda9f1c8adb42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:41:02 -0400 Subject: [PATCH 018/154] Revert ":fire: redundant parens." This reverts commit 62cf5bd8ab878c0f6fbf62f5358ea90c7c9034dc. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index e0df928a4..916f7c73b 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -139,7 +139,7 @@ runTask task = do Decorate algebra term -> logMessage (Info "Decorate") *> pure (decoratorWithAlgebra algebra term) Diff differ terms -> logMessage (Info "Diff") *> pure (differ terms) Render renderer input -> logMessage (Info "Render") *> pure (renderer input) - Distribute tasks -> logMessage (Info "Distribute") *> Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq) + Distribute tasks -> logMessage (Info "Distribute") *> (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) LiftIO action -> action) task atomically (closeTMQueue logQueue) From 4c494a8c57498cba6d984a918fc2471520611857 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:41:16 -0400 Subject: [PATCH 019/154] Revert "Run Tasks using foldFreer." This reverts commit 8bbd7a0caa4c56a5d32c88af0a4b32837294cad0. --- src/Semantic/Task.hs | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 916f7c73b..55274a3e8 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -127,20 +127,19 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) runTask :: Task a -> IO a runTask task = do logQueue <- newTMQueueIO - let logMessage message = atomically (writeTMQueue logQueue message) logging <- async (sink logQueue) - result <- foldFreer (\ task -> case task of - ReadBlobs source -> logMessage (Info "ReadBlobs") *> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source - ReadBlobPairs source -> logMessage (Info "ReadBlobPairs") *> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source - WriteToOutput destination contents -> logMessage (Info "WriteToOutput") *> either B.hPutStr B.writeFile destination contents - WriteLog message -> logMessage message - Parse parser blob -> logMessage (Info "Parse") *> runParser parser blob - Decorate algebra term -> logMessage (Info "Decorate") *> pure (decoratorWithAlgebra algebra term) - Diff differ terms -> logMessage (Info "Diff") *> pure (differ terms) - Render renderer input -> logMessage (Info "Render") *> pure (renderer input) - Distribute tasks -> logMessage (Info "Distribute") *> (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) - LiftIO action -> action) + result <- runFreerM (\ task -> case task of + ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source + ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source + WriteToOutput destination contents -> writeLog (Info "WriteToOutput") *> (pure <$> liftIO (either B.hPutStr B.writeFile destination contents)) + WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) + Parse parser blob -> pure <$ writeLog (Info "Parse") <*> liftIO (runParser parser blob) + Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) + Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) + Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) + Distribute tasks -> pure <$ writeLog (Info "Distribute") <*> (liftIO (Async.mapConcurrently runTask tasks) >>= pure . withStrategy (parTraversable rseq)) + LiftIO action -> pure action) task atomically (closeTMQueue logQueue) wait logging From 19bf5498f86bb8fde25b7e857c5445228464eb9f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:42:09 -0400 Subject: [PATCH 020/154] Move pure earlier in the chain. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 55274a3e8..4c814d675 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -132,7 +132,7 @@ runTask task = do result <- runFreerM (\ task -> case task of ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source - WriteToOutput destination contents -> writeLog (Info "WriteToOutput") *> (pure <$> liftIO (either B.hPutStr B.writeFile destination contents)) + WriteToOutput destination contents -> pure <$ writeLog (Info "WriteToOutput") <*> liftIO (either B.hPutStr B.writeFile destination contents) WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) Parse parser blob -> pure <$ writeLog (Info "Parse") <*> liftIO (runParser parser blob) Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) From dcd2e777040861c6b4309dfb0a64bb68064b9fa4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 13:50:13 -0400 Subject: [PATCH 021/154] Redistribute the parens. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 4c814d675..b9260dc31 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -138,7 +138,7 @@ runTask task = do Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) - Distribute tasks -> pure <$ writeLog (Info "Distribute") <*> (liftIO (Async.mapConcurrently runTask tasks) >>= pure . withStrategy (parTraversable rseq)) + Distribute tasks -> pure <$ writeLog (Info "Distribute") <*> liftIO (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) LiftIO action -> pure action) task atomically (closeTMQueue logQueue) From 4e79edf4214a2668c733845ff1fe1b4ff836558f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 14:12:41 -0400 Subject: [PATCH 022/154] Separate printing & formatting errors with options. --- src/Data/Syntax/Assignment.hs | 73 +++++++++++++++++++++++++---------- 1 file changed, 52 insertions(+), 21 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 4044052a5..241dbd848 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -76,8 +76,12 @@ module Data.Syntax.Assignment -- Results , Error(..) , ErrorCause(..) +, Options(..) +, defaultOptions +, optionsForHandle , printError -, withSGRCode +, formatError +, formatErrorWithOptions -- Running , assign , assignBy @@ -89,7 +93,7 @@ module Data.Syntax.Assignment import Control.Monad.Free.Freer import Data.Blob -import Data.ByteString (isSuffixOf) +import Data.ByteString (isSuffixOf, hPutStr) import Data.Functor.Classes import Data.Functor.Foldable as F hiding (Nil) import qualified Data.IntMap.Lazy as IntMap @@ -103,7 +107,7 @@ import Prologue hiding (Alt, get, Location, state) import System.Console.ANSI import Text.Parser.TreeSitter.Language import Text.Show hiding (show) -import System.IO (hIsTerminalDevice, hPutStr) +import System.IO (hIsTerminalDevice) -- | Assignment from an AST with some set of 'symbol's onto some other value. -- @@ -187,29 +191,56 @@ data ErrorCause grammar | UnexpectedEndOfInput [grammar] deriving (Eq, Show) --- | Pretty-print an Error with reference to the source where it occurred. +-- | Options for printing errors. +data Options = Options + { optionsColour :: Bool -- ^ Whether to use colour formatting. + } + +defaultOptions :: Options +defaultOptions = Options + { optionsColour = True + } + +optionsForHandle :: Handle -> IO Options +optionsForHandle handle = do + isTerminal <- hIsTerminalDevice handle + pure $ Options + { optionsColour = isTerminal + } + +-- | Pretty-print an 'Error' to stdout with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () -printError Blob{..} error@Error{..} = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": " - withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n' - putStrErr $ 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' - putStrErr $ showString (prettyCallStack callStack) . showChar '\n' +printError blob error = do + options <- optionsForHandle stderr + hPutStr stderr $ formatErrorWithOptions options blob error + +-- | Format an 'Error' with reference to the source where it occurred. +-- +-- > formatError = formatErrorWithOptions defaultOptions +formatError :: Show grammar => Blob -> Error grammar -> ByteString +formatError = formatErrorWithOptions defaultOptions + +-- | Format an 'Error' with reference +formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> ByteString +formatErrorWithOptions options Blob{..} error@Error{..} + = toS . ($ "") + $ withSGRCode options [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ") + . withSGRCode options [SetColor Foreground Vivid Red] (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 options [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') + . showString (prettyCallStack callStack) . showChar '\n' where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), 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))) - putStrErr = hPutStr stderr . ($ "") -withSGRCode :: [SGR] -> IO a -> IO () -withSGRCode code action = do - isTerm <- hIsTerminalDevice stderr - if isTerm then do - _ <- hSetSGR stderr code - _ <- action - hSetSGR stderr [] - else do - _ <- action - pure () +withSGRCode :: Options -> [SGR] -> ShowS -> ShowS +withSGRCode Options{..} code content = + if optionsColour then + showString (setSGRCode code) + . content + . showString (setSGRCode []) + else + content showExpectation :: Show grammar => Error grammar -> ShowS showExpectation Error{..} = case errorCause of From 72385b8a93f383a59ed625b1e18a1f87caa01310 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 14:13:04 -0400 Subject: [PATCH 023/154] Better docs for optionsColour. --- 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 241dbd848..9166538b6 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -193,7 +193,7 @@ data ErrorCause grammar -- | Options for printing errors. data Options = Options - { optionsColour :: Bool -- ^ Whether to use colour formatting. + { optionsColour :: Bool -- ^ Whether to use colour formatting codes suitable for a terminal device. } defaultOptions :: Options From b8ebbd2a3da4244437f7f5a6ca93b1c719d06962 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 14:17:34 -0400 Subject: [PATCH 024/154] Add an option to disable the display of source. --- src/Data/Syntax/Assignment.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 9166538b6..81d1bccff 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -194,40 +194,44 @@ data ErrorCause grammar -- | Options for printing errors. data Options = Options { optionsColour :: Bool -- ^ Whether to use colour formatting codes suitable for a terminal device. + , optionsIncludeSource :: Bool -- ^ Whether to include the source reference. } defaultOptions :: Options defaultOptions = Options { optionsColour = True + , optionsIncludeSource = True } optionsForHandle :: Handle -> IO Options optionsForHandle handle = do isTerminal <- hIsTerminalDevice handle - pure $ Options + pure $ defaultOptions { optionsColour = isTerminal } --- | Pretty-print an 'Error' to stdout with reference to the source where it occurred. +-- | Pretty-print an 'Error' to stderr, optionally with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () printError blob error = do options <- optionsForHandle stderr hPutStr stderr $ formatErrorWithOptions options blob error --- | Format an 'Error' with reference to the source where it occurred. +-- | Format an 'Error', optionally with reference to the source where it occurred. -- -- > formatError = formatErrorWithOptions defaultOptions formatError :: Show grammar => Blob -> Error grammar -> ByteString formatError = formatErrorWithOptions defaultOptions --- | Format an 'Error' with reference +-- | Format an 'Error', optionally with reference to the source where it occurred. formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> ByteString formatErrorWithOptions options Blob{..} error@Error{..} = toS . ($ "") $ withSGRCode options [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ") . withSGRCode options [SetColor Foreground Vivid Red] (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 options [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') + . (if optionsIncludeSource options + then showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') + . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode options [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') + else identity) . showString (prettyCallStack callStack) . showChar '\n' where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s From d87c8a98b454af02e2967baddb958754fad08ae6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 14:19:19 -0400 Subject: [PATCH 025/154] Move runParser into Task. --- src/Parser.hs | 22 ++-------------------- src/Semantic/Task.hs | 28 ++++++++++++++++++++++++++-- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 658958b03..5fc7bc011 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Parser -( Parser -, runParser +( Parser(..) -- Syntax parsers , parserForLanguage +, lineByLineParser -- À la carte parsers , jsonParser , markdownParser @@ -12,7 +12,6 @@ module Parser ) where import qualified CMark -import Data.Blob import Data.Functor.Foldable hiding (fold, Nil) import Data.Record import Data.Source as Source @@ -37,7 +36,6 @@ import Text.Parser.TreeSitter.Python import Text.Parser.TreeSitter.Ruby import Text.Parser.TreeSitter.TypeScript import Text.Parser.TreeSitter.JSON -import TreeSitter -- | A parser from 'Source' onto some term type. data Parser term where @@ -80,22 +78,6 @@ jsonParser = AssignmentParser (ASTParser tree_sitter_json) headF JSON.assignment markdownParser :: Parser Markdown.Term markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node { nodeSymbol = toGrammar nodeSymbol }) Markdown.assignment -runParser :: Parser term -> Blob -> IO term -runParser parser blob@Blob{..} = case parser of - ASTParser language -> parseToAST language blobSource - AssignmentParser parser by assignment -> do - ast <- runParser parser blob - case assignBy by assignment blobSource ast of - Left err -> do - printError blob err - pure (errorTerm blobSource) - Right term -> pure term - TreeSitterParser language tslanguage -> treeSitterParser language tslanguage blobSource - MarkdownParser -> pure (cmarkParser blobSource) - LineByLineParser -> pure (lineByLineParser blobSource) - -errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Location) -errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error [])) -- | A fallback parser that treats a file simply as rows of strings. lineByLineParser :: Source -> SyntaxTerm Text DefaultFields diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index b9260dc31..2acb9ceeb 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -27,13 +27,19 @@ import Data.Blob import qualified Data.ByteString as B import Data.Functor.Both as Both import Data.Record +import Data.Source +import qualified Data.Syntax as Syntax import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) +import Data.Syntax.Assignment hiding (Error) +import Data.Union import Diff import qualified Files import Language +import Language.Markdown import Parser -import Prologue +import Prologue hiding (Location) import Term +import TreeSitter data TaskF output where ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] @@ -134,7 +140,7 @@ runTask task = do ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source WriteToOutput destination contents -> pure <$ writeLog (Info "WriteToOutput") <*> liftIO (either B.hPutStr B.writeFile destination contents) WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) - Parse parser blob -> pure <$ writeLog (Info "Parse") <*> liftIO (runParser parser blob) + Parse parser blob -> pure <$ writeLog (Info "Parse") <*> runParser parser blob Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) @@ -152,6 +158,24 @@ runTask task = do sink queue _ -> pure () +runParser :: Parser term -> Blob -> Task term +runParser parser blob@Blob{..} = case parser of + ASTParser language -> liftIO $ parseToAST language blobSource + AssignmentParser parser by assignment -> do + ast <- runParser parser blob + case assignBy by assignment blobSource ast of + Left err -> do + options <- liftIO $ optionsForHandle stderr + writeLog (Warning (formatErrorWithOptions options blob err)) + pure (errorTerm blobSource) + Right term -> pure term + TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource + MarkdownParser -> pure (cmarkParser blobSource) + LineByLineParser -> pure (lineByLineParser blobSource) + +errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Location) +errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error [])) + instance MonadIO Task where liftIO action = LiftIO action `Then` return From 75721c09f0f549e9851c057edae3e0c3a5a9c970 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 14:45:38 -0400 Subject: [PATCH 026/154] Define options controlling Task running & output. --- src/Semantic/Task.hs | 52 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 41 insertions(+), 11 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 2acb9ceeb..a8754e268 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -15,7 +15,11 @@ module Semantic.Task , distribute , distributeFor , distributeFoldMap +, Options(..) +, defaultOptions +, configureOptionsForHandle , runTask +, runTaskOptions ) where import Control.Concurrent.STM.TMQueue @@ -30,7 +34,7 @@ import Data.Record import Data.Source import qualified Data.Syntax as Syntax import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) -import Data.Syntax.Assignment hiding (Error) +import qualified Data.Syntax.Assignment as Assignment import Data.Union import Diff import qualified Files @@ -38,6 +42,7 @@ import Language import Language.Markdown import Parser import Prologue hiding (Location) +import System.IO (hIsTerminalDevice) import Term import TreeSitter @@ -128,10 +133,33 @@ distributeFor inputs toTask = distribute (fmap toTask inputs) distributeFoldMap :: (Traversable t, Monoid output) => (a -> Task output) -> t a -> Task output distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) +-- | Options controlling 'Task' logging, error handling, &c. +data Options = Options + { optionsColour :: Maybe Bool -- ^ Whether to use colour formatting for errors. 'Nothing' implies automatic selection for the stderr handle, using colour for terminal handles but not for regular files. + } --- | Execute a 'Task', yielding its result value in 'IO'. +defaultOptions :: Options +defaultOptions = Options + { optionsColour = Nothing + } + +configureOptionsForHandle :: Handle -> Options -> IO Options +configureOptionsForHandle handle options = do + isTerminal <- hIsTerminalDevice handle + pure $ Options + { optionsColour = optionsColour options <|> Just isTerminal + } + +-- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. +-- +-- > runTask = runTaskOptions defaultOptions runTask :: Task a -> IO a -runTask task = do +runTask = runTaskOptions defaultOptions + +-- | Execute a 'Task' with the passed 'Options', yielding its result value in 'IO'. +runTaskOptions :: Options -> Task a -> IO a +runTaskOptions options task = do + options <- configureOptionsForHandle stderr options logQueue <- newTMQueueIO logging <- async (sink logQueue) @@ -140,7 +168,7 @@ runTask task = do ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source WriteToOutput destination contents -> pure <$ writeLog (Info "WriteToOutput") <*> liftIO (either B.hPutStr B.writeFile destination contents) WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) - Parse parser blob -> pure <$ writeLog (Info "Parse") <*> runParser parser blob + Parse parser blob -> pure <$ writeLog (Info "Parse") <*> runParser options parser blob Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) @@ -158,22 +186,24 @@ runTask task = do sink queue _ -> pure () -runParser :: Parser term -> Blob -> Task term -runParser parser blob@Blob{..} = case parser of +runParser :: Options -> Parser term -> Blob -> Task term +runParser options parser blob@Blob{..} = case parser of ASTParser language -> liftIO $ parseToAST language blobSource AssignmentParser parser by assignment -> do - ast <- runParser parser blob - case assignBy by assignment blobSource ast of + ast <- runParser options parser blob + case Assignment.assignBy by assignment blobSource ast of Left err -> do - options <- liftIO $ optionsForHandle stderr - writeLog (Warning (formatErrorWithOptions options blob err)) + let formatOptions = Assignment.defaultOptions + { Assignment.optionsColour = fromMaybe True (optionsColour options) + } + writeLog (Warning (Assignment.formatErrorWithOptions formatOptions blob err)) pure (errorTerm blobSource) Right term -> pure term TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource MarkdownParser -> pure (cmarkParser blobSource) LineByLineParser -> pure (lineByLineParser blobSource) -errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Location) +errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Assignment.Location) errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error [])) From 882947b689e640ea0ba1891042277ecaf483396e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:36:19 -0400 Subject: [PATCH 027/154] Add a flag to enable/disable colour output. --- src/SemanticCmdLine.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 01cfa3edb..7eca34f43 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -7,13 +7,13 @@ module SemanticCmdLine ) where import Files (languageForFilePath) -import Data.Functor.Both +import Data.Functor.Both hiding (fst, snd) import Data.List.Split (splitWhen) import Data.Version (showVersion) import Development.GitRev import Language import Options.Applicative hiding (action) -import Prologue hiding (concurrently, fst, snd, readFile) +import Prologue hiding (concurrently, readFile) import Renderer import qualified Paths_semantic_diff as Library (version) import qualified Semantic.Task as Task @@ -21,7 +21,7 @@ import System.IO (stdin) import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () -main = customExecParser (prefs showHelpOnEmpty) arguments >>= Task.runTask +main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskOptions runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs @@ -32,13 +32,15 @@ runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRendere -- | A parser for the application's command-line arguments. -- -- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout. -arguments :: ParserInfo (Task.Task ()) -arguments = info (version <*> helper <*> argumentsParser) description +arguments :: ParserInfo (Task.Options, Task.Task ()) +arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description where version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")" description = fullDesc <> header "semantic -- Parse and diff semantically" + optionsParser = Task.Options + <$> ( options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable/disable colour output, or enable automatically when stderr is a terminal but not for regular files.")) argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") @@ -69,3 +71,7 @@ arguments = info (version <*> helper <*> argumentsParser) description | Just lang <- readMaybe b -> Right (a, Just lang) [path] -> Right (path, languageForFilePath path) _ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE") + + optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) + options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options)) + findOption options value = maybe "" fst (find ((== value) . snd) options) From 63efa14594057007079517c1c815c5483c2fd722 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:37:23 -0400 Subject: [PATCH 028/154] Better help info for the colour flag. --- src/SemanticCmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 7eca34f43..523160537 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -40,7 +40,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar description = fullDesc <> header "semantic -- Parse and diff semantically" optionsParser = Task.Options - <$> ( options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable/disable colour output, or enable automatically when stderr is a terminal but not for regular files.")) + <$> ( options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable/disable colour output, or enable automatically iff stderr is a terminal device.")) argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") From 4baa0dd2b21b97bec40aa53c3d041e9bcbc64c31 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:37:43 -0400 Subject: [PATCH 029/154] :fire: parens/indentation. --- src/SemanticCmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 523160537..ea171f591 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -40,7 +40,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar description = fullDesc <> header "semantic -- Parse and diff semantically" optionsParser = Task.Options - <$> ( options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable/disable colour output, or enable automatically iff stderr is a terminal device.")) + <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable/disable colour output, or enable automatically iff stderr is a terminal device.") argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") From 7577eec6285c2dc911c1a9c366018891b84e4ab4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:39:20 -0400 Subject: [PATCH 030/154] Pass withSGRCode a flag instead of Options. --- src/Data/Syntax/Assignment.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 81d1bccff..26a3122ea 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -224,22 +224,22 @@ formatError = formatErrorWithOptions defaultOptions -- | Format an 'Error', optionally with reference to the source where it occurred. formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> ByteString -formatErrorWithOptions options Blob{..} error@Error{..} +formatErrorWithOptions Options{..} Blob{..} error@Error{..} = toS . ($ "") - $ withSGRCode options [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ") - . withSGRCode options [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation error . showChar '\n') - . (if optionsIncludeSource options + $ withSGRCode optionsColour [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ") + . withSGRCode optionsColour [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation error . showChar '\n') + . (if optionsIncludeSource then showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') - . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode options [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') + . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode optionsColour [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') else identity) . showString (prettyCallStack callStack) . showChar '\n' where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), 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))) -withSGRCode :: Options -> [SGR] -> ShowS -> ShowS -withSGRCode Options{..} code content = - if optionsColour then +withSGRCode :: Bool -> [SGR] -> ShowS -> ShowS +withSGRCode useColour code content = + if useColour then showString (setSGRCode code) . content . showString (setSGRCode []) From e1c7fb438b34d6c36d11e4669239b070b4a13a15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:40:02 -0400 Subject: [PATCH 031/154] Rename runTaskOptions to runTaskWithOptions. --- src/Semantic/Task.hs | 10 +++++----- src/SemanticCmdLine.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index a8754e268..5e2b1bb24 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -19,7 +19,7 @@ module Semantic.Task , defaultOptions , configureOptionsForHandle , runTask -, runTaskOptions +, runTaskWithOptions ) where import Control.Concurrent.STM.TMQueue @@ -152,13 +152,13 @@ configureOptionsForHandle handle options = do -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. -- --- > runTask = runTaskOptions defaultOptions +-- > runTask = runTaskWithOptions defaultOptions runTask :: Task a -> IO a -runTask = runTaskOptions defaultOptions +runTask = runTaskWithOptions defaultOptions -- | Execute a 'Task' with the passed 'Options', yielding its result value in 'IO'. -runTaskOptions :: Options -> Task a -> IO a -runTaskOptions options task = do +runTaskWithOptions :: Options -> Task a -> IO a +runTaskWithOptions options task = do options <- configureOptionsForHandle stderr options logQueue <- newTMQueueIO logging <- async (sink logQueue) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index ea171f591..d73c5a0ae 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -21,7 +21,7 @@ import System.IO (stdin) import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () -main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskOptions +main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs From 3c213b72db8473612f09508a606ce455a7cae034 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:41:59 -0400 Subject: [PATCH 032/154] Export withSGRCode. --- 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 26a3122ea..10494ad37 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -82,6 +82,7 @@ module Data.Syntax.Assignment , printError , formatError , formatErrorWithOptions +, withSGRCode -- Running , assign , assignBy From d1babd0fb77d794ba87d401816d4cd3cc11ccc2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:43:28 -0400 Subject: [PATCH 033/154] Pass the options to the sink. --- src/Semantic/Task.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 5e2b1bb24..cdcfa44b9 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -161,7 +161,7 @@ runTaskWithOptions :: Options -> Task a -> IO a runTaskWithOptions options task = do options <- configureOptionsForHandle stderr options logQueue <- newTMQueueIO - logging <- async (sink logQueue) + logging <- async (sink options logQueue) result <- runFreerM (\ task -> case task of ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source @@ -178,12 +178,12 @@ runTaskWithOptions options task = do atomically (closeTMQueue logQueue) wait logging pure result - where sink queue = do + where sink options queue = do message <- atomically (readTMQueue queue) case message of Just message -> do B.hPutStr stderr (formatMessage message) - sink queue + sink options queue _ -> pure () runParser :: Options -> Parser term -> Blob -> Task term From 580b817b9fe33ad72695eaaaae41ec2ec5f8bf1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:43:42 -0400 Subject: [PATCH 034/154] Rename sink to logSink. --- src/Semantic/Task.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index cdcfa44b9..02012b5e1 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -161,7 +161,7 @@ runTaskWithOptions :: Options -> Task a -> IO a runTaskWithOptions options task = do options <- configureOptionsForHandle stderr options logQueue <- newTMQueueIO - logging <- async (sink options logQueue) + logging <- async (logSink options logQueue) result <- runFreerM (\ task -> case task of ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source @@ -178,12 +178,12 @@ runTaskWithOptions options task = do atomically (closeTMQueue logQueue) wait logging pure result - where sink options queue = do + where logSink options queue = do message <- atomically (readTMQueue queue) case message of Just message -> do B.hPutStr stderr (formatMessage message) - sink options queue + logSink options queue _ -> pure () runParser :: Options -> Parser term -> Blob -> Task term From 7d6aa01c939480debdcfa76097abe9e65e44b215 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:48:30 -0400 Subject: [PATCH 035/154] Error & Message formatting produces a String. --- src/Data/Syntax/Assignment.hs | 11 ++++++----- src/Semantic/Task.hs | 16 +++++++++------- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 10494ad37..ffa6e9792 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -94,7 +94,7 @@ module Data.Syntax.Assignment import Control.Monad.Free.Freer import Data.Blob -import Data.ByteString (isSuffixOf, hPutStr) +import Data.ByteString (isSuffixOf) import Data.Functor.Classes import Data.Functor.Foldable as F hiding (Nil) import qualified Data.IntMap.Lazy as IntMap @@ -102,13 +102,14 @@ import Data.Ix (inRange) import Data.List.NonEmpty (nonEmpty) import Data.Record import qualified Data.Source as Source (Source, fromBytes, slice, sourceBytes, sourceLines) +import Data.String import GHC.Stack import qualified Info import Prologue hiding (Alt, get, Location, state) import System.Console.ANSI import Text.Parser.TreeSitter.Language import Text.Show hiding (show) -import System.IO (hIsTerminalDevice) +import System.IO (hIsTerminalDevice, hPutStr) -- | Assignment from an AST with some set of 'symbol's onto some other value. -- @@ -220,13 +221,13 @@ printError blob error = do -- | Format an 'Error', optionally with reference to the source where it occurred. -- -- > formatError = formatErrorWithOptions defaultOptions -formatError :: Show grammar => Blob -> Error grammar -> ByteString +formatError :: Show grammar => Blob -> Error grammar -> String formatError = formatErrorWithOptions defaultOptions -- | Format an 'Error', optionally with reference to the source where it occurred. -formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> ByteString +formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> String formatErrorWithOptions Options{..} Blob{..} error@Error{..} - = toS . ($ "") + = ($ "") $ withSGRCode optionsColour [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ") . withSGRCode optionsColour [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation error . showChar '\n') . (if optionsIncludeSource diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 02012b5e1..87bc2321f 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -32,6 +32,7 @@ import qualified Data.ByteString as B import Data.Functor.Both as Both import Data.Record import Data.Source +import Data.String import qualified Data.Syntax as Syntax import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import qualified Data.Syntax.Assignment as Assignment @@ -42,7 +43,7 @@ import Language import Language.Markdown import Parser import Prologue hiding (Location) -import System.IO (hIsTerminalDevice) +import System.IO (hIsTerminalDevice, hPutStr) import Term import TreeSitter @@ -63,13 +64,14 @@ type Task = Freer TaskF -- | A log message at a specific level. data Message - = Error { messageContent :: ByteString } - | Warning { messageContent :: ByteString } - | Info { messageContent :: ByteString } - | Debug { messageContent :: ByteString } + = Error { messageContent :: String } + | Warning { messageContent :: String } + | Info { messageContent :: String } + | Debug { messageContent :: String } deriving (Eq, Show) -formatMessage :: Message -> ByteString +-- | Format a 'Message'. +formatMessage :: Message -> String formatMessage (Error s) = "error: " <> s <> "\n" formatMessage (Warning s) = "warning: " <> s <> "\n" formatMessage (Info s) = "info: " <> s <> "\n" @@ -182,7 +184,7 @@ runTaskWithOptions options task = do message <- atomically (readTMQueue queue) case message of Just message -> do - B.hPutStr stderr (formatMessage message) + hPutStr stderr (formatMessage message) logSink options queue _ -> pure () From 22d81403f0be43d531ad165c7becde4df06a2525 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:48:46 -0400 Subject: [PATCH 036/154] Pass the colourization flag to formatMessage. --- src/Semantic/Task.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 87bc2321f..3780bcf26 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -70,12 +70,12 @@ data Message | Debug { messageContent :: String } deriving (Eq, Show) --- | Format a 'Message'. -formatMessage :: Message -> String -formatMessage (Error s) = "error: " <> s <> "\n" -formatMessage (Warning s) = "warning: " <> s <> "\n" -formatMessage (Info s) = "info: " <> s <> "\n" -formatMessage (Debug s) = "debug: " <> s <> "\n" +-- | Format a 'Message', optionally colourized. +formatMessage :: Bool -> Message -> String +formatMessage _ (Error s) = "error: " <> s <> "\n" +formatMessage _ (Warning s) = "warning: " <> s <> "\n" +formatMessage _ (Info s) = "info: " <> s <> "\n" +formatMessage _ (Debug s) = "debug: " <> s <> "\n" -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. type Differ f a = Both (Term f a) -> Diff f a @@ -184,7 +184,7 @@ runTaskWithOptions options task = do message <- atomically (readTMQueue queue) case message of Just message -> do - hPutStr stderr (formatMessage message) + hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message) logSink options queue _ -> pure () From 293104b94a7fe59b58898cabf91cb57d580eb40d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:53:53 -0400 Subject: [PATCH 037/154] Colourize logged messages. --- src/Semantic/Task.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 3780bcf26..ab2ab6ab1 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -43,8 +43,10 @@ import Language import Language.Markdown import Parser import Prologue hiding (Location) +import System.Console.ANSI import System.IO (hIsTerminalDevice, hPutStr) import Term +import Text.Show import TreeSitter data TaskF output where @@ -72,10 +74,12 @@ data Message -- | Format a 'Message', optionally colourized. formatMessage :: Bool -> Message -> String -formatMessage _ (Error s) = "error: " <> s <> "\n" -formatMessage _ (Warning s) = "warning: " <> s <> "\n" -formatMessage _ (Info s) = "info: " <> s <> "\n" -formatMessage _ (Debug s) = "debug: " <> s <> "\n" +formatMessage colourize m = showLabel m . showString ": " . showString (messageContent m) . showChar '\n' $ "" + where showLabel Error{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") + showLabel Warning{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") + showLabel Info{} = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") + showLabel Debug{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") + -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. type Differ f a = Both (Term f a) -> Diff f a From 01ac5356cb89752f3360c81b4476f3a2b90675b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 15:59:28 -0400 Subject: [PATCH 038/154] Configure the passed-in options. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index ab2ab6ab1..724e8f306 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -152,7 +152,7 @@ defaultOptions = Options configureOptionsForHandle :: Handle -> Options -> IO Options configureOptionsForHandle handle options = do isTerminal <- hIsTerminalDevice handle - pure $ Options + pure $ options { optionsColour = optionsColour options <|> Just isTerminal } From 09baaffc46fe53820756dd555026a9486c022b8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:01:35 -0400 Subject: [PATCH 039/154] Better help text for --colour. --- src/SemanticCmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index d73c5a0ae..ccf7252b9 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -40,7 +40,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar description = fullDesc <> header "semantic -- Parse and diff semantically" optionsParser = Task.Options - <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable/disable colour output, or enable automatically iff stderr is a terminal device.") + <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable (yes)/disable (no) colour output, or enable automatically iff stderr is a terminal device.") argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") From 94e8eb7f209e5408a513f14dd58e5798fef29e87 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:02:35 -0400 Subject: [PATCH 040/154] Separate log level & message. --- src/Semantic/Task.hs | 56 ++++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 724e8f306..1038c3954 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds, GADTs, TypeOperators #-} module Semantic.Task ( Task +, Level(..) , RAlgebra -, Message(..) , Differ , readBlobs , readBlobPairs @@ -53,7 +53,7 @@ data TaskF output where ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF () - WriteLog :: Message -> TaskF () + WriteLog :: Level -> String -> TaskF () Parse :: Parser term -> Blob -> TaskF term Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields))) Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a) @@ -65,20 +65,20 @@ data TaskF output where type Task = Freer TaskF -- | A log message at a specific level. -data Message - = Error { messageContent :: String } - | Warning { messageContent :: String } - | Info { messageContent :: String } - | Debug { messageContent :: String } - deriving (Eq, Show) +data Level + = Error + | Warning + | Info + | Debug + deriving (Eq, Ord, Show) -- | Format a 'Message', optionally colourized. -formatMessage :: Bool -> Message -> String -formatMessage colourize m = showLabel m . showString ": " . showString (messageContent m) . showChar '\n' $ "" - where showLabel Error{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") - showLabel Warning{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") - showLabel Info{} = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") - showLabel Debug{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") +formatMessage :: Bool -> Level -> String -> String +formatMessage colourize level message = showLabel level . showString ": " . showString message . showChar '\n' $ "" + where showLabel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") + showLabel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") + showLabel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") + showLabel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. @@ -101,8 +101,8 @@ writeToOutput path contents = WriteToOutput path contents `Then` return -- | A 'Task' which logs a message at a specific log level to stderr. -writeLog :: Message -> Task () -writeLog message = WriteLog message `Then` return +writeLog :: Level -> String -> Task () +writeLog level message = WriteLog level message `Then` return -- | A 'Task' which parses a 'Blob' with the given 'Parser'. @@ -170,15 +170,15 @@ runTaskWithOptions options task = do logging <- async (logSink options logQueue) result <- runFreerM (\ task -> case task of - ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source - ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source - WriteToOutput destination contents -> pure <$ writeLog (Info "WriteToOutput") <*> liftIO (either B.hPutStr B.writeFile destination contents) - WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) - Parse parser blob -> pure <$ writeLog (Info "Parse") <*> runParser options parser blob - Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) - Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) - Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) - Distribute tasks -> pure <$ writeLog (Info "Distribute") <*> liftIO (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) + ReadBlobs source -> pure <$ writeLog Info "ReadBlobs" <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source + ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source + WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents) + WriteLog level message -> pure <$> liftIO (atomically (writeTMQueue logQueue (level, message))) + Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob + Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term) + Diff differ terms -> pure <$ writeLog Info "Diff" <*> pure (differ terms) + Render renderer input -> pure <$ writeLog Info "Render" <*> pure (renderer input) + Distribute tasks -> pure <$ writeLog Info "Distribute" <*> liftIO (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) LiftIO action -> pure action) task atomically (closeTMQueue logQueue) @@ -187,8 +187,8 @@ runTaskWithOptions options task = do where logSink options queue = do message <- atomically (readTMQueue queue) case message of - Just message -> do - hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message) + Just (level, message) -> do + hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) level message) logSink options queue _ -> pure () @@ -202,7 +202,7 @@ runParser options parser blob@Blob{..} = case parser of let formatOptions = Assignment.defaultOptions { Assignment.optionsColour = fromMaybe True (optionsColour options) } - writeLog (Warning (Assignment.formatErrorWithOptions formatOptions blob err)) + writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err) pure (errorTerm blobSource) Right term -> pure term TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource From 9937a419d1fe902640001e3946d7bf54301b25c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:04:35 -0400 Subject: [PATCH 041/154] Add an option controlling the log level. --- src/Semantic/Task.hs | 6 +++++- src/SemanticCmdLine.hs | 1 + 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 1038c3954..4f2ed0f2a 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -142,11 +142,13 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) -- | Options controlling 'Task' logging, error handling, &c. data Options = Options { optionsColour :: Maybe Bool -- ^ Whether to use colour formatting for errors. 'Nothing' implies automatic selection for the stderr handle, using colour for terminal handles but not for regular files. + , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. } defaultOptions :: Options defaultOptions = Options { optionsColour = Nothing + , optionsLevel = Just Warning } configureOptionsForHandle :: Handle -> Options -> IO Options @@ -173,7 +175,9 @@ runTaskWithOptions options task = do ReadBlobs source -> pure <$ writeLog Info "ReadBlobs" <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents) - WriteLog level message -> pure <$> liftIO (atomically (writeTMQueue logQueue (level, message))) + WriteLog level message + | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (atomically (writeTMQueue logQueue (level, message))) + | otherwise -> pure (pure ()) Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term) Diff differ terms -> pure <$ writeLog Info "Diff" <*> pure (differ terms) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index ccf7252b9..5ebe57604 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -41,6 +41,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar optionsParser = Task.Options <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable (yes)/disable (no) colour output, or enable automatically iff stderr is a terminal device.") + <*> pure (Just Task.Warning) argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") From 10044e7dcc0899f34d1cdd75dda412c74acfc4d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:11:56 -0400 Subject: [PATCH 042/154] Align the actual values, not the default. --- src/SemanticCmdLine.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 5ebe57604..3dc96d17b 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -49,10 +49,10 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths")) diffArgumentsParser = runDiff - <$> ( flag (SomeRenderer PatchDiffRenderer) (SomeRenderer PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)") - <|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output a json diff") - <|> flag' (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree") - <|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output a table of contents for a diff") ) + <$> ( flag (SomeRenderer PatchDiffRenderer) (SomeRenderer PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)") + <|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output a json diff") + <|> flag' (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree") + <|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output a table of contents for a diff") ) <*> ( ((Right . pure) .) . both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B") @@ -61,8 +61,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)")) parseArgumentsParser = runParse <$> ( flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") - <|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees") - <|> flag' (SomeRenderer ToCTermRenderer) (long "toc" <> help "Output a table of contents for a file")) + <|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees") + <|> flag' (SomeRenderer ToCTermRenderer) (long "toc" <> help "Output a table of contents for a file")) <*> ( Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) ) From 5131ca98ffcf66cc878406bbb1dbdf45e71f96d0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:13:14 -0400 Subject: [PATCH 043/154] Show the valid values for options. --- src/SemanticCmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 3dc96d17b..d45310bcf 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -74,5 +74,5 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar _ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE") optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) - options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options)) + options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) findOption options value = maybe "" fst (find ((== value) . snd) options) From 1c7456571b524b846b6cf7186eb7eb9f4ca5db11 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:13:55 -0400 Subject: [PATCH 044/154] Better help text for --colour. --- src/SemanticCmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index d45310bcf..d6fed23d5 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -40,7 +40,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar description = fullDesc <> header "semantic -- Parse and diff semantically" optionsParser = Task.Options - <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable (yes)/disable (no) colour output, or enable automatically iff stderr is a terminal device.") + <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable, disable, or decide automatically iff stderr is a terminal device, whether to use colour.") <*> pure (Just Task.Warning) argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) From 323859d5854ca8c8827d12dd8830675093d7df17 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:15:56 -0400 Subject: [PATCH 045/154] Move the fields onto the next line. --- src/SemanticCmdLine.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index d6fed23d5..b724b4870 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -40,7 +40,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar description = fullDesc <> header "semantic -- Parse and diff semantically" optionsParser = Task.Options - <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable, disable, or decide automatically iff stderr is a terminal device, whether to use colour.") + <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] + (long "colour" <> long "color" <> value Nothing <> help "Enable, disable, or decide automatically iff stderr is a terminal device, whether to use colour.") <*> pure (Just Task.Warning) argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) From 07f10835433160ad9981fc4fcffff900b66b9ce0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 21 Jul 2017 16:17:17 -0400 Subject: [PATCH 046/154] Add a CLI flag for the log level, defaulting to warnings. --- src/SemanticCmdLine.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index b724b4870..9c1a81850 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -42,7 +42,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar optionsParser = Task.Options <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)] (long "colour" <> long "color" <> value Nothing <> help "Enable, disable, or decide automatically iff stderr is a terminal device, whether to use colour.") - <*> pure (Just Task.Warning) + <*> options [("error", Just Task.Error), ("warning", Just Task.Warning), ("info", Just Task.Info), ("debug", Just Task.Debug), ("none", Nothing)] + (long "log-level" <> value (Just Task.Warning) <> help "Log messages at or above this level, or disable logging entirely.") argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") From f3a780e3a9fbc7ab179ea6ac1ced0b68194ab984 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:22:42 -0400 Subject: [PATCH 047/154] Reformat the type signature for run. --- src/Data/Syntax/Assignment.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 171f22e54..b9130468b 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -264,7 +264,10 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) runAssignment source toNode = iterFreer run . fmap ((pure .) . (,)) - where run :: AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) + where run :: AssignmentF ast grammar x + -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) + -> AssignmentState ast grammar + -> Either (Error grammar) (a, AssignmentState ast grammar) run assignment yield initialState = case (assignment, stateNodes state) of (Location, node : _) -> yield (nodeLocation (toNode (F.project node))) state (Location, []) -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state From 4b28073c6e80b5e2dcf06eaaecddb49a98cae5d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:24:09 -0400 Subject: [PATCH 048/154] Pull the body of runAssignment into a worker function. --- src/Data/Syntax/Assignment.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index b9130468b..cf6a6cc49 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -263,8 +263,9 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> Assignment ast grammar a -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) -runAssignment source toNode = iterFreer run . fmap ((pure .) . (,)) - where run :: AssignmentF ast grammar x +runAssignment source toNode = go + where go = iterFreer run . fmap ((pure .) . (,)) + run :: AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) From cbed2b82a04f17757793680912a9411adc3bbf84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:28:45 -0400 Subject: [PATCH 049/154] run shadows the result type parameter. --- src/Data/Syntax/Assignment.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index cf6a6cc49..169240acf 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -265,7 +265,8 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> Either (Error grammar) (a, AssignmentState ast grammar) runAssignment source toNode = go where go = iterFreer run . fmap ((pure .) . (,)) - run :: AssignmentF ast grammar x + run :: forall a x + . AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) From ee66fc74bf5e07c38418030bf45e5a204d9384d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:28:59 -0400 Subject: [PATCH 050/154] runMany shadows the result type parameter. --- 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 169240acf..ff6eb77bf 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -297,7 +297,7 @@ runAssignment source toNode = go Choose choices -> choiceSymbols choices _ -> [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices - runMany :: Assignment ast grammar v -> AssignmentState ast grammar -> ([v], AssignmentState ast grammar) + runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) runMany rule state = case runAssignment source toNode rule state of Left err -> ([], state { stateError = Just err }) Right (a, state') | ((/=) `on` stateCounter) state state' -> From 37494f9c032f8b6ae9f95033bc20c89aaee63d47 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:29:12 -0400 Subject: [PATCH 051/154] go shadows the result type parameter. --- src/Data/Syntax/Assignment.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index ff6eb77bf..3dc55bac6 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -264,7 +264,8 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) runAssignment source toNode = go - where go = iterFreer run . fmap ((pure .) . (,)) + where go :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) + go = iterFreer run . fmap ((pure .) . (,)) run :: forall a x . AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) From 5b674d1940962f03415facd0e23167af8aae5280 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:29:41 -0400 Subject: [PATCH 052/154] runMany closes over the source and projection. --- 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 3dc55bac6..0df18a56b 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -299,7 +299,7 @@ runAssignment source toNode = go _ -> [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) - runMany rule state = case runAssignment source toNode rule state of + runMany rule state = case go rule state of Left err -> ([], state { stateError = Just err }) Right (a, state') | ((/=) `on` stateCounter) state state' -> let (as, state'') = runMany rule state' From a7a04ae3d38dffc885560ce83f9ef420a001f5f6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:32:51 -0400 Subject: [PATCH 053/154] :memo: the parameters to runAssignment. --- src/Data/Syntax/Assignment.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 0df18a56b..e96652c56 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -258,11 +258,11 @@ assignAllFrom source toNode assignment state = runAssignment source toNode assig -- | Run an assignment of nodes in a grammar onto terms in a syntax. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) - => Source.Source - -> (forall x. Base ast x -> Node grammar) - -> Assignment ast grammar a - -> AssignmentState ast grammar - -> Either (Error grammar) (a, AssignmentState ast grammar) + => Source.Source -- ^ The source for the parse tree. + -> (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. + -> Assignment ast grammar a -- ^ The 'Assignment' to run. + -> AssignmentState ast grammar -- ^ The current state. + -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. runAssignment source toNode = go where go :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) go = iterFreer run . fmap ((pure .) . (,)) From fab398e0897dfba2c0d1e83444fe6f9f5980a7fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:34:40 -0400 Subject: [PATCH 054/154] Pull runMany out of run. --- src/Data/Syntax/Assignment.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index e96652c56..f1e359b98 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -298,14 +298,14 @@ runAssignment source toNode = go Choose choices -> choiceSymbols choices _ -> [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices - runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) - runMany rule state = case go rule state of - Left err -> ([], state { stateError = Just err }) - Right (a, state') | ((/=) `on` stateCounter) state state' -> - let (as, state'') = runMany rule state' - in as `seq` (a : as, state'') - | otherwise -> ([a], state') {-# INLINE run #-} + runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) + runMany rule state = case go rule state of + Left err -> ([], state { stateError = Just err }) + Right (a, state') | ((/=) `on` stateCounter) state state' -> + let (as, state'') = runMany rule state' + in as `seq` (a : as, state'') + | otherwise -> ([a], state') dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar dropAnonymous toNode state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } From 2b72ca3a8a74902043b16a1ea0be218dc3215417 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:34:43 -0400 Subject: [PATCH 055/154] Inline runMany. --- 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 f1e359b98..d8913beb5 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -306,6 +306,7 @@ runAssignment source toNode = go let (as, state'') = runMany rule state' in as `seq` (a : as, state'') | otherwise -> ([a], state') + {-# INLINE runMany #-} dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar dropAnonymous toNode state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } From 15b7735874c96c8b8c0b43d3d4f94ba3dfffee98 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:38:16 -0400 Subject: [PATCH 056/154] Define assignAllFrom using do-notation. --- 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 d8913beb5..a1f7ed41d 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -249,12 +249,12 @@ assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Folda -> Assignment ast grammar a -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) -assignAllFrom source toNode assignment state = runAssignment source toNode assignment state >>= go - where - go (a, state) = case stateNodes (dropAnonymous toNode state) of - [] -> Right (a, state) - node : _ -> let Node nodeSymbol _ (Info.Span spanStart _) = toNode (F.project node) in - Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) +assignAllFrom source toNode assignment state = do + (a, state) <- runAssignment source toNode assignment state + case stateNodes (dropAnonymous toNode state) of + [] -> Right (a, state) + node : _ -> let Node nodeSymbol _ (Info.Span spanStart _) = toNode (F.project node) in + Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) -- | Run an assignment of nodes in a grammar onto terms in a syntax. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) From 07b132e631efe6b2939e7eeff55d4638f198de2f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:44:51 -0400 Subject: [PATCH 057/154] Define a combinator requiring exhaustiveness. --- src/Data/Syntax/Assignment.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index a1f7ed41d..602e32062 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -308,6 +308,13 @@ runAssignment source toNode = go | otherwise -> ([a], state') {-# INLINE runMany #-} +requireExhaustive :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> (a, AssignmentState ast grammar) -> Either (Error grammar) (a, AssignmentState ast grammar) +requireExhaustive toNode (a, state) = case stateNodes (dropAnonymous toNode state) of + [] -> Right (a, state) + node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- toNode (F.project node) -> + Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) + + dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar dropAnonymous toNode state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } From 353847c5e39ffbcce2f4551b8b9a57f7d453bbe6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:45:50 -0400 Subject: [PATCH 058/154] Recur and then require exhaustiveness. --- 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 602e32062..a020471f5 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -277,7 +277,7 @@ runAssignment source toNode = go (Project projection, node : _) -> yield (projection (F.project node)) state (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState toNode state) (Children childAssignment, node : _) -> do - (a, state') <- assignAllFrom source toNode childAssignment state { stateNodes = toList (F.project node) } + (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive toNode yield a (advanceState toNode state' { stateNodes = stateNodes state }) (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state (Many rule, _) -> uncurry yield (runMany rule state) From 0666ea03feb67901007dc9df6818fe3b4453a4ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:46:54 -0400 Subject: [PATCH 059/154] Define assignBy in terms of runAssignment & requireExhaustive. --- 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 a020471f5..5c089ba2f 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -241,7 +241,7 @@ assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable ( -> Source.Source -> ast -> Either (Error grammar) a -assignBy toNode assignment source = fmap fst . assignAllFrom source toNode assignment . makeState . pure +assignBy toNode assignment source = fmap fst . (>>= requireExhaustive toNode) . runAssignment source toNode assignment . makeState . pure assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => Source.Source From 9822c85709b3685efd83407c7244ee54c1ca7e2a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:47:08 -0400 Subject: [PATCH 060/154] :fire: assignAllFrom. --- src/Data/Syntax/Assignment.hs | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 5c089ba2f..44634d569 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -243,19 +243,6 @@ assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable ( -> Either (Error grammar) a assignBy toNode assignment source = fmap fst . (>>= requireExhaustive toNode) . runAssignment source toNode assignment . makeState . pure -assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) - => Source.Source - -> (forall x. Base ast x -> Node grammar) - -> Assignment ast grammar a - -> AssignmentState ast grammar - -> Either (Error grammar) (a, AssignmentState ast grammar) -assignAllFrom source toNode assignment state = do - (a, state) <- runAssignment source toNode assignment state - case stateNodes (dropAnonymous toNode state) of - [] -> Right (a, state) - node : _ -> let Node nodeSymbol _ (Info.Span spanStart _) = toNode (F.project node) in - Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) - -- | Run an assignment of nodes in a grammar onto terms in a syntax. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => Source.Source -- ^ The source for the parse tree. From 8a1a027e229ce11be5733fe23c0e32652922de83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:47:36 -0400 Subject: [PATCH 061/154] :fire: assign. --- src/Data/Syntax/Assignment.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 44634d569..4f6210311 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -79,7 +79,6 @@ module Data.Syntax.Assignment , printError , withSGRCode -- Running -, assign , assignBy , runAssignment -- Implementation details (for testing) @@ -228,13 +227,6 @@ showPos :: Maybe FilePath -> Info.Pos -> ShowS showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . shows posLine . showChar ':' . shows posColumn -- | Run an assignment over an AST exhaustively. -assign :: (HasField fields Info.Range, HasField fields Info.Span, HasField fields grammar, Symbol grammar, Enum grammar, Eq grammar, Traversable f, HasCallStack) - => Assignment (Cofree f (Record fields)) grammar a - -> Source.Source - -> Cofree f (Record fields) - -> Either (Error grammar) a -assign = assignBy (\ (r :< _) -> Node (getField r) (getField r) (getField r)) - assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) -> Assignment ast grammar a From 4eabcf9cfc0607887cc5018747c1ad3a9d26cddf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:50:31 -0400 Subject: [PATCH 062/154] Reformat the type signature for go. --- src/Data/Syntax/Assignment.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 4f6210311..44950c072 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -243,7 +243,10 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> AssignmentState ast grammar -- ^ The current state. -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. runAssignment source toNode = go - where go :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) + where go :: forall a + . Assignment ast grammar a + -> AssignmentState ast grammar + -> Either (Error grammar) (a, AssignmentState ast grammar) go = iterFreer run . fmap ((pure .) . (,)) run :: forall a x . AssignmentF ast grammar x From a1d03bb6cc777fd769653a8dbb880e4ed3433a3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:56:56 -0400 Subject: [PATCH 063/154] Inline go. --- 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 44950c072..8bf627ba1 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -248,6 +248,7 @@ runAssignment source toNode = go -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) go = iterFreer run . fmap ((pure .) . (,)) + {-# INLINE go #-} run :: forall a x . AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) From d464da8089fc464a26e94807e24b63d397c80691 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 13:59:45 -0400 Subject: [PATCH 064/154] runAssignment is exhaustive. --- src/Data/Syntax/Assignment.hs | 19 +++++++++---------- test/Data/Syntax/Assignment/Spec.hs | 3 +-- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 8bf627ba1..699ce1689 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -233,16 +233,16 @@ assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable ( -> Source.Source -> ast -> Either (Error grammar) a -assignBy toNode assignment source = fmap fst . (>>= requireExhaustive toNode) . runAssignment source toNode assignment . makeState . pure +assignBy toNode assignment source = fmap fst . runAssignment source toNode assignment . makeState . pure --- | Run an assignment of nodes in a grammar onto terms in a syntax. +-- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => Source.Source -- ^ The source for the parse tree. -> (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. -> Assignment ast grammar a -- ^ The 'Assignment' to run. -> AssignmentState ast grammar -- ^ The current state. -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. -runAssignment source toNode = go +runAssignment source toNode assignment state = go assignment state >>= requireExhaustive where go :: forall a . Assignment ast grammar a -> AssignmentState ast grammar @@ -260,7 +260,7 @@ runAssignment source toNode = go (Project projection, node : _) -> yield (projection (F.project node)) state (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState toNode state) (Children childAssignment, node : _) -> do - (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive toNode + (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive yield a (advanceState toNode state' { stateNodes = stateNodes state }) (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state (Many rule, _) -> uncurry yield (runMany rule state) @@ -290,12 +290,11 @@ runAssignment source toNode = go in as `seq` (a : as, state'') | otherwise -> ([a], state') {-# INLINE runMany #-} - -requireExhaustive :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> (a, AssignmentState ast grammar) -> Either (Error grammar) (a, AssignmentState ast grammar) -requireExhaustive toNode (a, state) = case stateNodes (dropAnonymous toNode state) of - [] -> Right (a, state) - node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- toNode (F.project node) -> - Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) + requireExhaustive :: forall a. (a, AssignmentState ast grammar) -> Either (Error grammar) (a, AssignmentState ast grammar) + requireExhaustive (a, state) = case stateNodes (dropAnonymous toNode state) of + [] -> Right (a, state) + node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- toNode (F.project node) -> + Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 8f2d0083c..5401fcfad 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -41,8 +41,7 @@ spec = do fst <$> runAssignment "hello" headF red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello") it "does not advance past the current node" $ - let initialState = makeState [ node Red 0 2 [] ] in - snd <$> runAssignment "hi" headF (symbol Red) initialState `shouldBe` Right initialState + runAssignment "hi" headF (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) (UnexpectedSymbol [] Red)) describe "without catchError" $ do it "assignment returns UnexpectedSymbol" $ From 455f9129411633093d6f533d2486cf2505c50ff2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:04:52 -0400 Subject: [PATCH 065/154] Swap the order of the projection & source. --- src/Data/Syntax/Assignment.hs | 8 ++--- test/Data/Syntax/Assignment/Spec.hs | 54 ++++++++++++++--------------- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 699ce1689..9df72368a 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -233,16 +233,16 @@ assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable ( -> Source.Source -> ast -> Either (Error grammar) a -assignBy toNode assignment source = fmap fst . runAssignment source toNode assignment . makeState . pure +assignBy toNode assignment source = fmap fst . runAssignment toNode source assignment . makeState . pure -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) - => Source.Source -- ^ The source for the parse tree. - -> (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. + => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. + -> Source.Source -- ^ The source for the parse tree. -> Assignment ast grammar a -- ^ The 'Assignment' to run. -> AssignmentState ast grammar -- ^ The current state. -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. -runAssignment source toNode assignment state = go assignment state >>= requireExhaustive +runAssignment toNode source assignment state = go assignment state >>= requireExhaustive where go :: forall a . Assignment ast grammar a -> AssignmentState ast grammar diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 5401fcfad..bc4775034 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -13,13 +13,13 @@ spec :: Spec spec = do describe "Applicative" $ it "matches in sequence" $ - fst <$> runAssignment "helloworld" headF ((,) <$> red <*> red) (makeState [node Red 0 5 [], node Red 5 10 []]) + fst <$> runAssignment headF "helloworld" ((,) <$> red <*> red) (makeState [node Red 0 5 [], node Red 5 10 []]) `shouldBe` Right (Out "hello", Out "world") describe "Alternative" $ do it "attempts multiple alternatives" $ - fst <$> runAssignment "hello" headF (green <|> red) (makeState [node Red 0 5 []]) + fst <$> runAssignment headF "hello" (green <|> red) (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello") @@ -27,32 +27,32 @@ spec = do let s = "colourless green ideas sleep furiously" w = words s (_, nodes) = foldl (\ (i, prev) word -> (i + B.length word + 1, prev <> [node Red i (i + B.length word) []])) (0, []) w in - fst <$> runAssignment (fromBytes s) headF (many red) (makeState nodes) + fst <$> runAssignment headF (fromBytes s) (many red) (makeState nodes) `shouldBe` Right (Out <$> w) it "matches one-or-more repetitions against one or more input nodes" $ - fst <$> runAssignment "hello" headF (some red) (makeState [node Red 0 5 []]) + fst <$> runAssignment headF "hello" (some red) (makeState [node Red 0 5 []]) `shouldBe` Right [Out "hello"] describe "symbol" $ do it "matches nodes with the same symbol" $ - fst <$> runAssignment "hello" headF red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello") + fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello") it "does not advance past the current node" $ - runAssignment "hi" headF (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) (UnexpectedSymbol [] Red)) + runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) (UnexpectedSymbol [] Red)) describe "without catchError" $ do it "assignment returns UnexpectedSymbol" $ - runAssignment "A" headF + runAssignment headF "A" red (makeState [node Green 0 1 []]) `shouldBe` Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green)) it "assignment returns UnexpectedEndOfInput" $ - runAssignment "A" headF + runAssignment headF "A" (symbol Green *> children (some red)) (makeState [node Green 0 1 []]) `shouldBe` @@ -60,21 +60,21 @@ spec = do describe "catchError" $ do it "handler that always matches" $ - fst <$> runAssignment "A" headF + fst <$> runAssignment headF "A" (red `catchError` (\ _ -> OutError <$ location <*> source)) (makeState [node Green 0 1 []]) `shouldBe` Right (OutError "A") it "handler that matches" $ - fst <$> runAssignment "A" headF + fst <$> runAssignment headF "A" (red `catchError` const green) (makeState [node Green 0 1 []]) `shouldBe` Right (Out "A") it "handler that doesn't match produces error" $ - runAssignment "A" headF + runAssignment headF "A" (red `catchError` const blue) (makeState [node Green 0 1 []]) `shouldBe` @@ -82,7 +82,7 @@ spec = do describe "in many" $ do it "handler that always matches" $ - fst <$> runAssignment "PG" headF + fst <$> runAssignment headF "PG" (symbol Palette *> children ( many (red `catchError` (\ _ -> OutError <$ location <*> source)) )) @@ -91,21 +91,21 @@ spec = do Right [OutError "G"] it "handler that matches" $ - fst <$> runAssignment "PG" headF + fst <$> runAssignment headF "PG" (symbol Palette *> children ( many (red `catchError` const green) )) (makeState [node Palette 0 1 [node Green 1 2 []]]) `shouldBe` Right [Out "G"] it "handler that doesn't match produces error" $ - runAssignment "PG" headF + runAssignment headF "PG" (symbol Palette *> children ( many (red `catchError` const blue) )) (makeState [node Palette 0 1 [node Green 1 2 []]]) `shouldBe` Left (Error (Info.Pos 1 2) (UnexpectedSymbol [Blue] Green)) it "handler that always matches with apply consumes and then errors" $ - runAssignment "PG" headF + runAssignment headF "PG" (symbol Palette *> children ( (,) <$> many (red `catchError` (\ _ -> OutError <$ location <*> source)) <*> green )) @@ -114,7 +114,7 @@ spec = do Left (Error (Info.Pos 1 3) (UnexpectedEndOfInput [Green])) it "handler that doesn't match with apply" $ - fst <$> runAssignment "PG" headF + fst <$> runAssignment headF "PG" (symbol Palette *> children ( (,) <$> many (red `catchError` const blue) <*> green )) @@ -124,7 +124,7 @@ spec = do describe "many" $ do it "takes ones and only one zero width repetition" $ - fst <$> runAssignment "PGG" headF + fst <$> runAssignment headF "PGG" (symbol Palette *> children ( many (green <|> pure (Out "always")) )) (makeState [node Palette 0 1 [node Green 1 2 [], node Green 2 3 []]]) `shouldBe` @@ -135,35 +135,35 @@ spec = do assignBy headF source "hi" (node Red 0 2 []) `shouldBe` Right "hi" it "advances past the current node" $ - snd <$> runAssignment "hi" headF source (makeState [ node Red 0 2 [] ]) + snd <$> runAssignment headF "hi" source (makeState [ node Red 0 2 [] ]) `shouldBe` Right (AssignmentState 2 (Info.Pos 1 3) Nothing 1 []) describe "children" $ do it "advances past the current node" $ - snd <$> runAssignment "a" headF (children (pure (Out ""))) (makeState [node Red 0 1 []]) + snd <$> runAssignment headF "a" (children (pure (Out ""))) (makeState [node Red 0 1 []]) `shouldBe` Right (AssignmentState 1 (Info.Pos 1 2) Nothing 1 []) it "matches if its subrule matches" $ - () <$ runAssignment "a" headF (children red) (makeState [node Blue 0 1 [node Red 0 1 []]]) + () <$ runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Red 0 1 []]]) `shouldBe` Right () it "does not match if its subrule does not match" $ - runAssignment "a" headF (children red) (makeState [node Blue 0 1 [node Green 0 1 []]]) + runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Green 0 1 []]]) `shouldBe` Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green)) it "matches nested children" $ - fst <$> runAssignment "1" headF + fst <$> runAssignment headF "1" (symbol Red *> children (symbol Green *> children (symbol Blue *> source))) (makeState [ node Red 0 1 [ node Green 0 1 [ node Blue 0 1 [] ] ] ]) `shouldBe` Right "1" it "continues after children" $ - fst <$> runAssignment "BC" headF + fst <$> runAssignment headF "BC" (many (symbol Red *> children (symbol Green *> source) <|> symbol Blue *> source)) (makeState [ node Red 0 1 [ node Green 0 1 [] ] @@ -172,7 +172,7 @@ spec = do Right ["B", "C"] it "matches multiple nested children" $ - fst <$> runAssignment "12" headF + fst <$> runAssignment headF "12" (symbol Red *> children (many (symbol Green *> children (symbol Blue *> source)))) (makeState [ node Red 0 2 [ node Green 0 1 [ node Blue 0 1 [] ] , node Green 1 2 [ node Blue 1 2 [] ] ] ]) @@ -181,17 +181,17 @@ spec = do describe "runAssignment" $ do it "drops anonymous nodes before matching symbols" $ - fst <$> runAssignment "magenta red" headF red (makeState [node Magenta 0 7 [], node Red 8 11 []]) + fst <$> runAssignment headF "magenta red" red (makeState [node Magenta 0 7 [], node Red 8 11 []]) `shouldBe` Right (Out "red") it "does not drop anonymous nodes after matching" $ - stateNodes . snd <$> runAssignment "red magenta" headF red (makeState [node Red 0 3 [], node Magenta 4 11 []]) + stateNodes . snd <$> runAssignment headF "red magenta" red (makeState [node Red 0 3 [], node Magenta 4 11 []]) `shouldBe` Right [node Magenta 4 11 []] it "does not drop anonymous nodes when requested" $ - fst <$> runAssignment "magenta red" headF ((,) <$> magenta <*> red) (makeState [node Magenta 0 7 [], node Red 8 11 []]) + fst <$> runAssignment headF "magenta red" ((,) <$> magenta <*> red) (makeState [node Magenta 0 7 [], node Red 8 11 []]) `shouldBe` Right (Out "magenta", Out "red") From 83a0d9c60edd6c0566394c210f57a71ad8f4c32f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:06:07 -0400 Subject: [PATCH 066/154] Swap the order of the source & assignment. --- src/Data/Syntax/Assignment.hs | 4 ++-- src/Parser.hs | 2 +- test/Data/Syntax/Assignment/Spec.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 9df72368a..0f8f552bc 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -229,11 +229,11 @@ showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) sh -- | Run an assignment over an AST exhaustively. assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) - -> Assignment ast grammar a -> Source.Source + -> Assignment ast grammar a -> ast -> Either (Error grammar) a -assignBy toNode assignment source = fmap fst . runAssignment toNode source assignment . makeState . pure +assignBy toNode source assignment = fmap fst . runAssignment toNode source assignment . makeState . pure -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) diff --git a/src/Parser.hs b/src/Parser.hs index 658958b03..bffcec270 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -85,7 +85,7 @@ runParser parser blob@Blob{..} = case parser of ASTParser language -> parseToAST language blobSource AssignmentParser parser by assignment -> do ast <- runParser parser blob - case assignBy by assignment blobSource ast of + case assignBy by blobSource assignment ast of Left err -> do printError blob err pure (errorTerm blobSource) diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index bc4775034..86ff16d8a 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -132,7 +132,7 @@ spec = do describe "source" $ do it "produces the node’s source" $ - assignBy headF source "hi" (node Red 0 2 []) `shouldBe` Right "hi" + assignBy headF "hi" source (node Red 0 2 []) `shouldBe` Right "hi" it "advances past the current node" $ snd <$> runAssignment headF "hi" source (makeState [ node Red 0 2 [] ]) From 53bb412fd3b97269d973315ba9f86b7d0f8ebf07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:06:44 -0400 Subject: [PATCH 067/154] Align the arguments with the ::. --- src/Data/Syntax/Assignment.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 0f8f552bc..46bad9a22 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -228,20 +228,20 @@ showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) sh -- | Run an assignment over an AST exhaustively. assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) - => (forall x. Base ast x -> Node grammar) - -> Source.Source - -> Assignment ast grammar a - -> ast - -> Either (Error grammar) a + => (forall x. Base ast x -> Node grammar) + -> Source.Source + -> Assignment ast grammar a + -> ast + -> Either (Error grammar) a assignBy toNode source assignment = fmap fst . runAssignment toNode source assignment . makeState . pure -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) - => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. - -> Source.Source -- ^ The source for the parse tree. - -> Assignment ast grammar a -- ^ The 'Assignment' to run. - -> AssignmentState ast grammar -- ^ The current state. - -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. + => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. + -> Source.Source -- ^ The source for the parse tree. + -> Assignment ast grammar a -- ^ The 'Assignment' to run. + -> AssignmentState ast grammar -- ^ The current state. + -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. runAssignment toNode source assignment state = go assignment state >>= requireExhaustive where go :: forall a . Assignment ast grammar a From b9353f0d1522b64165040d3cb3bb8ccf547d864c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:07:58 -0400 Subject: [PATCH 068/154] :memo: the arguments to assignBy. --- src/Data/Syntax/Assignment.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 46bad9a22..c49d410b6 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -228,11 +228,11 @@ showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) sh -- | Run an assignment over an AST exhaustively. assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) - => (forall x. Base ast x -> Node grammar) - -> Source.Source - -> Assignment ast grammar a - -> ast - -> Either (Error grammar) a + => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. + -> Source.Source -- ^ The source for the parse tree. + -> Assignment ast grammar a -- ^ The 'Assignment to run. + -> ast -- ^ The root of the ast. + -> Either (Error grammar) a -- ^ 'Either' an 'Error' or the assigned value. assignBy toNode source assignment = fmap fst . runAssignment toNode source assignment . makeState . pure -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. From fd20883532080aca95f287274efb243a82da44ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:09:13 -0400 Subject: [PATCH 069/154] :memo: stateError. --- src/Data/Syntax/Assignment.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index c49d410b6..fac253448 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -312,11 +312,11 @@ advanceState toNode state@AssignmentState{..} -- | State kept while running 'Assignment's. data AssignmentState ast grammar = AssignmentState - { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes. - , statePos :: Info.Pos -- ^ The (1-indexed) line/column position in the Source thus far reached. - , stateError :: Maybe (Error grammar) - , stateCounter :: Int -- ^ Always incrementing counter that tracks how many nodes have been visited. - , stateNodes :: [ast] -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.” + { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes. + , statePos :: Info.Pos -- ^ The (1-indexed) line/column position in the Source thus far reached. + , stateError :: Maybe (Error grammar) -- ^ The most recently encountered error. Preserved for improved error messages in the presence of backtracking. + , stateCounter :: Int -- ^ Always incrementing counter that tracks how many nodes have been visited. + , stateNodes :: [ast] -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.” } deriving (Eq, Show) From 48cfac86f2ee32424de6f884da77081f15a1d571 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:10:56 -0400 Subject: [PATCH 070/154] Tighten up how catching is run. --- src/Data/Syntax/Assignment.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index fac253448..9a1648261 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -269,9 +269,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Left err -> yield b state { stateError = Just err } r -> r (Throw e, _) -> Left e - (Catch during handler, _) -> case yield during state of - Left err -> yield (handler err) state - Right (a, state') -> Right (a, state') + (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) where state = case assignment of From b97deff73136763ea39930c6794bb3c7dc99daef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:12:04 -0400 Subject: [PATCH 071/154] Tighten up how alternations are run. --- src/Data/Syntax/Assignment.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 9a1648261..1ee645645 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -265,9 +265,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a 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, _) -> case yield a state of - Left err -> yield b state { stateError = Just err } - r -> r + (Alt a b, _) -> either (\ err -> yield b state { stateError = Just err }) Right (yield a state) (Throw e, _) -> Left e (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) From 346d87b572bfddde8d72cf491a63426d413e83aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:23:01 -0400 Subject: [PATCH 072/154] Tighten up the computation of the starting state. --- src/Data/Syntax/Assignment.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 1ee645645..1d6bfe442 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -270,9 +270,8 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) - where state = case assignment of - Choose choices | all ((== Regular) . symbolType) (choiceSymbols choices) -> dropAnonymous toNode initialState - _ -> initialState + where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous toNode initialState + | otherwise = initialState expectedSymbols = case assignment of Choose choices -> choiceSymbols choices _ -> [] From 8404b320b659e060888cf38c4116e5bdb7e926d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:23:38 -0400 Subject: [PATCH 073/154] Define expectedSymbols with guard clauses. --- src/Data/Syntax/Assignment.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 1d6bfe442..c2d069ac8 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -272,9 +272,8 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous toNode initialState | otherwise = initialState - expectedSymbols = case assignment of - Choose choices -> choiceSymbols choices - _ -> [] + expectedSymbols | Choose choices <- assignment = choiceSymbols choices + | otherwise = [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices {-# INLINE run #-} runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) From 8be255dfd730d979cb7c1fccd3563eb06ca63535 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:24:43 -0400 Subject: [PATCH 074/154] Define dropAnonymous closed over the projection. --- src/Data/Syntax/Assignment.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index c2d069ac8..ae8c59785 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -270,7 +270,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) - where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous toNode initialState + where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] @@ -285,14 +285,12 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx | otherwise -> ([a], state') {-# INLINE runMany #-} requireExhaustive :: forall a. (a, AssignmentState ast grammar) -> Either (Error grammar) (a, AssignmentState ast grammar) - requireExhaustive (a, state) = case stateNodes (dropAnonymous toNode state) of + requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- toNode (F.project node) -> Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) - -dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar -dropAnonymous toNode state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } + dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } -- | Advances the state past the current (head) node (if any), dropping it off -- stateNodes & its corresponding bytes off of source, and updating stateOffset & From 9bac6005968cebafa8e02409705ef2204f8dd10c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:27:46 -0400 Subject: [PATCH 075/154] Define advanceState closed over the projection. --- src/Data/Syntax/Assignment.hs | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index ae8c59785..169c2aee0 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -258,10 +258,10 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (Location, node : _) -> yield (nodeLocation (toNode (F.project node))) state (Location, []) -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state (Project projection, node : _) -> yield (projection (F.project node)) state - (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState toNode state) + (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState state) (Children childAssignment, node : _) -> do (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive - yield a (advanceState toNode state' { stateNodes = stateNodes state }) + yield a (advanceState state' { stateNodes = stateNodes state }) (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a 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. @@ -292,15 +292,11 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } --- | Advances the state past the current (head) node (if any), dropping it off --- stateNodes & its corresponding bytes off of source, and updating stateOffset & --- statePos to its end. Exhausted 'AssignmentState's (those without any --- remaining nodes) are returned unchanged. -advanceState :: Recursive ast => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar -advanceState toNode state@AssignmentState{..} - | node : rest <- stateNodes - , Node{..} <- toNode (F.project node) = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest - | otherwise = state + -- Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged. + advanceState state@AssignmentState{..} + | node : rest <- stateNodes + , Node{..} <- toNode (F.project node) = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest + | otherwise = state -- | State kept while running 'Assignment's. data AssignmentState ast grammar = AssignmentState From e8afa8817e75d84f85e04a0a21e89de957cb9034 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:34:04 -0400 Subject: [PATCH 076/154] Preserve backtracking errors via a setter. --- src/Data/Syntax/Assignment.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 169c2aee0..c5655fac8 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -265,7 +265,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a 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, _) -> either (\ err -> yield b state { stateError = Just err }) Right (yield a state) + (Alt a b, _) -> either (yield b . setStateError state . Just) Right (yield a state) (Throw e, _) -> Left e (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) @@ -311,6 +311,9 @@ data AssignmentState ast grammar = AssignmentState makeState :: [ast] -> AssignmentState ast grammar makeState = AssignmentState 0 (Info.Pos 1 1) Nothing 0 +setStateError :: AssignmentState ast grammar -> Maybe (Error grammar) -> AssignmentState ast grammar +setStateError state error = state { stateError = error } + -- Instances From dc9bfe28d17502fc5744fa2078397193b427a800 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:41:58 -0400 Subject: [PATCH 077/154] Combine the rules for Location assignments. --- src/Data/Syntax/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index c5655fac8..7edb82b8a 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -255,8 +255,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) run assignment yield initialState = case (assignment, stateNodes state) of - (Location, node : _) -> yield (nodeLocation (toNode (F.project node))) state - (Location, []) -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state + (Location, _) -> yield location state (Project projection, node : _) -> yield (projection (F.project node)) state (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState state) (Children childAssignment, node : _) -> do @@ -275,6 +274,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices + location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . toNode . F.project) (listToMaybe (stateNodes state)) {-# INLINE run #-} runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) runMany rule state = case go rule state of From 11e83f0413edd1bdc891daffc57ba7d22cc89498 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:49:14 -0400 Subject: [PATCH 078/154] Define the error cases with guard clauses. --- src/Data/Syntax/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 7edb82b8a..00ced2fbb 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -267,8 +267,8 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (Alt a b, _) -> either (yield b . setStateError state . Just) Right (yield a state) (Throw e, _) -> Left e (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) - (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) - (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) + _ | node : _ <- stateNodes state, Node symbol _ (Info.Span spanStart _) <- toNode (F.project node) -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) + | otherwise -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices From 140b5cf49bc7bf06500573a42852955edfb6c5c3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:50:26 -0400 Subject: [PATCH 079/154] Simplify how the node is projected out. --- 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 00ced2fbb..42da55f46 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -267,7 +267,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (Alt a b, _) -> either (yield b . setStateError state . Just) Right (yield a state) (Throw e, _) -> Left e (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) - _ | node : _ <- stateNodes state, Node symbol _ (Info.Span spanStart _) <- toNode (F.project node) -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) + _ | Node symbol _ (Info.Span spanStart _) : _ <- toNode . F.project <$> stateNodes state -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) | otherwise -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState From f628d22aee4844c4c8d102a9106fb7e3a83e81c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:52:34 -0400 Subject: [PATCH 080/154] Match the head node with guard clauses. --- src/Data/Syntax/Assignment.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 42da55f46..31d569241 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -254,19 +254,19 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) - run assignment yield initialState = case (assignment, stateNodes state) of - (Location, _) -> yield location state - (Project projection, node : _) -> yield (projection (F.project node)) state - (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState state) - (Children childAssignment, node : _) -> do + run assignment yield initialState = case assignment of + Location -> yield location state + Project projection | node : _ <- stateNodes state -> yield (projection (F.project node)) state + Source | node : _ <- stateNodes state -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState state) + Children childAssignment | node : _ <- stateNodes state -> do (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive yield a (advanceState state' { stateNodes = stateNodes state }) - (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state - (Many rule, _) -> uncurry yield (runMany rule state) + Choose choices | Node symbol _ _ : _ <- toNode . F.project <$> stateNodes state, Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a 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, _) -> either (yield b . setStateError state . Just) Right (yield a state) - (Throw e, _) -> Left e - (Catch during handler, _) -> either (flip yield state . handler) Right (yield during state) + Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) + Throw e -> Left e + Catch during handler -> either (flip yield state . handler) Right (yield during state) _ | Node symbol _ (Info.Span spanStart _) : _ <- toNode . F.project <$> stateNodes state -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) | otherwise -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState From 40313b598fd5af2585ea39f357f89e2314f85d00 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 14:56:19 -0400 Subject: [PATCH 081/154] Simplify the chain for choices. --- 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 31d569241..e11a8159e 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -261,7 +261,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Children childAssignment | node : _ <- stateNodes state -> do (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive yield a (advanceState state' { stateNodes = stateNodes state }) - Choose choices | Node symbol _ _ : _ <- toNode . F.project <$> stateNodes state, Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state + Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . toNode . F.project =<< listToMaybe (stateNodes state) -> yield choice 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 -> either (yield b . setStateError state . Just) Right (yield a state) From 1d8c4fdeea2d79d01fde7011307260fbf931b018 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:01:29 -0400 Subject: [PATCH 082/154] Define a helper to project nodes. --- src/Data/Syntax/Assignment.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index e11a8159e..6d6f82a7b 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -257,24 +257,24 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx run assignment yield initialState = case assignment of Location -> yield location state Project projection | node : _ <- stateNodes state -> yield (projection (F.project node)) state - Source | node : _ <- stateNodes state -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState state) + Source | node : _ <- stateNodes state -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advanceState state) Children childAssignment | node : _ <- stateNodes state -> do (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive yield a (advanceState state' { stateNodes = stateNodes state }) - Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . toNode . F.project =<< listToMaybe (stateNodes state) -> yield choice state + Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< listToMaybe (stateNodes state) -> yield choice 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 -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ | Node symbol _ (Info.Span spanStart _) : _ <- toNode . F.project <$> stateNodes state -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) + _ | Node symbol _ (Info.Span spanStart _) : _ <- projectNode <$> stateNodes state -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) | otherwise -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices - location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . toNode . F.project) (listToMaybe (stateNodes state)) + location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) (listToMaybe (stateNodes state)) {-# INLINE run #-} runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) runMany rule state = case go rule state of @@ -287,17 +287,19 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx requireExhaustive :: forall a. (a, AssignmentState ast grammar) -> Either (Error grammar) (a, AssignmentState ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) - node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- toNode (F.project node) -> + node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- projectNode node -> Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) - dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } + dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } -- Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged. advanceState state@AssignmentState{..} | node : rest <- stateNodes - , Node{..} <- toNode (F.project node) = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest + , Node{..} <- projectNode node = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest | otherwise = state + projectNode = toNode . F.project + -- | State kept while running 'Assignment's. data AssignmentState ast grammar = AssignmentState { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes. From 8062a7aad4a2690eaa7e5cc2aad3ba6c9ddb05aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:02:17 -0400 Subject: [PATCH 083/154] Spacing. --- src/Data/Syntax/Assignment.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 6d6f82a7b..980042599 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -249,6 +249,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> Either (Error grammar) (a, AssignmentState ast grammar) go = iterFreer run . fmap ((pure .) . (,)) {-# INLINE go #-} + run :: forall a x . AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) @@ -276,6 +277,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) (listToMaybe (stateNodes state)) {-# INLINE run #-} + runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) runMany rule state = case go rule state of Left err -> ([], state { stateError = Just err }) @@ -284,6 +286,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx in as `seq` (a : as, state'') | otherwise -> ([a], state') {-# INLINE runMany #-} + requireExhaustive :: forall a. (a, AssignmentState ast grammar) -> Either (Error grammar) (a, AssignmentState ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) From 6a80c9dae9f160c34238aa1ad8c2b8ea4f7b4052 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:03:58 -0400 Subject: [PATCH 084/154] :fire: some unneccessary quantifiers. --- src/Data/Syntax/Assignment.hs | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 980042599..e6de7860d 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -243,18 +243,14 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> AssignmentState ast grammar -- ^ The current state. -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. runAssignment toNode source assignment state = go assignment state >>= requireExhaustive - where go :: forall a - . Assignment ast grammar a - -> AssignmentState ast grammar - -> Either (Error grammar) (a, AssignmentState ast grammar) + where go :: Assignment ast grammar result -> AssignmentState ast grammar -> Either (Error grammar) (result, AssignmentState ast grammar) go = iterFreer run . fmap ((pure .) . (,)) {-# INLINE go #-} - - run :: forall a x - . AssignmentF ast grammar x - -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) + + run :: AssignmentF ast grammar x + -> (x -> AssignmentState ast grammar -> Either (Error grammar) (result, AssignmentState ast grammar)) -> AssignmentState ast grammar - -> Either (Error grammar) (a, AssignmentState ast grammar) + -> Either (Error grammar) (result, AssignmentState ast grammar) run assignment yield initialState = case assignment of Location -> yield location state Project projection | node : _ <- stateNodes state -> yield (projection (F.project node)) state @@ -278,7 +274,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) (listToMaybe (stateNodes state)) {-# INLINE run #-} - runMany :: forall a. Assignment ast grammar a -> AssignmentState ast grammar -> ([a], AssignmentState ast grammar) + runMany :: Assignment ast grammar result -> AssignmentState ast grammar -> ([result], AssignmentState ast grammar) runMany rule state = case go rule state of Left err -> ([], state { stateError = Just err }) Right (a, state') | ((/=) `on` stateCounter) state state' -> @@ -287,7 +283,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx | otherwise -> ([a], state') {-# INLINE runMany #-} - requireExhaustive :: forall a. (a, AssignmentState ast grammar) -> Either (Error grammar) (a, AssignmentState ast grammar) + requireExhaustive :: (result, AssignmentState ast grammar) -> Either (Error grammar) (result, AssignmentState ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- projectNode node -> From fd27976ba65f145736b2e4fde54dcb234ca249a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:04:42 -0400 Subject: [PATCH 085/154] :fire: the note re: nullability. It really only made sense when we were matching stateNodes at the same time. --- src/Data/Syntax/Assignment.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index e6de7860d..85e936a73 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -260,7 +260,6 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx yield a (advanceState state' { stateNodes = stateNodes state }) Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< listToMaybe (stateNodes state) -> yield choice 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 -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) From 126e319b88ba024429f496ebbb79876061a1183d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:07:31 -0400 Subject: [PATCH 086/154] Bind the head node. --- src/Data/Syntax/Assignment.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 85e936a73..234bc2492 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -253,24 +253,25 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> Either (Error grammar) (result, AssignmentState ast grammar) run assignment yield initialState = case assignment of Location -> yield location state - Project projection | node : _ <- stateNodes state -> yield (projection (F.project node)) state - Source | node : _ <- stateNodes state -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advanceState state) - Children childAssignment | node : _ <- stateNodes state -> do + Project projection | Just node <- headNode -> yield (projection (F.project node)) state + Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advanceState state) + Children childAssignment | Just node <- headNode -> do (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive yield a (advanceState state' { stateNodes = stateNodes state }) - Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< listToMaybe (stateNodes state) -> yield choice state + Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< headNode -> yield choice state Many rule -> uncurry yield (runMany rule state) Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ | Node symbol _ (Info.Span spanStart _) : _ <- projectNode <$> stateNodes state -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) + _ | Just (Node symbol _ (Info.Span spanStart _)) <- projectNode <$> headNode -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) | otherwise -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices - location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) (listToMaybe (stateNodes state)) + headNode = listToMaybe (stateNodes state) + location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) headNode {-# INLINE run #-} runMany :: Assignment ast grammar result -> AssignmentState ast grammar -> ([result], AssignmentState ast grammar) From 8f492b7a9a9cac6cd21c1cc81c78074f1b8c1441 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:19:27 -0400 Subject: [PATCH 087/154] Combine the error clauses. --- src/Data/Syntax/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 234bc2492..b03d747b8 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -263,8 +263,8 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ | Just (Node symbol _ (Info.Span spanStart _)) <- projectNode <$> headNode -> Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) - | otherwise -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols)) + _ -> Left (Error (maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode) + (maybe (UnexpectedEndOfInput expectedSymbols) (UnexpectedSymbol expectedSymbols . nodeSymbol . projectNode) headNode)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices From a04a05cf1ad7225f2ea5aefb299de99f0108cdea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:31:43 -0400 Subject: [PATCH 088/154] Combine ErrorCause into Error. --- src/Data/Syntax/Assignment.hs | 46 ++++++++++------------------- test/Data/Syntax/Assignment/Spec.hs | 14 ++++----- 2 files changed, 23 insertions(+), 37 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index b03d747b8..dd8c32ed3 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -75,7 +75,6 @@ module Data.Syntax.Assignment , while -- Results , Error(..) -, ErrorCause(..) , printError , withSGRCode -- Running @@ -171,32 +170,24 @@ nodeLocation :: Node grammar -> Record Location nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil -data Error grammar where - Error - :: HasCallStack - => { errorPos :: Info.Pos - , errorCause :: ErrorCause grammar - } -> Error grammar +data Error grammar + = HasCallStack => UnexpectedSymbol { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: grammar } + | HasCallStack => UnexpectedEndOfInput { errorPos :: Info.Pos, errorExpected :: [grammar] } deriving instance Eq grammar => Eq (Error grammar) deriving instance Show grammar => Show (Error grammar) -data ErrorCause grammar - = UnexpectedSymbol [grammar] grammar - | UnexpectedEndOfInput [grammar] - deriving (Eq, Show) - -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () -printError Blob{..} error@Error{..} = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": " +printError Blob{..} error = do + withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos (maybe Nothing (const (Just blobPath)) blobKind) (errorPos error) . showString ": " withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n' - putStrErr $ showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') + putStrErr $ showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn (errorPos error) + lineNumberDigits)) ' ') withSGRCode [SetColor Foreground Vivid Green] . putStrErr $ showChar '^' . showChar '\n' putStrErr $ showString (prettyCallStack callStack) . showChar '\n' - where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) + where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine (errorPos error) - 2, Info.posLine (errorPos error)) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s - lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) + lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine (errorPos error)) :: Double))) putStrErr = hPutStr stderr . ($ "") withSGRCode :: [SGR] -> IO a -> IO () @@ -211,10 +202,9 @@ withSGRCode code action = do pure () showExpectation :: Show grammar => Error grammar -> ShowS -showExpectation Error{..} = case errorCause of - UnexpectedEndOfInput [] -> showString "no rule to match at end of input nodes" - UnexpectedEndOfInput symbols -> showString "expected " . showSymbols symbols . showString " at end of input nodes" - UnexpectedSymbol symbols a -> showString "expected " . showSymbols symbols . showString ", but got " . shows a +showExpectation (UnexpectedEndOfInput _ []) = showString "no rule to match at end of input nodes" +showExpectation (UnexpectedEndOfInput _ symbols) = showString "expected " . showSymbols symbols . showString " at end of input nodes" +showExpectation (UnexpectedSymbol _ symbols a) = showString "expected " . showSymbols symbols . showString ", but got " . shows a showSymbols :: Show grammar => [grammar] -> ShowS showSymbols [] = showString "end of input nodes" @@ -263,8 +253,8 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ -> Left (Error (maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode) - (maybe (UnexpectedEndOfInput expectedSymbols) (UnexpectedSymbol expectedSymbols . nodeSymbol . projectNode) headNode)) + _ -> let pos = maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode in + Left (maybe (UnexpectedEndOfInput pos expectedSymbols) (UnexpectedSymbol pos expectedSymbols . nodeSymbol . projectNode) headNode) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices @@ -287,7 +277,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- projectNode node -> - Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) + Left $ fromMaybe (UnexpectedSymbol spanStart [] nodeSymbol) (stateError state) dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } @@ -345,12 +335,8 @@ instance Show grammar => Show1 (AssignmentF ast grammar) where Catch during handler -> showsBinaryWith sp (const (const (showChar '_'))) "Catch" d during handler instance Show1 Error where - liftShowsPrec sp sl d (Error p c) = showsBinaryWith showsPrec (liftShowsPrec sp sl) "Error" d p c - -instance Show1 ErrorCause where - liftShowsPrec sp sl d e = case e of - UnexpectedSymbol expected actual -> showsBinaryWith (liftShowsPrec sp sl) sp "UnexpectedSymbol" d expected actual - UnexpectedEndOfInput expected -> showsUnaryWith (liftShowsPrec sp sl) "UnexpectedEndOfInput" d expected + liftShowsPrec sp sl d UnexpectedSymbol{..} = showParen (d > 10) $ showString "UnexpectedSymbol" . showChar ' ' . showsPrec 11 errorPos . showChar ' ' . liftShowsPrec sp sl 11 errorExpected . showChar ' ' . sp 11 errorActual + liftShowsPrec sp sl d UnexpectedEndOfInput{..} = showsBinaryWith showsPrec (liftShowsPrec sp sl) "UnexpectedEndOfInput" d errorPos errorExpected instance MonadError (Error grammar) (Assignment ast grammar) where throwError :: HasCallStack => Error grammar -> Assignment ast grammar a diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 86ff16d8a..f96abc65d 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -41,7 +41,7 @@ spec = do fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello") it "does not advance past the current node" $ - runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) (UnexpectedSymbol [] Red)) + runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (UnexpectedSymbol (Info.Pos 1 1) [] Red) describe "without catchError" $ do it "assignment returns UnexpectedSymbol" $ @@ -49,14 +49,14 @@ spec = do red (makeState [node Green 0 1 []]) `shouldBe` - Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green)) + Left (UnexpectedSymbol (Info.Pos 1 1) [Red] Green) it "assignment returns UnexpectedEndOfInput" $ runAssignment headF "A" (symbol Green *> children (some red)) (makeState [node Green 0 1 []]) `shouldBe` - Left (Error (Info.Pos 1 1) (UnexpectedEndOfInput [Red])) + Left (UnexpectedEndOfInput (Info.Pos 1 1) [Red]) describe "catchError" $ do it "handler that always matches" $ @@ -78,7 +78,7 @@ spec = do (red `catchError` const blue) (makeState [node Green 0 1 []]) `shouldBe` - Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Blue] Green)) + Left (UnexpectedSymbol (Info.Pos 1 1) [Blue] Green) describe "in many" $ do it "handler that always matches" $ @@ -102,7 +102,7 @@ spec = do (symbol Palette *> children ( many (red `catchError` const blue) )) (makeState [node Palette 0 1 [node Green 1 2 []]]) `shouldBe` - Left (Error (Info.Pos 1 2) (UnexpectedSymbol [Blue] Green)) + Left (UnexpectedSymbol (Info.Pos 1 2) [Blue] Green) it "handler that always matches with apply consumes and then errors" $ runAssignment headF "PG" @@ -111,7 +111,7 @@ spec = do )) (makeState [node Palette 0 1 [node Green 1 2 []]]) `shouldBe` - Left (Error (Info.Pos 1 3) (UnexpectedEndOfInput [Green])) + Left (UnexpectedEndOfInput (Info.Pos 1 3) [Green]) it "handler that doesn't match with apply" $ fst <$> runAssignment headF "PG" @@ -153,7 +153,7 @@ spec = do it "does not match if its subrule does not match" $ runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Green 0 1 []]]) `shouldBe` - Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green)) + Left (UnexpectedSymbol (Info.Pos 1 1) [Red] Green) it "matches nested children" $ fst <$> runAssignment headF "1" From 1b3a8f131145ab69dc215669b3d641703a841288 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:34:56 -0400 Subject: [PATCH 089/154] Simplify error construction. --- src/Data/Syntax/Assignment.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index dd8c32ed3..382ed79cb 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -177,6 +177,9 @@ data Error grammar deriving instance Eq grammar => Eq (Error grammar) deriving instance Show grammar => Show (Error grammar) +makeError :: HasCallStack => Info.Pos -> [grammar] -> Maybe grammar -> Error grammar +makeError pos expected = maybe (UnexpectedEndOfInput pos expected) (UnexpectedSymbol pos expected) + -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () printError Blob{..} error = do @@ -253,8 +256,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ -> let pos = maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode in - Left (maybe (UnexpectedEndOfInput pos expectedSymbols) (UnexpectedSymbol pos expectedSymbols . nodeSymbol . projectNode) headNode) + _ -> Left (makeError (maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode) expectedSymbols (nodeSymbol . projectNode <$> headNode)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices From 630d78ae2ab6f829f4c531e62d46d50e0aa230e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:41:56 -0400 Subject: [PATCH 090/154] :fire: the Show1 instance for Error. --- src/Data/Syntax/Assignment.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 382ed79cb..aacf68c0f 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -336,10 +336,6 @@ instance Show grammar => Show1 (AssignmentF ast grammar) where Throw e -> showsUnaryWith showsPrec "Throw" d e Catch during handler -> showsBinaryWith sp (const (const (showChar '_'))) "Catch" d during handler -instance Show1 Error where - liftShowsPrec sp sl d UnexpectedSymbol{..} = showParen (d > 10) $ showString "UnexpectedSymbol" . showChar ' ' . showsPrec 11 errorPos . showChar ' ' . liftShowsPrec sp sl 11 errorExpected . showChar ' ' . sp 11 errorActual - liftShowsPrec sp sl d UnexpectedEndOfInput{..} = showsBinaryWith showsPrec (liftShowsPrec sp sl) "UnexpectedEndOfInput" d errorPos errorExpected - instance MonadError (Error grammar) (Assignment ast grammar) where throwError :: HasCallStack => Error grammar -> Assignment ast grammar a throwError error = withFrozenCallStack $ Throw error `Then` return From 09787f5e93982a0d40eea0b24e5bfe3999eff60b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:43:48 -0400 Subject: [PATCH 091/154] Combine the Error constructors. --- src/Data/Syntax/Assignment.hs | 16 ++++++---------- test/Data/Syntax/Assignment/Spec.hs | 18 +++++++++--------- 2 files changed, 15 insertions(+), 19 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index aacf68c0f..1e9842b7d 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -171,15 +171,11 @@ nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil data Error grammar - = HasCallStack => UnexpectedSymbol { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: grammar } - | HasCallStack => UnexpectedEndOfInput { errorPos :: Info.Pos, errorExpected :: [grammar] } + = HasCallStack => Error { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: Maybe grammar } deriving instance Eq grammar => Eq (Error grammar) deriving instance Show grammar => Show (Error grammar) -makeError :: HasCallStack => Info.Pos -> [grammar] -> Maybe grammar -> Error grammar -makeError pos expected = maybe (UnexpectedEndOfInput pos expected) (UnexpectedSymbol pos expected) - -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () printError Blob{..} error = do @@ -205,9 +201,9 @@ withSGRCode code action = do pure () showExpectation :: Show grammar => Error grammar -> ShowS -showExpectation (UnexpectedEndOfInput _ []) = showString "no rule to match at end of input nodes" -showExpectation (UnexpectedEndOfInput _ symbols) = showString "expected " . showSymbols symbols . showString " at end of input nodes" -showExpectation (UnexpectedSymbol _ symbols a) = showString "expected " . showSymbols symbols . showString ", but got " . shows a +showExpectation (Error _ [] Nothing) = showString "no rule to match at end of input nodes" +showExpectation (Error _ expected Nothing) = showString "expected " . showSymbols expected . showString " at end of input nodes" +showExpectation (Error _ expected (Just actual)) = showString "expected " . showSymbols expected . showString ", but got " . shows actual showSymbols :: Show grammar => [grammar] -> ShowS showSymbols [] = showString "end of input nodes" @@ -256,7 +252,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ -> Left (makeError (maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode) expectedSymbols (nodeSymbol . projectNode <$> headNode)) + _ -> Left (Error (maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode) expectedSymbols (nodeSymbol . projectNode <$> headNode)) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices @@ -279,7 +275,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- projectNode node -> - Left $ fromMaybe (UnexpectedSymbol spanStart [] nodeSymbol) (stateError state) + Left $ fromMaybe (Error spanStart [] (Just nodeSymbol)) (stateError state) dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index f96abc65d..ee0938540 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -41,22 +41,22 @@ spec = do fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello") it "does not advance past the current node" $ - runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (UnexpectedSymbol (Info.Pos 1 1) [] Red) + runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) [] (Just Red)) describe "without catchError" $ do - it "assignment returns UnexpectedSymbol" $ + it "assignment returns unexpected symbol error" $ runAssignment headF "A" red (makeState [node Green 0 1 []]) `shouldBe` - Left (UnexpectedSymbol (Info.Pos 1 1) [Red] Green) + Left (Error (Info.Pos 1 1) [Red] (Just Green)) - it "assignment returns UnexpectedEndOfInput" $ + it "assignment returns unexpected end of input" $ runAssignment headF "A" (symbol Green *> children (some red)) (makeState [node Green 0 1 []]) `shouldBe` - Left (UnexpectedEndOfInput (Info.Pos 1 1) [Red]) + Left (Error (Info.Pos 1 1) [Red] Nothing) describe "catchError" $ do it "handler that always matches" $ @@ -78,7 +78,7 @@ spec = do (red `catchError` const blue) (makeState [node Green 0 1 []]) `shouldBe` - Left (UnexpectedSymbol (Info.Pos 1 1) [Blue] Green) + Left (Error (Info.Pos 1 1) [Blue] (Just Green)) describe "in many" $ do it "handler that always matches" $ @@ -102,7 +102,7 @@ spec = do (symbol Palette *> children ( many (red `catchError` const blue) )) (makeState [node Palette 0 1 [node Green 1 2 []]]) `shouldBe` - Left (UnexpectedSymbol (Info.Pos 1 2) [Blue] Green) + Left (Error (Info.Pos 1 2) [Blue] (Just Green)) it "handler that always matches with apply consumes and then errors" $ runAssignment headF "PG" @@ -111,7 +111,7 @@ spec = do )) (makeState [node Palette 0 1 [node Green 1 2 []]]) `shouldBe` - Left (UnexpectedEndOfInput (Info.Pos 1 3) [Green]) + Left (Error (Info.Pos 1 3) [Green] Nothing) it "handler that doesn't match with apply" $ fst <$> runAssignment headF "PG" @@ -153,7 +153,7 @@ spec = do it "does not match if its subrule does not match" $ runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Green 0 1 []]]) `shouldBe` - Left (UnexpectedSymbol (Info.Pos 1 1) [Red] Green) + Left (Error (Info.Pos 1 1) [Red] (Just Green)) it "matches nested children" $ fst <$> runAssignment headF "1" From 2c98b31f7398f2fa24d729ab247af9d521ae6584 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:52:37 -0400 Subject: [PATCH 092/154] Run child assignments as direct Monadic chain. --- src/Data/Syntax/Assignment.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 1e9842b7d..6b8558f4d 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -244,9 +244,8 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Location -> yield location state Project projection | Just node <- headNode -> yield (projection (F.project node)) state Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advanceState state) - Children childAssignment | Just node <- headNode -> do - (a, state') <- go childAssignment state { stateNodes = toList (F.project node) } >>= requireExhaustive - yield a (advanceState state' { stateNodes = stateNodes state }) + Children child | Just node <- headNode -> + go child (setStateNodes state (toList (F.project node))) >>= requireExhaustive >>= uncurry yield . second (advanceState . flip setStateNodes (stateNodes state)) Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< headNode -> yield choice state Many rule -> uncurry yield (runMany rule state) Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) @@ -303,6 +302,9 @@ makeState = AssignmentState 0 (Info.Pos 1 1) Nothing 0 setStateError :: AssignmentState ast grammar -> Maybe (Error grammar) -> AssignmentState ast grammar setStateError state error = state { stateError = error } +setStateNodes :: AssignmentState ast grammar -> [ast] -> AssignmentState ast grammar +setStateNodes state nodes = state { stateNodes = nodes } + -- Instances From 130b4a0d3ee8da9de2c32926ea8825dcb79dd492 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 15:55:30 -0400 Subject: [PATCH 093/154] Write the child chain as a Kleisli composition. --- 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 6b8558f4d..466dccf2d 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -245,7 +245,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Project projection | Just node <- headNode -> yield (projection (F.project node)) state Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advanceState state) Children child | Just node <- headNode -> - go child (setStateNodes state (toList (F.project node))) >>= requireExhaustive >>= uncurry yield . second (advanceState . flip setStateNodes (stateNodes state)) + uncurry yield . second (advanceState . flip setStateNodes (stateNodes state)) <=< requireExhaustive <=< go child . setStateNodes state . toList . F.project $ node Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< headNode -> yield choice state Many rule -> uncurry yield (runMany rule state) Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) From 0aa86a309f3437d5d0f4ba0ab74a92f526fb9407 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:00:50 -0400 Subject: [PATCH 094/154] Reformat Error. --- src/Data/Syntax/Assignment.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 466dccf2d..3ebfdf525 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -170,8 +170,7 @@ nodeLocation :: Node grammar -> Record Location nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil -data Error grammar - = HasCallStack => Error { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: Maybe grammar } +data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: Maybe grammar } deriving instance Eq grammar => Eq (Error grammar) deriving instance Show grammar => Show (Error grammar) From a4a8e85bbbfe7377f62c1567572c2b0d6ca23b6c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:05:02 -0400 Subject: [PATCH 095/154] Extract the computation of errors for a given node. --- src/Data/Syntax/Assignment.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 3ebfdf525..b4112f7be 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -175,6 +175,9 @@ data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected deriving instance Eq grammar => Eq (Error grammar) deriving instance Show grammar => Show (Error grammar) +nodeError :: Node grammar -> [grammar] -> Error grammar +nodeError (Node actual _ (Info.Span spanStart _)) expected = Error spanStart expected (Just actual) + -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () printError Blob{..} error = do @@ -272,8 +275,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx requireExhaustive :: (result, AssignmentState ast grammar) -> Either (Error grammar) (result, AssignmentState ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) - node : _ | Node nodeSymbol _ (Info.Span spanStart _) <- projectNode node -> - Left $ fromMaybe (Error spanStart [] (Just nodeSymbol)) (stateError state) + node : _-> Left (fromMaybe (nodeError (projectNode node) []) (stateError state)) dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } From 04fe451ca35830206073faa3e83482333e6f4e5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:05:55 -0400 Subject: [PATCH 096/154] Swap the parameters to nodeError. --- 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 b4112f7be..0d6c00bd2 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -175,8 +175,8 @@ data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected deriving instance Eq grammar => Eq (Error grammar) deriving instance Show grammar => Show (Error grammar) -nodeError :: Node grammar -> [grammar] -> Error grammar -nodeError (Node actual _ (Info.Span spanStart _)) expected = Error spanStart expected (Just actual) +nodeError :: [grammar] -> Node grammar -> Error grammar +nodeError expected (Node actual _ (Info.Span spanStart _)) = Error spanStart expected (Just actual) -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () @@ -275,7 +275,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx requireExhaustive :: (result, AssignmentState ast grammar) -> Either (Error grammar) (result, AssignmentState ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) - node : _-> Left (fromMaybe (nodeError (projectNode node) []) (stateError state)) + node : _-> Left (fromMaybe (nodeError [] (projectNode node)) (stateError state)) dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } From b91f70ec6a600d4bb8b91560d4168983f4d3f415 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:08:12 -0400 Subject: [PATCH 097/154] Simplify error construction. --- 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 0d6c00bd2..980e29f11 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -253,7 +253,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ -> Left (Error (maybe (statePos state) (Info.spanStart . nodeSpan . projectNode) headNode) expectedSymbols (nodeSymbol . projectNode <$> headNode)) + _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . projectNode) headNode) where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices From 32c03be782b8659ff6ced82a9c29ef331c027aca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:13:42 -0400 Subject: [PATCH 098/154] Rename AssignmentState to State. --- src/Data/Syntax/Assignment.hs | 34 ++++++++++++++--------------- test/Data/Syntax/Assignment/Spec.hs | 6 ++--- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 980e29f11..300be1472 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -81,7 +81,7 @@ module Data.Syntax.Assignment , assignBy , runAssignment -- Implementation details (for testing) -, AssignmentState(..) +, State(..) , makeState ) where @@ -97,7 +97,7 @@ import Data.Record import qualified Data.Source as Source (Source, fromBytes, slice, sourceBytes, sourceLines) import GHC.Stack import qualified Info -import Prologue hiding (Alt, get, Location, state) +import Prologue hiding (Alt, get, Location, State, state) import System.Console.ANSI import Text.Parser.TreeSitter.Language import Text.Show hiding (show) @@ -231,17 +231,17 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. -> Source.Source -- ^ The source for the parse tree. -> Assignment ast grammar a -- ^ The 'Assignment' to run. - -> AssignmentState ast grammar -- ^ The current state. - -> Either (Error grammar) (a, AssignmentState ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. + -> State ast grammar -- ^ The current state. + -> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. runAssignment toNode source assignment state = go assignment state >>= requireExhaustive - where go :: Assignment ast grammar result -> AssignmentState ast grammar -> Either (Error grammar) (result, AssignmentState ast grammar) + where go :: Assignment ast grammar result -> State ast grammar -> Either (Error grammar) (result, State ast grammar) go = iterFreer run . fmap ((pure .) . (,)) {-# INLINE go #-} run :: AssignmentF ast grammar x - -> (x -> AssignmentState ast grammar -> Either (Error grammar) (result, AssignmentState ast grammar)) - -> AssignmentState ast grammar - -> Either (Error grammar) (result, AssignmentState ast grammar) + -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar)) + -> State ast grammar + -> Either (Error grammar) (result, State ast grammar) run assignment yield initialState = case assignment of Location -> yield location state Project projection | Just node <- headNode -> yield (projection (F.project node)) state @@ -263,7 +263,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) headNode {-# INLINE run #-} - runMany :: Assignment ast grammar result -> AssignmentState ast grammar -> ([result], AssignmentState ast grammar) + runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) runMany rule state = case go rule state of Left err -> ([], state { stateError = Just err }) Right (a, state') | ((/=) `on` stateCounter) state state' -> @@ -272,7 +272,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx | otherwise -> ([a], state') {-# INLINE runMany #-} - requireExhaustive :: (result, AssignmentState ast grammar) -> Either (Error grammar) (result, AssignmentState ast grammar) + requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) node : _-> Left (fromMaybe (nodeError [] (projectNode node)) (stateError state)) @@ -280,15 +280,15 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } -- Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged. - advanceState state@AssignmentState{..} + advanceState state@State{..} | node : rest <- stateNodes - , Node{..} <- projectNode node = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest + , Node{..} <- projectNode node = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest | otherwise = state projectNode = toNode . F.project -- | State kept while running 'Assignment's. -data AssignmentState ast grammar = AssignmentState +data State ast grammar = State { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes. , statePos :: Info.Pos -- ^ The (1-indexed) line/column position in the Source thus far reached. , stateError :: Maybe (Error grammar) -- ^ The most recently encountered error. Preserved for improved error messages in the presence of backtracking. @@ -297,13 +297,13 @@ data AssignmentState ast grammar = AssignmentState } deriving (Eq, Show) -makeState :: [ast] -> AssignmentState ast grammar -makeState = AssignmentState 0 (Info.Pos 1 1) Nothing 0 +makeState :: [ast] -> State ast grammar +makeState = State 0 (Info.Pos 1 1) Nothing 0 -setStateError :: AssignmentState ast grammar -> Maybe (Error grammar) -> AssignmentState ast grammar +setStateError :: State ast grammar -> Maybe (Error grammar) -> State ast grammar setStateError state error = state { stateError = error } -setStateNodes :: AssignmentState ast grammar -> [ast] -> AssignmentState ast grammar +setStateNodes :: State ast grammar -> [ast] -> State ast grammar setStateNodes state nodes = state { stateNodes = nodes } diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index ee0938540..5f407290c 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -5,7 +5,7 @@ import Data.ByteString.Char8 as B (words, length) import Data.Source import Data.Syntax.Assignment import Info -import Prologue +import Prologue hiding (State) import Test.Hspec import Text.Parser.TreeSitter.Language (Symbol(..), SymbolType(..)) @@ -137,13 +137,13 @@ spec = do it "advances past the current node" $ snd <$> runAssignment headF "hi" source (makeState [ node Red 0 2 [] ]) `shouldBe` - Right (AssignmentState 2 (Info.Pos 1 3) Nothing 1 []) + Right (State 2 (Info.Pos 1 3) Nothing 1 []) describe "children" $ do it "advances past the current node" $ snd <$> runAssignment headF "a" (children (pure (Out ""))) (makeState [node Red 0 1 []]) `shouldBe` - Right (AssignmentState 1 (Info.Pos 1 2) Nothing 1 []) + Right (State 1 (Info.Pos 1 2) Nothing 1 []) it "matches if its subrule matches" $ () <$ runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Red 0 1 []]]) From 30fba30c28a46e5492387e32d16106d7061a09e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:20:16 -0400 Subject: [PATCH 099/154] Correct the sense of the predicate. --- 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 300be1472..292904ce4 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -254,7 +254,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . projectNode) headNode) - where state | any ((/= Regular) . symbolType) expectedSymbols = dropAnonymous initialState + where state | all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] From 5fab039939ba633278bffa353458e6a9a43cb53f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:24:26 -0400 Subject: [PATCH 100/154] Only drop when there are choices. --- 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 292904ce4..98c13e1cd 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -254,7 +254,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . projectNode) headNode) - where state | all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState + where state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] From 7675f348d2117ba27e92e3dc5194d773a89f577b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:27:02 -0400 Subject: [PATCH 101/154] Rename advanceState to advance. --- 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 98c13e1cd..1896e4413 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -245,9 +245,9 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx run assignment yield initialState = case assignment of Location -> yield location state Project projection | Just node <- headNode -> yield (projection (F.project node)) state - Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advanceState state) + Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advance state) Children child | Just node <- headNode -> - uncurry yield . second (advanceState . flip setStateNodes (stateNodes state)) <=< requireExhaustive <=< go child . setStateNodes state . toList . F.project $ node + uncurry yield . second (advance . flip setStateNodes (stateNodes state)) <=< requireExhaustive <=< go child . setStateNodes state . toList . F.project $ node Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< headNode -> yield choice state Many rule -> uncurry yield (runMany rule state) Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) @@ -280,7 +280,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } -- Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged. - advanceState state@State{..} + advance state@State{..} | node : rest <- stateNodes , Node{..} <- projectNode node = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest | otherwise = state From 18ae76951bd7c0c3571e8720c3a3c445ca0b85dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:31:23 -0400 Subject: [PATCH 102/154] De-golf children assignment. --- src/Data/Syntax/Assignment.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 1896e4413..015f77762 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -246,8 +246,10 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Location -> yield location state Project projection | Just node <- headNode -> yield (projection (F.project node)) state Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advance state) - Children child | Just node <- headNode -> - uncurry yield . second (advance . flip setStateNodes (stateNodes state)) <=< requireExhaustive <=< go child . setStateNodes state . toList . F.project $ node + Children child | Just node <- headNode -> do + childResult <- go child state { stateNodes = toList (F.project node) } + (a, state') <- requireExhaustive childResult + yield a (advance state' { stateNodes = stateNodes state }) Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< headNode -> yield choice state Many rule -> uncurry yield (runMany rule state) Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) @@ -303,9 +305,6 @@ makeState = State 0 (Info.Pos 1 1) Nothing 0 setStateError :: State ast grammar -> Maybe (Error grammar) -> State ast grammar setStateError state error = state { stateError = error } -setStateNodes :: State ast grammar -> [ast] -> State ast grammar -setStateNodes state nodes = state { stateNodes = nodes } - -- Instances From ba0f28fce218fe2e8351b324b773f4b7ad60bf00 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:32:56 -0400 Subject: [PATCH 103/154] Only bind results explicitly once we need to destructure them. --- src/Data/Syntax/Assignment.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 015f77762..9880b1492 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -247,8 +247,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx Project projection | Just node <- headNode -> yield (projection (F.project node)) state Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advance state) Children child | Just node <- headNode -> do - childResult <- go child state { stateNodes = toList (F.project node) } - (a, state') <- requireExhaustive childResult + (a, state') <- go child state { stateNodes = toList (F.project node) } >>= requireExhaustive yield a (advance state' { stateNodes = stateNodes state }) Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< headNode -> yield choice state Many rule -> uncurry yield (runMany rule state) From 770e367c9b58efe86f8d91096edb1112ec8d8c70 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:33:59 -0400 Subject: [PATCH 104/154] Tacit definition of choiceSymbols. --- 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 9880b1492..e69c1fb88 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -259,7 +259,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] - choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices + choiceSymbols = fmap (toEnum :: Int -> grammar) . IntMap.keys headNode = listToMaybe (stateNodes state) location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) headNode {-# INLINE run #-} From d5799cff0d87e18ec5b742e9f6849532753f9d6e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:36:21 -0400 Subject: [PATCH 105/154] Project the head node. --- src/Data/Syntax/Assignment.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index e69c1fb88..a23884a49 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -244,24 +244,24 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> Either (Error grammar) (result, State ast grammar) run assignment yield initialState = case assignment of Location -> yield location state - Project projection | Just node <- headNode -> yield (projection (F.project node)) state - Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (projectNode node)) source)) (advance state) + Project projection | Just node <- headNode -> yield (projection node) state + Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode node)) source)) (advance state) Children child | Just node <- headNode -> do - (a, state') <- go child state { stateNodes = toList (F.project node) } >>= requireExhaustive + (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive yield a (advance state' { stateNodes = stateNodes state }) - Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . projectNode =<< headNode -> yield choice state + Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . toNode =<< headNode -> yield choice state Many rule -> uncurry yield (runMany rule state) Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . projectNode) headNode) + _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) headNode) where state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] choiceSymbols = fmap (toEnum :: Int -> grammar) . IntMap.keys - headNode = listToMaybe (stateNodes state) - location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . projectNode) headNode + headNode = F.project <$> listToMaybe (stateNodes state) + location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . toNode) headNode {-# INLINE run #-} runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) From 15a6680848a8f0435b78de6baeff4fad93f91e6c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:53:18 -0400 Subject: [PATCH 106/154] Divide rule behaviours into at-end and at-node. --- src/Data/Syntax/Assignment.hs | 36 +++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index a23884a49..db1ceb311 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -242,26 +242,30 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar)) -> State ast grammar -> Either (Error grammar) (result, State ast grammar) - run assignment yield initialState = case assignment of - Location -> yield location state - Project projection | Just node <- headNode -> yield (projection node) state - Source | Just node <- headNode -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode node)) source)) (advance state) - Children child | Just node <- headNode -> do - (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive - yield a (advance state' { stateNodes = stateNodes state }) - Choose choices | Just choice <- flip IntMap.lookup choices . fromEnum . nodeSymbol . toNode =<< headNode -> yield choice state - Many rule -> uncurry yield (runMany rule state) - Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) - Throw e -> Left e - Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) headNode) - where state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState + run assignment yield initialState = maybe atEnd atNode (F.project <$> listToMaybe (stateNodes state)) + where atNode node = case assignment of + Location -> yield (nodeLocation (toNode node)) state + Project projection -> yield (projection 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 + yield a (advance state' { stateNodes = stateNodes state }) + Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state + _ -> atEnd + + atEnd = case assignment of + Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state + Many rule -> uncurry yield (runMany rule state) + Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) + Throw e -> Left e + Catch during handler -> either (flip yield state . handler) Right (yield during state) + _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) (F.project <$> listToMaybe (stateNodes state))) + + state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = choiceSymbols choices | otherwise = [] choiceSymbols = fmap (toEnum :: Int -> grammar) . IntMap.keys - headNode = F.project <$> listToMaybe (stateNodes state) - location = maybe (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) (nodeLocation . toNode) headNode {-# INLINE run #-} runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) From c7d3def19f75e636f5f73c7522496b61eca147bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:53:46 -0400 Subject: [PATCH 107/154] :fire: choiceSymbols. --- src/Data/Syntax/Assignment.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index db1ceb311..70c632b7a 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -263,9 +263,8 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState - expectedSymbols | Choose choices <- assignment = choiceSymbols choices + expectedSymbols | Choose choices <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices | otherwise = [] - choiceSymbols = fmap (toEnum :: Int -> grammar) . IntMap.keys {-# INLINE run #-} runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) From 4a0fb31ba1fa5119b8f6cd3c0f9c65e2dfb1e135 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:55:43 -0400 Subject: [PATCH 108/154] Handle node errors in one place. --- src/Data/Syntax/Assignment.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 70c632b7a..ad18026f6 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -242,7 +242,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar)) -> State ast grammar -> Either (Error grammar) (result, State ast grammar) - run assignment yield initialState = maybe atEnd atNode (F.project <$> listToMaybe (stateNodes state)) + run assignment yield initialState = maybe (atEnd Nothing) atNode (F.project <$> listToMaybe (stateNodes state)) where atNode node = case assignment of Location -> yield (nodeLocation (toNode node)) state Project projection -> yield (projection node) state @@ -251,15 +251,15 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive yield a (advance state' { stateNodes = stateNodes state }) Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state - _ -> atEnd + _ -> atEnd (Just (nodeError expectedSymbols (toNode node))) - atEnd = case assignment of + atEnd nodeError = case assignment of Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state Many rule -> uncurry yield (runMany rule state) Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) Throw e -> Left e Catch during handler -> either (flip yield state . handler) Right (yield during state) - _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) (F.project <$> listToMaybe (stateNodes state))) + _ -> Left (fromMaybe (Error (statePos state) expectedSymbols Nothing) nodeError) state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState From 8b63e54f6d157b6219642bd33d3f9c9431cc761d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:56:21 -0400 Subject: [PATCH 109/154] :fire: an unnecessary fmap. --- 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 ad18026f6..d459f0522 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -242,7 +242,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar)) -> State ast grammar -> Either (Error grammar) (result, State ast grammar) - run assignment yield initialState = maybe (atEnd Nothing) atNode (F.project <$> listToMaybe (stateNodes state)) + run assignment yield initialState = maybe (atEnd Nothing) (atNode . F.project) (listToMaybe (stateNodes state)) where atNode node = case assignment of Location -> yield (nodeLocation (toNode node)) state Project projection -> yield (projection node) state From 2ee6332b66dc6b384d257c418841ce6962696de4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:57:45 -0400 Subject: [PATCH 110/154] :fire: projectNode. --- src/Data/Syntax/Assignment.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index d459f0522..754443db9 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -279,18 +279,16 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) - node : _-> Left (fromMaybe (nodeError [] (projectNode node)) (stateError state)) + node : _-> Left (fromMaybe (nodeError [] (toNode (F.project node))) (stateError state)) - dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . projectNode) (stateNodes state) } + dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } -- Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged. advance state@State{..} | node : rest <- stateNodes - , Node{..} <- projectNode node = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest + , Node{..} <- toNode (F.project node) = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest | otherwise = state - projectNode = toNode . F.project - -- | State kept while running 'Assignment's. data State ast grammar = State { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes. From 6caaec828988248bb013b8691a9d040f6b057288 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:58:09 -0400 Subject: [PATCH 111/154] Spacing. --- 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 754443db9..5e6a1c6ed 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -279,7 +279,7 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar) requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of [] -> Right (a, state) - node : _-> Left (fromMaybe (nodeError [] (toNode (F.project node))) (stateError state)) + node : _ -> Left (fromMaybe (nodeError [] (toNode (F.project node))) (stateError state)) dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } From 2adf4ee765bea81dca33fff2a87b5bc3354ed1c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 16:59:38 -0400 Subject: [PATCH 112/154] =?UTF-8?q?Use=20Either=E2=80=99s=20MonadError=20i?= =?UTF-8?q?nstance=20to=20backtrack.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Syntax/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 5e6a1c6ed..3481229ae 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -256,9 +256,9 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx atEnd nodeError = case assignment of Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state Many rule -> uncurry yield (runMany rule state) - Alt a b -> either (yield b . setStateError state . Just) Right (yield a state) + Alt a b -> yield a state `catchError` (yield b . setStateError state . Just) Throw e -> Left e - Catch during handler -> either (flip yield state . handler) Right (yield during state) + Catch during handler -> yield during state `catchError` (flip yield state . handler) _ -> Left (fromMaybe (Error (statePos state) expectedSymbols Nothing) nodeError) state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState From 6f954d4510d7ed217200ec71c2e9f3d07de12066 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:11:26 -0400 Subject: [PATCH 113/154] Define runMany as a worker/wrapper. --- 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 3481229ae..7483fe252 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -268,12 +268,10 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx {-# INLINE run #-} runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) - runMany rule state = case go rule state of - Left err -> ([], state { stateError = Just err }) - Right (a, state') | ((/=) `on` stateCounter) state state' -> - let (as, state'') = runMany rule state' - in as `seq` (a : as, state'') - | otherwise -> ([a], state') + runMany rule = goMany + where goMany state = either ((,) [] . setStateError state . Just) loop (go rule state) + loop (a, state') | ((/=) `on` stateCounter) state state', (as, state'') <- goMany state' = as `seq` (a : as, state'') + | otherwise = ( [a], state') {-# INLINE runMany #-} requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar) From d2bde129da0921a6b46c54eb58385baa9af5145c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:25:39 -0400 Subject: [PATCH 114/154] Combine goMany and loop. --- src/Data/Syntax/Assignment.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 7483fe252..479c08797 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -268,10 +268,11 @@ runAssignment toNode source assignment state = go assignment state >>= requireEx {-# INLINE run #-} runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) - runMany rule = goMany - where goMany state = either ((,) [] . setStateError state . Just) loop (go rule state) - loop (a, state') | ((/=) `on` stateCounter) state state', (as, state'') <- goMany state' = as `seq` (a : as, state'') - | otherwise = ( [a], state') + runMany rule = loop + where loop state = case go rule state of + Left err -> ([], state { stateError = Just err }) + Right (a, state') | ((/=) `on` stateCounter) state state', (as, state'') <- loop state' -> as `seq` (a : as, state'') + | otherwise -> ([], state') {-# INLINE runMany #-} requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar) From a1a3f3be790534868938cea8f444c5c08f34d602 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:25:54 -0400 Subject: [PATCH 115/154] =?UTF-8?q?Rename=20the=20first=20state=20so=20we?= =?UTF-8?q?=20don=E2=80=99t=20use=20it=20where=20we=20mean=20some=20later?= =?UTF-8?q?=20state.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- 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 479c08797..f84af7907 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -233,7 +233,7 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> Assignment ast grammar a -- ^ The 'Assignment' to run. -> State ast grammar -- ^ The current state. -> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. -runAssignment toNode source assignment state = go assignment state >>= requireExhaustive +runAssignment toNode source assignment firstState = go assignment firstState >>= requireExhaustive where go :: Assignment ast grammar result -> State ast grammar -> Either (Error grammar) (result, State ast grammar) go = iterFreer run . fmap ((pure .) . (,)) {-# INLINE go #-} From acc1d683d10512c80606a35c521dea6a67eea728 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:26:40 -0400 Subject: [PATCH 116/154] Define runAssignment as a Kleisli composition. --- 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 f84af7907..9a2a5d8b4 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -233,7 +233,7 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> Assignment ast grammar a -- ^ The 'Assignment' to run. -> State ast grammar -- ^ The current state. -> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. -runAssignment toNode source assignment firstState = go assignment firstState >>= requireExhaustive +runAssignment toNode source assignment = requireExhaustive <=< go assignment where go :: Assignment ast grammar result -> State ast grammar -> Either (Error grammar) (result, State ast grammar) go = iterFreer run . fmap ((pure .) . (,)) {-# INLINE go #-} From 0ffb818898ba96d9c5c17508b4bcc7ec1b8e3a5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:27:08 -0400 Subject: [PATCH 117/154] =?UTF-8?q?Don=E2=80=99t=20bind=20the=20first=20as?= =?UTF-8?q?signment.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- 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 9a2a5d8b4..21a7dfff1 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -233,7 +233,7 @@ runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar -> Assignment ast grammar a -- ^ The 'Assignment' to run. -> State ast grammar -- ^ The current state. -> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. -runAssignment toNode source assignment = requireExhaustive <=< go assignment +runAssignment toNode source = (requireExhaustive <=<) . go where go :: Assignment ast grammar result -> State ast grammar -> Either (Error grammar) (result, State ast grammar) go = iterFreer run . fmap ((pure .) . (,)) {-# INLINE go #-} From fa8d0e4db69ac066b8632b3fd8a9ef430d0998bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:28:09 -0400 Subject: [PATCH 118/154] :fire: the inlining of run. --- src/Data/Syntax/Assignment.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 21a7dfff1..25480e855 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -265,7 +265,6 @@ runAssignment toNode source = (requireExhaustive <=<) . go | otherwise = initialState expectedSymbols | Choose choices <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices | otherwise = [] - {-# INLINE run #-} runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar) runMany rule = loop From 3b95662be229cd6d4e0efa08f902a6da91d8523f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:29:35 -0400 Subject: [PATCH 119/154] Guard the expected symbols by pattern matching. --- 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 25480e855..d86e42706 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -261,7 +261,7 @@ runAssignment toNode source = (requireExhaustive <=<) . go Catch during handler -> yield during state `catchError` (flip yield state . handler) _ -> Left (fromMaybe (Error (statePos state) expectedSymbols Nothing) nodeError) - state | not (null expectedSymbols), all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState + state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState expectedSymbols | Choose choices <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices | otherwise = [] From 4f5990d5ade5788f8ddb6101deadf7629b898838 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:33:47 -0400 Subject: [PATCH 120/154] Rename atEnd to reflect the fact that it might not be. --- src/Data/Syntax/Assignment.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index d86e42706..b2faa1c78 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -242,7 +242,7 @@ runAssignment toNode source = (requireExhaustive <=<) . go -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar)) -> State ast grammar -> Either (Error grammar) (result, State ast grammar) - run assignment yield initialState = maybe (atEnd Nothing) (atNode . F.project) (listToMaybe (stateNodes state)) + run assignment yield initialState = maybe (atNodeOrEnd Nothing) (atNode . F.project) (listToMaybe (stateNodes state)) where atNode node = case assignment of Location -> yield (nodeLocation (toNode node)) state Project projection -> yield (projection node) state @@ -251,15 +251,15 @@ runAssignment toNode source = (requireExhaustive <=<) . go (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive yield a (advance state' { stateNodes = stateNodes state }) Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state - _ -> atEnd (Just (nodeError expectedSymbols (toNode node))) + _ -> atNodeOrEnd (Just node) - atEnd nodeError = case assignment of + atNodeOrEnd node = case assignment of Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state Many rule -> uncurry yield (runMany rule state) Alt a b -> yield a state `catchError` (yield b . setStateError state . Just) Throw e -> Left e Catch during handler -> yield during state `catchError` (flip yield state . handler) - _ -> Left (fromMaybe (Error (statePos state) expectedSymbols Nothing) nodeError) + _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node) state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState | otherwise = initialState From e4397a57b396a0a949c2cd8e1c34145cc3894418 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:34:13 -0400 Subject: [PATCH 121/154] Rename atNodeOrEnd to anywhere. --- 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 b2faa1c78..13f439173 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -242,7 +242,7 @@ runAssignment toNode source = (requireExhaustive <=<) . go -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar)) -> State ast grammar -> Either (Error grammar) (result, State ast grammar) - run assignment yield initialState = maybe (atNodeOrEnd Nothing) (atNode . F.project) (listToMaybe (stateNodes state)) + run assignment yield initialState = maybe (anywhere Nothing) (atNode . F.project) (listToMaybe (stateNodes state)) where atNode node = case assignment of Location -> yield (nodeLocation (toNode node)) state Project projection -> yield (projection node) state @@ -251,9 +251,9 @@ runAssignment toNode source = (requireExhaustive <=<) . go (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive yield a (advance state' { stateNodes = stateNodes state }) Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state - _ -> atNodeOrEnd (Just node) + _ -> anywhere (Just node) - atNodeOrEnd node = case assignment of + anywhere node = case assignment of Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state Many rule -> uncurry yield (runMany rule state) Alt a b -> yield a state `catchError` (yield b . setStateError state . Just) From 519c43d39dfd4470615ac1d8d87034cc75d06505 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 17:47:18 -0400 Subject: [PATCH 122/154] Correct the indentation of the argument docs. --- 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 13f439173..583839579 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -228,9 +228,9 @@ assignBy toNode source assignment = fmap fst . runAssignment toNode source assig -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) - => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. - -> Source.Source -- ^ The source for the parse tree. - -> Assignment ast grammar a -- ^ The 'Assignment' to run. + => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast. + -> Source.Source -- ^ The source for the parse tree. + -> Assignment ast grammar a -- ^ The 'Assignment' to run. -> State ast grammar -- ^ The current state. -> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state. runAssignment toNode source = (requireExhaustive <=<) . go From 0678c2aeee6b0813b288b9d71fe61ec00a6787f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 22 Jul 2017 18:06:32 -0400 Subject: [PATCH 123/154] Always return at least one zero-width match. --- 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 583839579..c11ada5fd 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -271,7 +271,7 @@ runAssignment toNode source = (requireExhaustive <=<) . go where loop state = case go rule state of Left err -> ([], state { stateError = Just err }) Right (a, state') | ((/=) `on` stateCounter) state state', (as, state'') <- loop state' -> as `seq` (a : as, state'') - | otherwise -> ([], state') + | otherwise -> ([a], state') {-# INLINE runMany #-} requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar) From a2f1a0cfe0f61ec59e77a0d54a8d72290cfdeec5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 13:44:18 -0400 Subject: [PATCH 124/154] Add an option & CLI flag for including source. --- src/Semantic/Task.hs | 2 ++ src/SemanticCmdLine.hs | 1 + 2 files changed, 3 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 16dba1ebc..378c24a77 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -143,12 +143,14 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) data Options = Options { optionsColour :: Maybe Bool -- ^ Whether to use colour formatting for errors. 'Nothing' implies automatic selection for the stderr handle, using colour for terminal handles but not for regular files. , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. + , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors. } defaultOptions :: Options defaultOptions = Options { optionsColour = Nothing , optionsLevel = Just Warning + , optionsPrintSource = False } configureOptionsForHandle :: Handle -> Options -> IO Options diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 9c1a81850..62b887ca2 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -44,6 +44,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar (long "colour" <> long "color" <> value Nothing <> help "Enable, disable, or decide automatically iff stderr is a terminal device, whether to use colour.") <*> options [("error", Just Task.Error), ("warning", Just Task.Warning), ("info", Just Task.Info), ("debug", Just Task.Debug), ("none", Nothing)] (long "log-level" <> value (Just Task.Warning) <> help "Log messages at or above this level, or disable logging entirely.") + <*> switch (long "print-source" <> help "Include source references in logged errors where applicable.") argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") From 6358896dc5bc51d6753243e16a896ba8e4b42b3e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 13:45:12 -0400 Subject: [PATCH 125/154] Pass the option to print source when formatting assignment errors. --- src/Semantic/Task.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 378c24a77..5d985c497 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -207,6 +207,7 @@ runParser options parser blob@Blob{..} = case parser of Left err -> do let formatOptions = Assignment.defaultOptions { Assignment.optionsColour = fromMaybe True (optionsColour options) + , Assignment.optionsIncludeSource = optionsPrintSource options } writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err) pure (errorTerm blobSource) From 29fd11f96f54ce9217725e6c884846cf8ae6e237 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:11:48 -0400 Subject: [PATCH 126/154] Define a Message datatype. --- src/Semantic/Task.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 5d985c497..d6aa6a703 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -65,6 +65,9 @@ data TaskF output where type Task = Freer TaskF -- | A log message at a specific level. +data Message = Message Time.UTCTime Level String + deriving (Eq, Show) + data Level = Error | Warning From 69b9b1d6be98bd78cde88b90aa04059a43a6d52c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:12:13 -0400 Subject: [PATCH 127/154] Pass Messages over the queue with the current time. --- semantic-diff.cabal | 1 + src/Semantic/Task.hs | 8 ++++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index b7d7ccc6e..9a291d1ec 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -114,6 +114,7 @@ library , template-haskell , text >= 1.2.1.3 , these + , time , haskell-tree-sitter , c , go diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index d6aa6a703..b672c81bf 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -36,6 +36,8 @@ import Data.String import qualified Data.Syntax as Syntax import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import qualified Data.Syntax.Assignment as Assignment +import qualified Data.Time.Clock as Time +import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) import Data.Union import Diff import qualified Files @@ -181,7 +183,9 @@ runTaskWithOptions options task = do ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents) WriteLog level message - | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (atomically (writeTMQueue logQueue (level, message))) + | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (do + now <- Time.getCurrentTime + atomically (writeTMQueue logQueue (Message now level message))) | otherwise -> pure (pure ()) Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term) @@ -196,7 +200,7 @@ runTaskWithOptions options task = do where logSink options queue = do message <- atomically (readTMQueue queue) case message of - Just (level, message) -> do + Just (Message _ level message) -> do hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) level message) logSink options queue _ -> pure () From adc71548e534744a70b17fb9d48f659af656e5f5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:15:53 -0400 Subject: [PATCH 128/154] Pass Messages to formatMessage. --- src/Semantic/Task.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index b672c81bf..7e8b006e4 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -78,12 +78,12 @@ data Level deriving (Eq, Ord, Show) -- | Format a 'Message', optionally colourized. -formatMessage :: Bool -> Level -> String -> String -formatMessage colourize level message = showLabel level . showString ": " . showString message . showChar '\n' $ "" - where showLabel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") - showLabel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") - showLabel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") - showLabel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") +formatMessage :: Bool -> Message -> String +formatMessage colourize (Message _ level message) = showLevel level . showString ": " . showString message . showChar '\n' $ "" + where showLevel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") + showLevel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") + showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") + showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. From bbb0c307e59f71e5aa9438fb812dd5bccc0e40a2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:16:15 -0400 Subject: [PATCH 129/154] Add timestamps to logged messages. --- src/Semantic/Task.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 7e8b006e4..e832bad7f 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -38,6 +38,7 @@ import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import qualified Data.Syntax.Assignment as Assignment import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) +import qualified Data.Time.Format as Time import Data.Union import Diff import qualified Files @@ -79,11 +80,12 @@ data Level -- | Format a 'Message', optionally colourized. formatMessage :: Bool -> Message -> String -formatMessage colourize (Message _ level message) = showLevel level . showString ": " . showString message . showChar '\n' $ "" +formatMessage colourize (Message time level message) = showTime time . showChar ' ' . showLevel level . showString ": " . showString message . showChar '\n' $ "" where showLevel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") showLevel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") + showTime = showString . Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat (Just "%Q")) -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. @@ -200,8 +202,8 @@ runTaskWithOptions options task = do where logSink options queue = do message <- atomically (readTMQueue queue) case message of - Just (Message _ level message) -> do - hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) level message) + Just message -> do + hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message) logSink options queue _ -> pure () From b7e776ee9079adce00a7c085f3b4cb6fae131f08 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:21:20 -0400 Subject: [PATCH 130/154] Add the hours, minutes, & seconds to timestamps. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index e832bad7f..4f4bc21fa 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -85,7 +85,7 @@ formatMessage colourize (Message time level message) = showTime time . showChar showLevel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") - showTime = showString . Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat (Just "%Q")) + showTime = showString . Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat (Just "%H:%M:%S%Q")) -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. From 77e7ed0ba5eb7b249c9e008edb4287449777676c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:24:05 -0400 Subject: [PATCH 131/154] Spacing. --- src/Semantic/Task.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 4f4bc21fa..7f03e060c 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -167,6 +167,7 @@ configureOptionsForHandle handle options = do { optionsColour = optionsColour options <|> Just isTerminal } + -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. -- -- > runTask = runTaskWithOptions defaultOptions From 2fb501ab30569b6a89d49170811ac03794da9cc2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:27:24 -0400 Subject: [PATCH 132/154] Bind the current time instead of using do notation. --- src/Semantic/Task.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 7f03e060c..4c28bb8ba 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -68,7 +68,7 @@ data TaskF output where type Task = Freer TaskF -- | A log message at a specific level. -data Message = Message Time.UTCTime Level String +data Message = Message Level String Time.UTCTime deriving (Eq, Show) data Level @@ -80,7 +80,7 @@ data Level -- | Format a 'Message', optionally colourized. formatMessage :: Bool -> Message -> String -formatMessage colourize (Message time level message) = showTime time . showChar ' ' . showLevel level . showString ": " . showString message . showChar '\n' $ "" +formatMessage colourize (Message level message time) = showTime time . showChar ' ' . showLevel level . showString ": " . showString message . showChar '\n' $ "" where showLevel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") showLevel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") @@ -186,9 +186,7 @@ runTaskWithOptions options task = do ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents) WriteLog level message - | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (do - now <- Time.getCurrentTime - atomically (writeTMQueue logQueue (Message now level message))) + | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (Time.getCurrentTime >>= atomically . writeTMQueue logQueue . Message level message) | otherwise -> pure (pure ()) Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term) From 93f653b7656e956ca7bcf69b6a6122233457d934 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:33:38 -0400 Subject: [PATCH 133/154] Bind the error fields. --- src/Data/Syntax/Assignment.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 9db03a3e5..f92cb1aac 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -217,18 +217,18 @@ formatError = formatErrorWithOptions defaultOptions -- | Format an 'Error', optionally with reference to the source where it occurred. formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> String -formatErrorWithOptions Options{..} Blob{..} error +formatErrorWithOptions Options{..} Blob{..} Error{..} = ($ "") - $ withSGRCode optionsColour [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) (errorPos error) . showString ": ") - . withSGRCode optionsColour [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation error . showChar '\n') + $ withSGRCode optionsColour [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ") + . withSGRCode optionsColour [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation errorExpected errorActual . showChar '\n') . (if optionsIncludeSource then showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') - . showString (replicate (succ (Info.posColumn (errorPos error) + lineNumberDigits)) ' ') . withSGRCode optionsColour [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') + . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode optionsColour [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') else identity) . showString (prettyCallStack callStack) . showChar '\n' - where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine (errorPos error) - 2, Info.posLine (errorPos error)) i ]) + where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), 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 error)) :: Double))) + lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) withSGRCode :: Bool -> [SGR] -> ShowS -> ShowS withSGRCode useColour code content = @@ -239,10 +239,10 @@ withSGRCode useColour code content = else content -showExpectation :: Show grammar => Error grammar -> ShowS -showExpectation (Error _ [] Nothing) = showString "no rule to match at end of input nodes" -showExpectation (Error _ expected Nothing) = showString "expected " . showSymbols expected . showString " at end of input nodes" -showExpectation (Error _ expected (Just actual)) = showString "expected " . showSymbols expected . showString ", but got " . shows actual +showExpectation :: Show grammar => [grammar] -> Maybe grammar -> ShowS +showExpectation [] Nothing = showString "no rule to match at end of input nodes" +showExpectation expected Nothing = showString "expected " . showSymbols expected . showString " at end of input nodes" +showExpectation expected (Just actual) = showString "expected " . showSymbols expected . showString ", but got " . shows actual showSymbols :: Show grammar => [grammar] -> ShowS showSymbols [] = showString "end of input nodes" From 8b3b6f36e2a059cd144b6cdfe39ef6edd0b25ecd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:40:30 -0400 Subject: [PATCH 134/154] Define a catamorphism determining whether a term contains parse errors. --- src/Semantic/Task.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 4c28bb8ba..fee1dcd08 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -227,6 +227,11 @@ runParser options parser blob@Blob{..} = case parser of errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Assignment.Location) errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error [])) +hasErrors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> Bool +hasErrors = cata $ \ (_ :< syntax) -> case syntax of + _ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool) + _ -> or syntax + instance MonadIO Task where liftIO action = LiftIO action `Then` return From 86823f75add32e8fbeee82c86ca189be490cc299 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:42:51 -0400 Subject: [PATCH 135/154] Log a warning on parse error. --- src/Semantic/Task.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index fee1dcd08..67f1a6a8d 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -219,7 +219,9 @@ runParser options parser blob@Blob{..} = case parser of } writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err) pure (errorTerm blobSource) - Right term -> pure term + Right term -> do + when (hasErrors term) $ writeLog Warning ("parse errors present in " <> blobPath) + pure term TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource MarkdownParser -> pure (cmarkParser blobSource) LineByLineParser -> pure (lineByLineParser blobSource) From 5b8015311f22af3601ecc5fa12592ebbe344a10d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:44:12 -0400 Subject: [PATCH 136/154] Show the language of sources with parse errors. --- src/Semantic/Task.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 67f1a6a8d..33c106792 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -45,7 +45,7 @@ import qualified Files import Language import Language.Markdown import Parser -import Prologue hiding (Location) +import Prologue hiding (Location, show) import System.Console.ANSI import System.IO (hIsTerminalDevice, hPutStr) import Term @@ -220,7 +220,7 @@ runParser options parser blob@Blob{..} = case parser of writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err) pure (errorTerm blobSource) Right term -> do - when (hasErrors term) $ writeLog Warning ("parse errors present in " <> blobPath) + when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> show blobLanguage <> " has parse errors") pure term TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource MarkdownParser -> pure (cmarkParser blobSource) From 607e5385883ce426a30d8b526b9a91792e7bbba3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:56:18 -0400 Subject: [PATCH 137/154] Define a function selecting a Language for a Ptr TSLanguage. --- src/TreeSitter.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 16106a0a7..53829c34a 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -167,3 +167,12 @@ categoryForLanguageProductionName = withDefaults . byLanguage Language.Go -> Go.categoryForGoName TypeScript -> TS.categoryForTypeScriptName _ -> Other + + +languageForTSLanguage :: Ptr TS.Language -> Maybe Language +languageForTSLanguage language + = if language == TS.tree_sitter_c then Just C + else if language == TS.tree_sitter_go then Just Language.Go + else if language == TS.tree_sitter_ruby then Just Ruby + else if language == TS.tree_sitter_typescript then Just TypeScript + else Nothing From 999d2d1efb35e5865e8e53ea983e54c9ed3c7750 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:56:44 -0400 Subject: [PATCH 138/154] Remove the Language from TreeSitterParsers. --- src/Parser.hs | 14 ++++++------- src/Semantic/Task.hs | 2 +- src/TreeSitter.hs | 49 ++++++++++++++++++++++++-------------------- 3 files changed, 35 insertions(+), 30 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 5fc7bc011..4ba82cbfe 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -48,7 +48,7 @@ data Parser term where -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. -> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's. -- | A tree-sitter parser. - TreeSitterParser :: Language -> Ptr TS.Language -> Parser (SyntaxTerm Text DefaultFields) + TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm Text DefaultFields) -- | A parser for 'Markdown' using cmark. MarkdownParser :: Parser (AST CMark.NodeType) -- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines. @@ -58,12 +58,12 @@ data Parser term where parserForLanguage :: Maybe Language -> Parser (SyntaxTerm Text DefaultFields) parserForLanguage Nothing = LineByLineParser parserForLanguage (Just language) = case language of - C -> TreeSitterParser C tree_sitter_c - Go -> TreeSitterParser Go tree_sitter_go - JSON -> TreeSitterParser JSON tree_sitter_json - JavaScript -> TreeSitterParser TypeScript tree_sitter_typescript - Ruby -> TreeSitterParser Ruby tree_sitter_ruby - TypeScript -> TreeSitterParser TypeScript tree_sitter_typescript + C -> TreeSitterParser tree_sitter_c + Go -> TreeSitterParser tree_sitter_go + JSON -> TreeSitterParser tree_sitter_json + JavaScript -> TreeSitterParser tree_sitter_typescript + Ruby -> TreeSitterParser tree_sitter_ruby + TypeScript -> TreeSitterParser tree_sitter_typescript _ -> LineByLineParser rubyParser :: Parser Ruby.Term diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 33c106792..63eb90d3b 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -222,7 +222,7 @@ runParser options parser blob@Blob{..} = case parser of Right term -> do when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> show blobLanguage <> " has parse errors") pure term - TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource + TreeSitterParser tslanguage -> liftIO $ treeSitterParser tslanguage blob MarkdownParser -> pure (cmarkParser blobSource) LineByLineParser -> pure (lineByLineParser blobSource) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 53829c34a..07ce9cb20 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -7,6 +7,7 @@ module TreeSitter import Prologue hiding (Constructor) import Category +import Data.Blob import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Functor.Foldable hiding (Nil) import Data.Range @@ -27,16 +28,20 @@ import qualified Syntax as S import Term import Text.Parser.TreeSitter hiding (Language(..)) import qualified Text.Parser.TreeSitter as TS +import qualified Text.Parser.TreeSitter.C as TS +import qualified Text.Parser.TreeSitter.Go as TS +import qualified Text.Parser.TreeSitter.Ruby as TS +import qualified Text.Parser.TreeSitter.TypeScript as TS import Info -- | Returns a TreeSitter parser for the given language and TreeSitter grammar. -treeSitterParser :: Language -> Ptr TS.Language -> Source -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) -treeSitterParser language grammar source = bracket ts_document_new ts_document_free $ \ document -> do - ts_document_set_language document grammar - unsafeUseAsCStringLen (sourceBytes source) $ \ (sourceBytes, len) -> do +treeSitterParser :: Ptr TS.Language -> Blob -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) +treeSitterParser language blob = bracket ts_document_new ts_document_free $ \ document -> do + ts_document_set_language document language + unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do ts_document_set_input_string_with_length document sourceBytes len ts_document_parse_halt_on_error document - term <- documentToTerm language document source + term <- documentToTerm language document blob pure term @@ -66,12 +71,12 @@ anaM g = a where a = pure . embed <=< traverse a <=< g -- | Return a parser for a tree sitter language & document. -documentToTerm :: Language -> Ptr Document -> Source -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) -documentToTerm language document allSource = do +documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) +documentToTerm language document blob = do root <- alloca (\ rootPtr -> do ts_document_root_node_p document rootPtr peek rootPtr) - toTerm root (slice (nodeRange root) allSource) + toTerm root (slice (nodeRange root) (blobSource blob)) where toTerm :: Node -> Source -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) toTerm node source = do name <- peekCString (nodeType node) @@ -101,17 +106,17 @@ nodeSpan :: Node -> Span nodeSpan Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint) where pointPos TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn) -assignTerm :: Language -> Source -> Record DefaultFields -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (SyntaxTerm Text DefaultFields) +assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (SyntaxTerm Text DefaultFields) assignTerm language source annotation children allChildren = - cofree . (annotation :<) <$> case assignTermByLanguage language source (category annotation) children of + cofree . (annotation :<) <$> case assignTermByLanguage source (category annotation) children of Just a -> pure a _ -> defaultTermAssignment source (category annotation) children allChildren - where assignTermByLanguage :: Language -> Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) - assignTermByLanguage language = case language of - C -> C.termAssignment - Language.Go -> Go.termAssignment - Ruby -> Ruby.termAssignment - TypeScript -> TS.termAssignment + where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) + assignTermByLanguage = case languageForTSLanguage language of + Just C -> C.termAssignment + Just Language.Go -> Go.termAssignment + Just Ruby -> Ruby.termAssignment + Just TypeScript -> TS.termAssignment _ -> \ _ _ _ -> Nothing defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax Text (SyntaxTerm Text DefaultFields)) @@ -154,18 +159,18 @@ defaultTermAssignment source category children allChildren ] -categoryForLanguageProductionName :: Language -> Text -> Category +categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category categoryForLanguageProductionName = withDefaults . byLanguage where withDefaults productionMap name = case name of "ERROR" -> ParseError s -> productionMap s - byLanguage language = case language of - C -> C.categoryForCProductionName - Ruby -> Ruby.categoryForRubyName - Language.Go -> Go.categoryForGoName - TypeScript -> TS.categoryForTypeScriptName + byLanguage language = case languageForTSLanguage language of + Just C -> C.categoryForCProductionName + Just Ruby -> Ruby.categoryForRubyName + Just Language.Go -> Go.categoryForGoName + Just TypeScript -> TS.categoryForTypeScriptName _ -> Other From cb90f2dd43fd03afd9784100bfa92fe91858ccf6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 14:59:34 -0400 Subject: [PATCH 139/154] =?UTF-8?q?Don=E2=80=99t=20slice=20the=20Source=20?= =?UTF-8?q?down=20repeatedly.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Slicing Source is O(1). --- src/TreeSitter.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 07ce9cb20..730f50c34 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -72,13 +72,14 @@ anaM g = a where a = pure . embed <=< traverse a <=< g -- | Return a parser for a tree sitter language & document. documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) -documentToTerm language document blob = do +documentToTerm language document Blob{..} = do root <- alloca (\ rootPtr -> do ts_document_root_node_p document rootPtr peek rootPtr) - toTerm root (slice (nodeRange root) (blobSource blob)) - where toTerm :: Node -> Source -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) - toTerm node source = do + toTerm root + where toTerm :: Node -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) + toTerm node = do + let source = slice (nodeRange node) blobSource name <- peekCString (nodeType node) children <- getChildren (fromIntegral (nodeNamedChildCount node)) copyNamed @@ -89,9 +90,8 @@ documentToTerm language document blob = do nodes <- allocaArray count $ \ childNodesPtr -> do _ <- with (nodeTSNode node) (\ nodePtr -> copy nodePtr childNodesPtr (fromIntegral count)) peekArray count childNodesPtr - children <- traverse childNodeToTerm nodes + children <- traverse toTerm nodes return $! filter isNonEmpty children - childNodeToTerm childNode = toTerm childNode (slice (offsetRange (nodeRange childNode) (negate (start range))) source) range = nodeRange node copyNamed = ts_node_copy_named_child_nodes document copyAll = ts_node_copy_child_nodes document From ec0c5420a3a56ce82cd4c15c6fee739f7dd4e432 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:00:46 -0400 Subject: [PATCH 140/154] Use the SyntaxTerm type synonym. --- src/TreeSitter.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 730f50c34..3eb08c5c4 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -20,7 +20,6 @@ import qualified Language.C as C import qualified Language.Go as Go import qualified Language.TypeScript as TS import qualified Language.Ruby as Ruby -import qualified Syntax import Foreign import Foreign.C.String (peekCString) import Foreign.Marshal.Array (allocaArray) @@ -35,7 +34,7 @@ import qualified Text.Parser.TreeSitter.TypeScript as TS import Info -- | Returns a TreeSitter parser for the given language and TreeSitter grammar. -treeSitterParser :: Ptr TS.Language -> Blob -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) +treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm Text DefaultFields) treeSitterParser language blob = bracket ts_document_new ts_document_free $ \ document -> do ts_document_set_language document language unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do @@ -71,13 +70,13 @@ anaM g = a where a = pure . embed <=< traverse a <=< g -- | Return a parser for a tree sitter language & document. -documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) +documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (SyntaxTerm Text DefaultFields) documentToTerm language document Blob{..} = do root <- alloca (\ rootPtr -> do ts_document_root_node_p document rootPtr peek rootPtr) toTerm root - where toTerm :: Node -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) + where toTerm :: Node -> IO (SyntaxTerm Text DefaultFields) toTerm node = do let source = slice (nodeRange node) blobSource name <- peekCString (nodeType node) From ca68b834e1cc91f86bf243a8f0b3c0113c10f47d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:03:02 -0400 Subject: [PATCH 141/154] Specify language lookup with a list. --- src/TreeSitter.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 3eb08c5c4..f044b9b31 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -174,9 +174,9 @@ categoryForLanguageProductionName = withDefaults . byLanguage languageForTSLanguage :: Ptr TS.Language -> Maybe Language -languageForTSLanguage language - = if language == TS.tree_sitter_c then Just C - else if language == TS.tree_sitter_go then Just Language.Go - else if language == TS.tree_sitter_ruby then Just Ruby - else if language == TS.tree_sitter_typescript then Just TypeScript - else Nothing +languageForTSLanguage = flip lookup + [ (TS.tree_sitter_c, C) + , (TS.tree_sitter_go, Language.Go) + , (TS.tree_sitter_ruby, Ruby) + , (TS.tree_sitter_typescript, TypeScript) + ] From 7902bf683d1e55400462beac3e4abcd166f0b35a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:06:21 -0400 Subject: [PATCH 142/154] Pass blobs to parseToAST. --- src/Semantic/Task.hs | 2 +- src/TreeSitter.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 63eb90d3b..49fdbd1d1 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -208,7 +208,7 @@ runTaskWithOptions options task = do runParser :: Options -> Parser term -> Blob -> Task term runParser options parser blob@Blob{..} = case parser of - ASTParser language -> liftIO $ parseToAST language blobSource + ASTParser language -> liftIO $ parseToAST language blob AssignmentParser parser by assignment -> do ast <- runParser options parser blob case Assignment.assignBy by blobSource assignment ast of diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index f044b9b31..28ef763c0 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -45,10 +45,10 @@ treeSitterParser language blob = bracket ts_document_new ts_document_free $ \ do -- | Parse 'Source' with the given 'TS.Language' and return its AST. -parseToAST :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Source -> IO (A.AST grammar) -parseToAST language source = bracket ts_document_new ts_document_free $ \ document -> do +parseToAST :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Blob -> IO (A.AST grammar) +parseToAST language Blob{..} = bracket ts_document_new ts_document_free $ \ document -> do ts_document_set_language document language - root <- unsafeUseAsCStringLen (sourceBytes source) $ \ (source, len) -> do + root <- unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do ts_document_set_input_string_with_length document source len ts_document_parse_halt_on_error document alloca (\ rootPtr -> do From edcb55a686af5583ee70c5b44ce24ce32d6038d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:08:53 -0400 Subject: [PATCH 143/154] =?UTF-8?q?Move=20the=20source=20adjacent=20to=20w?= =?UTF-8?q?here=20it=E2=80=99s=20used.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/TreeSitter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 28ef763c0..0a02866e0 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -78,12 +78,12 @@ documentToTerm language document Blob{..} = do toTerm root where toTerm :: Node -> IO (SyntaxTerm Text DefaultFields) toTerm node = do - let source = slice (nodeRange node) blobSource name <- peekCString (nodeType node) children <- getChildren (fromIntegral (nodeNamedChildCount node)) copyNamed let allChildren = getChildren (fromIntegral (nodeChildCount node)) copyAll + let source = slice (nodeRange node) blobSource assignTerm language source (range :. categoryForLanguageProductionName language (toS name) :. nodeSpan node :. Nil) children allChildren where getChildren count copy = do nodes <- allocaArray count $ \ childNodesPtr -> do From 8c46ff8afbab7764460dfca2ec20fb9f0fe4ca5d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:15:17 -0400 Subject: [PATCH 144/154] :fire: Syntax record selectors. --- src/Syntax.hs | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index c0e5bd058..fadc80fa4 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -24,36 +24,36 @@ data Syntax a f -- | A function call has an identifier where f is a (Leaf a) and a list of arguments. | FunctionCall f [f] [f] -- | A ternary has a condition, a true case and a false case - | Ternary { ternaryCondition :: f, ternaryCases :: [f] } + | Ternary f [f] -- | An anonymous function has a list of expressions and params. - | AnonymousFunction { params :: [f], expressions :: [f] } + | AnonymousFunction [f] [f] -- | A function has an identifier, possible type arguments, params, a possible type, and list of expressions. - | Function { id :: f, params :: [f], expressions :: [f] } + | Function f [f] [f] -- | An assignment has an identifier where f can be a member access, and the value is another syntax element (function call, leaf, etc.) - | Assignment { assignmentId :: f, value :: f } + | Assignment f f -- | An operator assignment represents expressions with operators like math (e.g x += 1) or conditional (e.g. x ||= 1) assignment. | OperatorAssignment f f -- | A member access contains a syntax, and another syntax that identifies a property or value in the first syntax. -- | e.g. in Javascript x.y represents a member access syntax. - | MemberAccess { memberId :: f, property :: f } + | MemberAccess f f -- | A method call consisting of its target, the method name, and the parameters passed to the method. -- | e.g. in Javascript console.log('hello') represents a method call. - | MethodCall { targetId :: f, methodId :: f, typeArgs :: [f], methodParams :: [f] } + | MethodCall f f [f] [f] -- | An operator can be applied to a list of syntaxes. | Operator [f] -- | A variable declaration. e.g. var foo; | VarDecl [f] -- | A variable assignment in a variable declaration. var foo = bar; - | VarAssignment { varId :: [f], varValue :: f } + | VarAssignment [f] f -- | A subscript access contains a syntax, and another syntax that indefies a property or value in the first syntax. -- | e.g. in Javascript x["y"] represents a subscript access syntax. - | SubscriptAccess { subscriptId :: f, subscriptElement :: f } - | Switch { switchExpr :: [f], cases :: [f] } - | Case { caseExpr :: f, caseStatements :: [f] } + | SubscriptAccess f f + | Switch [f] [f] + | Case f [f] -- | A default case in a switch statement. | DefaultCase [f] - | Select { cases :: [f] } - | Object { objectTy :: Maybe f, keyValues :: [f] } + | Select [f] + | Object (Maybe f) [f] -- | A pair in an Object. e.g. foo: bar or foo => bar | Pair f f -- | A comment. @@ -63,13 +63,13 @@ data Syntax a f | ParseError [f] -- | A for statement has a list of expressions to setup the iteration and then a list of expressions in the body. | For [f] [f] - | DoWhile { doWhileBody :: f, doWhileExpr :: f } - | While { whileExpr :: f, whileBody :: [f] } + | DoWhile f f + | While f [f] | Return [f] | Throw f | Constructor f -- | TODO: Is it a problem that in Ruby, this pattern can work for method def too? - | Try { tryBegin :: [f], catchRescue :: [f], beginElse :: Maybe f, finallyEnsure :: Maybe f } + | Try [f] [f] (Maybe f) (Maybe f) -- | An array literal with list of children. | Array (Maybe f) [f] -- | A class with an identifier, superclass, and a list of definitions. @@ -79,10 +79,10 @@ data Syntax a f -- | An if statement with an expression and maybe more expression clauses. | If f [f] -- | A module with an identifier, and a list of syntaxes. - | Module { moduleId:: f, moduleBody :: [f] } + | Module f [f] -- | An interface with an identifier, a list of clauses, and a list of declarations.. | Interface f [f] [f] - | Namespace { namespaceId:: f, namespaceBody :: [f] } + | Namespace f [f] | Import f [f] | Export (Maybe f) [f] | Yield [f] From 0ba3264f32ea4d9f48a201a4c3e922ba285d7c29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:46:29 -0400 Subject: [PATCH 145/154] Remove the leaf type parameter from Syntax. --- src/Diff.hs | 2 +- src/FDoc/RecursionSchemes.hs | 12 ++++++------ src/FDoc/Term.hs | 8 ++++---- src/Interpreter.hs | 8 ++++---- src/Language.hs | 10 +++++----- src/Language/C.hs | 2 +- src/Language/Go.hs | 2 +- src/Language/Ruby.hs | 2 +- src/Language/TypeScript.hs | 2 +- src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 2 +- src/SplitDiff.hs | 2 +- src/Syntax.hs | 26 ++++++++++++-------------- src/Term.hs | 4 ++-- src/TreeSitter.hs | 4 ++-- test/AlignmentSpec.hs | 18 +++++++++--------- test/Data/Mergeable/Spec.hs | 4 ++-- test/Data/RandomWalkSimilarity/Spec.hs | 2 +- test/InterpreterSpec.hs | 2 +- test/TOCSpec.hs | 14 +++++++------- 20 files changed, 63 insertions(+), 65 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index e90011c17..e2c1c542d 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -14,7 +14,7 @@ import Term type DiffF f annotation = FreeF (TermF f (Both annotation)) (Patch (Term f annotation)) type Diff f annotation = Free (TermF f (Both annotation)) (Patch (Term f annotation)) -type SyntaxDiff leaf fields = Diff (Syntax leaf) (Record fields) +type SyntaxDiff leaf fields = Diff Syntax (Record fields) diffSum :: (Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int diffSum patchCost diff = sum $ fmap patchCost diff diff --git a/src/FDoc/RecursionSchemes.hs b/src/FDoc/RecursionSchemes.hs index afb479273..d546b6806 100644 --- a/src/FDoc/RecursionSchemes.hs +++ b/src/FDoc/RecursionSchemes.hs @@ -25,7 +25,7 @@ structure. The example below adds a new field to the `Record` fields. -} -indexedTermAna :: [leaf] -> Term (Syntax leaf) (Record '[NewField, Range, Category]) +indexedTermAna :: [Text] -> Term Syntax (Record '[NewField, Range, Category]) indexedTermAna childrenLeaves = ana coalgebra (indexedTerm childrenLeaves) where coalgebra term = (NewField :. (extract term)) :< unwrap term @@ -43,7 +43,7 @@ structure to a new shape. The example below adds a new field to the `Record` fields. -} -indexedTermCata :: [leaf] -> Term (Syntax leaf) (Record '[NewField, Range, Category]) +indexedTermCata :: [Text] -> Term Syntax (Record '[NewField, Range, Category]) indexedTermCata childrenLeaves = cata algebra (indexedTerm childrenLeaves) where algebra :: Functor f => CofreeF f (Record t) (Cofree f (Record (NewField : t))) -> Cofree f (Record (NewField : t)) @@ -82,7 +82,7 @@ stringToTermAna "indexed" => the new cofree `Indexed` structure, resulting in a expansion of all possible string terms. -} -stringToTermAna :: String -> Term (Syntax String) (Record '[Range, Category]) +stringToTermAna :: Text -> Term Syntax (Record '[Range, Category]) stringToTermAna = ana coalgebra where coalgebra representation = case representation of @@ -95,7 +95,7 @@ Catamorphism -- construct a list of Strings from a recursive Term structure. The example below shows how to tear down a recursive Term structure into a list of String representation. -} -termToStringCata :: Term (Syntax String) (Record '[Range, Category]) -> [String] +termToStringCata :: Term Syntax (Record '[Range, Category]) -> [Text] termToStringCata = cata algebra where algebra term = case term of @@ -123,7 +123,7 @@ Example Usage: stringTermHylo "indexed" => ["indexed", "leaf1", "leaf2", "leaf3"] -} -stringTermHylo :: String -> [String] +stringTermHylo :: Text -> [Text] stringTermHylo = hylo algebra coalgebra where algebra term = case term of @@ -177,7 +177,7 @@ Final shape: ] -} -termPara :: Term (Syntax String) (Record '[Range, Category]) -> [(Term (Syntax String) (Record '[Range, Category]), String)] +termPara :: Term Syntax (Record '[Range, Category]) -> [(Term Syntax (Record '[Range, Category]), Text)] termPara = para algebra where algebra term = case term of diff --git a/src/FDoc/Term.hs b/src/FDoc/Term.hs index 0d90ebdcf..5f0041f14 100644 --- a/src/FDoc/Term.hs +++ b/src/FDoc/Term.hs @@ -32,7 +32,7 @@ Example (from GHCi): -} -leafTermF :: leaf -> TermF (Syntax leaf) (Record '[Range, Category]) b +leafTermF :: Text -> TermF Syntax (Record '[Range, Category]) b leafTermF leaf = (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf leaf {- @@ -57,11 +57,11 @@ Example (from GHCi): > Leaf "example" -} -leafTerm :: leaf -> Cofree (Syntax leaf) (Record '[Range, Category]) +leafTerm :: Text -> Cofree Syntax (Record '[Range, Category]) leafTerm = cofree . leafTermF -indexedTermF :: [leaf] -> TermF (Syntax leaf) (Record '[Range, Category]) (Term (Syntax leaf) (Record '[Range, Category])) +indexedTermF :: [Text] -> TermF Syntax (Record '[Range, Category]) (Term Syntax (Record '[Range, Category])) indexedTermF leaves = (Range 1 10 :. Category.MethodCall :. Nil) :< Indexed (leafTerm <$> leaves) -indexedTerm :: [leaf] -> Term (Syntax leaf) (Record '[Range, Category]) +indexedTerm :: [Text] -> Term Syntax (Record '[Range, Category]) indexedTerm leaves = cofree $ indexedTermF leaves diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 91c18dcae..a15b269e2 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -23,9 +23,9 @@ import Term -- | Diff two terms recursively, given functions characterizing the diffing. -diffTerms :: (Eq leaf, Hashable leaf, HasField fields Category) - => Both (SyntaxTerm leaf fields) -- ^ A pair of terms representing the old and new state, respectively. - -> SyntaxDiff leaf fields +diffTerms :: HasField fields Category + => Both (SyntaxTerm leaf fields) -- ^ A pair of terms representing the old and new state, respectively. + -> SyntaxDiff leaf fields diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparableByCategory) -- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff. @@ -55,7 +55,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) Replace a b -> pure (replacing a b) -- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram. -getLabel :: HasField fields Category => TermF (Syntax leaf) (Record fields) a -> (Category, Maybe leaf) +getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text) getLabel (h :< t) = (Info.category h, case t of Leaf s -> Just s _ -> Nothing) diff --git a/src/Language.hs b/src/Language.hs index e819e4e21..cb06dcb30 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -36,7 +36,7 @@ languageForType mediaType = case mediaType of ".py" -> Just Python _ -> Nothing -toVarDeclOrAssignment :: HasField fields Category => Term (S.Syntax Text) (Record fields) -> Term (S.Syntax Text) (Record fields) +toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) toVarDeclOrAssignment child = case unwrap child of S.Indexed [child', assignment] -> cofree $ setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment S.Indexed [child'] -> cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child'] @@ -44,22 +44,22 @@ toVarDeclOrAssignment child = case unwrap child of S.VarAssignment _ _ -> child _ -> toVarDecl child -toVarDecl :: HasField fields Category => Term (S.Syntax Text) (Record fields) -> Term (S.Syntax Text) (Record fields) +toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) toVarDecl child = cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child] -toTuple :: Term (S.Syntax Text) (Record fields) -> [Term (S.Syntax Text) (Record fields)] +toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)] toTuple child | S.Indexed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)] toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)] toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] toTuple child = pure child -toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax Text (SyntaxTerm Text fields)) +toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax (SyntaxTerm Text fields)) toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of (prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment (_, [_]) -> Just $ S.VarDecl children _ -> Nothing -toInterface :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax Text (SyntaxTerm Text fields)) +toInterface :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax (SyntaxTerm Text fields)) toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of (clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body)) _ -> Nothing diff --git a/src/Language/C.hs b/src/Language/C.hs index 6538af1d9..2647808fc 100644 --- a/src/Language/C.hs +++ b/src/Language/C.hs @@ -11,7 +11,7 @@ termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ _ _ = Nothing diff --git a/src/Language/Go.hs b/src/Language/Go.hs index e88946f7a..931c5fd3f 100644 --- a/src/Language/Go.hs +++ b/src/Language/Go.hs @@ -11,7 +11,7 @@ termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment source category children = case (category, children) of (Module, [moduleName]) -> Just $ S.Module moduleName [] (Import, [importName]) -> Just $ S.Import importName [] diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index 739484749..98a722fe6 100644 --- a/src/Language/Ruby.hs +++ b/src/Language/Ruby.hs @@ -13,7 +13,7 @@ termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ category children = case (category, children) of (ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v diff --git a/src/Language/TypeScript.hs b/src/Language/TypeScript.hs index 625268cb0..fa6481576 100644 --- a/src/Language/TypeScript.hs +++ b/src/Language/TypeScript.hs @@ -12,7 +12,7 @@ termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ category children = case (category, children) of (Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value diff --git a/src/Renderer.hs b/src/Renderer.hs index 24c233840..b5c870cdc 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -70,7 +70,7 @@ data SomeRenderer f where deriving instance Show (SomeRenderer f) -identifierAlgebra :: RAlgebra (CofreeF (Syntax Text) a) (Cofree (Syntax Text) a) (Maybe Identifier) +identifierAlgebra :: RAlgebra (CofreeF Syntax a) (Cofree Syntax a) (Maybe Identifier) identifierAlgebra (_ :< syntax) = case syntax of S.Assignment f _ -> identifier f S.Class f _ _ -> identifier f diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index e25ff737e..92b9b3a35 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -100,7 +100,7 @@ instance ToJSON a => ToJSONFields (Patch a) where instance ToJSON a => ToJSONFields [a] where toJSONFields list = [ "children" .= list ] -instance ToJSON recur => ToJSONFields (Syntax leaf recur) 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 diff --git a/src/SplitDiff.hs b/src/SplitDiff.hs index 79cc546b4..baa476d7b 100644 --- a/src/SplitDiff.hs +++ b/src/SplitDiff.hs @@ -24,4 +24,4 @@ getRange diff = byteRange $ case runFree diff of -- | A diff with only one side’s annotations. type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation)) -type SplitSyntaxDiff leaf fields = SplitDiff (Syntax leaf) (Record fields) +type SplitSyntaxDiff leaf fields = SplitDiff Syntax (Record fields) diff --git a/src/Syntax.hs b/src/Syntax.hs index fadc80fa4..81821293b 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -7,6 +7,7 @@ import Data.Functor.Classes import Data.Functor.Classes.Eq.Generic import Data.Functor.Listable import Data.Mergeable +import Data.Text (pack) import GHC.Generics import Prologue @@ -14,9 +15,9 @@ import Prologue -- -- 'a' is the type of leaves in the syntax tree, typically 'Text', but possibly some datatype representing different leaves more precisely. -- 'f' is the type representing another level of the tree, e.g. the children of branches. Often 'Cofree', 'Free' or similar. -data Syntax a f +data Syntax f -- | A terminal syntax node, e.g. an identifier, or atomic literal. - = Leaf a + = Leaf Text -- | An ordered branch of child nodes, expected to be variadic in the grammar, e.g. a list of statements or uncurried function parameters. | Indexed [f] -- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands. @@ -57,7 +58,7 @@ data Syntax a f -- | A pair in an Object. e.g. foo: bar or foo => bar | Pair f f -- | A comment. - | Comment a + | Comment Text -- | A term preceded or followed by any number of comments. | Commented [f] (Maybe f) | ParseError [f] @@ -113,16 +114,16 @@ data Syntax a f deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData) -extractLeafValue :: Syntax leaf b -> Maybe leaf +extractLeafValue :: Syntax a -> Maybe Text extractLeafValue syntax = case syntax of Leaf a -> Just a _ -> Nothing -- Instances -instance Listable2 Syntax where - liftTiers2 leaf recur - = liftCons1 leaf Leaf +instance Listable1 Syntax where + liftTiers recur + = liftCons1 (pack `mapT` tiers) Leaf \/ liftCons1 (liftTiers recur) Indexed \/ liftCons1 (liftTiers recur) Fixed \/ liftCons3 recur (liftTiers recur) (liftTiers recur) FunctionCall @@ -142,7 +143,7 @@ instance Listable2 Syntax where \/ liftCons1 (liftTiers recur) Select \/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Object \/ liftCons2 recur recur Pair - \/ liftCons1 leaf Comment + \/ liftCons1 (pack `mapT` tiers) Comment \/ liftCons2 (liftTiers recur) (liftTiers recur) Commented \/ liftCons1 (liftTiers recur) Syntax.ParseError \/ liftCons2 (liftTiers recur) (liftTiers recur) For @@ -177,13 +178,10 @@ instance Listable2 Syntax where \/ liftCons2 recur recur Send \/ liftCons1 (liftTiers recur) DefaultCase -instance Listable leaf => Listable1 (Syntax leaf) where - liftTiers = liftTiers2 tiers - -instance (Listable leaf, Listable recur) => Listable (Syntax leaf recur) where +instance Listable recur => Listable (Syntax recur) where tiers = tiers1 -instance Eq leaf => Eq1 (Syntax leaf) where +instance Eq1 Syntax where liftEq = genericLiftEq -instance Eq leaf => GAlign (Syntax leaf) +instance GAlign Syntax diff --git a/src/Term.hs b/src/Term.hs index 0ed7e35e8..d6c6ddc4e 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -14,8 +14,8 @@ type Term f = Cofree f type TermF = CofreeF -- | A Term with a Syntax leaf and a record of fields. -type SyntaxTerm leaf fields = Term (Syntax leaf) (Record fields) -type SyntaxTermF leaf fields = TermF (Syntax leaf) (Record fields) +type SyntaxTerm leaf fields = Term Syntax (Record fields) +type SyntaxTermF leaf fields = TermF Syntax (Record fields) instance (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where rnf = rnf . runCofree diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 0a02866e0..4f97658ad 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -110,7 +110,7 @@ assignTerm language source annotation children allChildren = cofree . (annotation :<) <$> case assignTermByLanguage source (category annotation) children of Just a -> pure a _ -> defaultTermAssignment source (category annotation) children allChildren - where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) + where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) assignTermByLanguage = case languageForTSLanguage language of Just C -> C.termAssignment Just Language.Go -> Go.termAssignment @@ -118,7 +118,7 @@ assignTerm language source annotation children allChildren = Just TypeScript -> TS.termAssignment _ -> \ _ _ _ -> Nothing -defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax Text (SyntaxTerm Text DefaultFields)) +defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax (SyntaxTerm Text DefaultFields)) defaultTermAssignment source category children allChildren | category `elem` operatorCategories = S.Operator <$> allChildren | otherwise = pure $! case (category, children) of diff --git a/test/AlignmentSpec.hs b/test/AlignmentSpec.hs index 3a84afe34..e519e597e 100644 --- a/test/AlignmentSpec.hs +++ b/test/AlignmentSpec.hs @@ -31,7 +31,7 @@ spec :: Spec spec = parallel $ do describe "alignBranch" $ do it "produces symmetrical context" $ - alignBranch getRange ([] :: [Join These (SplitDiff (Syntax Text) (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe` + alignBranch getRange ([] :: [Join These (SplitDiff Syntax (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe` [ Join (These (Range 0 2, []) (Range 0 2, [])) , Join (These (Range 2 4, []) @@ -39,7 +39,7 @@ spec = parallel $ do ] it "produces asymmetrical context" $ - alignBranch getRange ([] :: [Join These (SplitDiff (Syntax Text) (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe` + alignBranch getRange ([] :: [Join These (SplitDiff Syntax (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe` [ Join (These (Range 0 2, []) (Range 0 1, [])) , Join (This (Range 2 4, [])) @@ -256,7 +256,7 @@ instance Listable BranchElement where counts :: [Join These (Int, a)] -> Both Int counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered)) -align :: Both Source.Source -> ConstructibleFree (Syntax Text) (Patch (Term (Syntax Text) (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff [] (Record '[Range])) +align :: Both Source.Source -> ConstructibleFree Syntax (Patch (Term Syntax (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff [] (Record '[Range])) align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct info :: Int -> Int -> Record '[Range] @@ -281,14 +281,14 @@ newtype ConstructibleFree f patch annotation = ConstructibleFree { deconstruct : class PatchConstructible p where - insert :: Term (Syntax Text) (Record '[Range]) -> p - delete :: Term (Syntax Text) (Record '[Range]) -> p + insert :: Term Syntax (Record '[Range]) -> p + delete :: Term Syntax (Record '[Range]) -> p -instance PatchConstructible (Patch (Term (Syntax Text) (Record '[Range]))) where +instance PatchConstructible (Patch (Term Syntax (Record '[Range]))) where insert = Insert delete = Delete -instance PatchConstructible (SplitPatch (Term (Syntax Text) (Record '[Range]))) where +instance PatchConstructible (SplitPatch (Term Syntax (Record '[Range]))) where insert = SplitInsert delete = SplitDelete @@ -304,7 +304,7 @@ class SyntaxConstructible s where leaf :: annotation -> Text -> s annotation branch :: annotation -> [s annotation] -> s annotation -instance SyntaxConstructible (ConstructibleFree (Syntax Text) patch) where +instance SyntaxConstructible (ConstructibleFree Syntax patch) where leaf info = ConstructibleFree . free . Free . (info :<) . Leaf branch info = ConstructibleFree . free . Free . (info :<) . Indexed . fmap deconstruct @@ -312,7 +312,7 @@ instance SyntaxConstructible (ConstructibleFree [] patch) where leaf info = ConstructibleFree . free . Free . (info :<) . const [] branch info = ConstructibleFree . free . Free . (info :<) . fmap deconstruct -instance SyntaxConstructible (Cofree (Syntax Text)) where +instance SyntaxConstructible (Cofree Syntax) where info `leaf` value = cofree $ info :< Leaf value info `branch` children = cofree $ info :< Indexed children diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 8aba89d5c..a1a657a8f 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -24,8 +24,8 @@ spec = parallel $ do withAlternativeInstances sequenceAltLaws (Identity `mapT` tiers :: [Tier (Identity Char)]) withAlternativeInstances mergeLaws (Identity `mapT` tiers :: [Tier (Identity Char)]) describe "Syntax" $ do - withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Syntax Char Char)]) - withAlternativeInstances mergeLaws (tiers :: [Tier (Syntax Char Char)]) + withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Syntax Char)]) + withAlternativeInstances mergeLaws (tiers :: [Tier (Syntax Char)]) prop "subsumes catMaybes/Just" $ \ a -> sequenceAlt a `shouldBe` pure (catMaybes (a :: [Maybe Char])) diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index b4537a84c..71ae5577e 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -41,7 +41,7 @@ spec = parallel $ do (beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs))) it "produces unbiased insertions within branches" $ - let (a, b) = (decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf ("a" :: String)) ])), decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "b") ]))) in + let (a, b) = (decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "a") ])), decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "b") ]))) in fmap (bimap stripTerm stripTerm) (rws editDistance canCompare [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ] where canCompare a b = headF a == headF b diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index f7017c61d..3143beeb6 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -21,7 +21,7 @@ spec :: Spec spec = parallel $ do describe "interpret" $ do it "returns a replacement when comparing two unicode equivalent terms" $ - let termA = cofree $ (StringLiteral :. Nil) :< Leaf ("t\776" :: String) + let termA = cofree $ (StringLiteral :. Nil) :< Leaf "t\776" termB = cofree $ (StringLiteral :. Nil) :< Leaf "\7831" in diffTerms (both termA termB) `shouldBe` replacing termA termB diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 90c9b6292..b27f3535c 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -34,21 +34,21 @@ spec :: Spec spec = parallel $ do describe "tableOfContentsBy" $ do prop "drops all nodes with the constant Nothing function" $ - \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (unListableDiff diff :: Diff (Syntax ()) ()) `shouldBe` [] + \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (unListableDiff diff :: Diff Syntax ()) `shouldBe` [] let diffSize = max 1 . sum . fmap (const 1) let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a)) prop "includes all nodes with a constant Just function" $ - \ diff -> let diff' = (unListableDiff diff :: Diff (Syntax ()) ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') () + \ diff -> let diff' = (unListableDiff diff :: Diff Syntax ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') () prop "produces an unchanged entry for identity diffs" $ - \ term -> let term' = (unListableF term :: Term (Syntax ()) (Record '[Category])) in tableOfContentsBy (Just . headF) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')] + \ term -> let term' = (unListableF term :: Term Syntax (Record '[Category])) in tableOfContentsBy (Just . headF) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')] prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $ - \ patch -> let patch' = (unListableF <$> patch :: Patch (Term (Syntax ()) Int)) in tableOfContentsBy (Just . headF) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch')) + \ patch -> let patch' = (unListableF <$> patch :: Patch (Term Syntax Int)) in tableOfContentsBy (Just . headF) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch')) prop "produces changed entries for relevant nodes containing irrelevant patches" $ - \ diff -> let diff' = fmap (1 <$) <$> mapAnnotations (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff (Syntax ()) Int])) in + \ diff -> let diff' = fmap (1 <$) <$> mapAnnotations (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff Syntax Int])) in tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe` if Prologue.null diff' then [Unchanged 0] else replicate (length diff') (Changed 0) @@ -200,7 +200,7 @@ functionInfo :: Record DefaultFields functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil -- Filter tiers for terms that we consider "meaniningful" in TOC summaries. -isMeaningfulTerm :: ListableF (Term (Syntax leaf)) a -> Bool +isMeaningfulTerm :: ListableF (Term Syntax) a -> Bool isMeaningfulTerm a = case runCofree (unListableF a) of (_ :< S.Indexed _) -> False (_ :< S.Fixed _) -> False @@ -209,7 +209,7 @@ isMeaningfulTerm a = case runCofree (unListableF a) of _ -> True -- Filter tiers for terms if the Syntax is a Method or a Function. -isMethodOrFunction :: HasField fields Category => ListableF (Term (Syntax leaf)) (Record fields) -> Bool +isMethodOrFunction :: HasField fields Category => ListableF (Term Syntax) (Record fields) -> Bool isMethodOrFunction a = case runCofree (unListableF a) of (_ :< S.Method{}) -> True (_ :< S.Function{}) -> True From aa8ebfcd736d7ebe83f003134e9d9c0fbcbe4956 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:56:08 -0400 Subject: [PATCH 146/154] Remove the leaf type parameter from SyntaxTerm. --- src/Interpreter.hs | 8 ++++---- src/Language.hs | 4 ++-- src/Language/C.hs | 4 ++-- src/Language/Go.hs | 4 ++-- src/Language/Ruby.hs | 4 ++-- src/Language/TypeScript.hs | 4 ++-- src/Parser.hs | 8 ++++---- src/Renderer.hs | 2 +- src/Renderer/TOC.hs | 2 +- src/Term.hs | 4 ++-- src/TreeSitter.hs | 14 +++++++------- test/Data/RandomWalkSimilarity/Spec.hs | 12 ++++++------ test/DiffSpec.hs | 6 +++--- test/InterpreterSpec.hs | 6 +++--- test/TOCSpec.hs | 2 +- test/TermSpec.hs | 2 +- 16 files changed, 43 insertions(+), 43 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a15b269e2..16f196106 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -24,7 +24,7 @@ import Term -- | Diff two terms recursively, given functions characterizing the diffing. diffTerms :: HasField fields Category - => Both (SyntaxTerm leaf fields) -- ^ A pair of terms representing the old and new state, respectively. + => Both (SyntaxTerm fields) -- ^ A pair of terms representing the old and new state, respectively. -> SyntaxDiff leaf fields diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparableByCategory) @@ -62,9 +62,9 @@ getLabel (h :< t) = (Info.category h, case t of -- | Construct an algorithm to diff a pair of terms. -algorithmWithTerms :: SyntaxTerm leaf fields - -> SyntaxTerm leaf fields - -> Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) (SyntaxDiff leaf fields) +algorithmWithTerms :: SyntaxTerm fields + -> SyntaxTerm fields + -> Algorithm (SyntaxTerm fields) (SyntaxDiff leaf fields) (SyntaxDiff leaf fields) algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> annotate . Indexed <$> byRWS a b diff --git a/src/Language.hs b/src/Language.hs index cb06dcb30..fea480c42 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -53,13 +53,13 @@ toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] toTuple child = pure child -toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax (SyntaxTerm Text fields)) +toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of (prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment (_, [_]) -> Just $ S.VarDecl children _ -> Nothing -toInterface :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax (SyntaxTerm Text fields)) +toInterface :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of (clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body)) _ -> Nothing diff --git a/src/Language/C.hs b/src/Language/C.hs index 2647808fc..e39cec1f3 100644 --- a/src/Language/C.hs +++ b/src/Language/C.hs @@ -10,8 +10,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ _ _ = Nothing diff --git a/src/Language/Go.hs b/src/Language/Go.hs index 931c5fd3f..71257694e 100644 --- a/src/Language/Go.hs +++ b/src/Language/Go.hs @@ -10,8 +10,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment source category children = case (category, children) of (Module, [moduleName]) -> Just $ S.Module moduleName [] (Import, [importName]) -> Just $ S.Import importName [] diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index 98a722fe6..d09936155 100644 --- a/src/Language/Ruby.hs +++ b/src/Language/Ruby.hs @@ -12,8 +12,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ category children = case (category, children) of (ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v diff --git a/src/Language/TypeScript.hs b/src/Language/TypeScript.hs index fa6481576..6b115e5e2 100644 --- a/src/Language/TypeScript.hs +++ b/src/Language/TypeScript.hs @@ -11,8 +11,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ category children = case (category, children) of (Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value diff --git a/src/Parser.hs b/src/Parser.hs index 4ba82cbfe..9ade6b2fa 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -48,14 +48,14 @@ data Parser term where -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. -> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's. -- | A tree-sitter parser. - TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm Text DefaultFields) + TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm DefaultFields) -- | A parser for 'Markdown' using cmark. MarkdownParser :: Parser (AST CMark.NodeType) -- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines. - LineByLineParser :: Parser (SyntaxTerm Text DefaultFields) + LineByLineParser :: Parser (SyntaxTerm DefaultFields) -- | Return a 'Language'-specific 'Parser', if one exists, falling back to the 'LineByLineParser'. -parserForLanguage :: Maybe Language -> Parser (SyntaxTerm Text DefaultFields) +parserForLanguage :: Maybe Language -> Parser (SyntaxTerm DefaultFields) parserForLanguage Nothing = LineByLineParser parserForLanguage (Just language) = case language of C -> TreeSitterParser tree_sitter_c @@ -80,6 +80,6 @@ markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node -- | A fallback parser that treats a file simply as rows of strings. -lineByLineParser :: Source -> SyntaxTerm Text DefaultFields +lineByLineParser :: Source -> SyntaxTerm 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)) diff --git a/src/Renderer.hs b/src/Renderer.hs index b5c870cdc..bc78281e2 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -56,7 +56,7 @@ data TermRenderer output where -- | Render to a 'ByteString' formatted as nested s-expressions. SExpressionTermRenderer :: TermRenderer ByteString -- | “Render” by returning the computed 'SyntaxTerm'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for SemanticSpec.hs. - IdentityTermRenderer :: TermRenderer (Maybe (SyntaxTerm Text DefaultFields)) + IdentityTermRenderer :: TermRenderer (Maybe (SyntaxTerm DefaultFields)) deriving instance Eq (TermRenderer output) deriving instance Show (TermRenderer output) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 62f5eb626..fb884f98c 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -93,7 +93,7 @@ declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Decl -- | Compute 'Declaration's for methods and functions in 'Syntax'. -syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF Text fields) (SyntaxTerm Text fields) (Maybe Declaration) +syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration) syntaxDeclarationAlgebra Blob{..} r = case tailF r of S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) diff --git a/src/Term.hs b/src/Term.hs index d6c6ddc4e..05b896a8a 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -14,8 +14,8 @@ type Term f = Cofree f type TermF = CofreeF -- | A Term with a Syntax leaf and a record of fields. -type SyntaxTerm leaf fields = Term Syntax (Record fields) -type SyntaxTermF leaf fields = TermF Syntax (Record fields) +type SyntaxTerm fields = Term Syntax (Record fields) +type SyntaxTermF fields = TermF Syntax (Record fields) instance (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where rnf = rnf . runCofree diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 4f97658ad..b3078c1e0 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -34,7 +34,7 @@ import qualified Text.Parser.TreeSitter.TypeScript as TS import Info -- | Returns a TreeSitter parser for the given language and TreeSitter grammar. -treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm Text DefaultFields) +treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm DefaultFields) treeSitterParser language blob = bracket ts_document_new ts_document_free $ \ document -> do ts_document_set_language document language unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do @@ -70,13 +70,13 @@ anaM g = a where a = pure . embed <=< traverse a <=< g -- | Return a parser for a tree sitter language & document. -documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (SyntaxTerm Text DefaultFields) +documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (SyntaxTerm DefaultFields) documentToTerm language document Blob{..} = do root <- alloca (\ rootPtr -> do ts_document_root_node_p document rootPtr peek rootPtr) toTerm root - where toTerm :: Node -> IO (SyntaxTerm Text DefaultFields) + where toTerm :: Node -> IO (SyntaxTerm DefaultFields) toTerm node = do name <- peekCString (nodeType node) @@ -95,7 +95,7 @@ documentToTerm language document Blob{..} = do copyNamed = ts_node_copy_named_child_nodes document copyAll = ts_node_copy_child_nodes document -isNonEmpty :: HasField fields Category => SyntaxTerm Text fields -> Bool +isNonEmpty :: HasField fields Category => SyntaxTerm fields -> Bool isNonEmpty = (/= Empty) . category . extract nodeRange :: Node -> Range @@ -105,12 +105,12 @@ nodeSpan :: Node -> Span nodeSpan Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint) where pointPos TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn) -assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (SyntaxTerm Text DefaultFields) +assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) assignTerm language source annotation children allChildren = cofree . (annotation :<) <$> case assignTermByLanguage source (category annotation) children of Just a -> pure a _ -> defaultTermAssignment source (category annotation) children allChildren - where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) + where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) assignTermByLanguage = case languageForTSLanguage language of Just C -> C.termAssignment Just Language.Go -> Go.termAssignment @@ -118,7 +118,7 @@ assignTerm language source annotation children allChildren = Just TypeScript -> TS.termAssignment _ -> \ _ _ _ -> Nothing -defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax (SyntaxTerm Text DefaultFields)) +defaultTermAssignment :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (S.Syntax (SyntaxTerm DefaultFields)) defaultTermAssignment source category children allChildren | category `elem` operatorCategories = S.Operator <$> allChildren | otherwise = pure $! case (category, children) of diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index 71ae5577e..f0ef99eb5 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -23,19 +23,19 @@ spec = parallel $ do let positively = succ . abs describe "pqGramDecorator" $ do prop "produces grams with stems of the specified length" $ - \ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead) + \ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead) prop "produces grams with bases of the specified width" $ - \ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead) + \ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead) describe "featureVectorDecorator" $ do prop "produces a vector of the specified dimension" $ - \ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead) + \ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead) describe "rws" $ do prop "produces correct diffs" $ - \ (as, bs) -> let tas = decorate <$> (unListableF <$> as :: [SyntaxTerm String '[Category]]) - tbs = decorate <$> (unListableF <$> bs :: [SyntaxTerm String '[Category]]) + \ (as, bs) -> let tas = decorate <$> (unListableF <$> as :: [SyntaxTerm '[Category]]) + tbs = decorate <$> (unListableF <$> bs :: [SyntaxTerm '[Category]]) root = cofree . ((Program :. Nil) :<) . Indexed diff = wrap (pure (Program :. Nil) :< Indexed (stripDiff . diffThese <$> rws editDistance canCompare tas tbs)) in (beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs))) @@ -46,7 +46,7 @@ spec = parallel $ do where canCompare a b = headF a == headF b - decorate :: SyntaxTerm leaf '[Category] -> SyntaxTerm leaf '[FeatureVector, Category] + decorate :: SyntaxTerm '[Category] -> SyntaxTerm '[FeatureVector, Category] decorate = defaultFeatureVectorDecorator (category . headF) diffThese = these deleting inserting replacing diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index 77f2670ff..29d331bf4 100644 --- a/test/DiffSpec.hs +++ b/test/DiffSpec.hs @@ -23,15 +23,15 @@ spec = parallel $ do diff `shouldBe` diff prop "equal terms produce identity diffs" $ - \ a -> let term = decorate (unListableF a :: SyntaxTerm String '[Category]) in + \ a -> let term = decorate (unListableF a :: SyntaxTerm '[Category]) in diffCost (diffTerms (pure term)) `shouldBe` 0 describe "beforeTerm" $ do prop "recovers the before term" $ - \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm String '[Category])) in + \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in beforeTerm diff `shouldBe` Just (unListableF a) describe "afterTerm" $ do prop "recovers the after term" $ - \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm String '[Category])) in + \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in afterTerm diff `shouldBe` Just (unListableF b) diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 3143beeb6..c9f86efe7 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -26,15 +26,15 @@ spec = parallel $ do diffTerms (both termA termB) `shouldBe` replacing termA termB prop "produces correct diffs" $ - \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm String '[Category])) in + \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in (beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b)) prop "constructs zero-cost diffs of equal terms" $ - \ a -> let term = (unListableF a :: SyntaxTerm String '[Category]) + \ a -> let term = (unListableF a :: SyntaxTerm '[Category]) diff = diffTerms (pure term) in diffCost diff `shouldBe` 0 it "produces unbiased insertions within branches" $ - let term s = cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ]) :: SyntaxTerm String '[Category] + let term s = cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ]) :: SyntaxTerm '[Category] root = cofree . ((Program :. Nil) :<) . Indexed in diffTerms (both (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` wrap (pure (Program :. Nil) :< Indexed [ inserting (term "a"), cata wrap (fmap pure (term "b")) ]) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index b27f3535c..75562d7c3 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -156,7 +156,7 @@ spec = parallel $ do type Diff' = SyntaxDiff Text (Maybe Declaration ': DefaultFields) -type Term' = SyntaxTerm Text (Maybe Declaration ': DefaultFields) +type Term' = SyntaxTerm (Maybe Declaration ': DefaultFields) numTocSummaries :: Diff' -> Int numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) diff --git a/test/TermSpec.hs b/test/TermSpec.hs index 14dddfa75..d06295c12 100644 --- a/test/TermSpec.hs +++ b/test/TermSpec.hs @@ -14,4 +14,4 @@ spec :: Spec spec = parallel $ do describe "Term" $ do prop "equality is reflexive" $ - \ a -> unListableF a `shouldBe` (unListableF a :: SyntaxTerm String '[Category]) + \ a -> unListableF a `shouldBe` (unListableF a :: SyntaxTerm '[Category]) From ba68f866fd7efd24f0cb6ac4c711542174929b17 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 15:59:02 -0400 Subject: [PATCH 147/154] Remove the leaf type parameter from SyntaxDiff. --- src/Diff.hs | 2 +- src/Interpreter.hs | 4 ++-- src/Renderer.hs | 2 +- test/DiffSpec.hs | 2 +- test/TOCSpec.hs | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index e2c1c542d..3731bfb21 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -14,7 +14,7 @@ import Term type DiffF f annotation = FreeF (TermF f (Both annotation)) (Patch (Term f annotation)) type Diff f annotation = Free (TermF f (Both annotation)) (Patch (Term f annotation)) -type SyntaxDiff leaf fields = Diff Syntax (Record fields) +type SyntaxDiff fields = Diff Syntax (Record fields) diffSum :: (Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int diffSum patchCost diff = sum $ fmap patchCost diff diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 16f196106..8d7fa079f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -25,7 +25,7 @@ import Term -- | Diff two terms recursively, given functions characterizing the diffing. diffTerms :: HasField fields Category => Both (SyntaxTerm fields) -- ^ A pair of terms representing the old and new state, respectively. - -> SyntaxDiff leaf fields + -> SyntaxDiff fields diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparableByCategory) -- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff. @@ -64,7 +64,7 @@ getLabel (h :< t) = (Info.category h, case t of -- | Construct an algorithm to diff a pair of terms. algorithmWithTerms :: SyntaxTerm fields -> SyntaxTerm fields - -> Algorithm (SyntaxTerm fields) (SyntaxDiff leaf fields) (SyntaxDiff leaf fields) + -> Algorithm (SyntaxTerm fields) (SyntaxDiff fields) (SyntaxDiff fields) algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> annotate . Indexed <$> byRWS a b diff --git a/src/Renderer.hs b/src/Renderer.hs index bc78281e2..ca691a852 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -42,7 +42,7 @@ data DiffRenderer output where -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated. SExpressionDiffRenderer :: DiffRenderer ByteString -- | “Render” by returning the computed 'SyntaxDiff'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for TOCSpec.hs. - IdentityDiffRenderer :: DiffRenderer (Maybe (SyntaxDiff Text (Maybe Declaration ': DefaultFields))) + IdentityDiffRenderer :: DiffRenderer (Maybe (SyntaxDiff (Maybe Declaration ': DefaultFields))) deriving instance Eq (DiffRenderer output) deriving instance Show (DiffRenderer output) diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index 29d331bf4..2c0cdd770 100644 --- a/test/DiffSpec.hs +++ b/test/DiffSpec.hs @@ -19,7 +19,7 @@ spec :: Spec spec = parallel $ do let decorate = defaultFeatureVectorDecorator (category . headF) prop "equality is reflexive" $ - \ a -> let diff = unListableDiff a :: SyntaxDiff String '[Category] in + \ a -> let diff = unListableDiff a :: SyntaxDiff '[Category] in diff `shouldBe` diff prop "equal terms produce identity diffs" $ diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 75562d7c3..9d43e370b 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -155,7 +155,7 @@ spec = parallel $ do toS output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[5,1],\"end\":[5,7]},\"category\":\"Heading 2\",\"term\":\"## Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString) -type Diff' = SyntaxDiff Text (Maybe Declaration ': DefaultFields) +type Diff' = SyntaxDiff (Maybe Declaration ': DefaultFields) type Term' = SyntaxTerm (Maybe Declaration ': DefaultFields) numTocSummaries :: Diff' -> Int From d09c1690d7a32bea9b90d1991cd92c276c51d7fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 16:00:10 -0400 Subject: [PATCH 148/154] Remove the leaf type parameter from SplitSyntaxDiff. --- src/SplitDiff.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SplitDiff.hs b/src/SplitDiff.hs index baa476d7b..b069988ed 100644 --- a/src/SplitDiff.hs +++ b/src/SplitDiff.hs @@ -24,4 +24,4 @@ getRange diff = byteRange $ case runFree diff of -- | A diff with only one side’s annotations. type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation)) -type SplitSyntaxDiff leaf fields = SplitDiff Syntax (Record fields) +type SplitSyntaxDiff fields = SplitDiff Syntax (Record fields) From f1295cfe0bb92efa7f5d276376a96d6e31d41889 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 16:00:36 -0400 Subject: [PATCH 149/154] :fire: SplitSyntaxDiff. --- src/SplitDiff.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/SplitDiff.hs b/src/SplitDiff.hs index b069988ed..eac4aae84 100644 --- a/src/SplitDiff.hs +++ b/src/SplitDiff.hs @@ -3,7 +3,6 @@ module SplitDiff where import Data.Record import Info import Prologue -import Syntax import Term (Term, TermF) -- | A patch to only one side of a diff. @@ -24,4 +23,3 @@ getRange diff = byteRange $ case runFree diff of -- | A diff with only one side’s annotations. type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation)) -type SplitSyntaxDiff fields = SplitDiff Syntax (Record fields) From d6beb353fa0dde7065f7a4a6785b45a6328d7297 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 16:08:05 -0400 Subject: [PATCH 150/154] :fire: unused imports. --- test/Data/RandomWalkSimilarity/Spec.hs | 1 - test/DiffSpec.hs | 1 - test/InterpreterSpec.hs | 1 - test/TermSpec.hs | 1 - 4 files changed, 4 deletions(-) diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index f0ef99eb5..e5dc87f8a 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -7,7 +7,6 @@ import Data.Bifunctor import Data.Functor.Listable import RWS import Data.Record -import Data.String import Data.These import Diff import Info diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index 2c0cdd770..cbaced547 100644 --- a/test/DiffSpec.hs +++ b/test/DiffSpec.hs @@ -5,7 +5,6 @@ import Category import Data.Functor.Both import Data.Functor.Listable import RWS -import Data.String import Diff import Info import Interpreter diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index c9f86efe7..6c33c7444 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -6,7 +6,6 @@ import Data.Functor.Both import Data.Functor.Foldable hiding (Nil) import Data.Functor.Listable import Data.Record -import Data.String import Diff import Interpreter import Patch diff --git a/test/TermSpec.hs b/test/TermSpec.hs index d06295c12..decb4aab4 100644 --- a/test/TermSpec.hs +++ b/test/TermSpec.hs @@ -3,7 +3,6 @@ module TermSpec where import Category import Data.Functor.Listable -import Data.String (String) import Prologue import Term import Test.Hspec (Spec, describe, parallel) From 1f4ba7e09d3a3fe580f8a8793a7e7337d4bbe2fc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 16:15:01 -0400 Subject: [PATCH 151/154] Revert "Lift the operations in Files to MonadIO." This reverts commit 11915d97bf6083c8f4cffaa5cb18b3341e89de48. --- src/Files.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Files.hs b/src/Files.hs index 1bfc734f3..874e5ee08 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} module Files ( readFile , readBlobPairsFromHandle @@ -7,7 +7,6 @@ module Files ) where import Control.Exception (catch, IOException) -import Control.Monad.IO.Class import Data.Aeson import Data.These import Data.Functor.Both @@ -22,9 +21,9 @@ import Prelude (fail) import System.FilePath -- | Read a utf8-encoded file to a 'Blob'. -readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob +readFile :: FilePath -> Maybe Language -> IO Blob.Blob readFile path language = do - raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) + raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw) -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported. @@ -32,7 +31,7 @@ languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . toS . takeExtension -- | Read JSON encoded blob pairs from a handle. -readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob] +readBlobPairsFromHandle :: Handle -> IO [Both Blob.Blob] readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where toBlobPairs BlobDiff{..} = toBlobPair <$> blobs @@ -40,16 +39,16 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs))) -- | Read JSON encoded blobs from a handle. -readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] +readBlobsFromHandle :: Handle -> IO [Blob.Blob] readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs -readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a +readFromHandle :: FromJSON a => Handle -> IO a readFromHandle h = do - input <- liftIO $ BL.hGetContents h + input <- BL.hGetContents h case decode input of Just d -> pure d - Nothing -> liftIO $ die ("invalid input on " <> show h <> ", expecting JSON") + Nothing -> die ("invalid input on " <> show h <> ", expecting JSON") toBlob :: Blob -> Blob.Blob toBlob Blob{..} = Blob.sourceBlob path language' (fromText content) From 145a1ad155dd94507da325f6c3bbf8dd70003bb2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 16:16:38 -0400 Subject: [PATCH 152/154] Revert "Revert "Lift the operations in Files to MonadIO."" This reverts commit 2d5468e38a3050327654bf5251c16fb68660917c. --- src/Files.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Files.hs b/src/Files.hs index 874e5ee08..1bfc734f3 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables #-} module Files ( readFile , readBlobPairsFromHandle @@ -7,6 +7,7 @@ module Files ) where import Control.Exception (catch, IOException) +import Control.Monad.IO.Class import Data.Aeson import Data.These import Data.Functor.Both @@ -21,9 +22,9 @@ import Prelude (fail) import System.FilePath -- | Read a utf8-encoded file to a 'Blob'. -readFile :: FilePath -> Maybe Language -> IO Blob.Blob +readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob readFile path language = do - raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) + raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw) -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported. @@ -31,7 +32,7 @@ languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . toS . takeExtension -- | Read JSON encoded blob pairs from a handle. -readBlobPairsFromHandle :: Handle -> IO [Both Blob.Blob] +readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob] readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where toBlobPairs BlobDiff{..} = toBlobPair <$> blobs @@ -39,16 +40,16 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs))) -- | Read JSON encoded blobs from a handle. -readBlobsFromHandle :: Handle -> IO [Blob.Blob] +readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs -readFromHandle :: FromJSON a => Handle -> IO a +readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a readFromHandle h = do - input <- BL.hGetContents h + input <- liftIO $ BL.hGetContents h case decode input of Just d -> pure d - Nothing -> die ("invalid input on " <> show h <> ", expecting JSON") + Nothing -> liftIO $ die ("invalid input on " <> show h <> ", expecting JSON") toBlob :: Blob -> Blob.Blob toBlob Blob{..} = Blob.sourceBlob path language' (fromText content) From 0c9bc34a1cc280baf76f87ad7ff4575fcdb7316f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 16:16:52 -0400 Subject: [PATCH 153/154] Revert "Lift the operations in Files to MonadIO." This reverts commit 11915d97bf6083c8f4cffaa5cb18b3341e89de48. --- src/Files.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Files.hs b/src/Files.hs index 1bfc734f3..874e5ee08 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} module Files ( readFile , readBlobPairsFromHandle @@ -7,7 +7,6 @@ module Files ) where import Control.Exception (catch, IOException) -import Control.Monad.IO.Class import Data.Aeson import Data.These import Data.Functor.Both @@ -22,9 +21,9 @@ import Prelude (fail) import System.FilePath -- | Read a utf8-encoded file to a 'Blob'. -readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob +readFile :: FilePath -> Maybe Language -> IO Blob.Blob readFile path language = do - raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) + raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw) -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported. @@ -32,7 +31,7 @@ languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . toS . takeExtension -- | Read JSON encoded blob pairs from a handle. -readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob] +readBlobPairsFromHandle :: Handle -> IO [Both Blob.Blob] readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where toBlobPairs BlobDiff{..} = toBlobPair <$> blobs @@ -40,16 +39,16 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs))) -- | Read JSON encoded blobs from a handle. -readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] +readBlobsFromHandle :: Handle -> IO [Blob.Blob] readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs -readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a +readFromHandle :: FromJSON a => Handle -> IO a readFromHandle h = do - input <- liftIO $ BL.hGetContents h + input <- BL.hGetContents h case decode input of Just d -> pure d - Nothing -> liftIO $ die ("invalid input on " <> show h <> ", expecting JSON") + Nothing -> die ("invalid input on " <> show h <> ", expecting JSON") toBlob :: Blob -> Blob.Blob toBlob Blob{..} = Blob.sourceBlob path language' (fromText content) From b83366c2d187d1fd4776c253bc1b728987eb7d29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jul 2017 16:17:39 -0400 Subject: [PATCH 154/154] Revert "Revert "Lift the operations in Files to MonadIO."" This reverts commit 8adcb0fba5275ecde11781256b69b43f601f1037. --- src/Files.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Files.hs b/src/Files.hs index 874e5ee08..1bfc734f3 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables #-} module Files ( readFile , readBlobPairsFromHandle @@ -7,6 +7,7 @@ module Files ) where import Control.Exception (catch, IOException) +import Control.Monad.IO.Class import Data.Aeson import Data.These import Data.Functor.Both @@ -21,9 +22,9 @@ import Prelude (fail) import System.FilePath -- | Read a utf8-encoded file to a 'Blob'. -readFile :: FilePath -> Maybe Language -> IO Blob.Blob +readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob readFile path language = do - raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) + raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw) -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported. @@ -31,7 +32,7 @@ languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . toS . takeExtension -- | Read JSON encoded blob pairs from a handle. -readBlobPairsFromHandle :: Handle -> IO [Both Blob.Blob] +readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob] readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where toBlobPairs BlobDiff{..} = toBlobPair <$> blobs @@ -39,16 +40,16 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs))) -- | Read JSON encoded blobs from a handle. -readBlobsFromHandle :: Handle -> IO [Blob.Blob] +readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs -readFromHandle :: FromJSON a => Handle -> IO a +readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a readFromHandle h = do - input <- BL.hGetContents h + input <- liftIO $ BL.hGetContents h case decode input of Just d -> pure d - Nothing -> die ("invalid input on " <> show h <> ", expecting JSON") + Nothing -> liftIO $ die ("invalid input on " <> show h <> ", expecting JSON") toBlob :: Blob -> Blob.Blob toBlob Blob{..} = Blob.sourceBlob path language' (fromText content)