Merge remote-tracking branch 'origin/master' into subparsers

semantic-diff.cabal

@@ -22,11 +22,21 @@ library
                      , Data.Align.Generic
                      , Data.Functor.Both
                      , Data.Functor.Classes.Eq.Generic
+                     , Data.Functor.Classes.Show.Generic
                      , Data.Functor.Listable
+                     , Data.Functor.Union
                      , Data.Mergeable
                      , Data.Mergeable.Generic
                      , Data.RandomWalkSimilarity
                      , Data.Record
+                     , Data.Syntax
+                     , Data.Syntax.Assignment
+                     , Data.Syntax.Comment
+                     , Data.Syntax.Declaration
+                     , Data.Syntax.Expression
+                     , Data.Syntax.Literal
+                     , Data.Syntax.Statement
+                     , Data.Syntax.Type
                      , Data.Text.Listable
                      , Diff
                      , Info
@@ -38,6 +48,7 @@ library
                      , Language.Markdown
                      , Language.Go
                      , Language.Ruby
+                     , Language.Ruby.Syntax
                      , Parser
                      , Patch
                      , Paths_semantic_diff
@@ -137,6 +148,7 @@ test-suite test
                      , Command.Parse.Spec
                      , Data.Mergeable.Spec
                      , Data.RandomWalkSimilarity.Spec
+                     , Data.Syntax.Assignment.Spec
                      , DiffSpec
                      , SemanticSpec
                      , SummarySpec

src/Data/Functor/Classes/Eq/Generic.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TypeOperators #-}
 module Data.Functor.Classes.Eq.Generic
-( genericLiftEq
+( Eq1(..)
+, genericLiftEq
 , gliftEq
 ) where
 
@@ -44,8 +45,8 @@ instance GEq1 Par1 where
 instance Eq c => GEq1 (K1 i c) where
   gliftEq _ (K1 a) (K1 b) = a == b
 
-instance GEq1 f => GEq1 (Rec1 f) where
+instance Eq1 f => GEq1 (Rec1 f) where
-  gliftEq f (Rec1 a) (Rec1 b) = gliftEq f a b
+  gliftEq f (Rec1 a) (Rec1 b) = liftEq f a b
 
 instance GEq1 f => GEq1 (M1 i c f) where
   gliftEq f (M1 a) (M1 b) = gliftEq f a b
@@ -59,5 +60,5 @@ instance (GEq1 f, GEq1 g) => GEq1 (f :+: g) where
 instance (GEq1 f, GEq1 g) => GEq1 (f :*: g) where
   gliftEq f (a1 :*: b1) (a2 :*: b2) = gliftEq f a1 a2 && gliftEq f b1 b2
 
-instance (GEq1 f, GEq1 g) => GEq1 (f :.: g) where
+instance (Eq1 f, GEq1 g) => GEq1 (f :.: g) where
-  gliftEq f (Comp1 a) (Comp1 b) = gliftEq (gliftEq f) a b
+  gliftEq f (Comp1 a) (Comp1 b) = liftEq (gliftEq f) a b

src/Data/Functor/Classes/Show/Generic.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE TypeOperators #-}
+module Data.Functor.Classes.Show.Generic
+( Show1(..)
+, genericLiftShowsPrec
+, genericLiftShowList
+, gliftShowsPrec
+, gliftShowList
+) where
+
+import Data.Functor.Classes
+import GHC.Generics
+import Prologue
+import Text.Show
+
+-- | Generically-derivable lifting of the 'Show' class to unary type constructors.
+class GShow1 f where
+  -- | showsPrec function for an application of the type constructor based on showsPrec and showList functions for the argument type.
+  gliftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
+
+  -- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types.
+  gliftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
+  gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0)
+
+-- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types.
+genericLiftShowsPrec :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
+genericLiftShowsPrec sp sl d = gliftShowsPrec sp sl d . from1
+
+-- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types.
+genericLiftShowList :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
+genericLiftShowList sp sl = gliftShowList sp sl . map from1
+
+
+-- Show1 instances
+
+instance GShow1 [] where gliftShowsPrec = liftShowsPrec
+instance GShow1 Maybe where gliftShowsPrec = liftShowsPrec
+instance Show a => GShow1 ((,) a) where gliftShowsPrec = liftShowsPrec
+instance Show a => GShow1 (Either a) where gliftShowsPrec = liftShowsPrec
+
+
+-- Generics
+
+instance GShow1 U1 where
+  gliftShowsPrec _ _ _ _ = identity
+
+instance GShow1 Par1 where
+  gliftShowsPrec sp _ d (Par1 a) = sp d a
+
+instance Show c => GShow1 (K1 i c) where
+  gliftShowsPrec _ _ d (K1 a) = showsPrec d a
+
+instance Show1 f => GShow1 (Rec1 f) where
+  gliftShowsPrec sp sl d (Rec1 a) = liftShowsPrec sp sl d a
+
+instance GShow1 f => GShow1 (M1 D c f) where
+  gliftShowsPrec sp sl d (M1 a) = gliftShowsPrec sp sl d a
+
+instance (Constructor c, GShow1 f) => GShow1 (M1 C c f) where
+  gliftShowsPrec sp sl d m = showsUnaryWith (gliftShowsPrec sp sl) (conName m) d (unM1 m)
+
+instance GShow1 f => GShow1 (M1 S c f) where
+  gliftShowsPrec sp sl d (M1 a) = gliftShowsPrec sp sl d a
+
+instance (GShow1 f, GShow1 g) => GShow1 (f :+: g) where
+  gliftShowsPrec sp sl d (L1 l) = gliftShowsPrec sp sl d l
+  gliftShowsPrec sp sl d (R1 r) = gliftShowsPrec sp sl d r
+
+instance (GShow1 f, GShow1 g) => GShow1 (f :*: g) where
+  gliftShowsPrec sp sl d (a :*: b) = gliftShowsPrec sp sl d a . showChar ' ' . gliftShowsPrec sp sl d b
+
+instance (Show1 f, GShow1 g) => GShow1 (f :.: g) where
+  gliftShowsPrec sp sl d (Comp1 a) = liftShowsPrec (gliftShowsPrec sp sl) (gliftShowList sp sl) d a

