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-08-28 12:48:36 -04:00
parent bc68170623
commit 4f5f912d9e
23 changed files with 266 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitmodules vendored
View File

@ -25,3 +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

2
cabal.project
View File

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

3
semantic-diff.cabal
View File

@ -21,6 +21,7 @@ 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.Mergeable
@ -74,6 +75,7 @@ library
, Semantic
, Semantic.Log
, Semantic.Task
, Semantic.Util
, SemanticCmdLine
, SES
, SES.Myers
@ -107,6 +109,7 @@ library
, optparse-applicative
, parallel
, parsers
, prettyprinter
, recursion-schemes
, semigroups
, split

4
src/Category.hs
View File

@ -7,6 +7,7 @@ import Control.DeepSeq
import Data.Functor.Listable
import Data.Hashable
import Data.Text (Text)
import Data.Text.Prettyprint.Doc
import GHC.Generics
-- | A standardized category of AST node. Used to determine the semantics for
@ -363,3 +364,6 @@ instance Listable Category where
-- \/ cons0 (Modifier If)
\/ cons0 SingletonMethod
-- \/ cons0 (Other "other")
instance Pretty Category where
pretty = pretty . show

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

@ -0,0 +1,49 @@
{-# 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

4
src/Data/Range.hs
View File

@ -8,6 +8,7 @@ module Data.Range
import Control.DeepSeq
import Data.Semigroup
import Data.Text.Prettyprint.Doc
import GHC.Generics
import Test.LeanCheck
@ -38,3 +39,6 @@ instance Ord Range where
instance Listable Range where
tiers = cons2 Range
instance Pretty Range where
pretty (Range from to) = pretty from <> pretty '-' <> pretty to

10
src/Data/Record.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators #-}
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Record where
import Control.DeepSeq
import Data.Kind
import Data.Functor.Listable
import Data.Semigroup
import Data.Text.Prettyprint.Doc
-- | A type-safe, extensible record structure.
-- |
@ -87,3 +88,10 @@ instance (Semigroup head, Semigroup (Record tail)) => Semigroup (Record (head ':
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

7
src/Data/Span.hs
View File

@ -14,6 +14,7 @@ import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
import Data.Hashable (Hashable)
import Data.Semigroup
import Data.Text.Prettyprint.Doc
import GHC.Generics
import Test.LeanCheck
@ -62,3 +63,9 @@ instance Listable Pos where
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

18
src/Data/Syntax.hs
View File

@ -13,11 +13,13 @@ 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
@ -105,11 +107,15 @@ 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
@ -121,11 +127,15 @@ 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
@ -143,6 +153,7 @@ 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.
@ -152,6 +163,9 @@ 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
@ -164,3 +178,7 @@ 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' <$))

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

@ -5,7 +5,9 @@ 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).
@ -15,6 +17,9 @@ 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,6 +4,7 @@ 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
@ -12,6 +13,7 @@ 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?
@ -20,6 +22,7 @@ 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)
@ -41,6 +44,7 @@ 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] }
@ -48,6 +52,7 @@ 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] }
@ -55,6 +60,7 @@ 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
@ -63,6 +69,7 @@ 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.
@ -73,6 +80,7 @@ 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] }
@ -80,6 +88,7 @@ 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)
@ -88,6 +97,7 @@ 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.
@ -96,3 +106,4 @@ data Import a = Import { importContent :: ![a] }
instance Eq1 Import where liftEq = genericLiftEq
instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Import where liftPretty = genericLiftPretty

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

@ -4,6 +4,7 @@ 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
@ -13,6 +14,7 @@ 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
@ -26,6 +28,7 @@ data Comparison a
instance Eq1 Comparison where liftEq = genericLiftEq
instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Comparison where liftPretty = genericLiftPretty
-- | Binary arithmetic operators.
@ -41,6 +44,7 @@ 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
@ -51,6 +55,7 @@ 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
@ -85,6 +90,7 @@ 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
@ -93,6 +99,7 @@ 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
@ -102,6 +109,7 @@ 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 }
@ -109,6 +117,7 @@ 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
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
data ScopeResolution a
@ -117,3 +126,4 @@ data ScopeResolution a
instance Eq1 ScopeResolution where liftEq = genericLiftEq
instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 ScopeResolution where liftPretty = genericLiftPretty

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

