github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into typescript-assignment

Browse Source
This commit is contained in:
joshvera 2017-09-13 18:40:29 -04:00
commit 0e853a5f38
66 changed files with 1062 additions and 1355 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
.ghci-template Normal file
View File

@ -0,0 +1,23 @@
:set prompt "\ESC[1;36m\STXλ: \ESC[m\STX"
:def pretty \_ -> return ("import Text.Show.Pretty (pPrint, ppShow)\nimport Language.Haskell.HsColour\nimport Language.Haskell.HsColour.Colourise\nlet color = putStrLn . hscolour TTY defaultColourPrefs False False \"\" False . ppShow\n:set -interactive-print color")
:def no-pretty \_ -> return (":set -interactive-print System.IO.print")
:def re \_ -> return (":r\n:pretty")
:{
assignmentExample lang = case lang of
"Python" -> mk "py" "python"
"Go" -> mk "go" "go"
"Ruby" -> mk "rb" "ruby"
"JavaScript" -> mk "js" "typescript"
"TypeScript" -> mk "ts" "typescript"
"Haskell" -> mk "hs" "haskell"
"Markdown" -> mk "md" "markdown"
"JSON" -> mk "json" "json"
_ -> mk "" ""
where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parser\nimport Semantic.Task\nimport Semantic.Util")
:}
:def assignment assignmentExample

6
.gitmodules vendored
View File

@ -25,6 +25,6 @@
[submodule "vendor/freer-cofreer"]
path = vendor/freer-cofreer
url = https://github.com/robrix/freer-cofreer.git
[submodule "vendor/prettyprinter"]
path = vendor/prettyprinter
url = https://github.com/robrix/prettyprinter.git
[submodule "vendor/ghc-mod"]
path = vendor/ghc-mod
url = https://github.com/joshvera/ghc-mod

4
HLint.hs
View File

@ -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"

3
cabal.project
View File