src/Data/Functor/Union.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, PolyKinds, TypeFamilies, TypeOperators #-}
+module Data.Functor.Union
+( Union
+, wrapU
+, unwrapU
+) where
+
+import Data.Functor.Classes
+import Data.Kind
+import GHC.Show
+import Prologue
+
+-- | N-ary union of type constructors.
+data Union (ts :: [k -> *]) (a :: k) where
+  Here :: f a -> Union (f ': ts) a
+  There :: Union ts a -> Union (f ': ts) a
+
+-- | Embed a functor in a union and lift the union into a free monad.
+wrapU :: (MonadFree (Union fs) m, InUnion fs f) => f (m a) -> m a
+wrapU = wrap . emb
+
+-- | Unwrap a cofree comonad and project a functor from the resulting union.
+unwrapU :: (ComonadCofree (Union fs) w, InUnion fs f) => w a -> Maybe (f (w a))
+unwrapU = proj . unwrap
+
+
+-- Classes
+
+class InUnion (fs :: [* -> *]) (f :: * -> *) where
+  emb :: f a -> Union fs a
+  proj :: Union fs a -> Maybe (f a)
+
+type family Superset (combine :: [k] -> k -> Constraint) (fs :: [k]) (gs :: [k]) :: Constraint where
+  Superset combine fs (g ': gs) = (combine fs g, Superset combine fs gs)
+  Superset combine fs '[] = ()
+
+
+-- Instances
+
+instance {-# OVERLAPPABLE #-} InUnion (f ': fs) f where
+  emb = Here
+  proj (Here f) = Just f
+  proj _ = Nothing
+
+instance {-# OVERLAPPABLE #-} InUnion fs f => InUnion (g ': fs) f where
+  emb f = There (emb f)
+  proj (There fs) = proj fs
+  proj _ = Nothing
+
+
+instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f ': fs)) where
+  foldMap f (Here r) = foldMap f r
+  foldMap f (There t) = foldMap f t
+
+instance Foldable (Union '[]) where
+  foldMap _ _ = mempty
+
+
+instance (Eq (f a), Eq (Union fs a)) => Eq (Union (f ': fs) a) where
+  Here f1 == Here f2 = f1 == f2
+  There fs1 == There fs2 = fs1 == fs2
+  _ == _ = False
+
+instance Eq (Union '[] a) where
+  _ == _ = False
+
+
+instance (Show (f a), Show (Union fs a)) => Show (Union (f ': fs) a) where
+  showsPrec d s = case s of
+    Here f -> showsPrec d f
+    There fs -> showsPrec d fs
+
+instance Show (Union '[] a) where
+  showsPrec _ _ = identity
+
+instance (Eq1 f, Eq1 (Union fs)) => Eq1 (Union (f ': fs)) where
+  liftEq eq (Here f) (Here g) = liftEq eq f g
+  liftEq eq (There f) (There g) = liftEq eq f g
+  liftEq _ _ _ = False
+
+instance Eq1 (Union '[]) where
+  liftEq _ _ _ = False -- We can never get here anyway.
+
+instance (Show1 f, Show1 (Union fs)) => Show1 (Union (f ': fs)) where
+  liftShowsPrec sp sl d (Here f) = showsUnaryWith (liftShowsPrec sp sl) "emb" d f
+  liftShowsPrec sp sl d (There f) = liftShowsPrec sp sl d f
+
+instance Show1 (Union '[]) where
+  liftShowsPrec _ _ _ _ = identity

src/Data/Syntax.hs

@@ -0,0 +1,30 @@
+module Data.Syntax where
+
+import Data.Functor.Classes.Eq.Generic
+import Data.Functor.Classes.Show.Generic
+import GHC.Generics
+import Prologue
+
+-- Undifferentiated
+
+newtype Leaf a = Leaf { leafContent :: ByteString }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Leaf where liftEq = genericLiftEq
+instance Show1 Leaf where liftShowsPrec = genericLiftShowsPrec
+
+newtype Branch a = Branch { branchElements :: [a] }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Branch where liftEq = genericLiftEq
+instance Show1 Branch where liftShowsPrec = genericLiftShowsPrec
+
+
+-- Common
+
+-- | 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, Generic1, Show)
+
+instance Eq1 Identifier where liftEq = genericLiftEq
+instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Assignment.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE GADTs #-}
+module Data.Syntax.Assignment
+( Assignment
+, rule
+, content
+, children
+, Rose(..)
+, Node(..)
+, AST
+, assignAll
+, runAssignment
+) where
+
+import Control.Monad.Free.Freer
+import Data.Functor.Classes
+import Prologue hiding (Alt)
+import Text.Show
+
+-- | Assignment from an AST with some set of 'symbol's onto some other value.
+--
+--   This is essentially a parser.
+type Assignment symbol = Freer (AssignmentF symbol)
+
+data AssignmentF symbol a where
+  Rule :: symbol -> AssignmentF symbol ()
+  Content :: AssignmentF symbol ByteString
+  Children :: Assignment symbol a -> AssignmentF symbol a
+  Alt :: a -> a -> AssignmentF symbol a
+  Empty :: AssignmentF symbol a
+
+-- | Zero-width match of a node with the given symbol.
+--
+--   Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. 'many (rule A *> b)' is fine, but 'many (rule A)' is not.
+rule :: symbol -> Assignment symbol ()
+rule symbol = Rule symbol `Then` return
+
+-- | A rule to produce a node’s content as a ByteString.
+content :: Assignment symbol ByteString
+content = Content `Then` return
+
+-- | Match a node by applying an assignment to its children.
+children :: Assignment symbol a -> Assignment symbol a
+children forEach = Children forEach `Then` return
+
+
+-- | A rose tree.
+data Rose a = Rose a [Rose a]
+  deriving (Eq, Functor, Show)
+
+-- | A node in the input AST. We only concern ourselves with its symbol (considered as an element of 'grammar') and content.
+data Node grammar = Node { nodeSymbol :: grammar, nodeContent :: ByteString }
+  deriving (Eq, Show)
+
+-- | An abstract syntax tree.
+type AST grammar = Rose (Node grammar)
+
+-- | Run an assignment of nodes in a grammar onto terms in a syntax, discarding any unparsed nodes.
+assignAll :: Eq grammar => Assignment grammar a -> [AST grammar] -> Maybe a
+assignAll = (fmap snd .) . runAssignment
+
+-- | Run an assignment of nodes in a grammar onto terms in a syntax.
+runAssignment :: Eq grammar => Assignment grammar a -> [AST grammar] -> Maybe ([AST grammar], a)
+runAssignment = iterFreer (\ assignment yield nodes -> case (assignment, nodes) of
+  -- Nullability: some rules, e.g. 'pure a' and 'many a', should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input.
+  (Alt a b, nodes) -> yield a nodes <|> yield b nodes -- FIXME: Rule `Alt` Rule `Alt` Rule is inefficient, should build and match against an IntMap instead.
+  (assignment, Rose Node{..} children : rest) -> case assignment of
+    Rule symbol -> guard (symbol == nodeSymbol) >> yield () nodes
+    Content -> yield nodeContent rest
+    Children childAssignment -> assignAll childAssignment children >>= flip yield rest
+    _ -> Nothing
+  _ -> Nothing)
+  . fmap ((Just .) . flip (,))
+
+
+instance Alternative (Assignment symbol) where
+  empty = Empty `Then` return
+  (<|>) = (wrap .) . Alt
+
+instance Show symbol => Show1 (AssignmentF symbol) where
+  liftShowsPrec sp sl d a = case a of
+    Rule s -> showsUnaryWith showsPrec "Rule" d s . showChar ' ' . sp d ()
+    Content -> showString "Content" . showChar ' ' . sp d ""
+    Children a -> showsUnaryWith (liftShowsPrec sp sl) "Children" d a
+    Alt a b -> showsBinaryWith sp sp "Alt" d a b
+    Empty -> showString "Empty"

src/Data/Syntax/Comment.hs

@@ -0,0 +1,17 @@
+module Data.Syntax.Comment where
+
+import Data.Functor.Classes.Eq.Generic
+import Data.Functor.Classes.Show.Generic
+import GHC.Generics
+import Prologue
+
+-- | An unnested comment (line or block).
+newtype Comment a = Comment { commentContent :: ByteString }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Comment where liftEq = genericLiftEq
+instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: nested comment types
+-- TODO: documentation comment types
+-- TODO: literate programming comment types? alternatively, consider those as markup

src/Data/Syntax/Declaration.hs

@@ -0,0 +1,47 @@
+module Data.Syntax.Declaration where
+
+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, Generic1, Show)
+
+instance Eq1 Function where liftEq = genericLiftEq
+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, Generic1, Show)
+
+instance Eq1 Method where liftEq = genericLiftEq
+instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Should we replace this with Function and differentiate by context?
+-- TODO: How should we distinguish class/instance methods?
+
+
+data Class a = Class { classIdentifier :: !a, classSuperclasses :: ![a], classScope :: ![a] }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Class where liftEq = genericLiftEq
+instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Generics, constraints.
+
+
+-- | 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, Generic1, Show)
+
+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, Generic1, Show)
+
+instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
+instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Expression.hs

@@ -0,0 +1,13 @@
+module Data.Syntax.Expression where
+
+import Data.Functor.Classes.Eq.Generic
+import Data.Functor.Classes.Show.Generic
+import GHC.Generics
+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, Generic1, Show)
+
+instance Eq1 Call where liftEq = genericLiftEq
+instance Show1 Call where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Literal.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric #-}
+module Data.Syntax.Literal where
+
+import Data.Functor.Classes.Eq.Generic
+import Data.Functor.Classes.Show.Generic
+import Data.Syntax.Comment
+import Data.Functor.Union
+import GHC.Generics
+import Prologue
+
+-- Boolean
+
+newtype Boolean a = Boolean Bool
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Boolean where liftEq = genericLiftEq
+instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
+
+
+-- Numeric
+
+-- | A literal integer of unspecified width. No particular base is implied.
+newtype Integer a = Integer { integerContent :: ByteString }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
+instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Should IntegerLiteral hold an Integer instead of a ByteString?
+-- TODO: Do we care about differentiating between hex/octal/decimal/binary integer literals?
+-- TODO: Float/Double literals.
+
+
+-- Strings, symbols
+
+newtype String a = String { stringElements :: [Union '[InterpolationElement, TextElement] a] }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 String where liftEq = genericLiftEq
+instance Show1 String where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Should string literal bodies include escapes too?
+
+-- | An interpolation element within a string literal.
+newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 InterpolationElement where liftEq = genericLiftEq
+instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec
+
+
+-- | A sequence of textual contents within a string literal.
+newtype TextElement a = TextElement { textElementContent :: ByteString }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 TextElement where liftEq = genericLiftEq
+instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
+
+
+newtype Symbol a = SymbolLiteral { symbolContent :: ByteString }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Symbol where liftEq = genericLiftEq
+instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Character literals.
+
+
+-- Collections
+
+newtype ArrayLiteral a = ArrayLiteral { arrayElements :: [Union '[Identity, Comment] a] }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 ArrayLiteral where liftEq = genericLiftEq
+instance Show1 ArrayLiteral where liftShowsPrec = genericLiftShowsPrec
+
+
+newtype HashLiteral a = HashLiteral { hashElements :: [Union '[KeyValue, Comment] a] }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 HashLiteral where liftEq = genericLiftEq
+instance Show1 HashLiteral where liftShowsPrec = genericLiftShowsPrec
+
+
+data KeyValue a = KeyValue { key :: !a, value :: !a }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 KeyValue where liftEq = genericLiftEq
+instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec
+
+-- 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).
+-- TODO: Regexp literals.

src/Data/Syntax/Statement.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE StandaloneDeriving #-}
+module Data.Syntax.Statement where
+
+import Data.Functor.Classes.Eq.Generic
+import Data.Functor.Classes.Show.Generic
+import GHC.Generics
+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, Generic1, Show)
+
+instance Eq1 If where liftEq = genericLiftEq
+instance Show1 If where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Alternative definition would flatten if/else if/else chains: data If a = If ![(a, a)] !(Maybe a)
+
+-- | 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, Generic1, Show)
+
+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, Generic1, Show)
+
+instance Eq1 Pattern where liftEq = genericLiftEq
+instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec
+
+
+-- Returns
+
+newtype Return a = Return a
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Return where liftEq = genericLiftEq
+instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
+
+newtype Yield a = Yield a
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Yield where liftEq = genericLiftEq
+instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec
+
+
+-- Loops
+
+data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
+  deriving (Eq, Foldable, Generic1, Show)
+
+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, Generic1, Show)
+
+instance Eq1 ForEach where liftEq = genericLiftEq
+instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec
+
+data While a = While { whileCondition :: !a, whileBody :: !a }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 While where liftEq = genericLiftEq
+instance Show1 While where liftShowsPrec = genericLiftShowsPrec
+
+data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 DoWhile where liftEq = genericLiftEq
+instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
+
+
+-- Exception handling
+
+newtype Throw a = Throw a
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Throw where liftEq = genericLiftEq
+instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec
+
+data Try with a = Try !a ![with a]
+  deriving (Eq, Foldable, Generic1, Show)
+-- deriving instance (Eq a, Eq (with a)) => Eq (Try with a)
+-- deriving instance (Show a, Show (with a)) => Show (Try with a)
+
+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, Generic1, Show)
+
+instance Eq1 Catch where liftEq = genericLiftEq
+instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec
+
+newtype Finally a = Finally a
+  deriving (Eq, Foldable, Generic1, Show)
+
+instance Eq1 Finally where liftEq = genericLiftEq
+instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec

src/Data/Syntax/Type.hs

@@ -0,0 +1,9 @@
+module Data.Syntax.Type where
+
+import Prologue
+
+data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
+  deriving (Eq, Show)
+
+newtype Product a = Product { productElements :: [a] }
+  deriving (Eq, Show)

src/Language/Ruby/Syntax.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE DataKinds #-}
+module Language.Ruby.Syntax where
+
+import Control.Monad.Free.Freer
+import Data.Functor.Union
+import Data.Syntax.Assignment
+import qualified Data.Syntax as Syntax
+import qualified Data.Syntax.Comment as Comment
+import qualified Data.Syntax.Declaration as Declaration
+import qualified Data.Syntax.Literal as Literal
+import qualified Data.Syntax.Statement as Statement
+import Prologue
+
+-- | The type of Ruby syntax.
+type Syntax = Union
+  '[Comment.Comment
+  , Declaration.Class
+  , Declaration.Method
+  , Literal.Boolean
+  , Statement.If
+  , Statement.Return
+  , Statement.Yield
+  , Syntax.Identifier
+  ]
+
+
+-- | A program in some syntax functor, over which we can perform analyses.
+type Program = Freer
+
+
+-- | Statically-known rules corresponding to symbols in the grammar.
+data Grammar = Program | Uninterpreted | BeginBlock | EndBlock | Undef | Alias | Comment | True' | False' | Return | Yield | Break | Next | Redo | Retry | IfModifier | UnlessModifier | WhileModifier | UntilModifier | RescueModifier | While | Until | For | Do | Case | When | Pattern | If | Unless | Elsif | Else | Begin | Ensure | Rescue | Exceptions | ExceptionVariable | ElementReference | ScopeResolution | Call | MethodCall | ArgumentList | ArgumentListWithParens | SplatArgument | HashSplatArgument | BlockArgument | Class | Constant | Method | Identifier
+  deriving (Enum, Eq, Ord, Show)
+
+-- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax.
+assignment :: Assignment Grammar (Program Syntax (Maybe a))
+assignment = foldr (>>) (pure Nothing) <$ rule Program <*> children (many declaration)
+
+declaration :: Assignment Grammar (Program Syntax a)
+declaration = comment <|> class' <|> method
+
+class' :: Assignment Grammar (Program Syntax a)
+class' = wrapU <$  rule Class
+               <*> children (Declaration.Class <$> constant <*> pure [] <*> many declaration)
+
+constant :: Assignment Grammar (Program Syntax a)
+constant = wrapU . Syntax.Identifier <$ rule Constant <*> content
+
+identifier :: Assignment Grammar (Program Syntax a)
+identifier = wrapU . Syntax.Identifier <$ rule Identifier <*> content
+
+method :: Assignment Grammar (Program Syntax a)
+method = wrapU <$  rule Method
+               <*> children (Declaration.Method <$> identifier <*> pure [] <*> statement)
+
+statement :: Assignment Grammar (Program Syntax a)
+statement = expr
+
+comment :: Assignment Grammar (Program Syntax a)
+comment = wrapU . Comment.Comment <$ rule Comment <*> content
+
+if' :: Assignment Grammar (Program Syntax a)
+if' = wrapU <$ rule If <*> children (Statement.If <$> expr <*> expr <*> expr)
+
+expr :: Assignment Grammar (Program Syntax a)
+expr = if'

test/Data/Syntax/Assignment/Spec.hs

@@ -0,0 +1,89 @@
+module Data.Syntax.Assignment.Spec where
+
+import Data.ByteString.Char8 (words)
+import Data.Syntax.Assignment
+import Prologue
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "Applicative" $ do
+    it "matches in sequence" $
+      runAssignment ((,) <$> red <*> red) [ast Red "hello" [], ast Red "world" []] `shouldBe` Just ([], (Out "hello", Out "world"))
+
+  describe "Alternative" $ do
+    it "attempts multiple alternatives" $
+      runAssignment (green <|> red) [ast Red "hello" []] `shouldBe` Just ([], Out "hello")
+
+    it "matches repetitions" $
+      let w = words "colourless green ideas sleep furiously" in
+      runAssignment (many red) (flip (ast Red) [] <$> w) `shouldBe` Just ([], Out <$> w)
+
+    it "matches one-or-more repetitions against one or more input nodes" $
+      runAssignment (some red) [ast Red "hello" []] `shouldBe` Just ([], [Out "hello"])
+
+  describe "rule" $ do
+    it "matches nodes with the same symbol" $
+      runAssignment red [ast Red "hello" []] `shouldBe` Just ([], Out "hello")
+
+    it "does not advance past the current node" $
+      fst <$> runAssignment (rule ()) [ Rose (Node () "hi") [] ] `shouldBe` Just [ Rose (Node () "hi") [] ]
+
+  describe "content" $ do
+    it "produces the node’s content" $
+      snd <$> runAssignment content [ Rose (Node () "hi") [] ] `shouldBe` Just "hi"
+
+    it "advances past the current node" $
+      fst <$> runAssignment content [ Rose (Node () "hi") [] ] `shouldBe` Just []
+
+  describe "children" $ do
+    it "advances past the current node" $
+      fst <$> runAssignment (children (pure (Out ""))) [ast Red "a" []] `shouldBe` Just []
+
+    it "matches if its subrule matches" $
+      () <$ runAssignment (children red) [ast Blue "b" [ast Red "a" []]] `shouldBe` Just ()
+
+    it "does not match if its subrule does not match" $
+      runAssignment (children red) [ast Blue "b" [ast Green "a" []]] `shouldBe` Nothing
+
+    it "matches nested children" $ do
+      runAssignment
+        (rule 'A' *> children (rule 'B' *> children (rule 'C' *> content)))
+        [ ast 'A' "" [ ast 'B' "" [ ast 'C' "1" [] ] ] ]
+      `shouldBe`
+        Just ([], "1")
+
+    it "continues after children" $ do
+      runAssignment
+        (many (rule 'A' *> children (rule 'B' *> content)
+           <|> rule 'C' *> content))
+        [ ast 'A' "" [ ast 'B' "B" [] ]
+        , ast 'C' "C" [] ]
+      `shouldBe`
+        Just ([], ["B", "C"])
+
+    it "matches multiple nested children" $ do
+      runAssignment
+        (rule 'A' *> children (many (rule 'B' *> children (rule 'C' *> content))))
+        [ ast 'A' "" [ ast 'B' "" [ ast 'C' "1" [] ]
+                     , ast 'B' "" [ ast 'C' "2" [] ] ] ]
+      `shouldBe`
+        Just ([], ["1", "2"])
+
+ast :: grammar -> ByteString -> [AST grammar] -> AST grammar
+ast g s c = Rose (Node g s) c
+
+data Grammar = Red | Green | Blue
+  deriving (Eq, Show)
+
+data Out = Out ByteString
+  deriving (Eq, Show)
+
+red :: Assignment Grammar Out
+red = Out <$ rule Red <*> content
+
+green :: Assignment Grammar Out
+green = Out <$ rule Green <*> content
+
+blue :: Assignment Grammar Out
+blue = Out <$ rule Blue <*> content

test/Spec.hs

@@ -7,6 +7,7 @@ import qualified Command.Diff.Spec
 import qualified Command.Parse.Spec
 import qualified Data.Mergeable.Spec
 import qualified Data.RandomWalkSimilarity.Spec
+import qualified Data.Syntax.Assignment.Spec
 import qualified DiffSpec
 import qualified SummarySpec
 import qualified GitmonClientSpec
@@ -30,6 +31,7 @@ main = hspec $ do
     describe "Command.Parse" Command.Parse.Spec.spec
     describe "Data.Mergeable" Data.Mergeable.Spec.spec
     describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec
+    describe "Data.Syntax.Assignment" Data.Syntax.Assignment.Spec.spec
     describe "Diff" DiffSpec.spec
     describe "Summary" SummarySpec.spec
     describe "Interpreter" InterpreterSpec.spec