@ -5,9 +5,11 @@ 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 hiding (String)
import Prelude
-- Boolean
@ -22,6 +24,7 @@ false = Boolean False
instance Eq1 Boolean where liftEq = genericLiftEq
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Boolean where liftPretty = genericLiftPretty
-- Numeric
@ -33,6 +36,9 @@ 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.
@ -44,6 +50,9 @@ 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)
@ -51,6 +60,9 @@ 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)
@ -58,13 +70,18 @@ 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
newtype String a = String { stringElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
instance Eq1 String where liftEq = genericLiftEq
instance Show1 String where liftShowsPrec = genericLiftShowsPrec
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?
@ -74,6 +91,7 @@ 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.
@ -83,11 +101,15 @@ 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)
@ -95,6 +117,9 @@ 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.
@ -107,6 +132,7 @@ 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] }
@ -114,13 +140,14 @@ 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]}
@ -128,6 +155,7 @@ 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] }
@ -135,6 +163,7 @@ 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,7 +5,10 @@ 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
@ -14,6 +17,7 @@ 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
@ -23,42 +27,49 @@ 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)
@ -66,23 +77,29 @@ 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
@ -92,12 +109,14 @@ 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)
@ -105,32 +124,45 @@ 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,6 +4,7 @@ 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
@ -13,6 +14,7 @@ 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 }
@ -20,6 +22,7 @@ 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)
@ -29,6 +32,7 @@ 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 }
@ -36,6 +40,7 @@ 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 }
@ -43,6 +48,7 @@ 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
@ -53,6 +59,7 @@ data Assignment a = Assignment { assignmentTarget :: !a, assignmentValue :: !a }
instance Eq1 Assignment where liftEq = genericLiftEq
instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
instance Pretty1 Assignment where liftPretty = genericLiftPretty
-- Returns
@ -62,36 +69,42 @@ 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
@ -101,24 +114,28 @@ 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
@ -128,24 +145,28 @@ 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).
@ -154,6 +175,7 @@ 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).
@ -162,3 +184,4 @@ 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,6 +4,7 @@ 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
@ -12,24 +13,28 @@ 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/Diff.hs
View File

@ -8,6 +8,7 @@ import qualified Control.Monad.Free as Free
import qualified Control.Monad.Trans.Free as FreeF
import Data.Bifunctor
import Data.Functor.Both as Both
import Data.Functor.Classes.Pretty.Generic
import Data.Mergeable
import Data.Record
import Patch
@ -63,3 +64,11 @@ 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
instance Pretty1 f => Pretty1 (Free.Free f) where
liftPretty p pl = go where go (Free.Pure a) = p a
go (Free.Free f) = liftPretty go (list . map (liftPretty p pl)) f
instance (Pretty1 f, Pretty a) => Pretty (Free.Free f a) where
pretty = liftPretty pretty prettyList

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

@ -10,6 +10,7 @@ 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 (NonEmpty(..))
import Data.Maybe (fromMaybe)
@ -93,6 +94,7 @@ 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
@ -100,6 +102,7 @@ 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

8
src/Patch.hs
View File

@ -16,6 +16,7 @@ module Patch
import Control.DeepSeq
import Data.Align
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Listable
import Data.These
import GHC.Generics
@ -25,7 +26,7 @@ data Patch a
= Replace a a
| Insert a
| Delete a
deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable, NFData)
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable, NFData)
-- DSL
@ -87,3 +88,8 @@ 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 Pretty a => Pretty (Patch a) where
pretty = liftPretty pretty prettyList

13
src/Semantic/Util.hs Normal file
View File

@ -0,0 +1,13 @@
module Semantic.Util where
import Data.Blob
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Util
import Files
import Language
pp :: Pretty a => a -> IO ()
pp = putDocW 100 . (<> line) . pretty
file :: FilePath -> IO Blob
file path = Files.readFile path (languageForType path)

5
src/Syntax.hs
View File

@ -6,6 +6,7 @@ import Data.Aeson
import Data.Align.Generic
import Data.Functor.Classes
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Listable
import Data.Mergeable
import Data.Text (pack, Text)
@ -110,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, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData)
deriving (Eq, Foldable, Functor, GAlign, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData)
extractLeafValue :: Syntax a -> Maybe Text
@ -183,4 +184,4 @@ instance Listable recur => Listable (Syntax recur) where
instance Eq1 Syntax where
liftEq = genericLiftEq
instance GAlign Syntax
instance Pretty1 Syntax where liftPretty = genericLiftPretty

13
src/Term.hs
View File

@ -19,10 +19,13 @@ import Control.DeepSeq
import Control.Monad.Free
import Data.Align.Generic
import Data.Functor.Both
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Foldable
import Data.Maybe
import Data.Proxy
import Data.Record
import Data.These
import Data.Union
import Syntax
-- | A Term with an abstract syntax tree and an annotation.
@ -68,3 +71,13 @@ cofree (a CofreeF.:< f) = a Cofree.:< f
runCofree :: Cofree.Cofree f a -> CofreeF.CofreeF f a (Cofree.Cofree f a)
runCofree (a Cofree.:< f) = a CofreeF.:< f
instance Pretty1 f => Pretty1 (Cofree.Cofree f) where
liftPretty p pl = go where go (a Cofree.:< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f
instance (Pretty1 f, Pretty a) => Pretty (Cofree.Cofree f a) where
pretty = liftPretty pretty prettyList
instance Apply1 Pretty1 fs => Pretty1 (Union fs) where
liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl)

1
vendor/prettyprinter vendored Submodule

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