@ -1,3 +0,0 @@
packages: ./ vendor/*/ vendor/haskell-tree-sitter/languages/*/ vendor/prettyprinter/*/
jobs: $ncpus

11
semantic-diff.cabal
View File

@ -21,9 +21,8 @@ library
, Data.Error
, Data.Functor.Both
, Data.Functor.Classes.Eq.Generic
, Data.Functor.Classes.Pretty.Generic
, Data.Functor.Classes.Show.Generic
, Data.Functor.Listable
, Data.JSON.Fields
, 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
@ -94,7 +92,6 @@ library
, cmark-gfm
, comonad
, containers
, deepseq
, directory
, effects
, filepath
@ -103,14 +100,12 @@ library
, gitrev
, hashable
, kdt
, leancheck
, mersenne-random-pure64
, MonadRandom
, mtl
, optparse-applicative
, parallel
, parsers
, prettyprinter
, recursion-schemes
, semigroups
, split
@ -126,6 +121,8 @@ library
, tree-sitter-python
, tree-sitter-ruby
, tree-sitter-typescript
, pretty-show
, hscolour
default-language: Haskell2010
default-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, RecordWildCards, StrictData
ghc-options: -Wall -fno-warn-name-shadowing -O -j
@ -148,6 +145,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
@ -169,7 +167,6 @@ test-suite test
, bifunctors
, bytestring
, comonad
, deepseq
, filepath
, free
, Glob

11
src/Algorithm.hs
View File

@ -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.

13
src/Alignment.hs
View File

@ -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])]

131
src/Category.hs
View File

@ -3,11 +3,10 @@
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Category where
import Control.DeepSeq
import Data.Functor.Listable
import Data.Aeson
import Data.Hashable
import Data.Text (Text)
import Data.Text.Prettyprint.Doc
import Data.JSON.Fields
import Data.Text (Text, pack)
import GHC.Generics
-- | A standardized category of AST node. Used to determine the semantics for
@ -238,7 +237,7 @@ data Category
| Ty
| ParenthesizedExpression
| ParenthesizedType
deriving (Eq, Generic, Ord, Show, NFData)
deriving (Eq, Generic, Ord, Show)
{-# DEPRECATED RescueModifier "Deprecated; use Modifier Rescue instead." #-}
@ -247,123 +246,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
instance ToJSONFields Category where
toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }]

15
src/Data/Functor/Both.hs
View File

@ -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

49
src/Data/Functor/Classes/Pretty/Generic.hs
View File

@ -1,49 +0,0 @@
{-# LANGUAGE TypeOperators #-}
module Data.Functor.Classes.Pretty.Generic
( module Pretty
, genericLiftPretty
) where
import Data.Text.Prettyprint.Doc as Pretty
import GHC.Generics
genericLiftPretty :: (Generic1 f, GPretty1 (Rep1 f)) => (a -> Doc ann) -> ([a] -> Doc ann) -> f a -> Doc ann
genericLiftPretty pretty' prettyList' = gliftPretty pretty' prettyList' . from1
class GPretty1 f where
gliftPretty :: (a -> Doc ann) -> ([a] -> Doc ann) -> f a -> Doc ann
gcollectPretty :: (a -> Doc ann) -> ([a] -> Doc ann) -> f a -> [Doc ann]
gcollectPretty p pl a = [gliftPretty p pl a]
instance GPretty1 U1 where
gliftPretty _ _ _ = emptyDoc
instance GPretty1 Par1 where
gliftPretty p _ (Par1 a) = p a
instance Pretty c => GPretty1 (K1 i c) where
gliftPretty _ _ (K1 a) = pretty a
instance Pretty1 f => GPretty1 (Rec1 f) where
gliftPretty p pl (Rec1 a) = liftPretty p pl a
instance GPretty1 f => GPretty1 (M1 D c f) where
gliftPretty p pl (M1 a) = gliftPretty p pl a
instance (Constructor c, GPretty1 f) => GPretty1 (M1 C c f) where
gliftPretty p pl m = nest 2 (vsep (pretty (conName m) : gcollectPretty p pl (unM1 m)))
instance GPretty1 f => GPretty1 (M1 S c f) where
gliftPretty p pl (M1 a) = gliftPretty p pl a
instance (GPretty1 f, GPretty1 g) => GPretty1 (f :+: g) where
gliftPretty p pl (L1 l) = gliftPretty p pl l
gliftPretty p pl (R1 r) = gliftPretty p pl r
instance (GPretty1 f, GPretty1 g) => GPretty1 (f :*: g) where
gliftPretty p pl (a :*: b) = gliftPretty p pl a <+> gliftPretty p pl b
gcollectPretty p pl (a :*: b) = gcollectPretty p pl a <> gcollectPretty p pl b
instance (Pretty1 f, GPretty1 g) => GPretty1 (f :.: g) where
gliftPretty p pl (Comp1 a) = liftPretty (gliftPretty p pl) (list . map (gliftPretty p pl)) a

143
src/Data/Functor/Listable.hs
View File

@ -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

27
src/Data/JSON/Fields.hs Normal file
View File

@ -0,0 +1,27 @@
{-# LANGUAGE MultiParamTypeClasses #-}
module Data.JSON.Fields where
import Data.Aeson
import Data.Bifunctor.Join
import Data.Foldable (toList)
import Data.Proxy (Proxy(..))
import Data.Union
class ToJSONFields a where
toJSONFields :: KeyValue kv => a -> [kv]
class ToJSONFields1 f where
toJSONFields1 :: (KeyValue kv, ToJSON a) => f a -> [kv]
instance ToJSONFields a => ToJSONFields (Join (,) a) where
toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ]
instance ToJSONFields a => ToJSONFields (Maybe a) where
toJSONFields = maybe [] toJSONFields
instance ToJSON a => ToJSONFields [a] where
toJSONFields list = [ "children" .= list ]
instance (Apply1 Foldable fs) => ToJSONFields1 (Union fs) where
toJSONFields1 = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])

11
src/Data/Output.hs
View File

@ -1,9 +1,20 @@
module Data.Output where
import Data.Aeson (Value, encode)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Map (Map)
import Data.Semigroup
import Data.Text (Text)
class Monoid o => Output o where
toOutput :: o -> ByteString
instance Output ByteString where
toOutput s = s
instance Output (Map Text Value) where
toOutput = toStrict . (<> "\n") . encode
instance Output [Value] where
toOutput = toStrict . (<> "\n") . encode

14
src/Data/Range.hs
View File

@ -6,15 +6,14 @@ module Data.Range
, intersectsRange
) where
import Control.DeepSeq
import Data.Aeson
import Data.JSON.Fields
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 +36,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
instance ToJSONFields Range where
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]

32
src/Data/Record.hs
View File

@ -1,11 +1,10 @@
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Record where
import Control.DeepSeq
import Data.Aeson
import Data.JSON.Fields
import Data.Kind
import Data.Functor.Listable
import Data.Semigroup
import Data.Text.Prettyprint.Doc
-- | A type-safe, extensible record structure.
-- |
@ -49,11 +48,6 @@ instance {-# OVERLAPPABLE #-} HasField (field ': fields) field where
getField (h :. _) = h
setField (_ :. t) f = f :. t
instance (NFData h, NFData (Record t)) => NFData (Record (h ': t)) where
rnf (h :. t) = rnf h `seq` rnf t `seq` ()
instance NFData (Record '[]) where
rnf _ = ()
instance (Show h, Show (Record t)) => Show (Record (h ': t)) where
showsPrec n (h :. t) = showParen (n > 0) $ showsPrec 1 h . (" :. " <>) . shows t
@ -76,13 +70,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)
@ -90,8 +77,13 @@ instance Semigroup (Record '[]) where
_ <> _ = Nil
instance ConstrainAll Pretty ts => Pretty (Record ts) where
pretty = tupled . collectPretty
where collectPretty :: ConstrainAll Pretty ts => Record ts -> [Doc ann]
collectPretty Nil = []
collectPretty (first :. rest) = pretty first : collectPretty rest
instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where
toJSONFields (h :. t) = toJSONFields h <> toJSONFields t
instance ToJSONFields (Record '[]) where
toJSONFields _ = []
instance ToJSONFields (Record fs) => ToJSON (Record fs) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields

18
src/Data/Source.hs
View File

@ -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.

21
src/Data/Span.hs
View File

@ -9,21 +9,19 @@ module Data.Span
, emptySpan
) where
import Control.DeepSeq
import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
import Data.JSON.Fields
import Data.Hashable (Hashable)
import Data.Semigroup
import Data.Text.Prettyprint.Doc
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,14 +56,5 @@ 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
instance Pretty Span where
pretty Span{..} = pretty spanStart <> pretty '-' <> pretty spanEnd
instance ToJSONFields Span where
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]

25
src/Data/Syntax.hs
View File

@ -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)
@ -13,13 +12,11 @@ import Data.Function ((&))
import Data.Ix
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import Data.Record
import Data.Semigroup
import Data.Span
import qualified Data.Syntax.Assignment as Assignment
import Data.Text.Encoding (decodeUtf8With)
import Data.Union
import GHC.Generics
import GHC.Stack
@ -33,7 +30,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 +39,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 +47,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.
@ -107,15 +104,11 @@ newtype Leaf a = Leaf { leafContent :: ByteString }
instance Eq1 Leaf where liftEq = genericLiftEq
instance Show1 Leaf where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Leaf where
liftPretty _ _ (Leaf s) = pretty ("Leaf" :: String) <+> prettyBytes s
newtype Branch a = Branch { branchElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Branch where liftEq = genericLiftEq
instance Show1 Branch where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Branch where liftPretty = genericLiftPretty
-- Common
@ -127,15 +120,11 @@ newtype Identifier a = Identifier ByteString
instance Eq1 Identifier where liftEq = genericLiftEq
instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Identifier where
liftPretty _ _ (Identifier s) = pretty ("Identifier" :: String) <+> prettyBytes s
newtype Program a = Program [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Program where liftEq = genericLiftEq
instance Show1 Program where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Program where liftPretty = genericLiftPretty
-- | An accessibility modifier, e.g. private, public, protected, etc.
newtype AccessibilityModifier a = AccessibilityModifier ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
@ -152,7 +141,6 @@ data Empty a = Empty
instance Eq1 Empty where liftEq _ _ _ = True
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
instance Pretty1 Empty where liftPretty = genericLiftPretty
-- | Syntax representing a parsing or assignment error.
@ -162,9 +150,6 @@ data Error a = Error { errorCallStack :: [([Char], SrcLoc)], errorExpected :: [S
instance Eq1 Error where liftEq = genericLiftEq
instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Error where
liftPretty _ pl (Error cs e a c) = nest 2 (concatWith (\ x y -> x <> hardline <> y) [ pretty ("Error" :: String), pretty (Error.showExpectation False e a ""), pretty (Error.showCallStack False (fromCallSiteList cs) ""), pl c])
errorSyntax :: Error.Error String -> [a] -> Error a
errorSyntax Error.Error{..} = Error (getCallStack callStack) errorExpected errorActual
@ -177,7 +162,3 @@ data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
instance Eq1 Context where liftEq = genericLiftEq
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Context where liftPretty = genericLiftPretty
prettyBytes :: ByteString -> Doc ann
prettyBytes = pretty . decodeUtf8With (\ _ -> ('\xfffd' <$))

7
src/Data/Syntax/Algebra.hs
View File

@ -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)

68
src/Data/Syntax/Assignment.hs
View File

@ -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.
@ -95,10 +95,7 @@ module Data.Syntax.Assignment
, module Parsers
) where
import Control.Arrow ((&&&))
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
@ -119,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
@ -131,10 +128,9 @@ 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
Advance :: AssignmentF ast grammar ()
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
Many :: Assignment ast grammar a -> AssignmentF ast grammar [a]
Alt :: [a] -> AssignmentF ast grammar a
@ -160,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.
@ -177,10 +173,10 @@ children child = tracing (Children child) `Then` return
-- | Advance past the current node.
advance :: HasCallStack => Assignment ast grammar ()
advance = tracing Advance `Then` return
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
@ -223,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
@ -247,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.
@ -256,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.
@ -271,15 +267,14 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
-> (x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar))
-> State ast grammar
-> Either (Error (Either String grammar)) (result, State ast grammar)
run t yield initialState = expectedSymbols `seq` state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
where atNode (node :< f) = case runTracing t of
run t yield initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
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)
yield a (advanceState state' { stateNodes = stateNodes, stateCallSites = stateCallSites })
Advance -> yield () (advanceState state)
Choose choices _ handler | Just choice <- Table.lookup (nodeSymbol node) choices -> (go choice state `catchError` (maybe throwError (flip go state .) handler)) >>= uncurry yield
_ -> anywhere (Just node)
@ -293,25 +288,27 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
Choose _ (Just atEnd) _ | Nothing <- node -> go atEnd state >>= uncurry yield
_ -> Left (makeError node)
state@State{..} = if not (null expectedSymbols) && all ((== Regular) . symbolType) expectedSymbols then skipTokens initialState else initialState
state@State{..} = case (runTracing t, initialState) of
(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))
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.
@ -322,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) []
@ -331,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
@ -348,22 +345,14 @@ instance (Enum grammar, Eq (ast (AST ast grammar)), Ix grammar) => Alternative (
l@(Tracing callSiteL la `Then` continueL) <|> r@(Tracing callSiteR ra `Then` continueR) = go callSiteL la continueL callSiteR ra continueR
where go :: forall l r . Maybe (String, SrcLoc) -> AssignmentF ast grammar l -> (l -> Assignment ast grammar a) -> Maybe (String, SrcLoc) -> AssignmentF ast grammar r -> (r -> Assignment ast grammar a) -> Assignment ast grammar a
go callSiteL la continueL callSiteR ra continueR = case (la, ra) of
(Fail _, _) -> r
(Alt [], _) -> r
(_, Alt []) -> l
(Fail _, _) -> r
(Children cl, Children cr) -> alternate (Children (Left <$> cl <|> Right <$> cr))
(Location, Location) -> distribute Location
(CurrentNode, CurrentNode) -> distribute CurrentNode
(Advance, Advance) -> distribute Advance
(End, End) -> distribute End
(Source, Source) -> distribute Source
(Alt ls, Alt rs) -> alternate (Alt ((Left <$> ls) <> (Right <$> rs)))
(Alt ls, _) -> rebuild (Alt ((continueL <$> ls) <> pure r)) id
(_, Alt rs) -> rebuild (Alt (pure l <> (continueR <$> rs))) id
_ -> rebuild (Alt [l, r]) id
where distribute :: (l ~ lr, r ~ lr) => AssignmentF ast grammar lr -> Assignment ast grammar a
distribute a = rebuild a (uncurry (<|>) . (continueL &&& continueR))
alternate :: AssignmentF ast grammar (Either l r) -> Assignment ast grammar a
where alternate :: AssignmentF ast grammar (Either l r) -> Assignment ast grammar a
alternate a = rebuild a (either continueL continueR)
rebuild :: AssignmentF ast grammar x -> (x -> Assignment ast grammar a) -> Assignment ast grammar a
rebuild a c = Tracing (callSiteL <|> callSiteR) a `Then` c
@ -375,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
@ -391,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)
@ -404,10 +393,9 @@ 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 ()
Advance -> showString "Advance" . showChar ' ' . sp d ()
Location -> showString "Location" . sp d (Info.Range 0 0 :. Info.Span (Info.Pos 1 1) (Info.Pos 1 1) :. Nil)
CurrentNode -> showString "CurrentNode"
Source -> showString "Source" . showChar ' ' . sp d ""

2
src/Data/Syntax/Assignment/Table.hs
View File

@ -20,7 +20,7 @@ singleton :: Enum i => i -> a -> Table i a
singleton i a = Table [i] (IntMap.singleton (fromEnum i) a)
fromListWith :: (Enum i, Ord i) => (a -> a -> a) -> [(i, a)] -> Table i a
fromListWith with assocs = Table (fmap toEnum (IntSet.toList (IntSet.fromList (fromEnum . fst <$> assocs)))) (IntMap.fromListWith with (first fromEnum <$> assocs))
fromListWith with assocs = Table (toEnum <$> IntSet.toList (IntSet.fromList (fromEnum . fst <$> assocs))) (IntMap.fromListWith with (first fromEnum <$> assocs))
toList :: Enum i => Table i a -> [(i, a)]
toList Table{..} = first toEnum <$> IntMap.toList tableBranches

5
src/Data/Syntax/Comment.hs
View File

@ -5,9 +5,7 @@ import Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import Data.Syntax (prettyBytes)
import GHC.Generics
-- | An unnested comment (line or block).
@ -17,9 +15,6 @@ newtype Comment a = Comment { commentContent :: ByteString }
instance Eq1 Comment where liftEq = genericLiftEq
instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Comment where
liftPretty _ _ (Comment c) = pretty ("Comment" :: String) <+> prettyBytes c
-- TODO: nested comment types
-- TODO: documentation comment types
-- TODO: literate programming comment types? alternatively, consider those as markup

11
src/Data/Syntax/Declaration.hs
View File

@ -4,7 +4,6 @@ module Data.Syntax.Declaration where
import Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import GHC.Generics
@ -13,7 +12,6 @@ data Function a = Function { functionContext :: ![a], functionName :: !a, functi
instance Eq1 Function where liftEq = genericLiftEq
instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Function where liftPretty = genericLiftPretty
-- TODO: How should we represent function types, where applicable?
@ -22,7 +20,6 @@ data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName
instance Eq1 Method where liftEq = genericLiftEq
instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Method where liftPretty = genericLiftPretty
data RequiredParameter a = RequiredParameter { requiredParameter :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
@ -43,7 +40,6 @@ data Variable a = Variable { variableName :: !a, variableType :: !a, variableVal
instance Eq1 Variable where liftEq = genericLiftEq
instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Variable where liftPretty = genericLiftPretty
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: ![a] }
@ -51,7 +47,6 @@ data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSupercl
instance Eq1 Class where liftEq = genericLiftEq
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Class where liftPretty = genericLiftPretty
data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] }
@ -59,7 +54,6 @@ data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] }
instance Eq1 Module where liftEq = genericLiftEq
instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Module where liftPretty = genericLiftPretty
-- | A decorator in Python
@ -68,7 +62,6 @@ data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters ::
instance Eq1 Decorator where liftEq = genericLiftEq
instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Decorator where liftPretty = genericLiftPretty
-- TODO: Generics, constraints.
@ -79,7 +72,6 @@ data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] }
instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Data.Syntax.Declaration.Datatype where liftPretty = genericLiftPretty
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] }
@ -87,7 +79,6 @@ data Constructor a = Constructor { constructorName :: !a, constructorFields :: !
instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Data.Syntax.Declaration.Constructor where liftPretty = genericLiftPretty
-- | Comprehension (e.g. ((a for b in c if a()) in Python)
@ -96,7 +87,6 @@ data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBo
instance Eq1 Comprehension where liftEq = genericLiftEq
instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Comprehension where liftPretty = genericLiftPretty
-- | Import declarations.
@ -105,4 +95,3 @@ data Import a = Import { importContent :: ![a] }
instance Eq1 Import where liftEq = genericLiftEq
instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Import where liftPretty = genericLiftPretty

11
src/Data/Syntax/Expression.hs
View File

@ -4,7 +4,6 @@ module Data.Syntax.Expression where
import Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import GHC.Generics
@ -14,7 +13,6 @@ data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a]
instance Eq1 Call where liftEq = genericLiftEq
instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Call where liftPretty = genericLiftPretty
data Comparison a
@ -28,7 +26,6 @@ data Comparison a
instance Eq1 Comparison where liftEq = genericLiftEq
instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Comparison where liftPretty = genericLiftPretty
-- | Binary arithmetic operators.
@ -44,7 +41,6 @@ data Arithmetic a
instance Eq1 Arithmetic where liftEq = genericLiftEq
instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Arithmetic where liftPretty = genericLiftPretty
-- | Boolean operators.
data Boolean a
@ -55,7 +51,6 @@ data Boolean a
instance Eq1 Boolean where liftEq = genericLiftEq
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Boolean where liftPretty = genericLiftPretty
-- | Javascript delete operator
data Delete a = Delete !a
@ -90,7 +85,6 @@ data Bitwise a
instance Eq1 Bitwise where liftEq = genericLiftEq
instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Bitwise where liftPretty = genericLiftPretty
-- | Member Access (e.g. a.b)
data MemberAccess a
@ -99,7 +93,6 @@ data MemberAccess a
instance Eq1 MemberAccess where liftEq = genericLiftEq
instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 MemberAccess where liftPretty = genericLiftPretty
-- | Subscript (e.g a[1])
data Subscript a
@ -109,7 +102,6 @@ data Subscript a
instance Eq1 Subscript where liftEq = genericLiftEq
instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Subscript where liftPretty = genericLiftPretty
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a }
@ -117,7 +109,6 @@ data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a,
instance Eq1 Enumeration where liftEq = genericLiftEq
instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Enumeration where liftPretty = genericLiftPretty
-- | InstanceOf (e.g. a instanceof b in JavaScript
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
@ -125,7 +116,6 @@ data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a
instance Eq1 InstanceOf where liftEq = genericLiftEq
instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 InstanceOf where liftPretty = genericLiftPretty
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
data ScopeResolution a
@ -134,4 +124,3 @@ data ScopeResolution a
instance Eq1 ScopeResolution where liftEq = genericLiftEq
instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 ScopeResolution where liftPretty = genericLiftPretty

29
src/Data/Syntax/Literal.hs
View File

@ -5,9 +5,7 @@ import Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import Data.Syntax (prettyBytes)
import GHC.Generics
import Prelude
@ -24,7 +22,6 @@ false = Boolean False
instance Eq1 Boolean where liftEq = genericLiftEq
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Boolean where liftPretty = genericLiftPretty
-- Numeric
@ -36,9 +33,6 @@ newtype Integer a = Integer { integerContent :: ByteString }
instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Data.Syntax.Literal.Integer where
liftPretty _ _ (Integer s) = pretty ("Integer" :: Prelude.String) <+> prettyBytes s
-- TODO: Should IntegerLiteral hold an Integer instead of a ByteString?
-- TODO: Do we care about differentiating between hex/octal/decimal/binary integer literals?
-- TODO: Consider a Numeric datatype with FloatingPoint/Integral/etc constructors.
@ -50,9 +44,6 @@ newtype Float a = Float { floatContent :: ByteString }
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Data.Syntax.Literal.Float where
liftPretty _ _ (Float s) = pretty ("Float" :: Prelude.String) <+> prettyBytes s
-- Rational literals e.g. `2/3r`
newtype Rational a = Rational ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
@ -60,9 +51,6 @@ newtype Rational a = Rational ByteString
instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq
instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Data.Syntax.Literal.Rational where
liftPretty _ _ (Rational s) = pretty ("Rational" :: Prelude.String) <+> prettyBytes s
-- Complex literals e.g. `3 + 2i`
newtype Complex a = Complex ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
@ -70,9 +58,6 @@ newtype Complex a = Complex ByteString
instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq
instance Show1 Data.Syntax.Literal.Complex where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Complex where
liftPretty _ _ (Complex s) = pretty ("Complex" :: Prelude.String) <+> prettyBytes s
-- Strings, symbols
@ -81,7 +66,6 @@ newtype String a = String { stringElements :: [a] }
instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Data.Syntax.Literal.String where liftPretty = genericLiftPretty
-- TODO: Should string literal bodies include escapes too?
@ -91,7 +75,6 @@ newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
instance Eq1 InterpolationElement where liftEq = genericLiftEq
instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 InterpolationElement where liftPretty = genericLiftPretty
-- | A sequence of textual contents within a string literal.
@ -101,15 +84,11 @@ newtype TextElement a = TextElement { textElementContent :: ByteString }
instance Eq1 TextElement where liftEq = genericLiftEq
instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 TextElement where
liftPretty _ _ (TextElement s) = pretty ("TextElement" :: Prelude.String) <+> prettyBytes s
data Null a = Null
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Null where liftEq = genericLiftEq
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Null where liftPretty = genericLiftPretty
newtype Symbol a = Symbol { symbolContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
@ -117,9 +96,6 @@ newtype Symbol a = Symbol { symbolContent :: ByteString }
instance Eq1 Symbol where liftEq = genericLiftEq
instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Symbol where
liftPretty _ _ (Symbol s) = pretty ("Symbol" :: Prelude.String) <+> prettyBytes s
-- TODO: Heredoc-style string literals?
-- TODO: Character literals.
-- TODO: Regular expressions.
@ -132,7 +108,6 @@ newtype Array a = Array { arrayElements :: [a] }
instance Eq1 Array where liftEq = genericLiftEq
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Array where liftPretty = genericLiftPretty
newtype Hash a = Hash { hashElements :: [a] }
@ -140,14 +115,12 @@ newtype Hash a = Hash { hashElements :: [a] }
instance Eq1 Hash where liftEq = genericLiftEq
instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Hash where liftPretty = genericLiftPretty
data KeyValue a = KeyValue { key :: !a, value :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 KeyValue where liftEq = genericLiftEq
instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 KeyValue where liftPretty = genericLiftPretty
newtype Tuple a = Tuple { tupleContents :: [a]}
@ -155,7 +128,6 @@ newtype Tuple a = Tuple { tupleContents :: [a]}
instance Eq1 Tuple where liftEq = genericLiftEq
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Tuple where liftPretty = genericLiftPretty
newtype Set a = Set { setElements :: [a] }
@ -163,7 +135,6 @@ newtype Set a = Set { setElements :: [a] }
instance Eq1 Set where liftEq = genericLiftEq
instance Show1 Set where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Set where liftPretty = genericLiftPretty
-- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”?
-- TODO: Function literals (lambdas, procs, anonymous functions, what have you).

32
src/Data/Syntax/Markup.hs
View File

@ -5,10 +5,7 @@ import Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import Data.Maybe (catMaybes)
import Data.Syntax (prettyBytes)
import GHC.Generics
@ -17,7 +14,6 @@ newtype Document a = Document [a]
instance Eq1 Document where liftEq = genericLiftEq
instance Show1 Document where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Document where liftPretty = genericLiftPretty
-- Block elements
@ -27,49 +23,42 @@ newtype Paragraph a = Paragraph [a]
instance Eq1 Paragraph where liftEq = genericLiftEq
instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Paragraph where liftPretty = genericLiftPretty
data Section a = Section { sectionLevel :: Int, sectionHeading :: a, sectionContent :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Section where liftEq = genericLiftEq
instance Show1 Section where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Section where liftPretty = genericLiftPretty
data Heading a = Heading { headingLevel :: Int, headingContent :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Heading where liftEq = genericLiftEq
instance Show1 Heading where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Heading where liftPretty = genericLiftPretty
newtype UnorderedList a = UnorderedList [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 UnorderedList where liftEq = genericLiftEq
instance Show1 UnorderedList where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 UnorderedList where liftPretty = genericLiftPretty
newtype OrderedList a = OrderedList [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 OrderedList where liftEq = genericLiftEq
instance Show1 OrderedList where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 OrderedList where liftPretty = genericLiftPretty
newtype BlockQuote a = BlockQuote [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 BlockQuote where liftEq = genericLiftEq
instance Show1 BlockQuote where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 BlockQuote where liftPretty = genericLiftPretty
data ThematicBreak a = ThematicBreak
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 ThematicBreak where liftEq = genericLiftEq
instance Show1 ThematicBreak where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 ThematicBreak where liftPretty = genericLiftPretty
data HTMLBlock a = HTMLBlock ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
@ -77,29 +66,23 @@ data HTMLBlock a = HTMLBlock ByteString
instance Eq1 HTMLBlock where liftEq = genericLiftEq
instance Show1 HTMLBlock where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 HTMLBlock where
liftPretty _ _ (HTMLBlock s) = pretty ("HTMLBlock" :: String) <+> prettyBytes s
newtype Table a = Table [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Table where liftEq = genericLiftEq
instance Show1 Table where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Table where liftPretty = genericLiftPretty
newtype TableRow a = TableRow [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 TableRow where liftEq = genericLiftEq
instance Show1 TableRow where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 TableRow where liftPretty = genericLiftPretty
newtype TableCell a = TableCell [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 TableCell where liftEq = genericLiftEq
instance Show1 TableCell where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 TableCell where liftPretty = genericLiftPretty
-- Inline elements
@ -109,14 +92,12 @@ newtype Strong a = Strong [a]
instance Eq1 Strong where liftEq = genericLiftEq
instance Show1 Strong where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Strong where liftPretty = genericLiftPretty
newtype Emphasis a = Emphasis [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Emphasis where liftEq = genericLiftEq
instance Show1 Emphasis where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Emphasis where liftPretty = genericLiftPretty
newtype Text a = Text ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
@ -124,45 +105,32 @@ newtype Text a = Text ByteString
instance Eq1 Text where liftEq = genericLiftEq
instance Show1 Text where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Text where
liftPretty _ _ (Text s) = pretty ("Text" :: String) <+> prettyBytes s
data Link a = Link { linkURL :: ByteString, linkTitle :: Maybe ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Link where liftEq = genericLiftEq
instance Show1 Link where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Link where
liftPretty _ _ (Link u t) = pretty ("Link" :: String) <+> prettyBytes u <+> liftPretty prettyBytes (list . map prettyBytes) t
data Image a = Image { imageURL :: ByteString, imageTitle :: Maybe ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Image where liftEq = genericLiftEq
instance Show1 Image where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Image where
liftPretty _ _ (Image u t) = pretty ("Image" :: String) <+> prettyBytes u <+> liftPretty prettyBytes (list . map prettyBytes) t
data Code a = Code { codeLanguage :: Maybe ByteString, codeContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Code where liftEq = genericLiftEq
instance Show1 Code where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Code where
liftPretty _ _ (Code l c) = nest 2 (vsep (catMaybes [Just (pretty ("Code" :: String)), fmap prettyBytes l, Just (prettyBytes c)]))
data LineBreak a = LineBreak
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 LineBreak where liftEq = genericLiftEq
instance Show1 LineBreak where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 LineBreak where liftPretty = genericLiftPretty
newtype Strikethrough a = Strikethrough [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Strikethrough where liftEq = genericLiftEq
instance Show1 Strikethrough where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Strikethrough where liftPretty = genericLiftPretty

23
src/Data/Syntax/Statement.hs
View File

@ -4,7 +4,6 @@ module Data.Syntax.Statement where
import Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import GHC.Generics
@ -14,7 +13,6 @@ data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
instance Eq1 If where liftEq = genericLiftEq
instance Show1 If where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 If where liftPretty = genericLiftPretty
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
data Else a = Else { elseCondition :: !a, elseBody :: !a }
@ -22,7 +20,6 @@ data Else a = Else { elseCondition :: !a, elseBody :: !a }
instance Eq1 Else where liftEq = genericLiftEq
instance Show1 Else where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Else where liftPretty = genericLiftPretty
-- TODO: Alternative definition would flatten if/else if/else chains: data If a = If ![(a, a)] !(Maybe a)
@ -32,7 +29,6 @@ data Match a = Match { matchSubject :: !a, matchPatterns :: !a }
instance Eq1 Match where liftEq = genericLiftEq
instance Show1 Match where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Match where liftPretty = genericLiftPretty
-- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
data Pattern a = Pattern { pattern :: !a, patternBody :: !a }
@ -40,7 +36,6 @@ data Pattern a = Pattern { pattern :: !a, patternBody :: !a }
instance Eq1 Pattern where liftEq = genericLiftEq
instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Pattern where liftPretty = genericLiftPretty
-- | A let statement or local binding, like 'a as b' or 'let a = b'.
data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
@ -48,7 +43,6 @@ data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
instance Eq1 Let where liftEq = genericLiftEq
instance Show1 Let where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Let where liftPretty = genericLiftPretty
-- Assignment
@ -59,7 +53,6 @@ data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget ::
instance Eq1 Assignment where liftEq = genericLiftEq
instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Assignment where liftPretty = genericLiftPretty
-- Returns
@ -69,42 +62,36 @@ newtype Return a = Return a
instance Eq1 Return where liftEq = genericLiftEq
instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Return where liftPretty = genericLiftPretty
newtype Yield a = Yield a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Yield where liftEq = genericLiftEq
instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Yield where liftPretty = genericLiftPretty
newtype Break a = Break a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Break where liftEq = genericLiftEq
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Break where liftPretty = genericLiftPretty
newtype Continue a = Continue a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Continue where liftEq = genericLiftEq
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Continue where liftPretty = genericLiftPretty
newtype Retry a = Retry a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Retry where liftEq = genericLiftEq
instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Retry where liftPretty = genericLiftPretty
newtype NoOp a = NoOp a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 NoOp where liftEq = genericLiftEq
instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 NoOp where liftPretty = genericLiftPretty
-- Loops
@ -114,28 +101,24 @@ data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :
instance Eq1 For where liftEq = genericLiftEq
instance Show1 For where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 For where liftPretty = genericLiftPretty
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 ForEach where liftEq = genericLiftEq
instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 ForEach where liftPretty = genericLiftPretty
data While a = While { whileCondition :: !a, whileBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 While where liftEq = genericLiftEq
instance Show1 While where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 While where liftPretty = genericLiftPretty
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 DoWhile where liftEq = genericLiftEq
instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 DoWhile where liftPretty = genericLiftPretty
-- Exception handling
@ -145,28 +128,24 @@ newtype Throw a = Throw a
instance Eq1 Throw where liftEq = genericLiftEq
instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Throw where liftPretty = genericLiftPretty
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Try where liftEq = genericLiftEq
instance Show1 Try where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Try where liftPretty = genericLiftPretty
data Catch a = Catch { catchException :: !a, catchBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Catch where liftEq = genericLiftEq
instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Catch where liftPretty = genericLiftPretty
newtype Finally a = Finally a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Finally where liftEq = genericLiftEq
instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Finally where liftPretty = genericLiftPretty
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
@ -175,7 +154,6 @@ newtype ScopeEntry a = ScopeEntry [a]
instance Eq1 ScopeEntry where liftEq = genericLiftEq
instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 ScopeEntry where liftPretty = genericLiftPretty
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
@ -184,4 +162,3 @@ newtype ScopeExit a = ScopeExit [a]
instance Eq1 ScopeExit where liftEq = genericLiftEq
instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 ScopeExit where liftPretty = genericLiftPretty

5
src/Data/Syntax/Type.hs
View File

@ -4,7 +4,6 @@ module Data.Syntax.Type where
import Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import GHC.Generics
@ -13,27 +12,23 @@ data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
instance Eq1 Annotation where liftEq = genericLiftEq
instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Annotation where liftPretty = genericLiftPretty
newtype Product a = Product { productElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Product where liftEq = genericLiftEq
instance Show1 Product where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Product where liftPretty = genericLiftPretty
data Visibility a = Visibility { visibilitySubject :: !a, visibilityType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 Visibility where liftEq = genericLiftEq
instance Show1 Visibility where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Visibility where liftPretty = genericLiftPretty
data TypeParameters a = TypeParameters { typeParameters :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 TypeParameters where liftEq = genericLiftEq
instance Show1 TypeParameters where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 TypeParameters where liftPretty = genericLiftPretty
data Readonly a = Readonly
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)

9
src/Data/Text/Listable.hs
View File

@ -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)

6
src/Decorators.hs
View File

@ -8,11 +8,11 @@ module Decorators
import Data.Aeson
import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.Functor.Classes (Show1 (liftShowsPrec))
import Data.JSON.Fields
import Data.Proxy
import Data.Text.Encoding (decodeUtf8)
import Data.Union
import GHC.Generics
import Renderer.JSON
import Term
-- | Compute a 'ByteString' label for a 'Show1'able 'Term'.
@ -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

170
src/Diff.hs
View File

@ -1,37 +1,52 @@
{-# 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.Aeson
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.Foldable hiding (fold)
import Data.JSON.Fields
import Data.Mergeable
import Data.Record
import Data.Semigroup((<>))
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 +56,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
type instance Base (Diff syntax ann) = DiffF syntax ann
instance (Pretty1 f, Pretty a) => Pretty (Free.Free f a) where
pretty = liftPretty pretty prettyList
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
instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Diff f a) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where
toJSONFields = toJSONFields . unDiff
instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a b) where
toJSONFields (Copy a f) = toJSONFields a <> toJSONFields1 f
toJSONFields (Patch a) = toJSONFields a

29
src/Interpreter.hs
View File

@ -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))

20
src/Language.hs
View File

@ -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))

9
src/Language/Markdown.hs
View File

@ -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)))

20
src/Language/Markdown/Syntax.hs
View File

@ -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)

139
src/Language/Python/Syntax.hs
View File

@ -10,7 +10,6 @@ import Algorithm
import Data.Align.Generic
import Data.Functor (void)
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Show.Generic
import Data.List.NonEmpty (some1)
import Data.Maybe (fromMaybe)
@ -94,7 +93,6 @@ data Ellipsis a = Ellipsis
instance Eq1 Ellipsis where liftEq = genericLiftEq
instance Show1 Ellipsis where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Ellipsis where liftPretty = genericLiftPretty
data Redirect a = Redirect !a !a
@ -102,80 +100,81 @@ data Redirect a = Redirect !a !a
instance Eq1 Redirect where liftEq = genericLiftEq
instance Show1 Redirect where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Redirect where liftPretty = genericLiftPretty
-- | Assignment from AST in Python's grammar onto a program in Python's syntax.
assignment :: Assignment
assignment = handleError $ makeTerm <$> symbol Module <*> children (Syntax.Program <$> many expression) <|> parseError
expression :: Assignment
expression = term (handleError everything)
where -- Long-term, can we de/serialize assignments and avoid paying the cost of construction altogether?
everything = choice
[ argumentList
, assertStatement
, assignment'
, await
, binaryOperator
, boolean
, booleanOperator
, breakStatement
, call
, classDefinition
, comparisonOperator
, comprehension
, concatenatedString
, conditionalExpression
, continueStatement
, decoratedDefinition
, deleteStatement
, dictionary
, dictionarySplat
, dottedName
, ellipsis
, exceptClause
, execStatement
, expressionList
, expressionStatement
, finallyClause
, float
, forInClause
, forStatement
, functionDefinition
, globalStatement
, identifier
, ifClause
, ifStatement
, import'
, integer
, keywordArgument
, list'
, listSplat
, memberAccess
, none
, nonlocalStatement
, notOperator
, pair
, parameter
, parenthesizedExpression
, parseError
, passStatement
, printStatement
, raiseStatement
, returnStatement
, set
, slice
, string
, subscript
, tryStatement
, tuple
, type'
, unaryOperator
, variables
, whileStatement
, withStatement
, yield
]
expression = term (handleError (choice expressionChoices))
expressionChoices :: [Assignment.Assignment [] Grammar Term]
expressionChoices =
-- Long-term, can we de/serialize assignments and avoid paying the cost of construction altogether?
[ argumentList
, assertStatement
, assignment'
, await
, binaryOperator
, boolean
, booleanOperator
, breakStatement
, call
, classDefinition
, comparisonOperator
, comprehension
, concatenatedString
, conditionalExpression
, continueStatement
, decoratedDefinition
, deleteStatement
, dictionary
, dictionarySplat
, dottedName
, ellipsis
, exceptClause
, execStatement
, expressionList
, expressionStatement
, finallyClause
, float
, forInClause
, forStatement
, functionDefinition
, globalStatement
, identifier
, ifClause
, ifStatement
, import'
, integer
, keywordArgument
, list'
, listSplat
, memberAccess
, none
, nonlocalStatement
, notOperator
, pair
, parameter
, parenthesizedExpression
, parseError
, passStatement
, printStatement
, raiseStatement
, returnStatement
, set
, slice
, string
, subscript
, tryStatement
, tuple
, type'
, unaryOperator
, variables
, whileStatement
, withStatement
, yield
]
expressions :: Assignment
expressions = makeTerm <$> location <*> many expression

12
src/Language/Ruby.hs
View File

@ -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

13
src/Parser.hs
View File

@ -12,9 +12,8 @@ module Parser
, typescriptParser
) 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
@ -43,14 +42,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)
@ -84,5 +83,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)))

43
src/Patch.hs
View File

@ -2,9 +2,6 @@
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Patch
( Patch(..)
, replacing
, inserting
, deleting
, after
, before
, unPatch
@ -14,10 +11,11 @@ module Patch
, mapPatch
) where
import Control.DeepSeq
import Data.Aeson
import Data.Align
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Listable
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Show.Generic
import Data.JSON.Fields
import Data.These
import GHC.Generics
@ -26,22 +24,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,18 +61,16 @@ 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 Pretty1 Patch where liftPretty = genericLiftPretty
instance Eq1 Patch where liftEq = genericLiftEq
instance Show1 Patch where liftShowsPrec = genericLiftShowsPrec
instance Pretty a => Pretty (Patch a) where
pretty = liftPretty pretty prettyList
instance ToJSONFields a => ToJSONFields (Patch a) where
toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ]
toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ]
toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]

50
src/RWS.hs
View File

@ -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

12
src/Renderer.hs
View File

@ -18,12 +18,10 @@ 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)
import Data.JSON.Fields
import qualified Data.Map as Map
import Data.Output
import Data.Syntax.Algebra (RAlgebra)
@ -35,7 +33,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 +74,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 +93,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]

98
src/Renderer/JSON.hs
View File

@ -1,35 +1,18 @@
{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Renderer.JSON
( renderJSONDiff
, renderJSONTerm
, 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 (ToJSON, toJSON, object, (.=))
import Data.Aeson as A hiding (json)
import Data.Bifunctor.Join
import Data.Blob
import Data.ByteString.Lazy (toStrict)
import Data.Foldable (toList)
import Data.Functor.Both (Both)
import qualified Data.Map as Map
import Data.Output
import Data.Proxy
import Data.Record
import Data.Semigroup ((<>))
import Data.Text (pack, Text)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Union
import GHC.Generics
import Info
import Language
import Patch
import Syntax as S
--
-- Diffs
@ -43,88 +26,11 @@ renderJSONDiff blobs diff = Map.fromList
, ("paths", toJSON (blobPath <$> toList blobs))
]
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 ToJSON a => ToJSON (Join (,) a) where
toJSON = toJSON . toList
toEncoding = foldable
instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSON (Free 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))
class ToJSONFields a where
toJSONFields :: KeyValue kv => a -> [kv]
instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where
toJSONFields (h :. t) = toJSONFields h <> toJSONFields t
instance ToJSONFields (Record '[]) where
toJSONFields _ = []
instance ToJSONFields (Record fs) => ToJSON (Record fs) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
instance ToJSONFields Range where
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
instance ToJSONFields Category where
toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }]
instance ToJSONFields Span where
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
instance ToJSONFields a => ToJSONFields (Maybe a) where
toJSONFields = maybe [] toJSONFields
instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSONFields (Cofree f a) where
toJSONFields (a :< f) = toJSONFields a <> toJSONFields f
instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (CofreeF.CofreeF f a b) where
toJSONFields (a CofreeF.:< f) = toJSONFields a <> toJSONFields f
instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSONFields (Free f a) where
toJSONFields (Free f) = toJSONFields f
toJSONFields (Pure a) = toJSONFields a
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 ToJSON a => ToJSONFields (Patch a) where
toJSONFields (Insert a) = [ "insert" .= a ]
toJSONFields (Delete a) = [ "delete" .= a ]
toJSONFields (Replace a b) = [ "replace" .= [a, b] ]
instance ToJSON a => ToJSONFields [a] where
toJSONFields list = [ "children" .= list ]
instance ToJSON recur => ToJSONFields (Syntax recur) where
toJSONFields syntax = [ "children" .= toList syntax ]
instance (Apply1 Foldable fs, ToJSON a) => ToJSONFields (Union fs a) where
toJSONFields = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])
instance ToJSONFields (Union '[] a) where
toJSONFields _ = []
data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a }
deriving (Generic, Show)
instance ToJSON a => ToJSON (File a) where
toJSON File{..} = object [ "filePath" .= filePath, "language" .= fileLanguage, "programNode" .= fileContent ]
instance Output [Value] where
toOutput = toStrict . (<> "\n") . encode
renderJSONTerm :: ToJSON a => Blob -> a -> [Value]
renderJSONTerm Blob{..} = pure . toJSON . File blobPath blobLanguage

12
src/Renderer/SExpression.hs
View File

@ -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 = ""

37
src/Renderer/TOC.hs
View File

@ -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 (Error(..), showExpectation)
@ -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, Syntax.Empty :< 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{..} (a :< r)
declarationAlgebra Blob{..} (In a r)
-- Do not summarize anonymous functions
| Just (Declaration.Function _ (identifier, _) _ _) <- prj r
, Just Syntax.Empty <- prj (unwrap identifier)
@ -150,7 +144,7 @@ declarationAlgebra 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{..} (a :< r)
markupSectionAlgebra 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 (formatTOCError (Syntax.unError (sourceSpan a) err))) blobLanguage
| otherwise = Nothing
@ -175,11 +169,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)
@ -247,9 +244,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)

16
src/Semantic.hs
View File

@ -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, Just Language.TypeScript) -> parse typescriptParser blob >>= decorate (declarationAlgebra blob) >>= 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)
@ -76,7 +74,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, Just Language.TypeScript) -> run (\ blob -> parse typescriptParser blob >>= decorate (declarationAlgebra blob)) 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)
@ -89,11 +87,11 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
(PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffRecursively (renderPatch blobs)
(PatchDiffRenderer, Just Language.TypeScript) -> run (parse typescriptParser) 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, Just Language.TypeScript) -> run (decorate constructorLabel <=< parse typescriptParser) 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, Just Language.TypeScript) -> run (decorate constructorLabel <=< parse typescriptParser) 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

6
src/Semantic/Task.hs
View File

@ -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

10
src/Semantic/Util.hs
View File

@ -2,8 +2,9 @@
module Semantic.Util where
import Data.Blob
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Util
import Language.Haskell.HsColour (hscolour, Output(TTY))
import Language.Haskell.HsColour.Colourise (defaultColourPrefs)
import Text.Show.Pretty (ppShow)
import Files
import Data.Record
import Data.Functor.Classes
@ -24,8 +25,9 @@ import Data.Range
import Data.Span
import Data.Syntax
pp :: Pretty a => a -> IO ()
pp = putDocW 100 . (<> line) . pretty
-- Produces colorized pretty-printed output for the terminal / GHCi.
pp :: Show a => a -> IO ()
pp = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow
file :: FilePath -> IO Blob
file path = Files.readFile path (languageForFilePath path)

6
src/SplitDiff.hs
View File

@ -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.

77
src/Syntax.hs
View File

@ -1,15 +1,15 @@
{-# LANGUAGE DeriveAnyClass #-}
module Syntax where
import Control.DeepSeq
import Data.Aeson
import Data.Align.Generic
import Data.Foldable (toList)
import Data.Functor.Classes
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Listable
import Data.Functor.Classes.Show.Generic
import Data.JSON.Fields
import Data.Mergeable
import Data.Text (pack, Text)
import Data.Text (Text)
import GHC.Generics
-- | A node in an abstract syntax tree.
@ -111,7 +111,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 +121,8 @@ 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 Eq1 Syntax where liftEq = genericLiftEq
instance Show1 Syntax where liftShowsPrec = genericLiftShowsPrec
instance Listable recur => Listable (Syntax recur) where
tiers = tiers1
instance Eq1 Syntax where
liftEq = genericLiftEq
instance Pretty1 Syntax where liftPretty = genericLiftPretty
instance ToJSONFields1 Syntax where
toJSONFields1 syntax = [ "children" .= toList syntax ]

152
src/Term.hs
View File

@ -1,83 +1,123 @@
{-# 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
) 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.Aeson
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.Maybe
import Data.Proxy
import Data.JSON.Fields
import Data.Record
import Data.These
import Data.Union
import Data.Semigroup ((<>))
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
type instance Base (Term f a) = TermF f a
instance (Pretty1 f, Pretty a) => Pretty (Cofree.Cofree f a) where
pretty = liftPretty pretty prettyList
instance Functor f => Recursive (Term f a) where project = unTerm
instance Functor f => Corecursive (Term f a) where embed = Term
instance Apply1 Pretty1 fs => Pretty1 (Union fs) where
liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl)
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 (ToJSONFields a, ToJSONFields1 f) => ToJSON (Term f a) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Term f a) where
toJSONFields = toJSONFields . unTerm
instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (TermF f a b) where
toJSONFields (In a f) = toJSONFields a <> toJSONFields1 f

14
src/TreeSitter.hs
View File

@ -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
@ -65,7 +63,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
@ -110,7 +108,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
@ -120,7 +118,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
@ -155,7 +153,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
@ -166,7 +164,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
@ -181,7 +179,7 @@ defaultTermAssignment source annotation children allChildren
, RelationalOperator
, BitwiseOperator
]
toTerm = pure . cofree . (annotation :<)
toTerm = pure . Term . In annotation
categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category

207
test/AlignmentSpec.hs
View File

@ -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
View 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.

25
test/Data/RandomWalkSimilarity/Spec.hs
View File

@ -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

4
test/Data/Syntax/Assignment/Spec.hs
View File

@ -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)

18
test/DiffSpec.hs
View File

@ -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

3
test/IntegrationSpec.hs
View File

@ -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) ++)

12
test/InterpreterSpec.hs
View File

@ -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") ])

5
test/PatchOutputSpec.hs
View File

@ -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 = []}]

15
test/SemanticSpec.hs
View File

@ -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)

3
test/SourceSpec.hs
View File

@ -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

11
test/SpecHelpers.hs
View File

@ -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

83
test/TOCSpec.hs
View File

@ -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
@ -46,24 +42,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" $
@ -114,31 +110,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
@ -175,17 +171,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'
@ -198,12 +194,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
@ -212,22 +208,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)
@ -237,13 +233,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

1
vendor/ghc-mod vendored Submodule

@ -0,0 +1 @@
Subproject commit 7fb380dae0ae877a24ac8258fcd193cd6256a171

2
vendor/haskell-tree-sitter vendored

@ -1 +1 @@
Subproject commit 30805d19c277610399f4055993322228b19f6691
Subproject commit 6e430b9de70ac148bb6fb2f13f071dc825ad8682

1
vendor/prettyprinter vendored

@ -1 +0,0 @@
Subproject commit ec0e4825b18b5d43511396b03aac12b388c4ee02