Merge branch 'master' into fix-json-output-again

src/Algorithm.hs

@@ -34,6 +34,14 @@ diff = (liftF .) . Diff
 diffThese :: These term term -> Algorithm term diff diff
 diffThese = these byDeleting byInserting diff
 
+-- | Diff a pair of optional terms without specifying the algorithm to be used.
+diffMaybe :: Maybe term -> Maybe term -> Algorithm term diff (Maybe diff)
+diffMaybe a b = case (a, b) of
+  (Just a, Just b) -> Just <$> diff a b
+  (Just a, _) -> Just <$> byDeleting a
+  (_, Just b) -> Just <$> byInserting b
+  _ -> pure Nothing
+
 -- | Diff two terms linearly.
 linearly :: term -> term -> Algorithm term diff diff
 linearly a b = liftF (Linear a b)

src/Data/Align/Generic.hs

@@ -6,67 +6,70 @@ import Data.Align
 import Data.These
 import GHC.Generics
 import Prologue
-import Syntax
 
 -- | Functors which can be aligned (structure-unioning-ly zipped). The default implementation will operate generically over the constructors in the aligning type.
-class Functor f => GAlign f where
+class GAlign f where
   galign :: f a -> f b -> Maybe (f (These a b))
-  default galign :: (Generic1 f, GAlign (Rep1 f)) => f a -> f b -> Maybe (f (These a b))
-  galign a b = to1 <$> galign (from1 a) (from1 b)
+  galign = galignWith identity
 
   -- | Perform generic alignment of values of some functor, applying the given function to alignments of elements.
   galignWith :: (These a b -> c) -> f a -> f b -> Maybe (f c)
-  galignWith f = (fmap (fmap f) .) . galign
-
-
--- Generically-derived instances
-
-instance Eq a => GAlign (Syntax a)
+  default galignWith :: (Generic1 f, GAlign (Rep1 f)) => (These a b -> c) -> f a -> f b -> Maybe (f c)
+  galignWith f a b = to1 <$> galignWith f (from1 a) (from1 b)
 
 
 -- 'Data.Align.Align' instances
 
-instance GAlign [] where galign = galignAlign
-instance GAlign Maybe where galign = galignAlign
+instance GAlign [] where
+  galign = galignAlign
+  galignWith = galignWithAlign
+instance GAlign Maybe where
+  galign = galignAlign
+  galignWith = galignWithAlign
+instance GAlign Identity where
+  galignWith f (Identity a) (Identity b) = Just (Identity (f (These a b)))
 
 -- | Implements a function suitable for use as the definition of 'galign' for 'Align'able functors.
 galignAlign :: Align f => f a -> f b -> Maybe (f (These a b))
 galignAlign a = Just . align a
 
+galignWithAlign :: Align f => (These a b -> c) -> f a -> f b -> Maybe (f c)
+galignWithAlign f a b = Just (alignWith f a b)
+
 
 -- Generics
 
 -- | 'GAlign' over unit constructors.
 instance GAlign U1 where
-  galign _ _ = Just U1
+  galignWith _ _ _ = Just U1
 
 -- | 'GAlign' over parameters.
 instance GAlign Par1 where
-  galign (Par1 a) (Par1 b) = Just (Par1 (These a b))
+  galignWith f (Par1 a) (Par1 b) = Just (Par1 (f (These a b)))
 
 -- | 'GAlign' over non-parameter fields. Only equal values are aligned.
 instance Eq c => GAlign (K1 i c) where
-  galign (K1 a) (K1 b) = guard (a == b) >> Just (K1 b)
+  galignWith _ (K1 a) (K1 b) = guard (a == b) >> Just (K1 b)
 
 -- | 'GAlign' over applications over parameters.
 instance GAlign f => GAlign (Rec1 f) where
-  galign (Rec1 a) (Rec1 b) = Rec1 <$> galign a b
+  galignWith f (Rec1 a) (Rec1 b) = Rec1 <$> galignWith f a b
 
 -- | 'GAlign' over metainformation (constructor names, etc).
 instance GAlign f => GAlign (M1 i c f) where
-  galign (M1 a) (M1 b) = M1 <$> galign a b
+  galignWith f (M1 a) (M1 b) = M1 <$> galignWith f a b
 
 -- | 'GAlign' over sums. Returns 'Nothing' for disjoint constructors.
 instance (GAlign f, GAlign g) => GAlign (f :+: g) where
