From a296ec4ca3e626da63396e333eb374ae14ae2c3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 15:54:35 +0100 Subject: [PATCH 001/113] Re-enable the orphan instance warning in Term. --- src/Term.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Term.hs b/src/Term.hs index 918d3d304..d1970900d 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -1,5 +1,4 @@ {-# LANGUAGE RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Term ( Term , TermF From 1a6af2179b5f2bb45756b2302c84d31bd8478b80 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:24:11 +0100 Subject: [PATCH 002/113] Give our own definition of Cofree. --- src/Algorithm.hs | 7 ++-- src/Alignment.hs | 6 ++-- src/Data/Syntax.hs | 4 +-- src/Data/Syntax/Algebra.hs | 8 ++--- src/Data/Syntax/Assignment.hs | 7 ++-- src/Decorators.hs | 3 +- src/Interpreter.hs | 13 ++++--- src/Language.hs | 17 +++++---- src/Language/Markdown.hs | 2 +- src/Language/Markdown/Syntax.hs | 3 +- src/Language/Ruby.hs | 4 +-- src/Parser.hs | 6 ++-- src/RWS.hs | 2 +- src/Renderer.hs | 7 ++-- src/Renderer/JSON.hs | 2 +- src/Renderer/SExpression.hs | 2 +- src/Renderer/TOC.hs | 11 +++--- src/Semantic.hs | 1 - src/Semantic/Task.hs | 3 +- src/Term.hs | 61 ++++++++++++++++++++++++++------- src/TreeSitter.hs | 15 ++++---- 21 files changed, 105 insertions(+), 79 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 2c97488ad..8d8369a7c 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -2,6 +2,7 @@ module Algorithm where import Control.Applicative (liftA2) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad (guard, join) import Control.Monad.Free (wrap) import Control.Monad.Free.Freer hiding (wrap) @@ -88,9 +89,9 @@ instance Show term => Show1 (AlgorithmF term diff) where -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- (represented by a Nothing diff returned from algorithmFor) replace one term with another. algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a) -algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 :<)) <$> algorithmFor f1 f2) - where ann1 :< f1 = runCofree t1 - ann2 :< f2 = runCofree t2 +algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 CofreeF.:<)) <$> algorithmFor f1 f2) + where ann1 CofreeF.:< f1 = runCofree t1 + ann2 CofreeF.:< f2 = runCofree t2 -- | A type class for determining what algorithm to use for diffing two terms. diff --git a/src/Alignment.hs b/src/Alignment.hs index 98d5bf94b..761d47ab8 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -10,7 +10,7 @@ module Alignment import Data.Bifunctor (bimap, first, second) import Control.Arrow ((***)) -import Control.Comonad (extract) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad (join) import Control.Monad.Free import Data.Align @@ -66,12 +66,12 @@ alignPatch sources patch = case patch of -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff. alignSyntax :: (Applicative f, HasField fields Range, Foldable g) => (forall a. f a -> Join These a) -> (TermF [] (Record fields) term -> term) -> (term -> Range) -> f Source -> TermF g (f (Record fields)) [Join These term] -> [Join These term] -alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = +alignSyntax toJoinThese toNode getRange sources (infos CofreeF.:< syntax) = catMaybes $ wrapInBranch <$> alignBranch getRange (join (toList syntax)) bothRanges where bothRanges = modifyJoin (fromThese [] []) lineRanges lineRanges = toJoinThese $ sourceLineRangesWithin . byteRange <$> infos <*> sources wrapInBranch = applyThese $ toJoinThese (makeNode <$> infos) - makeNode info (range, children) = toNode (setByteRange info range :< children) + makeNode info (range, children) = toNode (setByteRange info range CofreeF.:< children) -- | Given a function to get the range, a list of already-aligned children, and the lists of ranges spanned by a branch, return the aligned lines. alignBranch :: (term -> Range) -> [Join These term] -> Both [Range] -> [Join These (Range, [term])] diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index f84452bbf..8dcd85c4c 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -3,7 +3,7 @@ module Data.Syntax where import Algorithm import Control.Applicative -import Control.Comonad.Trans.Cofree (headF) +import Control.Comonad.Trans.Cofree (CofreeF(..)) import Control.Monad.Error.Class hiding (Error) import Data.Align.Generic import Data.ByteString (ByteString) @@ -23,7 +23,7 @@ import Data.Text.Encoding (decodeUtf8With) import Data.Union import GHC.Generics import GHC.Stack -import Term +import Term hiding ((:<)) -- Combinators diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index 1613348a5..6ff97f6e0 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -8,7 +8,7 @@ module Data.Syntax.Algebra , cyclomaticComplexityAlgebra ) where -import Control.Comonad (extract) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.Functor.Foldable @@ -34,7 +34,7 @@ decoratorWithAlgebra :: Functor f => RAlgebra (Base (Term f (Record fs))) (Term f (Record fs)) a -- ^ An R-algebra on terms. -> Term f (Record fs) -- ^ A term to decorate with values produced by the R-algebra. -> Term f (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra. -decoratorWithAlgebra alg = para $ \ c@(a :< f) -> cofree $ (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f +decoratorWithAlgebra alg = para $ \ c@(a CofreeF.:< f) -> (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f newtype Identifier = Identifier ByteString @@ -44,7 +44,7 @@ newtype Identifier = Identifier ByteString -- -- Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not. identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier) -identifierAlgebra (_ :< union) = case union of +identifierAlgebra (_ CofreeF.:< union) = case union of _ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s) _ | Just Declaration.Class{..} <- prj union -> classIdentifier _ | Just Declaration.Method{..} <- prj union -> methodName @@ -60,7 +60,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int -- TODO: Anonymous functions should not increase parent scope’s complexity. -- TODO: Inner functions should not increase parent scope’s complexity. cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity -cyclomaticComplexityAlgebra (_ :< union) = case union of +cyclomaticComplexityAlgebra (_ CofreeF.:< union) = case union of _ | Just Declaration.Method{} <- prj union -> succ (sum union) _ | Just Statement.Return{} <- prj union -> succ (sum union) _ | Just Statement.Yield{} <- prj union -> succ (sum union) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index feb247802..b10b684a7 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -95,8 +95,7 @@ module Data.Syntax.Assignment import Control.Arrow ((&&&)) import Control.Applicative -import Control.Comonad.Cofree as Cofree -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..), headF) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad (guard) import Control.Monad.Error.Class hiding (Error) import Control.Monad.Free.Freer @@ -117,7 +116,7 @@ import qualified Data.Source as Source (Source, slice, sourceBytes) import GHC.Stack import qualified Info import Prelude hiding (until) -import Term (runCofree) +import Term as Cofree import Text.Parser.Combinators as Parsers import TreeSitter.Language @@ -294,7 +293,7 @@ withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallSta withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action skipTokens :: Symbol grammar => State ast grammar -> State ast grammar -skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . CofreeF.headF . runCofree) (stateNodes state) } +skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . headF . runCofree) (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 ast grammar -> State ast grammar diff --git a/src/Decorators.hs b/src/Decorators.hs index 7b646e893..7d3e48e37 100644 --- a/src/Decorators.hs +++ b/src/Decorators.hs @@ -5,6 +5,7 @@ module Decorators , constructorLabel ) where +import Control.Comonad.Trans.Cofree (CofreeF(..)) import Data.Aeson import Data.ByteString.Char8 (ByteString, pack, unpack) import Data.Functor.Classes (Show1 (liftShowsPrec)) @@ -13,7 +14,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Union import GHC.Generics import Renderer.JSON -import Term +import Term hiding ((:<)) -- | Compute a 'ByteString' label for a 'Show1'able 'Term'. -- diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 75fe7c5e1..cd5f4426c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -7,8 +7,7 @@ module Interpreter ) where import Algorithm -import Control.Comonad (extract) -import Control.Comonad.Cofree (unwrap) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad.Free (cutoff, wrap) import Control.Monad.Free.Freer hiding (cutoff, wrap) import Data.Align.Generic @@ -52,7 +51,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) decompose step = case step of Diff t1 t2 -> refine t1 t2 Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of - Just result -> wrap . (both (extract t1) (extract t2) :<) <$> sequenceA result + Just result -> wrap . (both (extract t1) (extract t2) CofreeF.:<) <$> sequenceA result _ -> byReplacing t1 t2 RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs) Delete a -> pure (deleting a) @@ -61,7 +60,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) -- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram. getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text) -getLabel (h :< t) = (Info.category h, case t of +getLabel (h CofreeF.:< t) = (Info.category h, case t of Leaf s -> Just s _ -> Nothing) @@ -107,16 +106,16 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of <*> byRWS bodyA bodyB _ -> linearly t1 t2 where - annotate = wrap . (both (extract t1) (extract t2) :<) + annotate = wrap . (both (extract t1) (extract t2) CofreeF.:<) -- | Test whether two terms are comparable by their Category. comparableByCategory :: HasField fields Category => ComparabilityRelation f fields -comparableByCategory (a :< _) (b :< _) = category a == category b +comparableByCategory (a CofreeF.:< _) (b CofreeF.:< _) = category a == category b -- | Test whether two terms are comparable by their constructor. comparableByConstructor :: GAlign f => ComparabilityRelation f fields -comparableByConstructor (_ :< a) (_ :< b) = isJust (galign a b) +comparableByConstructor (_ CofreeF.:< a) (_ CofreeF.:< b) = isJust (galign a b) -- | How many nodes to consider for our constant-time approximation to tree edit distance. diff --git a/src/Language.hs b/src/Language.hs index 95457d4d5..c2e04f64b 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DataKinds, DeriveGeneric, DeriveAnyClass #-} module Language where -import Control.Comonad -import Control.Comonad.Trans.Cofree hiding (cofree) +import Control.Comonad.Trans.Cofree hiding (cofree, (:<)) import Control.DeepSeq import Data.Aeson import Data.Foldable @@ -40,19 +39,19 @@ languageForType mediaType = case mediaType of 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'] - S.VarDecl _ -> cofree $ setCategory (extract child) VarDecl :< unwrap child + S.Indexed [child', assignment] -> setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment + S.Indexed [child'] -> setCategory (extract child) VarDecl :< S.VarDecl [child'] + S.VarDecl _ -> setCategory (extract child) VarDecl :< unwrap child S.VarAssignment _ _ -> child _ -> toVarDecl child toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) -toVarDecl child = cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child] +toVarDecl child = setCategory (extract child) VarDecl :< S.VarDecl [child] 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 | S.Indexed [key,value] <- unwrap child = [extract child :< S.Pair key value] +toTuple child | S.Fixed [key,value] <- unwrap child = [extract child :< S.Pair key value] +toTuple child | S.Leaf c <- unwrap child = [extract child :< S.Comment c] toTuple child = pure child toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index dfd770402..4840226fa 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -5,7 +5,6 @@ module Language.Markdown , toGrammar ) where -import Control.Comonad.Cofree as Cofree import Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import CMarkGFM import Data.Ix @@ -13,6 +12,7 @@ import Data.Source import qualified Data.Syntax.Assignment as A (AST, Node(..)) import Info import TreeSitter.Language (Symbol(..), SymbolType(..)) +import Term as Cofree data Grammar = Document diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index bf434f89f..a22a2011e 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -6,8 +6,6 @@ module Language.Markdown.Syntax , Term ) where -import Control.Comonad.Cofree (Cofree(..), unwrap) -import Control.Comonad.Trans.Cofree (CofreeF, headF, tailF) import qualified CMarkGFM import Data.ByteString (ByteString) import Data.Function (on) @@ -22,6 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) +import Term (Cofree(..), CofreeF, unwrap, headF, tailF) import qualified Term type Syntax = diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index d76db7809..dacbcfb24 100644 --- a/src/Language/Ruby.hs +++ b/src/Language/Ruby.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DataKinds #-} module Language.Ruby where -import Control.Comonad -import Control.Comonad.Cofree import Data.Foldable (toList) import Data.List (partition) import Data.Semigroup @@ -11,7 +9,7 @@ import Data.Text (Text) import Info import Language import qualified Syntax as S -import Term hiding ((:<)) +import Term termAssignment :: Source -- ^ The source of the term. diff --git a/src/Parser.hs b/src/Parser.hs index 31afcb865..feeeeecd5 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -11,8 +11,6 @@ module Parser , rubyParser ) where -import Control.Comonad.Cofree (Cofree) -import Control.Comonad.Trans.Cofree (CofreeF) import qualified CMarkGFM import Data.Ix import Data.Record @@ -79,5 +77,5 @@ markdownParser = AssignmentParser MarkdownParser Markdown.assignment -- | A fallback parser that treats a file simply as rows of strings. 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)) +lineByLineParser source = (totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source)) + where toLine line range = (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source)) diff --git a/src/RWS.hs b/src/RWS.hs index d5d1a8541..272e38061 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -30,7 +30,7 @@ import Data.Semigroup hiding (First(..)) import Data.These import Data.Traversable import Patch -import Term +import Term hiding ((:<)) import Data.Array.Unboxed import Data.Functor.Classes import SES diff --git a/src/Renderer.hs b/src/Renderer.hs index 74b820625..28912fc25 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -18,8 +18,7 @@ module Renderer , File(..) ) where -import Control.Comonad.Cofree (Cofree, unwrap) -import Control.Comonad.Trans.Cofree (CofreeF(..)) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.DeepSeq import Data.Aeson (Value, (.=)) import Data.ByteString (ByteString) @@ -35,7 +34,7 @@ import Renderer.Patch as R import Renderer.SExpression as R import Renderer.TOC as R import Syntax as S -import Term (SyntaxTerm) +import Term -- | Specification of renderers for diffs, producing output in the parameter type. data DiffRenderer output where @@ -77,7 +76,7 @@ data SomeRenderer f where deriving instance Show (SomeRenderer f) identifierAlgebra :: RAlgebra (CofreeF Syntax a) (Cofree Syntax a) (Maybe Identifier) -identifierAlgebra (_ :< syntax) = case syntax of +identifierAlgebra (_ CofreeF.:< syntax) = case syntax of S.Assignment f _ -> identifier f S.Class f _ _ -> identifier f S.Export f _ -> f >>= identifier diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 6c9dbd5e3..6937138d5 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -6,7 +6,6 @@ module Renderer.JSON , ToJSONFields(..) ) where -import Control.Comonad.Cofree import qualified Control.Comonad.Trans.Cofree as CofreeF import Control.Monad.Free import qualified Control.Monad.Trans.Free as FreeF @@ -30,6 +29,7 @@ import Info import Language import Patch import Syntax as S +import Term -- -- Diffs diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index a930a4725..6b0451dea 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -13,7 +13,7 @@ import Data.Semigroup import Diff import Patch import Prelude hiding (replicate) -import Term +import Term hiding ((:<)) -- | Returns a ByteString SExpression formatted diff. renderSExpressionDiff :: (ConstrainAll Show fields, Foldable f) => Diff f (Record fields) -> ByteString diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 7feb69e38..769916d17 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -17,8 +17,7 @@ module Renderer.TOC , entrySummary ) where -import Control.Comonad (extract) -import Control.Comonad.Cofree (unwrap) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.DeepSeq import Control.Monad.Free (iter) import Data.Aeson @@ -102,12 +101,12 @@ getDeclaration = getField -- | Produce the annotations of nodes representing declarations. declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields) -declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Declaration) +declaration (annotation CofreeF.:< _) = annotation <$ (getField annotation :: Maybe Declaration) -- | Compute 'Declaration's for methods and functions in 'Syntax'. syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration) -syntaxDeclarationAlgebra Blob{..} (a :< r) = case r of +syntaxDeclarationAlgebra Blob{..} (a CofreeF.:< r) = case r of S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) S.Method _ (identifier, _) (Just (receiver, _)) _ _ @@ -122,7 +121,7 @@ syntaxDeclarationAlgebra Blob{..} (a :< r) = case r of declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply1 Functor fs, HasField fields Range, HasField fields Span) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -declarationAlgebra blob@Blob{..} (a :< r) +declarationAlgebra blob@Blob{..} (a CofreeF.:< r) | Just (Declaration.Function (identifier, _) _ _) <- prj r = Just $ FunctionDeclaration (getSource (extract identifier)) | Just (Declaration.Method _ (identifier, _) _ _) <- prj r = Just $ MethodDeclaration (getSource (extract identifier)) | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage @@ -133,7 +132,7 @@ declarationAlgebra blob@Blob{..} (a :< r) markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, HasField fields Span, Apply1 Functor fs, Apply1 Foldable fs) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -markupSectionAlgebra blob@Blob{..} (a :< r) +markupSectionAlgebra blob@Blob{..} (a CofreeF.:< r) | Just (Markup.Section level (heading, _) _) <- prj r = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage | otherwise = Nothing diff --git a/src/Semantic.hs b/src/Semantic.hs index 1ace758de..c9d673fa4 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -9,7 +9,6 @@ module Semantic import Algorithm hiding (diff) import Control.Applicative ((<|>)) -import Control.Comonad.Cofree (hoistCofree) import Control.Monad ((<=<)) import Data.Align.Generic (GAlign) import Data.Blob diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index c9eb496f2..69a17341b 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -24,6 +24,7 @@ module Semantic.Task , runTaskWithOptions ) where +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Concurrent.STM.TMQueue import Control.Exception import Control.Monad.Error.Class @@ -220,7 +221,7 @@ runParser Options{..} blob@Blob{..} = go LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource) blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ] errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String] - errors = cata $ \ (a :< syntax) -> case syntax of + errors = cata $ \ (a CofreeF.:< syntax) -> case syntax of _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (sourceSpan a) err] _ -> fold syntax logTiming :: String -> Task a -> Task a diff --git a/src/Term.hs b/src/Term.hs index d1970900d..d858071ac 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} module Term ( Term , TermF @@ -9,10 +9,17 @@ module Term , alignCofreeWith , cofree , runCofree -, CofreeF.CofreeF(..) +, Cofree(..) +, extract +, unwrap +, hoistCofree +, CofreeF.headF +, CofreeF.tailF +, CofreeF.CofreeF() ) where -import qualified Control.Comonad.Cofree as Cofree +import Control.Comonad +import Control.Comonad.Cofree.Class import qualified Control.Comonad.Trans.Cofree as CofreeF import Control.DeepSeq import Control.Monad.Free @@ -28,14 +35,17 @@ import Data.Union import Syntax -- | A Term with an abstract syntax tree and an annotation. -type Term f = Cofree.Cofree f +type Term f = Cofree f type TermF = CofreeF.CofreeF +infixr 5 :< +data Cofree f a = a :< f (Cofree f a) + -- | A Term with a Syntax leaf and a record of fields. type SyntaxTerm fields = Term Syntax (Record fields) type SyntaxTermF fields = TermF Syntax (Record fields) -instance (NFData (f (Cofree.Cofree f a)), NFData a, Functor f) => NFData (Cofree.Cofree f a) where +instance (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where rnf = rnf . runCofree instance (NFData a, NFData (f b)) => NFData (CofreeF.CofreeF f a b) where @@ -61,22 +71,47 @@ alignCofreeWith :: Functor f -> Free (TermF f combined) contrasted alignCofreeWith compare contrast combine = go where go terms = fromMaybe (pure (contrast terms)) $ case terms of - These (a1 Cofree.:< f1) (a2 Cofree.:< f2) -> wrap . (combine a1 a2 CofreeF.:<) . fmap go <$> compare f1 f2 + These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 CofreeF.:<) . fmap go <$> compare f1 f2 _ -> Nothing -cofree :: CofreeF.CofreeF f a (Cofree.Cofree f a) -> Cofree.Cofree f a -cofree (a CofreeF.:< f) = a Cofree.:< f +cofree :: CofreeF.CofreeF f a (Cofree f a) -> Cofree f a +cofree (a CofreeF.:< f) = a :< f -runCofree :: Cofree.Cofree f a -> CofreeF.CofreeF f a (Cofree.Cofree f a) -runCofree (a Cofree.:< f) = a CofreeF.:< f +runCofree :: Cofree f a -> CofreeF.CofreeF f a (Cofree f a) +runCofree (a :< f) = a CofreeF.:< f +hoistCofree :: Functor f => (forall a. f a -> g a) -> Cofree f a -> Cofree g a +hoistCofree f = go where go (a :< r) = a :< f (fmap go r) -instance Pretty1 f => Pretty1 (Cofree.Cofree f) where - liftPretty p pl = go where go (a Cofree.:< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f +instance Pretty1 f => Pretty1 (Cofree f) where + liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f -instance (Pretty1 f, Pretty a) => Pretty (Cofree.Cofree f a) where +instance (Pretty1 f, Pretty a) => Pretty (Cofree f a) where pretty = liftPretty pretty prettyList instance Apply1 Pretty1 fs => Pretty1 (Union fs) where liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) + +type instance Base (Cofree f a) = CofreeF.CofreeF f a + +instance Functor f => Recursive (Cofree f a) where project = runCofree +instance Functor f => Corecursive (Cofree f a) where embed = cofree + +instance Functor f => Comonad (Cofree f) where + extract (a :< _) = a + duplicate w = w :< fmap duplicate (unwrap w) + extend f = go where go w = f w :< fmap go (unwrap w) + +instance Functor f => Functor (Cofree f) where + fmap f = go where go (a :< r) = f a :< fmap go r + +instance Functor f => ComonadCofree f (Cofree f) where + unwrap (_ :< as) = as + {-# INLINE unwrap #-} + +instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where + a1 :< f1 == a2 :< f2 = a1 == a2 && f1 == f2 + +instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where + showsPrec d (a :< f) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 f diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index e00ed9881..fb4a27de2 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -5,8 +5,7 @@ module TreeSitter ) where import Category -import Control.Comonad (extract) -import Control.Comonad.Cofree (unwrap) +import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Exception import Control.Monad ((<=<)) import Data.Blob @@ -66,7 +65,7 @@ toAST node@TS.Node{..} = do children <- allocaArray count $ \ childNodesPtr -> do _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nullPtr nodePtr childNodesPtr (fromIntegral count)) peekArray count childNodesPtr - pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) :< children + pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) CofreeF.:< children anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t anaM g = a where a = pure . embed <=< traverse a <=< g @@ -111,7 +110,7 @@ nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos no assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) assignTerm language source annotation children allChildren = case assignTermByLanguage source (category annotation) children of - Just a -> pure (cofree (annotation :< a)) + Just a -> pure (annotation :< a) _ -> defaultTermAssignment source annotation children allChildren where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) assignTermByLanguage = case languageForTSLanguage language of @@ -122,7 +121,7 @@ assignTerm language source annotation children allChildren = defaultTermAssignment :: Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) defaultTermAssignment source annotation children allChildren - | category annotation `elem` operatorCategories = cofree . (annotation :<) . S.Operator <$> allChildren + | category annotation `elem` operatorCategories = (annotation :<) . S.Operator <$> allChildren | otherwise = case (category annotation, children) of (ParseError, children) -> toTerm $ S.ParseError children @@ -157,7 +156,7 @@ defaultTermAssignment source annotation children allChildren [_, Other t] | t `elem` ["--", "++"] -> MathOperator _ -> Operator - pure (cofree ((setCategory annotation c) :< S.Operator cs)) + pure ((setCategory annotation c) :< S.Operator cs) (Other "binary_expression", _) -> do cs <- allChildren @@ -168,7 +167,7 @@ defaultTermAssignment source annotation children allChildren | s `elem` ["&&", "||"] -> BooleanOperator | s `elem` [">>", ">>=", ">>>", ">>>=", "<<", "<<=", "&", "^", "|"] -> BitwiseOperator _ -> Operator - pure (cofree ((setCategory annotation c) :< S.Operator cs)) + pure ((setCategory annotation c) :< S.Operator cs) (_, []) -> toTerm $ S.Leaf (toText source) (_, children) -> toTerm $ S.Indexed children @@ -183,7 +182,7 @@ defaultTermAssignment source annotation children allChildren , RelationalOperator , BitwiseOperator ] - toTerm = pure . cofree . (annotation :<) + toTerm = pure . (annotation :<) categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category From aa9d4c4f190a4737c2ec000969145584a25580e4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:40:23 +0100 Subject: [PATCH 003/113] Give our own definition of CofreeF. --- src/Algorithm.hs | 5 +---- src/Alignment.hs | 5 ++--- src/Data/Syntax.hs | 5 ++--- src/Data/Syntax/Algebra.hs | 7 +++---- src/Data/Syntax/Assignment.hs | 11 +++++------ src/Decorators.hs | 7 +++---- src/Diff.hs | 3 +-- src/Interpreter.hs | 11 +++++------ src/Language/Markdown.hs | 3 +-- src/Language/Markdown/Syntax.hs | 2 +- src/RWS.hs | 20 ++++++++----------- src/Renderer.hs | 3 +-- src/Renderer/JSON.hs | 5 ++--- src/Renderer/SExpression.hs | 9 ++++----- src/Renderer/TOC.hs | 9 ++++----- src/Semantic/Task.hs | 3 +-- src/SplitDiff.hs | 4 +--- src/Term.hs | 35 ++++++++++++++++++--------------- src/TreeSitter.hs | 2 +- 19 files changed, 65 insertions(+), 84 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 8d8369a7c..2e38b3f96 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -2,7 +2,6 @@ module Algorithm where import Control.Applicative (liftA2) -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad (guard, join) import Control.Monad.Free (wrap) import Control.Monad.Free.Freer hiding (wrap) @@ -89,9 +88,7 @@ instance Show term => Show1 (AlgorithmF term diff) where -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- (represented by a Nothing diff returned from algorithmFor) replace one term with another. algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a) -algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 CofreeF.:<)) <$> algorithmFor f1 f2) - where ann1 CofreeF.:< f1 = runCofree t1 - ann2 CofreeF.:< f2 = runCofree t2 +algorithmForTerms t1@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 :<<)) <$> algorithmFor f1 f2) -- | A type class for determining what algorithm to use for diffing two terms. diff --git a/src/Alignment.hs b/src/Alignment.hs index 761d47ab8..d66d89717 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -10,7 +10,6 @@ module Alignment import Data.Bifunctor (bimap, first, second) import Control.Arrow ((***)) -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad (join) import Control.Monad.Free import Data.Align @@ -66,12 +65,12 @@ alignPatch sources patch = case patch of -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff. alignSyntax :: (Applicative f, HasField fields Range, Foldable g) => (forall a. f a -> Join These a) -> (TermF [] (Record fields) term -> term) -> (term -> Range) -> f Source -> TermF g (f (Record fields)) [Join These term] -> [Join These term] -alignSyntax toJoinThese toNode getRange sources (infos CofreeF.:< syntax) = +alignSyntax toJoinThese toNode getRange sources (infos :<< syntax) = catMaybes $ wrapInBranch <$> alignBranch getRange (join (toList syntax)) bothRanges where bothRanges = modifyJoin (fromThese [] []) lineRanges lineRanges = toJoinThese $ sourceLineRangesWithin . byteRange <$> infos <*> sources wrapInBranch = applyThese $ toJoinThese (makeNode <$> infos) - makeNode info (range, children) = toNode (setByteRange info range CofreeF.:< children) + makeNode info (range, children) = toNode (setByteRange info range :<< children) -- | Given a function to get the range, a list of already-aligned children, and the lists of ranges spanned by a branch, return the aligned lines. alignBranch :: (term -> Range) -> [Join These term] -> Both [Range] -> [Join These (Range, [term])] diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 8dcd85c4c..7c6052934 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -3,7 +3,6 @@ module Data.Syntax where import Algorithm import Control.Applicative -import Control.Comonad.Trans.Cofree (CofreeF(..)) import Control.Monad.Error.Class hiding (Error) import Data.Align.Generic import Data.ByteString (ByteString) @@ -23,7 +22,7 @@ import Data.Text.Encoding (decodeUtf8With) import Data.Union import GHC.Generics import GHC.Stack -import Term hiding ((:<)) +import Term -- Combinators @@ -33,7 +32,7 @@ makeTerm a = makeTerm' a . inj -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a -makeTerm' a f = cofree (sconcat (a :| (headF . runCofree <$> toList f)) :< f) +makeTerm' a f = (sconcat (a :| (headF . runCofree <$> toList f)) :< f) -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index 6ff97f6e0..a0e87c725 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -8,7 +8,6 @@ module Data.Syntax.Algebra , cyclomaticComplexityAlgebra ) where -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.Functor.Foldable @@ -34,7 +33,7 @@ decoratorWithAlgebra :: Functor f => RAlgebra (Base (Term f (Record fs))) (Term f (Record fs)) a -- ^ An R-algebra on terms. -> Term f (Record fs) -- ^ A term to decorate with values produced by the R-algebra. -> Term f (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra. -decoratorWithAlgebra alg = para $ \ c@(a CofreeF.:< f) -> (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f +decoratorWithAlgebra alg = para $ \ c@(a :<< f) -> (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f newtype Identifier = Identifier ByteString @@ -44,7 +43,7 @@ newtype Identifier = Identifier ByteString -- -- Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not. identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier) -identifierAlgebra (_ CofreeF.:< union) = case union of +identifierAlgebra (_ :<< union) = case union of _ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s) _ | Just Declaration.Class{..} <- prj union -> classIdentifier _ | Just Declaration.Method{..} <- prj union -> methodName @@ -60,7 +59,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int -- TODO: Anonymous functions should not increase parent scope’s complexity. -- TODO: Inner functions should not increase parent scope’s complexity. cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity -cyclomaticComplexityAlgebra (_ CofreeF.:< union) = case union of +cyclomaticComplexityAlgebra (_ :<< union) = case union of _ | Just Declaration.Method{} <- prj union -> succ (sum union) _ | Just Statement.Return{} <- prj union -> succ (sum union) _ | Just Statement.Yield{} <- prj union -> succ (sum union) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index b10b684a7..e5127d4a8 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -95,7 +95,6 @@ module Data.Syntax.Assignment import Control.Arrow ((&&&)) import Control.Applicative -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad (guard) import Control.Monad.Error.Class hiding (Error) import Control.Monad.Free.Freer @@ -116,7 +115,7 @@ import qualified Data.Source as Source (Source, slice, sourceBytes) import GHC.Stack import qualified Info import Prelude hiding (until) -import Term as Cofree +import Term import Text.Parser.Combinators as Parsers import TreeSitter.Language @@ -128,7 +127,7 @@ type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar)) data AssignmentF ast grammar a where End :: AssignmentF ast grammar () Location :: AssignmentF ast grammar (Record Location) - CurrentNode :: AssignmentF ast grammar (CofreeF.CofreeF ast (Node grammar) ()) + CurrentNode :: AssignmentF ast grammar (CofreeF ast (Node grammar) ()) Source :: AssignmentF ast grammar ByteString Children :: Assignment ast grammar a -> AssignmentF ast grammar a Advance :: AssignmentF ast grammar () @@ -158,7 +157,7 @@ location :: HasCallStack => Assignment ast grammar (Record Location) location = tracing Location `Then` return -- | Zero-width production of the current node. -currentNode :: HasCallStack => Assignment ast grammar (CofreeF.CofreeF ast (Node grammar) ()) +currentNode :: HasCallStack => Assignment ast grammar (CofreeF ast (Node grammar) ()) currentNode = tracing CurrentNode `Then` return -- | Zero-width match of a node with the given symbol, producing the current node’s location. @@ -259,7 +258,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha run t yield initialState = expectedSymbols `seq` state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes) where atNode (node :< f) = case runTracing t of Location -> yield (nodeLocation node) state - CurrentNode -> yield (node CofreeF.:< (() <$ f)) state + CurrentNode -> yield (node :<< (() <$ f)) state Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state) Children child -> do (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t) @@ -298,7 +297,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n -- | 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 ast grammar -> State ast grammar advanceState state@State{..} - | (Node{..} Cofree.:< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest + | (Node{..} :< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest | otherwise = state -- | State kept while running 'Assignment's. diff --git a/src/Decorators.hs b/src/Decorators.hs index 7d3e48e37..463dac736 100644 --- a/src/Decorators.hs +++ b/src/Decorators.hs @@ -5,7 +5,6 @@ module Decorators , constructorLabel ) where -import Control.Comonad.Trans.Cofree (CofreeF(..)) import Data.Aeson import Data.ByteString.Char8 (ByteString, pack, unpack) import Data.Functor.Classes (Show1 (liftShowsPrec)) @@ -14,18 +13,18 @@ import Data.Text.Encoding (decodeUtf8) import Data.Union import GHC.Generics import Renderer.JSON -import Term hiding ((:<)) +import Term -- | Compute a 'ByteString' label for a 'Show1'able 'Term'. -- -- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that -- constant fields will be included and parametric fields will not be. constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString -constructorNameAndConstantFields (_ :< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "") +constructorNameAndConstantFields (_ :<< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "") -- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's. constructorLabel :: Apply1 ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel -constructorLabel (_ :< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u) +constructorLabel (_ :<< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u) newtype ConstructorLabel = ConstructorLabel ByteString diff --git a/src/Diff.hs b/src/Diff.hs index 444c7979e..76787ce70 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -2,7 +2,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Diff where -import qualified Control.Comonad.Trans.Cofree as CofreeF import Control.DeepSeq import qualified Control.Monad.Free as Free import qualified Control.Monad.Trans.Free as FreeF @@ -31,7 +30,7 @@ diffCost = diffSum $ patchSum termSize -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation) mergeMaybe transform extractAnnotation = Free.iter algebra . fmap transform - where algebra (annotations CofreeF.:< syntax) = cofree . (extractAnnotation annotations CofreeF.:<) <$> sequenceAlt syntax + where algebra (annotations :<< syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax -- | Recover the before state of a diff. beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index cd5f4426c..1aef66bc7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -7,7 +7,6 @@ module Interpreter ) where import Algorithm -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Monad.Free (cutoff, wrap) import Control.Monad.Free.Freer hiding (cutoff, wrap) import Data.Align.Generic @@ -51,7 +50,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) decompose step = case step of Diff t1 t2 -> refine t1 t2 Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of - Just result -> wrap . (both (extract t1) (extract t2) CofreeF.:<) <$> sequenceA result + Just result -> wrap . (both (extract t1) (extract t2) :<<) <$> sequenceA result _ -> byReplacing t1 t2 RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs) Delete a -> pure (deleting a) @@ -60,7 +59,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) -- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram. getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text) -getLabel (h CofreeF.:< t) = (Info.category h, case t of +getLabel (h :<< t) = (Info.category h, case t of Leaf s -> Just s _ -> Nothing) @@ -106,16 +105,16 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of <*> byRWS bodyA bodyB _ -> linearly t1 t2 where - annotate = wrap . (both (extract t1) (extract t2) CofreeF.:<) + annotate = wrap . (both (extract t1) (extract t2) :<<) -- | Test whether two terms are comparable by their Category. comparableByCategory :: HasField fields Category => ComparabilityRelation f fields -comparableByCategory (a CofreeF.:< _) (b CofreeF.:< _) = category a == category b +comparableByCategory (a :<< _) (b :<< _) = category a == category b -- | Test whether two terms are comparable by their constructor. comparableByConstructor :: GAlign f => ComparabilityRelation f fields -comparableByConstructor (_ CofreeF.:< a) (_ CofreeF.:< b) = isJust (galign a b) +comparableByConstructor (_ :<< a) (_ :<< b) = isJust (galign a b) -- | How many nodes to consider for our constant-time approximation to tree edit distance. diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index 4840226fa..c0f62b17e 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -5,7 +5,6 @@ module Language.Markdown , toGrammar ) where -import Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import CMarkGFM import Data.Ix import Data.Source @@ -55,7 +54,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT toTerm within withinSpan (Node position t children) = let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position span = maybe withinSpan toSpan position - in (A.Node (toGrammar t) range span) Cofree.:< (t CofreeF.:< (toTerm range span <$> children)) + in (A.Node (toGrammar t) range span) :< (t :<< (toTerm range span <$> children)) toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index a22a2011e..b21a63ef1 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -20,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) -import Term (Cofree(..), CofreeF, unwrap, headF, tailF) +import Term (Cofree(..), CofreeF(..), unwrap, headF, tailF) import qualified Term type Syntax = diff --git a/src/RWS.hs b/src/RWS.hs index 272e38061..a8f324e9f 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -14,8 +14,6 @@ module RWS ( import Control.Applicative (empty) import Control.Arrow ((&&&)) -import Control.Comonad -import Control.Comonad.Trans.Cofree hiding (cofree, runCofree) import Control.Monad.Free import Control.Monad.State.Strict import Data.Foldable @@ -30,7 +28,7 @@ import Data.Semigroup hiding (First(..)) import Data.These import Data.Traversable import Patch -import Term hiding ((:<)) +import Term import Data.Array.Unboxed import Data.Functor.Classes import SES @@ -228,8 +226,7 @@ featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term) eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields) -eraseFeatureVector term = let record :< functor = runCofree term in - cofree (setFeatureVector record nullFeatureVector :< functor) +eraseFeatureVector (record :< functor) = setFeatureVector record nullFeatureVector :< functor nullFeatureVector :: FeatureVector nullFeatureVector = listArray (0, 0) [0] @@ -263,7 +260,7 @@ featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields labe featureVectorDecorator getLabel p q d = cata collect . pqGramDecorator getLabel p q - where collect ((gram :. rest) :< functor) = cofree ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor) + where collect ((gram :. rest) :<< functor) = ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor) addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector addSubtermVector v term = addVectors v (rhead (extract term)) @@ -281,7 +278,7 @@ pqGramDecorator pqGramDecorator getLabel p q = cata algebra where algebra term = let label = getLabel term in - cofree ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label) + ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) @@ -289,11 +286,10 @@ pqGramDecorator getLabel p q = cata algebra => label -> Term f (Record (Gram label ': fields)) -> State [Maybe label] (Term f (Record (Gram label ': fields))) - assignLabels label a = case runCofree a of - (gram :. rest) :< functor -> do - labels <- get - put (drop 1 labels) - pure $! cofree ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) :< functor) + assignLabels label ((gram :. rest) :< functor) = do + labels <- get + put (drop 1 labels) + pure $! ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) :< functor) siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label] siblingLabels = foldMap (base . rhead . extract) padToSize n list = take n (list <> repeat empty) diff --git a/src/Renderer.hs b/src/Renderer.hs index 28912fc25..39a3468f3 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -18,7 +18,6 @@ module Renderer , File(..) ) where -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.DeepSeq import Data.Aeson (Value, (.=)) import Data.ByteString (ByteString) @@ -76,7 +75,7 @@ data SomeRenderer f where deriving instance Show (SomeRenderer f) identifierAlgebra :: RAlgebra (CofreeF Syntax a) (Cofree Syntax a) (Maybe Identifier) -identifierAlgebra (_ CofreeF.:< syntax) = case syntax of +identifierAlgebra (_ :<< syntax) = case syntax of S.Assignment f _ -> identifier f S.Class f _ _ -> identifier f S.Export f _ -> f >>= identifier diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 6937138d5..667943e57 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -6,7 +6,6 @@ module Renderer.JSON , ToJSONFields(..) ) where -import qualified Control.Comonad.Trans.Cofree as CofreeF import Control.Monad.Free import qualified Control.Monad.Trans.Free as FreeF import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) @@ -89,8 +88,8 @@ instance ToJSONFields a => ToJSONFields (Maybe a) where instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSONFields (Cofree f a) where toJSONFields (a :< f) = toJSONFields a <> toJSONFields f -instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (CofreeF.CofreeF f a b) where - toJSONFields (a CofreeF.:< f) = toJSONFields a <> toJSONFields f +instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (CofreeF f a b) where + toJSONFields (a :<< f) = toJSONFields a <> toJSONFields f instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSONFields (Free f a) where toJSONFields (Free f) = toJSONFields f diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index 6b0451dea..cec6833d3 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -4,7 +4,6 @@ module Renderer.SExpression , renderSExpressionTerm ) where -import Control.Comonad.Trans.Cofree hiding (runCofree) import Control.Monad.Trans.Free hiding (runFree) import Data.Bifunctor.Join import Data.ByteString.Char8 hiding (foldr, spanEnd) @@ -13,7 +12,7 @@ import Data.Semigroup import Diff import Patch import Prelude hiding (replicate) -import Term hiding ((:<)) +import Term -- | Returns a ByteString SExpression formatted diff. renderSExpressionDiff :: (ConstrainAll Show fields, Foldable f) => Diff f (Record fields) -> ByteString @@ -29,7 +28,7 @@ printDiff diff level = case runFree diff of Insert term -> pad (level - 1) <> "{+" <> printTerm term level <> "+}" Delete term -> pad (level - 1) <> "{-" <> printTerm term level <> "-}" Replace a b -> pad (level - 1) <> "{ " <> printTerm a level <> pad (level - 1) <> "->" <> printTerm b level <> " }" - Free (Join (_, annotation) :< syntax) -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")" + Free (Join (_, annotation) :<< syntax) -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")" where pad' :: Int -> ByteString pad' n = if n < 1 then "" else pad n @@ -45,8 +44,8 @@ printTerm term level = go term level 0 pad p n | n < 1 = "" | otherwise = "\n" <> replicate (2 * (p + n)) ' ' go :: (ConstrainAll Show fields, Foldable f) => Term f (Record fields) -> Int -> Int -> ByteString - go term parentLevel level = case runCofree term of - (annotation :< syntax) -> pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")" + go (annotation :< syntax) parentLevel level = + pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")" showAnnotation :: ConstrainAll Show fields => Record fields -> ByteString showAnnotation Nil = "" diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 769916d17..438c6082c 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -17,7 +17,6 @@ module Renderer.TOC , entrySummary ) where -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.DeepSeq import Control.Monad.Free (iter) import Data.Aeson @@ -101,12 +100,12 @@ getDeclaration = getField -- | Produce the annotations of nodes representing declarations. declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields) -declaration (annotation CofreeF.:< _) = annotation <$ (getField annotation :: Maybe Declaration) +declaration (annotation :<< _) = annotation <$ (getField annotation :: Maybe Declaration) -- | Compute 'Declaration's for methods and functions in 'Syntax'. syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration) -syntaxDeclarationAlgebra Blob{..} (a CofreeF.:< r) = case r of +syntaxDeclarationAlgebra Blob{..} (a :<< r) = case r of S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) S.Method _ (identifier, _) (Just (receiver, _)) _ _ @@ -121,7 +120,7 @@ syntaxDeclarationAlgebra Blob{..} (a CofreeF.:< r) = case r of declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply1 Functor fs, HasField fields Range, HasField fields Span) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -declarationAlgebra blob@Blob{..} (a CofreeF.:< r) +declarationAlgebra blob@Blob{..} (a :<< r) | Just (Declaration.Function (identifier, _) _ _) <- prj r = Just $ FunctionDeclaration (getSource (extract identifier)) | Just (Declaration.Method _ (identifier, _) _ _) <- prj r = Just $ MethodDeclaration (getSource (extract identifier)) | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage @@ -132,7 +131,7 @@ declarationAlgebra blob@Blob{..} (a CofreeF.:< r) markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, HasField fields Span, Apply1 Functor fs, Apply1 Foldable fs) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -markupSectionAlgebra blob@Blob{..} (a CofreeF.:< r) +markupSectionAlgebra blob@Blob{..} (a :<< r) | Just (Markup.Section level (heading, _) _) <- prj r = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage | otherwise = Nothing diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 69a17341b..b6bae0afd 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -24,7 +24,6 @@ module Semantic.Task , runTaskWithOptions ) where -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Concurrent.STM.TMQueue import Control.Exception import Control.Monad.Error.Class @@ -221,7 +220,7 @@ runParser Options{..} blob@Blob{..} = go LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource) blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ] errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String] - errors = cata $ \ (a CofreeF.:< syntax) -> case syntax of + errors = cata $ \ (a :<< syntax) -> case syntax of _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (sourceSpan a) err] _ -> fold syntax logTiming :: String -> Task a -> Task a diff --git a/src/SplitDiff.hs b/src/SplitDiff.hs index e71f2260b..fc343a8b8 100644 --- a/src/SplitDiff.hs +++ b/src/SplitDiff.hs @@ -1,11 +1,9 @@ module SplitDiff where -import Control.Comonad -import Control.Comonad.Trans.Cofree import Control.Monad.Free import Data.Record import Info -import Term (Term, TermF) +import Term -- | A patch to only one side of a diff. data SplitPatch a diff --git a/src/Term.hs b/src/Term.hs index d858071ac..6392f0b0d 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -13,17 +13,15 @@ module Term , extract , unwrap , hoistCofree -, CofreeF.headF -, CofreeF.tailF -, CofreeF.CofreeF() +, CofreeF(..) ) where import Control.Comonad import Control.Comonad.Cofree.Class -import qualified Control.Comonad.Trans.Cofree as CofreeF import Control.DeepSeq import Control.Monad.Free import Data.Align.Generic +import Data.Bifunctor import Data.Functor.Both import Data.Functor.Classes.Pretty.Generic import Data.Functor.Foldable @@ -35,11 +33,13 @@ import Data.Union import Syntax -- | A Term with an abstract syntax tree and an annotation. -type Term f = Cofree f -type TermF = CofreeF.CofreeF +type Term = Cofree +type TermF = CofreeF infixr 5 :< data Cofree f a = a :< f (Cofree f a) +data CofreeF f a b = (:<<) { headF :: a, tailF :: f b } + deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. type SyntaxTerm fields = Term Syntax (Record fields) @@ -48,19 +48,19 @@ 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 -instance (NFData a, NFData (f b)) => NFData (CofreeF.CofreeF f a b) where - rnf (a CofreeF.:< s) = rnf a `seq` rnf s `seq` () +instance (NFData a, NFData (f b)) => NFData (CofreeF f a b) where + rnf (a :<< s) = rnf a `seq` rnf s `seq` () -- | Zip two terms by combining their annotations into a pair of annotations. -- | If the structure of the two terms don't match, then Nothing will be returned. zipTerms :: (Traversable f, GAlign f) => Term f annotation -> Term f annotation -> Maybe (Term f (Both annotation)) zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2)) - where go (a CofreeF.:< s) = cofree . (a CofreeF.:<) <$> sequenceA s + where go (a :<< s) = (a :<) <$> sequenceA s -- | Return the node count of a term. termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where - size (_ CofreeF.:< syntax) = 1 + sum syntax + size (_ :<< syntax) = 1 + sum syntax -- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms. alignCofreeWith :: Functor f @@ -71,15 +71,15 @@ alignCofreeWith :: Functor f -> Free (TermF f combined) contrasted alignCofreeWith compare contrast combine = go where go terms = fromMaybe (pure (contrast terms)) $ case terms of - These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 CofreeF.:<) . fmap go <$> compare f1 f2 + These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 :<<) . fmap go <$> compare f1 f2 _ -> Nothing -cofree :: CofreeF.CofreeF f a (Cofree f a) -> Cofree f a -cofree (a CofreeF.:< f) = a :< f +cofree :: CofreeF f a (Cofree f a) -> Cofree f a +cofree (a :<< f) = a :< f -runCofree :: Cofree f a -> CofreeF.CofreeF f a (Cofree f a) -runCofree (a :< f) = a CofreeF.:< f +runCofree :: Cofree f a -> CofreeF f a (Cofree f a) +runCofree (a :< f) = a :<< f hoistCofree :: Functor f => (forall a. f a -> g a) -> Cofree f a -> Cofree g a hoistCofree f = go where go (a :< r) = a :< f (fmap go r) @@ -93,7 +93,7 @@ instance (Pretty1 f, Pretty a) => Pretty (Cofree f a) where instance Apply1 Pretty1 fs => Pretty1 (Union fs) where liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) -type instance Base (Cofree f a) = CofreeF.CofreeF f a +type instance Base (Cofree f a) = CofreeF f a instance Functor f => Recursive (Cofree f a) where project = runCofree instance Functor f => Corecursive (Cofree f a) where embed = cofree @@ -115,3 +115,6 @@ instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where showsPrec d (a :< f) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 f + +instance Functor f => Bifunctor (CofreeF f) where + bimap f g (a :<< r) = f a :<< fmap g r diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index fb4a27de2..b99d293b4 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -65,7 +65,7 @@ toAST node@TS.Node{..} = do children <- allocaArray count $ \ childNodesPtr -> do _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nullPtr nodePtr childNodesPtr (fromIntegral count)) peekArray count childNodesPtr - pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) CofreeF.:< children + pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) :<< children anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t anaM g = a where a = pure . embed <=< traverse a <=< g From f2cd05d5fccca8901c2dc4b7e641a9f0a9b429d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:45:08 +0100 Subject: [PATCH 004/113] Rename Cofree/CofreeF to Term/TermF. --- src/Data/Syntax/Assignment.hs | 6 ++-- src/Language/Markdown.hs | 6 ++-- src/Language/Markdown/Syntax.hs | 6 ++-- src/Parser.hs | 6 ++-- src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 6 ++-- src/Term.hs | 53 +++++++++++++++------------------ 7 files changed, 40 insertions(+), 45 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index e5127d4a8..f95484630 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -127,7 +127,7 @@ type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar)) data AssignmentF ast grammar a where End :: AssignmentF ast grammar () Location :: AssignmentF ast grammar (Record Location) - CurrentNode :: AssignmentF ast grammar (CofreeF ast (Node grammar) ()) + CurrentNode :: AssignmentF ast grammar (TermF ast (Node grammar) ()) Source :: AssignmentF ast grammar ByteString Children :: Assignment ast grammar a -> AssignmentF ast grammar a Advance :: AssignmentF ast grammar () @@ -157,7 +157,7 @@ location :: HasCallStack => Assignment ast grammar (Record Location) location = tracing Location `Then` return -- | Zero-width production of the current node. -currentNode :: HasCallStack => Assignment ast grammar (CofreeF ast (Node grammar) ()) +currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ()) currentNode = tracing CurrentNode `Then` return -- | Zero-width match of a node with the given symbol, producing the current node’s location. @@ -206,7 +206,7 @@ toIndex = index (minBound, maxBound) type Location = '[Info.Range, Info.Span] -- | An AST node labelled with symbols and source location. -type AST f grammar = Cofree f (Node grammar) +type AST f grammar = Term f (Node grammar) data Node grammar = Node { nodeSymbol :: !grammar diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index c0f62b17e..b33727117 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -11,7 +11,7 @@ import Data.Source import qualified Data.Syntax.Assignment as A (AST, Node(..)) import Info import TreeSitter.Language (Symbol(..), SymbolType(..)) -import Term as Cofree +import Term data Grammar = Document @@ -48,9 +48,9 @@ exts = [ , extTagfilter ] -cmarkParser :: Source -> A.AST (CofreeF [] NodeType) Grammar +cmarkParser :: Source -> A.AST (TermF [] NodeType) Grammar cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkToNode [ optSourcePos, optSafe ] exts (toText source) - where toTerm :: Range -> Span -> Node -> A.AST (CofreeF [] NodeType) Grammar + where toTerm :: Range -> Span -> Node -> A.AST (TermF [] NodeType) Grammar toTerm within withinSpan (Node position t children) = let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position span = maybe withinSpan toSpan position diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index b21a63ef1..89899ad98 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -20,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) -import Term (Cofree(..), CofreeF(..), unwrap, headF, tailF) +import Term (TermF(..), unwrap, headF, tailF) import qualified Term type Syntax = @@ -52,7 +52,7 @@ type Syntax = ] type Term = Term.Term (Union Syntax) (Record Location) -type Assignment = HasCallStack => Assignment.Assignment (CofreeF [] CMarkGFM.NodeType) Grammar Term +type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Term assignment :: Assignment @@ -68,7 +68,7 @@ paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) list :: Assignment -list = (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of +list = (Term.:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . headF . tailF <$> currentNode <*> children (many item)) diff --git a/src/Parser.hs b/src/Parser.hs index feeeeecd5..c70c5b3c2 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -39,14 +39,14 @@ data Parser term where -- | A parser producing 'AST' using a 'TS.Language'. ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST [] grammar) -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. - AssignmentParser :: (Bounded grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq (ast (Cofree ast (Node grammar))), Apply1 Foldable fs, Apply1 Functor fs, Foldable ast, Functor ast) - => Parser (Cofree ast (Node grammar)) -- ^ A parser producing AST. + AssignmentParser :: (Bounded grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq (ast (Term ast (Node grammar))), Apply1 Foldable fs, Apply1 Functor fs, Foldable ast, Functor ast) + => Parser (Term ast (Node grammar)) -- ^ A parser producing AST. -> 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 DefaultFields) -- | A parser for 'Markdown' using cmark. - MarkdownParser :: Parser (Cofree (CofreeF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) + MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) -- | 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 DefaultFields) diff --git a/src/Renderer.hs b/src/Renderer.hs index 39a3468f3..28f551ee6 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -74,7 +74,7 @@ data SomeRenderer f where deriving instance Show (SomeRenderer f) -identifierAlgebra :: RAlgebra (CofreeF Syntax a) (Cofree Syntax a) (Maybe Identifier) +identifierAlgebra :: RAlgebra (TermF Syntax a) (Term 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 667943e57..2ca643d28 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -56,7 +56,7 @@ instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSON (Free f a) wher toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields -instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSON (Cofree f a) where +instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) where toJSON (a :< f) = object (toJSONFields a <> toJSONFields f) toEncoding (a :< f) = pairs (mconcat (toJSONFields a <> toJSONFields f)) @@ -85,10 +85,10 @@ instance ToJSONFields Span where instance ToJSONFields a => ToJSONFields (Maybe a) where toJSONFields = maybe [] toJSONFields -instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSONFields (Cofree f a) where +instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where toJSONFields (a :< f) = toJSONFields a <> toJSONFields f -instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (CofreeF f a b) where +instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where toJSONFields (a :<< f) = toJSONFields a <> toJSONFields f instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSONFields (Free f a) where diff --git a/src/Term.hs b/src/Term.hs index 6392f0b0d..b7b050671 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -1,19 +1,17 @@ {-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} module Term -( Term -, TermF +( Term(..) +, TermF(..) , SyntaxTerm , SyntaxTermF , zipTerms , termSize -, alignCofreeWith +, alignTermWith , cofree , runCofree -, Cofree(..) , extract , unwrap , hoistCofree -, CofreeF(..) ) where import Control.Comonad @@ -33,28 +31,25 @@ import Data.Union import Syntax -- | A Term with an abstract syntax tree and an annotation. -type Term = Cofree -type TermF = CofreeF - infixr 5 :< -data Cofree f a = a :< f (Cofree f a) -data CofreeF f a b = (:<<) { headF :: a, tailF :: f b } +data Term f a = a :< f (Term f a) +data TermF f a b = (:<<) { headF :: a, tailF :: f b } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of 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 +instance (NFData (f (Term f a)), NFData a, Functor f) => NFData (Term f a) where rnf = rnf . runCofree -instance (NFData a, NFData (f b)) => NFData (CofreeF f a b) where +instance (NFData a, NFData (f b)) => NFData (TermF f a b) where rnf (a :<< s) = rnf a `seq` rnf s `seq` () -- | Zip two terms by combining their annotations into a pair of annotations. -- | If the structure of the two terms don't match, then Nothing will be returned. zipTerms :: (Traversable f, GAlign f) => Term f annotation -> Term f annotation -> Maybe (Term f (Both annotation)) -zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2)) +zipTerms t1 t2 = iter go (alignTermWith galign (const Nothing) both (These t1 t2)) where go (a :<< s) = (a :<) <$> sequenceA s -- | Return the node count of a term. @@ -63,58 +58,58 @@ termSize = cata size where size (_ :<< syntax) = 1 + sum syntax -- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms. -alignCofreeWith :: Functor f +alignTermWith :: Functor f => (forall a b. f a -> f b -> Maybe (f (These a b))) -- ^ A function comparing a pair of structures, returning `Just` the combined structure if they are comparable (e.g. if they have the same constructor), and `Nothing` otherwise. The 'Data.Align.Generic.galign' function is usually what you want here. -> (These (Term f a) (Term f b) -> contrasted) -- ^ A function mapping a 'These' of incomparable terms into 'Pure' values in the resulting tree. -> (a -> b -> combined) -- ^ A function mapping the input terms’ annotations into annotations in the 'Free' values in the resulting tree. -> These (Term f a) (Term f b) -- ^ The input terms. -> Free (TermF f combined) contrasted -alignCofreeWith compare contrast combine = go +alignTermWith compare contrast combine = go where go terms = fromMaybe (pure (contrast terms)) $ case terms of These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 :<<) . fmap go <$> compare f1 f2 _ -> Nothing -cofree :: CofreeF f a (Cofree f a) -> Cofree f a +cofree :: TermF f a (Term f a) -> Term f a cofree (a :<< f) = a :< f -runCofree :: Cofree f a -> CofreeF f a (Cofree f a) +runCofree :: Term f a -> TermF f a (Term f a) runCofree (a :< f) = a :<< f -hoistCofree :: Functor f => (forall a. f a -> g a) -> Cofree f a -> Cofree g a +hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistCofree f = go where go (a :< r) = a :< f (fmap go r) -instance Pretty1 f => Pretty1 (Cofree f) where +instance Pretty1 f => Pretty1 (Term f) where liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f -instance (Pretty1 f, Pretty a) => Pretty (Cofree f a) where +instance (Pretty1 f, Pretty a) => Pretty (Term f a) where pretty = liftPretty pretty prettyList instance Apply1 Pretty1 fs => Pretty1 (Union fs) where liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) -type instance Base (Cofree f a) = CofreeF f a +type instance Base (Term f a) = TermF f a -instance Functor f => Recursive (Cofree f a) where project = runCofree -instance Functor f => Corecursive (Cofree f a) where embed = cofree +instance Functor f => Recursive (Term f a) where project = runCofree +instance Functor f => Corecursive (Term f a) where embed = cofree -instance Functor f => Comonad (Cofree f) where +instance Functor f => Comonad (Term f) where extract (a :< _) = a duplicate w = w :< fmap duplicate (unwrap w) extend f = go where go w = f w :< fmap go (unwrap w) -instance Functor f => Functor (Cofree f) where +instance Functor f => Functor (Term f) where fmap f = go where go (a :< r) = f a :< fmap go r -instance Functor f => ComonadCofree f (Cofree f) where +instance Functor f => ComonadCofree f (Term f) where unwrap (_ :< as) = as {-# INLINE unwrap #-} -instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where +instance (Eq (f (Term f a)), Eq a) => Eq (Term f a) where a1 :< f1 == a2 :< f2 = a1 == a2 && f1 == f2 -instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where +instance (Show (f (Term f a)), Show a) => Show (Term f a) where showsPrec d (a :< f) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 f -instance Functor f => Bifunctor (CofreeF f) where +instance Functor f => Bifunctor (TermF f) where bimap f g (a :<< r) = f a :<< fmap g r From 185818d8bda9eedeca151130cc9b234c01aff167 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:46:35 +0100 Subject: [PATCH 005/113] Rename runCofree to unTerm. --- HLint.hs | 4 ++-- src/Alignment.hs | 2 +- src/Data/Syntax.hs | 4 ++-- src/Data/Syntax/Assignment.hs | 2 +- src/RWS.hs | 4 ++-- src/Term.hs | 10 +++++----- src/TreeSitter.hs | 1 - test/TOCSpec.hs | 4 ++-- 8 files changed, 15 insertions(+), 16 deletions(-) diff --git a/HLint.hs b/HLint.hs index 2b6b07f4c..bfdeb2bbc 100644 --- a/HLint.hs +++ b/HLint.hs @@ -17,8 +17,8 @@ error "Avoid return" = error "use pure" = free . Pure ==> pure error "use wrap" = free . Free ==> wrap -error "use extract" = headF . runCofree ==> extract -error "use unwrap" = tailF . runCofree ==> unwrap +error "use extract" = headF . unTerm ==> extract +error "use unwrap" = tailF . unTerm ==> unwrap error "avoid head" = head where note = "head is partial; consider using Data.Maybe.listToMaybe" diff --git a/src/Alignment.hs b/src/Alignment.hs index d66d89717..e5bc279a9 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -59,7 +59,7 @@ alignPatch sources patch = case patch of (alignSyntax' that (snd sources) term2) where getRange = byteRange . extract alignSyntax' :: (forall a. Identity a -> Join These a) -> Source -> Term f (Record fields) -> [Join These (Term [] (Record fields))] - alignSyntax' side source term = hylo (alignSyntax side cofree getRange (Identity source)) runCofree (Identity <$> term) + alignSyntax' side source term = hylo (alignSyntax side cofree getRange (Identity source)) unTerm (Identity <$> term) this = Join . This . runIdentity that = Join . That . runIdentity diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 7c6052934..4cb29b424 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -32,7 +32,7 @@ makeTerm a = makeTerm' a . inj -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a -makeTerm' a f = (sconcat (a :| (headF . runCofree <$> toList f)) :< f) +makeTerm' a f = (sconcat (a :| (headF . unTerm <$> toList f)) :< f) -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a @@ -41,7 +41,7 @@ makeTerm1 = makeTerm1' . inj -- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation. makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a makeTerm1' f = case toList f of - a : _ -> makeTerm' (headF (runCofree a)) f + a : _ -> makeTerm' (headF (unTerm a)) f _ -> error "makeTerm1': empty structure" -- | Construct an empty term at the current position. diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index f95484630..fa211dabe 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -292,7 +292,7 @@ withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallSta withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action skipTokens :: Symbol grammar => State ast grammar -> State ast grammar -skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . headF . runCofree) (stateNodes state) } +skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . headF . unTerm) (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 ast grammar -> State ast grammar diff --git a/src/RWS.hs b/src/RWS.hs index a8f324e9f..344101005 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -303,12 +303,12 @@ unitVector d hash = listArray (0, d - 1) ((* invMagnitude) <$> components) -- | Test the comparability of two root 'Term's in O(1). canCompareTerms :: ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool -canCompareTerms canCompare = canCompare `on` runCofree +canCompareTerms canCompare = canCompare `on` unTerm -- | Recursively test the equality of two 'Term's in O(n). equalTerms :: Eq1 f => ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool equalTerms canCompare = go - where go a b = canCompareTerms canCompare a b && liftEq go (tailF (runCofree a)) (tailF (runCofree b)) + where go a b = canCompareTerms canCompare a b && liftEq go (tailF (unTerm a)) (tailF (unTerm b)) -- | Strips the head annotation off a term annotated with non-empty records. diff --git a/src/Term.hs b/src/Term.hs index b7b050671..b3266a20b 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -8,7 +8,7 @@ module Term , termSize , alignTermWith , cofree -, runCofree +, unTerm , extract , unwrap , hoistCofree @@ -41,7 +41,7 @@ type SyntaxTerm fields = Term Syntax (Record fields) type SyntaxTermF fields = TermF Syntax (Record fields) instance (NFData (f (Term f a)), NFData a, Functor f) => NFData (Term f a) where - rnf = rnf . runCofree + rnf = rnf . unTerm instance (NFData a, NFData (f b)) => NFData (TermF f a b) where rnf (a :<< s) = rnf a `seq` rnf s `seq` () @@ -73,8 +73,8 @@ alignTermWith compare contrast combine = go cofree :: TermF f a (Term f a) -> Term f a cofree (a :<< f) = a :< f -runCofree :: Term f a -> TermF f a (Term f a) -runCofree (a :< f) = a :<< f +unTerm :: Term f a -> TermF f a (Term f a) +unTerm (a :< f) = a :<< f hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistCofree f = go where go (a :< r) = a :< f (fmap go r) @@ -90,7 +90,7 @@ instance Apply1 Pretty1 fs => Pretty1 (Union fs) where type instance Base (Term f a) = TermF f a -instance Functor f => Recursive (Term f a) where project = runCofree +instance Functor f => Recursive (Term f a) where project = unTerm instance Functor f => Corecursive (Term f a) where embed = cofree instance Functor f => Comonad (Term f) where diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index b99d293b4..c94d71780 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -5,7 +5,6 @@ module TreeSitter ) where import Category -import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..)) import Control.Exception import Control.Monad ((<=<)) import Data.Blob diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 5fd3cec31..96be8307d 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -211,7 +211,7 @@ 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) a -> Bool -isMeaningfulTerm a = case runCofree (unListableF a) of +isMeaningfulTerm a = case unTerm (unListableF a) of (_ :< S.Indexed _) -> False (_ :< S.Fixed _) -> False (_ :< S.Commented _ _) -> False @@ -220,7 +220,7 @@ isMeaningfulTerm a = case runCofree (unListableF a) of -- Filter tiers for terms if the Syntax is a Method or a Function. isMethodOrFunction :: HasField fields Category => ListableF (Term Syntax) (Record fields) -> Bool -isMethodOrFunction a = case runCofree (unListableF a) of +isMethodOrFunction a = case unTerm (unListableF a) of (_ :< S.Method{}) -> True (_ :< S.Function{}) -> True (a :< _) | getField a == C.Function -> True From ea5107c484ff251399574397009043cf31e18c10 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:50:21 +0100 Subject: [PATCH 006/113] Define Listable instances for Term/TermF. --- src/Data/Functor/Listable.hs | 13 ------------- src/Term.hs | 15 +++++++++++++-- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/Data/Functor/Listable.hs b/src/Data/Functor/Listable.hs index 60407c57c..557f73946 100644 --- a/src/Data/Functor/Listable.hs +++ b/src/Data/Functor/Listable.hs @@ -24,8 +24,6 @@ module Data.Functor.Listable , ofWeight ) where -import Control.Comonad.Cofree as Cofree -import Control.Comonad.Trans.Cofree as CofreeF import Control.Monad.Free as Free import Control.Monad.Trans.Free as FreeF import Data.Bifunctor.Join @@ -116,17 +114,6 @@ instance Listable2 p => Listable1 (Join p) where instance Listable2 These where liftTiers2 this that = liftCons1 this This \/ liftCons1 that That \/ liftCons2 this that These -instance Listable1 f => Listable2 (CofreeF f) where - liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (CofreeF.:<) - -instance (Listable1 f, Listable a) => Listable1 (CofreeF f a) where - liftTiers = liftTiers2 tiers - -instance (Functor f, Listable1 f) => Listable1 (Cofree.Cofree f) where - liftTiers annotationTiers = go - where go = liftCons1 (liftTiers2 annotationTiers go) cofree - cofree (a CofreeF.:< f) = a Cofree.:< f - instance Listable1 f => Listable2 (FreeF f) where liftTiers2 pureTiers recurTiers = liftCons1 pureTiers FreeF.Pure \/ liftCons1 (liftTiers recurTiers) FreeF.Free diff --git a/src/Term.hs b/src/Term.hs index b3266a20b..c47acf82c 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -21,8 +21,9 @@ import Control.Monad.Free import Data.Align.Generic import Data.Bifunctor import Data.Functor.Both -import Data.Functor.Classes.Pretty.Generic +import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable +import Data.Functor.Listable import Data.Maybe import Data.Proxy import Data.Record @@ -80,7 +81,7 @@ hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistCofree f = go where go (a :< r) = a :< f (fmap go r) instance Pretty1 f => Pretty1 (Term f) where - liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f + liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (Pretty.list . map (liftPretty p pl)) f instance (Pretty1 f, Pretty a) => Pretty (Term f a) where pretty = liftPretty pretty prettyList @@ -113,3 +114,13 @@ instance (Show (f (Term f a)), Show a) => Show (Term f a) where instance Functor f => Bifunctor (TermF f) where bimap f g (a :<< r) = f a :<< fmap g r + +instance Listable1 f => Listable2 (TermF f) where + liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<<) + +instance (Listable1 f, Listable a) => Listable1 (TermF f a) where + liftTiers = liftTiers2 tiers + +instance (Functor f, Listable1 f) => Listable1 (Term f) where + liftTiers annotationTiers = go + where go = liftCons1 (liftTiers2 annotationTiers go) cofree From d572c64b32f9d55364e686b27ca44730702e9bc2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:55:36 +0100 Subject: [PATCH 007/113] Define Term equality via Eq1. --- src/Data/Syntax/Assignment.hs | 10 +++++----- src/Parser.hs | 3 ++- src/Term.hs | 14 ++++++++++++-- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index fa211dabe..f0ae029c5 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -231,7 +231,7 @@ firstSet = iterFreer (\ (Tracing _ assignment) _ -> case assignment of -- | Run an assignment over an AST exhaustively. -assign :: (Bounded grammar, Ix grammar, Symbol grammar, Show grammar, Eq (ast (AST ast grammar)), Foldable ast, Functor ast) +assign :: (Bounded grammar, Ix grammar, Symbol grammar, Show grammar, Eq1 ast, Foldable ast, Functor ast) => Source.Source -- ^ The source for the parse tree. -> Assignment ast grammar a -- ^ The 'Assignment to run. -> AST ast grammar -- ^ The root of the ast. @@ -240,7 +240,7 @@ assign source assignment ast = bimap (fmap (either id show)) fst (runAssignment {-# INLINE assign #-} -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. -runAssignment :: forall grammar a ast. (Bounded grammar, Ix grammar, Symbol grammar, Eq (ast (AST ast grammar)), Foldable ast, Functor ast) +runAssignment :: forall grammar a ast. (Bounded grammar, Ix grammar, Symbol grammar, Eq1 ast, Foldable ast, Functor ast) => Source.Source -- ^ The source for the parse tree. -> Assignment ast grammar a -- ^ The 'Assignment' to run. -> State ast grammar -- ^ The current state. @@ -308,7 +308,7 @@ data State ast grammar = State , stateNodes :: ![AST ast grammar] -- ^ 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 instance (Eq grammar, Eq (ast (AST ast grammar))) => Eq (State ast grammar) +deriving instance (Eq grammar, Eq1 ast) => Eq (State ast grammar) deriving instance (Show grammar, Show (ast (AST ast grammar))) => Show (State ast grammar) makeState :: [AST ast grammar] -> State ast grammar @@ -317,7 +317,7 @@ makeState = State 0 (Info.Pos 1 1) [] -- Instances -instance (Eq grammar, Eq (ast (AST ast grammar))) => Alternative (Assignment ast grammar) where +instance (Eq grammar, Eq1 ast) => Alternative (Assignment ast grammar) where empty :: HasCallStack => Assignment ast grammar a empty = tracing (Alt []) `Then` return @@ -369,7 +369,7 @@ instance (Eq grammar, Eq (ast (AST ast grammar))) => Alternative (Assignment ast many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a] many a = tracing (Many a) `Then` return -instance (Eq grammar, Eq (ast (AST ast grammar)), Show grammar, Show (ast (AST ast grammar))) => Parsing (Assignment ast grammar) where +instance (Eq grammar, Eq1 ast, Show grammar, Show (ast (AST ast grammar))) => Parsing (Assignment ast grammar) where try :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a try = id diff --git a/src/Parser.hs b/src/Parser.hs index c70c5b3c2..f88c41048 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -12,6 +12,7 @@ module Parser ) where import qualified CMarkGFM +import Data.Functor.Classes (Eq1) import Data.Ix import Data.Record import Data.Source as Source @@ -39,7 +40,7 @@ data Parser term where -- | A parser producing 'AST' using a 'TS.Language'. ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST [] grammar) -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. - AssignmentParser :: (Bounded grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq (ast (Term ast (Node grammar))), Apply1 Foldable fs, Apply1 Functor fs, Foldable ast, Functor ast) + AssignmentParser :: (Bounded grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply1 Foldable fs, Apply1 Functor fs, Foldable ast, Functor ast) => Parser (Term ast (Node grammar)) -- ^ A parser producing AST. -> 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. diff --git a/src/Term.hs b/src/Term.hs index c47acf82c..09a516cf3 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -21,6 +21,7 @@ import Control.Monad.Free import Data.Align.Generic import Data.Bifunctor import Data.Functor.Both +import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable import Data.Functor.Listable @@ -106,8 +107,11 @@ instance Functor f => ComonadCofree f (Term f) where unwrap (_ :< as) = as {-# INLINE unwrap #-} -instance (Eq (f (Term f a)), Eq a) => Eq (Term f a) where - a1 :< f1 == a2 :< f2 = a1 == a2 && f1 == f2 +instance Eq1 f => Eq1 (Term f) where + liftEq eqA = go where go (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq go f1 f2 + +instance (Eq1 f, Eq a) => Eq (Term f a) where + (==) = eq1 instance (Show (f (Term f a)), Show a) => Show (Term f a) where showsPrec d (a :< f) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 f @@ -124,3 +128,9 @@ instance (Listable1 f, Listable a) => Listable1 (TermF f a) where instance (Functor f, Listable1 f) => Listable1 (Term f) where liftTiers annotationTiers = go where go = liftCons1 (liftTiers2 annotationTiers go) cofree + +instance Eq1 f => Eq2 (TermF f) where + liftEq2 eqA eqB (a1 :<< f1) (a2 :<< f2) = eqA a1 a2 && liftEq eqB f1 f2 + +instance (Eq1 f, Eq a) => Eq1 (TermF f a) where + liftEq = liftEq2 (==) From a8f0a965c303ef2435aaa5f8677109f1a9d34a47 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:56:29 +0100 Subject: [PATCH 008/113] Give fixity for :<<. --- src/Term.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Term.hs b/src/Term.hs index 09a516cf3..9c35f55ca 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -35,6 +35,7 @@ import Syntax -- | A Term with an abstract syntax tree and an annotation. infixr 5 :< data Term f a = a :< f (Term f a) +infixr 5 :<< data TermF f a b = (:<<) { headF :: a, tailF :: f b } deriving (Eq, Foldable, Functor, Show, Traversable) From 3231b163998c835c3811a47d4cce22eb58f5178e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:58:15 +0100 Subject: [PATCH 009/113] Define Term printing via Show1. --- src/Data/Syntax/Assignment.hs | 6 +++--- src/Term.hs | 7 +++++-- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index f0ae029c5..a4f684287 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -309,7 +309,7 @@ data State ast grammar = State } deriving instance (Eq grammar, Eq1 ast) => Eq (State ast grammar) -deriving instance (Show grammar, Show (ast (AST ast grammar))) => Show (State ast grammar) +deriving instance (Show grammar, Show1 ast) => Show (State ast grammar) makeState :: [AST ast grammar] -> State ast grammar makeState = State 0 (Info.Pos 1 1) [] @@ -369,7 +369,7 @@ instance (Eq grammar, Eq1 ast) => Alternative (Assignment ast grammar) where many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a] many a = tracing (Many a) `Then` return -instance (Eq grammar, Eq1 ast, Show grammar, Show (ast (AST ast grammar))) => Parsing (Assignment ast grammar) where +instance (Eq grammar, Eq1 ast, Show grammar, Show1 ast) => Parsing (Assignment ast grammar) where try :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a try = id @@ -395,7 +395,7 @@ instance MonadError (Error (Either String grammar)) (Assignment ast grammar) whe instance Show1 f => Show1 (Tracing f) where liftShowsPrec sp sl d = liftShowsPrec sp sl d . runTracing -instance (Show grammar, Show (ast (AST ast grammar))) => Show1 (AssignmentF ast grammar) where +instance (Show grammar, Show1 ast) => Show1 (AssignmentF ast grammar) where liftShowsPrec sp sl d a = case a of End -> showString "End" . showChar ' ' . sp d () Advance -> showString "Advance" . showChar ' ' . sp d () diff --git a/src/Term.hs b/src/Term.hs index 9c35f55ca..2161578db 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -114,8 +114,11 @@ instance Eq1 f => Eq1 (Term f) where instance (Eq1 f, Eq a) => Eq (Term f a) where (==) = eq1 -instance (Show (f (Term f a)), Show a) => Show (Term f a) where - showsPrec d (a :< f) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 f +instance Show1 f => Show1 (Term f) where + liftShowsPrec spA slA = go where go d (a :< f) = showParen (d > 5) $ spA 6 a . showString " :< " . liftShowsPrec go (liftShowList spA slA) 5 f + +instance (Show1 f, Show a) => Show (Term f a) where + showsPrec = showsPrec1 instance Functor f => Bifunctor (TermF f) where bimap f g (a :<< r) = f a :<< fmap g r From 0ca7a4bdcf4acd48b889a0baf6dbfc0a6ccc1087 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:59:40 +0100 Subject: [PATCH 010/113] Define a Show2 instance for TermF. --- src/Term.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index 2161578db..ee7ccd14e 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -138,3 +138,6 @@ instance Eq1 f => Eq2 (TermF f) where instance (Eq1 f, Eq a) => Eq1 (TermF f a) where liftEq = liftEq2 (==) + +instance Show1 f => Show2 (TermF f) where + liftShowsPrec2 spA _ spB slB d (a :<< f) = showParen (d > 5) $ spA 6 a . showString " :<< " . liftShowsPrec spB slB 5 f From c358bfad08250fe84e22b2fc79e8a99bc71d6c79 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:00:09 +0100 Subject: [PATCH 011/113] Define a Show1 instance for TermF. --- src/Term.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index ee7ccd14e..67ca7900b 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -141,3 +141,6 @@ instance (Eq1 f, Eq a) => Eq1 (TermF f a) where instance Show1 f => Show2 (TermF f) where liftShowsPrec2 spA _ spB slB d (a :<< f) = showParen (d > 5) $ spA 6 a . showString " :<< " . liftShowsPrec spB slB 5 f + +instance (Show1 f, Show a) => Show1 (TermF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList From fe3fa0e8113238bef93e05a477a46aadd14c2994 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:02:30 +0100 Subject: [PATCH 012/113] Define Pretty, Pretty1, & Pretty2 instances for TermF. --- src/Term.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index 67ca7900b..6dbe71df9 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -144,3 +144,12 @@ instance Show1 f => Show2 (TermF f) where instance (Show1 f, Show a) => Show1 (TermF f a) where liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Pretty1 f => Pretty2 (TermF f) where + liftPretty2 pA _ pB plB (a :<< f) = pA a <+> liftPretty pB plB f + +instance (Pretty1 f, Pretty a) => Pretty1 (TermF f a) where + liftPretty = liftPretty2 pretty prettyList + +instance (Pretty1 f, Pretty a, Pretty b) => Pretty (TermF f a b) where + pretty = liftPretty pretty prettyList From ee27d737470feea45675111d49fddb1f11ee3a20 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:18:03 +0100 Subject: [PATCH 013/113] :fire: zipTerms. --- src/Term.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Term.hs b/src/Term.hs index 6dbe71df9..638d60cc9 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -4,7 +4,6 @@ module Term , TermF(..) , SyntaxTerm , SyntaxTermF -, zipTerms , termSize , alignTermWith , cofree @@ -18,9 +17,7 @@ import Control.Comonad import Control.Comonad.Cofree.Class import Control.DeepSeq import Control.Monad.Free -import Data.Align.Generic import Data.Bifunctor -import Data.Functor.Both import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable @@ -49,12 +46,6 @@ instance (NFData (f (Term f a)), NFData a, Functor f) => NFData (Term f a) where instance (NFData a, NFData (f b)) => NFData (TermF f a b) where rnf (a :<< s) = rnf a `seq` rnf s `seq` () --- | Zip two terms by combining their annotations into a pair of annotations. --- | If the structure of the two terms don't match, then Nothing will be returned. -zipTerms :: (Traversable f, GAlign f) => Term f annotation -> Term f annotation -> Maybe (Term f (Both annotation)) -zipTerms t1 t2 = iter go (alignTermWith galign (const Nothing) both (These t1 t2)) - where go (a :<< s) = (a :<) <$> sequenceA s - -- | Return the node count of a term. termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where From 053954cc974edd1b8b49ce278517b456cc0649fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:18:46 +0100 Subject: [PATCH 014/113] :fire: alignTermWith. --- src/Term.hs | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/Term.hs b/src/Term.hs index 638d60cc9..736c592c7 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -5,7 +5,6 @@ module Term , SyntaxTerm , SyntaxTermF , termSize -, alignTermWith , cofree , unTerm , extract @@ -16,16 +15,13 @@ module Term import Control.Comonad import Control.Comonad.Cofree.Class import Control.DeepSeq -import Control.Monad.Free import Data.Bifunctor import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable import Data.Functor.Listable -import Data.Maybe import Data.Proxy import Data.Record -import Data.These import Data.Union import Syntax @@ -51,18 +47,6 @@ termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where size (_ :<< syntax) = 1 + sum syntax --- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms. -alignTermWith :: Functor f - => (forall a b. f a -> f b -> Maybe (f (These a b))) -- ^ A function comparing a pair of structures, returning `Just` the combined structure if they are comparable (e.g. if they have the same constructor), and `Nothing` otherwise. The 'Data.Align.Generic.galign' function is usually what you want here. - -> (These (Term f a) (Term f b) -> contrasted) -- ^ A function mapping a 'These' of incomparable terms into 'Pure' values in the resulting tree. - -> (a -> b -> combined) -- ^ A function mapping the input terms’ annotations into annotations in the 'Free' values in the resulting tree. - -> These (Term f a) (Term f b) -- ^ The input terms. - -> Free (TermF f combined) contrasted -alignTermWith compare contrast combine = go - where go terms = fromMaybe (pure (contrast terms)) $ case terms of - These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 :<<) . fmap go <$> compare f1 f2 - _ -> Nothing - cofree :: TermF f a (Term f a) -> Term f a cofree (a :<< f) = a :< f From a16c6e4f7582c4d7ca5f7596b0c5eccd9dfc8cc3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:20:55 +0100 Subject: [PATCH 015/113] Extract union pretty-printing to the top level. --- src/Term.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Term.hs b/src/Term.hs index 736c592c7..2c999d6db 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -57,6 +57,9 @@ unTerm (a :< f) = a :<< f hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistCofree f = go where go (a :< r) = a :< f (fmap go r) +liftPrettyUnion :: Apply1 Pretty1 fs => (a -> Doc ann) -> ([a] -> Doc ann) -> Union fs a -> Doc ann +liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) + instance Pretty1 f => Pretty1 (Term f) where liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (Pretty.list . map (liftPretty p pl)) f @@ -64,7 +67,7 @@ instance (Pretty1 f, Pretty a) => Pretty (Term f a) where pretty = liftPretty pretty prettyList instance Apply1 Pretty1 fs => Pretty1 (Union fs) where - liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) + liftPretty = liftPrettyUnion type instance Base (Term f a) = TermF f a From dfccae778a259d42e5d85f169bb80e3bf13119f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:21:39 +0100 Subject: [PATCH 016/113] Rename hoistCofree to hoistTerm. --- src/Semantic.hs | 4 ++-- src/Term.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Semantic.hs b/src/Semantic.hs index c9d673fa4..ceb97cdd1 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -46,7 +46,7 @@ parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . f parseBlob :: TermRenderer output -> Blob -> Task output parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate (markupSectionAlgebra blob) >>= render (renderToCTerm blob) - (ToCTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate (declarationAlgebra blob) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) + (ToCTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate (declarationAlgebra blob) . hoistTerm (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) (ToCTermRenderer, _) -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob) >>= render (renderToCTerm blob) (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob) (JSONTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob) @@ -71,7 +71,7 @@ diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair rendere diffBlobPair :: DiffRenderer output -> Both Blob -> Task output diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of (ToCDiffRenderer, Just Language.Markdown) -> run (\ blob -> parse markdownParser blob >>= decorate (markupSectionAlgebra blob)) diffRecursively (renderToCDiff blobs) - (ToCDiffRenderer, Just Language.Python) -> run (\ blob -> parse pythonParser blob >>= decorate (declarationAlgebra blob) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffRecursively (renderToCDiff blobs) + (ToCDiffRenderer, Just Language.Python) -> run (\ blob -> parse pythonParser blob >>= decorate (declarationAlgebra blob) . hoistTerm (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffRecursively (renderToCDiff blobs) (ToCDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms (renderToCDiff blobs) (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffRecursively (renderJSONDiff blobs) (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffRecursively (renderJSONDiff blobs) diff --git a/src/Term.hs b/src/Term.hs index 2c999d6db..8ccad14d3 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -9,7 +9,7 @@ module Term , unTerm , extract , unwrap -, hoistCofree +, hoistTerm ) where import Control.Comonad @@ -54,8 +54,8 @@ cofree (a :<< f) = a :< f unTerm :: Term f a -> TermF f a (Term f a) unTerm (a :< f) = a :<< f -hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a -hoistCofree f = go where go (a :< r) = a :< f (fmap go r) +hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a +hoistTerm f = go where go (a :< r) = a :< f (fmap go r) liftPrettyUnion :: Apply1 Pretty1 fs => (a -> Doc ann) -> ([a] -> Doc ann) -> Union fs a -> Doc ann liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) From 9e4ae0ee34e2c6c92af3b4da4c048fff4bcdeeaa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:23:16 +0100 Subject: [PATCH 017/113] Rename cofree to term. --- src/Alignment.hs | 2 +- src/RWS.hs | 2 +- src/Term.hs | 10 +++++----- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Alignment.hs b/src/Alignment.hs index e5bc279a9..301ef5fbc 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -59,7 +59,7 @@ alignPatch sources patch = case patch of (alignSyntax' that (snd sources) term2) where getRange = byteRange . extract alignSyntax' :: (forall a. Identity a -> Join These a) -> Source -> Term f (Record fields) -> [Join These (Term [] (Record fields))] - alignSyntax' side source term = hylo (alignSyntax side cofree getRange (Identity source)) unTerm (Identity <$> term) + alignSyntax' side source = hylo (alignSyntax side term getRange (Identity source)) unTerm . fmap Identity this = Join . This . runIdentity that = Join . That . runIdentity diff --git a/src/RWS.hs b/src/RWS.hs index 344101005..87ae27521 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -28,7 +28,7 @@ import Data.Semigroup hiding (First(..)) import Data.These import Data.Traversable import Patch -import Term +import Term hiding (term) import Data.Array.Unboxed import Data.Functor.Classes import SES diff --git a/src/Term.hs b/src/Term.hs index 8ccad14d3..d9f52f58c 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -5,7 +5,7 @@ module Term , SyntaxTerm , SyntaxTermF , termSize -, cofree +, term , unTerm , extract , unwrap @@ -48,8 +48,8 @@ termSize = cata size where size (_ :<< syntax) = 1 + sum syntax -cofree :: TermF f a (Term f a) -> Term f a -cofree (a :<< f) = a :< f +term :: TermF f a (Term f a) -> Term f a +term (a :<< f) = a :< f unTerm :: Term f a -> TermF f a (Term f a) unTerm (a :< f) = a :<< f @@ -72,7 +72,7 @@ instance Apply1 Pretty1 fs => Pretty1 (Union fs) where type instance Base (Term f a) = TermF f a instance Functor f => Recursive (Term f a) where project = unTerm -instance Functor f => Corecursive (Term f a) where embed = cofree +instance Functor f => Corecursive (Term f a) where embed = term instance Functor f => Comonad (Term f) where extract (a :< _) = a @@ -109,7 +109,7 @@ instance (Listable1 f, Listable a) => Listable1 (TermF f a) where instance (Functor f, Listable1 f) => Listable1 (Term f) where liftTiers annotationTiers = go - where go = liftCons1 (liftTiers2 annotationTiers go) cofree + where go = liftCons1 (liftTiers2 annotationTiers go) term instance Eq1 f => Eq2 (TermF f) where liftEq2 eqA eqB (a1 :<< f1) (a2 :<< f2) = eqA a1 a2 && liftEq eqB f1 f2 From ec8f535b2a01822368115b6015c2e0f68e58a2d2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:31:17 +0100 Subject: [PATCH 018/113] Define decidable NFData instances. --- src/Diff.hs | 10 ++++++---- src/Term.hs | 17 +++++++++++++---- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index 76787ce70..3b881b9d2 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -49,11 +49,13 @@ mapAnnotations :: (Functor f, Functor g) -> Free.Free (TermF f (g annotation')) (Patch (Term f annotation')) mapAnnotations f = Free.hoistFree (first (fmap f)) . fmap (fmap (fmap f)) +instance NFData1 f => NFData1 (Free.Free f) where + liftRnf rnfA = go + where go (Free.Free f) = liftRnf go f + go (Free.Pure a) = rnfA a -instance (NFData (f (Diff f a)), NFData (f (Term f a)), NFData a, Functor f) => NFData (Diff f a) where - rnf fa = case runFree fa of - FreeF.Free f -> rnf f `seq` () - FreeF.Pure a -> rnf a `seq` () +instance (NFData1 f, NFData a) => NFData (Diff f a) where + rnf = rnf1 free :: FreeF.FreeF f a (Free.Free f a) -> Free.Free f a diff --git a/src/Term.hs b/src/Term.hs index d9f52f58c..4f7b069dd 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -36,11 +36,20 @@ data TermF f a b = (:<<) { headF :: a, tailF :: f b } type SyntaxTerm fields = Term Syntax (Record fields) type SyntaxTermF fields = TermF Syntax (Record fields) -instance (NFData (f (Term f a)), NFData a, Functor f) => NFData (Term f a) where - rnf = rnf . unTerm +instance NFData1 f => NFData1 (Term f) where + liftRnf rnfA = go where go (a :< f) = rnfA a `seq` liftRnf go f -instance (NFData a, NFData (f b)) => NFData (TermF f a b) where - rnf (a :<< s) = rnf a `seq` rnf s `seq` () +instance (NFData1 f, NFData a) => NFData (Term f a) where + rnf = rnf1 + +instance NFData1 f => NFData2 (TermF f) where + liftRnf2 rnfA rnfB (a :<< f) = rnfA a `seq` liftRnf rnfB f `seq` () + +instance (NFData1 f, NFData a) => NFData1 (TermF f a) where + liftRnf = liftRnf2 rnf + +instance (NFData1 f, NFData a, NFData b) => NFData (TermF f a b) where + rnf = rnf1 -- | Return the node count of a term. termSize :: (Foldable f, Functor f) => Term f annotation -> Int From 0ce48d5248a7809ffbf346b330cbc066f0d93f01 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:32:05 +0100 Subject: [PATCH 019/113] :fire: the NFData instances for Diff. --- src/Diff.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index 3b881b9d2..a7e305179 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -2,7 +2,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Diff where -import Control.DeepSeq import qualified Control.Monad.Free as Free import qualified Control.Monad.Trans.Free as FreeF import Data.Bifunctor @@ -49,14 +48,6 @@ mapAnnotations :: (Functor f, Functor g) -> Free.Free (TermF f (g annotation')) (Patch (Term f annotation')) mapAnnotations f = Free.hoistFree (first (fmap f)) . fmap (fmap (fmap f)) -instance NFData1 f => NFData1 (Free.Free f) where - liftRnf rnfA = go - where go (Free.Free f) = liftRnf go f - go (Free.Pure a) = rnfA a - -instance (NFData1 f, NFData a) => NFData (Diff f a) where - rnf = rnf1 - free :: FreeF.FreeF f a (Free.Free f a) -> Free.Free f a free (FreeF.Free f) = Free.Free f From d1ced22ce8def909a8130e1253dab97f0bfeba5c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:32:24 +0100 Subject: [PATCH 020/113] :fire: the NFData instances for Term. --- src/Term.hs | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/Term.hs b/src/Term.hs index 4f7b069dd..967540c39 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -14,7 +14,6 @@ module Term import Control.Comonad import Control.Comonad.Cofree.Class -import Control.DeepSeq import Data.Bifunctor import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty @@ -36,21 +35,6 @@ data TermF f a b = (:<<) { headF :: a, tailF :: f b } type SyntaxTerm fields = Term Syntax (Record fields) type SyntaxTermF fields = TermF Syntax (Record fields) -instance NFData1 f => NFData1 (Term f) where - liftRnf rnfA = go where go (a :< f) = rnfA a `seq` liftRnf go f - -instance (NFData1 f, NFData a) => NFData (Term f a) where - rnf = rnf1 - -instance NFData1 f => NFData2 (TermF f) where - liftRnf2 rnfA rnfB (a :<< f) = rnfA a `seq` liftRnf rnfB f `seq` () - -instance (NFData1 f, NFData a) => NFData1 (TermF f a) where - liftRnf = liftRnf2 rnf - -instance (NFData1 f, NFData a, NFData b) => NFData (TermF f a b) where - rnf = rnf1 - -- | Return the node count of a term. termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where From 07bef3f75ef9bdf0bbd694230f5208e076272bcd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:35:55 +0100 Subject: [PATCH 021/113] :fire: deepseq. --- semantic-diff.cabal | 2 -- src/Category.hs | 3 +-- src/Data/Functor/Both.hs | 3 --- src/Data/Range.hs | 3 +-- src/Data/Record.hs | 6 ------ src/Data/Span.hs | 5 ++--- src/Language.hs | 3 +-- src/Patch.hs | 3 +-- src/Renderer.hs | 3 +-- src/Renderer/TOC.hs | 3 +-- src/Syntax.hs | 3 +-- test/IntegrationSpec.hs | 3 +-- 12 files changed, 10 insertions(+), 30 deletions(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 994ce923b..34b1e76a2 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -92,7 +92,6 @@ library , cmark-gfm , comonad , containers - , deepseq , directory , effects , filepath @@ -167,7 +166,6 @@ test-suite test , bifunctors , bytestring , comonad - , deepseq , filepath , free , Glob diff --git a/src/Category.hs b/src/Category.hs index a8c14b8ba..516fd8d2f 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -3,7 +3,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Category where -import Control.DeepSeq import Data.Functor.Listable import Data.Hashable import Data.Text (Text) @@ -238,7 +237,7 @@ data Category | Ty | ParenthesizedExpression | ParenthesizedType - deriving (Eq, Generic, Ord, Show, NFData) + deriving (Eq, Generic, Ord, Show) {-# DEPRECATED RescueModifier "Deprecated; use Modifier Rescue instead." #-} diff --git a/src/Data/Functor/Both.hs b/src/Data/Functor/Both.hs index 952e0460e..5487ab771 100644 --- a/src/Data/Functor/Both.hs +++ b/src/Data/Functor/Both.hs @@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans -funbox-strict-fields #-} module Data.Functor.Both (Both, both, runBothWith, fst, snd, module X) where -import Control.DeepSeq import Data.Bifunctor.Join as X import Data.Semigroup import Prelude hiding (fst, snd) @@ -33,5 +32,3 @@ instance (Semigroup a, Monoid a) => Monoid (Join (,) a) where instance (Semigroup a) => Semigroup (Join (,) a) where a <> b = Join $ runJoin a <> runJoin b - -instance NFData a => NFData (Join (,) a) diff --git a/src/Data/Range.hs b/src/Data/Range.hs index 3eef78cf1..850e09e58 100644 --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -6,7 +6,6 @@ module Data.Range , intersectsRange ) where -import Control.DeepSeq import Data.Semigroup import Data.Text.Prettyprint.Doc import GHC.Generics @@ -14,7 +13,7 @@ import Test.LeanCheck -- | A half-open interval of integers, defined by start & end indices. data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int } - deriving (Eq, Show, Generic, NFData) + deriving (Eq, Show, Generic) -- | Return the length of the range. rangeLength :: Range -> Int diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 9c113042f..12a486489 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} module Data.Record where -import Control.DeepSeq import Data.Kind import Data.Functor.Listable import Data.Semigroup @@ -49,11 +48,6 @@ instance {-# OVERLAPPABLE #-} HasField (field ': fields) field where getField (h :. _) = h setField (_ :. t) f = f :. t -instance (NFData h, NFData (Record t)) => NFData (Record (h ': t)) where - rnf (h :. t) = rnf h `seq` rnf t `seq` () - -instance NFData (Record '[]) where - rnf _ = () instance (Show h, Show (Record t)) => Show (Record (h ': t)) where showsPrec n (h :. t) = showParen (n > 0) $ showsPrec 1 h . (" :. " <>) . shows t diff --git a/src/Data/Span.hs b/src/Data/Span.hs index 4ce614ea5..0bc617776 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -9,7 +9,6 @@ module Data.Span , emptySpan ) where -import Control.DeepSeq import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import Data.Hashable (Hashable) @@ -23,7 +22,7 @@ data Pos = Pos { posLine :: !Int , posColumn :: !Int } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + deriving (Show, Read, Eq, Ord, Generic, Hashable) instance A.ToJSON Pos where toJSON Pos{..} = @@ -38,7 +37,7 @@ data Span = Span { spanStart :: Pos , spanEnd :: Pos } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + deriving (Show, Read, Eq, Ord, Generic, Hashable) emptySpan :: Span emptySpan = Span (Pos 1 1) (Pos 1 1) diff --git a/src/Language.hs b/src/Language.hs index c2e04f64b..9b3178eee 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -2,7 +2,6 @@ module Language where import Control.Comonad.Trans.Cofree hiding (cofree, (:<)) -import Control.DeepSeq import Data.Aeson import Data.Foldable import Data.Record @@ -21,7 +20,7 @@ data Language | Python | Ruby | TypeScript - deriving (Show, Eq, Read, Generic, NFData, ToJSON) + deriving (Show, Eq, Read, Generic, ToJSON) -- | Returns a Language based on the file extension (including the "."). languageForType :: String -> Maybe Language diff --git a/src/Patch.hs b/src/Patch.hs index d67ced4a7..9ed5701a2 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -14,7 +14,6 @@ module Patch , mapPatch ) where -import Control.DeepSeq import Data.Align import Data.Functor.Classes.Pretty.Generic import Data.Functor.Listable @@ -26,7 +25,7 @@ data Patch a = Replace a a | Insert a | Delete a - deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable, NFData) + deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) -- DSL diff --git a/src/Renderer.hs b/src/Renderer.hs index 28f551ee6..11cb31d03 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -18,7 +18,6 @@ module Renderer , File(..) ) where -import Control.DeepSeq import Data.Aeson (Value, (.=)) import Data.ByteString (ByteString) import Data.Foldable (asum) @@ -93,7 +92,7 @@ identifierAlgebra (_ :<< syntax) = case syntax of where identifier = fmap Identifier . extractLeafValue . unwrap . fst newtype Identifier = Identifier Text - deriving (Eq, NFData, Show) + deriving (Eq, Show) instance ToJSONFields Identifier where toJSONFields (Identifier i) = ["identifier" .= i] diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 438c6082c..88e44fcdf 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -17,7 +17,6 @@ module Renderer.TOC , entrySummary ) where -import Control.DeepSeq import Control.Monad.Free (iter) import Data.Aeson import Data.Align (crosswalk) @@ -93,7 +92,7 @@ data Declaration | FunctionDeclaration { declarationIdentifier :: T.Text } | SectionDeclaration { declarationIdentifier :: T.Text, declarationLevel :: Int } | ErrorDeclaration { declarationIdentifier :: T.Text, declarationLanguage :: Maybe Language } - deriving (Eq, Generic, NFData, Show) + deriving (Eq, Generic, Show) getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration getDeclaration = getField diff --git a/src/Syntax.hs b/src/Syntax.hs index b04d80f69..c628cdbe1 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} module Syntax where -import Control.DeepSeq import Data.Aeson import Data.Align.Generic import Data.Functor.Classes @@ -111,7 +110,7 @@ data Syntax f | Ty [f] -- | A send statement has a channel and an expression in Go. | Send f f - deriving (Eq, Foldable, Functor, GAlign, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData) + deriving (Eq, Foldable, Functor, GAlign, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON) extractLeafValue :: Syntax a -> Maybe Text diff --git a/test/IntegrationSpec.hs b/test/IntegrationSpec.hs index 9eb8cc855..45b0b342d 100644 --- a/test/IntegrationSpec.hs +++ b/test/IntegrationSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, OverloadedStrings #-} module IntegrationSpec where -import Control.DeepSeq import qualified Data.ByteString as B import Data.Foldable (find, traverse_) import Data.Functor.Both @@ -113,7 +112,7 @@ stripWhitespace = B.foldl' go B.empty -- | A wrapper around 'B.ByteString' with a more readable 'Show' instance. newtype Verbatim = Verbatim B.ByteString - deriving (Eq, NFData) + deriving (Eq) instance Show Verbatim where showsPrec _ (Verbatim byteString) = ('\n':) . (T.unpack (decodeUtf8 byteString) ++) From d5af30009497a8274a9ccde93055a5ac96f6c4c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:38:12 +0100 Subject: [PATCH 022/113] Specialize the Pretty1 instance for Term to only apply to Terms of Unions. --- src/Term.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Term.hs b/src/Term.hs index 967540c39..b026fe4db 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -53,15 +53,12 @@ hoistTerm f = go where go (a :< r) = a :< f (fmap go r) liftPrettyUnion :: Apply1 Pretty1 fs => (a -> Doc ann) -> ([a] -> Doc ann) -> Union fs a -> Doc ann liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) -instance Pretty1 f => Pretty1 (Term f) where - liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (Pretty.list . map (liftPretty p pl)) f +instance Apply1 Pretty1 fs => Pretty1 (Term (Union fs)) where + liftPretty p pl = go where go (a :< f) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f -instance (Pretty1 f, Pretty a) => Pretty (Term f a) where +instance (Apply1 Pretty1 fs, Pretty a) => Pretty (Term (Union fs) a) where pretty = liftPretty pretty prettyList -instance Apply1 Pretty1 fs => Pretty1 (Union fs) where - liftPretty = liftPrettyUnion - type instance Base (Term f a) = TermF f a instance Functor f => Recursive (Term f a) where project = unTerm From c551923eff0250e491fc426bb995e0788a3e2a2f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:38:35 +0100 Subject: [PATCH 023/113] :fire: some unnecessary extensions. --- src/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Term.hs b/src/Term.hs index b026fe4db..d1ba04258 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies #-} module Term ( Term(..) , TermF(..) From 20758f1c31117635824638d3c9700c32b9386efe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:38:51 +0100 Subject: [PATCH 024/113] :fire: the orphan instance disabling in Diff. --- src/Diff.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Diff.hs b/src/Diff.hs index a7e305179..7da32c5e3 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Diff where import qualified Control.Monad.Free as Free From e4c5d6bb825db8429bf36a3787461e78db962dc8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:40:35 +0100 Subject: [PATCH 025/113] Rename the Term/TermF type parameters. --- src/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Term.hs b/src/Term.hs index d1ba04258..f3a900331 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -26,9 +26,9 @@ import Syntax -- | A Term with an abstract syntax tree and an annotation. infixr 5 :< -data Term f a = a :< f (Term f a) +data Term expr ann = ann :< expr (Term expr ann) infixr 5 :<< -data TermF f a b = (:<<) { headF :: a, tailF :: f b } +data TermF expr ann recur = (:<<) { headF :: ann, tailF :: expr recur } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. From 14e8bb46ec52bd25b1464cabca97c08144ef7a4c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:40:54 +0100 Subject: [PATCH 026/113] :fire: UndecidableInstances in Assignment. --- 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 a4f684287..7eb92d5a1 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-} -- | Assignment of AST onto some other structure (typically terms). -- -- Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and Span). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference. From adf884def0f0b44dbda561a169d3e13349969127 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 17:41:31 +0100 Subject: [PATCH 027/113] Rename expr to syntax. --- src/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Term.hs b/src/Term.hs index f3a900331..7501106db 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -26,9 +26,9 @@ import Syntax -- | A Term with an abstract syntax tree and an annotation. infixr 5 :< -data Term expr ann = ann :< expr (Term expr ann) +data Term syntax ann = ann :< syntax (Term syntax ann) infixr 5 :<< -data TermF expr ann recur = (:<<) { headF :: ann, tailF :: expr recur } +data TermF syntax ann recur = (:<<) { headF :: ann, tailF :: syntax recur } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. From 9e40e9a09ace11be413c7ff8360a94abef3e769b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:23:57 +0100 Subject: [PATCH 028/113] Give our own definition of Diff. --- src/Algorithm.hs | 9 ++-- src/Alignment.hs | 6 ++- src/Diff.hs | 90 ++++++++++++++++++++++++------------- src/Interpreter.hs | 21 +++++---- src/Patch.hs | 18 -------- src/RWS.hs | 17 ------- src/Renderer/JSON.hs | 28 ++++++------ src/Renderer/SExpression.hs | 7 ++- src/Renderer/TOC.hs | 16 ++++--- src/Semantic.hs | 9 ++-- src/Semantic/Task.hs | 4 +- src/Term.hs | 10 ++++- test/TOCSpec.hs | 2 +- 13 files changed, 121 insertions(+), 116 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 2e38b3f96..ed16ba716 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -3,8 +3,7 @@ module Algorithm where import Control.Applicative (liftA2) import Control.Monad (guard, join) -import Control.Monad.Free (wrap) -import Control.Monad.Free.Freer hiding (wrap) +import Control.Monad.Free.Freer import Data.Function (on) import Data.Functor.Both import Data.Functor.Classes @@ -40,7 +39,7 @@ type Algorithm term diff = Freer (AlgorithmF term diff) -- | Diff two terms without specifying the algorithm to be used. diff :: term -> term -> Algorithm term diff diff -diff = (liftF .) . Diff +diff = (liftF .) . Algorithm.Diff -- | Diff a These of terms without specifying the algorithm to be used. diffThese :: These term term -> Algorithm term diff diff @@ -77,7 +76,7 @@ byReplacing = (liftF .) . Replace instance Show term => Show1 (AlgorithmF term diff) where liftShowsPrec _ _ d algorithm = case algorithm of - Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2 + Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2 Linear t1 t2 -> showsBinaryWith showsPrec showsPrec "Linear" d t1 t2 RWS as bs -> showsBinaryWith showsPrec showsPrec "RWS" d as bs Delete t1 -> showsUnaryWith showsPrec "Delete" d t1 @@ -88,7 +87,7 @@ instance Show term => Show1 (AlgorithmF term diff) where -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- (represented by a Nothing diff returned from algorithmFor) replace one term with another. algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a) -algorithmForTerms t1@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 :<<)) <$> algorithmFor f1 f2) +algorithmForTerms t1@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . In (both ann1 ann2)) <$> algorithmFor f1 f2) -- | A type class for determining what algorithm to use for diffing two terms. diff --git a/src/Alignment.hs b/src/Alignment.hs index 301ef5fbc..ab92508c1 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -11,7 +11,7 @@ module Alignment import Data.Bifunctor (bimap, first, second) import Control.Arrow ((***)) import Control.Monad (join) -import Control.Monad.Free +import Control.Monad.Free (wrap) import Data.Align import Data.Bifunctor.Join import Data.Foldable (toList) @@ -47,7 +47,9 @@ hasChanges = or . (True <$) -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side. alignDiff :: Traversable f => HasField fields Range => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))] -alignDiff sources diff = iter (alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources) (alignPatch sources <$> diff) +alignDiff sources = cata $ \ diff -> case diff of + In ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :<< r) + Patch patch -> alignPatch sources patch -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff. alignPatch :: forall fields f. (Traversable f, HasField fields Range) => Both Source -> Patch (Term f (Record fields)) -> [Join These (SplitDiff [] (Record fields))] diff --git a/src/Diff.hs b/src/Diff.hs index 7da32c5e3..9d57f755a 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -1,34 +1,41 @@ -{-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-} +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-} module Diff where -import qualified Control.Monad.Free as Free -import qualified Control.Monad.Trans.Free as FreeF import Data.Bifunctor import Data.Functor.Both as Both import Data.Functor.Classes.Pretty.Generic +import Data.Functor.Foldable import Data.Mergeable import Data.Record +import Data.Union import Patch import Syntax import Term -- | An annotated series of patches of terms. -type DiffF f annotation = FreeF.FreeF (TermF f (Both annotation)) (Patch (Term f annotation)) -type Diff f annotation = Free.Free (TermF f (Both annotation)) (Patch (Term f annotation)) +newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) } + +data DiffF syntax ann recur + = In (Both ann) (syntax recur) + | Patch (Patch (Term syntax ann)) + deriving (Functor) 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 +diffSum :: (Foldable syntax, Functor syntax) => (Patch (Term syntax annotation) -> Int) -> Diff syntax annotation -> Int +diffSum patchCost = go + where go (Diff (In _ syntax)) = sum (fmap go syntax) + go (Diff (Patch patch)) = patchCost patch -- | The sum of the node count of the diff’s patches. -diffCost :: (Foldable f, Functor f) => Diff f annotation -> Int -diffCost = diffSum $ patchSum termSize +diffCost :: (Foldable syntax, Functor syntax) => Diff syntax annotation -> Int +diffCost = diffSum (patchSum termSize) -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. -mergeMaybe :: Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation) -mergeMaybe transform extractAnnotation = Free.iter algebra . fmap transform - where algebra (annotations :<< syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax +mergeMaybe :: Mergeable syntax => (Patch (Term syntax annotation) -> Maybe (Term syntax annotation)) -> (Both annotation -> annotation) -> Diff syntax annotation -> Maybe (Term syntax annotation) +mergeMaybe transform extractAnnotation = cata algebra + where algebra (In annotations syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax + algebra (Patch term) = transform term -- | Recover the before state of a diff. beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation) @@ -38,28 +45,51 @@ beforeTerm = mergeMaybe before Both.fst afterTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation) afterTerm = mergeMaybe after Both.snd --- | Map a function over the annotations in a diff, whether in diff or term nodes. --- --- Typed using Free so as to accommodate Free structures derived from diffs that don’t fit into the Diff type synonym. -mapAnnotations :: (Functor f, Functor g) - => (annotation -> annotation') - -> Free.Free (TermF f (g annotation)) (Patch (Term f annotation)) - -> Free.Free (TermF f (g annotation')) (Patch (Term f annotation')) -mapAnnotations f = Free.hoistFree (first (fmap f)) . fmap (fmap (fmap f)) + +-- | Strips the head annotation off a diff annotated with non-empty records. +stripDiff :: Functor f + => Diff f (Record (h ': t)) + -> Diff f (Record t) +stripDiff = fmap rtail -free :: FreeF.FreeF f a (Free.Free f a) -> Free.Free f a -free (FreeF.Free f) = Free.Free f -free (FreeF.Pure a) = Free.Pure a +-- | Constructs the replacement of one value by another in an Applicative context. +replacing :: Term syntax ann -> Term syntax ann -> Diff syntax ann +replacing = (Diff .) . (Patch .) . Replace -runFree :: Free.Free f a -> FreeF.FreeF f a (Free.Free f a) -runFree (Free.Free f) = FreeF.Free f -runFree (Free.Pure a) = FreeF.Pure a +-- | Constructs the insertion of a value in an Applicative context. +inserting :: Term syntax ann -> Diff syntax ann +inserting = Diff . Patch . Insert + +-- | Constructs the deletion of a value in an Applicative context. +deleting :: Term syntax ann -> Diff syntax ann +deleting = Diff . Patch . Delete -instance Pretty1 f => Pretty1 (Free.Free f) where - liftPretty p pl = go where go (Free.Pure a) = p a - go (Free.Free f) = liftPretty go (list . map (liftPretty p pl)) f +wrapTermF :: TermF syntax (Both ann) (Diff syntax ann) -> Diff syntax ann +wrapTermF (a :<< r) = Diff (In a r) -instance (Pretty1 f, Pretty a) => Pretty (Free.Free f a) where + +instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where + liftPretty p pl = go + where go (Diff (In _ syntax)) = liftPrettyUnion go (list . map (liftPretty p pl)) syntax + go (Diff (Patch patch)) = liftPretty (liftPretty p pl) (list . map (liftPretty p pl)) patch + +instance (Apply1 Pretty1 fs, Pretty ann) => Pretty (Diff (Union fs) ann) where pretty = liftPretty pretty prettyList + +instance Apply1 Pretty1 fs => Pretty2 (DiffF (Union fs)) where + liftPretty2 pA plA pB plB (In (Join ann) f) = liftPretty2 pA plA pA plA ann <+> liftPrettyUnion pB plB f + liftPretty2 pA plA _ _ (Patch p) = liftPretty (liftPretty pA plA) (list . map (liftPretty pA plA)) p + +type instance Base (Diff syntax ann) = DiffF syntax ann + +instance Functor syntax => Recursive (Diff syntax ann) where project = unDiff +instance Functor syntax => Corecursive (Diff syntax ann) where embed = Diff + +instance Functor syntax => Functor (Diff syntax) where + fmap f = Diff . bimap f (fmap f) . unDiff + +instance Functor syntax => Bifunctor (DiffF syntax) where + bimap f g (In anns r) = In (fmap f anns) (fmap g r) + bimap f _ (Patch term) = Patch (fmap (fmap f) term) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 1aef66bc7..ee89d659c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -7,8 +7,7 @@ module Interpreter ) where import Algorithm -import Control.Monad.Free (cutoff, wrap) -import Control.Monad.Free.Freer hiding (cutoff, wrap) +import Control.Monad.Free.Freer import Data.Align.Generic import Data.Functor.Both import Data.Functor.Classes (Eq1) @@ -19,7 +18,7 @@ import Data.Text (Text) import Data.These import Diff import Info hiding (Return) -import Patch (inserting, deleting, replacing, patchSum) +import Patch (patchSum) import RWS import Syntax as S hiding (Return) import Term @@ -48,9 +47,9 @@ diffTermsWith :: forall f fields . (Traversable f, GAlign f, Eq1 f, HasField fie 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 + Algorithm.Diff t1 t2 -> refine t1 t2 Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of - Just result -> wrap . (both (extract t1) (extract t2) :<<) <$> sequenceA result + Just result -> Diff.Diff . In (both (extract t1) (extract t2)) <$> sequenceA result _ -> byReplacing t1 t2 RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs) Delete a -> pure (deleting a) @@ -105,7 +104,7 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of <*> byRWS bodyA bodyB _ -> linearly t1 t2 where - annotate = wrap . (both (extract t1) (extract t2) :<<) + annotate = Diff.Diff . In (both (extract t1) (extract t2)) -- | Test whether two terms are comparable by their Category. @@ -124,6 +123,10 @@ defaultM = 10 -- | Return an edit distance as the sum of it's term sizes, given an cutoff and a syntax of terms 'f a'. -- | Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost. editDistanceUpTo :: (GAlign f, Foldable f, Functor f) => Integer -> These (Term f (Record fields)) (Term f (Record fields)) -> Int -editDistanceUpTo m = these termSize termSize (\ a b -> diffSum (patchSum termSize) (cutoff m (approximateDiff a b))) - where diffSum patchCost = sum . fmap (maybe 0 patchCost) - approximateDiff a b = maybe (replacing a b) wrap (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b)) +editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b)) + where diffCost m (Diff.Diff diff) + | m <= 0 = 0 + | otherwise = case diff of + In _ r -> sum (fmap (diffCost (pred m)) r) + Patch patch -> patchSum termSize patch + approximateDiff a b = maybe (replacing a b) (Diff.Diff . In (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b)) diff --git a/src/Patch.hs b/src/Patch.hs index 9ed5701a2..a07a709f7 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -2,9 +2,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Patch ( Patch(..) -, replacing -, inserting -, deleting , after , before , unPatch @@ -28,21 +25,6 @@ data Patch a deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) --- DSL - --- | Constructs the replacement of one value by another in an Applicative context. -replacing :: Applicative f => a -> a -> f (Patch a) -replacing = (pure .) . Replace - --- | Constructs the insertion of a value in an Applicative context. -inserting :: Applicative f => a -> f (Patch a) -inserting = pure . Insert - --- | Constructs the deletion of a value in an Applicative context. -deleting :: Applicative f => a -> f (Patch a) -deleting = pure . Delete - - -- | Return the item from the after side of the patch. after :: Patch a -> Maybe a after = maybeSnd . unPatch diff --git a/src/RWS.hs b/src/RWS.hs index 87ae27521..8fd38ae5d 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -3,9 +3,7 @@ module RWS ( rws , ComparabilityRelation , FeatureVector - , stripDiff , defaultFeatureVectorDecorator - , stripTerm , featureVectorDecorator , pqGramDecorator , Gram(..) @@ -14,7 +12,6 @@ module RWS ( import Control.Applicative (empty) import Control.Arrow ((&&&)) -import Control.Monad.Free import Control.Monad.State.Strict import Data.Foldable import Data.Function ((&), on) @@ -27,7 +24,6 @@ import Data.Record import Data.Semigroup hiding (First(..)) import Data.These import Data.Traversable -import Patch import Term hiding (term) import Data.Array.Unboxed import Data.Functor.Classes @@ -39,7 +35,6 @@ import qualified Data.IntMap as IntMap import Control.Monad.Random import System.Random.Mersenne.Pure64 -import Diff (mapAnnotations) type Label f fields label = forall b. TermF f (Record fields) b -> label @@ -311,18 +306,6 @@ equalTerms canCompare = go where go a b = canCompareTerms canCompare a b && liftEq go (tailF (unTerm a)) (tailF (unTerm b)) --- | Strips the head annotation off a term annotated with non-empty records. -stripTerm :: Functor f => Term f (Record (h ': t)) -> Term f (Record t) -stripTerm = fmap rtail - --- | Strips the head annotation off a diff annotated with non-empty records. -stripDiff - :: (Functor f, Functor g) - => Free (TermF f (g (Record (h ': t)))) (Patch (Term f (Record (h ': t)))) - -> Free (TermF f (g (Record t))) (Patch (Term f (Record t))) -stripDiff = mapAnnotations rtail - - -- Instances instance Hashable label => Hashable (Gram label) where diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 2ca643d28..4bc8a92f8 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -6,8 +6,6 @@ module Renderer.JSON , ToJSONFields(..) ) where -import Control.Monad.Free -import qualified Control.Monad.Trans.Free as FreeF import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) import Data.Aeson as A hiding (json) import Data.Bifunctor.Join @@ -23,6 +21,7 @@ import Data.Semigroup ((<>)) import Data.Text (pack, Text) import Data.Text.Encoding (decodeUtf8) import Data.Union +import Diff import GHC.Generics import Info import Language @@ -45,14 +44,14 @@ renderJSONDiff blobs diff = Map.fromList instance Output (Map.Map Text Value) where toOutput = toStrict . (<> "\n") . encode -instance ToJSON a => ToJSONFields (Join (,) a) where - toJSONFields (Join (a, b)) = [ "before" .= a, "after" .= b ] +instance ToJSONFields a => ToJSONFields (Join (,) a) where + toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ] instance ToJSON a => ToJSON (Join (,) a) where toJSON = toJSON . toList toEncoding = foldable -instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSON (Free f a) where +instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSON (Diff f a) where toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields @@ -91,18 +90,17 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where toJSONFields (a :<< f) = toJSONFields a <> toJSONFields f -instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSONFields (Free f a) where - toJSONFields (Free f) = toJSONFields f - toJSONFields (Pure a) = toJSONFields a +instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSONFields (Diff f a) where + toJSONFields = toJSONFields . unDiff -instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (FreeF.FreeF f a b) where - toJSONFields (FreeF.Free f) = toJSONFields f - toJSONFields (FreeF.Pure a) = toJSONFields a +instance (ToJSONFields a, ToJSONFields (f b), ToJSONFields (f (Term f a))) => ToJSONFields (DiffF f a b) where + toJSONFields (In a f) = toJSONFields a <> toJSONFields f + toJSONFields (Patch a) = toJSONFields a -instance ToJSON a => ToJSONFields (Patch a) where - toJSONFields (Insert a) = [ "insert" .= a ] - toJSONFields (Delete a) = [ "delete" .= a ] - toJSONFields (Replace a b) = [ "replace" .= [a, b] ] +instance ToJSONFields a => ToJSONFields (Patch a) where + toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ] + toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ] + toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ] instance ToJSON a => ToJSONFields [a] where toJSONFields list = [ "children" .= list ] diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index cec6833d3..116d04428 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -4,7 +4,6 @@ module Renderer.SExpression , renderSExpressionTerm ) where -import Control.Monad.Trans.Free hiding (runFree) import Data.Bifunctor.Join import Data.ByteString.Char8 hiding (foldr, spanEnd) import Data.Record @@ -23,12 +22,12 @@ renderSExpressionTerm :: (ConstrainAll Show fields, Foldable f) => Term f (Recor renderSExpressionTerm term = printTerm term 0 <> "\n" printDiff :: (ConstrainAll Show fields, Foldable f) => Diff f (Record fields) -> Int -> ByteString -printDiff diff level = case runFree diff of - Pure patch -> case patch of +printDiff diff level = case unDiff diff of + Patch patch -> case patch of Insert term -> pad (level - 1) <> "{+" <> printTerm term level <> "+}" Delete term -> pad (level - 1) <> "{-" <> printTerm term level <> "-}" Replace a b -> pad (level - 1) <> "{ " <> printTerm a level <> pad (level - 1) <> "->" <> printTerm b level <> " }" - Free (Join (_, annotation) :<< syntax) -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")" + In (Join (_, annotation)) syntax -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")" where pad' :: Int -> ByteString pad' n = if n < 1 then "" else pad n diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 88e44fcdf..adf80cdf2 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -17,10 +17,9 @@ module Renderer.TOC , entrySummary ) where -import Control.Monad.Free (iter) import Data.Aeson import Data.Align (crosswalk) -import Data.Bifunctor (bimap, first) +import Data.Bifunctor (bimap) import Data.Blob import Data.ByteString.Lazy (toStrict) import Data.Error as Error (formatError) @@ -153,11 +152,14 @@ tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f annotation b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f annotation -- ^ The diff to compute the table of contents for. -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. -tableOfContentsBy selector = fromMaybe [] . iter diffAlgebra . fmap (Just . fmap patchEntry . crosswalk (termTableOfContentsBy selector)) - where diffAlgebra r = case (selector (first Both.snd r), fold r) of - (Just a, Nothing) -> Just [Unchanged a] - (Just a, Just []) -> Just [Changed a] - (_ , entries) -> entries +tableOfContentsBy selector = fromMaybe [] . cata diffAlgebra + where diffAlgebra r = case r of + In ann r -> case (selector (Both.snd ann :<< r), fold r) of + (Just a, Nothing) -> Just [Unchanged a] + (Just a, Just []) -> Just [Changed a] + (_ , entries) -> entries + Patch patch -> Just (patchEntry <$> crosswalk (termTableOfContentsBy selector) patch) + patchEntry = these Deleted Inserted (const Replaced) . unPatch termTableOfContentsBy :: (Foldable f, Functor f) diff --git a/src/Semantic.hs b/src/Semantic.hs index ceb97cdd1..388a6ebee 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -24,7 +24,6 @@ import Diff import Info import Interpreter import qualified Language -import Patch import Parser import Renderer import Semantic.Task as Task @@ -81,10 +80,10 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of (PatchDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffRecursively (renderPatch blobs) (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffRecursively (renderPatch blobs) (PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs) - (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffRecursively (renderSExpressionDiff . mapAnnotations keepConstructorLabel) - (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate constructorLabel <=< parse markdownParser) diffRecursively (renderSExpressionDiff . mapAnnotations keepConstructorLabel) - (SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffRecursively (renderSExpressionDiff . mapAnnotations keepConstructorLabel) - (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . mapAnnotations keepCategory) + (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel) + (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate constructorLabel <=< parse markdownParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel) + (SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel) + (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . fmap keepCategory) (IdentityDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms Just where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs) syntaxParser = parserForLanguage effectiveLanguage diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index b6bae0afd..899cb2465 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -118,7 +118,7 @@ decorate algebra term = Decorate algebra term `Then` return -- | A 'Task' which diffs a pair of terms using the supplied 'Differ' function. diff :: Differ f a -> Both (Term f a) -> Task (Diff f a) -diff differ terms = Diff differ terms `Then` return +diff differ terms = Semantic.Task.Diff differ terms `Then` return -- | A 'Task' which renders some input using the supplied 'Renderer' function. render :: Renderer input output -> input -> Task output @@ -182,7 +182,7 @@ runTaskWithOptions options task = do either (pure . Left) yield res Parse parser blob -> go (runParser options blob parser) >>= either (pure . Left) yield Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield - Diff differ terms -> pure (differ terms) >>= yield + Semantic.Task.Diff differ terms -> pure (differ terms) >>= yield Render renderer input -> pure (renderer input) >>= yield Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq)) LiftIO action -> action >>= yield diff --git a/src/Term.hs b/src/Term.hs index 7501106db..0fc62533f 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies #-} +{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeOperators #-} module Term ( Term(..) , TermF(..) @@ -10,6 +10,8 @@ module Term , extract , unwrap , hoistTerm +, stripTerm +, liftPrettyUnion ) where import Control.Comonad @@ -50,9 +52,15 @@ unTerm (a :< f) = a :<< f hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistTerm f = go where go (a :< r) = a :< f (fmap go r) +-- | Strips the head annotation off a term annotated with non-empty records. +stripTerm :: Functor f => Term f (Record (h ': t)) -> Term f (Record t) +stripTerm = fmap rtail + + liftPrettyUnion :: Apply1 Pretty1 fs => (a -> Doc ann) -> ([a] -> Doc ann) -> Union fs a -> Doc ann liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) + instance Apply1 Pretty1 fs => Pretty1 (Term (Union fs)) where liftPretty p pl = go where go (a :< f) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 96be8307d..403dc24e9 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -58,7 +58,7 @@ spec = parallel $ do \ 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 <$) <$> fmap (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 null diff' then [Unchanged 0] else replicate (length diff') (Changed 0) From 1267fe5ea7ce68e455fbf98fc73eb810bc9acf10 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:27:04 +0100 Subject: [PATCH 029/113] Rename the In constructor to Copy. --- src/Algorithm.hs | 2 +- src/Alignment.hs | 2 +- src/Diff.hs | 14 +++++++------- src/Interpreter.hs | 8 ++++---- src/Renderer/JSON.hs | 2 +- src/Renderer/SExpression.hs | 2 +- src/Renderer/TOC.hs | 2 +- 7 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index ed16ba716..4769cba79 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -87,7 +87,7 @@ instance Show term => Show1 (AlgorithmF term diff) where -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- (represented by a Nothing diff returned from algorithmFor) replace one term with another. algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a) -algorithmForTerms t1@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . In (both ann1 ann2)) <$> algorithmFor f1 f2) +algorithmForTerms t1@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . Copy (both ann1 ann2)) <$> algorithmFor f1 f2) -- | A type class for determining what algorithm to use for diffing two terms. diff --git a/src/Alignment.hs b/src/Alignment.hs index ab92508c1..62433fd37 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -48,7 +48,7 @@ hasChanges = or . (True <$) -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side. alignDiff :: Traversable f => HasField fields Range => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))] alignDiff sources = cata $ \ diff -> case diff of - In ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :<< r) + Copy ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :<< r) Patch patch -> alignPatch sources patch -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff. diff --git a/src/Diff.hs b/src/Diff.hs index 9d57f755a..ba7ddb7e5 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -16,7 +16,7 @@ import Term newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) } data DiffF syntax ann recur - = In (Both ann) (syntax recur) + = Copy (Both ann) (syntax recur) | Patch (Patch (Term syntax ann)) deriving (Functor) @@ -24,7 +24,7 @@ type SyntaxDiff fields = Diff Syntax (Record fields) diffSum :: (Foldable syntax, Functor syntax) => (Patch (Term syntax annotation) -> Int) -> Diff syntax annotation -> Int diffSum patchCost = go - where go (Diff (In _ syntax)) = sum (fmap go syntax) + where go (Diff (Copy _ syntax)) = sum (fmap go syntax) go (Diff (Patch patch)) = patchCost patch -- | The sum of the node count of the diff’s patches. @@ -34,7 +34,7 @@ diffCost = diffSum (patchSum termSize) -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: Mergeable syntax => (Patch (Term syntax annotation) -> Maybe (Term syntax annotation)) -> (Both annotation -> annotation) -> Diff syntax annotation -> Maybe (Term syntax annotation) mergeMaybe transform extractAnnotation = cata algebra - where algebra (In annotations syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax + where algebra (Copy annotations syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax algebra (Patch term) = transform term -- | Recover the before state of a diff. @@ -67,19 +67,19 @@ deleting = Diff . Patch . Delete wrapTermF :: TermF syntax (Both ann) (Diff syntax ann) -> Diff syntax ann -wrapTermF (a :<< r) = Diff (In a r) +wrapTermF (a :<< r) = Diff (Copy a r) instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where liftPretty p pl = go - where go (Diff (In _ syntax)) = liftPrettyUnion go (list . map (liftPretty p pl)) syntax + where go (Diff (Copy _ syntax)) = liftPrettyUnion go (list . map (liftPretty p pl)) syntax go (Diff (Patch patch)) = liftPretty (liftPretty p pl) (list . map (liftPretty p pl)) patch instance (Apply1 Pretty1 fs, Pretty ann) => Pretty (Diff (Union fs) ann) where pretty = liftPretty pretty prettyList instance Apply1 Pretty1 fs => Pretty2 (DiffF (Union fs)) where - liftPretty2 pA plA pB plB (In (Join ann) f) = liftPretty2 pA plA pA plA ann <+> liftPrettyUnion pB plB f + liftPretty2 pA plA pB plB (Copy (Join ann) f) = liftPretty2 pA plA pA plA ann <+> liftPrettyUnion pB plB f liftPretty2 pA plA _ _ (Patch p) = liftPretty (liftPretty pA plA) (list . map (liftPretty pA plA)) p type instance Base (Diff syntax ann) = DiffF syntax ann @@ -91,5 +91,5 @@ instance Functor syntax => Functor (Diff syntax) where fmap f = Diff . bimap f (fmap f) . unDiff instance Functor syntax => Bifunctor (DiffF syntax) where - bimap f g (In anns r) = In (fmap f anns) (fmap g r) + bimap f g (Copy anns r) = Copy (fmap f anns) (fmap g r) bimap f _ (Patch term) = Patch (fmap (fmap f) term) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index ee89d659c..0a9bf5790 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -49,7 +49,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) decompose step = case step of Algorithm.Diff t1 t2 -> refine t1 t2 Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of - Just result -> Diff.Diff . In (both (extract t1) (extract t2)) <$> sequenceA result + Just result -> Diff.Diff . Copy (both (extract t1) (extract t2)) <$> sequenceA result _ -> byReplacing t1 t2 RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs) Delete a -> pure (deleting a) @@ -104,7 +104,7 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of <*> byRWS bodyA bodyB _ -> linearly t1 t2 where - annotate = Diff.Diff . In (both (extract t1) (extract t2)) + annotate = Diff.Diff . Copy (both (extract t1) (extract t2)) -- | Test whether two terms are comparable by their Category. @@ -127,6 +127,6 @@ editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDi where diffCost m (Diff.Diff diff) | m <= 0 = 0 | otherwise = case diff of - In _ r -> sum (fmap (diffCost (pred m)) r) + Copy _ r -> sum (fmap (diffCost (pred m)) r) Patch patch -> patchSum termSize patch - approximateDiff a b = maybe (replacing a b) (Diff.Diff . In (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b)) + approximateDiff a b = maybe (replacing a b) (Diff.Diff . Copy (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b)) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 4bc8a92f8..e9606445f 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -94,7 +94,7 @@ instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a toJSONFields = toJSONFields . unDiff instance (ToJSONFields a, ToJSONFields (f b), ToJSONFields (f (Term f a))) => ToJSONFields (DiffF f a b) where - toJSONFields (In a f) = toJSONFields a <> toJSONFields f + toJSONFields (Copy a f) = toJSONFields a <> toJSONFields f toJSONFields (Patch a) = toJSONFields a instance ToJSONFields a => ToJSONFields (Patch a) where diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index 116d04428..15e01a828 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -27,7 +27,7 @@ printDiff diff level = case unDiff diff of Insert term -> pad (level - 1) <> "{+" <> printTerm term level <> "+}" Delete term -> pad (level - 1) <> "{-" <> printTerm term level <> "-}" Replace a b -> pad (level - 1) <> "{ " <> printTerm a level <> pad (level - 1) <> "->" <> printTerm b level <> " }" - In (Join (_, annotation)) syntax -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")" + Copy (Join (_, annotation)) syntax -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")" where pad' :: Int -> ByteString pad' n = if n < 1 then "" else pad n diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index adf80cdf2..2443b8dd6 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -154,7 +154,7 @@ tableOfContentsBy :: (Foldable f, Functor f) -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. tableOfContentsBy selector = fromMaybe [] . cata diffAlgebra where diffAlgebra r = case r of - In ann r -> case (selector (Both.snd ann :<< r), fold r) of + Copy ann r -> case (selector (Both.snd ann :<< r), fold r) of (Just a, Nothing) -> Just [Unchanged a] (Just a, Just []) -> Just [Changed a] (_ , entries) -> entries From b7e211c9c229566e19394057bedafb94367464ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:47:10 +0100 Subject: [PATCH 030/113] Redefine Term as a wrapper for TermF. --- src/Algorithm.hs | 2 +- src/Alignment.hs | 8 +++--- src/Data/Syntax.hs | 2 +- src/Data/Syntax/Algebra.hs | 6 ++--- src/Data/Syntax/Assignment.hs | 8 +++--- src/Decorators.hs | 4 +-- src/Diff.hs | 6 ++--- src/Interpreter.hs | 6 ++--- src/Language.hs | 14 +++++----- src/Language/Markdown.hs | 2 +- src/Language/Markdown/Syntax.hs | 9 +++---- src/Language/Ruby.hs | 8 +++--- src/Parser.hs | 4 +-- src/RWS.hs | 16 +++++------ src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 8 +++--- src/Renderer/SExpression.hs | 2 +- src/Renderer/TOC.hs | 10 +++---- src/Semantic/Task.hs | 2 +- src/Term.hs | 48 ++++++++++++++------------------- src/TreeSitter.hs | 12 ++++----- 21 files changed, 85 insertions(+), 94 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 4769cba79..18c9a3037 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -87,7 +87,7 @@ instance Show term => Show1 (AlgorithmF term diff) where -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- (represented by a Nothing diff returned from algorithmFor) replace one term with another. algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a) -algorithmForTerms t1@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . Copy (both ann1 ann2)) <$> algorithmFor f1 f2) +algorithmForTerms t1@(Term (ann1 :< f1)) t2@(Term (ann2 :< f2)) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . Copy (both ann1 ann2)) <$> algorithmFor f1 f2) -- | A type class for determining what algorithm to use for diffing two terms. diff --git a/src/Alignment.hs b/src/Alignment.hs index 62433fd37..43f1afbeb 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -48,7 +48,7 @@ hasChanges = or . (True <$) -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side. alignDiff :: Traversable f => HasField fields Range => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))] alignDiff sources = cata $ \ diff -> case diff of - Copy ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :<< r) + Copy ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :< r) Patch patch -> alignPatch sources patch -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff. @@ -61,18 +61,18 @@ alignPatch sources patch = case patch of (alignSyntax' that (snd sources) term2) where getRange = byteRange . extract alignSyntax' :: (forall a. Identity a -> Join These a) -> Source -> Term f (Record fields) -> [Join These (Term [] (Record fields))] - alignSyntax' side source = hylo (alignSyntax side term getRange (Identity source)) unTerm . fmap Identity + alignSyntax' side source = hylo (alignSyntax side Term getRange (Identity source)) unTerm . fmap Identity this = Join . This . runIdentity that = Join . That . runIdentity -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff. alignSyntax :: (Applicative f, HasField fields Range, Foldable g) => (forall a. f a -> Join These a) -> (TermF [] (Record fields) term -> term) -> (term -> Range) -> f Source -> TermF g (f (Record fields)) [Join These term] -> [Join These term] -alignSyntax toJoinThese toNode getRange sources (infos :<< syntax) = +alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = catMaybes $ wrapInBranch <$> alignBranch getRange (join (toList syntax)) bothRanges where bothRanges = modifyJoin (fromThese [] []) lineRanges lineRanges = toJoinThese $ sourceLineRangesWithin . byteRange <$> infos <*> sources wrapInBranch = applyThese $ toJoinThese (makeNode <$> infos) - makeNode info (range, children) = toNode (setByteRange info range :<< children) + makeNode info (range, children) = toNode (setByteRange info range :< children) -- | Given a function to get the range, a list of already-aligned children, and the lists of ranges spanned by a branch, return the aligned lines. alignBranch :: (term -> Range) -> [Join These term] -> Both [Range] -> [Join These (Range, [term])] diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 4cb29b424..187efa6b6 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -32,7 +32,7 @@ makeTerm a = makeTerm' a . inj -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a -makeTerm' a f = (sconcat (a :| (headF . unTerm <$> toList f)) :< f) +makeTerm' a f = Term (sconcat (a :| (headF . unTerm <$> toList f)) :< f) -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index a0e87c725..73701d2ab 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -33,7 +33,7 @@ decoratorWithAlgebra :: Functor f => RAlgebra (Base (Term f (Record fs))) (Term f (Record fs)) a -- ^ An R-algebra on terms. -> Term f (Record fs) -- ^ A term to decorate with values produced by the R-algebra. -> Term f (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra. -decoratorWithAlgebra alg = para $ \ c@(a :<< f) -> (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f +decoratorWithAlgebra alg = para $ \ c@(a :< f) -> Term ((alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f) newtype Identifier = Identifier ByteString @@ -43,7 +43,7 @@ newtype Identifier = Identifier ByteString -- -- Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not. identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier) -identifierAlgebra (_ :<< union) = case union of +identifierAlgebra (_ :< union) = case union of _ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s) _ | Just Declaration.Class{..} <- prj union -> classIdentifier _ | Just Declaration.Method{..} <- prj union -> methodName @@ -59,7 +59,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int -- TODO: Anonymous functions should not increase parent scope’s complexity. -- TODO: Inner functions should not increase parent scope’s complexity. cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity -cyclomaticComplexityAlgebra (_ :<< union) = case union of +cyclomaticComplexityAlgebra (_ :< union) = case union of _ | Just Declaration.Method{} <- prj union -> succ (sum union) _ | Just Statement.Return{} <- prj union -> succ (sum union) _ | Just Statement.Yield{} <- prj union -> succ (sum union) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 7eb92d5a1..410b1e5ab 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -256,9 +256,9 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar) run t yield initialState = expectedSymbols `seq` state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes) - where atNode (node :< f) = case runTracing t of + where atNode (Term (node :< f)) = case runTracing t of Location -> yield (nodeLocation node) state - CurrentNode -> yield (node :<< (() <$ f)) state + CurrentNode -> yield (node :< (() <$ f)) state Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state) Children child -> do (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t) @@ -286,7 +286,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha requireExhaustive :: Symbol grammar => Maybe (String, SrcLoc) -> (result, State ast grammar) -> Either (Error (Either String grammar)) (result, State ast grammar) requireExhaustive callSite (a, state) = let state' = skipTokens state in case stateNodes state' of [] -> Right (a, state') - (node :< _) : _ -> Left (withStateCallStack callSite state (nodeError [] node)) + Term (node :< _) : _ -> Left (withStateCallStack callSite state (nodeError [] node)) withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallStack => a) -> a withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action @@ -297,7 +297,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n -- | 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 ast grammar -> State ast grammar advanceState state@State{..} - | (Node{..} :< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest + | Term (Node{..} :< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest | otherwise = state -- | State kept while running 'Assignment's. diff --git a/src/Decorators.hs b/src/Decorators.hs index 463dac736..7b646e893 100644 --- a/src/Decorators.hs +++ b/src/Decorators.hs @@ -20,11 +20,11 @@ import Term -- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that -- constant fields will be included and parametric fields will not be. constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString -constructorNameAndConstantFields (_ :<< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "") +constructorNameAndConstantFields (_ :< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "") -- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's. constructorLabel :: Apply1 ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel -constructorLabel (_ :<< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u) +constructorLabel (_ :< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u) newtype ConstructorLabel = ConstructorLabel ByteString diff --git a/src/Diff.hs b/src/Diff.hs index ba7ddb7e5..236683932 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -34,8 +34,8 @@ diffCost = diffSum (patchSum termSize) -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: Mergeable syntax => (Patch (Term syntax annotation) -> Maybe (Term syntax annotation)) -> (Both annotation -> annotation) -> Diff syntax annotation -> Maybe (Term syntax annotation) mergeMaybe transform extractAnnotation = cata algebra - where algebra (Copy annotations syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax - algebra (Patch term) = transform term + where algebra (Copy annotations syntax) = Term . (extractAnnotation annotations :<) <$> sequenceAlt syntax + algebra (Patch patch) = transform patch -- | Recover the before state of a diff. beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation) @@ -67,7 +67,7 @@ deleting = Diff . Patch . Delete wrapTermF :: TermF syntax (Both ann) (Diff syntax ann) -> Diff syntax ann -wrapTermF (a :<< r) = Diff (Copy a r) +wrapTermF (a :< r) = Diff (Copy a r) instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0a9bf5790..5667f3246 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -58,7 +58,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) -- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram. getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text) -getLabel (h :<< t) = (Info.category h, case t of +getLabel (h :< t) = (Info.category h, case t of Leaf s -> Just s _ -> Nothing) @@ -109,11 +109,11 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Test whether two terms are comparable by their Category. comparableByCategory :: HasField fields Category => ComparabilityRelation f fields -comparableByCategory (a :<< _) (b :<< _) = category a == category b +comparableByCategory (a :< _) (b :< _) = category a == category b -- | Test whether two terms are comparable by their constructor. comparableByConstructor :: GAlign f => ComparabilityRelation f fields -comparableByConstructor (_ :<< a) (_ :<< b) = isJust (galign a b) +comparableByConstructor (_ :< a) (_ :< b) = isJust (galign a b) -- | How many nodes to consider for our constant-time approximation to tree edit distance. diff --git a/src/Language.hs b/src/Language.hs index 9b3178eee..b2fee057a 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -38,19 +38,19 @@ languageForType mediaType = case mediaType of toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) toVarDeclOrAssignment child = case unwrap child of - S.Indexed [child', assignment] -> setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment - S.Indexed [child'] -> setCategory (extract child) VarDecl :< S.VarDecl [child'] - S.VarDecl _ -> setCategory (extract child) VarDecl :< unwrap child + S.Indexed [child', assignment] -> Term (setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment) + S.Indexed [child'] -> Term (setCategory (extract child) VarDecl :< S.VarDecl [child']) + S.VarDecl _ -> Term (setCategory (extract child) VarDecl :< unwrap child) S.VarAssignment _ _ -> child _ -> toVarDecl child toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) -toVarDecl child = setCategory (extract child) VarDecl :< S.VarDecl [child] +toVarDecl child = Term (setCategory (extract child) VarDecl :< S.VarDecl [child]) toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)] -toTuple child | S.Indexed [key,value] <- unwrap child = [extract child :< S.Pair key value] -toTuple child | S.Fixed [key,value] <- unwrap child = [extract child :< S.Pair key value] -toTuple child | S.Leaf c <- unwrap child = [extract child :< S.Comment c] +toTuple child | S.Indexed [key,value] <- unwrap child = [Term (extract child :< S.Pair key value)] +toTuple child | S.Fixed [key,value] <- unwrap child = [Term (extract child :< S.Pair key value)] +toTuple child | S.Leaf c <- unwrap child = [Term (extract child :< S.Comment c)] toTuple child = pure child toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index b33727117..055d50236 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -54,7 +54,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT toTerm within withinSpan (Node position t children) = let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position span = maybe withinSpan toSpan position - in (A.Node (toGrammar t) range span) :< (t :<< (toTerm range span <$> children)) + in Term ((A.Node (toGrammar t) range span) :< (t :< (toTerm range span <$> children))) toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 89899ad98..677748c74 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -3,7 +3,7 @@ module Language.Markdown.Syntax ( assignment , Syntax , Grammar -, Term +, Language.Markdown.Syntax.Term ) where import qualified CMarkGFM @@ -20,8 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) -import Term (TermF(..), unwrap, headF, tailF) -import qualified Term +import Term (Term(..), TermF(..), unwrap, headF, tailF) type Syntax = '[ Markup.Document @@ -52,7 +51,7 @@ type Syntax = ] type Term = Term.Term (Union Syntax) (Record Location) -type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Term +type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Language.Markdown.Syntax.Term assignment :: Assignment @@ -68,7 +67,7 @@ paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) list :: Assignment -list = (Term.:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of +list = (Term .) . (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . headF . tailF <$> currentNode <*> children (many item)) diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index dacbcfb24..1b4bde5f7 100644 --- a/src/Language/Ruby.hs +++ b/src/Language/Ruby.hs @@ -57,10 +57,10 @@ termAssignment _ category children -> Just $ S.FunctionCall fn [] (toList . unwrap =<< args) (Object, _ ) -> Just . S.Object Nothing $ foldMap toTuple children (Modifier If, [ lhs, condition ]) -> Just $ S.If condition [lhs] - (Modifier Unless, [lhs, rhs]) -> Just $ S.If (setCategory (extract rhs) Negate :< S.Negate rhs) [lhs] - (Unless, expr : rest) -> Just $ S.If ((setCategory (extract expr) Negate) :< S.Negate expr) rest - (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (setCategory (extract rhs) Negate :< S.Negate rhs) [lhs] - (Until, expr : rest) -> Just $ S.While (setCategory (extract expr) Negate :< S.Negate expr) rest + (Modifier Unless, [lhs, rhs]) -> Just $ S.If (Term (setCategory (extract rhs) Negate :< S.Negate rhs)) [lhs] + (Unless, expr : rest) -> Just $ S.If (Term (setCategory (extract expr) Negate :< S.Negate expr)) rest + (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (Term (setCategory (extract rhs) Negate :< S.Negate rhs)) [lhs] + (Until, expr : rest) -> Just $ S.While (Term (setCategory (extract expr) Negate :< S.Negate expr)) rest (Elsif, condition : body ) -> Just $ S.If condition body (SubscriptAccess, [ base, element ]) -> Just $ S.SubscriptAccess base element (For, lhs : expr : rest ) -> Just $ S.For [lhs, expr] rest diff --git a/src/Parser.hs b/src/Parser.hs index f88c41048..78e081820 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -78,5 +78,5 @@ markdownParser = AssignmentParser MarkdownParser Markdown.assignment -- | A fallback parser that treats a file simply as rows of strings. lineByLineParser :: Source -> SyntaxTerm DefaultFields -lineByLineParser source = (totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source)) - where toLine line range = (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source)) +lineByLineParser source = Term ((totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source))) + where toLine line range = Term ((range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source))) diff --git a/src/RWS.hs b/src/RWS.hs index 8fd38ae5d..fdfadded4 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -24,7 +24,7 @@ import Data.Record import Data.Semigroup hiding (First(..)) import Data.These import Data.Traversable -import Term hiding (term) +import Term import Data.Array.Unboxed import Data.Functor.Classes import SES @@ -139,7 +139,7 @@ findNearestNeighbourToDiff' :: (Diff f fields -> Int) -- ^ A function computes a (Maybe (MappedDiff f fields)) findNearestNeighbourToDiff' editDistance canCompare kdTrees termThing = case termThing of None -> pure Nothing - Term term -> Just <$> findNearestNeighbourTo editDistance canCompare kdTrees term + RWS.Term term -> Just <$> findNearestNeighbourTo editDistance canCompare kdTrees term Index i -> modify' (\ (_, unA, unB) -> (i, unA, unB)) >> pure Nothing -- | Construct a diff for a term in B by matching it against the most similar eligible term in A (if any), marking both as ineligible for future matches. @@ -212,7 +212,7 @@ genFeaturizedTermsAndDiffs :: (Functor f, HasField fields FeatureVector) genFeaturizedTermsAndDiffs sesDiffs = let Mapping _ _ a b c d = foldl' combine (Mapping 0 0 [] [] [] []) sesDiffs in (reverse a, reverse b, reverse c, reverse d) where combine (Mapping counterA counterB as bs mappedDiffs allDiffs) diff = case diff of This term -> Mapping (succ counterA) counterB (featurize counterA term : as) bs mappedDiffs (None : allDiffs) - That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (Term (featurize counterB term) : allDiffs) + That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (RWS.Term (featurize counterB term) : allDiffs) These a b -> Mapping (succ counterA) (succ counterB) as bs ((These counterA counterB, These a b) : mappedDiffs) (Index counterA : allDiffs) data Mapping f fields = Mapping {-# UNPACK #-} !Int {-# UNPACK #-} !Int ![UnmappedTerm f fields] ![UnmappedTerm f fields] ![MappedDiff f fields] ![TermOrIndexOrNone (UnmappedTerm f fields)] @@ -221,7 +221,7 @@ featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term) eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields) -eraseFeatureVector (record :< functor) = setFeatureVector record nullFeatureVector :< functor +eraseFeatureVector (Term.Term (record :< functor)) = Term.Term (setFeatureVector record nullFeatureVector :< functor) nullFeatureVector :: FeatureVector nullFeatureVector = listArray (0, 0) [0] @@ -255,7 +255,7 @@ featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields labe featureVectorDecorator getLabel p q d = cata collect . pqGramDecorator getLabel p q - where collect ((gram :. rest) :<< functor) = ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor) + where collect ((gram :. rest) :< functor) = Term.Term ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor) addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector addSubtermVector v term = addVectors v (rhead (extract term)) @@ -273,7 +273,7 @@ pqGramDecorator pqGramDecorator getLabel p q = cata algebra where algebra term = let label = getLabel term in - ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label) + Term.Term ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) @@ -281,10 +281,10 @@ pqGramDecorator getLabel p q = cata algebra => label -> Term f (Record (Gram label ': fields)) -> State [Maybe label] (Term f (Record (Gram label ': fields))) - assignLabels label ((gram :. rest) :< functor) = do + assignLabels label (Term.Term ((gram :. rest) :< functor)) = do labels <- get put (drop 1 labels) - pure $! ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) :< functor) + pure $! Term.Term ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) :< functor) siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label] siblingLabels = foldMap (base . rhead . extract) padToSize n list = take n (list <> repeat empty) diff --git a/src/Renderer.hs b/src/Renderer.hs index 11cb31d03..9b0bb09ae 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -74,7 +74,7 @@ data SomeRenderer f where deriving instance Show (SomeRenderer f) identifierAlgebra :: RAlgebra (TermF Syntax a) (Term Syntax a) (Maybe Identifier) -identifierAlgebra (_ :<< syntax) = case syntax of +identifierAlgebra (_ :< syntax) = case syntax of S.Assignment f _ -> identifier f S.Class f _ _ -> identifier f S.Export f _ -> f >>= identifier diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index e9606445f..88d50de76 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -56,8 +56,8 @@ instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a toEncoding = pairs . mconcat . toJSONFields instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) where - toJSON (a :< f) = object (toJSONFields a <> toJSONFields f) - toEncoding (a :< f) = pairs (mconcat (toJSONFields a <> toJSONFields f)) + toJSON = object . toJSONFields + toEncoding = pairs . mconcat . toJSONFields class ToJSONFields a where toJSONFields :: KeyValue kv => a -> [kv] @@ -85,10 +85,10 @@ instance ToJSONFields a => ToJSONFields (Maybe a) where toJSONFields = maybe [] toJSONFields instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where - toJSONFields (a :< f) = toJSONFields a <> toJSONFields f + toJSONFields = toJSONFields . unTerm instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where - toJSONFields (a :<< f) = toJSONFields a <> toJSONFields f + toJSONFields (a :< f) = toJSONFields a <> toJSONFields f instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSONFields (Diff f a) where toJSONFields = toJSONFields . unDiff diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index 15e01a828..c34f5b816 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -43,7 +43,7 @@ printTerm term level = go term level 0 pad p n | n < 1 = "" | otherwise = "\n" <> replicate (2 * (p + n)) ' ' go :: (ConstrainAll Show fields, Foldable f) => Term f (Record fields) -> Int -> Int -> ByteString - go (annotation :< syntax) parentLevel level = + go (Term (annotation :< syntax)) parentLevel level = pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")" showAnnotation :: ConstrainAll Show fields => Record fields -> ByteString diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 2443b8dd6..ac86a9262 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -98,12 +98,12 @@ getDeclaration = getField -- | Produce the annotations of nodes representing declarations. declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields) -declaration (annotation :<< _) = annotation <$ (getField annotation :: Maybe Declaration) +declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Declaration) -- | Compute 'Declaration's for methods and functions in 'Syntax'. syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration) -syntaxDeclarationAlgebra Blob{..} (a :<< r) = case r of +syntaxDeclarationAlgebra Blob{..} (a :< r) = case r of S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) S.Method _ (identifier, _) (Just (receiver, _)) _ _ @@ -118,7 +118,7 @@ syntaxDeclarationAlgebra Blob{..} (a :<< r) = case r of declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply1 Functor fs, HasField fields Range, HasField fields Span) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -declarationAlgebra blob@Blob{..} (a :<< r) +declarationAlgebra blob@Blob{..} (a :< r) | Just (Declaration.Function (identifier, _) _ _) <- prj r = Just $ FunctionDeclaration (getSource (extract identifier)) | Just (Declaration.Method _ (identifier, _) _ _) <- prj r = Just $ MethodDeclaration (getSource (extract identifier)) | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage @@ -129,7 +129,7 @@ declarationAlgebra blob@Blob{..} (a :<< r) markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, HasField fields Span, Apply1 Functor fs, Apply1 Foldable fs) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -markupSectionAlgebra blob@Blob{..} (a :<< r) +markupSectionAlgebra blob@Blob{..} (a :< r) | Just (Markup.Section level (heading, _) _) <- prj r = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage | otherwise = Nothing @@ -154,7 +154,7 @@ tableOfContentsBy :: (Foldable f, Functor f) -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. tableOfContentsBy selector = fromMaybe [] . cata diffAlgebra where diffAlgebra r = case r of - Copy ann r -> case (selector (Both.snd ann :<< r), fold r) of + Copy ann r -> case (selector (Both.snd ann :< r), fold r) of (Just a, Nothing) -> Just [Unchanged a] (Just a, Just []) -> Just [Changed a] (_ , entries) -> entries diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 899cb2465..a1b062106 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -220,7 +220,7 @@ runParser Options{..} blob@Blob{..} = go LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource) blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ] errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String] - errors = cata $ \ (a :<< syntax) -> case syntax of + errors = cata $ \ (a :< syntax) -> case syntax of _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (sourceSpan a) err] _ -> fold syntax logTiming :: String -> Task a -> Task a diff --git a/src/Term.hs b/src/Term.hs index 0fc62533f..4d8db5473 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -5,8 +5,6 @@ module Term , SyntaxTerm , SyntaxTermF , termSize -, term -, unTerm , extract , unwrap , hoistTerm @@ -25,12 +23,12 @@ import Data.Proxy import Data.Record import Data.Union import Syntax +import Text.Show -- | A Term with an abstract syntax tree and an annotation. +newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } infixr 5 :< -data Term syntax ann = ann :< syntax (Term syntax ann) -infixr 5 :<< -data TermF syntax ann recur = (:<<) { headF :: ann, tailF :: syntax recur } +data TermF syntax ann recur = (:<) { headF :: ann, tailF :: syntax recur } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. @@ -40,17 +38,11 @@ type SyntaxTermF fields = TermF Syntax (Record fields) -- | Return the node count of a term. termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where - size (_ :<< syntax) = 1 + sum syntax + size (_ :< syntax) = 1 + sum syntax -term :: TermF f a (Term f a) -> Term f a -term (a :<< f) = a :< f - -unTerm :: Term f a -> TermF f a (Term f a) -unTerm (a :< f) = a :<< f - hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a -hoistTerm f = go where go (a :< r) = a :< f (fmap go r) +hoistTerm f = go where go (Term (a :< r)) = Term (a :< f (fmap go r)) -- | Strips the head annotation off a term annotated with non-empty records. stripTerm :: Functor f => Term f (Record (h ': t)) -> Term f (Record t) @@ -62,7 +54,7 @@ liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) instance Apply1 Pretty1 fs => Pretty1 (Term (Union fs)) where - liftPretty p pl = go where go (a :< f) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f + liftPretty p pl = go where go (Term (a :< f)) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f instance (Apply1 Pretty1 fs, Pretty a) => Pretty (Term (Union fs) a) where pretty = liftPretty pretty prettyList @@ -70,59 +62,59 @@ instance (Apply1 Pretty1 fs, Pretty a) => Pretty (Term (Union fs) a) where type instance Base (Term f a) = TermF f a instance Functor f => Recursive (Term f a) where project = unTerm -instance Functor f => Corecursive (Term f a) where embed = term +instance Functor f => Corecursive (Term f a) where embed = Term instance Functor f => Comonad (Term f) where - extract (a :< _) = a - duplicate w = w :< fmap duplicate (unwrap w) - extend f = go where go w = f w :< fmap go (unwrap w) + extract (Term (a :< _)) = a + duplicate w = Term (w :< fmap duplicate (unwrap w)) + extend f = go where go w = Term (f w :< fmap go (unwrap w)) instance Functor f => Functor (Term f) where - fmap f = go where go (a :< r) = f a :< fmap go r + fmap f = go where go (Term (a :< r)) = Term (f a :< fmap go r) instance Functor f => ComonadCofree f (Term f) where - unwrap (_ :< as) = as + unwrap (Term (_ :< as)) = as {-# INLINE unwrap #-} instance Eq1 f => Eq1 (Term f) where - liftEq eqA = go where go (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq go f1 f2 + liftEq eqA = go where go (Term (a1 :< f1)) (Term (a2 :< f2)) = eqA a1 a2 && liftEq go f1 f2 instance (Eq1 f, Eq a) => Eq (Term f a) where (==) = eq1 instance Show1 f => Show1 (Term f) where - liftShowsPrec spA slA = go where go d (a :< f) = showParen (d > 5) $ spA 6 a . showString " :< " . liftShowsPrec go (liftShowList spA slA) 5 f + liftShowsPrec spA slA = go where go d = showsUnaryWith (liftShowsPrec2 spA slA go (showListWith (go 0))) "Term" d . unTerm instance (Show1 f, Show a) => Show (Term f a) where showsPrec = showsPrec1 instance Functor f => Bifunctor (TermF f) where - bimap f g (a :<< r) = f a :<< fmap g r + bimap f g (a :< r) = f a :< fmap g r instance Listable1 f => Listable2 (TermF f) where - liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<<) + liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<) instance (Listable1 f, Listable a) => Listable1 (TermF f a) where liftTiers = liftTiers2 tiers instance (Functor f, Listable1 f) => Listable1 (Term f) where liftTiers annotationTiers = go - where go = liftCons1 (liftTiers2 annotationTiers go) term + where go = liftCons1 (liftTiers2 annotationTiers go) Term instance Eq1 f => Eq2 (TermF f) where - liftEq2 eqA eqB (a1 :<< f1) (a2 :<< f2) = eqA a1 a2 && liftEq eqB f1 f2 + liftEq2 eqA eqB (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq eqB f1 f2 instance (Eq1 f, Eq a) => Eq1 (TermF f a) where liftEq = liftEq2 (==) instance Show1 f => Show2 (TermF f) where - liftShowsPrec2 spA _ spB slB d (a :<< f) = showParen (d > 5) $ spA 6 a . showString " :<< " . liftShowsPrec spB slB 5 f + liftShowsPrec2 spA _ spB slB d (a :< f) = showParen (d > 5) $ spA 6 a . showString " :< " . liftShowsPrec spB slB 5 f instance (Show1 f, Show a) => Show1 (TermF f a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Pretty1 f => Pretty2 (TermF f) where - liftPretty2 pA _ pB plB (a :<< f) = pA a <+> liftPretty pB plB f + liftPretty2 pA _ pB plB (a :< f) = pA a <+> liftPretty pB plB f instance (Pretty1 f, Pretty a) => Pretty1 (TermF f a) where liftPretty = liftPretty2 pretty prettyList diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index c94d71780..253dfa8bc 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -64,7 +64,7 @@ toAST node@TS.Node{..} = do children <- allocaArray count $ \ childNodesPtr -> do _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nullPtr nodePtr childNodesPtr (fromIntegral count)) peekArray count childNodesPtr - pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) :<< children + pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) :< children anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t anaM g = a where a = pure . embed <=< traverse a <=< g @@ -109,7 +109,7 @@ nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos no assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) assignTerm language source annotation children allChildren = case assignTermByLanguage source (category annotation) children of - Just a -> pure (annotation :< a) + Just a -> pure (Term (annotation :< a)) _ -> defaultTermAssignment source annotation children allChildren where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) assignTermByLanguage = case languageForTSLanguage language of @@ -120,7 +120,7 @@ assignTerm language source annotation children allChildren = defaultTermAssignment :: Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) defaultTermAssignment source annotation children allChildren - | category annotation `elem` operatorCategories = (annotation :<) . S.Operator <$> allChildren + | category annotation `elem` operatorCategories = Term . (annotation :<) . S.Operator <$> allChildren | otherwise = case (category annotation, children) of (ParseError, children) -> toTerm $ S.ParseError children @@ -155,7 +155,7 @@ defaultTermAssignment source annotation children allChildren [_, Other t] | t `elem` ["--", "++"] -> MathOperator _ -> Operator - pure ((setCategory annotation c) :< S.Operator cs) + pure (Term (setCategory annotation c :< S.Operator cs)) (Other "binary_expression", _) -> do cs <- allChildren @@ -166,7 +166,7 @@ defaultTermAssignment source annotation children allChildren | s `elem` ["&&", "||"] -> BooleanOperator | s `elem` [">>", ">>=", ">>>", ">>>=", "<<", "<<=", "&", "^", "|"] -> BitwiseOperator _ -> Operator - pure ((setCategory annotation c) :< S.Operator cs) + pure (Term (setCategory annotation c :< S.Operator cs)) (_, []) -> toTerm $ S.Leaf (toText source) (_, children) -> toTerm $ S.Indexed children @@ -181,7 +181,7 @@ defaultTermAssignment source annotation children allChildren , RelationalOperator , BitwiseOperator ] - toTerm = pure . (annotation :<) + toTerm = pure . Term . (annotation :<) categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category From e2ffba24010c24cdde4f41acf98a7b67f4a2291c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:50:29 +0100 Subject: [PATCH 031/113] Rename headF to termAnnotation. --- HLint.hs | 2 +- src/Data/Syntax.hs | 4 ++-- src/Data/Syntax/Assignment.hs | 2 +- src/Language/Markdown/Syntax.hs | 12 ++++++------ src/RWS.hs | 2 +- src/SplitDiff.hs | 2 +- src/Term.hs | 2 +- test/Data/RandomWalkSimilarity/Spec.hs | 12 +++++------- test/DiffSpec.hs | 3 +-- test/TOCSpec.hs | 9 +++------ 10 files changed, 22 insertions(+), 28 deletions(-) diff --git a/HLint.hs b/HLint.hs index bfdeb2bbc..1ba9cd181 100644 --- a/HLint.hs +++ b/HLint.hs @@ -17,7 +17,7 @@ error "Avoid return" = error "use pure" = free . Pure ==> pure error "use wrap" = free . Free ==> wrap -error "use extract" = headF . unTerm ==> extract +error "use extract" = termAnnotation . unTerm ==> extract error "use unwrap" = tailF . unTerm ==> unwrap error "avoid head" = head diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 187efa6b6..d07201b63 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -32,7 +32,7 @@ makeTerm a = makeTerm' a . inj -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a -makeTerm' a f = Term (sconcat (a :| (headF . unTerm <$> toList f)) :< f) +makeTerm' a f = Term (sconcat (a :| (termAnnotation . unTerm <$> toList f)) :< f) -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a @@ -41,7 +41,7 @@ makeTerm1 = makeTerm1' . inj -- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation. makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a makeTerm1' f = case toList f of - a : _ -> makeTerm' (headF (unTerm a)) f + a : _ -> makeTerm' (termAnnotation (unTerm a)) f _ -> error "makeTerm1': empty structure" -- | Construct an empty term at the current position. diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 410b1e5ab..70bfab4db 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -292,7 +292,7 @@ withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallSta withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action skipTokens :: Symbol grammar => State ast grammar -> State ast grammar -skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . headF . unTerm) (stateNodes state) } +skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation . unTerm) (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 ast grammar -> State ast grammar diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 677748c74..c28f35a67 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -20,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) -import Term (Term(..), TermF(..), unwrap, headF, tailF) +import Term (Term(..), TermF(..), unwrap, termAnnotation, tailF) type Syntax = '[ Markup.Document @@ -69,14 +69,14 @@ paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> man list :: Assignment list = (Term .) . (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList - CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . headF . tailF <$> currentNode <*> children (many item)) + CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termAnnotation . tailF <$> currentNode <*> children (many item)) item :: Assignment item = makeTerm <$> symbol Item <*> children (many blockElement) section :: Assignment section = makeTerm <$> symbol Heading <*> (heading >>= \ headingTerm -> Markup.Section (level headingTerm) headingTerm <$> while (((<) `on` level) headingTerm) blockElement) - where heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . headF . tailF <$> currentNode <*> children (many inlineElement)) + where heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . tailF <$> currentNode <*> children (many inlineElement)) level term = case term of _ | Just section <- prj (unwrap term) -> level (Markup.sectionHeading section) _ | Just heading <- prj (unwrap term) -> Markup.headingLevel heading @@ -86,7 +86,7 @@ blockQuote :: Assignment blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) codeBlock :: Assignment -codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . headF . tailF <$> currentNode <*> source) +codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . termAnnotation . tailF <$> currentNode <*> source) thematicBreak :: Assignment thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak @@ -124,10 +124,10 @@ htmlInline :: Assignment htmlInline = makeTerm <$> symbol HTMLInline <*> (Markup.HTMLBlock <$> source) link :: Assignment -link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . headF . tailF <$> currentNode) <* advance +link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . termAnnotation . tailF <$> currentNode) <* advance image :: Assignment -image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . headF . tailF <$> currentNode) <* advance +image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termAnnotation . tailF <$> currentNode) <* advance code :: Assignment code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source) diff --git a/src/RWS.hs b/src/RWS.hs index fdfadded4..1ccb836f3 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -273,7 +273,7 @@ pqGramDecorator pqGramDecorator getLabel p q = cata algebra where algebra term = let label = getLabel term in - Term.Term ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label) + Term.Term ((gram label :. termAnnotation term) :< assignParentAndSiblingLabels (tailF term) label) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) diff --git a/src/SplitDiff.hs b/src/SplitDiff.hs index fc343a8b8..ca327670d 100644 --- a/src/SplitDiff.hs +++ b/src/SplitDiff.hs @@ -15,7 +15,7 @@ data SplitPatch a -- | Get the range of a SplitDiff. getRange :: Functor f => HasField fields Range => SplitDiff f (Record fields) -> Range getRange diff = byteRange $ case diff of - Free annotated -> headF annotated + Free annotated -> termAnnotation annotated Pure patch -> extract (splitTerm patch) -- | A diff with only one side’s annotations. diff --git a/src/Term.hs b/src/Term.hs index 4d8db5473..cea9098ab 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -28,7 +28,7 @@ import Text.Show -- | A Term with an abstract syntax tree and an annotation. newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } infixr 5 :< -data TermF syntax ann recur = (:<) { headF :: ann, tailF :: syntax recur } +data TermF syntax ann recur = (:<) { termAnnotation :: ann, tailF :: syntax recur } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index f5fc3c951..e023f5cd5 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -2,8 +2,6 @@ module Data.RandomWalkSimilarity.Spec where import Category -import Control.Comonad.Trans.Cofree (headF) -import Control.Monad.Free (wrap) import Data.Array.IArray import Data.Bifunctor import Data.Functor.Listable @@ -23,14 +21,14 @@ 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 '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead) + \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (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 '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead) + \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (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 '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead) + \ (term, p, q, d) -> featureVectorDecorator (rhead . termAnnotation) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead) describe "rws" $ do prop "produces correct diffs" $ @@ -44,10 +42,10 @@ spec = parallel $ do 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 + where canCompare a b = termAnnotation a == termAnnotation b decorate :: SyntaxTerm '[Category] -> SyntaxTerm '[FeatureVector, Category] - decorate = defaultFeatureVectorDecorator (category . headF) + decorate = defaultFeatureVectorDecorator (category . termAnnotation) diffThese = these deleting inserting replacing diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index 0fe89ba38..47b86a0fa 100644 --- a/test/DiffSpec.hs +++ b/test/DiffSpec.hs @@ -2,7 +2,6 @@ module DiffSpec where import Category -import Control.Comonad.Trans.Cofree (headF) import Data.Functor.Both import Data.Functor.Listable import RWS @@ -16,7 +15,7 @@ import Test.Hspec.LeanCheck spec :: Spec spec = parallel $ do - let decorate = defaultFeatureVectorDecorator (category . headF) + let decorate = defaultFeatureVectorDecorator (category . termAnnotation) prop "equality is reflexive" $ \ a -> let diff = unListableDiff a :: SyntaxDiff '[Category] in diff `shouldBe` diff diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 403dc24e9..35d557145 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -3,9 +3,6 @@ module TOCSpec where import Category as C -import Control.Comonad (extract) -import Control.Comonad.Trans.Cofree (headF) -import Control.Monad.Free (wrap) import Data.Aeson import Data.Blob import Data.ByteString (ByteString) @@ -52,10 +49,10 @@ spec = parallel $ do \ 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 . termAnnotation) (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 . termAnnotation) (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 <$) <$> fmap (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff Syntax Int])) in @@ -136,7 +133,7 @@ spec = parallel $ do in numTocSummaries diff `shouldBe` 0 prop "equal terms produce identity diffs" $ - \a -> let term = defaultFeatureVectorDecorator (Info.category . headF) (unListableF a :: Term') in + \a -> let term = defaultFeatureVectorDecorator (Info.category . termAnnotation) (unListableF a :: Term') in diffTOC (diffTerms (pure term)) `shouldBe` [] describe "JSONSummary" $ do From 9d1d1717d96a7a6889710672c09196ab2afc460b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:51:41 +0100 Subject: [PATCH 032/113] Rename tailF to termSyntax. --- HLint.hs | 2 +- src/Language/Markdown/Syntax.hs | 12 ++++++------ src/RWS.hs | 4 ++-- src/Term.hs | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/HLint.hs b/HLint.hs index 1ba9cd181..f3dc8ff9a 100644 --- a/HLint.hs +++ b/HLint.hs @@ -18,7 +18,7 @@ error "use pure" = free . Pure ==> pure error "use wrap" = free . Free ==> wrap error "use extract" = termAnnotation . unTerm ==> extract -error "use unwrap" = tailF . unTerm ==> unwrap +error "use unwrap" = termSyntax . unTerm ==> unwrap error "avoid head" = head where note = "head is partial; consider using Data.Maybe.listToMaybe" diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index c28f35a67..ae9ba030f 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -20,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) -import Term (Term(..), TermF(..), unwrap, termAnnotation, tailF) +import Term (Term(..), TermF(..), unwrap) type Syntax = '[ Markup.Document @@ -69,14 +69,14 @@ paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> man list :: Assignment list = (Term .) . (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList - CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termAnnotation . tailF <$> currentNode <*> children (many item)) + CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termAnnotation . termSyntax <$> currentNode <*> children (many item)) item :: Assignment item = makeTerm <$> symbol Item <*> children (many blockElement) section :: Assignment section = makeTerm <$> symbol Heading <*> (heading >>= \ headingTerm -> Markup.Section (level headingTerm) headingTerm <$> while (((<) `on` level) headingTerm) blockElement) - where heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . tailF <$> currentNode <*> children (many inlineElement)) + where heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termSyntax <$> currentNode <*> children (many inlineElement)) level term = case term of _ | Just section <- prj (unwrap term) -> level (Markup.sectionHeading section) _ | Just heading <- prj (unwrap term) -> Markup.headingLevel heading @@ -86,7 +86,7 @@ blockQuote :: Assignment blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) codeBlock :: Assignment -codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . termAnnotation . tailF <$> currentNode <*> source) +codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . termAnnotation . termSyntax <$> currentNode <*> source) thematicBreak :: Assignment thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak @@ -124,10 +124,10 @@ htmlInline :: Assignment htmlInline = makeTerm <$> symbol HTMLInline <*> (Markup.HTMLBlock <$> source) link :: Assignment -link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . termAnnotation . tailF <$> currentNode) <* advance +link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . termAnnotation . termSyntax <$> currentNode) <* advance image :: Assignment -image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termAnnotation . tailF <$> currentNode) <* advance +image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termAnnotation . termSyntax <$> currentNode) <* advance code :: Assignment code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source) diff --git a/src/RWS.hs b/src/RWS.hs index 1ccb836f3..3df058806 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -273,7 +273,7 @@ pqGramDecorator pqGramDecorator getLabel p q = cata algebra where algebra term = let label = getLabel term in - Term.Term ((gram label :. termAnnotation term) :< assignParentAndSiblingLabels (tailF term) label) + Term.Term ((gram label :. termAnnotation term) :< assignParentAndSiblingLabels (termSyntax term) label) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) @@ -303,7 +303,7 @@ canCompareTerms canCompare = canCompare `on` unTerm -- | Recursively test the equality of two 'Term's in O(n). equalTerms :: Eq1 f => ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool equalTerms canCompare = go - where go a b = canCompareTerms canCompare a b && liftEq go (tailF (unTerm a)) (tailF (unTerm b)) + where go a b = canCompareTerms canCompare a b && liftEq go (termSyntax (unTerm a)) (termSyntax (unTerm b)) -- Instances diff --git a/src/Term.hs b/src/Term.hs index cea9098ab..b21ba6009 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -28,7 +28,7 @@ import Text.Show -- | A Term with an abstract syntax tree and an annotation. newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } infixr 5 :< -data TermF syntax ann recur = (:<) { termAnnotation :: ann, tailF :: syntax recur } +data TermF syntax ann recur = (:<) { termAnnotation :: ann, termSyntax :: syntax recur } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. From 69cba8430ff248deb07f54729522384cb1d7fa76 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:53:57 +0100 Subject: [PATCH 033/113] :fire: wrapTermF. --- src/Diff.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index 236683932..8be3b1682 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -66,8 +66,6 @@ deleting :: Term syntax ann -> Diff syntax ann deleting = Diff . Patch . Delete -wrapTermF :: TermF syntax (Both ann) (Diff syntax ann) -> Diff syntax ann -wrapTermF (a :< r) = Diff (Copy a r) instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where From 30fe4d520b8e04781f18d7a62c8ce6fab5bfc2bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:54:29 +0100 Subject: [PATCH 034/113] Define a copy helper. --- src/Diff.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 8be3b1682..b672bb862 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -66,6 +66,8 @@ deleting :: Term syntax ann -> Diff syntax ann deleting = Diff . Patch . Delete +copy :: Both ann -> syntax (Diff syntax ann) -> Diff syntax ann +copy = (Diff .) . Copy instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where From 3e496176cc1f59ea014bc6770e964c587dd02c7f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:57:56 +0100 Subject: [PATCH 035/113] Use the copy helper widely. --- src/Algorithm.hs | 2 +- src/Interpreter.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 18c9a3037..8208dae30 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -87,7 +87,7 @@ instance Show term => Show1 (AlgorithmF term diff) where -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- (represented by a Nothing diff returned from algorithmFor) replace one term with another. algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a) -algorithmForTerms t1@(Term (ann1 :< f1)) t2@(Term (ann2 :< f2)) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . Copy (both ann1 ann2)) <$> algorithmFor f1 f2) +algorithmForTerms t1@(Term (ann1 :< f1)) t2@(Term (ann2 :< f2)) = fromMaybe (byReplacing t1 t2) (fmap (copy (both ann1 ann2)) <$> algorithmFor f1 f2) -- | A type class for determining what algorithm to use for diffing two terms. diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 5667f3246..c35c55af1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -49,7 +49,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) decompose step = case step of Algorithm.Diff t1 t2 -> refine t1 t2 Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of - Just result -> Diff.Diff . Copy (both (extract t1) (extract t2)) <$> sequenceA result + Just result -> copy (both (extract t1) (extract t2)) <$> sequenceA result _ -> byReplacing t1 t2 RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs) Delete a -> pure (deleting a) @@ -104,7 +104,7 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of <*> byRWS bodyA bodyB _ -> linearly t1 t2 where - annotate = Diff.Diff . Copy (both (extract t1) (extract t2)) + annotate = copy (both (extract t1) (extract t2)) -- | Test whether two terms are comparable by their Category. @@ -129,4 +129,4 @@ editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDi | otherwise = case diff of Copy _ r -> sum (fmap (diffCost (pred m)) r) Patch patch -> patchSum termSize patch - approximateDiff a b = maybe (replacing a b) (Diff.Diff . Copy (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b)) + approximateDiff a b = maybe (replacing a b) (copy (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b)) From 2454096b2bcf5606aaeea011c500379fb100162a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:00:21 +0100 Subject: [PATCH 036/113] Spacing. --- src/Term.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Term.hs b/src/Term.hs index b21ba6009..7d66f7351 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -27,6 +27,7 @@ import Text.Show -- | A Term with an abstract syntax tree and an annotation. newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } + infixr 5 :< data TermF syntax ann recur = (:<) { termAnnotation :: ann, termSyntax :: syntax recur } deriving (Eq, Foldable, Functor, Show, Traversable) From cfd583cd5110491a2d9e33a99126191c590bc316 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:00:28 +0100 Subject: [PATCH 037/113] Define a Bifoldable instance for TermF. --- src/Term.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index 7d66f7351..7d49de72c 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -14,6 +14,7 @@ module Term import Control.Comonad import Control.Comonad.Cofree.Class +import Data.Bifoldable import Data.Bifunctor import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty @@ -92,6 +93,9 @@ instance (Show1 f, Show a) => Show (Term f a) where instance Functor f => Bifunctor (TermF f) where bimap f g (a :< r) = f a :< fmap g r +instance Foldable f => Bifoldable (TermF f) where + bifoldMap f g (a :< r) = f a `mappend` foldMap g r + instance Listable1 f => Listable2 (TermF f) where liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<) From a358be60cc017be1090361bbb4880373768a1832 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:01:17 +0100 Subject: [PATCH 038/113] :fire: a redundant Functor constraint. --- src/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Term.hs b/src/Term.hs index 7d49de72c..c04a413c4 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -102,7 +102,7 @@ instance Listable1 f => Listable2 (TermF f) where instance (Listable1 f, Listable a) => Listable1 (TermF f a) where liftTiers = liftTiers2 tiers -instance (Functor f, Listable1 f) => Listable1 (Term f) where +instance Listable1 f => Listable1 (Term f) where liftTiers annotationTiers = go where go = liftCons1 (liftTiers2 annotationTiers go) Term From ce02539dab89c620bc0c2db8d047f4d2235b4808 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:02:11 +0100 Subject: [PATCH 039/113] Define a Foldable instance for Term. --- src/Term.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index c04a413c4..bc3a04178 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -74,6 +74,9 @@ instance Functor f => Comonad (Term f) where instance Functor f => Functor (Term f) where fmap f = go where go (Term (a :< r)) = Term (f a :< fmap go r) +instance Foldable f => Foldable (Term f) where + foldMap f = go where go (Term (a :< r)) = f a `mappend` foldMap go r + instance Functor f => ComonadCofree f (Term f) where unwrap (Term (_ :< as)) = as {-# INLINE unwrap #-} From 748ecbb104104ee60736197744bc7549bb9056cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:03:55 +0100 Subject: [PATCH 040/113] Define a Bitraversable instance for TermF. --- src/Term.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index bc3a04178..dfa1b0542 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -16,6 +16,7 @@ import Control.Comonad import Control.Comonad.Cofree.Class import Data.Bifoldable import Data.Bifunctor +import Data.Bitraversable import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable @@ -99,6 +100,9 @@ instance Functor f => Bifunctor (TermF f) where instance Foldable f => Bifoldable (TermF f) where bifoldMap f g (a :< r) = f a `mappend` foldMap g r +instance Traversable f => Bitraversable (TermF f) where + bitraverse f g (a :< r) = (:<) <$> f a <*> traverse g r + instance Listable1 f => Listable2 (TermF f) where liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<) From 7ca2e9ed4dd538026998119c139a02f0038dad63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:04:37 +0100 Subject: [PATCH 041/113] Define a Traversable instance for Term. --- src/Term.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index dfa1b0542..8710c3d22 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -78,6 +78,9 @@ instance Functor f => Functor (Term f) where instance Foldable f => Foldable (Term f) where foldMap f = go where go (Term (a :< r)) = f a `mappend` foldMap go r +instance Traversable f => Traversable (Term f) where + traverse f = go where go (Term (a :< r)) = (Term .) . (:<) <$> f a <*> traverse go r + instance Functor f => ComonadCofree f (Term f) where unwrap (Term (_ :< as)) = as {-# INLINE unwrap #-} From dab0e4d0443119a838da685b8a5e4c133dc6a1e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:15:54 +0100 Subject: [PATCH 042/113] Define a Show1 instance for Syntax. --- src/Syntax.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index c628cdbe1..4c2ece882 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -6,6 +6,7 @@ import Data.Align.Generic import Data.Functor.Classes import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Pretty.Generic +import Data.Functor.Classes.Show.Generic import Data.Functor.Listable import Data.Mergeable import Data.Text (pack, Text) @@ -180,7 +181,6 @@ instance Listable1 Syntax where instance Listable recur => Listable (Syntax recur) where tiers = tiers1 -instance Eq1 Syntax where - liftEq = genericLiftEq - +instance Eq1 Syntax where liftEq = genericLiftEq +instance Show1 Syntax where liftShowsPrec = genericLiftShowsPrec instance Pretty1 Syntax where liftPretty = genericLiftPretty From 221cf89b5b0f1661453a3830ce32e9010502dfaa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:24:48 +0100 Subject: [PATCH 043/113] Derive Eq1 & Show1 instances for Patch. --- src/Patch.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Patch.hs b/src/Patch.hs index a07a709f7..7c44dd524 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -12,7 +12,9 @@ module Patch ) where import Data.Align +import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Pretty.Generic +import Data.Functor.Classes.Show.Generic import Data.Functor.Listable import Data.These import GHC.Generics @@ -70,6 +72,8 @@ instance Crosswalk Patch where crosswalk f (Insert b) = Insert <$> f b crosswalk f (Delete a) = Delete <$> f a +instance Eq1 Patch where liftEq = genericLiftEq +instance Show1 Patch where liftShowsPrec = genericLiftShowsPrec instance Pretty1 Patch where liftPretty = genericLiftPretty instance Pretty a => Pretty (Patch a) where From af31840ee9882a972cc16b5b69173fcc44f7e887 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:24:55 +0100 Subject: [PATCH 044/113] Define an Eq2 instance for DiffF. --- src/Diff.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index b672bb862..fd9ab5f65 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -3,6 +3,7 @@ module Diff where import Data.Bifunctor import Data.Functor.Both as Both +import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic import Data.Functor.Foldable import Data.Mergeable @@ -93,3 +94,9 @@ instance Functor syntax => Functor (Diff syntax) where instance Functor syntax => Bifunctor (DiffF syntax) where bimap f g (Copy anns r) = Copy (fmap f anns) (fmap g r) bimap f _ (Patch term) = Patch (fmap (fmap f) term) + +instance Eq1 f => Eq2 (DiffF f) where + liftEq2 eqA eqB d1 d2 = case (d1, d2) of + (Copy (Join (a1, b1)) f1, Copy (Join (a2, b2)) f2) -> eqA a1 a2 && eqA b1 b2 && liftEq eqB f1 f2 + (Patch p1, Patch p2) -> liftEq (liftEq eqA) p1 p2 + _ -> False From cd154559c48c9d7a0d0f749fb95d6a7723cb124d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:28:47 +0100 Subject: [PATCH 045/113] Reformat the exports from Both. --- src/Data/Functor/Both.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Data/Functor/Both.hs b/src/Data/Functor/Both.hs index 5487ab771..6bf057068 100644 --- a/src/Data/Functor/Both.hs +++ b/src/Data/Functor/Both.hs @@ -1,5 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans -funbox-strict-fields #-} -module Data.Functor.Both (Both, both, runBothWith, fst, snd, module X) where +module Data.Functor.Both +( Both +, both +, runBothWith +, fst +, snd +, module X +) where import Data.Bifunctor.Join as X import Data.Semigroup From 33192c3ce0edd7d2ddc2647c803d23bb320c4102 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:28:54 +0100 Subject: [PATCH 046/113] Define lifted showing of Both. --- src/Data/Functor/Both.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Functor/Both.hs b/src/Data/Functor/Both.hs index 6bf057068..5b50c6add 100644 --- a/src/Data/Functor/Both.hs +++ b/src/Data/Functor/Both.hs @@ -6,9 +6,11 @@ module Data.Functor.Both , fst , snd , module X +, liftShowsPrecBoth ) where import Data.Bifunctor.Join as X +import Data.Functor.Classes import Data.Semigroup import Prelude hiding (fst, snd) import qualified Prelude @@ -39,3 +41,6 @@ instance (Semigroup a, Monoid a) => Monoid (Join (,) a) where instance (Semigroup a) => Semigroup (Join (,) a) where a <> b = Join $ runJoin a <> runJoin b + +liftShowsPrecBoth :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Both a -> ShowS +liftShowsPrecBoth sp sl d = showsUnaryWith (liftShowsPrec2 sp sl sp sl) "Join" d . runJoin From 6837ee44e461586d365e21e112c8954577ad8c1c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:30:06 +0100 Subject: [PATCH 047/113] Define a Show2 instance for DiffF. --- src/Diff.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index fd9ab5f65..430b963ec 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -100,3 +100,8 @@ instance Eq1 f => Eq2 (DiffF f) where (Copy (Join (a1, b1)) f1, Copy (Join (a2, b2)) f2) -> eqA a1 a2 && eqA b1 b2 && liftEq eqB f1 f2 (Patch p1, Patch p2) -> liftEq (liftEq eqA) p1 p2 _ -> False + +instance Show1 f => Show2 (DiffF f) where + liftShowsPrec2 spA slA spB slB d diff = case diff of + Copy ann r -> showsBinaryWith (liftShowsPrecBoth spA slA) (liftShowsPrec spB slB) "Copy" d ann r + Patch patch -> showsUnaryWith (liftShowsPrec (liftShowsPrec spA slA) (liftShowList spA slA)) "Patch" d patch From e68d46081c84402dced8bb8959bbd161f7445e42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:30:33 +0100 Subject: [PATCH 048/113] Define a Show1 instance for DiffF. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 430b963ec..119ec43bf 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -105,3 +105,6 @@ instance Show1 f => Show2 (DiffF f) where liftShowsPrec2 spA slA spB slB d diff = case diff of Copy ann r -> showsBinaryWith (liftShowsPrecBoth spA slA) (liftShowsPrec spB slB) "Copy" d ann r Patch patch -> showsUnaryWith (liftShowsPrec (liftShowsPrec spA slA) (liftShowList spA slA)) "Patch" d patch + +instance (Show1 f, Show a) => Show1 (DiffF f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList From f65fb137fac602bf08b91285ebb788244fd5dddf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:31:04 +0100 Subject: [PATCH 049/113] Define a Show instance for DiffF. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 119ec43bf..4e3bae1ce 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -108,3 +108,6 @@ instance Show1 f => Show2 (DiffF f) where instance (Show1 f, Show a) => Show1 (DiffF f a) where liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance (Show1 f, Show a, Show b) => Show (DiffF f a b) where + showsPrec = showsPrec1 From 2f63aca72f438fff1804282608571f08c58fae75 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:31:30 +0100 Subject: [PATCH 050/113] Define an Eq1 instance for DiffF. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 4e3bae1ce..7f3f77bd6 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -101,6 +101,9 @@ instance Eq1 f => Eq2 (DiffF f) where (Patch p1, Patch p2) -> liftEq (liftEq eqA) p1 p2 _ -> False +instance (Eq1 f, Eq a) => Eq1 (DiffF f a) where + liftEq = liftEq2 (==) + instance Show1 f => Show2 (DiffF f) where liftShowsPrec2 spA slA spB slB d diff = case diff of Copy ann r -> showsBinaryWith (liftShowsPrecBoth spA slA) (liftShowsPrec spB slB) "Copy" d ann r From 03eb93db31cb3188a1178c53576b90d09cd8049a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:31:58 +0100 Subject: [PATCH 051/113] Define an Eq instance for DiffF. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 7f3f77bd6..5d69c684b 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -104,6 +104,9 @@ instance Eq1 f => Eq2 (DiffF f) where instance (Eq1 f, Eq a) => Eq1 (DiffF f a) where liftEq = liftEq2 (==) +instance (Eq1 f, Eq a, Eq b) => Eq (DiffF f a b) where + (==) = eq1 + instance Show1 f => Show2 (DiffF f) where liftShowsPrec2 spA slA spB slB d diff = case diff of Copy ann r -> showsBinaryWith (liftShowsPrecBoth spA slA) (liftShowsPrec spB slB) "Copy" d ann r From b4e02d41fd07617f4f0ed27daccb37242b8b714c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:33:09 +0100 Subject: [PATCH 052/113] Define an Eq1 instance for Diff. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 5d69c684b..9122b7094 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -95,6 +95,9 @@ instance Functor syntax => Bifunctor (DiffF syntax) where bimap f g (Copy anns r) = Copy (fmap f anns) (fmap g r) bimap f _ (Patch term) = Patch (fmap (fmap f) term) +instance Eq1 f => Eq1 (Diff f) where + liftEq eqA = go where go (Diff d1) (Diff d2) = liftEq2 eqA go d1 d2 + instance Eq1 f => Eq2 (DiffF f) where liftEq2 eqA eqB d1 d2 = case (d1, d2) of (Copy (Join (a1, b1)) f1, Copy (Join (a2, b2)) f2) -> eqA a1 a2 && eqA b1 b2 && liftEq eqB f1 f2 From e7735ad131a621962cefd8808f0f63297f64916a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:33:35 +0100 Subject: [PATCH 053/113] Define an Eq instance for Diff. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 9122b7094..3e4a0c374 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -98,6 +98,9 @@ instance Functor syntax => Bifunctor (DiffF syntax) where instance Eq1 f => Eq1 (Diff f) where liftEq eqA = go where go (Diff d1) (Diff d2) = liftEq2 eqA go d1 d2 +instance (Eq1 f, Eq a) => Eq (Diff f a) where + (==) = eq1 + instance Eq1 f => Eq2 (DiffF f) where liftEq2 eqA eqB d1 d2 = case (d1, d2) of (Copy (Join (a1, b1)) f1, Copy (Join (a2, b2)) f2) -> eqA a1 a2 && eqA b1 b2 && liftEq eqB f1 f2 From 0df5175798ad5083eeccb8d128ed97f7950f7ae5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:34:47 +0100 Subject: [PATCH 054/113] Define a Show1 instance for Diff. --- src/Diff.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 3e4a0c374..789670332 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -12,6 +12,7 @@ import Data.Union import Patch import Syntax import Term +import Text.Show -- | An annotated series of patches of terms. newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) } @@ -113,6 +114,10 @@ instance (Eq1 f, Eq a) => Eq1 (DiffF f a) where instance (Eq1 f, Eq a, Eq b) => Eq (DiffF f a b) where (==) = eq1 + +instance Show1 f => Show1 (Diff f) where + liftShowsPrec sp sl = go where go d = showsUnaryWith (liftShowsPrec2 sp sl go (showListWith (go 0))) "Diff" d . unDiff + instance Show1 f => Show2 (DiffF f) where liftShowsPrec2 spA slA spB slB d diff = case diff of Copy ann r -> showsBinaryWith (liftShowsPrecBoth spA slA) (liftShowsPrec spB slB) "Copy" d ann r From 48175bb9b099be9dfdaea5e7b3bfdc60a03f54b2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 12:35:20 +0100 Subject: [PATCH 055/113] Define a Show instance for Diff. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 789670332..7dd84113a 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -118,6 +118,9 @@ instance (Eq1 f, Eq a, Eq b) => Eq (DiffF f a b) where instance Show1 f => Show1 (Diff f) where liftShowsPrec sp sl = go where go d = showsUnaryWith (liftShowsPrec2 sp sl go (showListWith (go 0))) "Diff" d . unDiff +instance (Show1 f, Show a) => Show (Diff f a) where + showsPrec = showsPrec1 + instance Show1 f => Show2 (DiffF f) where liftShowsPrec2 spA slA spB slB d diff = case diff of Copy ann r -> showsBinaryWith (liftShowsPrecBoth spA slA) (liftShowsPrec spB slB) "Copy" d ann r From 2094dd059bdad356708e35ed4c169b42ac6fe38d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:34:08 +0100 Subject: [PATCH 056/113] Derive Foldable & Traversable instances for DiffF. --- src/Diff.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diff.hs b/src/Diff.hs index 7dd84113a..1bc0e2395 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -20,7 +20,7 @@ newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) } data DiffF syntax ann recur = Copy (Both ann) (syntax recur) | Patch (Patch (Term syntax ann)) - deriving (Functor) + deriving (Foldable, Functor, Traversable) type SyntaxDiff fields = Diff Syntax (Record fields) From e42152dca82bc3b1d20ebdcf64777008babe3f4c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:35:59 +0100 Subject: [PATCH 057/113] Define a Bifoldable instance for DiffF. --- src/Diff.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 1bc0e2395..40f9422e2 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-} module Diff where +import Data.Bifoldable import Data.Bifunctor import Data.Functor.Both as Both import Data.Functor.Classes @@ -131,3 +132,8 @@ instance (Show1 f, Show a) => Show1 (DiffF f a) where instance (Show1 f, Show a, Show b) => Show (DiffF f a b) where showsPrec = showsPrec1 + + +instance Foldable f => Bifoldable (DiffF f) where + bifoldMap f g (Copy as r) = foldMap f as `mappend` foldMap g r + bifoldMap f _ (Patch p) = foldMap (foldMap f) p From 8df8b345e7bc0f1e2c99a6a94a090a1415248d46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:37:11 +0100 Subject: [PATCH 058/113] Define a Bitraversable instance for DiffF. --- src/Diff.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 40f9422e2..18b269c42 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -3,6 +3,7 @@ module Diff where import Data.Bifoldable import Data.Bifunctor +import Data.Bitraversable import Data.Functor.Both as Both import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic @@ -137,3 +138,7 @@ instance (Show1 f, Show a, Show b) => Show (DiffF f a b) where instance Foldable f => Bifoldable (DiffF f) where bifoldMap f g (Copy as r) = foldMap f as `mappend` foldMap g r bifoldMap f _ (Patch p) = foldMap (foldMap f) p + +instance Traversable f => Bitraversable (DiffF f) where + bitraverse f g (Copy as r) = Copy <$> traverse f as <*> traverse g r + bitraverse f _ (Patch p) = Patch <$> traverse (traverse f) p From a9ac82819ced1beeab65d47807fc7b7dd925473b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:39:04 +0100 Subject: [PATCH 059/113] Give a different instance of Functor for Diff. --- src/Diff.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index 18b269c42..2d762c3cf 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -91,9 +91,6 @@ type instance Base (Diff syntax ann) = DiffF syntax ann instance Functor syntax => Recursive (Diff syntax ann) where project = unDiff instance Functor syntax => Corecursive (Diff syntax ann) where embed = Diff -instance Functor syntax => Functor (Diff syntax) where - fmap f = Diff . bimap f (fmap f) . unDiff - instance Functor syntax => Bifunctor (DiffF syntax) where bimap f g (Copy anns r) = Copy (fmap f anns) (fmap g r) bimap f _ (Patch term) = Patch (fmap (fmap f) term) @@ -135,6 +132,12 @@ instance (Show1 f, Show a, Show b) => Show (DiffF f a b) where showsPrec = showsPrec1 +instance Functor f => Functor (Diff f) where + fmap f = go + where go (Diff (Copy as r)) = Diff (Copy (f <$> as) (fmap go r)) + go (Diff (Patch p)) = Diff (Patch (fmap f <$> p)) + + instance Foldable f => Bifoldable (DiffF f) where bifoldMap f g (Copy as r) = foldMap f as `mappend` foldMap g r bifoldMap f _ (Patch p) = foldMap (foldMap f) p From ff1cc394c4b333ab8e1f2e1e2809cf44c691fe92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:40:07 +0100 Subject: [PATCH 060/113] Define a Foldable instance for Diff. --- src/Diff.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 2d762c3cf..d10df3eb2 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -137,6 +137,11 @@ instance Functor f => Functor (Diff f) where where go (Diff (Copy as r)) = Diff (Copy (f <$> as) (fmap go r)) go (Diff (Patch p)) = Diff (Patch (fmap f <$> p)) +instance Foldable f => Foldable (Diff f) where + foldMap f = go + where go (Diff (Copy as r)) = foldMap f as `mappend` foldMap go r + go (Diff (Patch p)) = foldMap (foldMap f) p + instance Foldable f => Bifoldable (DiffF f) where bifoldMap f g (Copy as r) = foldMap f as `mappend` foldMap g r From 1e6bd6e27ef1eb57e6dab90a084f9478f9cba99e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:41:10 +0100 Subject: [PATCH 061/113] Define a Traversable instance for Diff. --- src/Diff.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index d10df3eb2..78197dc71 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -142,6 +142,11 @@ instance Foldable f => Foldable (Diff f) where where go (Diff (Copy as r)) = foldMap f as `mappend` foldMap go r go (Diff (Patch p)) = foldMap (foldMap f) p +instance Traversable f => Traversable (Diff f) where + traverse f = go + where go (Diff (Copy as r)) = copy <$> traverse f as <*> traverse go r + go (Diff (Patch p)) = Diff . Patch <$> traverse (traverse f) p + instance Foldable f => Bifoldable (DiffF f) where bifoldMap f g (Copy as r) = foldMap f as `mappend` foldMap g r From fa5aeb6ee64a655bc5189b984219ec27a778507b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:44:07 +0100 Subject: [PATCH 062/113] Define a Listable2 instance for DiffF. --- src/Diff.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index 78197dc71..46888affd 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -6,8 +6,9 @@ import Data.Bifunctor import Data.Bitraversable import Data.Functor.Both as Both import Data.Functor.Classes -import Data.Functor.Classes.Pretty.Generic +import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable +import Data.Functor.Listable import Data.Mergeable import Data.Record import Data.Union @@ -76,15 +77,15 @@ copy = (Diff .) . Copy instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where liftPretty p pl = go - where go (Diff (Copy _ syntax)) = liftPrettyUnion go (list . map (liftPretty p pl)) syntax - go (Diff (Patch patch)) = liftPretty (liftPretty p pl) (list . map (liftPretty p pl)) patch + where go (Diff (Copy _ syntax)) = liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) syntax + go (Diff (Patch patch)) = liftPretty (liftPretty p pl) (Pretty.list . map (liftPretty p pl)) patch instance (Apply1 Pretty1 fs, Pretty ann) => Pretty (Diff (Union fs) ann) where pretty = liftPretty pretty prettyList instance Apply1 Pretty1 fs => Pretty2 (DiffF (Union fs)) where liftPretty2 pA plA pB plB (Copy (Join ann) f) = liftPretty2 pA plA pA plA ann <+> liftPrettyUnion pB plB f - liftPretty2 pA plA _ _ (Patch p) = liftPretty (liftPretty pA plA) (list . map (liftPretty pA plA)) p + liftPretty2 pA plA _ _ (Patch p) = liftPretty (liftPretty pA plA) (Pretty.list . map (liftPretty pA plA)) p type instance Base (Diff syntax ann) = DiffF syntax ann @@ -155,3 +156,7 @@ instance Foldable f => Bifoldable (DiffF f) where instance Traversable f => Bitraversable (DiffF f) where bitraverse f g (Copy as r) = Copy <$> traverse f as <*> traverse g r bitraverse f _ (Patch p) = Patch <$> traverse (traverse f) p + + +instance Listable1 f => Listable2 (DiffF f) where + liftTiers2 annTiers recurTiers = liftCons2 (liftCons2 annTiers annTiers both) (liftTiers recurTiers) Copy From 923a39faae4743e74b09f041c787974ee27385bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:45:22 +0100 Subject: [PATCH 063/113] Define Listable instances for TermF & Term. --- src/Term.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Term.hs b/src/Term.hs index 8710c3d22..4297996ee 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -112,10 +112,16 @@ instance Listable1 f => Listable2 (TermF f) where instance (Listable1 f, Listable a) => Listable1 (TermF f a) where liftTiers = liftTiers2 tiers +instance (Listable1 f, Listable a, Listable b) => Listable (TermF f a b) where + tiers = tiers1 + instance Listable1 f => Listable1 (Term f) where liftTiers annotationTiers = go where go = liftCons1 (liftTiers2 annotationTiers go) Term +instance (Listable1 f, Listable a) => Listable (Term f a) where + tiers = tiers1 + instance Eq1 f => Eq2 (TermF f) where liftEq2 eqA eqB (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq eqB f1 f2 From 6c744336a82bb28cace744437048d59fb4b09ede Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:45:52 +0100 Subject: [PATCH 064/113] Define a Listable1 instance for DiffF. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 46888affd..e579844e2 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -160,3 +160,6 @@ instance Traversable f => Bitraversable (DiffF f) where instance Listable1 f => Listable2 (DiffF f) where liftTiers2 annTiers recurTiers = liftCons2 (liftCons2 annTiers annTiers both) (liftTiers recurTiers) Copy + +instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where + liftTiers = liftTiers2 tiers From a4e98d43180fa61ab7d10de31d338e67d70836fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:46:21 +0100 Subject: [PATCH 065/113] Define a Listable instance for DiffF. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index e579844e2..f3dea687e 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -163,3 +163,6 @@ instance Listable1 f => Listable2 (DiffF f) where instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where liftTiers = liftTiers2 tiers + +instance (Listable1 f, Listable a, Listable b) => Listable (DiffF f a b) where + tiers = tiers1 From 32984965f8d31d60644b71c675ed3c06a7c9f109 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:47:51 +0100 Subject: [PATCH 066/113] Add Patch to the Listable2 instance for DiffF. --- src/Diff.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diff.hs b/src/Diff.hs index f3dea687e..01859039a 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -159,7 +159,7 @@ instance Traversable f => Bitraversable (DiffF f) where instance Listable1 f => Listable2 (DiffF f) where - liftTiers2 annTiers recurTiers = liftCons2 (liftCons2 annTiers annTiers both) (liftTiers recurTiers) Copy + liftTiers2 annTiers recurTiers = liftCons2 (liftCons2 annTiers annTiers both) (liftTiers recurTiers) Copy \/ liftCons1 (liftTiers (liftTiers annTiers)) Patch instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where liftTiers = liftTiers2 tiers From 63f2961e4ba8406ab559ef0f2b26f775ff96c48c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:48:25 +0100 Subject: [PATCH 067/113] Define a Listable1 instance for Diff. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index 01859039a..f8fa06b29 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -166,3 +166,6 @@ instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where instance (Listable1 f, Listable a, Listable b) => Listable (DiffF f a b) where tiers = tiers1 + +instance Listable1 f => Listable1 (Diff f) where + liftTiers annTiers = go where go = liftCons1 (liftTiers2 annTiers go) Diff From 0282bf1dae8deb57676af233abf954098ba21354 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 13:48:48 +0100 Subject: [PATCH 068/113] Define a Listable instance for Diff. --- src/Diff.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diff.hs b/src/Diff.hs index f8fa06b29..5c996b508 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -169,3 +169,6 @@ instance (Listable1 f, Listable a, Listable b) => Listable (DiffF f a b) where instance Listable1 f => Listable1 (Diff f) where liftTiers annTiers = go where go = liftCons1 (liftTiers2 annTiers go) Diff + +instance (Listable1 f, Listable a) => Listable (Diff f a) where + tiers = tiers1 From a1bfea611fb1d86029764deb2429060304fbfa4b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:18:08 +0100 Subject: [PATCH 069/113] Update all the tests. --- test/AlignmentSpec.hs | 203 ++++++++++--------------- test/Data/RandomWalkSimilarity/Spec.hs | 16 +- test/Data/Syntax/Assignment/Spec.hs | 4 +- test/DiffSpec.hs | 12 +- test/InterpreterSpec.hs | 10 +- test/PatchOutputSpec.hs | 5 +- test/SemanticSpec.hs | 15 +- test/SpecHelpers.hs | 5 - test/TOCSpec.hs | 52 +++---- 9 files changed, 137 insertions(+), 185 deletions(-) diff --git a/test/AlignmentSpec.hs b/test/AlignmentSpec.hs index bb5b431bc..9b0e4fd54 100644 --- a/test/AlignmentSpec.hs +++ b/test/AlignmentSpec.hs @@ -3,7 +3,6 @@ module AlignmentSpec where import Alignment import Control.Arrow ((&&&)) -import Control.Comonad.Cofree (Cofree, hoistCofree) import Control.Monad.Free (Free, wrap) import Control.Monad.State import Data.Align hiding (align) @@ -21,6 +20,7 @@ import Data.Semigroup ((<>)) import qualified Data.Source as Source import qualified Data.Text as Text import Data.These +import Diff import Patch import SplitDiff import Syntax @@ -66,134 +66,134 @@ spec = parallel $ do describe "alignDiff" $ do it "aligns identical branches on a single line" $ let sources = both (Source.fromText "[ foo ]") (Source.fromText "[ foo ]") in - align sources (pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 7 `branch` [ info 2 5 `leaf` "foo" ]) - (info 0 7 `branch` [ info 2 5 `leaf` "foo" ])) ] + align sources (pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ]) + (wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ])) ] it "aligns identical branches spanning multiple lines" $ let sources = both (Source.fromText "[\nfoo\n]") (Source.fromText "[\nfoo\n]") in - align sources (pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 2 `branch` []) - (info 0 2 `branch` [])) - , Join (These (info 2 6 `branch` [ info 2 5 `leaf` "foo" ]) - (info 2 6 `branch` [ info 2 5 `leaf` "foo" ])) - , Join (These (info 6 7 `branch` []) - (info 6 7 `branch` [])) + align sources (pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 2 :< []) + (wrap $ info 0 2 :< [])) + , Join (These (wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ]) + (wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ])) + , Join (These (wrap $ info 6 7 :< []) + (wrap $ info 6 7 :< [])) ] it "aligns reformatted branches" $ let sources = both (Source.fromText "[ foo ]") (Source.fromText "[\nfoo\n]") in - align sources (pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ]) `shouldBe` prettyDiff sources - [ Join (That (info 0 2 `branch` [])) - , Join (These (info 0 7 `branch` [ info 2 5 `leaf` "foo" ]) - (info 2 6 `branch` [ info 2 5 `leaf` "foo" ])) - , Join (That (info 6 7 `branch` [])) + align sources (pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ]) `shouldBe` prettyDiff sources + [ Join (That (wrap $ info 0 2 :< [])) + , Join (These (wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ]) + (wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ])) + , Join (That (wrap $ info 6 7 :< [])) ] it "aligns nodes following reformatted branches" $ let sources = both (Source.fromText "[ foo ]\nbar\n") (Source.fromText "[\nfoo\n]\nbar\n") in - align sources (pure (info 0 12) `branch` [ pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ], pure (info 8 11) `leaf` "bar" ]) `shouldBe` prettyDiff sources - [ Join (That (info 0 2 `branch` [ info 0 2 `branch` [] ])) - , Join (These (info 0 8 `branch` [ info 0 7 `branch` [ info 2 5 `leaf` "foo" ] ]) - (info 2 6 `branch` [ info 2 6 `branch` [ info 2 5 `leaf` "foo" ] ])) - , Join (That (info 6 8 `branch` [ info 6 7 `branch` [] ])) - , Join (These (info 8 12 `branch` [ info 8 11 `leaf` "bar" ]) - (info 8 12 `branch` [ info 8 11 `leaf` "bar" ])) - , Join (These (info 12 12 `branch` []) - (info 12 12 `branch` [])) + align sources (pure (info 0 12) `copy` Indexed [ pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ], pure (info 8 11) `copy` Leaf "bar" ]) `shouldBe` prettyDiff sources + [ Join (That (wrap $ info 0 2 :< [ wrap $ info 0 2 :< [] ])) + , Join (These (wrap $ info 0 8 :< [ wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ] ]) + (wrap $ info 2 6 :< [ wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ] ])) + , Join (That (wrap $ info 6 8 :< [ wrap $ info 6 7 :< [] ])) + , Join (These (wrap $ info 8 12 :< [ wrap $ info 8 11 :< [] ]) + (wrap $ info 8 12 :< [ wrap $ info 8 11 :< [] ])) + , Join (These (wrap $ info 12 12 :< []) + (wrap $ info 12 12 :< [])) ] it "aligns identical branches with multiple children on the same line" $ let sources = pure (Source.fromText "[ foo, bar ]") in - align sources (pure (info 0 12) `branch` [ pure (info 2 5) `leaf` "foo", pure (info 7 10) `leaf` "bar" ]) `shouldBe` prettyDiff sources - [ Join (runBothWith These (pure (info 0 12 `branch` [ info 2 5 `leaf` "foo", info 7 10 `leaf` "bar" ])) ) ] + align sources (pure (info 0 12) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo", pure (info 7 10) `copy` Leaf "bar" ]) `shouldBe` prettyDiff sources + [ Join (runBothWith These (pure (wrap $ info 0 12 :< [ wrap $ info 2 5 :< [], wrap $ info 7 10 :< [] ])) ) ] it "aligns insertions" $ let sources = both (Source.fromText "a") (Source.fromText "a\nb") in - align sources (both (info 0 1) (info 0 3) `branch` [ pure (info 0 1) `leaf` "a", insert (info 2 3 `leaf` "b") ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 1 `branch` [ info 0 1 `leaf` "a" ]) - (info 0 2 `branch` [ info 0 1 `leaf` "a" ])) - , Join (That (info 2 3 `branch` [ insert (info 2 3 `leaf` "b") ])) + align sources (both (info 0 1) (info 0 3) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", inserting (Term (info 2 3 :< Leaf "b")) ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 1 :< [ wrap $ info 0 1 :< [] ]) + (wrap $ info 0 2 :< [ wrap $ info 0 1 :< [] ])) + , Join (That (wrap $ info 2 3 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) ] it "aligns total insertions" $ let sources = both (Source.fromText "") (Source.fromText "a") in - align sources (insert (info 0 1 `leaf` "a")) `shouldBe` prettyDiff sources - [ Join (That (insert (info 0 1 `leaf` "a"))) ] + align sources (inserting (Term (info 0 1 :< Leaf "a"))) `shouldBe` prettyDiff sources + [ Join (That (pure (SplitInsert (Term (info 0 1 :< []))))) ] it "aligns insertions into empty branches" $ let sources = both (Source.fromText "[ ]") (Source.fromText "[a]") in - align sources (pure (info 0 3) `branch` [ insert (info 1 2 `leaf` "a") ]) `shouldBe` prettyDiff sources - [ Join (That (info 0 3 `branch` [ insert (info 1 2 `leaf` "a") ])) - , Join (This (info 0 3 `branch` [])) + align sources (pure (info 0 3) `copy` Indexed [ inserting (Term (info 1 2 :< Leaf "a")) ]) `shouldBe` prettyDiff sources + [ Join (That (wrap $ info 0 3 :< [ pure (SplitInsert (Term (info 1 2 :< []))) ])) + , Join (This (wrap $ info 0 3 :< [])) ] it "aligns symmetrically following insertions" $ let sources = both (Source.fromText "a\nc") (Source.fromText "a\nb\nc") in - align sources (both (info 0 3) (info 0 5) `branch` [ pure (info 0 1) `leaf` "a", insert (info 2 3 `leaf` "b"), both (info 2 3) (info 4 5) `leaf` "c" ]) + align sources (both (info 0 3) (info 0 5) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", inserting (Term (info 2 3 :< Leaf "b")), both (info 2 3) (info 4 5) `copy` Leaf "c" ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 2 `branch` [ info 0 1 `leaf` "a" ]) - (info 0 2 `branch` [ info 0 1 `leaf` "a" ])) - , Join (That (info 2 4 `branch` [ insert (info 2 3 `leaf` "b") ])) - , Join (These (info 2 3 `branch` [ info 2 3 `leaf` "c" ]) - (info 4 5 `branch` [ info 4 5 `leaf` "c" ])) + [ Join (These (wrap $ info 0 2 :< [ wrap $ info 0 1 :< [] ]) + (wrap $ info 0 2 :< [ wrap $ info 0 1 :< [] ])) + , Join (That (wrap $ info 2 4 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) + , Join (These (wrap $ info 2 3 :< [ wrap $ info 2 3 :< [] ]) + (wrap $ info 4 5 :< [ wrap $ info 4 5 :< [] ])) ] it "symmetrical nodes force the alignment of asymmetrical nodes on both sides" $ let sources = both (Source.fromText "[ a, b ]") (Source.fromText "[ b, c ]") in - align sources (pure (info 0 8) `branch` [ delete (info 2 3 `leaf` "a"), both (info 5 6) (info 2 3) `leaf` "b", insert (info 5 6 `leaf` "c") ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 8 `branch` [ delete (info 2 3 `leaf` "a"), info 5 6 `leaf` "b" ]) - (info 0 8 `branch` [ info 2 3 `leaf` "b", insert (info 5 6 `leaf` "c") ])) ] + align sources (pure (info 0 8) `copy` Indexed [ deleting (Term (info 2 3 :< Leaf "a")), both (info 5 6) (info 2 3) `copy` Leaf "b", inserting (Term (info 5 6 :< Leaf "c")) ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 8 :< [ pure (SplitDelete (Term (info 2 3 :< []))), wrap $ info 5 6 :< [] ]) + (wrap $ info 0 8 :< [ wrap $ info 2 3 :< [], pure (SplitInsert (Term (info 5 6 :< []))) ])) ] it "when one of two symmetrical nodes must be split, splits the latter" $ let sources = both (Source.fromText "[ a, b ]") (Source.fromText "[ a\n, b\n]") in - align sources (both (info 0 8) (info 0 9) `branch` [ pure (info 2 3) `leaf` "a", both (info 5 6) (info 6 7) `leaf` "b" ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 8 `branch` [ info 2 3 `leaf` "a", info 5 6 `leaf` "b" ]) - (info 0 4 `branch` [ info 2 3 `leaf` "a" ])) - , Join (That (info 4 8 `branch` [ info 6 7 `leaf` "b" ])) - , Join (That (info 8 9 `branch` [])) + align sources (both (info 0 8) (info 0 9) `copy` Indexed [ pure (info 2 3) `copy` Leaf "a", both (info 5 6) (info 6 7) `copy` Leaf "b" ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 8 :< [ wrap $ info 2 3 :< [], wrap $ info 5 6 :< [] ]) + (wrap $ info 0 4 :< [ wrap $ info 2 3 :< [] ])) + , Join (That (wrap $ info 4 8 :< [ wrap $ info 6 7 :< [] ])) + , Join (That (wrap $ info 8 9 :< [])) ] it "aligns deletions before insertions" $ let sources = both (Source.fromText "[ a ]") (Source.fromText "[ b ]") in - align sources (pure (info 0 5) `branch` [ delete (info 2 3 `leaf` "a"), insert (info 2 3 `leaf` "b") ]) `shouldBe` prettyDiff sources - [ Join (This (info 0 5 `branch` [ delete (info 2 3 `leaf` "a") ])) - , Join (That (info 0 5 `branch` [ insert (info 2 3 `leaf` "b") ])) + align sources (pure (info 0 5) `copy` Indexed [ deleting (Term (info 2 3 :< Leaf "a")), inserting (Term (info 2 3 :< Leaf "b")) ]) `shouldBe` prettyDiff sources + [ Join (This (wrap $ info 0 5 :< [ pure (SplitDelete (Term (info 2 3 :< []))) ])) + , Join (That (wrap $ info 0 5 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) ] it "aligns context-only lines symmetrically" $ let sources = both (Source.fromText "[\n a\n,\n b\n]") (Source.fromText "[\n a, b\n\n\n]") in - align sources (both (info 0 13) (info 0 12) `branch` [ pure (info 4 5) `leaf` "a", both (info 10 11) (info 7 8) `leaf` "b" ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 2 `branch` []) - (info 0 2 `branch` [])) - , Join (These (info 2 6 `branch` [ info 4 5 `leaf` "a" ]) - (info 2 9 `branch` [ info 4 5 `leaf` "a", info 7 8 `leaf` "b" ])) - , Join (These (info 6 8 `branch` []) - (info 9 10 `branch` [])) - , Join (This (info 8 12 `branch` [ info 10 11 `leaf` "b" ])) - , Join (These (info 12 13 `branch` []) - (info 10 11 `branch` [])) - , Join (That (info 11 12 `branch` [])) + align sources (both (info 0 13) (info 0 12) `copy` Indexed [ pure (info 4 5) `copy` Leaf "a", both (info 10 11) (info 7 8) `copy` Leaf "b" ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 2 :< []) + (wrap $ info 0 2 :< [])) + , Join (These (wrap $ info 2 6 :< [ wrap $ info 4 5 :< [] ]) + (wrap $ info 2 9 :< [ wrap $ info 4 5 :< [], wrap $ info 7 8 :< [] ])) + , Join (These (wrap $ info 6 8 :< []) + (wrap $ info 9 10 :< [])) + , Join (This (wrap $ info 8 12 :< [ wrap $ info 10 11 :< [] ])) + , Join (These (wrap $ info 12 13 :< []) + (wrap $ info 10 11 :< [])) + , Join (That (wrap $ info 11 12 :< [])) ] it "aligns asymmetrical nodes preceding their symmetrical siblings conservatively" $ let sources = both (Source.fromText "[ b, c ]") (Source.fromText "[ a\n, c\n]") in - align sources (both (info 0 8) (info 0 9) `branch` [ insert (info 2 3 `leaf` "a"), delete (info 2 3 `leaf` "b"), both (info 5 6) (info 6 7) `leaf` "c" ]) `shouldBe` prettyDiff sources - [ Join (That (info 0 4 `branch` [ insert (info 2 3 `leaf` "a") ])) - , Join (These (info 0 8 `branch` [ delete (info 2 3 `leaf` "b"), info 5 6 `leaf` "c" ]) - (info 4 8 `branch` [ info 6 7 `leaf` "c" ])) - , Join (That (info 8 9 `branch` [])) + align sources (both (info 0 8) (info 0 9) `copy` Indexed [ inserting (Term (info 2 3 :< Leaf "a")), deleting (Term (info 2 3 :< Leaf "b")), both (info 5 6) (info 6 7) `copy` Leaf "c" ]) `shouldBe` prettyDiff sources + [ Join (That (wrap $ info 0 4 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) + , Join (These (wrap $ info 0 8 :< [ pure (SplitDelete (Term (info 2 3 :< []))), wrap $ info 5 6 :< [] ]) + (wrap $ info 4 8 :< [ wrap $ info 6 7 :< [] ])) + , Join (That (wrap $ info 8 9 :< [])) ] it "aligns symmetrical reformatted nodes" $ let sources = both (Source.fromText "a [ b ]\nc") (Source.fromText "a [\nb\n]\nc") in - align sources (pure (info 0 9) `branch` [ pure (info 0 1) `leaf` "a", pure (info 2 7) `branch` [ pure (info 4 5) `leaf` "b" ], pure (info 8 9) `leaf` "c" ]) `shouldBe` prettyDiff sources - [ Join (These (info 0 8 `branch` [ info 0 1 `leaf` "a", info 2 7 `branch` [ info 4 5 `leaf` "b" ] ]) - (info 0 4 `branch` [ info 0 1 `leaf` "a", info 2 4 `branch` [] ])) - , Join (That (info 4 6 `branch` [ info 4 6 `branch` [ info 4 5 `leaf` "b" ] ])) - , Join (That (info 6 8 `branch` [ info 6 7 `branch` [] ])) - , Join (These (info 8 9 `branch` [ info 8 9 `leaf` "c" ]) - (info 8 9 `branch` [ info 8 9 `leaf` "c" ])) + align sources (pure (info 0 9) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", pure (info 2 7) `copy` Indexed [ pure (info 4 5) `copy` Leaf "b" ], pure (info 8 9) `copy` Leaf "c" ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 8 :< [ wrap $ info 0 1 :< [], wrap $ info 2 7 :< [ wrap $ info 4 5 :< [] ] ]) + (wrap $ info 0 4 :< [ wrap $ info 0 1 :< [], wrap $ info 2 4 :< [] ])) + , Join (That (wrap $ info 4 6 :< [ wrap $ info 4 6 :< [ wrap $ info 4 5 :< [] ] ])) + , Join (That (wrap $ info 6 8 :< [ wrap $ info 6 7 :< [] ])) + , Join (These (wrap $ info 8 9 :< [ wrap $ info 8 9 :< [] ]) + (wrap $ info 8 9 :< [ wrap $ info 8 9 :< [] ])) ] describe "numberedRows" $ do @@ -260,14 +260,14 @@ instance Listable BranchElement where counts :: [Join These (Int, a)] -> Both Int counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap fst <$> numbered)) -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 &&& id)) . alignDiff sources . deconstruct +align :: Both Source.Source -> Diff Syntax (Record '[Range]) -> PrettyDiff (SplitDiff [] (Record '[Range])) +align sources = PrettyDiff sources . fmap (fmap (getRange &&& id)) . alignDiff sources info :: Int -> Int -> Record '[Range] info start end = Range start end :. Nil -prettyDiff :: Both Source.Source -> [Join These (ConstructibleFree [] (SplitPatch (Term [] (Record '[Range]))) (Record '[Range]))] -> PrettyDiff (SplitDiff [] (Record '[Range])) -prettyDiff sources = PrettyDiff sources . fmap (fmap ((getRange &&& id) . deconstruct)) +prettyDiff :: Both Source.Source -> [Join These (SplitDiff [] (Record '[Range]))] -> PrettyDiff (SplitDiff [] (Record '[Range])) +prettyDiff sources = PrettyDiff sources . fmap (fmap ((getRange &&& id))) data PrettyDiff a = PrettyDiff { unPrettySources :: Both Source.Source, unPrettyLines :: [Join These (Range, a)] } deriving Eq @@ -280,46 +280,3 @@ instance Show (PrettyDiff a) where showDiff (range, _) = filter (/= '\n') . Text.unpack . Source.toText . Source.slice range pad n string = (<>) (take n string) (replicate (max 0 (n - length string)) ' ') toBoth them = showDiff <$> them `applyThese` modifyJoin (uncurry These) sources - -newtype ConstructibleFree f patch annotation = ConstructibleFree { deconstruct :: Free (CofreeF f annotation) patch } - - -class PatchConstructible p where - insert :: Term Syntax (Record '[Range]) -> p - delete :: Term Syntax (Record '[Range]) -> p - -instance PatchConstructible (Patch (Term Syntax (Record '[Range]))) where - insert = Insert - delete = Delete - -instance PatchConstructible (SplitPatch (Term Syntax (Record '[Range]))) where - insert = SplitInsert - delete = SplitDelete - -instance PatchConstructible (SplitPatch (Term [] (Record '[Range]))) where - insert = SplitInsert . hoistCofree toList - delete = SplitDelete . hoistCofree toList - -instance (Functor f, PatchConstructible patch) => PatchConstructible (ConstructibleFree f patch annotation) where - insert = ConstructibleFree . pure . insert - delete = ConstructibleFree . pure . delete - -class SyntaxConstructible s where - leaf :: annotation -> Text.Text -> s annotation - branch :: annotation -> [s annotation] -> s annotation - -instance SyntaxConstructible (ConstructibleFree Syntax patch) where - leaf info = ConstructibleFree . wrap . (info :<) . Leaf - branch info = ConstructibleFree . wrap . (info :<) . Indexed . fmap deconstruct - -instance SyntaxConstructible (ConstructibleFree [] patch) where - leaf info = ConstructibleFree . wrap . (info :<) . const [] - branch info = ConstructibleFree . wrap . (info :<) . fmap deconstruct - -instance SyntaxConstructible (Cofree Syntax) where - info `leaf` value = cofree $ info :< Leaf value - info `branch` children = cofree $ info :< Indexed children - -instance SyntaxConstructible (Cofree []) where - info `leaf` _ = cofree $ info :< [] - info `branch` children = cofree $ info :< children diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index e023f5cd5..5181d0f03 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -21,25 +21,25 @@ spec = parallel $ do let positively = succ . abs describe "pqGramDecorator" $ do prop "produces grams with stems of the specified length" $ - \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead) + \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead) prop "produces grams with bases of the specified width" $ - \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead) + \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (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 . termAnnotation) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead) + \ (term, p, q, d) -> featureVectorDecorator (rhead . termAnnotation) (positively p) (positively q) (positively d) (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 '[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 + \ (as, bs) -> let tas = decorate <$> (as :: [SyntaxTerm '[Category]]) + tbs = decorate <$> (bs :: [SyntaxTerm '[Category]]) + root = Term . ((Program :. Nil) :<) . Indexed + diff = copy (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))) it "produces unbiased insertions within branches" $ - let (a, b) = (decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "a") ])), decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "b") ]))) in + let (a, b) = (decorate (Term ((StringLiteral :. Nil) :< Indexed [ Term ((StringLiteral :. Nil) :< Leaf "a") ])), decorate (Term ((StringLiteral :. Nil) :< Indexed [ Term ((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 = termAnnotation a == termAnnotation b diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 3c305e465..63b50b450 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} module Data.Syntax.Assignment.Spec where -import Control.Comonad.Cofree (Cofree(..)) import Data.Bifunctor (first) import Data.ByteString.Char8 as B (ByteString, length, words) import Data.Ix @@ -12,6 +11,7 @@ import Data.Span import Data.Syntax.Assignment import GHC.Stack (getCallStack) import Prelude hiding (words) +import Term import Test.Hspec import TreeSitter.Language (Symbol(..), SymbolType(..)) @@ -289,7 +289,7 @@ spec = do Left [ "symbol" ] node :: symbol -> Int -> Int -> [AST [] symbol] -> AST [] symbol -node symbol start end children = Node symbol (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end))) :< children +node symbol start end children = Term (Node symbol (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end))) :< children) data Grammar = Palette | Red | Green | Blue | Magenta deriving (Bounded, Enum, Eq, Ix, Ord, Show) diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index 47b86a0fa..4361ac492 100644 --- a/test/DiffSpec.hs +++ b/test/DiffSpec.hs @@ -17,19 +17,19 @@ spec :: Spec spec = parallel $ do let decorate = defaultFeatureVectorDecorator (category . termAnnotation) prop "equality is reflexive" $ - \ a -> let diff = unListableDiff a :: SyntaxDiff '[Category] in + \ a -> let diff = a :: SyntaxDiff '[Category] in diff `shouldBe` diff prop "equal terms produce identity diffs" $ - \ a -> let term = decorate (unListableF a :: SyntaxTerm '[Category]) in + \ a -> let term = decorate (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 '[Category])) in - beforeTerm diff `shouldBe` Just (unListableF a) + \ a b -> let diff = diffTerms (both a b :: Both (SyntaxTerm '[Category])) in + beforeTerm diff `shouldBe` Just a describe "afterTerm" $ do prop "recovers the after term" $ - \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in - afterTerm diff `shouldBe` Just (unListableF b) + \ a b -> let diff = diffTerms (both a b :: Both (SyntaxTerm '[Category])) in + afterTerm diff `shouldBe` Just b diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 6044f5e89..b24785fc7 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -20,8 +20,8 @@ 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" - termB = cofree $ (StringLiteral :. Nil) :< Leaf "\7831" in + let termA = Term $ (StringLiteral :. Nil) :< Leaf "t\776" + termB = Term $ (StringLiteral :. Nil) :< Leaf "\7831" in diffTerms (both termA termB) `shouldBe` replacing termA termB prop "produces correct diffs" $ @@ -34,6 +34,6 @@ spec = parallel $ do diffCost diff `shouldBe` 0 it "produces unbiased insertions within branches" $ - 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")) ]) + let term s = Term ((StringLiteral :. Nil) :< Indexed [ Term ((StringLiteral :. Nil) :< Leaf s) ]) :: SyntaxTerm '[Category] + root = Term . ((Program :. Nil) :<) . Indexed in + diffTerms (both (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` copy (pure (Program :. Nil)) (Indexed [ inserting (term "a"), cata (\ (a :< r) -> copy (pure a) r) (term "b") ]) diff --git a/test/PatchOutputSpec.hs b/test/PatchOutputSpec.hs index f5d55a67f..4dfbd652c 100644 --- a/test/PatchOutputSpec.hs +++ b/test/PatchOutputSpec.hs @@ -1,11 +1,10 @@ module PatchOutputSpec where -import Control.Comonad.Trans.Cofree (CofreeF(..)) -import Control.Monad.Free (wrap) import Data.Blob import Data.Functor.Both import Data.Range import Data.Record +import Diff import Renderer.Patch import Syntax import Test.Hspec (Spec, describe, it, parallel) @@ -15,4 +14,4 @@ spec :: Spec spec = parallel $ do describe "hunks" $ do it "empty diffs have empty hunks" $ - hunks (wrap $ pure (Range 0 0 :. Nil) :< Leaf "") (both (Blob mempty "abcde" "path2.txt" (Just defaultPlainBlob) Nothing) (Blob mempty "xyz" "path2.txt" (Just defaultPlainBlob) Nothing)) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}] + hunks (copy (pure (Range 0 0 :. Nil)) (Leaf "")) (both (Blob mempty "abcde" "path2.txt" (Just defaultPlainBlob) Nothing) (Blob mempty "xyz" "path2.txt" (Just defaultPlainBlob) Nothing)) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}] diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs index 95c9497be..c7fec3115 100644 --- a/test/SemanticSpec.hs +++ b/test/SemanticSpec.hs @@ -1,15 +1,16 @@ module SemanticSpec where -import Control.Comonad.Cofree (Cofree(..)) import Data.Blob import Data.Functor (void) import Data.Functor.Both as Both +import Diff import Language import Patch import Renderer import Semantic import Semantic.Task import Syntax +import Term import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty @@ -18,11 +19,11 @@ spec = parallel $ do describe "parseBlob" $ do it "parses in the specified language" $ do Just term <- runTask $ parseBlob IdentityTermRenderer methodsBlob - void term `shouldBe` (() :< Indexed [ () :< Method [] (() :< Leaf "foo") Nothing [] [] ]) + void term `shouldBe` Term (() :< Indexed [ Term (() :< Method [] (Term (() :< Leaf "foo")) Nothing [] []) ]) it "parses line by line if not given a language" $ do Just term <- runTask $ parseBlob IdentityTermRenderer methodsBlob { blobLanguage = Nothing } - void term `shouldBe` (() :< Indexed [ () :< Leaf "def foo\n", () :< Leaf "end\n", () :< Leaf "" ]) + void term `shouldBe` Term (() :< Indexed [ Term (() :< Leaf "def foo\n"), Term (() :< Leaf "end\n"), Term (() :< Leaf "") ]) it "renders with the specified renderer" $ do output <- runTask $ parseBlob SExpressionTermRenderer methodsBlob @@ -30,12 +31,12 @@ spec = parallel $ do describe "diffTermPair" $ do it "produces an Insert when the first blob is missing" $ do - result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) (runBothWith replacing) (pure (() :< []))) - (() <$) <$> result `shouldBe` pure (Insert ()) + result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) (runBothWith replacing) (pure (Term (() :< [])))) + result `shouldBe` Diff (Patch (Insert (Term (() :< [])))) it "produces a Delete when the second blob is missing" $ do - result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) (runBothWith replacing) (pure (() :< []))) - (() <$) <$> result `shouldBe` pure (Delete ()) + result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) (runBothWith replacing) (pure (Term (() :< [])))) + result `shouldBe` Diff (Patch (Delete (Term (() :< [])))) where methodsBlob = Blob "def foo\nend\n" "ff7bbbe9495f61d9e1e58c597502d152bab1761e" "methods.rb" (Just defaultPlainBlob) (Just Ruby) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 7e1ff14a8..c78e9c7f7 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -4,7 +4,6 @@ module SpecHelpers , parseFilePath , readFile , languageForFilePath -, unListableDiff ) where import Control.Exception @@ -51,7 +50,3 @@ readFile path = do -- | Returns a Maybe Language based on the FilePath's extension. languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . takeExtension - --- | Extract a 'Diff' from a 'ListableF' enumerated by a property test. -unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation -unListableDiff diff = hoistFree (first unListableF) $ fmap unListableF <$> unListableF diff diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 35d557145..555a866de 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -41,24 +41,24 @@ 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 ()) (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' = (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 . termAnnotation) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')] + \ term -> let term' = (term :: Term Syntax (Record '[Category])) in tableOfContentsBy (Just . termAnnotation) (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 . termAnnotation) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch')) + \ patch -> let patch' = (patch :: Patch (Term Syntax Int)) in tableOfContentsBy (Just . termAnnotation) (Diff (Patch 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 <$) <$> fmap (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff Syntax Int])) in + \ diff -> let diff' = copy (pure 0) (Indexed [diff :: Diff Syntax Int]) in tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe` if null diff' then [Unchanged 0] - else replicate (length diff') (Changed 0) + else replicate (length diff') (Changed 0) describe "diffTOC" $ do it "blank if there are no methods" $ @@ -109,31 +109,31 @@ spec = parallel $ do prop "inserts of methods and functions are summarized" $ \name body -> - let diff = programWithInsert name (unListableF body) + let diff = programWithInsert name body in numTocSummaries diff `shouldBe` 1 prop "deletes of methods and functions are summarized" $ \name body -> - let diff = programWithDelete name (unListableF body) + let diff = programWithDelete name body in numTocSummaries diff `shouldBe` 1 prop "replacements of methods and functions are summarized" $ \name body -> - let diff = programWithReplace name (unListableF body) + let diff = programWithReplace name body in numTocSummaries diff `shouldBe` 1 prop "changes inside methods and functions are summarizied" . forAll (isMeaningfulTerm `filterT` tiers) $ \body -> - let diff = programWithChange (unListableF body) + let diff = programWithChange body in numTocSummaries diff `shouldBe` 1 prop "other changes don't summarize" . forAll ((not . isMethodOrFunction) `filterT` tiers) $ \body -> - let diff = programWithChangeOutsideFunction (unListableF body) + let diff = programWithChangeOutsideFunction body in numTocSummaries diff `shouldBe` 0 prop "equal terms produce identity diffs" $ - \a -> let term = defaultFeatureVectorDecorator (Info.category . termAnnotation) (unListableF a :: Term') in + \a -> let term = defaultFeatureVectorDecorator (Info.category . termAnnotation) (a :: Term') in diffTOC (diffTerms (pure term)) `shouldBe` [] describe "JSONSummary" $ do @@ -170,17 +170,17 @@ numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) -- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff. programWithChange :: Term' -> Diff' -programWithChange body = wrap (pure programInfo :< Indexed [ function' ]) +programWithChange body = copy (pure programInfo) (Indexed [ function' ]) where - function' = wrap (pure (Just (FunctionDeclaration "foo") :. functionInfo) :< S.Function name' [] [ inserting body ] ) - name' = wrap (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo") + function' = copy (pure (Just (FunctionDeclaration "foo") :. functionInfo)) (S.Function name' [] [ inserting body ]) + name' = copy (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil)) (Leaf "foo") -- Return a diff where term is inserted in the program, below a function found on both sides of the diff. programWithChangeOutsideFunction :: Term' -> Diff' -programWithChangeOutsideFunction term = wrap (pure programInfo :< Indexed [ function', term' ]) +programWithChangeOutsideFunction term = copy (pure programInfo) (Indexed [ function', term' ]) where - function' = wrap (pure (Just (FunctionDeclaration "foo") :. functionInfo) :< S.Function name' [] [] ) - name' = wrap (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf "foo") + function' = copy (pure (Just (FunctionDeclaration "foo") :. functionInfo)) (S.Function name' [] []) + name' = copy (pure (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil)) (Leaf "foo") term' = inserting term programWithInsert :: Text -> Term' -> Diff' @@ -193,12 +193,12 @@ programWithReplace :: Text -> Term' -> Diff' programWithReplace name body = programOf $ replacing (functionOf name body) (functionOf (name <> "2") body) programOf :: Diff' -> Diff' -programOf diff = wrap (pure programInfo :< Indexed [ diff ]) +programOf diff = copy (pure programInfo) (Indexed [ diff ]) functionOf :: Text -> Term' -> Term' -functionOf name body = cofree $ (Just (FunctionDeclaration name) :. functionInfo) :< S.Function name' [] [body] +functionOf name body = Term $ (Just (FunctionDeclaration name) :. functionInfo) :< S.Function name' [] [body] where - name' = cofree $ (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name + name' = Term $ (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name programInfo :: Record (Maybe Declaration ': DefaultFields) programInfo = Nothing :. Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil @@ -207,8 +207,8 @@ 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) a -> Bool -isMeaningfulTerm a = case unTerm (unListableF a) of +isMeaningfulTerm :: Term Syntax a -> Bool +isMeaningfulTerm a = case unTerm a of (_ :< S.Indexed _) -> False (_ :< S.Fixed _) -> False (_ :< S.Commented _ _) -> False @@ -216,8 +216,8 @@ isMeaningfulTerm a = case unTerm (unListableF a) of _ -> True -- Filter tiers for terms if the Syntax is a Method or a Function. -isMethodOrFunction :: HasField fields Category => ListableF (Term Syntax) (Record fields) -> Bool -isMethodOrFunction a = case unTerm (unListableF a) of +isMethodOrFunction :: HasField fields Category => Term Syntax (Record fields) -> Bool +isMethodOrFunction a = case unTerm a of (_ :< S.Method{}) -> True (_ :< S.Function{}) -> True (a :< _) | getField a == C.Function -> True @@ -232,7 +232,7 @@ sourceSpanBetween :: (Int, Int) -> (Int, Int) -> Span sourceSpanBetween (s1, e1) (s2, e2) = Span (Pos s1 e1) (Pos s2 e2) blankDiff :: Diff' -blankDiff = wrap (pure arrayInfo :< Indexed [ inserting (cofree $ literalInfo :< Leaf "\"a\"") ]) +blankDiff = copy (pure arrayInfo) (Indexed [ inserting (Term $ literalInfo :< Leaf "\"a\"") ]) where arrayInfo = Nothing :. Range 0 3 :. ArrayLiteral :. sourceSpanBetween (1, 1) (1, 5) :. Nil literalInfo = Nothing :. Range 1 2 :. StringLiteral :. sourceSpanBetween (1, 2) (1, 4) :. Nil From f01c65a0a2c3a68ba11d9fe0f44e813b3019d2a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:23:20 +0100 Subject: [PATCH 070/113] Define a function computing the list of patches in a diff. --- src/Diff.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Diff.hs b/src/Diff.hs index 5c996b508..fc7258f21 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -4,10 +4,11 @@ module Diff where import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable +import Data.Foldable (fold) import Data.Functor.Both as Both import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty -import Data.Functor.Foldable +import Data.Functor.Foldable hiding (fold) import Data.Functor.Listable import Data.Mergeable import Data.Record @@ -36,6 +37,11 @@ diffSum patchCost = go diffCost :: (Foldable syntax, Functor syntax) => Diff syntax annotation -> Int diffCost = diffSum (patchSum termSize) +diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann -> [Patch (Term syntax ann)] +diffPatches = cata $ \ diff -> case diff of + Copy _ r -> fold r + Patch p -> [p] + -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: Mergeable syntax => (Patch (Term syntax annotation) -> Maybe (Term syntax annotation)) -> (Both annotation -> annotation) -> Diff syntax annotation -> Maybe (Term syntax annotation) mergeMaybe transform extractAnnotation = cata algebra From 72586828621efdc07c1b86391b7ed9967d4a6d2c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:28:43 +0100 Subject: [PATCH 071/113] Fix one of the ToC tests. --- test/TOCSpec.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 555a866de..16a693373 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -55,10 +55,10 @@ spec = parallel $ do \ patch -> let patch' = (patch :: Patch (Term Syntax Int)) in tableOfContentsBy (Just . termAnnotation) (Diff (Patch 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' = copy (pure 0) (Indexed [diff :: Diff Syntax Int]) in + \ diff -> let diff' = copy (pure 0) (Indexed [1 <$ (diff :: Diff Syntax Int)]) in tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe` - if null diff' then [Unchanged 0] - else replicate (length diff') (Changed 0) + if null (diffPatches diff') then [Unchanged 0] + else replicate (length (diffPatches diff')) (Changed 0) describe "diffTOC" $ do it "blank if there are no methods" $ From eb01f7450a971dd63291d665f81eba74b6ec35e5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:30:42 +0100 Subject: [PATCH 072/113] Correct the diffSize helper. --- test/TOCSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 16a693373..c13ff9f8b 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -43,7 +43,7 @@ spec = parallel $ do prop "drops all nodes with the constant Nothing function" $ \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff Syntax ()) `shouldBe` [] - let diffSize = max 1 . sum . fmap (const 1) + let diffSize = max 1 . length . diffPatches let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a)) prop "includes all nodes with a constant Just function" $ \ diff -> let diff' = (diff :: Diff Syntax ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') () From 3ad5374b942312a3c0f51c7762a338573aa272b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:44:57 +0100 Subject: [PATCH 073/113] Move all the Listable stuff into the tests. --- semantic-diff.cabal | 3 +- src/Category.hs | 119 -------------- src/Data/Functor/Listable.hs | 130 --------------- src/Data/Record.hs | 8 - src/Data/Text/Listable.hs | 9 -- src/Diff.hs | 17 -- src/Patch.hs | 7 - src/RWS.hs | 7 - src/Renderer/TOC.hs | 8 - src/Syntax.hs | 63 +------- src/Term.hs | 16 -- test/Data/Functor/Listable.hs | 287 ++++++++++++++++++++++++++++++++++ test/TOCSpec.hs | 4 - 13 files changed, 289 insertions(+), 389 deletions(-) delete mode 100644 src/Data/Functor/Listable.hs delete mode 100644 src/Data/Text/Listable.hs create mode 100644 test/Data/Functor/Listable.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 34b1e76a2..bfb21be59 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -23,7 +23,6 @@ library , Data.Functor.Classes.Eq.Generic , Data.Functor.Classes.Pretty.Generic , Data.Functor.Classes.Show.Generic - , Data.Functor.Listable , Data.Mergeable , Data.Mergeable.Generic , Data.Output @@ -41,7 +40,6 @@ library , Data.Syntax.Markup , Data.Syntax.Statement , Data.Syntax.Type - , Data.Text.Listable , Decorators , Diff , Files @@ -145,6 +143,7 @@ test-suite test main-is: Spec.hs other-modules: AlignmentSpec , CommandSpec + , Data.Functor.Listable , Data.Mergeable.Spec , Data.RandomWalkSimilarity.Spec , Data.Syntax.Assignment.Spec diff --git a/src/Category.hs b/src/Category.hs index 516fd8d2f..3030d2e0a 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -3,7 +3,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Category where -import Data.Functor.Listable import Data.Hashable import Data.Text (Text) import Data.Text.Prettyprint.Doc @@ -246,123 +245,5 @@ data Category instance Hashable Category -instance Listable Category where - tiers = cons0 Program - \/ cons0 ParseError - \/ cons0 Boolean - \/ cons0 BooleanOperator - -- \/ cons0 MathOperator - -- \/ cons0 DictionaryLiteral - -- \/ cons0 Pair - \/ cons0 FunctionCall - \/ cons0 Function - \/ cons0 Identifier - -- \/ cons0 Params - -- \/ cons0 ExpressionStatements - \/ cons0 MethodCall - -- \/ cons0 Args - \/ cons0 StringLiteral - \/ cons0 IntegerLiteral - \/ cons0 NumberLiteral - -- \/ cons0 Regex - \/ cons0 Return - -- \/ cons0 SymbolLiteral - -- \/ cons0 TemplateString - -- \/ cons0 ArrayLiteral - -- \/ cons0 Assignment - -- \/ cons0 MathAssignment - -- \/ cons0 MemberAccess - -- \/ cons0 SubscriptAccess - -- \/ cons0 VarAssignment - -- \/ cons0 VarDecl - -- \/ cons0 For - -- \/ cons0 DoWhile - -- \/ cons0 While - -- \/ cons0 Switch - \/ cons0 If - -- \/ cons0 Ternary - -- \/ cons0 Case - -- \/ cons0 Operator - -- \/ cons0 CommaOperator - -- \/ cons0 Object - -- \/ cons0 Throw - -- \/ cons0 Constructor - -- \/ cons0 Try - -- \/ cons0 Catch - -- \/ cons0 Finally - \/ cons0 Class - \/ cons0 Method - -- \/ cons0 Comment - -- \/ cons0 RelationalOperator - -- \/ cons0 Empty - -- \/ cons0 Module - -- \/ cons0 Import - -- \/ cons0 Export - -- \/ cons0 AnonymousFunction - -- \/ cons0 Interpolation - -- \/ cons0 Subshell - -- \/ cons0 OperatorAssignment - -- \/ cons0 Yield - -- \/ cons0 Until - -- \/ cons0 Unless - -- \/ cons0 Begin - -- \/ cons0 Else - -- \/ cons0 Elsif - -- \/ cons0 Ensure - -- \/ cons0 Rescue - -- \/ cons0 RescueModifier - -- \/ cons0 RescuedException - -- \/ cons0 RescueArgs - -- \/ cons0 When - -- \/ cons0 Negate - -- \/ cons0 Select - -- \/ cons0 Defer - -- \/ cons0 Go - -- \/ cons0 Slice - -- \/ cons0 TypeAssertion - -- \/ cons0 TypeConversion - -- \/ cons0 ArgumentPair - -- \/ cons0 KeywordParameter - -- \/ cons0 OptionalParameter - -- \/ cons0 SplatParameter - -- \/ cons0 HashSplatParameter - -- \/ cons0 BlockParameter - -- \/ cons0 FloatLiteral - -- \/ cons0 ArrayTy - -- \/ cons0 DictionaryTy - -- \/ cons0 StructTy - -- \/ cons0 Struct - -- \/ cons0 Break - -- \/ cons0 Continue - \/ cons0 Binary - \/ cons0 Unary - -- \/ cons0 Constant - -- \/ cons0 Superclass - -- \/ cons0 SingletonClass - -- \/ cons0 RangeExpression - -- \/ cons0 ScopeOperator - -- \/ cons0 BeginBlock - -- \/ cons0 EndBlock - -- \/ cons0 ParameterDecl - -- \/ cons0 DefaultCase - -- \/ cons0 TypeDecl - -- \/ cons0 PointerTy - -- \/ cons0 FieldDecl - -- \/ cons0 SliceTy - -- \/ cons0 Element - -- \/ cons0 Literal - -- \/ cons0 ChannelTy - -- \/ cons0 Send - -- \/ cons0 IndexExpression - -- \/ cons0 FunctionTy - -- \/ cons0 IncrementStatement - -- \/ cons0 DecrementStatement - -- \/ cons0 QualifiedType - -- \/ cons0 FieldDeclarations - -- \/ cons0 RuneLiteral - -- \/ cons0 (Modifier If) - \/ cons0 SingletonMethod - -- \/ cons0 (Other "other") - instance Pretty Category where pretty = pretty . show diff --git a/src/Data/Functor/Listable.hs b/src/Data/Functor/Listable.hs deleted file mode 100644 index 557f73946..000000000 --- a/src/Data/Functor/Listable.hs +++ /dev/null @@ -1,130 +0,0 @@ -module Data.Functor.Listable -( Listable(..) -, mapT -, cons0 -, cons1 -, cons2 -, cons3 -, cons4 -, cons5 -, cons6 -, (\/) -, Tier -, Listable1(..) -, tiers1 -, Listable2(..) -, tiers2 -, liftCons1 -, liftCons2 -, liftCons3 -, liftCons4 -, liftCons5 -, ListableF(..) -, addWeight -, ofWeight -) where - -import Control.Monad.Free as Free -import Control.Monad.Trans.Free as FreeF -import Data.Bifunctor.Join -import Data.These -import Test.LeanCheck - -type Tier a = [a] - --- | Lifting of 'Listable' to @* -> *@. -class Listable1 l where - -- | The tiers for @l :: * -> *@, parameterized by the tiers for @a :: *@. - liftTiers :: [Tier a] -> [Tier (l a)] - --- | A suitable definition of 'tiers' for 'Listable1' type constructors parameterized by 'Listable' types. -tiers1 :: (Listable a, Listable1 l) => [Tier (l a)] -tiers1 = liftTiers tiers - - --- | Lifting of 'Listable' to @* -> * -> *@. -class Listable2 l where - -- | The tiers for @l :: * -> * -> *@, parameterized by the tiers for @a :: *@ & @b :: *@. - liftTiers2 :: [Tier a] -> [Tier b] -> [Tier (l a b)] - --- | A suitable definition of 'tiers' for 'Listable2' type constructors parameterized by 'Listable' types. -tiers2 :: (Listable a, Listable b, Listable2 l) => [Tier (l a b)] -tiers2 = liftTiers2 tiers tiers - - --- | Lifts a unary constructor to a list of tiers, given a list of tiers for its argument. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons1 :: [Tier a] -> (a -> b) -> [Tier b] -liftCons1 tiers f = mapT f tiers `addWeight` 1 - --- | Lifts a binary constructor to a list of tiers, given lists of tiers for its arguments. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons2 :: [Tier a] -> [Tier b] -> (a -> b -> c) -> [Tier c] -liftCons2 tiers1 tiers2 f = mapT (uncurry f) (liftTiers2 tiers1 tiers2) `addWeight` 1 - --- | Lifts a ternary constructor to a list of tiers, given lists of tiers for its arguments. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons3 :: [Tier a] -> [Tier b] -> [Tier c] -> (a -> b -> c -> d) -> [Tier d] -liftCons3 tiers1 tiers2 tiers3 f = mapT (uncurry3 f) (tiers1 >< tiers2 >< tiers3) `addWeight` 1 - where uncurry3 f (a, (b, c)) = f a b c - --- | Lifts a quaternary constructor to a list of tiers, given lists of tiers for its arguments. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons4 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> (a -> b -> c -> d -> e) -> [Tier e] -liftCons4 tiers1 tiers2 tiers3 tiers4 f = mapT (uncurry4 f) (tiers1 >< tiers2 >< tiers3 >< tiers4) `addWeight` 1 - where uncurry4 f (a, (b, (c, d))) = f a b c d - --- | Lifts a quinary constructor to a list of tiers, given lists of tiers for its arguments. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons5 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> [Tier e] -> (a -> b -> c -> d -> e -> f) -> [Tier f] -liftCons5 tiers1 tiers2 tiers3 tiers4 tiers5 f = mapT (uncurry5 f) (tiers1 >< tiers2 >< tiers3 >< tiers4 >< tiers5) `addWeight` 1 - where uncurry5 f (a, (b, (c, (d, e)))) = f a b c d e - --- | Convenient wrapper for 'Listable1' type constructors and 'Listable' types, where a 'Listable' instance would necessarily be orphaned. -newtype ListableF f a = ListableF { unListableF :: f a } - deriving Show - - --- Instances - -instance Listable1 Maybe where - liftTiers tiers = cons0 Nothing \/ liftCons1 tiers Just - -instance Listable2 (,) where - liftTiers2 = (><) - -instance Listable2 Either where - liftTiers2 leftTiers rightTiers = liftCons1 leftTiers Left \/ liftCons1 rightTiers Right - -instance Listable a => Listable1 ((,) a) where - liftTiers = liftTiers2 tiers - -instance Listable1 [] where - liftTiers tiers = go - where go = cons0 [] \/ liftCons2 tiers go (:) - -instance Listable2 p => Listable1 (Join p) where - liftTiers tiers = liftCons1 (liftTiers2 tiers tiers) Join - -instance Listable2 These where - liftTiers2 this that = liftCons1 this This \/ liftCons1 that That \/ liftCons2 this that These - -instance Listable1 f => Listable2 (FreeF f) where - liftTiers2 pureTiers recurTiers = liftCons1 pureTiers FreeF.Pure \/ liftCons1 (liftTiers recurTiers) FreeF.Free - -instance (Listable1 f, Listable a) => Listable1 (FreeF f a) where - liftTiers = liftTiers2 tiers - -instance (Functor f, Listable1 f) => Listable1 (Free.Free f) where - liftTiers pureTiers = go - where go = liftCons1 (liftTiers2 pureTiers go) free - free (FreeF.Free f) = Free.Free f - free (FreeF.Pure a) = Free.Pure a - -instance (Listable1 f, Listable a) => Listable (ListableF f a) where - tiers = ListableF `mapT` tiers1 diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 12a486489..ac5431973 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -2,7 +2,6 @@ module Data.Record where import Data.Kind -import Data.Functor.Listable import Data.Semigroup import Data.Text.Prettyprint.Doc @@ -70,13 +69,6 @@ instance Ord (Record '[]) where _ `compare` _ = EQ -instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where - tiers = cons2 (:.) - -instance Listable (Record '[]) where - tiers = cons0 Nil - - instance (Semigroup head, Semigroup (Record tail)) => Semigroup (Record (head ': tail)) where (h1 :. t1) <> (h2 :. t2) = (h1 <> h2) :. (t1 <> t2) diff --git a/src/Data/Text/Listable.hs b/src/Data/Text/Listable.hs deleted file mode 100644 index e4afd072b..000000000 --- a/src/Data/Text/Listable.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Data.Text.Listable where - -import Data.Functor.Listable -import Data.Text - -newtype ListableText = ListableText { unListableText :: Text } - -instance Listable ListableText where - tiers = cons1 (ListableText . pack) diff --git a/src/Diff.hs b/src/Diff.hs index fc7258f21..732f0ca94 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -9,7 +9,6 @@ import Data.Functor.Both as Both import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable hiding (fold) -import Data.Functor.Listable import Data.Mergeable import Data.Record import Data.Union @@ -162,19 +161,3 @@ instance Foldable f => Bifoldable (DiffF f) where instance Traversable f => Bitraversable (DiffF f) where bitraverse f g (Copy as r) = Copy <$> traverse f as <*> traverse g r bitraverse f _ (Patch p) = Patch <$> traverse (traverse f) p - - -instance Listable1 f => Listable2 (DiffF f) where - liftTiers2 annTiers recurTiers = liftCons2 (liftCons2 annTiers annTiers both) (liftTiers recurTiers) Copy \/ liftCons1 (liftTiers (liftTiers annTiers)) Patch - -instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where - liftTiers = liftTiers2 tiers - -instance (Listable1 f, Listable a, Listable b) => Listable (DiffF f a b) where - tiers = tiers1 - -instance Listable1 f => Listable1 (Diff f) where - liftTiers annTiers = go where go = liftCons1 (liftTiers2 annTiers go) Diff - -instance (Listable1 f, Listable a) => Listable (Diff f a) where - tiers = tiers1 diff --git a/src/Patch.hs b/src/Patch.hs index 7c44dd524..30b6f20f9 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -15,7 +15,6 @@ import Data.Align import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic -import Data.Functor.Listable import Data.These import GHC.Generics @@ -61,12 +60,6 @@ maybeSnd = these (const Nothing) Just ((Just .) . flip const) -- Instances -instance Listable1 Patch where - liftTiers t = liftCons1 t Insert \/ liftCons1 t Delete \/ liftCons2 t t Replace - -instance Listable a => Listable (Patch a) where - tiers = tiers1 - instance Crosswalk Patch where crosswalk f (Replace a b) = alignWith (these Delete Insert Replace) (f a) (f b) crosswalk f (Insert b) = Insert <$> f b diff --git a/src/RWS.hs b/src/RWS.hs index 3df058806..a23829f82 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -29,7 +29,6 @@ import Data.Array.Unboxed import Data.Functor.Classes import SES import qualified Data.Functor.Both as Both -import Data.Functor.Listable import Data.KdTree.Static hiding (empty, toList) import qualified Data.IntMap as IntMap @@ -311,9 +310,3 @@ equalTerms canCompare = go instance Hashable label => Hashable (Gram label) where hashWithSalt _ = hash hash gram = hash (stem gram <> base gram) - -instance Listable1 Gram where - liftTiers tiers = liftCons2 (liftTiers (liftTiers tiers)) (liftTiers (liftTiers tiers)) Gram - -instance Listable a => Listable (Gram a) where - tiers = tiers1 diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index ac86a9262..6efd9ef55 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -27,7 +27,6 @@ import Data.Foldable (fold, foldl', toList) import Data.Functor.Both hiding (fst, snd) import qualified Data.Functor.Both as Both import Data.Functor.Foldable (cata) -import Data.Functor.Listable import Data.Function (on) import Data.List.NonEmpty (nonEmpty) import Data.Maybe (fromMaybe, mapMaybe) @@ -37,7 +36,6 @@ import Data.Semigroup ((<>), sconcat) import Data.Source as Source import Data.Text (toLower) import qualified Data.Text as T -import Data.Text.Listable import Data.These import Data.Union import Diff @@ -227,9 +225,3 @@ toCategoryName declaration = case declaration of MethodDeclaration _ -> "Method" SectionDeclaration _ l -> "Heading " <> T.pack (show l) ErrorDeclaration{} -> "ParseError" - -instance Listable Declaration where - tiers - = cons1 (MethodDeclaration . unListableText) - \/ cons1 (FunctionDeclaration . unListableText) - \/ cons1 (flip ErrorDeclaration Nothing . unListableText) diff --git a/src/Syntax.hs b/src/Syntax.hs index 4c2ece882..f501d71f4 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -7,9 +7,8 @@ import Data.Functor.Classes import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic -import Data.Functor.Listable import Data.Mergeable -import Data.Text (pack, Text) +import Data.Text (Text) import GHC.Generics -- | A node in an abstract syntax tree. @@ -121,66 +120,6 @@ extractLeafValue syntax = case syntax of -- Instances -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 - \/ liftCons2 recur (liftTiers recur) Ternary - \/ liftCons2 (liftTiers recur) (liftTiers recur) AnonymousFunction - \/ liftCons3 recur (liftTiers recur) (liftTiers recur) Function - \/ liftCons2 recur recur Assignment - \/ liftCons2 recur recur OperatorAssignment - \/ liftCons2 recur recur MemberAccess - \/ liftCons4 recur recur (liftTiers recur) (liftTiers recur) MethodCall - \/ liftCons1 (liftTiers recur) Operator - \/ liftCons1 (liftTiers recur) VarDecl - \/ liftCons2 (liftTiers recur) recur VarAssignment - \/ liftCons2 recur recur SubscriptAccess - \/ liftCons2 (liftTiers recur) (liftTiers recur) Switch - \/ liftCons2 recur (liftTiers recur) Case - \/ liftCons1 (liftTiers recur) Select - \/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Object - \/ liftCons2 recur recur Pair - \/ liftCons1 (pack `mapT` tiers) Comment - \/ liftCons2 (liftTiers recur) (liftTiers recur) Commented - \/ liftCons1 (liftTiers recur) Syntax.ParseError - \/ liftCons2 (liftTiers recur) (liftTiers recur) For - \/ liftCons2 recur recur DoWhile - \/ liftCons2 recur (liftTiers recur) While - \/ liftCons1 (liftTiers recur) Return - \/ liftCons1 recur Throw - \/ liftCons1 recur Constructor - \/ liftCons4 (liftTiers recur) (liftTiers recur) (liftTiers recur) (liftTiers recur) Try - \/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Array - \/ liftCons3 recur (liftTiers recur) (liftTiers recur) Class - \/ liftCons5 (liftTiers recur) recur (liftTiers recur) (liftTiers recur) (liftTiers recur) Method - \/ liftCons2 recur (liftTiers recur) If - \/ liftCons2 recur (liftTiers recur) Module - \/ liftCons2 recur (liftTiers recur) Namespace - \/ liftCons2 recur (liftTiers recur) Import - \/ liftCons2 (liftTiers recur) (liftTiers recur) Export - \/ liftCons1 (liftTiers recur) Yield - \/ liftCons1 recur Negate - \/ liftCons2 (liftTiers recur) (liftTiers recur) Rescue - \/ liftCons1 recur Go - \/ liftCons1 recur Defer - \/ liftCons2 recur recur TypeAssertion - \/ liftCons2 recur recur TypeConversion - \/ liftCons1 (liftTiers recur) Break - \/ liftCons1 (liftTiers recur) Continue - \/ liftCons1 (liftTiers recur) BlockStatement - \/ liftCons2 (liftTiers recur) recur ParameterDecl - \/ liftCons2 recur recur TypeDecl - \/ liftCons1 (liftTiers recur) FieldDecl - \/ liftCons1 (liftTiers recur) Ty - \/ liftCons2 recur recur Send - \/ liftCons1 (liftTiers recur) DefaultCase - -instance Listable recur => Listable (Syntax recur) where - tiers = tiers1 - instance Eq1 Syntax where liftEq = genericLiftEq instance Show1 Syntax where liftShowsPrec = genericLiftShowsPrec instance Pretty1 Syntax where liftPretty = genericLiftPretty diff --git a/src/Term.hs b/src/Term.hs index 4297996ee..402e9af4f 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -20,7 +20,6 @@ import Data.Bitraversable import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable -import Data.Functor.Listable import Data.Proxy import Data.Record import Data.Union @@ -106,21 +105,6 @@ instance Foldable f => Bifoldable (TermF f) where instance Traversable f => Bitraversable (TermF f) where bitraverse f g (a :< r) = (:<) <$> f a <*> traverse g r -instance Listable1 f => Listable2 (TermF f) where - liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<) - -instance (Listable1 f, Listable a) => Listable1 (TermF f a) where - liftTiers = liftTiers2 tiers - -instance (Listable1 f, Listable a, Listable b) => Listable (TermF f a b) where - tiers = tiers1 - -instance Listable1 f => Listable1 (Term f) where - liftTiers annotationTiers = go - where go = liftCons1 (liftTiers2 annotationTiers go) Term - -instance (Listable1 f, Listable a) => Listable (Term f a) where - tiers = tiers1 instance Eq1 f => Eq2 (TermF f) where liftEq2 eqA eqB (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq eqB f1 f2 diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs new file mode 100644 index 000000000..0525c6551 --- /dev/null +++ b/test/Data/Functor/Listable.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Functor.Listable +( Listable(..) +, mapT +, cons0 +, cons1 +, cons2 +, cons3 +, cons4 +, cons5 +, cons6 +, (\/) +, Tier +, Listable1(..) +, tiers1 +, Listable2(..) +, tiers2 +, liftCons1 +, liftCons2 +, liftCons3 +, liftCons4 +, liftCons5 +, ListableF(..) +, addWeight +, ofWeight +) where + +import qualified Category +import Control.Monad.Free as Free +import Control.Monad.Trans.Free as FreeF +import Data.Functor.Both +import Data.Record +import Data.Text +import Data.These +import Diff +import Patch +import Renderer.TOC +import RWS +import Syntax +import Term +import Test.LeanCheck + +type Tier a = [a] + +-- | Lifting of 'Listable' to @* -> *@. +class Listable1 l where + -- | The tiers for @l :: * -> *@, parameterized by the tiers for @a :: *@. + liftTiers :: [Tier a] -> [Tier (l a)] + +-- | A suitable definition of 'tiers' for 'Listable1' type constructors parameterized by 'Listable' types. +tiers1 :: (Listable a, Listable1 l) => [Tier (l a)] +tiers1 = liftTiers tiers + + +-- | Lifting of 'Listable' to @* -> * -> *@. +class Listable2 l where + -- | The tiers for @l :: * -> * -> *@, parameterized by the tiers for @a :: *@ & @b :: *@. + liftTiers2 :: [Tier a] -> [Tier b] -> [Tier (l a b)] + +-- | A suitable definition of 'tiers' for 'Listable2' type constructors parameterized by 'Listable' types. +tiers2 :: (Listable a, Listable b, Listable2 l) => [Tier (l a b)] +tiers2 = liftTiers2 tiers tiers + + +-- | Lifts a unary constructor to a list of tiers, given a list of tiers for its argument. +-- +-- Commonly used in the definition of 'Listable1' and 'Listable2' instances. +liftCons1 :: [Tier a] -> (a -> b) -> [Tier b] +liftCons1 tiers f = mapT f tiers `addWeight` 1 + +-- | Lifts a binary constructor to a list of tiers, given lists of tiers for its arguments. +-- +-- Commonly used in the definition of 'Listable1' and 'Listable2' instances. +liftCons2 :: [Tier a] -> [Tier b] -> (a -> b -> c) -> [Tier c] +liftCons2 tiers1 tiers2 f = mapT (uncurry f) (liftTiers2 tiers1 tiers2) `addWeight` 1 + +-- | Lifts a ternary constructor to a list of tiers, given lists of tiers for its arguments. +-- +-- Commonly used in the definition of 'Listable1' and 'Listable2' instances. +liftCons3 :: [Tier a] -> [Tier b] -> [Tier c] -> (a -> b -> c -> d) -> [Tier d] +liftCons3 tiers1 tiers2 tiers3 f = mapT (uncurry3 f) (tiers1 >< tiers2 >< tiers3) `addWeight` 1 + where uncurry3 f (a, (b, c)) = f a b c + +-- | Lifts a quaternary constructor to a list of tiers, given lists of tiers for its arguments. +-- +-- Commonly used in the definition of 'Listable1' and 'Listable2' instances. +liftCons4 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> (a -> b -> c -> d -> e) -> [Tier e] +liftCons4 tiers1 tiers2 tiers3 tiers4 f = mapT (uncurry4 f) (tiers1 >< tiers2 >< tiers3 >< tiers4) `addWeight` 1 + where uncurry4 f (a, (b, (c, d))) = f a b c d + +-- | Lifts a quinary constructor to a list of tiers, given lists of tiers for its arguments. +-- +-- Commonly used in the definition of 'Listable1' and 'Listable2' instances. +liftCons5 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> [Tier e] -> (a -> b -> c -> d -> e -> f) -> [Tier f] +liftCons5 tiers1 tiers2 tiers3 tiers4 tiers5 f = mapT (uncurry5 f) (tiers1 >< tiers2 >< tiers3 >< tiers4 >< tiers5) `addWeight` 1 + where uncurry5 f (a, (b, (c, (d, e)))) = f a b c d e + +-- | Convenient wrapper for 'Listable1' type constructors and 'Listable' types, where a 'Listable' instance would necessarily be orphaned. +newtype ListableF f a = ListableF { unListableF :: f a } + deriving Show + + +-- Instances + +instance Listable1 Maybe where + liftTiers tiers = cons0 Nothing \/ liftCons1 tiers Just + +instance Listable2 (,) where + liftTiers2 = (><) + +instance Listable2 Either where + liftTiers2 leftTiers rightTiers = liftCons1 leftTiers Left \/ liftCons1 rightTiers Right + +instance Listable a => Listable1 ((,) a) where + liftTiers = liftTiers2 tiers + +instance Listable1 [] where + liftTiers tiers = go + where go = cons0 [] \/ liftCons2 tiers go (:) + +instance Listable2 p => Listable1 (Join p) where + liftTiers tiers = liftCons1 (liftTiers2 tiers tiers) Join + +instance Listable2 These where + liftTiers2 this that = liftCons1 this This \/ liftCons1 that That \/ liftCons2 this that These + +instance Listable1 f => Listable2 (FreeF f) where + liftTiers2 pureTiers recurTiers = liftCons1 pureTiers FreeF.Pure \/ liftCons1 (liftTiers recurTiers) FreeF.Free + +instance (Listable1 f, Listable a) => Listable1 (FreeF f a) where + liftTiers = liftTiers2 tiers + +instance (Functor f, Listable1 f) => Listable1 (Free.Free f) where + liftTiers pureTiers = go + where go = liftCons1 (liftTiers2 pureTiers go) free + free (FreeF.Free f) = Free.Free f + free (FreeF.Pure a) = Free.Pure a + +instance (Listable1 f, Listable a) => Listable (ListableF f a) where + tiers = ListableF `mapT` tiers1 + + +instance Listable1 f => Listable2 (TermF f) where + liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<) + +instance (Listable1 f, Listable a) => Listable1 (TermF f a) where + liftTiers = liftTiers2 tiers + +instance (Listable1 f, Listable a, Listable b) => Listable (TermF f a b) where + tiers = tiers1 + +instance Listable1 f => Listable1 (Term f) where + liftTiers annotationTiers = go + where go = liftCons1 (liftTiers2 annotationTiers go) Term + +instance (Listable1 f, Listable a) => Listable (Term f a) where + tiers = tiers1 + + +instance Listable1 f => Listable2 (DiffF f) where + liftTiers2 annTiers recurTiers = liftCons2 (liftCons2 annTiers annTiers both) (liftTiers recurTiers) Copy \/ liftCons1 (liftTiers (liftTiers annTiers)) Patch + +instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where + liftTiers = liftTiers2 tiers + +instance (Listable1 f, Listable a, Listable b) => Listable (DiffF f a b) where + tiers = tiers1 + +instance Listable1 f => Listable1 (Diff f) where + liftTiers annTiers = go where go = liftCons1 (liftTiers2 annTiers go) Diff + +instance (Listable1 f, Listable a) => Listable (Diff f a) where + tiers = tiers1 + + +instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where + tiers = cons2 (:.) + +instance Listable (Record '[]) where + tiers = cons0 Nil + + +instance Listable Category.Category where + tiers = cons0 Category.Program + \/ cons0 Category.ParseError + \/ cons0 Category.Boolean + \/ cons0 Category.BooleanOperator + \/ cons0 Category.FunctionCall + \/ cons0 Category.Function + \/ cons0 Category.Identifier + \/ cons0 Category.MethodCall + \/ cons0 Category.StringLiteral + \/ cons0 Category.IntegerLiteral + \/ cons0 Category.NumberLiteral + \/ cons0 Category.Return + \/ cons0 Category.If + \/ cons0 Category.Class + \/ cons0 Category.Method + \/ cons0 Category.Binary + \/ cons0 Category.Unary + \/ cons0 Category.SingletonMethod + + +instance Listable1 Patch where + liftTiers t = liftCons1 t Insert \/ liftCons1 t Delete \/ liftCons2 t t Replace + +instance Listable a => Listable (Patch a) where + tiers = tiers1 + + +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 + \/ liftCons2 recur (liftTiers recur) Ternary + \/ liftCons2 (liftTiers recur) (liftTiers recur) AnonymousFunction + \/ liftCons3 recur (liftTiers recur) (liftTiers recur) Function + \/ liftCons2 recur recur Assignment + \/ liftCons2 recur recur OperatorAssignment + \/ liftCons2 recur recur MemberAccess + \/ liftCons4 recur recur (liftTiers recur) (liftTiers recur) MethodCall + \/ liftCons1 (liftTiers recur) Operator + \/ liftCons1 (liftTiers recur) VarDecl + \/ liftCons2 (liftTiers recur) recur VarAssignment + \/ liftCons2 recur recur SubscriptAccess + \/ liftCons2 (liftTiers recur) (liftTiers recur) Switch + \/ liftCons2 recur (liftTiers recur) Case + \/ liftCons1 (liftTiers recur) Select + \/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Object + \/ liftCons2 recur recur Pair + \/ liftCons1 (pack `mapT` tiers) Comment + \/ liftCons2 (liftTiers recur) (liftTiers recur) Commented + \/ liftCons1 (liftTiers recur) Syntax.ParseError + \/ liftCons2 (liftTiers recur) (liftTiers recur) For + \/ liftCons2 recur recur DoWhile + \/ liftCons2 recur (liftTiers recur) While + \/ liftCons1 (liftTiers recur) Return + \/ liftCons1 recur Throw + \/ liftCons1 recur Constructor + \/ liftCons4 (liftTiers recur) (liftTiers recur) (liftTiers recur) (liftTiers recur) Try + \/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Array + \/ liftCons3 recur (liftTiers recur) (liftTiers recur) Class + \/ liftCons5 (liftTiers recur) recur (liftTiers recur) (liftTiers recur) (liftTiers recur) Method + \/ liftCons2 recur (liftTiers recur) If + \/ liftCons2 recur (liftTiers recur) Module + \/ liftCons2 recur (liftTiers recur) Namespace + \/ liftCons2 recur (liftTiers recur) Import + \/ liftCons2 (liftTiers recur) (liftTiers recur) Export + \/ liftCons1 (liftTiers recur) Yield + \/ liftCons1 recur Negate + \/ liftCons2 (liftTiers recur) (liftTiers recur) Rescue + \/ liftCons1 recur Go + \/ liftCons1 recur Defer + \/ liftCons2 recur recur TypeAssertion + \/ liftCons2 recur recur TypeConversion + \/ liftCons1 (liftTiers recur) Break + \/ liftCons1 (liftTiers recur) Continue + \/ liftCons1 (liftTiers recur) BlockStatement + \/ liftCons2 (liftTiers recur) recur ParameterDecl + \/ liftCons2 recur recur TypeDecl + \/ liftCons1 (liftTiers recur) FieldDecl + \/ liftCons1 (liftTiers recur) Ty + \/ liftCons2 recur recur Send + \/ liftCons1 (liftTiers recur) DefaultCase + +instance Listable recur => Listable (Syntax recur) where + tiers = tiers1 + + +instance Listable1 Gram where + liftTiers tiers = liftCons2 (liftTiers (liftTiers tiers)) (liftTiers (liftTiers tiers)) Gram + +instance Listable a => Listable (Gram a) where + tiers = tiers1 + + +instance Listable Text where + tiers = pack `mapT` tiers + +instance Listable Declaration where + tiers + = cons1 (MethodDeclaration) + \/ cons1 (FunctionDeclaration) + \/ cons1 (flip ErrorDeclaration Nothing) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index c13ff9f8b..16dec7c86 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -16,7 +16,6 @@ import Data.Record import Data.Semigroup ((<>)) import Data.Source import Data.Text (Text) -import Data.Text.Listable import Data.These import Diff import Info @@ -239,6 +238,3 @@ blankDiff = copy (pure arrayInfo) (Indexed [ inserting (Term $ literalInfo :< Le blankDiffBlobs :: Both Blob blankDiffBlobs = both (Blob (fromText "[]") nullOid "a.js" (Just defaultPlainBlob) (Just TypeScript)) (Blob (fromText "[a]") nullOid "b.js" (Just defaultPlainBlob) (Just TypeScript)) - -instance Listable Text where - tiers = unListableText `mapT` tiers From 24914eeb053701211072d7bfb1474f87cc175dc2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:51:37 +0100 Subject: [PATCH 074/113] Move the remaining Listable instances into the tests. --- semantic-diff.cabal | 1 - src/Data/Range.hs | 4 ---- src/Data/Source.hs | 18 +----------------- src/Data/Span.hs | 7 ------- test/Data/Functor/Listable.hs | 32 +++++++++++++++++++++++++++++++- test/SourceSpec.hs | 3 ++- 6 files changed, 34 insertions(+), 31 deletions(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index bfb21be59..222db9103 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -98,7 +98,6 @@ library , gitrev , hashable , kdt - , leancheck , mersenne-random-pure64 , MonadRandom , mtl diff --git a/src/Data/Range.hs b/src/Data/Range.hs index 850e09e58..bc8d4c421 100644 --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -9,7 +9,6 @@ module Data.Range import Data.Semigroup import Data.Text.Prettyprint.Doc import GHC.Generics -import Test.LeanCheck -- | A half-open interval of integers, defined by start & end indices. data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int } @@ -36,8 +35,5 @@ instance Semigroup Range where instance Ord Range where a <= b = start a <= start b -instance Listable Range where - tiers = cons2 Range - instance Pretty Range where pretty (Range from to) = pretty from <> pretty '-' <> pretty to diff --git a/src/Data/Source.hs b/src/Data/Source.hs index 43da689c3..310d26e7b 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -23,14 +23,12 @@ module Data.Source , spanToRangeInLineRanges , sourceLineRangesByLineNumber , rangeToSpan --- Listable -, ListableByteString(..) ) where import Control.Arrow ((&&&)) import Data.Array import qualified Data.ByteString as B -import Data.Char (chr, ord) +import Data.Char (ord) import Data.List (span) import Data.Monoid (First(..), Last(..)) import Data.Range @@ -39,7 +37,6 @@ import Data.Span import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Test.LeanCheck -- | The contents of a source file, represented as a 'ByteString'. newtype Source = Source { sourceBytes :: B.ByteString } @@ -144,16 +141,3 @@ instance Semigroup Source where instance Monoid Source where mempty = Source B.empty mappend = (<>) - -instance Listable Source where - tiers = (Source . unListableByteString) `mapT` tiers - -newtype ListableByteString = ListableByteString { unListableByteString :: B.ByteString } - -instance Listable ListableByteString where - tiers = (ListableByteString . T.encodeUtf8 . T.pack) `mapT` strings - where strings = foldr ((\\//) . listsOf . toTiers) [] - [ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] - , [' '..'/'] <> [':'..'@'] <> ['['..'`'] <> ['{'..'~'] - , [chr 0x00..chr 0x1f] <> [chr 127] -- Control characters. - , [chr 0xa0..chr 0x24f] ] -- Non-ASCII. diff --git a/src/Data/Span.hs b/src/Data/Span.hs index 0bc617776..298809e0f 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -15,7 +15,6 @@ import Data.Hashable (Hashable) import Data.Semigroup import Data.Text.Prettyprint.Doc import GHC.Generics -import Test.LeanCheck -- | Source position information data Pos = Pos @@ -57,12 +56,6 @@ instance A.FromJSON Span where o .: "start" <*> o .: "end" -instance Listable Pos where - tiers = cons2 Pos - -instance Listable Span where - tiers = cons2 Span - instance Pretty Pos where pretty Pos{..} = pretty posLine <> colon <> pretty posColumn diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 0525c6551..85d4ad62d 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -29,9 +29,16 @@ module Data.Functor.Listable import qualified Category import Control.Monad.Free as Free import Control.Monad.Trans.Free as FreeF +import Data.ByteString (ByteString) +import Data.Char (chr, ord) import Data.Functor.Both +import Data.Range import Data.Record -import Data.Text +import Data.Semigroup +import Data.Source +import Data.Span +import Data.Text as T (Text, pack) +import qualified Data.Text.Encoding as T import Data.These import Diff import Patch @@ -285,3 +292,26 @@ instance Listable Declaration where = cons1 (MethodDeclaration) \/ cons1 (FunctionDeclaration) \/ cons1 (flip ErrorDeclaration Nothing) + + +instance Listable Range where + tiers = cons2 Range + + +instance Listable Pos where + tiers = cons2 Pos + +instance Listable Span where + tiers = cons2 Span + + +instance Listable Source where + tiers = fromBytes `mapT` tiers + +instance Listable ByteString where + tiers = (T.encodeUtf8 . T.pack) `mapT` strings + where strings = foldr ((\\//) . listsOf . toTiers) [] + [ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] + , [' '..'/'] <> [':'..'@'] <> ['['..'`'] <> ['{'..'~'] + , [chr 0x00..chr 0x1f] <> [chr 127] -- Control characters. + , [chr 0xa0..chr 0x24f] ] -- Non-ASCII. diff --git a/test/SourceSpec.hs b/test/SourceSpec.hs index 5e4011bd6..2ccab8dca 100644 --- a/test/SourceSpec.hs +++ b/test/SourceSpec.hs @@ -1,6 +1,7 @@ module SourceSpec where import Data.Char (chr) +import Data.Functor.Listable import Data.Range import Data.Semigroup import Data.Source @@ -20,7 +21,7 @@ spec = parallel $ do \ source -> foldMap (`slice` source) (sourceLineRanges source) `shouldBe` source describe "spanToRange" $ do - prop "computes single-line ranges" . forAll (unListableByteString `mapT` tiers) $ + prop "computes single-line ranges" $ \ s -> let source = fromBytes s spans = zipWith (\ i Range {..} -> Span (Pos i 1) (Pos i (succ (end - start)))) [1..] ranges ranges = sourceLineRanges source in From 10b262e0699b6171c63bc85cf25f2fc4eb70748d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:54:49 +0100 Subject: [PATCH 075/113] :fire: a stray import. --- test/Data/Functor/Listable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 85d4ad62d..c58d045ff 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -30,7 +30,7 @@ import qualified Category import Control.Monad.Free as Free import Control.Monad.Trans.Free as FreeF import Data.ByteString (ByteString) -import Data.Char (chr, ord) +import Data.Char (chr) import Data.Functor.Both import Data.Range import Data.Record From 2a7a937a7e7ecbc1af81fb7f0178692ab689e98e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:58:07 +0100 Subject: [PATCH 076/113] :fire: a bunch more redundant imports. --- test/AlignmentSpec.hs | 4 +--- test/Data/RandomWalkSimilarity/Spec.hs | 3 +-- test/InterpreterSpec.hs | 2 -- test/SpecHelpers.hs | 6 ------ 4 files changed, 2 insertions(+), 13 deletions(-) diff --git a/test/AlignmentSpec.hs b/test/AlignmentSpec.hs index 9b0e4fd54..1ef88ce43 100644 --- a/test/AlignmentSpec.hs +++ b/test/AlignmentSpec.hs @@ -3,12 +3,11 @@ module AlignmentSpec where import Alignment import Control.Arrow ((&&&)) -import Control.Monad.Free (Free, wrap) +import Control.Monad.Free (wrap) import Control.Monad.State import Data.Align hiding (align) import Data.Bifunctor import Data.Bifunctor.Join -import Data.Foldable (toList) import Data.Functor.Both as Both hiding (fst, snd) import Data.Functor.Listable import Data.List (nub, sort) @@ -21,7 +20,6 @@ import qualified Data.Source as Source import qualified Data.Text as Text import Data.These import Diff -import Patch import SplitDiff import Syntax import Term diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index 5181d0f03..897a67224 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -4,12 +4,11 @@ module Data.RandomWalkSimilarity.Spec where import Category import Data.Array.IArray import Data.Bifunctor -import Data.Functor.Listable +import Data.Functor.Listable () import Data.Record import Data.These import Diff import Info -import Patch import RWS import Syntax import Term diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index b24785fc7..6e0af9c2e 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -2,14 +2,12 @@ module InterpreterSpec where import Category -import Control.Monad.Free (wrap) import Data.Functor.Both import Data.Functor.Foldable hiding (Nil) import Data.Functor.Listable import Data.Record import Diff import Interpreter -import Patch import Syntax import Term import Test.Hspec (Spec, describe, it, parallel) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index c78e9c7f7..c6708576b 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -7,23 +7,17 @@ module SpecHelpers ) where import Control.Exception -import Control.Monad.Free (Free, hoistFree) -import Data.Bifunctor (first) import Data.Blob import qualified Data.ByteString as B import Data.Functor.Both -import Data.Functor.Listable import Data.Maybe (fromMaybe) import Data.Source -import Diff import Language -import Patch import Prelude hiding (readFile) import Renderer import Semantic import Semantic.Task import System.FilePath -import Term -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO B.ByteString From 9c97ea7c486dfbf5ccdfae7c2c088cecdffd97ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:59:03 +0100 Subject: [PATCH 077/113] More :fire: --- test/DiffSpec.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index 4361ac492..3bf1fbae7 100644 --- a/test/DiffSpec.hs +++ b/test/DiffSpec.hs @@ -3,12 +3,11 @@ module DiffSpec where import Category import Data.Functor.Both -import Data.Functor.Listable +import Data.Functor.Listable () import RWS import Diff import Info import Interpreter -import SpecHelpers import Term import Test.Hspec import Test.Hspec.LeanCheck From 825990cfce0cc07405232f1e4794eb3743e3fa6f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 14:59:33 +0100 Subject: [PATCH 078/113] Constrain a type to Int. --- test/TOCSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 16dec7c86..8c51d97cf 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -55,7 +55,7 @@ spec = parallel $ do prop "produces changed entries for relevant nodes containing irrelevant patches" $ \ diff -> let diff' = copy (pure 0) (Indexed [1 <$ (diff :: Diff Syntax Int)]) in - tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe` + tableOfContentsBy (\ (n :< _) -> if n == (0 :: Int) then Just n else Nothing) diff' `shouldBe` if null (diffPatches diff') then [Unchanged 0] else replicate (length (diffPatches diff')) (Changed 0) From c69e3383e3082d4194522e4e69a6b26855843a11 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:15:22 +0100 Subject: [PATCH 079/113] Define a module for JSONFields. --- semantic-diff.cabal | 1 + src/Data/JSON/Fields.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/JSON/Fields.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 222db9103..ad21174ac 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -23,6 +23,7 @@ library , Data.Functor.Classes.Eq.Generic , Data.Functor.Classes.Pretty.Generic , Data.Functor.Classes.Show.Generic + , Data.JSON.Fields , Data.Mergeable , Data.Mergeable.Generic , Data.Output diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs new file mode 100644 index 000000000..1748f5a35 --- /dev/null +++ b/src/Data/JSON/Fields.hs @@ -0,0 +1 @@ +module Data.JSON.Fields where From 3e12a9135930f669caf4c98d7c9e04196865a900 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:16:00 +0100 Subject: [PATCH 080/113] Move ToJSONFields into its own module. --- src/Data/JSON/Fields.hs | 5 +++++ src/Renderer/JSON.hs | 4 +--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index 1748f5a35..5edbd1c21 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -1 +1,6 @@ module Data.JSON.Fields where + +import Data.Aeson + +class ToJSONFields a where + toJSONFields :: KeyValue kv => a -> [kv] diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 88d50de76..a950af3e4 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -13,6 +13,7 @@ import Data.Blob import Data.ByteString.Lazy (toStrict) import Data.Foldable (toList) import Data.Functor.Both (Both) +import Data.JSON.Fields import qualified Data.Map as Map import Data.Output import Data.Proxy @@ -59,9 +60,6 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) wher toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields -class ToJSONFields a where - toJSONFields :: KeyValue kv => a -> [kv] - instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where toJSONFields (h :. t) = toJSONFields h <> toJSONFields t From 7a88cad0941b0173bc23ff6938efe4af97931262 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:18:10 +0100 Subject: [PATCH 081/113] Move the ToJSONFields instance for Both into the Data.JSON.Fields module. --- src/Data/JSON/Fields.hs | 5 +++++ src/Renderer/JSON.hs | 3 --- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index 5edbd1c21..56d88c3a2 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -1,6 +1,11 @@ module Data.JSON.Fields where import Data.Aeson +import Data.Bifunctor.Join class ToJSONFields a where toJSONFields :: KeyValue kv => a -> [kv] + + +instance ToJSONFields a => ToJSONFields (Join (,) a) where + toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ] diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index a950af3e4..49155f895 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -45,9 +45,6 @@ renderJSONDiff blobs diff = Map.fromList instance Output (Map.Map Text Value) where toOutput = toStrict . (<> "\n") . encode -instance ToJSONFields a => ToJSONFields (Join (,) a) where - toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ] - instance ToJSON a => ToJSON (Join (,) a) where toJSON = toJSON . toList toEncoding = foldable From 62603c803c5c1aa369d7ae023303dba4a4ea8c0d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:18:24 +0100 Subject: [PATCH 082/113] Move the ToJSONFields/ToJSON instances for Records into Data.Record. --- src/Data/Record.hs | 14 ++++++++++++++ src/Renderer/JSON.hs | 11 ----------- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Data/Record.hs b/src/Data/Record.hs index ac5431973..6431a869d 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} module Data.Record where +import Data.Aeson +import Data.JSON.Fields import Data.Kind import Data.Semigroup import Data.Text.Prettyprint.Doc @@ -81,3 +83,15 @@ instance ConstrainAll Pretty ts => Pretty (Record ts) where where collectPretty :: ConstrainAll Pretty ts => Record ts -> [Doc ann] collectPretty Nil = [] collectPretty (first :. rest) = pretty first : collectPretty rest + + +instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where + toJSONFields (h :. t) = toJSONFields h <> toJSONFields t + +instance ToJSONFields (Record '[]) where + toJSONFields _ = [] + + +instance ToJSONFields (Record fs) => ToJSON (Record fs) where + toJSON = object . toJSONFields + toEncoding = pairs . mconcat . toJSONFields diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 49155f895..31edd0a6e 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -17,7 +17,6 @@ import Data.JSON.Fields import qualified Data.Map as Map import Data.Output import Data.Proxy -import Data.Record import Data.Semigroup ((<>)) import Data.Text (pack, Text) import Data.Text.Encoding (decodeUtf8) @@ -57,16 +56,6 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) wher toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields -instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where - toJSONFields (h :. t) = toJSONFields h <> toJSONFields t - -instance ToJSONFields (Record '[]) where - toJSONFields _ = [] - -instance ToJSONFields (Record fs) => ToJSON (Record fs) where - toJSON = object . toJSONFields - toEncoding = pairs . mconcat . toJSONFields - instance ToJSONFields Range where toJSONFields Range{..} = ["sourceRange" .= [ start, end ]] From 42c1795c0af70ba3b1837a23a87ed667ef94a5c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:19:46 +0100 Subject: [PATCH 083/113] Move the ToJSONFields instance for Range into Data.Range. --- src/Data/Range.hs | 6 ++++++ src/Renderer/JSON.hs | 3 --- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Data/Range.hs b/src/Data/Range.hs index bc8d4c421..6aa222d5b 100644 --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -6,6 +6,8 @@ module Data.Range , intersectsRange ) where +import Data.Aeson +import Data.JSON.Fields import Data.Semigroup import Data.Text.Prettyprint.Doc import GHC.Generics @@ -37,3 +39,7 @@ instance Ord Range where instance Pretty Range where pretty (Range from to) = pretty from <> pretty '-' <> pretty to + + +instance ToJSONFields Range where + toJSONFields Range{..} = ["sourceRange" .= [ start, end ]] diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 31edd0a6e..5b6bcaf52 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -56,9 +56,6 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) wher toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields -instance ToJSONFields Range where - toJSONFields Range{..} = ["sourceRange" .= [ start, end ]] - instance ToJSONFields Category where toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }] From d7a5ea152d2f59c2ec647bcb09237546e87f4803 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:20:43 +0100 Subject: [PATCH 084/113] Move the ToJSONFields instance for Span into Data.Span. --- src/Data/Span.hs | 5 +++++ src/Renderer/JSON.hs | 3 --- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/Span.hs b/src/Data/Span.hs index 298809e0f..77c36acca 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -11,6 +11,7 @@ module Data.Span import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A +import Data.JSON.Fields import Data.Hashable (Hashable) import Data.Semigroup import Data.Text.Prettyprint.Doc @@ -61,3 +62,7 @@ instance Pretty Pos where instance Pretty Span where pretty Span{..} = pretty spanStart <> pretty '-' <> pretty spanEnd + + +instance ToJSONFields Span where + toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ] diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 5b6bcaf52..b69606882 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -59,9 +59,6 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) wher instance ToJSONFields Category where toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }] -instance ToJSONFields Span where - toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ] - instance ToJSONFields a => ToJSONFields (Maybe a) where toJSONFields = maybe [] toJSONFields From c1b521ab9b5a55c209748b056dbb7d1bf837d1b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:23:14 +0100 Subject: [PATCH 085/113] Move the ToJSONFields instance for Maybe into Data.JSON.Fields. --- src/Data/JSON/Fields.hs | 3 +++ src/Renderer/JSON.hs | 3 --- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index 56d88c3a2..3b8402eb2 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -9,3 +9,6 @@ class ToJSONFields a where instance ToJSONFields a => ToJSONFields (Join (,) a) where toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ] + +instance ToJSONFields a => ToJSONFields (Maybe a) where + toJSONFields = maybe [] toJSONFields diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index b69606882..6c5112517 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -59,9 +59,6 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) wher instance ToJSONFields Category where toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }] -instance ToJSONFields a => ToJSONFields (Maybe a) where - toJSONFields = maybe [] toJSONFields - instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where toJSONFields = toJSONFields . unTerm From 7bb92dfd98c1a737ec68cb1f12bd0c1b2507dfb4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:23:28 +0100 Subject: [PATCH 086/113] Move the ToJSONFields instance for [] into Data.JSON.Fields. --- src/Data/JSON/Fields.hs | 3 +++ src/Renderer/JSON.hs | 3 --- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index 3b8402eb2..69e3aea23 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -12,3 +12,6 @@ instance ToJSONFields a => ToJSONFields (Join (,) a) where instance ToJSONFields a => ToJSONFields (Maybe a) where toJSONFields = maybe [] toJSONFields + +instance ToJSON a => ToJSONFields [a] where + toJSONFields list = [ "children" .= list ] diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 6c5112517..657a87c5d 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -77,9 +77,6 @@ instance ToJSONFields a => ToJSONFields (Patch a) where toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ] toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ] -instance ToJSON a => ToJSONFields [a] where - toJSONFields list = [ "children" .= list ] - instance ToJSON recur => ToJSONFields (Syntax recur) where toJSONFields syntax = [ "children" .= toList syntax ] From 5b62e4bf5c787e8321a2ca7cc356a772fba78963 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:23:49 +0100 Subject: [PATCH 087/113] Move the ToJSONFields instance for populated Unions into Data.JSON.Fields. --- src/Data/JSON/Fields.hs | 7 +++++++ src/Renderer/JSON.hs | 4 ---- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index 69e3aea23..e4825092e 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE MultiParamTypeClasses #-} module Data.JSON.Fields where import Data.Aeson import Data.Bifunctor.Join +import Data.Foldable (toList) +import Data.Proxy (Proxy(..)) +import Data.Union class ToJSONFields a where toJSONFields :: KeyValue kv => a -> [kv] @@ -15,3 +19,6 @@ instance ToJSONFields a => ToJSONFields (Maybe a) where instance ToJSON a => ToJSONFields [a] where toJSONFields list = [ "children" .= list ] + +instance (Apply1 Foldable fs, ToJSON a) => ToJSONFields (Union fs a) where + toJSONFields = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ]) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 657a87c5d..05b6d1b60 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -16,7 +16,6 @@ import Data.Functor.Both (Both) import Data.JSON.Fields import qualified Data.Map as Map import Data.Output -import Data.Proxy import Data.Semigroup ((<>)) import Data.Text (pack, Text) import Data.Text.Encoding (decodeUtf8) @@ -80,9 +79,6 @@ instance ToJSONFields a => ToJSONFields (Patch a) where instance ToJSON recur => ToJSONFields (Syntax recur) where toJSONFields syntax = [ "children" .= toList syntax ] -instance (Apply1 Foldable fs, ToJSON a) => ToJSONFields (Union fs a) where - toJSONFields = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ]) - instance ToJSONFields (Union '[] a) where toJSONFields _ = [] From 41ecede0237ede8694d2d9a68d883228a64876e5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:23:58 +0100 Subject: [PATCH 088/113] :fire: the ToJSONFields instance for unpopulated Unions. --- src/Renderer/JSON.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 05b6d1b60..0d8ac34ef 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -19,7 +19,6 @@ import Data.Output import Data.Semigroup ((<>)) import Data.Text (pack, Text) import Data.Text.Encoding (decodeUtf8) -import Data.Union import Diff import GHC.Generics import Info @@ -79,9 +78,6 @@ instance ToJSONFields a => ToJSONFields (Patch a) where instance ToJSON recur => ToJSONFields (Syntax recur) where toJSONFields syntax = [ "children" .= toList syntax ] -instance ToJSONFields (Union '[] a) where - toJSONFields _ = [] - data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } deriving (Generic, Show) From 4e3c34d8f742ce0dfe4ce18819a20995a0e849d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:24:56 +0100 Subject: [PATCH 089/113] Move the ToJSONFields instance for Patch into Patch. --- src/Patch.hs | 8 ++++++++ src/Renderer/JSON.hs | 6 ------ 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Patch.hs b/src/Patch.hs index 30b6f20f9..c6e7aa627 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -11,10 +11,12 @@ module Patch , mapPatch ) where +import Data.Aeson import Data.Align import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic +import Data.JSON.Fields import Data.These import GHC.Generics @@ -71,3 +73,9 @@ instance Pretty1 Patch where liftPretty = genericLiftPretty instance Pretty a => Pretty (Patch a) where pretty = liftPretty pretty prettyList + + +instance ToJSONFields a => ToJSONFields (Patch a) where + toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ] + toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ] + toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ] diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 0d8ac34ef..6f1f428ee 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -23,7 +23,6 @@ import Diff import GHC.Generics import Info import Language -import Patch import Syntax as S import Term @@ -70,11 +69,6 @@ instance (ToJSONFields a, ToJSONFields (f b), ToJSONFields (f (Term f a))) => To toJSONFields (Copy a f) = toJSONFields a <> toJSONFields f toJSONFields (Patch a) = toJSONFields a -instance ToJSONFields a => ToJSONFields (Patch a) where - toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ] - toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ] - toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ] - instance ToJSON recur => ToJSONFields (Syntax recur) where toJSONFields syntax = [ "children" .= toList syntax ] From 0845687d51cb52f29c3c1139c9d3aab708bf4f55 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:25:55 +0100 Subject: [PATCH 090/113] Move the ToJSONFields instance for Syntax into Syntax. --- src/Renderer/JSON.hs | 4 ---- src/Syntax.hs | 5 +++++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 6f1f428ee..989c4c7b8 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -23,7 +23,6 @@ import Diff import GHC.Generics import Info import Language -import Syntax as S import Term -- @@ -69,9 +68,6 @@ instance (ToJSONFields a, ToJSONFields (f b), ToJSONFields (f (Term f a))) => To toJSONFields (Copy a f) = toJSONFields a <> toJSONFields f toJSONFields (Patch a) = toJSONFields a -instance ToJSON recur => ToJSONFields (Syntax recur) where - toJSONFields syntax = [ "children" .= toList syntax ] - data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } deriving (Generic, Show) diff --git a/src/Syntax.hs b/src/Syntax.hs index f501d71f4..d71c088bb 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -3,10 +3,12 @@ module Syntax where import Data.Aeson import Data.Align.Generic +import Data.Foldable (toList) import Data.Functor.Classes import Data.Functor.Classes.Eq.Generic import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic +import Data.JSON.Fields import Data.Mergeable import Data.Text (Text) import GHC.Generics @@ -123,3 +125,6 @@ extractLeafValue syntax = case syntax of instance Eq1 Syntax where liftEq = genericLiftEq instance Show1 Syntax where liftShowsPrec = genericLiftShowsPrec instance Pretty1 Syntax where liftPretty = genericLiftPretty + +instance ToJSON recur => ToJSONFields (Syntax recur) where + toJSONFields syntax = [ "children" .= toList syntax ] From aa78f3eaeb20d6ae0d69b0a38db89ba2afa5d88f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:30:34 +0100 Subject: [PATCH 091/113] Move the ToJSONFields instance for Category into Category. --- src/Category.hs | 7 ++++++- src/Renderer/JSON.hs | 6 +----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Category.hs b/src/Category.hs index 3030d2e0a..40b254c96 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -3,8 +3,10 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Category where +import Data.Aeson import Data.Hashable -import Data.Text (Text) +import Data.JSON.Fields +import Data.Text (Text, pack) import Data.Text.Prettyprint.Doc import GHC.Generics @@ -247,3 +249,6 @@ instance Hashable Category instance Pretty Category where pretty = pretty . show + +instance ToJSONFields Category where + toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }] diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 989c4c7b8..62d60cf09 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -17,11 +17,10 @@ import Data.JSON.Fields import qualified Data.Map as Map import Data.Output import Data.Semigroup ((<>)) -import Data.Text (pack, Text) +import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) import Diff import GHC.Generics -import Info import Language import Term @@ -52,9 +51,6 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) wher toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields -instance ToJSONFields Category where - toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }] - instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where toJSONFields = toJSONFields . unTerm From 3231d85347d9a752ea51d1ea066ede8897b832a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:31:45 +0100 Subject: [PATCH 092/113] Define a lifting of ToJSONFields to * -> *. --- src/Data/JSON/Fields.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index e4825092e..2cb2bdc6d 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -10,6 +10,9 @@ import Data.Union class ToJSONFields a where toJSONFields :: KeyValue kv => a -> [kv] +class ToJSONFields1 f where + toJSONFields1 :: (KeyValue kv, ToJSON a) => f a -> [kv] + instance ToJSONFields a => ToJSONFields (Join (,) a) where toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ] From 8ce60eecb89c6e65cf8529d094bb68d89b591aa1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:35:45 +0100 Subject: [PATCH 093/113] Lift the Term/Diff ToJSONFields instances to * -> *. --- src/Data/JSON/Fields.hs | 4 ++-- src/Renderer/JSON.hs | 28 ++++++++++++++-------------- src/Syntax.hs | 4 ++-- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index 2cb2bdc6d..093cf7749 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -23,5 +23,5 @@ instance ToJSONFields a => ToJSONFields (Maybe a) where instance ToJSON a => ToJSONFields [a] where toJSONFields list = [ "children" .= list ] -instance (Apply1 Foldable fs, ToJSON a) => ToJSONFields (Union fs a) where - toJSONFields = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ]) +instance (Apply1 Foldable fs) => ToJSONFields1 (Union fs) where + toJSONFields1 = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ]) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 62d60cf09..0ad9c8235 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -43,27 +43,27 @@ instance ToJSON a => ToJSON (Join (,) a) where toJSON = toJSON . toList toEncoding = foldable -instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSON (Diff f a) where +instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Diff f a) where toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields -instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) where - toJSON = object . toJSONFields - toEncoding = pairs . mconcat . toJSONFields - -instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where - toJSONFields = toJSONFields . unTerm - -instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where - toJSONFields (a :< f) = toJSONFields a <> toJSONFields f - -instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSONFields (Diff f a) where +instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where toJSONFields = toJSONFields . unDiff -instance (ToJSONFields a, ToJSONFields (f b), ToJSONFields (f (Term f a))) => ToJSONFields (DiffF f a b) where - toJSONFields (Copy a f) = toJSONFields a <> toJSONFields f +instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a b) where + toJSONFields (Copy a f) = toJSONFields a <> toJSONFields1 f toJSONFields (Patch a) = toJSONFields a +instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Term f a) where + toJSON = object . toJSONFields + toEncoding = pairs . mconcat . toJSONFields + +instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Term f a) where + toJSONFields = toJSONFields . unTerm + +instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (TermF f a b) where + toJSONFields (a :< f) = toJSONFields a <> toJSONFields1 f + data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } deriving (Generic, Show) diff --git a/src/Syntax.hs b/src/Syntax.hs index d71c088bb..6f6e3cd08 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -126,5 +126,5 @@ instance Eq1 Syntax where liftEq = genericLiftEq instance Show1 Syntax where liftShowsPrec = genericLiftShowsPrec instance Pretty1 Syntax where liftPretty = genericLiftPretty -instance ToJSON recur => ToJSONFields (Syntax recur) where - toJSONFields syntax = [ "children" .= toList syntax ] +instance ToJSONFields1 Syntax where + toJSONFields1 syntax = [ "children" .= toList syntax ] From c449ad481e676747eb6478f8e114a1237e442f74 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:36:35 +0100 Subject: [PATCH 094/113] Move the ToJSON/ToJSONFields instances for Term into Term. --- src/Renderer/JSON.hs | 11 ----------- src/Term.hs | 13 +++++++++++++ 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 0ad9c8235..c4ff4da55 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -22,7 +22,6 @@ import Data.Text.Encoding (decodeUtf8) import Diff import GHC.Generics import Language -import Term -- -- Diffs @@ -54,16 +53,6 @@ instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a toJSONFields (Copy a f) = toJSONFields a <> toJSONFields1 f toJSONFields (Patch a) = toJSONFields a -instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Term f a) where - toJSON = object . toJSONFields - toEncoding = pairs . mconcat . toJSONFields - -instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Term f a) where - toJSONFields = toJSONFields . unTerm - -instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (TermF f a b) where - toJSONFields (a :< f) = toJSONFields a <> toJSONFields1 f - data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } deriving (Generic, Show) diff --git a/src/Term.hs b/src/Term.hs index 402e9af4f..c1958c271 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -14,12 +14,14 @@ module Term import Control.Comonad import Control.Comonad.Cofree.Class +import Data.Aeson import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable +import Data.JSON.Fields import Data.Proxy import Data.Record import Data.Union @@ -126,3 +128,14 @@ instance (Pretty1 f, Pretty a) => Pretty1 (TermF f a) where instance (Pretty1 f, Pretty a, Pretty b) => Pretty (TermF f a b) where pretty = liftPretty pretty prettyList + + +instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Term f a) where + toJSON = object . toJSONFields + toEncoding = pairs . mconcat . toJSONFields + +instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Term f a) where + toJSONFields = toJSONFields . unTerm + +instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (TermF f a b) where + toJSONFields (a :< f) = toJSONFields a <> toJSONFields1 f From f30a5d07544a6577f701f6e0fe7791d4055562e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:37:26 +0100 Subject: [PATCH 095/113] Move the ToJSON/ToJSONFields instances for Diff into Diff. --- src/Diff.hs | 14 ++++++++++++++ src/Renderer/JSON.hs | 11 ----------- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index 732f0ca94..045b98b8c 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-} module Diff where +import Data.Aeson import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable @@ -9,6 +10,7 @@ import Data.Functor.Both as Both import Data.Functor.Classes import Data.Functor.Classes.Pretty.Generic as Pretty import Data.Functor.Foldable hiding (fold) +import Data.JSON.Fields import Data.Mergeable import Data.Record import Data.Union @@ -161,3 +163,15 @@ instance Foldable f => Bifoldable (DiffF f) where instance Traversable f => Bitraversable (DiffF f) where bitraverse f g (Copy as r) = Copy <$> traverse f as <*> traverse g r bitraverse f _ (Patch p) = Patch <$> traverse (traverse f) p + + +instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Diff f a) where + toJSON = object . toJSONFields + toEncoding = pairs . mconcat . toJSONFields + +instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where + toJSONFields = toJSONFields . unDiff + +instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a b) where + toJSONFields (Copy a f) = toJSONFields a <> toJSONFields1 f + toJSONFields (Patch a) = toJSONFields a diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index c4ff4da55..cb4436c4e 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -42,17 +42,6 @@ instance ToJSON a => ToJSON (Join (,) a) where toJSON = toJSON . toList toEncoding = foldable -instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Diff f a) where - toJSON = object . toJSONFields - toEncoding = pairs . mconcat . toJSONFields - -instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where - toJSONFields = toJSONFields . unDiff - -instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a b) where - toJSONFields (Copy a f) = toJSONFields a <> toJSONFields1 f - toJSONFields (Patch a) = toJSONFields a - data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } deriving (Generic, Show) From c6a111b71ddf08ef1a5b4735dff258c560997164 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:39:08 +0100 Subject: [PATCH 096/113] :fire: the ToJSON instance for Both. --- src/Renderer/JSON.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index cb4436c4e..4e9a0440c 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -8,7 +8,6 @@ module Renderer.JSON import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) import Data.Aeson as A hiding (json) -import Data.Bifunctor.Join import Data.Blob import Data.ByteString.Lazy (toStrict) import Data.Foldable (toList) @@ -19,7 +18,6 @@ import Data.Output import Data.Semigroup ((<>)) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) -import Diff import GHC.Generics import Language @@ -38,10 +36,6 @@ renderJSONDiff blobs diff = Map.fromList instance Output (Map.Map Text Value) where toOutput = toStrict . (<> "\n") . encode -instance ToJSON a => ToJSON (Join (,) a) where - toJSON = toJSON . toList - toEncoding = foldable - data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } deriving (Generic, Show) From 44aab0edcf9ed678361f96e684e789f376b219de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:39:46 +0100 Subject: [PATCH 097/113] Renderer.JSON is decidable. --- src/Renderer/JSON.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 4e9a0440c..1b4aedad3 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Renderer.JSON ( renderJSONDiff From 5be89f11ee408fdc63162efa38d0a66ca47f8246 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:41:24 +0100 Subject: [PATCH 098/113] =?UTF-8?q?:fire:=20Renderer.JSON=E2=80=99s=20expo?= =?UTF-8?q?rt=20of=20ToJSONFields.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Decorators.hs | 2 +- src/Renderer.hs | 1 + src/Renderer/JSON.hs | 2 -- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Decorators.hs b/src/Decorators.hs index 7b646e893..606232ec8 100644 --- a/src/Decorators.hs +++ b/src/Decorators.hs @@ -8,11 +8,11 @@ module Decorators import Data.Aeson import Data.ByteString.Char8 (ByteString, pack, unpack) import Data.Functor.Classes (Show1 (liftShowsPrec)) +import Data.JSON.Fields import Data.Proxy import Data.Text.Encoding (decodeUtf8) import Data.Union import GHC.Generics -import Renderer.JSON import Term -- | Compute a 'ByteString' label for a 'Show1'able 'Term'. diff --git a/src/Renderer.hs b/src/Renderer.hs index 9b0bb09ae..bbae25c37 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -21,6 +21,7 @@ module Renderer import Data.Aeson (Value, (.=)) import Data.ByteString (ByteString) import Data.Foldable (asum) +import Data.JSON.Fields import qualified Data.Map as Map import Data.Output import Data.Syntax.Algebra (RAlgebra) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 1b4aedad3..9b5a88313 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -3,7 +3,6 @@ module Renderer.JSON ( renderJSONDiff , renderJSONTerm -, ToJSONFields(..) ) where import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) @@ -12,7 +11,6 @@ import Data.Blob import Data.ByteString.Lazy (toStrict) import Data.Foldable (toList) import Data.Functor.Both (Both) -import Data.JSON.Fields import qualified Data.Map as Map import Data.Output import Data.Semigroup ((<>)) From f6f1b21d94941b44ef8336c17364040702dd0fbf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:45:01 +0100 Subject: [PATCH 099/113] Move the Output instance for maps to Data.Output. --- src/Data/Output.hs | 8 ++++++++ src/Renderer/JSON.hs | 3 --- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Data/Output.hs b/src/Data/Output.hs index 2e2944f02..062430d53 100644 --- a/src/Data/Output.hs +++ b/src/Data/Output.hs @@ -1,9 +1,17 @@ module Data.Output where +import Data.Aeson (Value, encode) import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Map (Map) +import Data.Semigroup +import Data.Text (Text) class Monoid o => Output o where toOutput :: o -> ByteString instance Output ByteString where toOutput s = s + +instance Output (Map Text Value) where + toOutput = toStrict . (<> "\n") . encode diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 9b5a88313..3b6c7ac70 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -31,9 +31,6 @@ renderJSONDiff blobs diff = Map.fromList , ("paths", toJSON (blobPath <$> toList blobs)) ] -instance Output (Map.Map Text Value) where - toOutput = toStrict . (<> "\n") . encode - data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } deriving (Generic, Show) From c83746e74ef0aa09471d61c262886e943c4491e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:45:49 +0100 Subject: [PATCH 100/113] Move the Output instance for [Value] to Data.Output. --- src/Data/Output.hs | 3 +++ src/Renderer/JSON.hs | 8 +------- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Data/Output.hs b/src/Data/Output.hs index 062430d53..abb24d3c6 100644 --- a/src/Data/Output.hs +++ b/src/Data/Output.hs @@ -15,3 +15,6 @@ instance Output ByteString where instance Output (Map Text Value) where toOutput = toStrict . (<> "\n") . encode + +instance Output [Value] where + toOutput = toStrict . (<> "\n") . encode diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 3b6c7ac70..5a564145c 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -5,15 +5,12 @@ module Renderer.JSON , renderJSONTerm ) where -import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) +import Data.Aeson (ToJSON, toJSON, object, (.=)) import Data.Aeson as A hiding (json) import Data.Blob -import Data.ByteString.Lazy (toStrict) import Data.Foldable (toList) import Data.Functor.Both (Both) import qualified Data.Map as Map -import Data.Output -import Data.Semigroup ((<>)) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) import GHC.Generics @@ -37,8 +34,5 @@ data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileC instance ToJSON a => ToJSON (File a) where toJSON File{..} = object [ "filePath" .= filePath, "language" .= fileLanguage, "programNode" .= fileContent ] -instance Output [Value] where - toOutput = toStrict . (<> "\n") . encode - renderJSONTerm :: ToJSON a => Blob -> a -> [Value] renderJSONTerm Blob{..} = pure . toJSON . File blobPath blobLanguage From 7404b41717435a7b74fd83d22b9fdea340e22c53 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:46:08 +0100 Subject: [PATCH 101/113] Renderer.JSON no longer contains orphan instances. --- src/Renderer/JSON.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 5a564145c..21a98a089 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Renderer.JSON ( renderJSONDiff , renderJSONTerm From d0a2687edc04f6f852816c3105aff34c635abf3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 17:46:35 +0100 Subject: [PATCH 102/113] :fire: all the LANGUAGE pragmas in Renderer.JSON. --- src/Renderer/JSON.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 21a98a089..af8ea745a 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators #-} module Renderer.JSON ( renderJSONDiff , renderJSONTerm From c29a9671f0165da5537e862bbdd5a58253b7f80f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Sep 2017 15:24:09 -0400 Subject: [PATCH 103/113] Rename termSyntax to termOut. --- HLint.hs | 2 +- src/Language/Markdown/Syntax.hs | 10 +++++----- src/RWS.hs | 4 ++-- src/Term.hs | 2 +- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/HLint.hs b/HLint.hs index f3dc8ff9a..7f1c52d2c 100644 --- a/HLint.hs +++ b/HLint.hs @@ -18,7 +18,7 @@ error "use pure" = free . Pure ==> pure error "use wrap" = free . Free ==> wrap error "use extract" = termAnnotation . unTerm ==> extract -error "use unwrap" = termSyntax . unTerm ==> unwrap +error "use unwrap" = termOut . unTerm ==> unwrap error "avoid head" = head where note = "head is partial; consider using Data.Maybe.listToMaybe" diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index ae9ba030f..c4bd5104c 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -69,14 +69,14 @@ paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> man list :: Assignment list = (Term .) . (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList - CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termAnnotation . termSyntax <$> currentNode <*> children (many item)) + CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termAnnotation . termOut <$> currentNode <*> children (many item)) item :: Assignment item = makeTerm <$> symbol Item <*> children (many blockElement) section :: Assignment section = makeTerm <$> symbol Heading <*> (heading >>= \ headingTerm -> Markup.Section (level headingTerm) headingTerm <$> while (((<) `on` level) headingTerm) blockElement) - where heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termSyntax <$> currentNode <*> children (many inlineElement)) + where heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termOut <$> currentNode <*> children (many inlineElement)) level term = case term of _ | Just section <- prj (unwrap term) -> level (Markup.sectionHeading section) _ | Just heading <- prj (unwrap term) -> Markup.headingLevel heading @@ -86,7 +86,7 @@ blockQuote :: Assignment blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement) codeBlock :: Assignment -codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . termAnnotation . termSyntax <$> currentNode <*> source) +codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . termAnnotation . termOut <$> currentNode <*> source) thematicBreak :: Assignment thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak @@ -124,10 +124,10 @@ htmlInline :: Assignment htmlInline = makeTerm <$> symbol HTMLInline <*> (Markup.HTMLBlock <$> source) link :: Assignment -link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . termAnnotation . termSyntax <$> currentNode) <* advance +link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . termAnnotation . termOut <$> currentNode) <* advance image :: Assignment -image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termAnnotation . termSyntax <$> currentNode) <* advance +image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termAnnotation . termOut <$> currentNode) <* advance code :: Assignment code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source) diff --git a/src/RWS.hs b/src/RWS.hs index a23829f82..2675c6559 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -272,7 +272,7 @@ pqGramDecorator pqGramDecorator getLabel p q = cata algebra where algebra term = let label = getLabel term in - Term.Term ((gram label :. termAnnotation term) :< assignParentAndSiblingLabels (termSyntax term) label) + Term.Term ((gram label :. termAnnotation term) :< assignParentAndSiblingLabels (termOut term) label) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) @@ -302,7 +302,7 @@ canCompareTerms canCompare = canCompare `on` unTerm -- | Recursively test the equality of two 'Term's in O(n). equalTerms :: Eq1 f => ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool equalTerms canCompare = go - where go a b = canCompareTerms canCompare a b && liftEq go (termSyntax (unTerm a)) (termSyntax (unTerm b)) + where go a b = canCompareTerms canCompare a b && liftEq go (termOut (unTerm a)) (termOut (unTerm b)) -- Instances diff --git a/src/Term.hs b/src/Term.hs index 402e9af4f..c34749131 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -30,7 +30,7 @@ import Text.Show newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } infixr 5 :< -data TermF syntax ann recur = (:<) { termAnnotation :: ann, termSyntax :: syntax recur } +data TermF syntax ann recur = (:<) { termAnnotation :: ann, termOut :: syntax recur } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. From 3cc8440faea70500ed647ae98aa8938340edf42c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Sep 2017 15:36:23 -0400 Subject: [PATCH 104/113] Rename the TermF constructor to In. --- src/Algorithm.hs | 2 +- src/Alignment.hs | 6 +++--- src/Data/Syntax.hs | 2 +- src/Data/Syntax/Algebra.hs | 6 +++--- src/Data/Syntax/Assignment.hs | 8 +++---- src/Decorators.hs | 4 ++-- src/Diff.hs | 2 +- src/Interpreter.hs | 6 +++--- src/Language.hs | 16 +++++++------- src/Language/Markdown.hs | 2 +- src/Language/Markdown/Syntax.hs | 2 +- src/Language/Ruby.hs | 8 +++---- src/Parser.hs | 4 ++-- src/RWS.hs | 10 ++++----- src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 2 +- src/Renderer/SExpression.hs | 2 +- src/Renderer/TOC.hs | 10 ++++----- src/Semantic/Task.hs | 2 +- src/Term.hs | 37 ++++++++++++++++----------------- src/TreeSitter.hs | 12 +++++------ 21 files changed, 72 insertions(+), 73 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 8208dae30..22f218242 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -87,7 +87,7 @@ instance Show term => Show1 (AlgorithmF term diff) where -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- (represented by a Nothing diff returned from algorithmFor) replace one term with another. algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a) -algorithmForTerms t1@(Term (ann1 :< f1)) t2@(Term (ann2 :< f2)) = fromMaybe (byReplacing t1 t2) (fmap (copy (both ann1 ann2)) <$> algorithmFor f1 f2) +algorithmForTerms t1@(Term (In ann1 f1)) t2@(Term (In ann2 f2)) = fromMaybe (byReplacing t1 t2) (fmap (copy (both ann1 ann2)) <$> algorithmFor f1 f2) -- | A type class for determining what algorithm to use for diffing two terms. diff --git a/src/Alignment.hs b/src/Alignment.hs index 43f1afbeb..8fc16c66f 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -48,7 +48,7 @@ hasChanges = or . (True <$) -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side. alignDiff :: Traversable f => HasField fields Range => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))] alignDiff sources = cata $ \ diff -> case diff of - Copy ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :< r) + Copy ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (In ann r) Patch patch -> alignPatch sources patch -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff. @@ -67,12 +67,12 @@ alignPatch sources patch = case patch of -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff. alignSyntax :: (Applicative f, HasField fields Range, Foldable g) => (forall a. f a -> Join These a) -> (TermF [] (Record fields) term -> term) -> (term -> Range) -> f Source -> TermF g (f (Record fields)) [Join These term] -> [Join These term] -alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = +alignSyntax toJoinThese toNode getRange sources (In infos syntax) = catMaybes $ wrapInBranch <$> alignBranch getRange (join (toList syntax)) bothRanges where bothRanges = modifyJoin (fromThese [] []) lineRanges lineRanges = toJoinThese $ sourceLineRangesWithin . byteRange <$> infos <*> sources wrapInBranch = applyThese $ toJoinThese (makeNode <$> infos) - makeNode info (range, children) = toNode (setByteRange info range :< children) + makeNode info (range, children) = toNode (In (setByteRange info range) children) -- | Given a function to get the range, a list of already-aligned children, and the lists of ranges spanned by a branch, return the aligned lines. alignBranch :: (term -> Range) -> [Join These term] -> Both [Range] -> [Join These (Range, [term])] diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index d07201b63..725ec6cdc 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -32,7 +32,7 @@ makeTerm a = makeTerm' a . inj -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a -makeTerm' a f = Term (sconcat (a :| (termAnnotation . unTerm <$> toList f)) :< f) +makeTerm' a f = Term (In (sconcat (a :| (termAnnotation . unTerm <$> toList f))) f) -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index 73701d2ab..6535995db 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -33,7 +33,7 @@ decoratorWithAlgebra :: Functor f => RAlgebra (Base (Term f (Record fs))) (Term f (Record fs)) a -- ^ An R-algebra on terms. -> Term f (Record fs) -- ^ A term to decorate with values produced by the R-algebra. -> Term f (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra. -decoratorWithAlgebra alg = para $ \ c@(a :< f) -> Term ((alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f) +decoratorWithAlgebra alg = para $ \ c@(In a f) -> Term (In (alg (fmap (second (rhead . extract)) c) :. a) (fmap snd f)) newtype Identifier = Identifier ByteString @@ -43,7 +43,7 @@ newtype Identifier = Identifier ByteString -- -- Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not. identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier) -identifierAlgebra (_ :< union) = case union of +identifierAlgebra (In _ union) = case union of _ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s) _ | Just Declaration.Class{..} <- prj union -> classIdentifier _ | Just Declaration.Method{..} <- prj union -> methodName @@ -59,7 +59,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int -- TODO: Anonymous functions should not increase parent scope’s complexity. -- TODO: Inner functions should not increase parent scope’s complexity. cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity -cyclomaticComplexityAlgebra (_ :< union) = case union of +cyclomaticComplexityAlgebra (In _ union) = case union of _ | Just Declaration.Method{} <- prj union -> succ (sum union) _ | Just Statement.Return{} <- prj union -> succ (sum union) _ | Just Statement.Yield{} <- prj union -> succ (sum union) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 70bfab4db..4ea088159 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -256,9 +256,9 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar) run t yield initialState = expectedSymbols `seq` state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes) - where atNode (Term (node :< f)) = case runTracing t of + where atNode (Term (In node f)) = case runTracing t of Location -> yield (nodeLocation node) state - CurrentNode -> yield (node :< (() <$ f)) state + CurrentNode -> yield (In node (() <$ f)) state Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state) Children child -> do (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t) @@ -286,7 +286,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha requireExhaustive :: Symbol grammar => Maybe (String, SrcLoc) -> (result, State ast grammar) -> Either (Error (Either String grammar)) (result, State ast grammar) requireExhaustive callSite (a, state) = let state' = skipTokens state in case stateNodes state' of [] -> Right (a, state') - Term (node :< _) : _ -> Left (withStateCallStack callSite state (nodeError [] node)) + Term (In node _) : _ -> Left (withStateCallStack callSite state (nodeError [] node)) withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallStack => a) -> a withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action @@ -297,7 +297,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n -- | 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 ast grammar -> State ast grammar advanceState state@State{..} - | Term (Node{..} :< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest + | Term (In Node{..} _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest | otherwise = state -- | State kept while running 'Assignment's. diff --git a/src/Decorators.hs b/src/Decorators.hs index 7b646e893..824e010ae 100644 --- a/src/Decorators.hs +++ b/src/Decorators.hs @@ -20,11 +20,11 @@ import Term -- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that -- constant fields will be included and parametric fields will not be. constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString -constructorNameAndConstantFields (_ :< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "") +constructorNameAndConstantFields (In _ f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "") -- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's. constructorLabel :: Apply1 ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel -constructorLabel (_ :< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u) +constructorLabel (In _ u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u) newtype ConstructorLabel = ConstructorLabel ByteString diff --git a/src/Diff.hs b/src/Diff.hs index 732f0ca94..01de6e775 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -44,7 +44,7 @@ diffPatches = cata $ \ diff -> case diff of -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: Mergeable syntax => (Patch (Term syntax annotation) -> Maybe (Term syntax annotation)) -> (Both annotation -> annotation) -> Diff syntax annotation -> Maybe (Term syntax annotation) mergeMaybe transform extractAnnotation = cata algebra - where algebra (Copy annotations syntax) = Term . (extractAnnotation annotations :<) <$> sequenceAlt syntax + where algebra (Copy annotations syntax) = Term . (In (extractAnnotation annotations)) <$> sequenceAlt syntax algebra (Patch patch) = transform patch -- | Recover the before state of a diff. diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c35c55af1..236b579c2 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -58,7 +58,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) -- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram. getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text) -getLabel (h :< t) = (Info.category h, case t of +getLabel (In h t) = (Info.category h, case t of Leaf s -> Just s _ -> Nothing) @@ -109,11 +109,11 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Test whether two terms are comparable by their Category. comparableByCategory :: HasField fields Category => ComparabilityRelation f fields -comparableByCategory (a :< _) (b :< _) = category a == category b +comparableByCategory (In a _) (In b _) = category a == category b -- | Test whether two terms are comparable by their constructor. comparableByConstructor :: GAlign f => ComparabilityRelation f fields -comparableByConstructor (_ :< a) (_ :< b) = isJust (galign a b) +comparableByConstructor (In _ a) (In _ b) = isJust (galign a b) -- | How many nodes to consider for our constant-time approximation to tree edit distance. diff --git a/src/Language.hs b/src/Language.hs index b2fee057a..457b8b1c9 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds, DeriveGeneric, DeriveAnyClass #-} module Language where -import Control.Comonad.Trans.Cofree hiding (cofree, (:<)) +import Control.Comonad.Trans.Cofree import Data.Aeson import Data.Foldable import Data.Record @@ -38,19 +38,19 @@ languageForType mediaType = case mediaType of toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) toVarDeclOrAssignment child = case unwrap child of - S.Indexed [child', assignment] -> Term (setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment) - S.Indexed [child'] -> Term (setCategory (extract child) VarDecl :< S.VarDecl [child']) - S.VarDecl _ -> Term (setCategory (extract child) VarDecl :< unwrap child) + S.Indexed [child', assignment] -> Term (In (setCategory (extract child) VarAssignment) (S.VarAssignment [child'] assignment)) + S.Indexed [child'] -> Term (In (setCategory (extract child) VarDecl) (S.VarDecl [child'])) + S.VarDecl _ -> Term (In (setCategory (extract child) VarDecl) (unwrap child)) S.VarAssignment _ _ -> child _ -> toVarDecl child toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) -toVarDecl child = Term (setCategory (extract child) VarDecl :< S.VarDecl [child]) +toVarDecl child = Term (In (setCategory (extract child) VarDecl) (S.VarDecl [child])) toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)] -toTuple child | S.Indexed [key,value] <- unwrap child = [Term (extract child :< S.Pair key value)] -toTuple child | S.Fixed [key,value] <- unwrap child = [Term (extract child :< S.Pair key value)] -toTuple child | S.Leaf c <- unwrap child = [Term (extract child :< S.Comment c)] +toTuple child | S.Indexed [key,value] <- unwrap child = [Term (In (extract child) (S.Pair key value))] +toTuple child | S.Fixed [key,value] <- unwrap child = [Term (In (extract child) (S.Pair key value))] +toTuple child | S.Leaf c <- unwrap child = [Term (In (extract child) (S.Comment c))] toTuple child = pure child toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index 055d50236..5a328eadd 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -54,7 +54,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT toTerm within withinSpan (Node position t children) = let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position span = maybe withinSpan toSpan position - in Term ((A.Node (toGrammar t) range span) :< (t :< (toTerm range span <$> children))) + in Term (In (A.Node (toGrammar t) range span) (In t (toTerm range span <$> children))) toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index c4bd5104c..42650e562 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -67,7 +67,7 @@ paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) list :: Assignment -list = (Term .) . (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of +list = (Term .) . In <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termAnnotation . termOut <$> currentNode <*> children (many item)) diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index 1b4bde5f7..9a62c368b 100644 --- a/src/Language/Ruby.hs +++ b/src/Language/Ruby.hs @@ -57,10 +57,10 @@ termAssignment _ category children -> Just $ S.FunctionCall fn [] (toList . unwrap =<< args) (Object, _ ) -> Just . S.Object Nothing $ foldMap toTuple children (Modifier If, [ lhs, condition ]) -> Just $ S.If condition [lhs] - (Modifier Unless, [lhs, rhs]) -> Just $ S.If (Term (setCategory (extract rhs) Negate :< S.Negate rhs)) [lhs] - (Unless, expr : rest) -> Just $ S.If (Term (setCategory (extract expr) Negate :< S.Negate expr)) rest - (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (Term (setCategory (extract rhs) Negate :< S.Negate rhs)) [lhs] - (Until, expr : rest) -> Just $ S.While (Term (setCategory (extract expr) Negate :< S.Negate expr)) rest + (Modifier Unless, [lhs, rhs]) -> Just $ S.If (Term (In (setCategory (extract rhs) Negate) (S.Negate rhs))) [lhs] + (Unless, expr : rest) -> Just $ S.If (Term (In (setCategory (extract expr) Negate) (S.Negate expr))) rest + (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (Term (In (setCategory (extract rhs) Negate) (S.Negate rhs))) [lhs] + (Until, expr : rest) -> Just $ S.While (Term (In (setCategory (extract expr) Negate) (S.Negate expr))) rest (Elsif, condition : body ) -> Just $ S.If condition body (SubscriptAccess, [ base, element ]) -> Just $ S.SubscriptAccess base element (For, lhs : expr : rest ) -> Just $ S.For [lhs, expr] rest diff --git a/src/Parser.hs b/src/Parser.hs index 78e081820..4dd1215a5 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -78,5 +78,5 @@ markdownParser = AssignmentParser MarkdownParser Markdown.assignment -- | A fallback parser that treats a file simply as rows of strings. lineByLineParser :: Source -> SyntaxTerm DefaultFields -lineByLineParser source = Term ((totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source))) - where toLine line range = Term ((range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source))) +lineByLineParser source = Term (In (totalRange source :. Program :. totalSpan source :. Nil) (Indexed (zipWith toLine [1..] (sourceLineRanges source)))) + where toLine line range = Term (In (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) (Leaf (toText (slice range source)))) diff --git a/src/RWS.hs b/src/RWS.hs index 2675c6559..beafa1369 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -220,7 +220,7 @@ featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term) eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields) -eraseFeatureVector (Term.Term (record :< functor)) = Term.Term (setFeatureVector record nullFeatureVector :< functor) +eraseFeatureVector (Term.Term (In record functor)) = Term.Term (In (setFeatureVector record nullFeatureVector) functor) nullFeatureVector :: FeatureVector nullFeatureVector = listArray (0, 0) [0] @@ -254,7 +254,7 @@ featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields labe featureVectorDecorator getLabel p q d = cata collect . pqGramDecorator getLabel p q - where collect ((gram :. rest) :< functor) = Term.Term ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor) + where collect (In (gram :. rest) functor) = Term.Term (In (foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) functor) addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector addSubtermVector v term = addVectors v (rhead (extract term)) @@ -272,7 +272,7 @@ pqGramDecorator pqGramDecorator getLabel p q = cata algebra where algebra term = let label = getLabel term in - Term.Term ((gram label :. termAnnotation term) :< assignParentAndSiblingLabels (termOut term) label) + Term.Term (In (gram label :. termAnnotation term) (assignParentAndSiblingLabels (termOut term) label)) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) @@ -280,10 +280,10 @@ pqGramDecorator getLabel p q = cata algebra => label -> Term f (Record (Gram label ': fields)) -> State [Maybe label] (Term f (Record (Gram label ': fields))) - assignLabels label (Term.Term ((gram :. rest) :< functor)) = do + assignLabels label (Term.Term (In (gram :. rest) functor)) = do labels <- get put (drop 1 labels) - pure $! Term.Term ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) :< functor) + pure $! Term.Term (In (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) functor) siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label] siblingLabels = foldMap (base . rhead . extract) padToSize n list = take n (list <> repeat empty) diff --git a/src/Renderer.hs b/src/Renderer.hs index 9b0bb09ae..132b2d2f2 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -74,7 +74,7 @@ data SomeRenderer f where deriving instance Show (SomeRenderer f) identifierAlgebra :: RAlgebra (TermF Syntax a) (Term Syntax a) (Maybe Identifier) -identifierAlgebra (_ :< syntax) = case syntax of +identifierAlgebra (In _ syntax) = case syntax of S.Assignment f _ -> identifier f S.Class f _ _ -> identifier f S.Export f _ -> f >>= identifier diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 88d50de76..cf511beca 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -88,7 +88,7 @@ instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a toJSONFields = toJSONFields . unTerm instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where - toJSONFields (a :< f) = toJSONFields a <> toJSONFields f + toJSONFields (In a f) = toJSONFields a <> toJSONFields f instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSONFields (Diff f a) where toJSONFields = toJSONFields . unDiff diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index c34f5b816..ef12def98 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -43,7 +43,7 @@ printTerm term level = go term level 0 pad p n | n < 1 = "" | otherwise = "\n" <> replicate (2 * (p + n)) ' ' go :: (ConstrainAll Show fields, Foldable f) => Term f (Record fields) -> Int -> Int -> ByteString - go (Term (annotation :< syntax)) parentLevel level = + go (Term (In annotation syntax)) parentLevel level = pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")" showAnnotation :: ConstrainAll Show fields => Record fields -> ByteString diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 6efd9ef55..9b5ed09e5 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -96,12 +96,12 @@ getDeclaration = getField -- | Produce the annotations of nodes representing declarations. declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields) -declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Declaration) +declaration (In annotation _) = annotation <$ (getField annotation :: Maybe Declaration) -- | Compute 'Declaration's for methods and functions in 'Syntax'. syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration) -syntaxDeclarationAlgebra Blob{..} (a :< r) = case r of +syntaxDeclarationAlgebra Blob{..} (In a r) = case r of S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) S.Method _ (identifier, _) (Just (receiver, _)) _ _ @@ -116,7 +116,7 @@ syntaxDeclarationAlgebra Blob{..} (a :< r) = case r of declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply1 Functor fs, HasField fields Range, HasField fields Span) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -declarationAlgebra blob@Blob{..} (a :< r) +declarationAlgebra blob@Blob{..} (In a r) | Just (Declaration.Function (identifier, _) _ _) <- prj r = Just $ FunctionDeclaration (getSource (extract identifier)) | Just (Declaration.Method _ (identifier, _) _ _) <- prj r = Just $ MethodDeclaration (getSource (extract identifier)) | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage @@ -127,7 +127,7 @@ declarationAlgebra blob@Blob{..} (a :< r) markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, HasField fields Span, Apply1 Functor fs, Apply1 Foldable fs) => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -markupSectionAlgebra blob@Blob{..} (a :< r) +markupSectionAlgebra blob@Blob{..} (In a r) | Just (Markup.Section level (heading, _) _) <- prj r = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage | otherwise = Nothing @@ -152,7 +152,7 @@ tableOfContentsBy :: (Foldable f, Functor f) -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. tableOfContentsBy selector = fromMaybe [] . cata diffAlgebra where diffAlgebra r = case r of - Copy ann r -> case (selector (Both.snd ann :< r), fold r) of + Copy ann r -> case (selector (In (Both.snd ann) r), fold r) of (Just a, Nothing) -> Just [Unchanged a] (Just a, Just []) -> Just [Changed a] (_ , entries) -> entries diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index a1b062106..6d54ba168 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -220,7 +220,7 @@ runParser Options{..} blob@Blob{..} = go LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource) blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ] errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String] - errors = cata $ \ (a :< syntax) -> case syntax of + errors = cata $ \ (In a syntax) -> case syntax of _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (sourceSpan a) err] _ -> fold syntax logTiming :: String -> Task a -> Task a diff --git a/src/Term.hs b/src/Term.hs index c34749131..20678964c 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -29,8 +29,7 @@ import Text.Show -- | A Term with an abstract syntax tree and an annotation. newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } -infixr 5 :< -data TermF syntax ann recur = (:<) { termAnnotation :: ann, termOut :: syntax recur } +data TermF syntax ann recur = In { termAnnotation :: ann, termOut :: syntax recur } deriving (Eq, Foldable, Functor, Show, Traversable) -- | A Term with a Syntax leaf and a record of fields. @@ -40,11 +39,11 @@ type SyntaxTermF fields = TermF Syntax (Record fields) -- | Return the node count of a term. termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where - size (_ :< syntax) = 1 + sum syntax + size (In _ syntax) = 1 + sum syntax hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a -hoistTerm f = go where go (Term (a :< r)) = Term (a :< f (fmap go r)) +hoistTerm f = go where go (Term (In a r)) = Term (In a (f (fmap go r))) -- | Strips the head annotation off a term annotated with non-empty records. stripTerm :: Functor f => Term f (Record (h ': t)) -> Term f (Record t) @@ -56,7 +55,7 @@ liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) instance Apply1 Pretty1 fs => Pretty1 (Term (Union fs)) where - liftPretty p pl = go where go (Term (a :< f)) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f + liftPretty p pl = go where go (Term (In a f)) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f instance (Apply1 Pretty1 fs, Pretty a) => Pretty (Term (Union fs) a) where pretty = liftPretty pretty prettyList @@ -67,25 +66,25 @@ instance Functor f => Recursive (Term f a) where project = unTerm instance Functor f => Corecursive (Term f a) where embed = Term instance Functor f => Comonad (Term f) where - extract (Term (a :< _)) = a - duplicate w = Term (w :< fmap duplicate (unwrap w)) - extend f = go where go w = Term (f w :< fmap go (unwrap w)) + extract = termAnnotation . unTerm + duplicate w = Term (In w (fmap duplicate (unwrap w))) + extend f = go where go w = Term (In (f w) (fmap go (unwrap w))) instance Functor f => Functor (Term f) where - fmap f = go where go (Term (a :< r)) = Term (f a :< fmap go r) + fmap f = go where go (Term (In a r)) = Term (In (f a) (fmap go r)) instance Foldable f => Foldable (Term f) where - foldMap f = go where go (Term (a :< r)) = f a `mappend` foldMap go r + foldMap f = go where go (Term (In a r)) = f a `mappend` foldMap go r instance Traversable f => Traversable (Term f) where - traverse f = go where go (Term (a :< r)) = (Term .) . (:<) <$> f a <*> traverse go r + traverse f = go where go (Term (In a r)) = (Term .) . In <$> f a <*> traverse go r instance Functor f => ComonadCofree f (Term f) where - unwrap (Term (_ :< as)) = as + unwrap = termOut . unTerm {-# INLINE unwrap #-} instance Eq1 f => Eq1 (Term f) where - liftEq eqA = go where go (Term (a1 :< f1)) (Term (a2 :< f2)) = eqA a1 a2 && liftEq go f1 f2 + liftEq eqA = go where go (Term (In a1 f1)) (Term (In a2 f2)) = eqA a1 a2 && liftEq go f1 f2 instance (Eq1 f, Eq a) => Eq (Term f a) where (==) = eq1 @@ -97,29 +96,29 @@ instance (Show1 f, Show a) => Show (Term f a) where showsPrec = showsPrec1 instance Functor f => Bifunctor (TermF f) where - bimap f g (a :< r) = f a :< fmap g r + bimap f g (In a r) = In (f a) (fmap g r) instance Foldable f => Bifoldable (TermF f) where - bifoldMap f g (a :< r) = f a `mappend` foldMap g r + bifoldMap f g (In a r) = f a `mappend` foldMap g r instance Traversable f => Bitraversable (TermF f) where - bitraverse f g (a :< r) = (:<) <$> f a <*> traverse g r + bitraverse f g (In a r) = In <$> f a <*> traverse g r instance Eq1 f => Eq2 (TermF f) where - liftEq2 eqA eqB (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq eqB f1 f2 + liftEq2 eqA eqB (In a1 f1) (In a2 f2) = eqA a1 a2 && liftEq eqB f1 f2 instance (Eq1 f, Eq a) => Eq1 (TermF f a) where liftEq = liftEq2 (==) instance Show1 f => Show2 (TermF f) where - liftShowsPrec2 spA _ spB slB d (a :< f) = showParen (d > 5) $ spA 6 a . showString " :< " . liftShowsPrec spB slB 5 f + liftShowsPrec2 spA _ spB slB d (In a f) = showsBinaryWith spA (liftShowsPrec spB slB) "In" d a f instance (Show1 f, Show a) => Show1 (TermF f a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Pretty1 f => Pretty2 (TermF f) where - liftPretty2 pA _ pB plB (a :< f) = pA a <+> liftPretty pB plB f + liftPretty2 pA _ pB plB (In a f) = pA a <+> liftPretty pB plB f instance (Pretty1 f, Pretty a) => Pretty1 (TermF f a) where liftPretty = liftPretty2 pretty prettyList diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 253dfa8bc..2558f4b6a 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -64,7 +64,7 @@ toAST node@TS.Node{..} = do children <- allocaArray count $ \ childNodesPtr -> do _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nullPtr nodePtr childNodesPtr (fromIntegral count)) peekArray count childNodesPtr - pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) :< children + pure $! In (A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node)) children anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t anaM g = a where a = pure . embed <=< traverse a <=< g @@ -109,7 +109,7 @@ nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos no assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) assignTerm language source annotation children allChildren = case assignTermByLanguage source (category annotation) children of - Just a -> pure (Term (annotation :< a)) + Just a -> pure (Term (In annotation a)) _ -> defaultTermAssignment source annotation children allChildren where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) assignTermByLanguage = case languageForTSLanguage language of @@ -120,7 +120,7 @@ assignTerm language source annotation children allChildren = defaultTermAssignment :: Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) defaultTermAssignment source annotation children allChildren - | category annotation `elem` operatorCategories = Term . (annotation :<) . S.Operator <$> allChildren + | category annotation `elem` operatorCategories = Term . In annotation . S.Operator <$> allChildren | otherwise = case (category annotation, children) of (ParseError, children) -> toTerm $ S.ParseError children @@ -155,7 +155,7 @@ defaultTermAssignment source annotation children allChildren [_, Other t] | t `elem` ["--", "++"] -> MathOperator _ -> Operator - pure (Term (setCategory annotation c :< S.Operator cs)) + pure (Term (In (setCategory annotation c) (S.Operator cs))) (Other "binary_expression", _) -> do cs <- allChildren @@ -166,7 +166,7 @@ defaultTermAssignment source annotation children allChildren | s `elem` ["&&", "||"] -> BooleanOperator | s `elem` [">>", ">>=", ">>>", ">>>=", "<<", "<<=", "&", "^", "|"] -> BitwiseOperator _ -> Operator - pure (Term (setCategory annotation c :< S.Operator cs)) + pure (Term (In (setCategory annotation c) (S.Operator cs))) (_, []) -> toTerm $ S.Leaf (toText source) (_, children) -> toTerm $ S.Indexed children @@ -181,7 +181,7 @@ defaultTermAssignment source annotation children allChildren , RelationalOperator , BitwiseOperator ] - toTerm = pure . Term . (annotation :<) + toTerm = pure . Term . In annotation categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category From 56e9982960fcd52cbcf6307485e21d66094bc4a6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Sep 2017 15:43:31 -0400 Subject: [PATCH 105/113] Define a Term smart constructor. --- src/Language/Markdown/Syntax.hs | 4 ++-- src/Term.hs | 14 +++++++++----- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 42650e562..77440e20a 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -20,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) -import Term (Term(..), TermF(..), unwrap) +import Term (Term(..), TermF(..), termIn, unwrap) type Syntax = '[ Markup.Document @@ -67,7 +67,7 @@ paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) list :: Assignment -list = (Term .) . In <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of +list = termIn <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termAnnotation . termOut <$> currentNode <*> children (many item)) diff --git a/src/Term.hs b/src/Term.hs index 20678964c..e4f62e142 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeOperators #-} module Term ( Term(..) +, termIn , TermF(..) , SyntaxTerm , SyntaxTermF @@ -41,9 +42,12 @@ termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where size (In _ syntax) = 1 + sum syntax +termIn :: ann -> syntax (Term syntax ann) -> Term syntax ann +termIn = (Term .) . In + hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a -hoistTerm f = go where go (Term (In a r)) = Term (In a (f (fmap go r))) +hoistTerm f = go where go (Term (In a r)) = termIn a (f (fmap go r)) -- | Strips the head annotation off a term annotated with non-empty records. stripTerm :: Functor f => Term f (Record (h ': t)) -> Term f (Record t) @@ -67,17 +71,17 @@ instance Functor f => Corecursive (Term f a) where embed = Term instance Functor f => Comonad (Term f) where extract = termAnnotation . unTerm - duplicate w = Term (In w (fmap duplicate (unwrap w))) - extend f = go where go w = Term (In (f w) (fmap go (unwrap w))) + duplicate w = termIn w (fmap duplicate (unwrap w)) + extend f = go where go w = termIn (f w) (fmap go (unwrap w)) instance Functor f => Functor (Term f) where - fmap f = go where go (Term (In a r)) = Term (In (f a) (fmap go r)) + fmap f = go where go (Term (In a r)) = termIn (f a) (fmap go r) instance Foldable f => Foldable (Term f) where foldMap f = go where go (Term (In a r)) = f a `mappend` foldMap go r instance Traversable f => Traversable (Term f) where - traverse f = go where go (Term (In a r)) = (Term .) . In <$> f a <*> traverse go r + traverse f = go where go (Term (In a r)) = termIn <$> f a <*> traverse go r instance Functor f => ComonadCofree f (Term f) where unwrap = termOut . unTerm From 5df09cd26169f97423d2de3102ceeccac58ab2b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Sep 2017 15:43:52 -0400 Subject: [PATCH 106/113] :memo: termIn. --- src/Term.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Term.hs b/src/Term.hs index e4f62e142..ecff900d2 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -42,6 +42,7 @@ termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize = cata size where size (In _ syntax) = 1 + sum syntax +-- | Build a Term from its annotation and syntax. termIn :: ann -> syntax (Term syntax ann) -> Term syntax ann termIn = (Term .) . In From 1cd6dd28992a6e30834719ff0adc7e385fb5ae28 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Sep 2017 15:48:58 -0400 Subject: [PATCH 107/113] Update the tests. --- test/AlignmentSpec.hs | 134 ++++++++++++------------- test/Data/Functor/Listable.hs | 2 +- test/Data/RandomWalkSimilarity/Spec.hs | 4 +- test/Data/Syntax/Assignment/Spec.hs | 2 +- test/InterpreterSpec.hs | 10 +- test/SemanticSpec.hs | 12 +-- test/TOCSpec.hs | 26 ++--- 7 files changed, 95 insertions(+), 95 deletions(-) diff --git a/test/AlignmentSpec.hs b/test/AlignmentSpec.hs index 1ef88ce43..24d122060 100644 --- a/test/AlignmentSpec.hs +++ b/test/AlignmentSpec.hs @@ -65,133 +65,133 @@ spec = parallel $ do it "aligns identical branches on a single line" $ let sources = both (Source.fromText "[ foo ]") (Source.fromText "[ foo ]") in align sources (pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ]) - (wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ])) ] + [ Join (These (wrap $ info 0 7 `In` [ wrap $ info 2 5 `In` [] ]) + (wrap $ info 0 7 `In` [ wrap $ info 2 5 `In` [] ])) ] it "aligns identical branches spanning multiple lines" $ let sources = both (Source.fromText "[\nfoo\n]") (Source.fromText "[\nfoo\n]") in align sources (pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 2 :< []) - (wrap $ info 0 2 :< [])) - , Join (These (wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ]) - (wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ])) - , Join (These (wrap $ info 6 7 :< []) - (wrap $ info 6 7 :< [])) + [ Join (These (wrap $ info 0 2 `In` []) + (wrap $ info 0 2 `In` [])) + , Join (These (wrap $ info 2 6 `In` [ wrap $ info 2 5 `In` [] ]) + (wrap $ info 2 6 `In` [ wrap $ info 2 5 `In` [] ])) + , Join (These (wrap $ info 6 7 `In` []) + (wrap $ info 6 7 `In` [])) ] it "aligns reformatted branches" $ let sources = both (Source.fromText "[ foo ]") (Source.fromText "[\nfoo\n]") in align sources (pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ]) `shouldBe` prettyDiff sources - [ Join (That (wrap $ info 0 2 :< [])) - , Join (These (wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ]) - (wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ])) - , Join (That (wrap $ info 6 7 :< [])) + [ Join (That (wrap $ info 0 2 `In` [])) + , Join (These (wrap $ info 0 7 `In` [ wrap $ info 2 5 `In` [] ]) + (wrap $ info 2 6 `In` [ wrap $ info 2 5 `In` [] ])) + , Join (That (wrap $ info 6 7 `In` [])) ] it "aligns nodes following reformatted branches" $ let sources = both (Source.fromText "[ foo ]\nbar\n") (Source.fromText "[\nfoo\n]\nbar\n") in align sources (pure (info 0 12) `copy` Indexed [ pure (info 0 7) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo" ], pure (info 8 11) `copy` Leaf "bar" ]) `shouldBe` prettyDiff sources - [ Join (That (wrap $ info 0 2 :< [ wrap $ info 0 2 :< [] ])) - , Join (These (wrap $ info 0 8 :< [ wrap $ info 0 7 :< [ wrap $ info 2 5 :< [] ] ]) - (wrap $ info 2 6 :< [ wrap $ info 2 6 :< [ wrap $ info 2 5 :< [] ] ])) - , Join (That (wrap $ info 6 8 :< [ wrap $ info 6 7 :< [] ])) - , Join (These (wrap $ info 8 12 :< [ wrap $ info 8 11 :< [] ]) - (wrap $ info 8 12 :< [ wrap $ info 8 11 :< [] ])) - , Join (These (wrap $ info 12 12 :< []) - (wrap $ info 12 12 :< [])) + [ Join (That (wrap $ info 0 2 `In` [ wrap $ info 0 2 `In` [] ])) + , Join (These (wrap $ info 0 8 `In` [ wrap $ info 0 7 `In` [ wrap $ info 2 5 `In` [] ] ]) + (wrap $ info 2 6 `In` [ wrap $ info 2 6 `In` [ wrap $ info 2 5 `In` [] ] ])) + , Join (That (wrap $ info 6 8 `In` [ wrap $ info 6 7 `In` [] ])) + , Join (These (wrap $ info 8 12 `In` [ wrap $ info 8 11 `In` [] ]) + (wrap $ info 8 12 `In` [ wrap $ info 8 11 `In` [] ])) + , Join (These (wrap $ info 12 12 `In` []) + (wrap $ info 12 12 `In` [])) ] it "aligns identical branches with multiple children on the same line" $ let sources = pure (Source.fromText "[ foo, bar ]") in align sources (pure (info 0 12) `copy` Indexed [ pure (info 2 5) `copy` Leaf "foo", pure (info 7 10) `copy` Leaf "bar" ]) `shouldBe` prettyDiff sources - [ Join (runBothWith These (pure (wrap $ info 0 12 :< [ wrap $ info 2 5 :< [], wrap $ info 7 10 :< [] ])) ) ] + [ Join (runBothWith These (pure (wrap $ info 0 12 `In` [ wrap $ info 2 5 `In` [], wrap $ info 7 10 `In` [] ])) ) ] it "aligns insertions" $ let sources = both (Source.fromText "a") (Source.fromText "a\nb") in - align sources (both (info 0 1) (info 0 3) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", inserting (Term (info 2 3 :< Leaf "b")) ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 1 :< [ wrap $ info 0 1 :< [] ]) - (wrap $ info 0 2 :< [ wrap $ info 0 1 :< [] ])) - , Join (That (wrap $ info 2 3 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) + align sources (both (info 0 1) (info 0 3) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", inserting (Term (info 2 3 `In` Leaf "b")) ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 1 `In` [ wrap $ info 0 1 `In` [] ]) + (wrap $ info 0 2 `In` [ wrap $ info 0 1 `In` [] ])) + , Join (That (wrap $ info 2 3 `In` [ pure (SplitInsert (Term (info 2 3 `In` []))) ])) ] it "aligns total insertions" $ let sources = both (Source.fromText "") (Source.fromText "a") in - align sources (inserting (Term (info 0 1 :< Leaf "a"))) `shouldBe` prettyDiff sources - [ Join (That (pure (SplitInsert (Term (info 0 1 :< []))))) ] + align sources (inserting (Term (info 0 1 `In` Leaf "a"))) `shouldBe` prettyDiff sources + [ Join (That (pure (SplitInsert (Term (info 0 1 `In` []))))) ] it "aligns insertions into empty branches" $ let sources = both (Source.fromText "[ ]") (Source.fromText "[a]") in - align sources (pure (info 0 3) `copy` Indexed [ inserting (Term (info 1 2 :< Leaf "a")) ]) `shouldBe` prettyDiff sources - [ Join (That (wrap $ info 0 3 :< [ pure (SplitInsert (Term (info 1 2 :< []))) ])) - , Join (This (wrap $ info 0 3 :< [])) + align sources (pure (info 0 3) `copy` Indexed [ inserting (Term (info 1 2 `In` Leaf "a")) ]) `shouldBe` prettyDiff sources + [ Join (That (wrap $ info 0 3 `In` [ pure (SplitInsert (Term (info 1 2 `In` []))) ])) + , Join (This (wrap $ info 0 3 `In` [])) ] it "aligns symmetrically following insertions" $ let sources = both (Source.fromText "a\nc") (Source.fromText "a\nb\nc") in - align sources (both (info 0 3) (info 0 5) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", inserting (Term (info 2 3 :< Leaf "b")), both (info 2 3) (info 4 5) `copy` Leaf "c" ]) + align sources (both (info 0 3) (info 0 5) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", inserting (Term (info 2 3 `In` Leaf "b")), both (info 2 3) (info 4 5) `copy` Leaf "c" ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 2 :< [ wrap $ info 0 1 :< [] ]) - (wrap $ info 0 2 :< [ wrap $ info 0 1 :< [] ])) - , Join (That (wrap $ info 2 4 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) - , Join (These (wrap $ info 2 3 :< [ wrap $ info 2 3 :< [] ]) - (wrap $ info 4 5 :< [ wrap $ info 4 5 :< [] ])) + [ Join (These (wrap $ info 0 2 `In` [ wrap $ info 0 1 `In` [] ]) + (wrap $ info 0 2 `In` [ wrap $ info 0 1 `In` [] ])) + , Join (That (wrap $ info 2 4 `In` [ pure (SplitInsert (Term (info 2 3 `In` []))) ])) + , Join (These (wrap $ info 2 3 `In` [ wrap $ info 2 3 `In` [] ]) + (wrap $ info 4 5 `In` [ wrap $ info 4 5 `In` [] ])) ] it "symmetrical nodes force the alignment of asymmetrical nodes on both sides" $ let sources = both (Source.fromText "[ a, b ]") (Source.fromText "[ b, c ]") in - align sources (pure (info 0 8) `copy` Indexed [ deleting (Term (info 2 3 :< Leaf "a")), both (info 5 6) (info 2 3) `copy` Leaf "b", inserting (Term (info 5 6 :< Leaf "c")) ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 8 :< [ pure (SplitDelete (Term (info 2 3 :< []))), wrap $ info 5 6 :< [] ]) - (wrap $ info 0 8 :< [ wrap $ info 2 3 :< [], pure (SplitInsert (Term (info 5 6 :< []))) ])) ] + align sources (pure (info 0 8) `copy` Indexed [ deleting (Term (info 2 3 `In` Leaf "a")), both (info 5 6) (info 2 3) `copy` Leaf "b", inserting (Term (info 5 6 `In` Leaf "c")) ]) `shouldBe` prettyDiff sources + [ Join (These (wrap $ info 0 8 `In` [ pure (SplitDelete (Term (info 2 3 `In` []))), wrap $ info 5 6 `In` [] ]) + (wrap $ info 0 8 `In` [ wrap $ info 2 3 `In` [], pure (SplitInsert (Term (info 5 6 `In` []))) ])) ] it "when one of two symmetrical nodes must be split, splits the latter" $ let sources = both (Source.fromText "[ a, b ]") (Source.fromText "[ a\n, b\n]") in align sources (both (info 0 8) (info 0 9) `copy` Indexed [ pure (info 2 3) `copy` Leaf "a", both (info 5 6) (info 6 7) `copy` Leaf "b" ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 8 :< [ wrap $ info 2 3 :< [], wrap $ info 5 6 :< [] ]) - (wrap $ info 0 4 :< [ wrap $ info 2 3 :< [] ])) - , Join (That (wrap $ info 4 8 :< [ wrap $ info 6 7 :< [] ])) - , Join (That (wrap $ info 8 9 :< [])) + [ Join (These (wrap $ info 0 8 `In` [ wrap $ info 2 3 `In` [], wrap $ info 5 6 `In` [] ]) + (wrap $ info 0 4 `In` [ wrap $ info 2 3 `In` [] ])) + , Join (That (wrap $ info 4 8 `In` [ wrap $ info 6 7 `In` [] ])) + , Join (That (wrap $ info 8 9 `In` [])) ] it "aligns deletions before insertions" $ let sources = both (Source.fromText "[ a ]") (Source.fromText "[ b ]") in - align sources (pure (info 0 5) `copy` Indexed [ deleting (Term (info 2 3 :< Leaf "a")), inserting (Term (info 2 3 :< Leaf "b")) ]) `shouldBe` prettyDiff sources - [ Join (This (wrap $ info 0 5 :< [ pure (SplitDelete (Term (info 2 3 :< []))) ])) - , Join (That (wrap $ info 0 5 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) + align sources (pure (info 0 5) `copy` Indexed [ deleting (Term (info 2 3 `In` Leaf "a")), inserting (Term (info 2 3 `In` Leaf "b")) ]) `shouldBe` prettyDiff sources + [ Join (This (wrap $ info 0 5 `In` [ pure (SplitDelete (Term (info 2 3 `In` []))) ])) + , Join (That (wrap $ info 0 5 `In` [ pure (SplitInsert (Term (info 2 3 `In` []))) ])) ] it "aligns context-only lines symmetrically" $ let sources = both (Source.fromText "[\n a\n,\n b\n]") (Source.fromText "[\n a, b\n\n\n]") in align sources (both (info 0 13) (info 0 12) `copy` Indexed [ pure (info 4 5) `copy` Leaf "a", both (info 10 11) (info 7 8) `copy` Leaf "b" ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 2 :< []) - (wrap $ info 0 2 :< [])) - , Join (These (wrap $ info 2 6 :< [ wrap $ info 4 5 :< [] ]) - (wrap $ info 2 9 :< [ wrap $ info 4 5 :< [], wrap $ info 7 8 :< [] ])) - , Join (These (wrap $ info 6 8 :< []) - (wrap $ info 9 10 :< [])) - , Join (This (wrap $ info 8 12 :< [ wrap $ info 10 11 :< [] ])) - , Join (These (wrap $ info 12 13 :< []) - (wrap $ info 10 11 :< [])) - , Join (That (wrap $ info 11 12 :< [])) + [ Join (These (wrap $ info 0 2 `In` []) + (wrap $ info 0 2 `In` [])) + , Join (These (wrap $ info 2 6 `In` [ wrap $ info 4 5 `In` [] ]) + (wrap $ info 2 9 `In` [ wrap $ info 4 5 `In` [], wrap $ info 7 8 `In` [] ])) + , Join (These (wrap $ info 6 8 `In` []) + (wrap $ info 9 10 `In` [])) + , Join (This (wrap $ info 8 12 `In` [ wrap $ info 10 11 `In` [] ])) + , Join (These (wrap $ info 12 13 `In` []) + (wrap $ info 10 11 `In` [])) + , Join (That (wrap $ info 11 12 `In` [])) ] it "aligns asymmetrical nodes preceding their symmetrical siblings conservatively" $ let sources = both (Source.fromText "[ b, c ]") (Source.fromText "[ a\n, c\n]") in - align sources (both (info 0 8) (info 0 9) `copy` Indexed [ inserting (Term (info 2 3 :< Leaf "a")), deleting (Term (info 2 3 :< Leaf "b")), both (info 5 6) (info 6 7) `copy` Leaf "c" ]) `shouldBe` prettyDiff sources - [ Join (That (wrap $ info 0 4 :< [ pure (SplitInsert (Term (info 2 3 :< []))) ])) - , Join (These (wrap $ info 0 8 :< [ pure (SplitDelete (Term (info 2 3 :< []))), wrap $ info 5 6 :< [] ]) - (wrap $ info 4 8 :< [ wrap $ info 6 7 :< [] ])) - , Join (That (wrap $ info 8 9 :< [])) + align sources (both (info 0 8) (info 0 9) `copy` Indexed [ inserting (Term (info 2 3 `In` Leaf "a")), deleting (Term (info 2 3 `In` Leaf "b")), both (info 5 6) (info 6 7) `copy` Leaf "c" ]) `shouldBe` prettyDiff sources + [ Join (That (wrap $ info 0 4 `In` [ pure (SplitInsert (Term (info 2 3 `In` []))) ])) + , Join (These (wrap $ info 0 8 `In` [ pure (SplitDelete (Term (info 2 3 `In` []))), wrap $ info 5 6 `In` [] ]) + (wrap $ info 4 8 `In` [ wrap $ info 6 7 `In` [] ])) + , Join (That (wrap $ info 8 9 `In` [])) ] it "aligns symmetrical reformatted nodes" $ let sources = both (Source.fromText "a [ b ]\nc") (Source.fromText "a [\nb\n]\nc") in align sources (pure (info 0 9) `copy` Indexed [ pure (info 0 1) `copy` Leaf "a", pure (info 2 7) `copy` Indexed [ pure (info 4 5) `copy` Leaf "b" ], pure (info 8 9) `copy` Leaf "c" ]) `shouldBe` prettyDiff sources - [ Join (These (wrap $ info 0 8 :< [ wrap $ info 0 1 :< [], wrap $ info 2 7 :< [ wrap $ info 4 5 :< [] ] ]) - (wrap $ info 0 4 :< [ wrap $ info 0 1 :< [], wrap $ info 2 4 :< [] ])) - , Join (That (wrap $ info 4 6 :< [ wrap $ info 4 6 :< [ wrap $ info 4 5 :< [] ] ])) - , Join (That (wrap $ info 6 8 :< [ wrap $ info 6 7 :< [] ])) - , Join (These (wrap $ info 8 9 :< [ wrap $ info 8 9 :< [] ]) - (wrap $ info 8 9 :< [ wrap $ info 8 9 :< [] ])) + [ Join (These (wrap $ info 0 8 `In` [ wrap $ info 0 1 `In` [], wrap $ info 2 7 `In` [ wrap $ info 4 5 `In` [] ] ]) + (wrap $ info 0 4 `In` [ wrap $ info 0 1 `In` [], wrap $ info 2 4 `In` [] ])) + , Join (That (wrap $ info 4 6 `In` [ wrap $ info 4 6 `In` [ wrap $ info 4 5 `In` [] ] ])) + , Join (That (wrap $ info 6 8 `In` [ wrap $ info 6 7 `In` [] ])) + , Join (These (wrap $ info 8 9 `In` [ wrap $ info 8 9 `In` [] ]) + (wrap $ info 8 9 `In` [ wrap $ info 8 9 `In` [] ])) ] describe "numberedRows" $ do diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index c58d045ff..667bef0ac 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -149,7 +149,7 @@ instance (Listable1 f, Listable a) => Listable (ListableF f a) where instance Listable1 f => Listable2 (TermF f) where - liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<) + liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) In instance (Listable1 f, Listable a) => Listable1 (TermF f a) where liftTiers = liftTiers2 tiers diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index 897a67224..a5dc61d8c 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -33,12 +33,12 @@ spec = parallel $ do prop "produces correct diffs" $ \ (as, bs) -> let tas = decorate <$> (as :: [SyntaxTerm '[Category]]) tbs = decorate <$> (bs :: [SyntaxTerm '[Category]]) - root = Term . ((Program :. Nil) :<) . Indexed + root = termIn (Program :. Nil) . Indexed diff = copy (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))) it "produces unbiased insertions within branches" $ - let (a, b) = (decorate (Term ((StringLiteral :. Nil) :< Indexed [ Term ((StringLiteral :. Nil) :< Leaf "a") ])), decorate (Term ((StringLiteral :. Nil) :< Indexed [ Term ((StringLiteral :. Nil) :< Leaf "b") ]))) in + let (a, b) = (decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "a") ])), decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` 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 = termAnnotation a == termAnnotation b diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 63b50b450..99e67fa33 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -289,7 +289,7 @@ spec = do Left [ "symbol" ] node :: symbol -> Int -> Int -> [AST [] symbol] -> AST [] symbol -node symbol start end children = Term (Node symbol (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end))) :< children) +node symbol start end children = Term (Node symbol (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end))) `In` children) data Grammar = Palette | Red | Green | Blue | Magenta deriving (Bounded, Enum, Eq, Ix, Ord, Show) diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 6e0af9c2e..566245194 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -18,8 +18,8 @@ spec :: Spec spec = parallel $ do describe "interpret" $ do it "returns a replacement when comparing two unicode equivalent terms" $ - let termA = Term $ (StringLiteral :. Nil) :< Leaf "t\776" - termB = Term $ (StringLiteral :. Nil) :< Leaf "\7831" in + let termA = Term $ (StringLiteral :. Nil) `In` Leaf "t\776" + termB = Term $ (StringLiteral :. Nil) `In` Leaf "\7831" in diffTerms (both termA termB) `shouldBe` replacing termA termB prop "produces correct diffs" $ @@ -32,6 +32,6 @@ spec = parallel $ do diffCost diff `shouldBe` 0 it "produces unbiased insertions within branches" $ - let term s = Term ((StringLiteral :. Nil) :< Indexed [ Term ((StringLiteral :. Nil) :< Leaf s) ]) :: SyntaxTerm '[Category] - root = Term . ((Program :. Nil) :<) . Indexed in - diffTerms (both (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` copy (pure (Program :. Nil)) (Indexed [ inserting (term "a"), cata (\ (a :< r) -> copy (pure a) r) (term "b") ]) + let term s = Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf s) ]) :: SyntaxTerm '[Category] + root = termIn (Program :. Nil) . Indexed in + diffTerms (both (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` copy (pure (Program :. Nil)) (Indexed [ inserting (term "a"), cata (\ (In a r) -> copy (pure a) r) (term "b") ]) diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs index c7fec3115..6960474c1 100644 --- a/test/SemanticSpec.hs +++ b/test/SemanticSpec.hs @@ -19,11 +19,11 @@ spec = parallel $ do describe "parseBlob" $ do it "parses in the specified language" $ do Just term <- runTask $ parseBlob IdentityTermRenderer methodsBlob - void term `shouldBe` Term (() :< Indexed [ Term (() :< Method [] (Term (() :< Leaf "foo")) Nothing [] []) ]) + void term `shouldBe` Term (() `In` Indexed [ Term (() `In` Method [] (Term (() `In` Leaf "foo")) Nothing [] []) ]) it "parses line by line if not given a language" $ do Just term <- runTask $ parseBlob IdentityTermRenderer methodsBlob { blobLanguage = Nothing } - void term `shouldBe` Term (() :< Indexed [ Term (() :< Leaf "def foo\n"), Term (() :< Leaf "end\n"), Term (() :< Leaf "") ]) + void term `shouldBe` Term (() `In` Indexed [ Term (() `In` Leaf "def foo\n"), Term (() `In` Leaf "end\n"), Term (() `In` Leaf "") ]) it "renders with the specified renderer" $ do output <- runTask $ parseBlob SExpressionTermRenderer methodsBlob @@ -31,12 +31,12 @@ spec = parallel $ do describe "diffTermPair" $ do it "produces an Insert when the first blob is missing" $ do - result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) (runBothWith replacing) (pure (Term (() :< [])))) - result `shouldBe` Diff (Patch (Insert (Term (() :< [])))) + result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) (runBothWith replacing) (pure (Term (() `In` [])))) + result `shouldBe` Diff (Patch (Insert (Term (() `In` [])))) it "produces a Delete when the second blob is missing" $ do - result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) (runBothWith replacing) (pure (Term (() :< [])))) - result `shouldBe` Diff (Patch (Delete (Term (() :< [])))) + result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) (runBothWith replacing) (pure (Term (() `In` [])))) + result `shouldBe` Diff (Patch (Delete (Term (() `In` [])))) where methodsBlob = Blob "def foo\nend\n" "ff7bbbe9495f61d9e1e58c597502d152bab1761e" "methods.rb" (Just defaultPlainBlob) (Just Ruby) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 8c51d97cf..a609f3b66 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -55,7 +55,7 @@ spec = parallel $ do prop "produces changed entries for relevant nodes containing irrelevant patches" $ \ diff -> let diff' = copy (pure 0) (Indexed [1 <$ (diff :: Diff Syntax Int)]) in - tableOfContentsBy (\ (n :< _) -> if n == (0 :: Int) then Just n else Nothing) diff' `shouldBe` + tableOfContentsBy (\ (n `In` _) -> if n == (0 :: Int) then Just n else Nothing) diff' `shouldBe` if null (diffPatches diff') then [Unchanged 0] else replicate (length (diffPatches diff')) (Changed 0) @@ -195,9 +195,9 @@ programOf :: Diff' -> Diff' programOf diff = copy (pure programInfo) (Indexed [ diff ]) functionOf :: Text -> Term' -> Term' -functionOf name body = Term $ (Just (FunctionDeclaration name) :. functionInfo) :< S.Function name' [] [body] +functionOf name body = Term $ (Just (FunctionDeclaration name) :. functionInfo) `In` S.Function name' [] [body] where - name' = Term $ (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name + name' = Term $ (Nothing :. Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) `In` Leaf name programInfo :: Record (Maybe Declaration ': DefaultFields) programInfo = Nothing :. Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil @@ -208,20 +208,20 @@ functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil -- Filter tiers for terms that we consider "meaniningful" in TOC summaries. isMeaningfulTerm :: Term Syntax a -> Bool isMeaningfulTerm a = case unTerm a of - (_ :< S.Indexed _) -> False - (_ :< S.Fixed _) -> False - (_ :< S.Commented _ _) -> False - (_ :< S.ParseError _) -> False + (_ `In` S.Indexed _) -> False + (_ `In` S.Fixed _) -> False + (_ `In` S.Commented _ _) -> False + (_ `In` S.ParseError _) -> False _ -> True -- Filter tiers for terms if the Syntax is a Method or a Function. isMethodOrFunction :: HasField fields Category => Term Syntax (Record fields) -> Bool isMethodOrFunction a = case unTerm a of - (_ :< S.Method{}) -> True - (_ :< S.Function{}) -> True - (a :< _) | getField a == C.Function -> True - (a :< _) | getField a == C.Method -> True - (a :< _) | getField a == C.SingletonMethod -> True + (_ `In` S.Method{}) -> True + (_ `In` S.Function{}) -> True + (a `In` _) | getField a == C.Function -> True + (a `In` _) | getField a == C.Method -> True + (a `In` _) | getField a == C.SingletonMethod -> True _ -> False blobsForPaths :: Both FilePath -> IO (Both Blob) @@ -231,7 +231,7 @@ sourceSpanBetween :: (Int, Int) -> (Int, Int) -> Span sourceSpanBetween (s1, e1) (s2, e2) = Span (Pos s1 e1) (Pos s2 e2) blankDiff :: Diff' -blankDiff = copy (pure arrayInfo) (Indexed [ inserting (Term $ literalInfo :< Leaf "\"a\"") ]) +blankDiff = copy (pure arrayInfo) (Indexed [ inserting (Term $ literalInfo `In` Leaf "\"a\"") ]) where arrayInfo = Nothing :. Range 0 3 :. ArrayLiteral :. sourceSpanBetween (1, 1) (1, 5) :. Nil literalInfo = Nothing :. Range 1 2 :. StringLiteral :. sourceSpanBetween (1, 2) (1, 4) :. Nil From 96323a909538b1dd7c7cbca4ae58e669fd30f754 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Sep 2017 16:43:23 -0400 Subject: [PATCH 108/113] Use termIn widely. --- src/Data/Syntax.hs | 2 +- src/Data/Syntax/Algebra.hs | 2 +- src/Diff.hs | 2 +- src/Language.hs | 14 +++++++------- src/Language/Markdown.hs | 2 +- src/Language/Ruby.hs | 8 ++++---- src/Parser.hs | 4 ++-- src/RWS.hs | 8 ++++---- src/TreeSitter.hs | 6 +++--- 9 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index b87e1df5a..a9c5e7adb 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -32,7 +32,7 @@ makeTerm a = makeTerm' a . inj -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a -makeTerm' a f = Term (In (sconcat (a :| (termAnnotation . unTerm <$> toList f))) f) +makeTerm' a f = termIn (sconcat (a :| (termAnnotation . unTerm <$> toList f))) f -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index 6535995db..6804d4656 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/src/Data/Syntax/Algebra.hs @@ -33,7 +33,7 @@ decoratorWithAlgebra :: Functor f => RAlgebra (Base (Term f (Record fs))) (Term f (Record fs)) a -- ^ An R-algebra on terms. -> Term f (Record fs) -- ^ A term to decorate with values produced by the R-algebra. -> Term f (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra. -decoratorWithAlgebra alg = para $ \ c@(In a f) -> Term (In (alg (fmap (second (rhead . extract)) c) :. a) (fmap snd f)) +decoratorWithAlgebra alg = para $ \ c@(In a f) -> termIn (alg (fmap (second (rhead . extract)) c) :. a) (fmap snd f) newtype Identifier = Identifier ByteString diff --git a/src/Diff.hs b/src/Diff.hs index 01de6e775..22a42ca8b 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -44,7 +44,7 @@ diffPatches = cata $ \ diff -> case diff of -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: Mergeable syntax => (Patch (Term syntax annotation) -> Maybe (Term syntax annotation)) -> (Both annotation -> annotation) -> Diff syntax annotation -> Maybe (Term syntax annotation) mergeMaybe transform extractAnnotation = cata algebra - where algebra (Copy annotations syntax) = Term . (In (extractAnnotation annotations)) <$> sequenceAlt syntax + where algebra (Copy annotations syntax) = termIn (extractAnnotation annotations) <$> sequenceAlt syntax algebra (Patch patch) = transform patch -- | Recover the before state of a diff. diff --git a/src/Language.hs b/src/Language.hs index 457b8b1c9..7d0c04bd5 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -38,19 +38,19 @@ languageForType mediaType = case mediaType of toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) toVarDeclOrAssignment child = case unwrap child of - S.Indexed [child', assignment] -> Term (In (setCategory (extract child) VarAssignment) (S.VarAssignment [child'] assignment)) - S.Indexed [child'] -> Term (In (setCategory (extract child) VarDecl) (S.VarDecl [child'])) - S.VarDecl _ -> Term (In (setCategory (extract child) VarDecl) (unwrap child)) + S.Indexed [child', assignment] -> termIn (setCategory (extract child) VarAssignment) (S.VarAssignment [child'] assignment) + S.Indexed [child'] -> termIn (setCategory (extract child) VarDecl) (S.VarDecl [child']) + S.VarDecl _ -> termIn (setCategory (extract child) VarDecl) (unwrap child) S.VarAssignment _ _ -> child _ -> toVarDecl child toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields) -toVarDecl child = Term (In (setCategory (extract child) VarDecl) (S.VarDecl [child])) +toVarDecl child = termIn (setCategory (extract child) VarDecl) (S.VarDecl [child]) toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)] -toTuple child | S.Indexed [key,value] <- unwrap child = [Term (In (extract child) (S.Pair key value))] -toTuple child | S.Fixed [key,value] <- unwrap child = [Term (In (extract child) (S.Pair key value))] -toTuple child | S.Leaf c <- unwrap child = [Term (In (extract child) (S.Comment c))] +toTuple child | S.Indexed [key,value] <- unwrap child = [termIn (extract child) (S.Pair key value)] +toTuple child | S.Fixed [key,value] <- unwrap child = [termIn (extract child) (S.Pair key value)] +toTuple child | S.Leaf c <- unwrap child = [termIn (extract child) (S.Comment c)] toTuple child = pure child toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index 5a328eadd..5aa10cc1e 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -54,7 +54,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT toTerm within withinSpan (Node position t children) = let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position span = maybe withinSpan toSpan position - in Term (In (A.Node (toGrammar t) range span) (In t (toTerm range span <$> children))) + in termIn (A.Node (toGrammar t) range span) (In t (toTerm range span <$> children)) toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index 9a62c368b..26eac68ba 100644 --- a/src/Language/Ruby.hs +++ b/src/Language/Ruby.hs @@ -57,10 +57,10 @@ termAssignment _ category children -> Just $ S.FunctionCall fn [] (toList . unwrap =<< args) (Object, _ ) -> Just . S.Object Nothing $ foldMap toTuple children (Modifier If, [ lhs, condition ]) -> Just $ S.If condition [lhs] - (Modifier Unless, [lhs, rhs]) -> Just $ S.If (Term (In (setCategory (extract rhs) Negate) (S.Negate rhs))) [lhs] - (Unless, expr : rest) -> Just $ S.If (Term (In (setCategory (extract expr) Negate) (S.Negate expr))) rest - (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (Term (In (setCategory (extract rhs) Negate) (S.Negate rhs))) [lhs] - (Until, expr : rest) -> Just $ S.While (Term (In (setCategory (extract expr) Negate) (S.Negate expr))) rest + (Modifier Unless, [lhs, rhs]) -> Just $ S.If (termIn (setCategory (extract rhs) Negate) (S.Negate rhs)) [lhs] + (Unless, expr : rest) -> Just $ S.If (termIn (setCategory (extract expr) Negate) (S.Negate expr)) rest + (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (termIn (setCategory (extract rhs) Negate) (S.Negate rhs)) [lhs] + (Until, expr : rest) -> Just $ S.While (termIn (setCategory (extract expr) Negate) (S.Negate expr)) rest (Elsif, condition : body ) -> Just $ S.If condition body (SubscriptAccess, [ base, element ]) -> Just $ S.SubscriptAccess base element (For, lhs : expr : rest ) -> Just $ S.For [lhs, expr] rest diff --git a/src/Parser.hs b/src/Parser.hs index 60a5bc2f2..7d249ac24 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -78,5 +78,5 @@ markdownParser = AssignmentParser MarkdownParser Markdown.assignment -- | A fallback parser that treats a file simply as rows of strings. lineByLineParser :: Source -> SyntaxTerm DefaultFields -lineByLineParser source = Term (In (totalRange source :. Program :. totalSpan source :. Nil) (Indexed (zipWith toLine [1..] (sourceLineRanges source)))) - where toLine line range = Term (In (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) (Leaf (toText (slice range source)))) +lineByLineParser source = termIn (totalRange source :. Program :. totalSpan source :. Nil) (Indexed (zipWith toLine [1..] (sourceLineRanges source))) + where toLine line range = termIn (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) (Leaf (toText (slice range source))) diff --git a/src/RWS.hs b/src/RWS.hs index beafa1369..a526c889f 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -220,7 +220,7 @@ featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term) eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields) -eraseFeatureVector (Term.Term (In record functor)) = Term.Term (In (setFeatureVector record nullFeatureVector) functor) +eraseFeatureVector (Term.Term (In record functor)) = termIn (setFeatureVector record nullFeatureVector) functor nullFeatureVector :: FeatureVector nullFeatureVector = listArray (0, 0) [0] @@ -254,7 +254,7 @@ featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields labe featureVectorDecorator getLabel p q d = cata collect . pqGramDecorator getLabel p q - where collect (In (gram :. rest) functor) = Term.Term (In (foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) functor) + where collect (In (gram :. rest) functor) = termIn (foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) functor addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector addSubtermVector v term = addVectors v (rhead (extract term)) @@ -272,7 +272,7 @@ pqGramDecorator pqGramDecorator getLabel p q = cata algebra where algebra term = let label = getLabel term in - Term.Term (In (gram label :. termAnnotation term) (assignParentAndSiblingLabels (termOut term) label)) + termIn (gram label :. termAnnotation term) (assignParentAndSiblingLabels (termOut term) label) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) @@ -283,7 +283,7 @@ pqGramDecorator getLabel p q = cata algebra assignLabels label (Term.Term (In (gram :. rest) functor)) = do labels <- get put (drop 1 labels) - pure $! Term.Term (In (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) functor) + pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) functor siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label] siblingLabels = foldMap (base . rhead . extract) padToSize n list = take n (list <> repeat empty) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 2558f4b6a..3e3145dfb 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -109,7 +109,7 @@ nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos no assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) assignTerm language source annotation children allChildren = case assignTermByLanguage source (category annotation) children of - Just a -> pure (Term (In annotation a)) + Just a -> pure (termIn annotation a) _ -> defaultTermAssignment source annotation children allChildren where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) assignTermByLanguage = case languageForTSLanguage language of @@ -155,7 +155,7 @@ defaultTermAssignment source annotation children allChildren [_, Other t] | t `elem` ["--", "++"] -> MathOperator _ -> Operator - pure (Term (In (setCategory annotation c) (S.Operator cs))) + pure (termIn (setCategory annotation c) (S.Operator cs)) (Other "binary_expression", _) -> do cs <- allChildren @@ -166,7 +166,7 @@ defaultTermAssignment source annotation children allChildren | s `elem` ["&&", "||"] -> BooleanOperator | s `elem` [">>", ">>=", ">>>", ">>>=", "<<", "<<=", "&", "^", "|"] -> BitwiseOperator _ -> Operator - pure (Term (In (setCategory annotation c) (S.Operator cs))) + pure (termIn (setCategory annotation c) (S.Operator cs)) (_, []) -> toTerm $ S.Leaf (toText source) (_, children) -> toTerm $ S.Indexed children From 026efbc1ec6befad49b1b26fdcddebd8f2c9a908 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 12 Sep 2017 10:26:26 -0700 Subject: [PATCH 109/113] Add pretty-show and hscolour --- semantic-diff.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 486d44913..2d5dce057 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -125,6 +125,8 @@ library , tree-sitter-python , tree-sitter-ruby , tree-sitter-typescript + , pretty-show + , hscolour default-language: Haskell2010 default-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, RecordWildCards, StrictData ghc-options: -Wall -fno-warn-name-shadowing -O -j From 3f7755b9e892db825c7799a0564aa80307621fb5 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 12 Sep 2017 13:14:35 -0700 Subject: [PATCH 110/113] Add .ghci-template file --- .ghci-template | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 .ghci-template diff --git a/.ghci-template b/.ghci-template new file mode 100644 index 000000000..147266626 --- /dev/null +++ b/.ghci-template @@ -0,0 +1,23 @@ +:set prompt "\ESC[1;36m\STXλ: \ESC[m\STX" + +:def pretty \_ -> return ("import Text.Show.Pretty (pPrint, ppShow)\nimport Language.Haskell.HsColour\nimport Language.Haskell.HsColour.Colourise\nlet color = putStrLn . hscolour TTY defaultColourPrefs False False \"\" False . ppShow\n:set -interactive-print color") +:def no-pretty \_ -> return (":set -interactive-print System.IO.print") + +:def re \_ -> return (":r\n:pretty") + +:{ +assignmentExample lang = case lang of + "Python" -> mk "py" "python" + "Go" -> mk "go" "go" + "Ruby" -> mk "rb" "ruby" + "JavaScript" -> mk "js" "typescript" + "TypeScript" -> mk "ts" "typescript" + "Haskell" -> mk "hs" "haskell" + "Markdown" -> mk "md" "markdown" + "JSON" -> mk "json" "json" + _ -> mk "" "" + where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parser\nimport Semantic.Task\nimport Semantic.Util") +:} + +:def assignment assignmentExample + From a6cbdab2e953968ba6b8476c62b5e658cf87ca0e Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 12 Sep 2017 15:40:24 -0700 Subject: [PATCH 111/113] :fire: prettyprint --- .gitmodules | 3 -- cabal.project | 2 +- semantic-diff.cabal | 2 - src/Category.hs | 4 -- src/Data/Functor/Classes/Pretty/Generic.hs | 49 ---------------------- src/Data/Range.hs | 4 -- src/Data/Record.hs | 8 ---- src/Data/Span.hs | 7 ---- src/Data/Syntax.hs | 18 -------- src/Data/Syntax/Comment.hs | 5 --- src/Data/Syntax/Declaration.hs | 11 ----- src/Data/Syntax/Expression.hs | 10 ----- src/Data/Syntax/Literal.hs | 29 ------------- src/Data/Syntax/Markup.hs | 32 -------------- src/Data/Syntax/Statement.hs | 23 ---------- src/Data/Syntax/Type.hs | 3 -- src/Diff.hs | 9 ---- src/Language/Python/Syntax.hs | 3 -- src/Patch.hs | 6 --- src/Semantic/Util.hs | 4 -- src/Syntax.hs | 3 -- src/Term.hs | 13 ------ vendor/prettyprinter | 1 - 23 files changed, 1 insertion(+), 248 deletions(-) delete mode 100644 src/Data/Functor/Classes/Pretty/Generic.hs delete mode 160000 vendor/prettyprinter diff --git a/.gitmodules b/.gitmodules index 4057676c3..a51ba2fb2 100644 --- a/.gitmodules +++ b/.gitmodules @@ -25,6 +25,3 @@ [submodule "vendor/freer-cofreer"] path = vendor/freer-cofreer url = https://github.com/robrix/freer-cofreer.git -[submodule "vendor/prettyprinter"] - path = vendor/prettyprinter - url = https://github.com/robrix/prettyprinter.git diff --git a/cabal.project b/cabal.project index 76859f12f..dd75d0e82 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,3 @@ -packages: ./ vendor/*/ vendor/haskell-tree-sitter/languages/*/ vendor/prettyprinter/*/ +packages: ./ vendor/*/ vendor/haskell-tree-sitter/languages/*/ jobs: $ncpus diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 2d5dce057..8388f0aaa 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -21,7 +21,6 @@ library , Data.Error , Data.Functor.Both , Data.Functor.Classes.Eq.Generic - , Data.Functor.Classes.Pretty.Generic , Data.Functor.Classes.Show.Generic , Data.Functor.Listable , Data.Mergeable @@ -109,7 +108,6 @@ library , optparse-applicative , parallel , parsers - , prettyprinter , recursion-schemes , semigroups , split diff --git a/src/Category.hs b/src/Category.hs index a8c14b8ba..85fea468e 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -7,7 +7,6 @@ import Control.DeepSeq import Data.Functor.Listable import Data.Hashable import Data.Text (Text) -import Data.Text.Prettyprint.Doc import GHC.Generics -- | A standardized category of AST node. Used to determine the semantics for @@ -364,6 +363,3 @@ instance Listable Category where -- \/ cons0 (Modifier If) \/ cons0 SingletonMethod -- \/ cons0 (Other "other") - -instance Pretty Category where - pretty = pretty . show diff --git a/src/Data/Functor/Classes/Pretty/Generic.hs b/src/Data/Functor/Classes/Pretty/Generic.hs deleted file mode 100644 index 2281beaf8..000000000 --- a/src/Data/Functor/Classes/Pretty/Generic.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Data.Functor.Classes.Pretty.Generic -( module Pretty -, genericLiftPretty -) where - -import Data.Text.Prettyprint.Doc as Pretty -import GHC.Generics - -genericLiftPretty :: (Generic1 f, GPretty1 (Rep1 f)) => (a -> Doc ann) -> ([a] -> Doc ann) -> f a -> Doc ann -genericLiftPretty pretty' prettyList' = gliftPretty pretty' prettyList' . from1 - - -class GPretty1 f where - gliftPretty :: (a -> Doc ann) -> ([a] -> Doc ann) -> f a -> Doc ann - gcollectPretty :: (a -> Doc ann) -> ([a] -> Doc ann) -> f a -> [Doc ann] - gcollectPretty p pl a = [gliftPretty p pl a] - -instance GPretty1 U1 where - gliftPretty _ _ _ = emptyDoc - -instance GPretty1 Par1 where - gliftPretty p _ (Par1 a) = p a - -instance Pretty c => GPretty1 (K1 i c) where - gliftPretty _ _ (K1 a) = pretty a - -instance Pretty1 f => GPretty1 (Rec1 f) where - gliftPretty p pl (Rec1 a) = liftPretty p pl a - -instance GPretty1 f => GPretty1 (M1 D c f) where - gliftPretty p pl (M1 a) = gliftPretty p pl a - -instance (Constructor c, GPretty1 f) => GPretty1 (M1 C c f) where - gliftPretty p pl m = nest 2 (vsep (pretty (conName m) : gcollectPretty p pl (unM1 m))) - -instance GPretty1 f => GPretty1 (M1 S c f) where - gliftPretty p pl (M1 a) = gliftPretty p pl a - -instance (GPretty1 f, GPretty1 g) => GPretty1 (f :+: g) where - gliftPretty p pl (L1 l) = gliftPretty p pl l - gliftPretty p pl (R1 r) = gliftPretty p pl r - -instance (GPretty1 f, GPretty1 g) => GPretty1 (f :*: g) where - gliftPretty p pl (a :*: b) = gliftPretty p pl a <+> gliftPretty p pl b - gcollectPretty p pl (a :*: b) = gcollectPretty p pl a <> gcollectPretty p pl b - -instance (Pretty1 f, GPretty1 g) => GPretty1 (f :.: g) where - gliftPretty p pl (Comp1 a) = liftPretty (gliftPretty p pl) (list . map (gliftPretty p pl)) a diff --git a/src/Data/Range.hs b/src/Data/Range.hs index 3eef78cf1..7b77c4c15 100644 --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -8,7 +8,6 @@ module Data.Range import Control.DeepSeq import Data.Semigroup -import Data.Text.Prettyprint.Doc import GHC.Generics import Test.LeanCheck @@ -39,6 +38,3 @@ instance Ord Range where instance Listable Range where tiers = cons2 Range - -instance Pretty Range where - pretty (Range from to) = pretty from <> pretty '-' <> pretty to diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 9c113042f..d61bc5e61 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -5,7 +5,6 @@ import Control.DeepSeq import Data.Kind import Data.Functor.Listable import Data.Semigroup -import Data.Text.Prettyprint.Doc -- | A type-safe, extensible record structure. -- | @@ -88,10 +87,3 @@ instance (Semigroup head, Semigroup (Record tail)) => Semigroup (Record (head ': instance Semigroup (Record '[]) where _ <> _ = Nil - - -instance ConstrainAll Pretty ts => Pretty (Record ts) where - pretty = tupled . collectPretty - where collectPretty :: ConstrainAll Pretty ts => Record ts -> [Doc ann] - collectPretty Nil = [] - collectPretty (first :. rest) = pretty first : collectPretty rest diff --git a/src/Data/Span.hs b/src/Data/Span.hs index 4ce614ea5..fd050305b 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -14,7 +14,6 @@ import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import Data.Hashable (Hashable) import Data.Semigroup -import Data.Text.Prettyprint.Doc import GHC.Generics import Test.LeanCheck @@ -63,9 +62,3 @@ instance Listable Pos where instance Listable Span where tiers = cons2 Span - -instance Pretty Pos where - pretty Pos{..} = pretty posLine <> colon <> pretty posColumn - -instance Pretty Span where - pretty Span{..} = pretty spanStart <> pretty '-' <> pretty spanEnd diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index cdd72387b..c62f73923 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -13,13 +13,11 @@ import Data.Function ((&)) import Data.Ix import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic import Data.Record import Data.Semigroup import Data.Span import qualified Data.Syntax.Assignment as Assignment -import Data.Text.Encoding (decodeUtf8With) import Data.Union import GHC.Generics import GHC.Stack @@ -107,15 +105,11 @@ newtype Leaf a = Leaf { leafContent :: ByteString } instance Eq1 Leaf where liftEq = genericLiftEq instance Show1 Leaf where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Leaf where - liftPretty _ _ (Leaf s) = pretty ("Leaf" :: String) <+> prettyBytes s - newtype Branch a = Branch { branchElements :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Branch where liftEq = genericLiftEq instance Show1 Branch where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Branch where liftPretty = genericLiftPretty -- Common @@ -127,15 +121,11 @@ newtype Identifier a = Identifier ByteString instance Eq1 Identifier where liftEq = genericLiftEq instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Identifier where - liftPretty _ _ (Identifier s) = pretty ("Identifier" :: String) <+> prettyBytes s - newtype Program a = Program [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Program where liftEq = genericLiftEq instance Show1 Program where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Program where liftPretty = genericLiftPretty -- | Empty syntax, with essentially no-op semantics. @@ -146,7 +136,6 @@ data Empty a = Empty instance Eq1 Empty where liftEq _ _ _ = True instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty" -instance Pretty1 Empty where liftPretty = genericLiftPretty -- | Syntax representing a parsing or assignment error. @@ -156,9 +145,6 @@ data Error a = Error { errorCallStack :: [([Char], SrcLoc)], errorExpected :: [S instance Eq1 Error where liftEq = genericLiftEq instance Show1 Error where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Error where - liftPretty _ pl (Error cs e a c) = nest 2 (concatWith (\ x y -> x <> hardline <> y) [ pretty ("Error" :: String), pretty (Error.showExpectation False e a ""), pretty (Error.showCallStack False (fromCallSiteList cs) ""), pl c]) - errorSyntax :: Error.Error String -> [a] -> Error a errorSyntax Error.Error{..} = Error (getCallStack callStack) errorExpected errorActual @@ -171,7 +157,3 @@ data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a } instance Eq1 Context where liftEq = genericLiftEq instance Show1 Context where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Context where liftPretty = genericLiftPretty - -prettyBytes :: ByteString -> Doc ann -prettyBytes = pretty . decodeUtf8With (\ _ -> ('\xfffd' <$)) diff --git a/src/Data/Syntax/Comment.hs b/src/Data/Syntax/Comment.hs index 41a991900..1204e95a1 100644 --- a/src/Data/Syntax/Comment.hs +++ b/src/Data/Syntax/Comment.hs @@ -5,9 +5,7 @@ import Algorithm import Data.Align.Generic import Data.ByteString (ByteString) import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic -import Data.Syntax (prettyBytes) import GHC.Generics -- | An unnested comment (line or block). @@ -17,9 +15,6 @@ newtype Comment a = Comment { commentContent :: ByteString } instance Eq1 Comment where liftEq = genericLiftEq instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Comment where - liftPretty _ _ (Comment c) = pretty ("Comment" :: String) <+> prettyBytes c - -- TODO: nested comment types -- TODO: documentation comment types -- TODO: literate programming comment types? alternatively, consider those as markup diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 9c9f1b021..8f5c41e83 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -4,7 +4,6 @@ module Data.Syntax.Declaration where import Algorithm import Data.Align.Generic import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic import GHC.Generics @@ -13,7 +12,6 @@ data Function a = Function { functionName :: !a, functionParameters :: ![a], fun instance Eq1 Function where liftEq = genericLiftEq instance Show1 Function where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Function where liftPretty = genericLiftPretty -- TODO: How should we represent function types, where applicable? @@ -22,7 +20,6 @@ data Method a = Method { methodReceiver :: !a, methodName :: !a, methodParameter instance Eq1 Method where liftEq = genericLiftEq instance Show1 Method where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Method where liftPretty = genericLiftPretty -- TODO: Should we replace this with Function and differentiate by context? -- TODO: How should we distinguish class/instance methods? @@ -32,7 +29,6 @@ data Variable a = Variable { variableName :: !a, variableType :: !a, variableVal instance Eq1 Variable where liftEq = genericLiftEq instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Variable where liftPretty = genericLiftPretty data Class a = Class { classIdentifier :: !a, classSuperclasses :: ![a], classBody :: ![a] } @@ -40,7 +36,6 @@ data Class a = Class { classIdentifier :: !a, classSuperclasses :: ![a], classBo instance Eq1 Class where liftEq = genericLiftEq instance Show1 Class where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Class where liftPretty = genericLiftPretty data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] } @@ -48,7 +43,6 @@ data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] } instance Eq1 Module where liftEq = genericLiftEq instance Show1 Module where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Module where liftPretty = genericLiftPretty -- | A decorator in Python @@ -57,7 +51,6 @@ data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: instance Eq1 Decorator where liftEq = genericLiftEq instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Decorator where liftPretty = genericLiftPretty -- TODO: Generics, constraints. @@ -68,7 +61,6 @@ data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] } instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Data.Syntax.Declaration.Datatype where liftPretty = genericLiftPretty -- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift. data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] } @@ -76,7 +68,6 @@ data Constructor a = Constructor { constructorName :: !a, constructorFields :: ! instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Data.Syntax.Declaration.Constructor where liftPretty = genericLiftPretty -- | Comprehension (e.g. ((a for b in c if a()) in Python) @@ -85,7 +76,6 @@ data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBo instance Eq1 Comprehension where liftEq = genericLiftEq instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Comprehension where liftPretty = genericLiftPretty -- | Import declarations. @@ -94,4 +84,3 @@ data Import a = Import { importContent :: ![a] } instance Eq1 Import where liftEq = genericLiftEq instance Show1 Import where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Import where liftPretty = genericLiftPretty diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 4bf66e959..3fb78ef4d 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -4,7 +4,6 @@ module Data.Syntax.Expression where import Algorithm import Data.Align.Generic import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic import GHC.Generics @@ -14,7 +13,6 @@ data Call a = Call { callFunction :: !a, callParams :: ![a], callBlock :: !a } instance Eq1 Call where liftEq = genericLiftEq instance Show1 Call where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Call where liftPretty = genericLiftPretty data Comparison a @@ -28,7 +26,6 @@ data Comparison a instance Eq1 Comparison where liftEq = genericLiftEq instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Comparison where liftPretty = genericLiftPretty -- | Binary arithmetic operators. @@ -44,7 +41,6 @@ data Arithmetic a instance Eq1 Arithmetic where liftEq = genericLiftEq instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Arithmetic where liftPretty = genericLiftPretty -- | Boolean operators. data Boolean a @@ -55,7 +51,6 @@ data Boolean a instance Eq1 Boolean where liftEq = genericLiftEq instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Boolean where liftPretty = genericLiftPretty -- | Bitwise operators. data Bitwise a @@ -69,7 +64,6 @@ data Bitwise a instance Eq1 Bitwise where liftEq = genericLiftEq instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Bitwise where liftPretty = genericLiftPretty -- | Member Access (e.g. a.b) data MemberAccess a @@ -78,7 +72,6 @@ data MemberAccess a instance Eq1 MemberAccess where liftEq = genericLiftEq instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 MemberAccess where liftPretty = genericLiftPretty -- | Subscript (e.g a[1]) data Subscript a @@ -88,7 +81,6 @@ data Subscript a instance Eq1 Subscript where liftEq = genericLiftEq instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Subscript where liftPretty = genericLiftPretty -- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop)) data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a } @@ -96,7 +88,6 @@ data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, instance Eq1 Enumeration where liftEq = genericLiftEq instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Enumeration where liftPretty = genericLiftPretty -- | ScopeResolution (e.g. import a.b in Python or a::b in C++) data ScopeResolution a @@ -105,4 +96,3 @@ data ScopeResolution a instance Eq1 ScopeResolution where liftEq = genericLiftEq instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 ScopeResolution where liftPretty = genericLiftPretty diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 3da5fd25c..dbdbcf85d 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -5,9 +5,7 @@ import Algorithm import Data.Align.Generic import Data.ByteString (ByteString) import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic -import Data.Syntax (prettyBytes) import GHC.Generics import Prelude @@ -24,7 +22,6 @@ false = Boolean False instance Eq1 Boolean where liftEq = genericLiftEq instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Boolean where liftPretty = genericLiftPretty -- Numeric @@ -36,9 +33,6 @@ newtype Integer a = Integer { integerContent :: ByteString } instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Data.Syntax.Literal.Integer where - liftPretty _ _ (Integer s) = pretty ("Integer" :: Prelude.String) <+> prettyBytes s - -- TODO: Should IntegerLiteral hold an Integer instead of a ByteString? -- TODO: Do we care about differentiating between hex/octal/decimal/binary integer literals? -- TODO: Consider a Numeric datatype with FloatingPoint/Integral/etc constructors. @@ -50,9 +44,6 @@ newtype Float a = Float { floatContent :: ByteString } instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Data.Syntax.Literal.Float where - liftPretty _ _ (Float s) = pretty ("Float" :: Prelude.String) <+> prettyBytes s - -- Rational literals e.g. `2/3r` newtype Rational a = Rational ByteString deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) @@ -60,9 +51,6 @@ newtype Rational a = Rational ByteString instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Data.Syntax.Literal.Rational where - liftPretty _ _ (Rational s) = pretty ("Rational" :: Prelude.String) <+> prettyBytes s - -- Complex literals e.g. `3 + 2i` newtype Complex a = Complex ByteString deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) @@ -70,9 +58,6 @@ newtype Complex a = Complex ByteString instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq instance Show1 Data.Syntax.Literal.Complex where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Complex where - liftPretty _ _ (Complex s) = pretty ("Complex" :: Prelude.String) <+> prettyBytes s - -- Strings, symbols @@ -81,7 +66,6 @@ newtype String a = String { stringElements :: [a] } instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Data.Syntax.Literal.String where liftPretty = genericLiftPretty -- TODO: Should string literal bodies include escapes too? @@ -91,7 +75,6 @@ newtype InterpolationElement a = InterpolationElement { interpolationBody :: a } instance Eq1 InterpolationElement where liftEq = genericLiftEq instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 InterpolationElement where liftPretty = genericLiftPretty -- | A sequence of textual contents within a string literal. @@ -101,15 +84,11 @@ newtype TextElement a = TextElement { textElementContent :: ByteString } instance Eq1 TextElement where liftEq = genericLiftEq instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 TextElement where - liftPretty _ _ (TextElement s) = pretty ("TextElement" :: Prelude.String) <+> prettyBytes s - data Null a = Null deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Null where liftEq = genericLiftEq instance Show1 Null where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Null where liftPretty = genericLiftPretty newtype Symbol a = Symbol { symbolContent :: ByteString } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) @@ -117,9 +96,6 @@ newtype Symbol a = Symbol { symbolContent :: ByteString } instance Eq1 Symbol where liftEq = genericLiftEq instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Symbol where - liftPretty _ _ (Symbol s) = pretty ("Symbol" :: Prelude.String) <+> prettyBytes s - -- TODO: Heredoc-style string literals? -- TODO: Character literals. -- TODO: Regular expressions. @@ -132,7 +108,6 @@ newtype Array a = Array { arrayElements :: [a] } instance Eq1 Array where liftEq = genericLiftEq instance Show1 Array where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Array where liftPretty = genericLiftPretty newtype Hash a = Hash { hashElements :: [a] } @@ -140,14 +115,12 @@ newtype Hash a = Hash { hashElements :: [a] } instance Eq1 Hash where liftEq = genericLiftEq instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Hash where liftPretty = genericLiftPretty data KeyValue a = KeyValue { key :: !a, value :: !a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 KeyValue where liftEq = genericLiftEq instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 KeyValue where liftPretty = genericLiftPretty newtype Tuple a = Tuple { tupleContents :: [a]} @@ -155,7 +128,6 @@ newtype Tuple a = Tuple { tupleContents :: [a]} instance Eq1 Tuple where liftEq = genericLiftEq instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Tuple where liftPretty = genericLiftPretty newtype Set a = Set { setElements :: [a] } @@ -163,7 +135,6 @@ newtype Set a = Set { setElements :: [a] } instance Eq1 Set where liftEq = genericLiftEq instance Show1 Set where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Set where liftPretty = genericLiftPretty -- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”? -- TODO: Function literals (lambdas, procs, anonymous functions, what have you). diff --git a/src/Data/Syntax/Markup.hs b/src/Data/Syntax/Markup.hs index 93bc7e298..953e5b61d 100644 --- a/src/Data/Syntax/Markup.hs +++ b/src/Data/Syntax/Markup.hs @@ -5,10 +5,7 @@ import Algorithm import Data.Align.Generic import Data.ByteString (ByteString) import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic -import Data.Maybe (catMaybes) -import Data.Syntax (prettyBytes) import GHC.Generics @@ -17,7 +14,6 @@ newtype Document a = Document [a] instance Eq1 Document where liftEq = genericLiftEq instance Show1 Document where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Document where liftPretty = genericLiftPretty -- Block elements @@ -27,49 +23,42 @@ newtype Paragraph a = Paragraph [a] instance Eq1 Paragraph where liftEq = genericLiftEq instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Paragraph where liftPretty = genericLiftPretty data Section a = Section { sectionLevel :: Int, sectionHeading :: a, sectionContent :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Section where liftEq = genericLiftEq instance Show1 Section where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Section where liftPretty = genericLiftPretty data Heading a = Heading { headingLevel :: Int, headingContent :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Heading where liftEq = genericLiftEq instance Show1 Heading where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Heading where liftPretty = genericLiftPretty newtype UnorderedList a = UnorderedList [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 UnorderedList where liftEq = genericLiftEq instance Show1 UnorderedList where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 UnorderedList where liftPretty = genericLiftPretty newtype OrderedList a = OrderedList [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 OrderedList where liftEq = genericLiftEq instance Show1 OrderedList where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 OrderedList where liftPretty = genericLiftPretty newtype BlockQuote a = BlockQuote [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 BlockQuote where liftEq = genericLiftEq instance Show1 BlockQuote where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 BlockQuote where liftPretty = genericLiftPretty data ThematicBreak a = ThematicBreak deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 ThematicBreak where liftEq = genericLiftEq instance Show1 ThematicBreak where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 ThematicBreak where liftPretty = genericLiftPretty data HTMLBlock a = HTMLBlock ByteString deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) @@ -77,29 +66,23 @@ data HTMLBlock a = HTMLBlock ByteString instance Eq1 HTMLBlock where liftEq = genericLiftEq instance Show1 HTMLBlock where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 HTMLBlock where - liftPretty _ _ (HTMLBlock s) = pretty ("HTMLBlock" :: String) <+> prettyBytes s - newtype Table a = Table [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Table where liftEq = genericLiftEq instance Show1 Table where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Table where liftPretty = genericLiftPretty newtype TableRow a = TableRow [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 TableRow where liftEq = genericLiftEq instance Show1 TableRow where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 TableRow where liftPretty = genericLiftPretty newtype TableCell a = TableCell [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 TableCell where liftEq = genericLiftEq instance Show1 TableCell where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 TableCell where liftPretty = genericLiftPretty -- Inline elements @@ -109,14 +92,12 @@ newtype Strong a = Strong [a] instance Eq1 Strong where liftEq = genericLiftEq instance Show1 Strong where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Strong where liftPretty = genericLiftPretty newtype Emphasis a = Emphasis [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Emphasis where liftEq = genericLiftEq instance Show1 Emphasis where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Emphasis where liftPretty = genericLiftPretty newtype Text a = Text ByteString deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) @@ -124,45 +105,32 @@ newtype Text a = Text ByteString instance Eq1 Text where liftEq = genericLiftEq instance Show1 Text where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Text where - liftPretty _ _ (Text s) = pretty ("Text" :: String) <+> prettyBytes s - data Link a = Link { linkURL :: ByteString, linkTitle :: Maybe ByteString } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Link where liftEq = genericLiftEq instance Show1 Link where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Link where - liftPretty _ _ (Link u t) = pretty ("Link" :: String) <+> prettyBytes u <+> liftPretty prettyBytes (list . map prettyBytes) t - data Image a = Image { imageURL :: ByteString, imageTitle :: Maybe ByteString } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Image where liftEq = genericLiftEq instance Show1 Image where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Image where - liftPretty _ _ (Image u t) = pretty ("Image" :: String) <+> prettyBytes u <+> liftPretty prettyBytes (list . map prettyBytes) t - data Code a = Code { codeLanguage :: Maybe ByteString, codeContent :: ByteString } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Code where liftEq = genericLiftEq instance Show1 Code where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Code where - liftPretty _ _ (Code l c) = nest 2 (vsep (catMaybes [Just (pretty ("Code" :: String)), fmap prettyBytes l, Just (prettyBytes c)])) data LineBreak a = LineBreak deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 LineBreak where liftEq = genericLiftEq instance Show1 LineBreak where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 LineBreak where liftPretty = genericLiftPretty newtype Strikethrough a = Strikethrough [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Strikethrough where liftEq = genericLiftEq instance Show1 Strikethrough where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Strikethrough where liftPretty = genericLiftPretty diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index f00e4fe65..5d79c4cdf 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -4,7 +4,6 @@ module Data.Syntax.Statement where import Algorithm import Data.Align.Generic import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic import GHC.Generics @@ -14,7 +13,6 @@ data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a } instance Eq1 If where liftEq = genericLiftEq instance Show1 If where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 If where liftPretty = genericLiftPretty -- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python. data Else a = Else { elseCondition :: !a, elseBody :: !a } @@ -22,7 +20,6 @@ data Else a = Else { elseCondition :: !a, elseBody :: !a } instance Eq1 Else where liftEq = genericLiftEq instance Show1 Else where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Else where liftPretty = genericLiftPretty -- TODO: Alternative definition would flatten if/else if/else chains: data If a = If ![(a, a)] !(Maybe a) @@ -32,7 +29,6 @@ data Match a = Match { matchSubject :: !a, matchPatterns :: !a } instance Eq1 Match where liftEq = genericLiftEq instance Show1 Match where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Match where liftPretty = genericLiftPretty -- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions. data Pattern a = Pattern { pattern :: !a, patternBody :: !a } @@ -40,7 +36,6 @@ data Pattern a = Pattern { pattern :: !a, patternBody :: !a } instance Eq1 Pattern where liftEq = genericLiftEq instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Pattern where liftPretty = genericLiftPretty -- | A let statement or local binding, like 'a as b' or 'let a = b'. data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a } @@ -48,7 +43,6 @@ data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a } instance Eq1 Let where liftEq = genericLiftEq instance Show1 Let where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Let where liftPretty = genericLiftPretty -- Assignment @@ -59,7 +53,6 @@ data Assignment a = Assignment { assignmentTarget :: !a, assignmentValue :: !a } instance Eq1 Assignment where liftEq = genericLiftEq instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Assignment where liftPretty = genericLiftPretty -- Returns @@ -69,42 +62,36 @@ newtype Return a = Return a instance Eq1 Return where liftEq = genericLiftEq instance Show1 Return where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Return where liftPretty = genericLiftPretty newtype Yield a = Yield a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Yield where liftEq = genericLiftEq instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Yield where liftPretty = genericLiftPretty newtype Break a = Break a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Break where liftEq = genericLiftEq instance Show1 Break where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Break where liftPretty = genericLiftPretty newtype Continue a = Continue a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Continue where liftEq = genericLiftEq instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Continue where liftPretty = genericLiftPretty newtype Retry a = Retry a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Retry where liftEq = genericLiftEq instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Retry where liftPretty = genericLiftPretty newtype NoOp a = NoOp a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 NoOp where liftEq = genericLiftEq instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 NoOp where liftPretty = genericLiftPretty -- Loops @@ -114,28 +101,24 @@ data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody : instance Eq1 For where liftEq = genericLiftEq instance Show1 For where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 For where liftPretty = genericLiftPretty data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 ForEach where liftEq = genericLiftEq instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 ForEach where liftPretty = genericLiftPretty data While a = While { whileCondition :: !a, whileBody :: !a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 While where liftEq = genericLiftEq instance Show1 While where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 While where liftPretty = genericLiftPretty data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 DoWhile where liftEq = genericLiftEq instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 DoWhile where liftPretty = genericLiftPretty -- Exception handling @@ -145,28 +128,24 @@ newtype Throw a = Throw a instance Eq1 Throw where liftEq = genericLiftEq instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Throw where liftPretty = genericLiftPretty data Try a = Try { tryBody :: !a, tryCatch :: ![a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Try where liftEq = genericLiftEq instance Show1 Try where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Try where liftPretty = genericLiftPretty data Catch a = Catch { catchException :: !a, catchBody :: !a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Catch where liftEq = genericLiftEq instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Catch where liftPretty = genericLiftPretty newtype Finally a = Finally a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Finally where liftEq = genericLiftEq instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Finally where liftPretty = genericLiftPretty -- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl). @@ -175,7 +154,6 @@ newtype ScopeEntry a = ScopeEntry [a] instance Eq1 ScopeEntry where liftEq = genericLiftEq instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 ScopeEntry where liftPretty = genericLiftPretty -- | ScopeExit (e.g. `END {}` block in Ruby or Perl). @@ -184,4 +162,3 @@ newtype ScopeExit a = ScopeExit [a] instance Eq1 ScopeExit where liftEq = genericLiftEq instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 ScopeExit where liftPretty = genericLiftPretty diff --git a/src/Data/Syntax/Type.hs b/src/Data/Syntax/Type.hs index 36d94b576..b2431b4d0 100644 --- a/src/Data/Syntax/Type.hs +++ b/src/Data/Syntax/Type.hs @@ -4,7 +4,6 @@ module Data.Syntax.Type where import Algorithm import Data.Align.Generic import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic import GHC.Generics @@ -13,11 +12,9 @@ data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a } instance Eq1 Annotation where liftEq = genericLiftEq instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Annotation where liftPretty = genericLiftPretty newtype Product a = Product { productElements :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable) instance Eq1 Product where liftEq = genericLiftEq instance Show1 Product where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Product where liftPretty = genericLiftPretty diff --git a/src/Diff.hs b/src/Diff.hs index 444c7979e..d6c6b5388 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -8,7 +8,6 @@ import qualified Control.Monad.Free as Free import qualified Control.Monad.Trans.Free as FreeF import Data.Bifunctor import Data.Functor.Both as Both -import Data.Functor.Classes.Pretty.Generic import Data.Mergeable import Data.Record import Patch @@ -64,11 +63,3 @@ free (FreeF.Pure a) = Free.Pure a runFree :: Free.Free f a -> FreeF.FreeF f a (Free.Free f a) runFree (Free.Free f) = FreeF.Free f runFree (Free.Pure a) = FreeF.Pure a - - -instance Pretty1 f => Pretty1 (Free.Free f) where - liftPretty p pl = go where go (Free.Pure a) = p a - go (Free.Free f) = liftPretty go (list . map (liftPretty p pl)) f - -instance (Pretty1 f, Pretty a) => Pretty (Free.Free f a) where - pretty = liftPretty pretty prettyList diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index c19849e76..22b323311 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -10,7 +10,6 @@ import Algorithm import Data.Align.Generic import Data.Functor (void) import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Classes.Show.Generic import Data.List.NonEmpty (some1) import Data.Maybe (fromMaybe) @@ -94,7 +93,6 @@ data Ellipsis a = Ellipsis instance Eq1 Ellipsis where liftEq = genericLiftEq instance Show1 Ellipsis where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Ellipsis where liftPretty = genericLiftPretty data Redirect a = Redirect !a !a @@ -102,7 +100,6 @@ data Redirect a = Redirect !a !a instance Eq1 Redirect where liftEq = genericLiftEq instance Show1 Redirect where liftShowsPrec = genericLiftShowsPrec -instance Pretty1 Redirect where liftPretty = genericLiftPretty -- | Assignment from AST in Python's grammar onto a program in Python's syntax. assignment :: Assignment diff --git a/src/Patch.hs b/src/Patch.hs index d67ced4a7..40af27f78 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -16,7 +16,6 @@ module Patch import Control.DeepSeq import Data.Align -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Listable import Data.These import GHC.Generics @@ -88,8 +87,3 @@ instance Crosswalk Patch where crosswalk f (Replace a b) = alignWith (these Delete Insert Replace) (f a) (f b) crosswalk f (Insert b) = Insert <$> f b crosswalk f (Delete a) = Delete <$> f a - -instance Pretty1 Patch where liftPretty = genericLiftPretty - -instance Pretty a => Pretty (Patch a) where - pretty = liftPretty pretty prettyList diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 7f9babef1..853050a4b 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,12 +1,8 @@ module Semantic.Util where import Data.Blob -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Util import Files -pp :: Pretty a => a -> IO () -pp = putDocW 100 . (<> line) . pretty file :: FilePath -> IO Blob file path = Files.readFile path (languageForFilePath path) diff --git a/src/Syntax.hs b/src/Syntax.hs index b04d80f69..ac319f4d4 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -6,7 +6,6 @@ import Data.Aeson import Data.Align.Generic import Data.Functor.Classes import Data.Functor.Classes.Eq.Generic -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Listable import Data.Mergeable import Data.Text (pack, Text) @@ -183,5 +182,3 @@ instance Listable recur => Listable (Syntax recur) where instance Eq1 Syntax where liftEq = genericLiftEq - -instance Pretty1 Syntax where liftPretty = genericLiftPretty diff --git a/src/Term.hs b/src/Term.hs index 918d3d304..f9ac226d5 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -19,13 +19,10 @@ import Control.DeepSeq import Control.Monad.Free import Data.Align.Generic import Data.Functor.Both -import Data.Functor.Classes.Pretty.Generic import Data.Functor.Foldable import Data.Maybe -import Data.Proxy import Data.Record import Data.These -import Data.Union import Syntax -- | A Term with an abstract syntax tree and an annotation. @@ -71,13 +68,3 @@ cofree (a CofreeF.:< f) = a Cofree.:< f runCofree :: Cofree.Cofree f a -> CofreeF.CofreeF f a (Cofree.Cofree f a) runCofree (a Cofree.:< f) = a CofreeF.:< f - - -instance Pretty1 f => Pretty1 (Cofree.Cofree f) where - liftPretty p pl = go where go (a Cofree.:< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f - -instance (Pretty1 f, Pretty a) => Pretty (Cofree.Cofree f a) where - pretty = liftPretty pretty prettyList - -instance Apply1 Pretty1 fs => Pretty1 (Union fs) where - liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) diff --git a/vendor/prettyprinter b/vendor/prettyprinter deleted file mode 160000 index ec0e4825b..000000000 --- a/vendor/prettyprinter +++ /dev/null @@ -1 +0,0 @@ -Subproject commit ec0e4825b18b5d43511396b03aac12b388c4ee02 From 9d2469a2bff10c1513059dd417dd86322167ae87 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 12 Sep 2017 15:40:44 -0700 Subject: [PATCH 112/113] Add pretty-show / colourised `pp` function --- src/Semantic/Util.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 853050a4b..57bcd5026 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,8 +1,14 @@ module Semantic.Util where import Data.Blob +import Language.Haskell.HsColour (hscolour, Output(TTY)) +import Language.Haskell.HsColour.Colourise (defaultColourPrefs) +import Text.Show.Pretty (ppShow) import Files +-- Produces colorized pretty-printed output for the terminal / GHCi. +pp :: Show a => a -> IO () +pp = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow file :: FilePath -> IO Blob file path = Files.readFile path (languageForFilePath path) From 725c2fcd301c900522841eb72c2fda8719cde7d5 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 12 Sep 2017 17:47:50 -0700 Subject: [PATCH 113/113] Import Semigroup; remove unused imports --- src/Diff.hs | 2 +- src/Term.hs | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index a0ab71e9b..cc92173da 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -12,7 +12,7 @@ import Data.Functor.Foldable hiding (fold) import Data.JSON.Fields import Data.Mergeable import Data.Record -import Data.Union +import Data.Semigroup((<>)) import Patch import Syntax import Term diff --git a/src/Term.hs b/src/Term.hs index 94e0ec803..1784c23e0 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -10,7 +10,6 @@ module Term , unwrap , hoistTerm , stripTerm -, liftPrettyUnion ) where import Control.Comonad @@ -22,9 +21,8 @@ import Data.Bitraversable import Data.Functor.Classes import Data.Functor.Foldable import Data.JSON.Fields -import Data.Proxy import Data.Record -import Data.Union +import Data.Semigroup ((<>)) import Syntax import Text.Show