mirror of
https://github.com/github/semantic.git
synced 2024-12-27 17:05:33 +03:00
Merge pull request #1331 from github/specialized-terms-and-diffs
Specialized Terms and Diffs
This commit is contained in:
Rob Rix
GitHub
commit
7d31c314c0
4
HLint.hs
4
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" = termAnnotation . unTerm ==> extract
|
||||
error "use unwrap" = termOut . unTerm ==> unwrap
|
||||
|
||||
error "avoid head" = head
|
||||
where note = "head is partial; consider using Data.Maybe.listToMaybe"
|
||||
|
||||
@ -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
|
||||
@ -42,7 +41,6 @@ library
|
||||
, Data.Syntax.Markup
|
||||
, Data.Syntax.Statement
|
||||
, Data.Syntax.Type
|
||||
, Data.Text.Listable
|
||||
, Decorators
|
||||
, Diff
|
||||
, Files
|
||||
@ -93,7 +91,6 @@ library
|
||||
, cmark-gfm
|
||||
, comonad
|
||||
, containers
|
||||
, deepseq
|
||||
, directory
|
||||
, effects
|
||||
, filepath
|
||||
@ -102,7 +99,6 @@ library
|
||||
, gitrev
|
||||
, hashable
|
||||
, kdt
|
||||
, leancheck
|
||||
, mersenne-random-pure64
|
||||
, MonadRandom
|
||||
, mtl
|
||||
@ -147,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
|
||||
@ -168,7 +165,6 @@ test-suite test
|
||||
, bifunctors
|
||||
, bytestring
|
||||
, comonad
|
||||
, deepseq
|
||||
, filepath
|
||||
, free
|
||||
, Glob
|
||||
|
||||
@ -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,9 +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 t2 = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 :<)) <$> algorithmFor f1 f2)
|
||||
where ann1 :< f1 = runCofree t1
|
||||
ann2 :< f2 = runCofree t2
|
||||
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.
|
||||
|
||||
@ -10,9 +10,8 @@ module Alignment
|
||||
|
||||
import Data.Bifunctor (bimap, first, second)
|
||||
import Control.Arrow ((***))
|
||||
import Control.Comonad (extract)
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.Free
|
||||
import Control.Monad.Free (wrap)
|
||||
import Data.Align
|
||||
import Data.Bifunctor.Join
|
||||
import Data.Foldable (toList)
|
||||
@ -48,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
|
||||
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.
|
||||
alignPatch :: forall fields f. (Traversable f, HasField fields Range) => Both Source -> Patch (Term f (Record fields)) -> [Join These (SplitDiff [] (Record fields))]
|
||||
@ -60,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 term = hylo (alignSyntax side cofree getRange (Identity source)) runCofree (Identity <$> term)
|
||||
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 (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])]
|
||||
|
||||
122
src/Category.hs
122
src/Category.hs
@ -3,8 +3,6 @@
|
||||
{-# OPTIONS_GHC -funbox-strict-fields #-}
|
||||
module Category where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Functor.Listable
|
||||
import Data.Hashable
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Prettyprint.Doc
|
||||
@ -238,7 +236,7 @@ data Category
|
||||
| Ty
|
||||
| ParenthesizedExpression
|
||||
| ParenthesizedType
|
||||
deriving (Eq, Generic, Ord, Show, NFData)
|
||||
deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
{-# DEPRECATED RescueModifier "Deprecated; use Modifier Rescue instead." #-}
|
||||
|
||||
@ -247,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
|
||||
|
||||
@ -1,8 +1,16 @@
|
||||
{-# 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
|
||||
, liftShowsPrecBoth
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Bifunctor.Join as X
|
||||
import Data.Functor.Classes
|
||||
import Data.Semigroup
|
||||
import Prelude hiding (fst, snd)
|
||||
import qualified Prelude
|
||||
@ -34,4 +42,5 @@ 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)
|
||||
liftShowsPrecBoth :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Both a -> ShowS
|
||||
liftShowsPrecBoth sp sl d = showsUnaryWith (liftShowsPrec2 sp sl sp sl) "Join" d . runJoin
|
||||
|
||||
@ -1,143 +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.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
|
||||
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 (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
|
||||
|
||||
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
|
||||
@ -6,15 +6,13 @@ module Data.Range
|
||||
, intersectsRange
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
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 }
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
-- | Return the length of the range.
|
||||
rangeLength :: Range -> Int
|
||||
@ -37,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
|
||||
|
||||
@ -1,9 +1,7 @@
|
||||
{-# 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
|
||||
import Data.Text.Prettyprint.Doc
|
||||
|
||||
@ -49,11 +47,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
|
||||
@ -76,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)
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -9,21 +9,19 @@ module Data.Span
|
||||
, emptySpan
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Aeson ((.=), (.:))
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Semigroup
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import GHC.Generics
|
||||
import Test.LeanCheck
|
||||
|
||||
-- | Source position information
|
||||
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 +36,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)
|
||||
@ -58,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
|
||||
|
||||
|
||||
@ -3,7 +3,6 @@ module Data.Syntax where
|
||||
|
||||
import Algorithm
|
||||
import Control.Applicative
|
||||
import Control.Comonad.Trans.Cofree (headF)
|
||||
import Control.Monad.Error.Class hiding (Error)
|
||||
import Data.Align.Generic
|
||||
import Data.ByteString (ByteString)
|
||||
@ -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 = 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
|
||||
@ -42,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' (termAnnotation (unTerm a)) f
|
||||
_ -> error "makeTerm1': empty structure"
|
||||
|
||||
-- | Construct an empty term at the current position.
|
||||
@ -50,7 +49,7 @@ emptyTerm :: (HasCallStack, Empty :< fs, Apply1 Foldable fs) => Assignment.Assig
|
||||
emptyTerm = makeTerm <$> Assignment.location <*> pure Empty
|
||||
|
||||
-- | Catch assignment errors into an error term.
|
||||
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq (ast (Assignment.AST ast grammar)), Ix grammar, Show grammar, Apply1 Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply1 Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
|
||||
handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
|
||||
|
||||
-- | Catch parse errors into an error term.
|
||||
|
||||
@ -8,7 +8,6 @@ module Data.Syntax.Algebra
|
||||
, cyclomaticComplexityAlgebra
|
||||
) where
|
||||
|
||||
import Control.Comonad (extract)
|
||||
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 :< f) -> cofree $ (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
|
||||
@ -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 (_ :< 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
|
||||
@ -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 (_ :< 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)
|
||||
|
||||
@ -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.
|
||||
@ -96,8 +96,6 @@ module Data.Syntax.Assignment
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Comonad.Cofree as Cofree
|
||||
import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..), headF)
|
||||
import Control.Monad ((<=<), guard)
|
||||
import Control.Monad.Error.Class hiding (Error)
|
||||
import Control.Monad.Fail
|
||||
@ -118,7 +116,7 @@ import qualified Data.Syntax.Assignment.Table as Table
|
||||
import GHC.Stack
|
||||
import qualified Info
|
||||
import Prelude hiding (fail, until)
|
||||
import Term (runCofree)
|
||||
import Term
|
||||
import Text.Parser.Combinators as Parsers hiding (choice)
|
||||
import TreeSitter.Language
|
||||
|
||||
@ -130,7 +128,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 (TermF ast (Node grammar) ())
|
||||
Source :: AssignmentF ast grammar ByteString
|
||||
Children :: Assignment ast grammar a -> AssignmentF ast grammar a
|
||||
Choose :: Table.Table grammar (Assignment ast grammar a) -> Maybe (Assignment ast grammar a) -> Maybe (Error (Either String grammar) -> Assignment ast grammar a) -> AssignmentF ast grammar a
|
||||
@ -158,7 +156,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 (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.
|
||||
@ -178,7 +176,7 @@ advance :: HasCallStack => Assignment ast grammar ()
|
||||
advance = () <$ source
|
||||
|
||||
-- | Construct a committed choice table from a list of alternatives. Use this to efficiently select between long lists of rules.
|
||||
choice :: (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar, HasCallStack) => [Assignment ast grammar a] -> Assignment ast grammar a
|
||||
choice :: (Enum grammar, Eq1 ast, Ix grammar, HasCallStack) => [Assignment ast grammar a] -> Assignment ast grammar a
|
||||
choice [] = empty
|
||||
choice alternatives
|
||||
| null choices = asum alternatives
|
||||
@ -221,7 +219,7 @@ manyThrough step stop = go
|
||||
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
|
||||
@ -245,7 +243,7 @@ firstSet = iterFreer (\ (Tracing _ assignment) _ -> case assignment of
|
||||
|
||||
|
||||
-- | Run an assignment over an AST exhaustively.
|
||||
assign :: (Enum grammar, Ix grammar, Symbol grammar, Show grammar, Eq (ast (AST ast grammar)), Foldable ast, Functor ast)
|
||||
assign :: (Enum 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.
|
||||
@ -254,7 +252,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. (Enum grammar, Ix grammar, Symbol grammar, Eq (ast (AST ast grammar)), Foldable ast, Functor ast)
|
||||
runAssignment :: forall grammar a ast. (Enum 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.
|
||||
@ -270,9 +268,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 = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
|
||||
where atNode (node :< f) = case runTracing t of
|
||||
where atNode (Term (In node f)) = case runTracing t of
|
||||
Location -> yield (nodeLocation node) state
|
||||
CurrentNode -> yield (node CofreeF.:< (() <$ 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)
|
||||
@ -291,7 +289,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
|
||||
_ -> Left (makeError node)
|
||||
|
||||
state@State{..} = case (runTracing t, initialState) of
|
||||
(Choose table _ _, State { stateNodes = (node :< _) : _ }) | symbolType (nodeSymbol node) /= Regular, symbols@(_:_) <- Table.tableAddresses table, all ((== Regular) . symbolType) symbols -> skipTokens initialState
|
||||
(Choose table _ _, State { stateNodes = Term (In node _) : _ }) | symbolType (nodeSymbol node) /= Regular, symbols@(_:_) <- Table.tableAddresses table, all ((== Regular) . symbolType) symbols -> skipTokens initialState
|
||||
_ -> initialState
|
||||
expectedSymbols = firstSet (t `Then` return)
|
||||
makeError = withStateCallStack (tracingCallSite t) state $ maybe (Error (Info.Span statePos statePos) (fmap Right expectedSymbols) Nothing) (nodeError (fmap Right expectedSymbols))
|
||||
@ -299,18 +297,18 @@ 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 (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
|
||||
|
||||
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 . 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
|
||||
advanceState state@State{..}
|
||||
| (Node{..} Cofree.:< _) : 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.
|
||||
@ -321,8 +319,8 @@ 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 (Show grammar, Show (ast (AST ast grammar))) => Show (State ast grammar)
|
||||
deriving instance (Eq grammar, Eq1 ast) => Eq (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) []
|
||||
@ -330,14 +328,14 @@ makeState = State 0 (Info.Pos 1 1) []
|
||||
|
||||
-- Instances
|
||||
|
||||
instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar) => Semigroup (Assignment ast grammar a) where
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar) => Semigroup (Assignment ast grammar a) where
|
||||
(<>) = (<|>)
|
||||
|
||||
instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar) => Monoid (Assignment ast grammar a) where
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar) => Monoid (Assignment ast grammar a) where
|
||||
mempty = empty
|
||||
mappend = (<|>)
|
||||
|
||||
instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar) => Alternative (Assignment ast grammar) where
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast grammar) where
|
||||
empty :: HasCallStack => Assignment ast grammar a
|
||||
empty = tracing (Alt []) `Then` return
|
||||
|
||||
@ -366,7 +364,7 @@ instance MonadFail (Assignment ast grammar) where
|
||||
fail :: HasCallStack => String -> Assignment ast grammar a
|
||||
fail s = tracing (Fail s) `Then` return
|
||||
|
||||
instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar, Show grammar, Show (ast (AST ast grammar))) => Parsing (Assignment ast grammar) where
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar, Show1 ast) => Parsing (Assignment ast grammar) where
|
||||
try :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a
|
||||
try = id
|
||||
|
||||
@ -382,7 +380,7 @@ instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar, Show grammar, Sh
|
||||
notFollowedBy :: (HasCallStack, Show a) => Assignment ast grammar a -> Assignment ast grammar ()
|
||||
notFollowedBy a = a *> unexpected (show a) <|> pure ()
|
||||
|
||||
instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar, Show grammar) => MonadError (Error (Either String grammar)) (Assignment ast grammar) where
|
||||
instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => MonadError (Error (Either String grammar)) (Assignment ast grammar) where
|
||||
throwError :: HasCallStack => Error (Either String grammar) -> Assignment ast grammar a
|
||||
throwError err = fail (show err)
|
||||
|
||||
@ -395,7 +393,7 @@ instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar, Show grammar) =>
|
||||
instance Show1 f => Show1 (Tracing f) where
|
||||
liftShowsPrec sp sl d = liftShowsPrec sp sl d . runTracing
|
||||
|
||||
instance (Enum grammar, Ix grammar, Show grammar, Show (ast (AST ast grammar))) => Show1 (AssignmentF ast grammar) where
|
||||
instance (Enum grammar, Ix grammar, Show grammar, Show1 ast) => Show1 (AssignmentF ast grammar) where
|
||||
liftShowsPrec sp sl d a = case a of
|
||||
End -> showString "End" . showChar ' ' . sp d ()
|
||||
Location -> showString "Location" . sp d (Info.Range 0 0 :. Info.Span (Info.Pos 1 1) (Info.Pos 1 1) :. Nil)
|
||||
|
||||
@ -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)
|
||||
@ -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
|
||||
|
||||
167
src/Diff.hs
167
src/Diff.hs
@ -1,37 +1,51 @@
|
||||
{-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-}
|
||||
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
|
||||
import Data.Bifoldable
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.Foldable (fold)
|
||||
import Data.Functor.Both as Both
|
||||
import Data.Functor.Classes.Pretty.Generic
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Classes.Pretty.Generic as Pretty
|
||||
import Data.Functor.Foldable hiding (fold)
|
||||
import Data.Mergeable
|
||||
import Data.Record
|
||||
import Data.Union
|
||||
import Patch
|
||||
import Syntax
|
||||
import Term
|
||||
import Text.Show
|
||||
|
||||
-- | 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
|
||||
= Copy (Both ann) (syntax recur)
|
||||
| Patch (Patch (Term syntax ann))
|
||||
deriving (Foldable, Functor, Traversable)
|
||||
|
||||
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 (Copy _ 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)
|
||||
|
||||
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 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
|
||||
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) = termIn (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)
|
||||
@ -41,34 +55,109 @@ 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
|
||||
|
||||
|
||||
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` ()
|
||||
-- | 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
|
||||
|
||||
-- | 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
|
||||
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
copy :: Both ann -> syntax (Diff syntax ann) -> Diff syntax ann
|
||||
copy = (Diff .) . Copy
|
||||
|
||||
|
||||
instance Pretty1 f => Pretty1 (Free.Free f) where
|
||||
liftPretty p pl = go where go (Free.Pure a) = p a
|
||||
go (Free.Free f) = liftPretty go (list . map (liftPretty p pl)) f
|
||||
instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where
|
||||
liftPretty p pl = go
|
||||
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 (Pretty1 f, Pretty a) => Pretty (Free.Free f a) where
|
||||
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) (Pretty.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 => 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, 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
|
||||
(Patch p1, Patch p2) -> liftEq (liftEq eqA) p1 p2
|
||||
_ -> False
|
||||
|
||||
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 => 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
|
||||
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
|
||||
|
||||
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 => 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 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
|
||||
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
|
||||
|
||||
@ -7,10 +7,7 @@ module Interpreter
|
||||
) where
|
||||
|
||||
import Algorithm
|
||||
import Control.Comonad (extract)
|
||||
import Control.Comonad.Cofree (unwrap)
|
||||
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)
|
||||
@ -21,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
|
||||
@ -50,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 -> 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)
|
||||
@ -61,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)
|
||||
|
||||
@ -107,16 +104,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 = copy (both (extract t1) (extract t2))
|
||||
|
||||
|
||||
-- | 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.
|
||||
@ -126,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
|
||||
Copy _ r -> sum (fmap (diffCost (pred m)) r)
|
||||
Patch patch -> patchSum termSize patch
|
||||
approximateDiff a b = maybe (replacing a b) (copy (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))
|
||||
|
||||
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE DataKinds, DeriveGeneric, DeriveAnyClass #-}
|
||||
module Language where
|
||||
|
||||
import Control.Comonad
|
||||
import Control.Comonad.Trans.Cofree hiding (cofree)
|
||||
import Control.DeepSeq
|
||||
import Control.Comonad.Trans.Cofree
|
||||
import Data.Aeson
|
||||
import Data.Foldable
|
||||
import Data.Record
|
||||
@ -22,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
|
||||
@ -40,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] -> 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] -> 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 = cofree $ 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 = [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 = [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))
|
||||
|
||||
@ -5,14 +5,13 @@ module Language.Markdown
|
||||
, toGrammar
|
||||
) where
|
||||
|
||||
import Control.Comonad.Cofree as Cofree
|
||||
import Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
|
||||
import CMarkGFM
|
||||
import Data.Ix
|
||||
import Data.Source
|
||||
import qualified Data.Syntax.Assignment as A (AST, Node(..))
|
||||
import Info
|
||||
import TreeSitter.Language (Symbol(..), SymbolType(..))
|
||||
import Term
|
||||
|
||||
data Grammar
|
||||
= Document
|
||||
@ -49,13 +48,13 @@ 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
|
||||
in (A.Node (toGrammar t) range span) Cofree.:< (t CofreeF.:< (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)))
|
||||
|
||||
|
||||
@ -3,11 +3,9 @@ module Language.Markdown.Syntax
|
||||
( assignment
|
||||
, Syntax
|
||||
, Grammar
|
||||
, Term
|
||||
, 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,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Union
|
||||
import GHC.Stack
|
||||
import Language.Markdown as Grammar (Grammar(..))
|
||||
import qualified Term
|
||||
import Term (Term(..), TermF(..), termIn, unwrap)
|
||||
|
||||
type Syntax =
|
||||
'[ Markup.Document
|
||||
@ -53,7 +51,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 Language.Markdown.Syntax.Term
|
||||
|
||||
|
||||
assignment :: Assignment
|
||||
@ -69,16 +67,16 @@ paragraph :: Assignment
|
||||
paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement)
|
||||
|
||||
list :: Assignment
|
||||
list = (:<) <$> 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) . headF . tailF <$> 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) . headF . tailF <$> 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
|
||||
@ -88,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 . termOut <$> currentNode <*> source)
|
||||
|
||||
thematicBreak :: Assignment
|
||||
thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak
|
||||
@ -126,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 . termOut <$> 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 . termOut <$> currentNode) <* advance
|
||||
|
||||
code :: Assignment
|
||||
code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source)
|
||||
|
||||
@ -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.
|
||||
@ -59,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 (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
|
||||
|
||||
@ -11,9 +11,8 @@ module Parser
|
||||
, rubyParser
|
||||
) where
|
||||
|
||||
import Control.Comonad.Cofree (Cofree)
|
||||
import Control.Comonad.Trans.Cofree (CofreeF)
|
||||
import qualified CMarkGFM
|
||||
import Data.Functor.Classes (Eq1)
|
||||
import Data.Ix
|
||||
import Data.Record
|
||||
import Data.Source as Source
|
||||
@ -41,14 +40,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 :: (Enum 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 :: (Enum 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.
|
||||
-- | 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)
|
||||
|
||||
@ -79,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 = 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 = 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)))
|
||||
|
||||
32
src/Patch.hs
32
src/Patch.hs
@ -2,9 +2,6 @@
|
||||
{-# OPTIONS_GHC -funbox-strict-fields #-}
|
||||
module Patch
|
||||
( Patch(..)
|
||||
, replacing
|
||||
, inserting
|
||||
, deleting
|
||||
, after
|
||||
, before
|
||||
, unPatch
|
||||
@ -14,10 +11,10 @@ module Patch
|
||||
, mapPatch
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Align
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Pretty.Generic
|
||||
import Data.Functor.Listable
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.These
|
||||
import GHC.Generics
|
||||
|
||||
@ -26,22 +23,7 @@ data Patch a
|
||||
= Replace a a
|
||||
| Insert a
|
||||
| Delete a
|
||||
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable, NFData)
|
||||
|
||||
|
||||
-- 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
|
||||
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
|
||||
|
||||
|
||||
-- | Return the item from the after side of the patch.
|
||||
@ -78,17 +60,13 @@ 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
|
||||
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
|
||||
|
||||
50
src/RWS.hs
50
src/RWS.hs
@ -3,9 +3,7 @@ module RWS (
|
||||
rws
|
||||
, ComparabilityRelation
|
||||
, FeatureVector
|
||||
, stripDiff
|
||||
, defaultFeatureVectorDecorator
|
||||
, stripTerm
|
||||
, featureVectorDecorator
|
||||
, pqGramDecorator
|
||||
, Gram(..)
|
||||
@ -14,9 +12,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
|
||||
import Data.Function ((&), on)
|
||||
@ -29,19 +24,16 @@ import Data.Record
|
||||
import Data.Semigroup hiding (First(..))
|
||||
import Data.These
|
||||
import Data.Traversable
|
||||
import Patch
|
||||
import Term
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
@ -146,7 +138,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.
|
||||
@ -219,7 +211,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)]
|
||||
@ -228,8 +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 = let record :< functor = runCofree term in
|
||||
cofree (setFeatureVector record nullFeatureVector :< functor)
|
||||
eraseFeatureVector (Term.Term (In record functor)) = termIn (setFeatureVector record nullFeatureVector) functor
|
||||
|
||||
nullFeatureVector :: FeatureVector
|
||||
nullFeatureVector = listArray (0, 0) [0]
|
||||
@ -263,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) = cofree ((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))
|
||||
|
||||
@ -281,7 +272,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)
|
||||
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))
|
||||
|
||||
@ -289,11 +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 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 (Term.Term (In (gram :. rest) functor)) = do
|
||||
labels <- get
|
||||
put (drop 1 labels)
|
||||
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)
|
||||
@ -307,24 +297,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))
|
||||
|
||||
|
||||
-- | 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
|
||||
where go a b = canCompareTerms canCompare a b && liftEq go (termOut (unTerm a)) (termOut (unTerm b))
|
||||
|
||||
|
||||
-- Instances
|
||||
@ -332,9 +310,3 @@ stripDiff = mapAnnotations rtail
|
||||
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
|
||||
|
||||
@ -18,9 +18,6 @@ module Renderer
|
||||
, File(..)
|
||||
) where
|
||||
|
||||
import Control.Comonad.Cofree (Cofree, unwrap)
|
||||
import Control.Comonad.Trans.Cofree (CofreeF(..))
|
||||
import Control.DeepSeq
|
||||
import Data.Aeson (Value, (.=))
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable (asum)
|
||||
@ -35,7 +32,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
|
||||
@ -76,8 +73,8 @@ 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 :: RAlgebra (TermF Syntax a) (Term Syntax a) (Maybe Identifier)
|
||||
identifierAlgebra (In _ syntax) = case syntax of
|
||||
S.Assignment f _ -> identifier f
|
||||
S.Class f _ _ -> identifier f
|
||||
S.Export f _ -> f >>= identifier
|
||||
@ -95,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]
|
||||
|
||||
@ -6,10 +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
|
||||
import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
|
||||
import Data.Aeson as A hiding (json)
|
||||
import Data.Bifunctor.Join
|
||||
@ -25,11 +21,13 @@ 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
|
||||
import Patch
|
||||
import Syntax as S
|
||||
import Term
|
||||
|
||||
--
|
||||
-- Diffs
|
||||
@ -46,20 +44,20 @@ 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
|
||||
|
||||
instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSON (Cofree f a) where
|
||||
toJSON (a :< f) = object (toJSONFields a <> toJSONFields f)
|
||||
toEncoding (a :< f) = pairs (mconcat (toJSONFields a <> toJSONFields f))
|
||||
instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) where
|
||||
toJSON = object . toJSONFields
|
||||
toEncoding = pairs . mconcat . toJSONFields
|
||||
|
||||
class ToJSONFields a where
|
||||
toJSONFields :: KeyValue kv => a -> [kv]
|
||||
@ -86,24 +84,23 @@ 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
|
||||
toJSONFields (a :< f) = toJSONFields a <> toJSONFields f
|
||||
instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where
|
||||
toJSONFields = toJSONFields . unTerm
|
||||
|
||||
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 (TermF f a b) where
|
||||
toJSONFields (In 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 (Copy 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 ]
|
||||
|
||||
@ -4,8 +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)
|
||||
import Data.Record
|
||||
@ -24,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 <> ")"
|
||||
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
|
||||
@ -45,8 +43,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 (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
|
||||
showAnnotation Nil = ""
|
||||
|
||||
@ -17,13 +17,9 @@ module Renderer.TOC
|
||||
, entrySummary
|
||||
) where
|
||||
|
||||
import Control.Comonad (extract)
|
||||
import Control.Comonad.Cofree (unwrap)
|
||||
import Control.DeepSeq
|
||||
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)
|
||||
@ -31,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)
|
||||
@ -41,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
|
||||
@ -95,19 +89,19 @@ 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
|
||||
|
||||
-- | 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, _)) _ _
|
||||
@ -122,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
|
||||
@ -133,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
|
||||
@ -156,11 +150,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
|
||||
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
|
||||
Patch patch -> Just (patchEntry <$> crosswalk (termTableOfContentsBy selector) patch)
|
||||
|
||||
patchEntry = these Deleted Inserted (const Replaced) . unPatch
|
||||
|
||||
termTableOfContentsBy :: (Foldable f, Functor f)
|
||||
@ -228,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)
|
||||
|
||||
@ -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
|
||||
@ -25,7 +24,6 @@ import Diff
|
||||
import Info
|
||||
import Interpreter
|
||||
import qualified Language
|
||||
import Patch
|
||||
import Parser
|
||||
import Renderer
|
||||
import Semantic.Task as Task
|
||||
@ -47,7 +45,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)
|
||||
@ -72,7 +70,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)
|
||||
@ -82,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
|
||||
|
||||
@ -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
|
||||
@ -220,7 +220,7 @@ runParser Options{..} blob@Blob{..} = go
|
||||
LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource)
|
||||
blobFields = ("path", blobPath) : maybe [] (pure . (,) "language" . 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
|
||||
|
||||
@ -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
|
||||
@ -17,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.
|
||||
|
||||
@ -1,15 +1,14 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
module Syntax where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Aeson
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Pretty.Generic
|
||||
import Data.Functor.Listable
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Mergeable
|
||||
import Data.Text (pack, Text)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
|
||||
-- | A node in an abstract syntax tree.
|
||||
@ -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
|
||||
@ -121,67 +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 Eq1 Syntax where liftEq = genericLiftEq
|
||||
instance Show1 Syntax where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Pretty1 Syntax where liftPretty = genericLiftPretty
|
||||
|
||||
155
src/Term.hs
155
src/Term.hs
@ -1,83 +1,132 @@
|
||||
{-# LANGUAGE RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeOperators #-}
|
||||
module Term
|
||||
( Term
|
||||
, TermF
|
||||
( Term(..)
|
||||
, termIn
|
||||
, TermF(..)
|
||||
, SyntaxTerm
|
||||
, SyntaxTermF
|
||||
, zipTerms
|
||||
, termSize
|
||||
, alignCofreeWith
|
||||
, cofree
|
||||
, runCofree
|
||||
, CofreeF.CofreeF(..)
|
||||
, extract
|
||||
, unwrap
|
||||
, hoistTerm
|
||||
, stripTerm
|
||||
, liftPrettyUnion
|
||||
) where
|
||||
|
||||
import qualified Control.Comonad.Cofree as Cofree
|
||||
import qualified Control.Comonad.Trans.Cofree as CofreeF
|
||||
import Control.DeepSeq
|
||||
import Control.Monad.Free
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Both
|
||||
import Data.Functor.Classes.Pretty.Generic
|
||||
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
|
||||
import Data.Maybe
|
||||
import Data.Proxy
|
||||
import Data.Record
|
||||
import Data.These
|
||||
import Data.Union
|
||||
import Syntax
|
||||
import Text.Show
|
||||
|
||||
-- | A Term with an abstract syntax tree and an annotation.
|
||||
type Term f = Cofree.Cofree f
|
||||
type TermF = CofreeF.CofreeF
|
||||
newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
|
||||
|
||||
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.
|
||||
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
|
||||
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` ()
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | 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 (In _ syntax) = 1 + sum syntax
|
||||
|
||||
-- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms.
|
||||
alignCofreeWith :: 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
|
||||
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
|
||||
_ -> Nothing
|
||||
-- | Build a Term from its annotation and syntax.
|
||||
termIn :: ann -> syntax (Term syntax ann) -> Term syntax ann
|
||||
termIn = (Term .) . In
|
||||
|
||||
|
||||
cofree :: CofreeF.CofreeF f a (Cofree.Cofree f a) -> Cofree.Cofree f a
|
||||
cofree (a CofreeF.:< f) = a Cofree.:< f
|
||||
hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a
|
||||
hoistTerm f = go where go (Term (In a r)) = termIn a (f (fmap go r))
|
||||
|
||||
runCofree :: Cofree.Cofree f a -> CofreeF.CofreeF f a (Cofree.Cofree f a)
|
||||
runCofree (a Cofree.:< f) = a CofreeF.:< f
|
||||
-- | 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
|
||||
|
||||
|
||||
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
|
||||
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, Pretty a) => Pretty (Cofree.Cofree f a) where
|
||||
|
||||
instance Apply1 Pretty1 fs => Pretty1 (Term (Union fs)) where
|
||||
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
|
||||
|
||||
instance Apply1 Pretty1 fs => Pretty1 (Union fs) where
|
||||
liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl)
|
||||
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 => Comonad (Term f) where
|
||||
extract = termAnnotation . unTerm
|
||||
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)) = 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)) = termIn <$> f a <*> traverse go r
|
||||
|
||||
instance Functor f => ComonadCofree f (Term f) where
|
||||
unwrap = termOut . unTerm
|
||||
{-# INLINE unwrap #-}
|
||||
|
||||
instance Eq1 f => Eq1 (Term f) where
|
||||
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
|
||||
|
||||
instance Show1 f => Show1 (Term f) where
|
||||
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 (In a r) = In (f a) (fmap g r)
|
||||
|
||||
instance Foldable f => Bifoldable (TermF f) where
|
||||
bifoldMap f g (In a r) = f a `mappend` foldMap g r
|
||||
|
||||
instance Traversable f => Bitraversable (TermF f) where
|
||||
bitraverse f g (In a r) = In <$> f a <*> traverse g r
|
||||
|
||||
|
||||
instance Eq1 f => Eq2 (TermF f) where
|
||||
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 (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 (In 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
|
||||
|
||||
@ -5,8 +5,6 @@ module TreeSitter
|
||||
) where
|
||||
|
||||
import Category
|
||||
import Control.Comonad (extract)
|
||||
import Control.Comonad.Cofree (unwrap)
|
||||
import Control.Exception
|
||||
import Control.Monad ((<=<))
|
||||
import Data.Blob
|
||||
@ -66,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
|
||||
@ -111,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 (cofree (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
|
||||
@ -122,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 = cofree . (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
|
||||
|
||||
@ -157,7 +155,7 @@ defaultTermAssignment source annotation children allChildren
|
||||
[_, Other t]
|
||||
| t `elem` ["--", "++"] -> MathOperator
|
||||
_ -> Operator
|
||||
pure (cofree ((setCategory annotation c) :< S.Operator cs))
|
||||
pure (termIn (setCategory annotation c) (S.Operator cs))
|
||||
|
||||
(Other "binary_expression", _) -> do
|
||||
cs <- allChildren
|
||||
@ -168,7 +166,7 @@ defaultTermAssignment source annotation children allChildren
|
||||
| s `elem` ["&&", "||"] -> BooleanOperator
|
||||
| s `elem` [">>", ">>=", ">>>", ">>>=", "<<", "<<=", "&", "^", "|"] -> BitwiseOperator
|
||||
_ -> Operator
|
||||
pure (cofree ((setCategory annotation c) :< S.Operator cs))
|
||||
pure (termIn (setCategory annotation c) (S.Operator cs))
|
||||
|
||||
(_, []) -> toTerm $ S.Leaf (toText source)
|
||||
(_, children) -> toTerm $ S.Indexed children
|
||||
@ -183,7 +181,7 @@ defaultTermAssignment source annotation children allChildren
|
||||
, RelationalOperator
|
||||
, BitwiseOperator
|
||||
]
|
||||
toTerm = pure . cofree . (annotation :<)
|
||||
toTerm = pure . Term . In annotation
|
||||
|
||||
|
||||
categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category
|
||||
|
||||
@ -3,13 +3,11 @@ module AlignmentSpec where
|
||||
|
||||
import Alignment
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Comonad.Cofree (Cofree, hoistCofree)
|
||||
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 +19,7 @@ import Data.Semigroup ((<>))
|
||||
import qualified Data.Source as Source
|
||||
import qualified Data.Text as Text
|
||||
import Data.These
|
||||
import Patch
|
||||
import Diff
|
||||
import SplitDiff
|
||||
import Syntax
|
||||
import Term
|
||||
@ -66,134 +64,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 `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) `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 `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) `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 `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) `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 `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) `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 `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) `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 `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 (insert (info 0 1 `leaf` "a")) `shouldBe` prettyDiff sources
|
||||
[ Join (That (insert (info 0 1 `leaf` "a"))) ]
|
||||
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) `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 `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) `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 `In` 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 `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) `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 `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) `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 `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) `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 `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) `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 `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) `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 `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) `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 `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
|
||||
@ -260,14 +258,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 +278,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
|
||||
|
||||
317
test/Data/Functor/Listable.hs
Normal file
317
test/Data/Functor/Listable.hs
Normal file
@ -0,0 +1,317 @@
|
||||
{-# 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.ByteString (ByteString)
|
||||
import Data.Char (chr)
|
||||
import Data.Functor.Both
|
||||
import Data.Range
|
||||
import Data.Record
|
||||
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
|
||||
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) In
|
||||
|
||||
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)
|
||||
|
||||
|
||||
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.
|
||||
@ -2,16 +2,13 @@
|
||||
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
|
||||
import Data.Functor.Listable ()
|
||||
import Data.Record
|
||||
import Data.These
|
||||
import Diff
|
||||
import Info
|
||||
import Patch
|
||||
import RWS
|
||||
import Syntax
|
||||
import Term
|
||||
@ -23,31 +20,31 @@ 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) (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) (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) (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 = 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 (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) `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 = 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
|
||||
|
||||
|
||||
@ -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(..))
|
||||
|
||||
@ -251,7 +251,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))) `In` children)
|
||||
|
||||
data Grammar = Palette | Red | Green | Blue | Magenta
|
||||
deriving (Bounded, Enum, Eq, Ix, Ord, Show)
|
||||
|
||||
@ -2,35 +2,33 @@
|
||||
module DiffSpec where
|
||||
|
||||
import Category
|
||||
import Control.Comonad.Trans.Cofree (headF)
|
||||
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
|
||||
|
||||
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
|
||||
\ 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
|
||||
|
||||
@ -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) ++)
|
||||
|
||||
@ -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)
|
||||
@ -20,8 +18,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) `In` Leaf "t\776"
|
||||
termB = Term $ (StringLiteral :. Nil) `In` Leaf "\7831" in
|
||||
diffTerms (both termA termB) `shouldBe` replacing termA termB
|
||||
|
||||
prop "produces correct diffs" $
|
||||
@ -34,6 +32,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) `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") ])
|
||||
|
||||
@ -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 = []}]
|
||||
|
||||
@ -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 (() `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` (() :< Indexed [ () :< Leaf "def foo\n", () :< Leaf "end\n", () :< 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
|
||||
@ -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 (() `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 (() :< [])))
|
||||
(() <$) <$> result `shouldBe` pure (Delete ())
|
||||
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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -4,27 +4,20 @@ module SpecHelpers
|
||||
, parseFilePath
|
||||
, readFile
|
||||
, languageForFilePath
|
||||
, unListableDiff
|
||||
) 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
|
||||
@ -51,7 +44,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
|
||||
|
||||
@ -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)
|
||||
@ -19,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
|
||||
@ -44,24 +40,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 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' = (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 . headF) (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 . headF) (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 <$) <$> mapAnnotations (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff Syntax Int])) in
|
||||
tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe`
|
||||
if null diff' then [Unchanged 0]
|
||||
else replicate (length diff') (Changed 0)
|
||||
\ diff -> let diff' = copy (pure 0) (Indexed [1 <$ (diff :: Diff Syntax Int)]) in
|
||||
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)
|
||||
|
||||
describe "diffTOC" $ do
|
||||
it "blank if there are no methods" $
|
||||
@ -112,31 +108,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 . headF) (unListableF a :: Term') in
|
||||
\a -> let term = defaultFeatureVectorDecorator (Info.category . termAnnotation) (a :: Term') in
|
||||
diffTOC (diffTerms (pure term)) `shouldBe` []
|
||||
|
||||
describe "JSONSummary" $ do
|
||||
@ -173,17 +169,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'
|
||||
@ -196,12 +192,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) `In` 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) `In` Leaf name
|
||||
|
||||
programInfo :: Record (Maybe Declaration ': DefaultFields)
|
||||
programInfo = Nothing :. Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil
|
||||
@ -210,22 +206,22 @@ 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 runCofree (unListableF a) of
|
||||
(_ :< S.Indexed _) -> False
|
||||
(_ :< S.Fixed _) -> False
|
||||
(_ :< S.Commented _ _) -> False
|
||||
(_ :< S.ParseError _) -> False
|
||||
isMeaningfulTerm :: Term Syntax a -> Bool
|
||||
isMeaningfulTerm a = case unTerm a of
|
||||
(_ `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 => ListableF (Term Syntax) (Record fields) -> Bool
|
||||
isMethodOrFunction a = case runCofree (unListableF 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
|
||||
isMethodOrFunction :: HasField fields Category => Term Syntax (Record fields) -> Bool
|
||||
isMethodOrFunction a = case unTerm a of
|
||||
(_ `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)
|
||||
@ -235,13 +231,10 @@ 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 `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
|
||||
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user