From a296ec4ca3e626da63396e333eb374ae14ae2c3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 15:54:35 +0100 Subject: [PATCH 01/84] 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 02/84] 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 03/84] 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 04/84] 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 05/84] 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 06/84] 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 07/84] 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 08/84] 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 09/84] 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 10/84] 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 11/84] 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 12/84] 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 13/84] :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 14/84] :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 15/84] 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 16/84] 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 17/84] 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 18/84] 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 19/84] :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 20/84] :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 21/84] :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 22/84] 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 23/84] :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 24/84] :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 25/84] 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 26/84] :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 27/84] 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 28/84] 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 29/84] 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 30/84] 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 31/84] 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 32/84] 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 33/84] :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 34/84] 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 35/84] 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 36/84] 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 37/84] 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 38/84] :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 39/84] 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 40/84] 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 41/84] 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 42/84] 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 43/84] 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 44/84] 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 45/84] 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 46/84] 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 47/84] 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 48/84] 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 49/84] 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 50/84] 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 51/84] 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 52/84] 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 53/84] 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 54/84] 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 55/84] 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 56/84] 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 57/84] 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 58/84] 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 59/84] 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 60/84] 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 61/84] 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 62/84] 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 63/84] 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 64/84] 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 65/84] 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 66/84] 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 67/84] 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 68/84] 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 69/84] 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 70/84] 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 71/84] 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 72/84] 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 73/84] 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 74/84] 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 75/84] :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 76/84] :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 77/84] 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 78/84] 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 c29a9671f0165da5537e862bbdd5a58253b7f80f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Sep 2017 15:24:09 -0400 Subject: [PATCH 79/84] 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 80/84] 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 81/84] 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 82/84] :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 83/84] 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 84/84] 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