-  galign a b = case (a, b) of
-    (L1 a, L1 b) -> L1 <$> galign a b
-    (R1 a, R1 b) -> R1 <$> galign a b
+  galignWith f a b = case (a, b) of
+    (L1 a, L1 b) -> L1 <$> galignWith f a b
+    (R1 a, R1 b) -> R1 <$> galignWith f a b
     _ -> Nothing
 
 -- | 'GAlign' over products.
 instance (GAlign f, GAlign g) => GAlign (f :*: g) where
-  galign (a1 :*: b1) (a2 :*: b2) = (:*:) <$> galign a1 a2 <*> galign b1 b2
+  galignWith f (a1 :*: b1) (a2 :*: b2) = (:*:) <$> galignWith f a1 a2 <*> galignWith f b1 b2
 
 -- | 'GAlign' over type compositions.
 instance (Traversable f, Applicative f, GAlign g) => GAlign (f :.: g) where
-  galign (Comp1 a) (Comp1 b) = Comp1 <$> sequenceA (galign <$> a <*> b)
+  galignWith f (Comp1 a) (Comp1 b) = Comp1 <$> sequenceA (galignWith f <$> a <*> b)

src/Data/Functor/Union.hs

@@ -6,6 +6,7 @@ module Data.Functor.Union
 , InUnion(..)
 ) where
 
+import Data.Align.Generic
 import Data.Functor.Classes
 import Data.Kind
 import GHC.Show
@@ -111,3 +112,11 @@ instance (Show1 f, Show1 (Union fs)) => Show1 (Union (f ': fs)) where
 
 instance Show1 (Union '[]) where
   liftShowsPrec _ _ _ _ = identity
+
+instance (GAlign f, GAlign (Union fs)) => GAlign (Union (f ': fs)) where
+  galignWith f (Here a) (Here b) = Here <$> galignWith f a b
+  galignWith f (There a) (There b) = There <$> galignWith f a b
+  galignWith _ _ _ = Nothing
+
+instance GAlign (Union '[]) where
+  galignWith _ _ _ = Nothing

src/Data/Syntax.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Data.Syntax where
 
+import Data.Align.Generic
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import GHC.Generics
@@ -9,13 +11,13 @@ import Text.Show
 -- Undifferentiated
 
 newtype Leaf a = Leaf { leafContent :: ByteString }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Leaf where liftEq = genericLiftEq
 instance Show1 Leaf where liftShowsPrec = genericLiftShowsPrec
 
 newtype Branch a = Branch { branchElements :: [a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Branch where liftEq = genericLiftEq
 instance Show1 Branch where liftShowsPrec = genericLiftShowsPrec
@@ -25,7 +27,7 @@ instance Show1 Branch where liftShowsPrec = genericLiftShowsPrec
 
 -- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
 newtype Identifier a = Identifier ByteString
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Identifier where liftEq = genericLiftEq
 instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
@@ -35,7 +37,7 @@ instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
 --
 --   This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
 data Empty a = Empty
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Empty where liftEq _ _ _ = True
 instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"

src/Data/Syntax/Assignment.hs

@@ -1,4 +1,64 @@
 {-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeFamilies #-}
+-- | 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 SourceSpan). 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.
+--
+--   Assignments can be any of the following primitive rules:
+--
+--   1. 'symbol' rules match a node against a specific symbol in the source language’s grammar; they succeed iff a) there is a current node, and b) its symbol is equal to the argument symbol. Matching a 'symbol' rule does not advance past the current node, meaning that you can match a node against a symbol and also e.g. match against the node’s 'children'. This also means that some care must be taken, as repeating a symbol with 'many' or 'some' (see below) will never advance past the current node and could therefore loop forever.
+--
+--   2. 'location' rules always succeed, and produce the current node’s Location (byte Range and SourceSpan). If there is no current node (i.e. if matching has advanced past the root node or past the last child node when operating within a 'children' rule), the location is instead the end of the most recently matched node, specified as a zero-width Range and SourceSpan. 'location' rules do not advance past the current node, meaning that you can both match a node’s 'location' and other properties.
+--
+--   3. 'source' rules succeed whenever there is a current node (i.e. matching has not advanced past the root node or the last child node when operating within a 'children' rule), and produce its source as a ByteString. 'source' is intended to match leaf nodes such as e.g. comments. 'source' rules advance past the current node.
+--
+--   4. 'children' rules apply their argument (an assignment) to the children of the current node, succeeding iff a) there is a current node, b) the argument assignment matches the children, and c) there are no (regular) nodes left over (see below re: tokens), producing the result of matching the argument assignment against the children. 'children' rules can match a node with no child nodes if their argument can successfully match at the end of input.
+--
+--   5. Via the 'Alternative' instance, 'empty' assignments always fail. This can be used (in combination with the 'Monad' instance) to (for example) fail if a 'source' assignment produces an ill-formatted ByteString. However, see below re: committed choice.
+--
+--   6. Via the 'Applicative' instance, 'pure' (or via the 'Monad' instance, 'return') assignments always succeed, producing the passed value. They do not advance past the current node. In combination with the 'Alternative' instance, 'pure' can provide default values when optional syntax is not present in the AST.
+--
+--   Assignments can further be combined in a few different ways:
+--
+--   1. The 'Functor' instance maps values from the AST (Location, ByteString, etc.) into another structure.
+--
+--   2. The 'Applicative' instance assigns sequences of (sibling) AST nodes in order, as well as providing 'pure' assignments (see above). Most assignments of a single piece of syntax consist of an 'Applicative' chain of assignments.
+--
+--   3. The 'Alternative' instance chooses between a set of assignments, as well as providing 'empty' assignments (see above). See below re: committed choice for best practices for efficiency & error reporting when it comes to assigning multiple alternatives. Most high-level assignments (e.g. “declaration” or “statement” assignments) consist of choices among two or more 'Applicative' chains of assignments, mirroring the structure of the parser’s choices. The 'Alternative' instance also enables repetitions via the 'many' (≥ 0 repetitions) and 'some' (≥ 1 repetition) methods. Finally, the 'optional' function uses the 'Alternative' instance to assign a value in 'Maybe', succeeding with 'Nothing' when unmatched.
+--
+--   4. The 'Monad' instance allows assignments to depend on the results of earlier assignments. In general, most assignments should not be written using the 'Monad' instance; however, some specific situations require it, e.g. assigning 'x += y' to be equivalent to 'x = x + y'.
+--
+--
+--   == Best practices
+--
+--   Because of their flexibility, the same assignment can often be written in multiple different ways. The following best practices should ensure efficient assignment with clear error messages for ill-formed AST.
+--
+--   === Committed choice
+--
+--   Assignments can represent alternatives as either committed or uncommitted choices, both written with '<|>'. “Committed” in this context means that a failure in one of the alternatives will not result in backtracking followed by an attempt of one of the other alternatives; thus, committed choice is more efficient. (By the same token, it enables much better error messages since backtracking erases most of the relevant context.) Committed choices are constructed via the following rules:
+--
+--   1. 'empty' is dropped from choices:
+--   prop> empty <|> a = a -- empty is the left-identity of <|>
+--   prop> a <|> empty = a -- empty is the right-identity of <|>
+--
+--   2. 'symbol' rules construct a committed choice (with only a single alternative).
+--
+--   3. 'fmap' (and by extension '<$>' and '<$') of a committed choice is a committed choice.
+--
+--   4. '<*>' (and by extension '*>' and '<*') with a committed choice on the left is a committed choice.
+--
+--   5. '>>=' (and by extension '>>', '=<<', and '<<') of a committed choice is a committed choice. It may be helpful to think of this and the above rule for '<*>' as “sequences starting with committed choices remain committed choices.”
+--
+--   6. '<|>' of two committed choices is a committed choice.
+--
+--   Finally, if a given choice is not a committed choice, it is an uncommitted choice.
+--
+--   Distilling the above, the rule of thumb is to always start an assignment for a given piece of syntax with either a 'symbol' rule or an 'fmap' over a 'symbol' rule. When assigning multiple pieces of syntax, place any known uncommitted choices at the (rightmost) end of the chain; '<|>' is left-associative, so this guarantees that you’re adding at most one uncommitted choice on top of the ones already present.
+--
+--   === Matching tokens
+--
+--   AST symbols are classified by their 'symbolType' as either 'Regular', 'Anonymous', or 'Auxiliary'. 'Auxiliary' never appears in ASTs; 'Regular' is for the symbols of explicitly named productions in the grammar, and 'Anonymous' is for unnamed productions of content such as tokens. Most of the time, assignments are only concerned with the named productions, and thus will be using 'Regular' symbols. Therefore, when matching a committed choice of all-'Regular' symbols, nodes with 'Anonymous' symbols will be skipped. However, in some cases grammars don’t provide a named symbol for e.g. every kind of infix operator, and thus the only way to differentiate between them is by means of a 'symbol' rule for an 'Anonymous' token. In these cases, and before every other kind of assignment, the 'Anonymous' nodes will not be skipped so that matching can succeed.
+--
+--   Therefore, in addition to the rule of thumb for committed choices (see above), try to match 'Regular' symbols up front, and only match 'Anonymous' ones in the middle of a chain. That will ensure that you don’t have to make redundant effort to explicitly skip 'Anonymous' nodes ahead of multiple alternatives, and can instead rely on them being automatically skipped except when explicitly required.
 module Data.Syntax.Assignment
 ( Assignment
 , Location

src/Data/Syntax/Comment.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Data.Syntax.Comment where
 
+import Data.Align.Generic
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import GHC.Generics
@@ -7,7 +9,7 @@ import Prologue
 
 -- | An unnested comment (line or block).
 newtype Comment a = Comment { commentContent :: ByteString }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Comment where liftEq = genericLiftEq
 instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Declaration.hs

@@ -1,12 +1,14 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Data.Syntax.Declaration where
 
+import Data.Align.Generic
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import GHC.Generics
 import Prologue
 
 data Function a = Function { functionName :: !a, functionParameters :: ![a], functionBody :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Function where liftEq = genericLiftEq
 instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
@@ -14,7 +16,7 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
 -- TODO: How should we represent function types, where applicable?
 
 data Method a = Method { methodName :: !a, methodParameters :: ![a], methodBody :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Method where liftEq = genericLiftEq
 instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
@@ -24,7 +26,7 @@ instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
 
 
 data Class a = Class { classIdentifier :: !a, classSuperclasses :: ![a], classScope :: ![a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Class where liftEq = genericLiftEq
 instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
@@ -34,14 +36,14 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
 
 -- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
 data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
 instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec
 
 -- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
 data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
 instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Expression.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Data.Syntax.Expression where
 
+import Data.Align.Generic
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import GHC.Generics
@@ -7,7 +9,7 @@ import Prologue
 
 -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
 data Call a = Call { callFunction :: a, callParams :: [a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Call where liftEq = genericLiftEq
 instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
@@ -15,7 +17,7 @@ instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
 
 -- | Unary boolean negation, like '!x' in many languages.
 data Not a = Not a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Not where liftEq = genericLiftEq
 instance Show1 Not where liftShowsPrec = genericLiftShowsPrec
@@ -23,7 +25,7 @@ instance Show1 Not where liftShowsPrec = genericLiftShowsPrec
 
 -- | Binary addition.
 data Plus a = Plus a a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Plus where liftEq = genericLiftEq
 instance Show1 Plus where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Literal.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric #-}
 module Data.Syntax.Literal where
 
+import Data.Align.Generic
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import Data.Syntax.Comment
@@ -11,7 +12,7 @@ import Prologue
 -- Boolean
 
 newtype Boolean a = Boolean Bool
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 true :: Boolean a
 true = Boolean True
@@ -27,7 +28,7 @@ instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 
 -- | A literal integer of unspecified width. No particular base is implied.
 newtype Integer a = Integer { integerContent :: ByteString }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
 instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec
@@ -39,7 +40,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
 
 
 data Range a = Range { rangeStart :: a, rangeEnd :: a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Range where liftEq = genericLiftEq
 instance Show1 Range where liftShowsPrec = genericLiftShowsPrec
@@ -48,7 +49,7 @@ instance Show1 Range where liftShowsPrec = genericLiftShowsPrec
 -- Strings, symbols
 
 newtype String a = String { stringElements :: [Union '[InterpolationElement, TextElement] a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 String where liftEq = genericLiftEq
 instance Show1 String where liftShowsPrec = genericLiftShowsPrec
@@ -57,7 +58,7 @@ instance Show1 String where liftShowsPrec = genericLiftShowsPrec
 
 -- | An interpolation element within a string literal.
 newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 InterpolationElement where liftEq = genericLiftEq
 instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec
@@ -65,14 +66,14 @@ instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec
 
 -- | A sequence of textual contents within a string literal.
 newtype TextElement a = TextElement { textElementContent :: ByteString }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 TextElement where liftEq = genericLiftEq
 instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
 
 
 newtype Symbol a = Symbol { symbolContent :: ByteString }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Symbol where liftEq = genericLiftEq
 instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
@@ -85,21 +86,21 @@ instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
 -- Collections
 
 newtype Array a = Array { arrayElements :: [Union '[Identity, Comment] a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Array where liftEq = genericLiftEq
 instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
 
 
 newtype Hash a = Hash { hashElements :: [Union '[KeyValue, Comment] a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Hash where liftEq = genericLiftEq
 instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
 
 
 data KeyValue a = KeyValue { key :: !a, value :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 KeyValue where liftEq = genericLiftEq
 instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Statement.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveAnyClass, StandaloneDeriving #-}
 module Data.Syntax.Statement where
 
+import Data.Align.Generic
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import GHC.Generics
@@ -8,7 +9,7 @@ import Prologue
 
 -- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
 data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 If where liftEq = genericLiftEq
 instance Show1 If where liftShowsPrec = genericLiftShowsPrec
@@ -17,14 +18,14 @@ instance Show1 If where liftShowsPrec = genericLiftShowsPrec
 
 -- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
 data Match with a = Match { matchSubject :: !a, matchPatterns :: ![with a] }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 with => Eq1 (Match with) where liftEq = genericLiftEq
 instance Show1 with => Show1 (Match with) where liftShowsPrec = genericLiftShowsPrec
 
 -- | 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.
 newtype Pattern a = Pattern a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Pattern where liftEq = genericLiftEq
 instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec
@@ -34,7 +35,7 @@ instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec
 
 -- | Assignment to a variable or other lvalue.
 data Assignment a = Assignment { assignmentTarget :: !a, assignmentValue :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Assignment where liftEq = genericLiftEq
 instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
@@ -43,25 +44,25 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
 -- Returns
 
 newtype Return a = Return a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Return where liftEq = genericLiftEq
 instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
 
 newtype Yield a = Yield a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Yield where liftEq = genericLiftEq
 instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec
 
 newtype Break a = Break a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Break where liftEq = genericLiftEq
 instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
 
 newtype Continue a = Continue a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Continue where liftEq = genericLiftEq
 instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
@@ -70,25 +71,25 @@ instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
 -- Loops
 
 data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 For where liftEq = genericLiftEq
 instance Show1 For where liftShowsPrec = genericLiftShowsPrec
 
 data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 ForEach where liftEq = genericLiftEq
 instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec
 
 data While a = While { whileCondition :: !a, whileBody :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 While where liftEq = genericLiftEq
 instance Show1 While where liftShowsPrec = genericLiftShowsPrec
 
 data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 DoWhile where liftEq = genericLiftEq
 instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
@@ -97,13 +98,13 @@ instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
 -- Exception handling
 
 newtype Throw a = Throw a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Throw where liftEq = genericLiftEq
 instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec
 
 data Try with a = Try !a ![with a]
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 -- deriving instance (Eq a, Eq (with a)) => Eq (Try with a)
 -- deriving instance (Show a, Show (with a)) => Show (Try with a)
 
@@ -111,13 +112,13 @@ instance Eq1 with => Eq1 (Try with) where liftEq = genericLiftEq
 instance Show1 with => Show1 (Try with) where liftShowsPrec = genericLiftShowsPrec
 
 data Catch a = Catch !(Maybe a) !a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Catch where liftEq = genericLiftEq
 instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec
 
 newtype Finally a = Finally a
-  deriving (Eq, Foldable, Functor, Generic1, Show, Traversable)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Finally where liftEq = genericLiftEq
 instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Type.hs

@@ -1,9 +1,17 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Data.Syntax.Type where
 
-import Prologue
+import Data.Align.Generic
+import Data.Functor.Classes.Eq.Generic
+import Data.Functor.Classes.Show.Generic
+import GHC.Generics
+import Prologue hiding (Product)
 
 data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
-  deriving (Eq, Show)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 newtype Product a = Product { productElements :: [a] }
-  deriving (Eq, Show)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
+
+instance Eq1 Product where liftEq = genericLiftEq
+instance Show1 Product where liftShowsPrec = genericLiftShowsPrec

src/Interpreter.hs

@@ -1,10 +1,11 @@
-{-# LANGUAGE GADTs, RankNTypes #-}
-module Interpreter (diffTerms, run, runSteps, runStep) where
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
+module Interpreter (diffTerms, runAlgorithm, runAlgorithmSteps) where
 
 import Algorithm
 import Control.Monad.Free.Freer
 import Data.Align.Generic
 import Data.Functor.Both
+import Data.Functor.Classes (Eq1)
 import RWS
 import Data.Record
 import Data.These
@@ -20,36 +21,32 @@ diffTerms :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureV
   => SyntaxTerm leaf fields -- ^ A term representing the old state.
   -> SyntaxTerm leaf fields -- ^ A term representing the new state.
   -> SyntaxDiff leaf fields
-diffTerms = (run .) . diff
+diffTerms = (runAlgorithm (decomposeWith algorithmWithTerms) .) . diff
 
--- | Run an Algorithm to completion, returning its result.
-run :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector))
-    => Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) result
-    -> result
-run = iterFreer (\ algorithm cont -> cont (run (decompose algorithm)))
+-- | Run an Algorithm to completion by repeated application of a stepping operation and return its result.
+runAlgorithm :: forall f result
+             .  (forall x. f x -> Freer f x)
+             -> Freer f result
+             -> result
+runAlgorithm decompose = go
+  where go :: Freer f x -> x
+        go = iterFreer (\ algorithm yield -> yield (go (decompose algorithm)))
 
--- | Run an Algorithm to completion, returning the list of steps taken.
-runSteps :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector))
-    => Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) result
-    -> [Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) result]
-runSteps algorithm = case runStep algorithm of
-  Left a -> [Return a]
-  Right next -> next : runSteps next
+-- | Run an Algorithm to completion by repeated application of a stepping operation, returning the list of steps taken up to and including the final result.
+runAlgorithmSteps :: (forall x. f x -> Freer f x)
+                  -> Freer f result
+                  -> [Freer f result]
+runAlgorithmSteps decompose = go
+  where go algorithm = case algorithm of
+          Return a -> [Return a]
+          step `Then` yield -> algorithm : go (decompose step >>= yield)
 
--- | Run a single step of an Algorithm, returning Either its result if it has finished, or the next step otherwise.
-runStep :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector))
-        => Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) result
-        -> Either result (Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) result)
-runStep step = case step of
-  Return a -> Left a
-  algorithm `Then` cont -> Right $ decompose algorithm >>= cont
-
-
--- | Decompose a step of an algorithm into the next steps to perform.
-decompose :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector))
-          => AlgorithmF (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) result -- ^ The step in an algorithm to decompose into its next steps.
-          -> Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) result -- ^ The sequence of next steps to undertake to continue the algorithm.
-decompose step = case step of
+-- | Decompose a step of an algorithm into the next steps to perform using a helper function.
+decomposeWith :: (Traversable f, GAlign f, Eq1 f, HasField fields (Maybe FeatureVector), HasField fields Category)
+              => (Term f (Record fields) -> Term f (Record fields) -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) (Diff f (Record fields)))
+              -> AlgorithmF (Term f (Record fields)) (Diff f (Record fields)) result
+              -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) result
+decomposeWith algorithmWithTerms step = case step of
   Diff t1 t2 -> algorithmWithTerms t1 t2
   Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of
     Just result -> wrap . (both (extract t1) (extract t2) :<) <$> sequenceA result
@@ -64,51 +61,45 @@ decompose step = case step of
 algorithmWithTerms :: SyntaxTerm leaf fields
                    -> SyntaxTerm leaf fields
                    -> Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) (SyntaxDiff leaf fields)
-algorithmWithTerms t1 t2 = maybe (linearly t1 t2) (fmap annotate) $ case (unwrap t1, unwrap t2) of
+algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
   (Indexed a, Indexed b) ->
-    Just $ Indexed <$> byRWS a b
+    annotate . Indexed <$> byRWS a b
   (S.Module idA a, S.Module idB b) ->
-    Just $ S.Module <$> linearly idA idB <*> byRWS a b
-  (S.FunctionCall identifierA typeParamsA argsA, S.FunctionCall identifierB typeParamsB argsB) -> Just $
+    (annotate .) . S.Module <$> linearly idA idB <*> byRWS a b
+  (S.FunctionCall identifierA typeParamsA argsA, S.FunctionCall identifierB typeParamsB argsB) -> fmap annotate $
     S.FunctionCall <$> linearly identifierA identifierB
                    <*> byRWS typeParamsA typeParamsB
                    <*> byRWS argsA argsB
-  (S.Switch exprA casesA, S.Switch exprB casesB) -> Just $
+  (S.Switch exprA casesA, S.Switch exprB casesB) -> fmap annotate $
     S.Switch <$> byRWS exprA exprB
              <*> byRWS casesA casesB
-  (S.Object tyA a, S.Object tyB b) -> Just $
-    S.Object <$> maybeLinearly tyA tyB
+  (S.Object tyA a, S.Object tyB b) -> fmap annotate $
+    S.Object <$> diffMaybe tyA tyB
              <*> byRWS a b
-  (Commented commentsA a, Commented commentsB b) -> Just $
+  (Commented commentsA a, Commented commentsB b) -> fmap annotate $
     Commented <$> byRWS commentsA commentsB
-              <*> maybeLinearly a b
-  (Array tyA a, Array tyB b) -> Just $
-    Array <$> maybeLinearly tyA tyB
+              <*> diffMaybe a b
+  (Array tyA a, Array tyB b) -> fmap annotate $
+    Array <$> diffMaybe tyA tyB
           <*> byRWS a b
-  (S.Class identifierA clausesA expressionsA, S.Class identifierB clausesB expressionsB) -> Just $
+  (S.Class identifierA clausesA expressionsA, S.Class identifierB clausesB expressionsB) -> fmap annotate $
     S.Class <$> linearly identifierA identifierB
             <*> byRWS clausesA clausesB
             <*> byRWS expressionsA expressionsB
-  (S.Method clausesA identifierA receiverA paramsA expressionsA, S.Method clausesB identifierB receiverB paramsB expressionsB) -> Just $
+  (S.Method clausesA identifierA receiverA paramsA expressionsA, S.Method clausesB identifierB receiverB paramsB expressionsB) -> fmap annotate $
     S.Method <$> byRWS clausesA clausesB
              <*> linearly identifierA identifierB
-             <*> maybeLinearly receiverA receiverB
+             <*> diffMaybe receiverA receiverB
              <*> byRWS paramsA paramsB
              <*> byRWS expressionsA expressionsB
-  (S.Function idA paramsA bodyA, S.Function idB paramsB bodyB) -> Just $
+  (S.Function idA paramsA bodyA, S.Function idB paramsB bodyB) -> fmap annotate $
     S.Function <$> linearly idA idB
                <*> byRWS paramsA paramsB
                <*> byRWS bodyA bodyB
-  _ -> Nothing
+  _ -> linearly t1 t2
   where
     annotate = wrap . (both (extract t1) (extract t2) :<)
 
-    maybeLinearly a b = case (a, b) of
-      (Just a, Just b) -> Just <$> linearly a b
-      (Nothing, Just b) -> Just <$> byInserting b
-      (Just a, Nothing) -> Just <$> byDeleting a
-      (Nothing, Nothing) -> pure Nothing
-
 
 -- | Test whether two terms are comparable.
 comparable :: (Functor f, HasField fields Category) => Term f (Record fields) -> Term f (Record fields) -> Bool
@@ -121,7 +112,7 @@ 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, HasField fields Category) => Integer -> These (Term f (Record fields)) (Term f (Record fields)) -> Int
+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))

src/Syntax.hs

@@ -2,6 +2,7 @@
 module Syntax where
 
 import Data.Aeson
+import Data.Align.Generic
 import Data.Functor.Classes
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Listable
@@ -184,3 +185,5 @@ instance (Listable leaf, Listable recur) => Listable (Syntax leaf recur) where
 
 instance Eq leaf => Eq1 (Syntax leaf) where
   liftEq = genericLiftEq
+
+instance Eq leaf => GAlign (Syntax leaf)