From 26707bab6926d1ab0b6d215a0daef8f1e7b73698 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 1 Jun 2018 15:41:21 -0700 Subject: [PATCH 01/19] Update Declaration.Datatype to hold deriving clause --- src/Data/Syntax/Declaration.hs | 2 +- src/Language/Haskell/Syntax.hs | 25 ++++++++++++++++--------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 2fc337360..a23b59e80 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -182,7 +182,7 @@ instance Evaluatable Decorator -- | 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] } +data Datatype a = Datatype { datatypeName :: a, datatypeConstructors :: [a], datatypeDeriving :: a } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 86d6defa9..ab5d8f35c 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -20,7 +20,7 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Module data StrictType a = StrictType { strictTypeIdentifier :: !a, strictTypeParameters :: !a } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 StrictType where liftEq = genericLiftEq instance Ord1 StrictType where liftCompare = genericLiftCompare @@ -31,7 +31,7 @@ instance ToJSONFields1 StrictType instance Evaluatable StrictType newtype StrictTypeVariable a = StrictTypeVariable { strictTypeVariableIdentifier :: a } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 StrictTypeVariable where liftEq = genericLiftEq instance Ord1 StrictTypeVariable where liftCompare = genericLiftCompare @@ -59,7 +59,8 @@ instance Show1 TypeSynonym where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeSynonym -data UnitConstructor a = UnitConstructor deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) +data UnitConstructor a = UnitConstructor + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 UnitConstructor where liftEq = genericLiftEq instance Ord1 UnitConstructor where liftCompare = genericLiftCompare @@ -67,7 +68,8 @@ instance Show1 UnitConstructor where liftShowsPrec = genericLiftShowsPrec instance Evaluatable UnitConstructor -newtype TupleConstructor a = TupleConstructor { tupleConstructorArity :: Int } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) +newtype TupleConstructor a = TupleConstructor { tupleConstructorArity :: Int } + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 TupleConstructor where liftEq = genericLiftEq instance Ord1 TupleConstructor where liftCompare = genericLiftCompare @@ -75,7 +77,8 @@ instance Show1 TupleConstructor where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TupleConstructor -data ListConstructor a = ListConstructor deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) +data ListConstructor a = ListConstructor + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 ListConstructor where liftEq = genericLiftEq instance Ord1 ListConstructor where liftCompare = genericLiftCompare @@ -83,7 +86,8 @@ instance Show1 ListConstructor where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ListConstructor -data FunctionConstructor a = FunctionConstructor deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) +data FunctionConstructor a = FunctionConstructor + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 FunctionConstructor where liftEq = genericLiftEq instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare @@ -91,7 +95,8 @@ instance Show1 FunctionConstructor where liftShowsPrec = genericLiftShowsPrec instance Evaluatable FunctionConstructor -data RecordDataConstructor a = RecordDataConstructor { recordDataConstructorName :: !a, recordDataConstructorFields :: !a } deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +data RecordDataConstructor a = RecordDataConstructor { recordDataConstructorName :: !a, recordDataConstructorFields :: !a } + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 RecordDataConstructor where liftEq = genericLiftEq instance Ord1 RecordDataConstructor where liftCompare = genericLiftCompare @@ -101,7 +106,8 @@ instance ToJSONFields1 RecordDataConstructor instance Evaluatable RecordDataConstructor -data Field a = Field { fieldName :: !a, fieldBody :: !a } deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +data Field a = Field { fieldName :: !a, fieldBody :: !a } + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Field where liftEq = genericLiftEq instance Ord1 Field where liftCompare = genericLiftCompare @@ -111,7 +117,8 @@ instance ToJSONFields1 Field instance Evaluatable Field -newtype Pragma a = Pragma ByteString deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype Pragma a = Pragma ByteString + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Pragma where liftEq = genericLiftEq instance Ord1 Pragma where liftCompare = genericLiftCompare From bf117f09078e8b4a4e4010a56805baae81a7300c Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 1 Jun 2018 15:44:37 -0700 Subject: [PATCH 02/19] Add deriving constructor --- src/Language/Haskell/Syntax.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index ab5d8f35c..07a812119 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -127,3 +127,13 @@ instance Show1 Pragma where liftShowsPrec = genericLiftShowsPrec instance ToJSONFields1 Pragma instance Evaluatable Pragma + +newtype Deriving a = Deriving [a] deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 Deriving where liftEq = genericLiftEq +instance Ord1 Deriving where liftCompare = genericLiftCompare +instance Show1 Deriving where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 Deriving + +instance Evaluatable Deriving From 4f34d716515e9f216db7265016a10031077f31f2 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 1 Jun 2018 15:52:49 -0700 Subject: [PATCH 03/19] Assign datatype declarations with deriving clauses --- src/Language/Haskell/Assignment.hs | 16 +++- .../algebraic-datatype-declarations.A.hs | 3 + .../algebraic-datatype-declarations.B.hs | 3 + ...lgebraic-datatype-declarations.diffA-B.txt | 94 ++++++++++++------- ...lgebraic-datatype-declarations.diffB-A.txt | 76 +++++++++++---- ...algebraic-datatype-declarations.parseA.txt | 56 ++++++++--- ...algebraic-datatype-declarations.parseB.txt | 56 ++++++++--- .../haskell/corpus/literals.diffB-A.txt | 76 +++++++-------- 8 files changed, 265 insertions(+), 115 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 2f99497ed..b14953a75 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -34,6 +34,7 @@ type Syntax = '[ , Literal.Integer , Literal.TextElement , Syntax.Context + , Syntax.Deriving , Syntax.Empty , Syntax.Error , Syntax.Field @@ -78,6 +79,7 @@ expressionChoices = [ , character , comment , constructorIdentifier + , derivingClause , float , functionConstructor , functionDeclaration @@ -107,7 +109,8 @@ algebraicDatatypeDeclaration = makeTerm <*> children (Declaration.Datatype <$> (makeTerm <$> location <*> (Syntax.Type <$> typeConstructor <*> typeParameters)) <*> ((symbol Constructors *> children (many constructor)) - <|> pure [])) + <|> pure []) + <*> (derivingClause <|> emptyTerm)) comment :: Assignment comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) @@ -116,6 +119,9 @@ constructor :: Assignment constructor = (makeTerm <$> symbol DataConstructor <*> children (Declaration.Constructor <$> typeConstructor <*> typeParameters)) <|> (makeTerm <$> symbol RecordDataConstructor <*> children (Syntax.RecordDataConstructor <$> constructorIdentifier <*> fields)) +derivingClause :: Assignment +derivingClause = makeTerm <$> symbol Deriving <*> children (Syntax.Deriving <$> many typeConstructor) + fields :: Assignment fields = makeTerm <$> symbol Fields <*> children (many field) @@ -134,6 +140,9 @@ constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Id moduleIdentifier :: Assignment moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . Name.name <$> source) +typeClassIdentifier :: Assignment +typeClassIdentifier = makeTerm <$> symbol TypeClassIdentifier <*> (Syntax.Identifier . Name.name <$> source) + typeConstructorIdentifier :: Assignment typeConstructorIdentifier = makeTerm <$> symbol TypeConstructorIdentifier <*> (Syntax.Identifier . Name.name <$> source) @@ -205,13 +214,14 @@ string :: Assignment string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source) typeConstructor :: Assignment -typeConstructor = typeConstructorIdentifier +typeConstructor = constructorIdentifier <|> functionConstructor <|> listConstructor <|> listType + <|> typeClassIdentifier + <|> typeConstructorIdentifier <|> tuplingConstructor <|> unitConstructor - <|> constructorIdentifier typeSynonymDeclaration :: Assignment typeSynonymDeclaration = makeTerm diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs index e552c1208..72ca6cf43 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs @@ -16,3 +16,6 @@ data N = N { a :: !Int, b :: Int } data N = N { a, b :: {-# UNPACK #-} !Int, c :: String } data N = N { a :: Int } | O { b :: String } data N = N { b :: Int } | O { c :: String } + +data N = N deriving Show +data N = N deriving (Eq, Ord, Enum, Bounded, Show, Read) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs index 14d3e65e1..9a23d9a4b 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs @@ -16,3 +16,6 @@ data O = O { a :: !Int, b :: Int } data O = O { a, b :: {-# UNPACK #-} !Int, c :: String } data N = N { b :: Int } | O { c :: String } data N = N { b :: Text } | O { c :: Bool } + +data N = N deriving Show +data N = N deriving (Functor, Ord, Enum, Bounded, Show, Read) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt index ba8a87f1a..8a294c4ff 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt @@ -5,7 +5,8 @@ (Type { (Identifier) ->(Identifier) } - (TypeParameters))) + (TypeParameters)) + (Empty)) (Datatype (Type { (Identifier) @@ -16,7 +17,8 @@ { (Identifier) ->(Identifier) } (TypeParameters - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type { (Identifier) @@ -28,7 +30,8 @@ ->(Identifier) } (TypeParameters (StrictTypeVariable - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -42,30 +45,34 @@ (TypeParameters (StrictTypeVariable (Identifier)) - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type { (Identifier) ->(Identifier) } (TypeParameters)) + (Constructor + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Constructor + { (Identifier) + ->(Identifier) } + (TypeParameters)) + {+(Constructor + {+(Identifier)+} + {+(TypeParameters)+})+} + (Constructor + { (Identifier) + ->(Identifier) } + (TypeParameters)) {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} - {+(Constructor - {+(Identifier)+} - {+(TypeParameters)+})+} - {+(Constructor - {+(Identifier)+} - {+(TypeParameters)+})+} - {+(Constructor - {+(Identifier)+} - {+(TypeParameters)+})+} - {+(Constructor - {+(Identifier)+} - {+(TypeParameters)+})+} {-(Constructor {-(Identifier)-} {-(TypeParameters)-})-} @@ -75,15 +82,7 @@ {-(Constructor {-(Identifier)-} {-(TypeParameters)-})-} - {-(Constructor - {-(Identifier)-} - {-(TypeParameters)-})-} - {-(Constructor - {-(Identifier)-} - {-(TypeParameters)-})-} - {-(Constructor - {-(Identifier)-} - {-(TypeParameters)-})-}) + (Empty)) (Datatype (Type { (Identifier) @@ -96,7 +95,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -110,7 +110,8 @@ (Statements (Identifier) (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -129,7 +130,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -151,7 +153,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) {-(Datatype {-(Type {-(Identifier)-} @@ -169,7 +172,8 @@ {-(Field {-(Statements {-(Identifier)-})-} - {-(Identifier)-})-})-})-})-} + {-(Identifier)-})-})-})-} + {-(Empty)-})-} (Datatype (Type (Identifier) @@ -187,7 +191,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) {+(Datatype {+(Type {+(Identifier)+} @@ -205,4 +210,29 @@ {+(Field {+(Statements {+(Identifier)+})+} - {+(Identifier)+})+})+})+})+})) + {+(Identifier)+})+})+})+} + {+(Empty)+})+} + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + (Identifier))) + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + { (Identifier) + ->(Identifier) } + (Identifier) + (Identifier) + (Identifier) + (Identifier) + (Identifier))))) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt index 20de24ea8..343e3dc0c 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt @@ -5,7 +5,8 @@ (Type { (Identifier) ->(Identifier) } - (TypeParameters))) + (TypeParameters)) + (Empty)) (Datatype (Type { (Identifier) @@ -16,7 +17,8 @@ { (Identifier) ->(Identifier) } (TypeParameters - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type { (Identifier) @@ -28,7 +30,8 @@ ->(Identifier) } (TypeParameters (StrictTypeVariable - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -42,12 +45,21 @@ (TypeParameters (StrictTypeVariable (Identifier)) - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type { (Identifier) ->(Identifier) } (TypeParameters)) + (Constructor + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Constructor + { (Identifier) + ->(Identifier) } + (TypeParameters)) {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} @@ -61,14 +73,6 @@ {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} - (Constructor - { (Identifier) - ->(Identifier) } - (TypeParameters)) - (Constructor - { (Identifier) - ->(Identifier) } - (TypeParameters)) {-(Constructor {-(Identifier)-} {-(TypeParameters)-})-} @@ -77,7 +81,8 @@ {-(TypeParameters)-})-} {-(Constructor {-(Identifier)-} - {-(TypeParameters)-})-}) + {-(TypeParameters)-})-} + (Empty)) (Datatype (Type { (Identifier) @@ -90,7 +95,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -104,7 +110,8 @@ (Statements (Identifier) (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -123,7 +130,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type { (Identifier) @@ -145,7 +153,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) {+(Datatype {+(Type {+(Identifier)+} @@ -163,7 +172,8 @@ {+(Field {+(Statements {+(Identifier)+})+} - {+(Identifier)+})+})+})+})+} + {+(Identifier)+})+})+})+} + {+(Empty)+})+} (Datatype (Type (Identifier) @@ -181,7 +191,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) {-(Datatype {-(Type {-(Identifier)-} @@ -199,4 +210,29 @@ {-(Field {-(Statements {-(Identifier)-})-} - {-(Identifier)-})-})-})-})-})) + {-(Identifier)-})-})-})-} + {-(Empty)-})-} + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + (Identifier))) + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + { (Identifier) + ->(Identifier) } + (Identifier) + (Identifier) + (Identifier) + (Identifier) + (Identifier))))) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt index 9261d15ba..0a8677682 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt @@ -4,7 +4,8 @@ (Datatype (Type (Identifier) - (TypeParameters))) + (TypeParameters)) + (Empty)) (Datatype (Type (Identifier) @@ -13,7 +14,8 @@ (Constructor (Identifier) (TypeParameters - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type (Identifier) @@ -23,7 +25,8 @@ (Identifier) (TypeParameters (StrictTypeVariable - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -35,7 +38,8 @@ (TypeParameters (StrictTypeVariable (Identifier)) - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type (Identifier) @@ -57,7 +61,8 @@ (TypeParameters)) (Constructor (Identifier) - (TypeParameters))) + (TypeParameters)) + (Empty)) (Datatype (Type (Identifier) @@ -68,7 +73,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -80,7 +86,8 @@ (Statements (Identifier) (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -97,7 +104,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -117,7 +125,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -135,7 +144,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -153,4 +163,28 @@ (Field (Statements (Identifier)) - (Identifier))))))) + (Identifier)))) + (Empty)) + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + (Identifier))) + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + (Identifier) + (Identifier) + (Identifier) + (Identifier) + (Identifier) + (Identifier))))) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt index 9261d15ba..0a8677682 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt @@ -4,7 +4,8 @@ (Datatype (Type (Identifier) - (TypeParameters))) + (TypeParameters)) + (Empty)) (Datatype (Type (Identifier) @@ -13,7 +14,8 @@ (Constructor (Identifier) (TypeParameters - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type (Identifier) @@ -23,7 +25,8 @@ (Identifier) (TypeParameters (StrictTypeVariable - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -35,7 +38,8 @@ (TypeParameters (StrictTypeVariable (Identifier)) - (Identifier)))) + (Identifier))) + (Empty)) (Datatype (Type (Identifier) @@ -57,7 +61,8 @@ (TypeParameters)) (Constructor (Identifier) - (TypeParameters))) + (TypeParameters)) + (Empty)) (Datatype (Type (Identifier) @@ -68,7 +73,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -80,7 +86,8 @@ (Statements (Identifier) (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -97,7 +104,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -117,7 +125,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -135,7 +144,8 @@ (Field (Statements (Identifier)) - (Identifier))))) + (Identifier)))) + (Empty)) (Datatype (Type (Identifier) @@ -153,4 +163,28 @@ (Field (Statements (Identifier)) - (Identifier))))))) + (Identifier)))) + (Empty)) + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + (Identifier))) + (Datatype + (Type + (Identifier) + (TypeParameters)) + (Constructor + (Identifier) + (TypeParameters)) + (Deriving + (Identifier) + (Identifier) + (Identifier) + (Identifier) + (Identifier) + (Identifier))))) diff --git a/test/fixtures/haskell/corpus/literals.diffB-A.txt b/test/fixtures/haskell/corpus/literals.diffB-A.txt index 10ff96ffd..923d94247 100644 --- a/test/fixtures/haskell/corpus/literals.diffB-A.txt +++ b/test/fixtures/haskell/corpus/literals.diffB-A.txt @@ -18,48 +18,48 @@ {+(Identifier)+} {+(Statements {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+(Statements - {+(Float)+})+})+} (Function { (Identifier) ->(Identifier) } (Statements - {+(Float)+} - {-(Integer)-})) + { (Integer) + ->(Integer) })) + {+(Function + {+(Identifier)+} + {+(Statements + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Float)+})+})+} {+(Function {+(Identifier)+} {+(Statements From 9db3c596dcc79731defcaafcff0bd03f250a28fe Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 1 Jun 2018 16:23:59 -0700 Subject: [PATCH 04/19] Add Context' and Class syntax constructors --- src/Language/Haskell/Syntax.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 07a812119..053aa73bb 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -137,3 +137,23 @@ instance Show1 Deriving where liftShowsPrec = genericLiftShowsPrec instance ToJSONFields1 Deriving instance Evaluatable Deriving + +newtype Context' a = Context' [a] deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 Context' where liftEq = genericLiftEq +instance Ord1 Context' where liftCompare = genericLiftCompare +instance Show1 Context' where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 Context' + +instance Evaluatable Context' + +data Class a = Class { classType :: a, classTypeParameters :: a } deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 Class where liftEq = genericLiftEq +instance Ord1 Class where liftCompare = genericLiftCompare +instance Show1 Class where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 Class + +instance Evaluatable Class From b0fb50e21a115708a1c73312024207378fd20344 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 1 Jun 2018 16:25:49 -0700 Subject: [PATCH 05/19] Assign contexts with classes --- src/Language/Haskell/Assignment.hs | 20 +++- .../algebraic-datatype-declarations.A.hs | 4 + .../algebraic-datatype-declarations.B.hs | 4 + ...lgebraic-datatype-declarations.diffA-B.txt | 100 ++++++++++++++++-- ...lgebraic-datatype-declarations.diffB-A.txt | 92 +++++++++++++++- ...algebraic-datatype-declarations.parseA.txt | 78 +++++++++++++- ...algebraic-datatype-declarations.parseB.txt | 78 +++++++++++++- .../haskell/corpus/literals.diffA-B.txt | 13 ++- .../haskell/corpus/literals.diffB-A.txt | 27 +++-- 9 files changed, 383 insertions(+), 33 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index b14953a75..0855f30c7 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -33,7 +33,9 @@ type Syntax = '[ , Literal.Float , Literal.Integer , Literal.TextElement + , Syntax.Class , Syntax.Context + , Syntax.Context' , Syntax.Deriving , Syntax.Empty , Syntax.Error @@ -78,6 +80,7 @@ expressionChoices = [ algebraicDatatypeDeclaration , character , comment + , context' , constructorIdentifier , derivingClause , float @@ -107,7 +110,8 @@ algebraicDatatypeDeclaration :: Assignment algebraicDatatypeDeclaration = makeTerm <$> symbol AlgebraicDatatypeDeclaration <*> children (Declaration.Datatype - <$> (makeTerm <$> location <*> (Syntax.Type <$> typeConstructor <*> typeParameters)) + <$> (context' <|> emptyTerm) + <*> (makeTerm <$> location <*> (Syntax.Type <$> typeConstructor <*> typeParameters)) <*> ((symbol Constructors *> children (many constructor)) <|> pure []) <*> (derivingClause <|> emptyTerm)) @@ -119,6 +123,15 @@ constructor :: Assignment constructor = (makeTerm <$> symbol DataConstructor <*> children (Declaration.Constructor <$> typeConstructor <*> typeParameters)) <|> (makeTerm <$> symbol RecordDataConstructor <*> children (Syntax.RecordDataConstructor <$> constructorIdentifier <*> fields)) +class' :: Assignment +class' = makeTerm <$> symbol Class <*> children (Syntax.Class <$> typeConstructor <*> typeParameters) + +context' :: Assignment +context' = makeTerm <$> symbol Context <*> children (Syntax.Context' <$> many (type' <|> contextPattern)) + +contextPattern :: Assignment +contextPattern = symbol ContextPattern *> children (type') + derivingClause :: Assignment derivingClause = makeTerm <$> symbol Deriving <*> children (Syntax.Deriving <$> many typeConstructor) @@ -186,6 +199,9 @@ listExpression = makeTerm <$> symbol ListExpression <*> children (Literal.Array listType :: Assignment listType = makeTerm <$> symbol ListType <*> children (Literal.Array <$> many type') +parenthesizedTypePattern :: Assignment +parenthesizedTypePattern = symbol ParenthesizedTypePattern *> children (typeParameters) + strictType :: Assignment strictType = makeTerm' <$> symbol StrictType <*> children ((inject <$> (Syntax.StrictType <$> typeConstructor <*> typeParameters)) <|> (inject <$> (Syntax.StrictTypeVariable <$> typeVariableIdentifier))) @@ -198,8 +214,10 @@ tuplingConstructor = makeTerm <$> symbol TuplingConstructor <*> (tupleWithArity type' :: Assignment type' = (makeTerm <$> symbol Type <*> children (Syntax.Type <$> typeConstructor <*> typeParameters)) <|> (makeTerm <$> symbol TypePattern <*> children (Syntax.Type <$> typeConstructor <*> typeParameters)) + <|> parenthesizedTypePattern <|> strictType <|> typeConstructor + <|> class' typeParameters :: Assignment typeParameters = makeTerm <$> location <*> (Type.TypeParameters <$> many expression) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs index 72ca6cf43..e4cadf473 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.A.hs @@ -19,3 +19,7 @@ data N = N { b :: Int } | O { c :: String } data N = N deriving Show data N = N deriving (Eq, Ord, Enum, Bounded, Show, Read) + +data Show a => N a = N a +data (Eq a, Show a, Eq b) => N a b = N a b +data (Eq (f a), Functor f) => N f a = N f a diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs index 9a23d9a4b..51ab98920 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.B.hs @@ -19,3 +19,7 @@ data N = N { b :: Text } | O { c :: Bool } data N = N deriving Show data N = N deriving (Functor, Ord, Enum, Bounded, Show, Read) + +data Monad a => N a = N a +data (Ord a, Show a, Eq b) => N a b = N a b +data (Eq (f a), Applicative f) => N f a = N f a diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt index 8a294c4ff..79e846b8a 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt @@ -2,12 +2,14 @@ (Empty) (Statements (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } (TypeParameters)) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -20,6 +22,7 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -33,6 +36,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -48,18 +52,14 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } (TypeParameters)) - (Constructor - { (Identifier) - ->(Identifier) } - (TypeParameters)) - (Constructor - { (Identifier) - ->(Identifier) } - (TypeParameters)) + {+(Constructor + {+(Identifier)+} + {+(TypeParameters)+})+} {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} @@ -73,6 +73,13 @@ {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} + (Constructor + { (Identifier) + ->(Identifier) } + (TypeParameters)) + {-(Constructor + {-(Identifier)-} + {-(TypeParameters)-})-} {-(Constructor {-(Identifier)-} {-(TypeParameters)-})-} @@ -84,6 +91,7 @@ {-(TypeParameters)-})-} (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -98,6 +106,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -113,6 +122,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -133,6 +143,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -156,6 +167,7 @@ (Identifier)))) (Empty)) {-(Datatype + {-(Empty)-} {-(Type {-(Identifier)-} {-(TypeParameters)-})-} @@ -175,6 +187,7 @@ {-(Identifier)-})-})-})-} {-(Empty)-})-} (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -194,6 +207,7 @@ (Identifier)))) (Empty)) {+(Datatype + {+(Empty)+} {+(Type {+(Identifier)+} {+(TypeParameters)+})+} @@ -213,6 +227,7 @@ {+(Identifier)+})+})+})+} {+(Empty)+})+} (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -222,6 +237,7 @@ (Deriving (Identifier))) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -235,4 +251,70 @@ (Identifier) (Identifier) (Identifier) - (Identifier))))) + (Identifier))) + (Datatype + (Context' + (Class + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (TypeParameters + (Identifier) + (Identifier)))) + (Class + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)))) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt index 343e3dc0c..aa3e6ab85 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt @@ -2,12 +2,14 @@ (Empty) (Statements (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } (TypeParameters)) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -20,6 +22,7 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -33,6 +36,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -48,10 +52,14 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } (TypeParameters)) + {+(Constructor + {+(Identifier)+} + {+(TypeParameters)+})+} (Constructor { (Identifier) ->(Identifier) } @@ -63,10 +71,6 @@ {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} - (Constructor - { (Identifier) - ->(Identifier) } - (TypeParameters)) {+(Constructor {+(Identifier)+} {+(TypeParameters)+})+} @@ -79,11 +83,15 @@ {-(Constructor {-(Identifier)-} {-(TypeParameters)-})-} + {-(Constructor + {-(Identifier)-} + {-(TypeParameters)-})-} {-(Constructor {-(Identifier)-} {-(TypeParameters)-})-} (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -98,6 +106,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -113,6 +122,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -133,6 +143,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type { (Identifier) ->(Identifier) } @@ -156,6 +167,7 @@ (Identifier)))) (Empty)) {+(Datatype + {+(Empty)+} {+(Type {+(Identifier)+} {+(TypeParameters)+})+} @@ -175,6 +187,7 @@ {+(Identifier)+})+})+})+} {+(Empty)+})+} (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -194,6 +207,7 @@ (Identifier)))) (Empty)) {-(Datatype + {-(Empty)-} {-(Type {-(Identifier)-} {-(TypeParameters)-})-} @@ -213,6 +227,7 @@ {-(Identifier)-})-})-})-} {-(Empty)-})-} (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -222,6 +237,7 @@ (Deriving (Identifier))) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -235,4 +251,70 @@ (Identifier) (Identifier) (Identifier) - (Identifier))))) + (Identifier))) + (Datatype + (Context' + (Class + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (TypeParameters + (Identifier) + (Identifier)))) + (Class + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)))) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt index 0a8677682..7eda5ef92 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseA.txt @@ -2,11 +2,13 @@ (Empty) (Statements (Datatype + (Empty) (Type (Identifier) (TypeParameters)) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters @@ -17,6 +19,7 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters @@ -28,6 +31,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters @@ -41,6 +45,7 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -64,6 +69,7 @@ (TypeParameters)) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -76,6 +82,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -89,6 +96,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -107,6 +115,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -128,6 +137,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -147,6 +157,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -166,6 +177,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -175,6 +187,7 @@ (Deriving (Identifier))) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -187,4 +200,67 @@ (Identifier) (Identifier) (Identifier) - (Identifier))))) + (Identifier))) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (TypeParameters + (Identifier) + (Identifier)))) + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)))) diff --git a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt index 0a8677682..7eda5ef92 100644 --- a/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt +++ b/test/fixtures/haskell/corpus/algebraic-datatype-declarations.parseB.txt @@ -2,11 +2,13 @@ (Empty) (Statements (Datatype + (Empty) (Type (Identifier) (TypeParameters)) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters @@ -17,6 +19,7 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters @@ -28,6 +31,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters @@ -41,6 +45,7 @@ (Identifier))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -64,6 +69,7 @@ (TypeParameters)) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -76,6 +82,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -89,6 +96,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -107,6 +115,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -128,6 +137,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -147,6 +157,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -166,6 +177,7 @@ (Identifier)))) (Empty)) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -175,6 +187,7 @@ (Deriving (Identifier))) (Datatype + (Empty) (Type (Identifier) (TypeParameters)) @@ -187,4 +200,67 @@ (Identifier) (Identifier) (Identifier) - (Identifier))))) + (Identifier))) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier))) + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)) + (Datatype + (Context' + (Class + (Identifier) + (TypeParameters + (TypeParameters + (Identifier) + (Identifier)))) + (Class + (Identifier) + (TypeParameters + (Identifier)))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Constructor + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Empty)))) diff --git a/test/fixtures/haskell/corpus/literals.diffA-B.txt b/test/fixtures/haskell/corpus/literals.diffA-B.txt index b92d95ba6..e428f0440 100644 --- a/test/fixtures/haskell/corpus/literals.diffA-B.txt +++ b/test/fixtures/haskell/corpus/literals.diffA-B.txt @@ -1,11 +1,10 @@ (Module (Identifier) (Statements - (Function - { (Identifier) - ->(Identifier) } - (Statements - (Integer))) + {+(Function + {+(Identifier)+} + {+(Statements + {+(Integer)+})+})+} {+(Function {+(Identifier)+} {+(Statements @@ -284,6 +283,10 @@ {-(Identifier)-} {-(Statements {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-(Statements + {-(Integer)-})-})-} {-(Function {-(Identifier)-} {-(Statements diff --git a/test/fixtures/haskell/corpus/literals.diffB-A.txt b/test/fixtures/haskell/corpus/literals.diffB-A.txt index 923d94247..e428f0440 100644 --- a/test/fixtures/haskell/corpus/literals.diffB-A.txt +++ b/test/fixtures/haskell/corpus/literals.diffB-A.txt @@ -1,11 +1,6 @@ (Module (Identifier) (Statements - (Function - { (Identifier) - ->(Identifier) } - (Statements - (Integer))) {+(Function {+(Identifier)+} {+(Statements @@ -18,12 +13,14 @@ {+(Identifier)+} {+(Statements {+(Integer)+})+})+} - (Function - { (Identifier) - ->(Identifier) } - (Statements - { (Integer) - ->(Integer) })) + {+(Function + {+(Identifier)+} + {+(Statements + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+(Statements + {+(Integer)+})+})+} {+(Function {+(Identifier)+} {+(Statements @@ -282,6 +279,14 @@ {-(Identifier)-} {-(Statements {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-(Statements + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-(Statements + {-(Integer)-})-})-} {-(Function {-(Identifier)-} {-(Statements From eb64f88bd085804cd7d24ebfe1583522cf2c988e Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 1 Jun 2018 16:41:29 -0700 Subject: [PATCH 06/19] Updates per changes in master --- src/Data/Syntax/Declaration.hs | 2 +- src/Language/Haskell/Syntax.hs | 27 +++++++-------------------- 2 files changed, 8 insertions(+), 21 deletions(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index a23b59e80..201615a73 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -182,7 +182,7 @@ instance Evaluatable Decorator -- | 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], datatypeDeriving :: a } +data Datatype a = Datatype { datatypeContext :: a, datatypeName :: a, datatypeConstructors :: [a], datatypeDeriving :: a } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 053aa73bb..7f4074b36 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -26,8 +26,6 @@ instance Eq1 StrictType where liftEq = genericLiftEq instance Ord1 StrictType where liftCompare = genericLiftCompare instance Show1 StrictType where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 StrictType - instance Evaluatable StrictType newtype StrictTypeVariable a = StrictTypeVariable { strictTypeVariableIdentifier :: a } @@ -37,8 +35,6 @@ instance Eq1 StrictTypeVariable where liftEq = genericLiftEq instance Ord1 StrictTypeVariable where liftCompare = genericLiftCompare instance Show1 StrictTypeVariable where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 StrictTypeVariable - instance Evaluatable StrictTypeVariable data Type a = Type { typeIdentifier :: !a, typeParameters :: !a } @@ -102,19 +98,15 @@ instance Eq1 RecordDataConstructor where liftEq = genericLiftEq instance Ord1 RecordDataConstructor where liftCompare = genericLiftCompare instance Show1 RecordDataConstructor where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 RecordDataConstructor - instance Evaluatable RecordDataConstructor -data Field a = Field { fieldName :: !a, fieldBody :: !a } +data Field a = Field { fieldName :: !a, fieldBody :: !a } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Field where liftEq = genericLiftEq instance Ord1 Field where liftCompare = genericLiftCompare instance Show1 Field where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 Field - instance Evaluatable Field newtype Pragma a = Pragma ByteString @@ -124,36 +116,31 @@ instance Eq1 Pragma where liftEq = genericLiftEq instance Ord1 Pragma where liftCompare = genericLiftCompare instance Show1 Pragma where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 Pragma - instance Evaluatable Pragma -newtype Deriving a = Deriving [a] deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype Deriving a = Deriving [a] + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Deriving where liftEq = genericLiftEq instance Ord1 Deriving where liftCompare = genericLiftCompare instance Show1 Deriving where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 Deriving - instance Evaluatable Deriving -newtype Context' a = Context' [a] deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype Context' a = Context' [a] + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Context' where liftEq = genericLiftEq instance Ord1 Context' where liftCompare = genericLiftCompare instance Show1 Context' where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 Context' - instance Evaluatable Context' -data Class a = Class { classType :: a, classTypeParameters :: a } deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +data Class a = Class { classType :: a, classTypeParameters :: a } + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) instance Eq1 Class where liftEq = genericLiftEq instance Ord1 Class where liftCompare = genericLiftCompare instance Show1 Class where liftShowsPrec = genericLiftShowsPrec -instance ToJSONFields1 Class - instance Evaluatable Class From 2a8e02856b4c39317bcd93d6cd67c97835219c95 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 14:25:17 -0400 Subject: [PATCH 07/19] tentative commit to move from Maybe Language to Language. should fix a lot of issues around decoding Maybe Language fields. --- src/Analysis/Declaration.hs | 16 +++++------ src/Data/Blob.hs | 9 +++--- src/Data/Language.hs | 55 +++++++++++++++++++++++++------------ src/Data/Project.hs | 12 ++++++-- src/Parsing/Parser.hs | 6 ++-- src/Rendering/Imports.hs | 4 +-- src/Rendering/Symbol.hs | 6 ++-- src/Rendering/TOC.hs | 4 +-- src/Semantic/AST.hs | 2 +- src/Semantic/CLI.hs | 9 +++--- src/Semantic/Diff.hs | 2 +- src/Semantic/IO.hs | 8 +++--- src/Semantic/Parse.hs | 3 +- src/Semantic/Task.hs | 2 +- src/Semantic/Util.hs | 6 ++-- types.proto | 3 +- 16 files changed, 88 insertions(+), 59 deletions(-) diff --git a/src/Analysis/Declaration.hs b/src/Analysis/Declaration.hs index 04d12088d..0f6ae1ae8 100644 --- a/src/Analysis/Declaration.hs +++ b/src/Analysis/Declaration.hs @@ -26,13 +26,13 @@ import Prologue hiding (project) -- | A declaration’s identifier and type. data Declaration - = MethodDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationReceiver :: Maybe T.Text } - | ClassDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language } - | ImportDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationAlias :: T.Text, declarationSymbols :: [(T.Text, T.Text)] } - | FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language } - | HeadingDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationLevel :: Int } - | CallReference { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationImportIdentifier :: [T.Text] } - | ErrorDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language } + = MethodDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationReceiver :: Maybe T.Text } + | ClassDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language } + | ImportDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationAlias :: T.Text, declarationSymbols :: [(T.Text, T.Text)] } + | FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language } + | HeadingDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationLevel :: Int } + | CallReference { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationImportIdentifier :: [T.Text] } + | ErrorDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language } deriving (Eq, Generic, Show) @@ -109,7 +109,7 @@ instance CustomHasDeclaration whole Declaration.Method where -- Methods without a receiver | isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage Nothing -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go). - | blobLanguage == Just Go + | blobLanguage == Go , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource blobSource receiverType)) -- Methods with a receiver (class methods) are formatted like `receiver.method_name` | otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource blobSource receiverAnn)) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 426b9712c..d65842d4e 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -26,17 +26,16 @@ import Data.Source as Source data Blob = Blob { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. , blobPath :: FilePath -- ^ The file path to the blob. - , blobLanguage :: Maybe Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet. + , blobLanguage :: Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet. } deriving (Show, Eq, Generic, Message, Named) nullBlob :: Blob -> Bool nullBlob Blob{..} = nullSource blobSource -sourceBlob :: FilePath -> Maybe Language -> Source -> Blob +sourceBlob :: FilePath -> Language -> Source -> Blob sourceBlob filepath language source = Blob source filepath language - -- | Represents a blobs suitable for diffing which can be either a blob to -- delete, a blob to insert, or a pair of blobs to diff. type BlobPair = Join These Blob @@ -51,7 +50,7 @@ blobPairInserting = Join . That blobPairDeleting :: Blob -> BlobPair blobPairDeleting = Join . This -languageForBlobPair :: BlobPair -> Maybe Language +languageForBlobPair :: BlobPair -> Language languageForBlobPair (Join (This Blob{..})) = blobLanguage languageForBlobPair (Join (That Blob{..})) = blobLanguage languageForBlobPair (Join (These _ Blob{..})) = blobLanguage @@ -62,7 +61,7 @@ pathForBlobPair (Join (That Blob{..})) = blobPath pathForBlobPair (Join (These _ Blob{..})) = blobPath languageTagForBlobPair :: BlobPair -> [(String, String)] -languageTagForBlobPair pair = maybe [] showLanguage (languageForBlobPair pair) +languageTagForBlobPair pair = showLanguage (languageForBlobPair pair) where showLanguage = pure . (,) "language" . show pathKeyForBlobPair :: BlobPair -> FilePath diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 1d4b2eb40..504077767 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-} module Data.Language where import Prologue import Data.Aeson +import Debug.Trace import Proto3.Suite -- | A programming language. @@ -18,25 +19,45 @@ data Language | Ruby | TypeScript | PHP - deriving (Eq, Generic, Ord, Read, Show, ToJSON, Named, Enum, Finite, Message) + | Unknown + deriving (Eq, Generic, Ord, Read, Show, Bounded, ToJSON, Named, Enum, Finite, MessageField) + +knownLanguage :: Language -> Bool +knownLanguage = (/= Unknown) + +ensureLanguage :: Language -> Maybe Language +ensureLanguage Unknown = Nothing +ensureLanguage x = Just x + +-- | Defaults to 'PACKAGE'. +instance HasDefault Language where def = Unknown + +-- | Piggybacks on top of the 'Enumerated' instance, as the generated code would. +-- This instance will get easier when we have DerivingVia. +instance Primitive Language where + primType _ = primType (Proxy @(Enumerated Language)) + encodePrimitive f = encodePrimitive f . Enumerated . Right + decodePrimitive = decodePrimitive >>= \case + (Enumerated (Right r)) -> pure (succ r) + other -> Prelude.fail ("Language decodeMessageField: unexpected value" <> show other) -- | Returns a Language based on the file extension (including the "."). -languageForType :: String -> Maybe Language +languageForType :: String -> Language languageForType mediaType = case mediaType of - ".java" -> Just Java - ".json" -> Just JSON - ".hs" -> Just Haskell - ".md" -> Just Markdown - ".rb" -> Just Ruby - ".go" -> Just Go - ".js" -> Just JavaScript - ".ts" -> Just TypeScript - ".tsx" -> Just TypeScript - ".jsx" -> Just JSX - ".py" -> Just Python - ".php" -> Just PHP - ".phpt" -> Just PHP - _ -> Nothing + ".java" -> Java + ".json" -> JSON + ".hs" -> Haskell + ".md" -> Markdown + ".rb" -> Ruby + ".go" -> Go + ".js" -> JavaScript + ".ts" -> TypeScript + ".tsx" -> TypeScript + ".jsx" -> JSX + ".py" -> Python + ".php" -> PHP + ".phpt" -> PHP + _ -> Unknown extensionsForLanguage :: Language -> [String] extensionsForLanguage language = case language of diff --git a/src/Data/Project.hs b/src/Data/Project.hs index a63478e8d..6214bdd7b 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE MultiWayIf #-} + module Data.Project where -import Data.ByteString.Char8 as BC (pack) +import Data.ByteString.Char8 as BC (pack, writeFile) +import Data.Blob import Data.Language import Prologue import System.FilePath.Posix @@ -22,11 +25,14 @@ projectExtensions = extensionsForLanguage . projectLanguage data File = File - { filePath :: FilePath - , fileLanguage :: Maybe Language + { filePath :: FilePath + , fileLanguage :: Language } deriving (Eq, Ord, Show) file :: FilePath -> File file path = File path (languageForFilePath path) where languageForFilePath = languageForType . takeExtension + +blobToFile :: Blob -> File +blobToFile (Blob _ f l) = File f l diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 83e942131..6324a93b7 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -82,11 +82,11 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced. someAnalysisParser _ Go = SomeAnalysisParser goParser Nothing someAnalysisParser _ Java = SomeAnalysisParser javaParser Nothing -someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) (Just JavaScript)) +someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) JavaScript) someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser Nothing someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing -someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python)) -someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby)) +someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) Python) +someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Ruby) someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser Nothing someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l diff --git a/src/Rendering/Imports.hs b/src/Rendering/Imports.hs index 33be742f0..24d0bb87e 100644 --- a/src/Rendering/Imports.hs +++ b/src/Rendering/Imports.hs @@ -44,7 +44,7 @@ renderToImports blob term = ImportSummary $ toMap (termToModule blob term) _ -> defaultModuleName makeModule :: (HasField fields Span, HasField fields (Maybe Declaration)) => T.Text -> Blob -> [Record fields] -> Module -makeModule name Blob{..} ds = Module name [T.pack blobPath] (T.pack . show <$> blobLanguage) (mapMaybe importSummary ds) (mapMaybe (declarationSummary name) ds) (mapMaybe referenceSummary ds) +makeModule name Blob{..} ds = Module name [T.pack blobPath] (T.pack (show blobLanguage)) (mapMaybe importSummary ds) (mapMaybe (declarationSummary name) ds) (mapMaybe referenceSummary ds) getPackageDef :: HasField fields (Maybe PackageDef) => Record fields -> Maybe PackageDef @@ -79,7 +79,7 @@ referenceSummary record = case getDeclaration record of data Module = Module { moduleName :: T.Text , modulePaths :: [T.Text] - , moduleLanguage :: Maybe T.Text + , moduleLanguage :: T.Text , moduleImports :: [ImportStatement] , moduleDeclarations :: [SymbolDeclaration] , moduleCalls :: [CallExpression] diff --git a/src/Rendering/Symbol.hs b/src/Rendering/Symbol.hs index 27bd41b39..c08260c78 100644 --- a/src/Rendering/Symbol.hs +++ b/src/Rendering/Symbol.hs @@ -34,7 +34,7 @@ renderToSymbols :: (HasField fields (Maybe Declaration), HasField fields Span, F renderToSymbols fields Blob{..} term = [toJSON (termToC fields blobPath term)] where termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => SymbolFields -> FilePath -> Term f (Record fields) -> File - termToC fields path = File (T.pack path) (T.pack . show <$> blobLanguage) . mapMaybe (symbolSummary fields path "unchanged") . termTableOfContentsBy declaration + termToC fields path = File (T.pack path) (T.pack (show blobLanguage)) . mapMaybe (symbolSummary fields path "unchanged") . termTableOfContentsBy declaration -- | Construct a 'Symbol' from a node annotation and a change type label. symbolSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => SymbolFields -> FilePath -> T.Text -> Record fields -> Maybe Symbol @@ -43,7 +43,7 @@ symbolSummary SymbolFields{..} path _ record = case getDeclaration record of Just declaration -> Just Symbol { symbolName = when symbolFieldsName (declarationIdentifier declaration) , symbolPath = when symbolFieldsPath (T.pack path) - , symbolLang = join (when symbolFieldsLang (T.pack . show <$> declarationLanguage declaration)) + , symbolLang = when symbolFieldsLang (T.pack (show (declarationLanguage declaration))) , symbolKind = when symbolFieldsKind (toCategoryName declaration) , symbolLine = when symbolFieldsLine (declarationText declaration) , symbolSpan = when symbolFieldsSpan (getField record) @@ -52,7 +52,7 @@ symbolSummary SymbolFields{..} path _ record = case getDeclaration record of data File = File { filePath :: T.Text - , fileLanguage :: Maybe T.Text + , fileLanguage :: T.Text , fileSymbols :: [Symbol] } deriving (Generic, Eq, Show) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 6a23ec8fd..9cebc0f56 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -54,7 +54,7 @@ data TOCSummary , summarySpan :: Span , summaryChangeType :: T.Text } - | ErrorSummary { errorText :: T.Text, errorSpan :: Span, errorLanguage :: Maybe Language } + | ErrorSummary { errorText :: T.Text, errorSpan :: Span, errorLanguage :: Language } deriving (Generic, Eq, Show) instance ToJSON TOCSummary where @@ -146,7 +146,7 @@ recordSummary changeText record = case getDeclaration record of Just declaration -> Just $ TOCSummary (toCategoryName declaration) (formatIdentifier declaration) (getField record) changeText Nothing -> Nothing where - formatIdentifier (MethodDeclaration identifier _ (Just Language.Go) (Just receiver)) = "(" <> receiver <> ") " <> identifier + formatIdentifier (MethodDeclaration identifier _ Language.Go (Just receiver)) = "(" <> receiver <> ") " <> identifier formatIdentifier (MethodDeclaration identifier _ _ (Just receiver)) = receiver <> "." <> identifier formatIdentifier declaration = declarationIdentifier declaration diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index 7df7beca9..a7b382732 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -18,7 +18,7 @@ withSomeAST f (SomeAST ast) = f ast astParseBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs SomeAST astParseBlob blob@Blob{..} - | Just (SomeASTParser parser) <- someASTParser <$> blobLanguage + | Just (SomeASTParser parser) <- someASTParser <$> (Just blobLanguage) = SomeAST <$> parse parser blob | otherwise = noLanguageForBlob blobPath diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 6a9ac8427..3c238749a 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -8,6 +8,7 @@ module Semantic.CLI ) where import Data.Project +import Data.Language (ensureLanguage) import Data.List (intercalate) import Data.List.Split (splitWhen) import Data.Version (showVersion) @@ -98,15 +99,15 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar rootDir <- rootDirectoryOption excludeDirs <- excludeDirsOption File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE") - pure $ Task.readProject rootDir filePath (fromJust fileLanguage) excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer + pure $ Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer rootDirectoryOption = optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of - [a, b] | lang <- readMaybe b -> Right (File a lang) - | lang <- readMaybe a -> Right (File b lang) - [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path . Just) (languageForFilePath path) + [a, b] | (Just lang) <- (readMaybe b >>= ensureLanguage) -> Right (File a lang) + | (Just lang) <- (readMaybe a >>= ensureLanguage) -> Right (File b lang) + [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path) (ensureLanguage (languageForFilePath path)) args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE") optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 8e9046794..9225a5cc1 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -54,6 +54,6 @@ withParsedBlobPair :: (Member (Distribute WrappedTask) effs, Member (Exc SomeExc -> BlobPair -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (Record fields)) withParsedBlobPair decorate blobs - | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs + | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] <$> (Just (languageForBlobPair blobs)) = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob)) | otherwise = noLanguageForBlob (pathForBlobPair blobs) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 9a594e557..1de1bbc22 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -77,7 +77,7 @@ isDirectory :: MonadIO m => FilePath -> m Bool isDirectory path = liftIO (doesDirectoryExist path) -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported. -languageForFilePath :: FilePath -> Maybe Language +languageForFilePath :: FilePath -> Language languageForFilePath = languageForType . takeExtension -- | Read JSON encoded blob pairs from a handle. @@ -108,7 +108,7 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do paths <- liftIO $ filterFun <$> findFilesInDir rootDir exts excludeDirs pure $ Project rootDir (toFile <$> paths) lang entryPoints excludeDirs where - toFile path = File path (Just lang) + toFile path = File path lang exts = extensionsForLanguage lang -- Recursively find files in a directory. @@ -138,7 +138,7 @@ findFilesInDir path exts excludeDirs = do readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob] readBlobsFromDir path = do paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path) - let paths' = catMaybes $ fmap (\p -> File p . Just <$> languageForFilePath p) paths + let paths' = fmap (\p -> File p (languageForFilePath p)) paths blobs <- traverse readFile paths' pure (catMaybes blobs) @@ -153,7 +153,7 @@ toBlob :: Blob -> Blob.Blob toBlob Blob{..} = Blob.sourceBlob path language' (fromText content) where language' = case language of "" -> languageForFilePath path - _ -> readMaybe language + _ -> fromMaybe Unknown (readMaybe language) newtype BlobDiff = BlobDiff { blobs :: [BlobPair] } diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index a6e54ece0..d8f84589b 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -9,6 +9,7 @@ import Data.Blob import Data.JSON.Fields import Data.Record import Data.Term +import Data.Language (ensureLanguage) import Parsing.Parser import Prologue hiding (MonadError(..)) import Rendering.Graph @@ -30,4 +31,4 @@ withParsedBlobs :: (Member (Distribute WrappedTask) effs, Monoid output) => (for withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob))) parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] (Record Location)) -parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage +parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) (ensureLanguage blobLanguage) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index bd86a3f49..9cf2496ba 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -227,7 +227,7 @@ runParser blob@Blob{..} parser = case parser of in length term `seq` pure term SomeParser parser -> SomeTerm <$> runParser blob parser where blobFields = ("path", blobPath) : languageTag - languageTag = maybe [] (pure . (,) ("language" :: String) . show) blobLanguage + languageTag = pure . (,) ("language" :: String) . show $ blobLanguage errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) (Record Assignment.Location) -> [Error.Error String] errors = cata $ \ (In a syntax) -> case syntax of _ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError (getField a) err] diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e032419de..10e7e0903 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -71,9 +71,9 @@ evalTypeScriptProject path = justEvaluating =<< evaluateProject typescriptParser typecheckGoFile path = checking =<< evaluateProjectWithCaching goParser Language.Go Nothing path -rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby) -pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python) -javaScriptPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) (Just Language.JavaScript) +rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Language.Ruby +pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) Language.Python +javaScriptPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) Language.JavaScript -- Evaluate a project, starting at a single entrypoint. evaluateProject parser lang prelude path = evaluatePackageWith id withTermSpans . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude) diff --git a/types.proto b/types.proto index d06c84fcf..ed0cc94ab 100644 --- a/types.proto +++ b/types.proto @@ -9,7 +9,8 @@ enum Language {Go = 0; Python = 6; Ruby = 7; TypeScript = 8; - PHP = 9;} + PHP = 9; + Unknown = 10;} message Blob { bytes blobSource = 1; string blobPath = 2; Language blobLanguage = 3; From 39d9ad8e864605156496b536c0d3436e2b33ee74 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 15:14:07 -0400 Subject: [PATCH 08/19] Try, unsuccessfully, to fix weird off-by-one error in Language serialization --- src/Data/Language.hs | 4 ++-- types.proto | 24 ++++++++++++------------ 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 504077767..635a18801 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -8,7 +8,8 @@ import Proto3.Suite -- | A programming language. data Language - = Go + = Unknown + | Go | Haskell | Java | JavaScript @@ -19,7 +20,6 @@ data Language | Ruby | TypeScript | PHP - | Unknown deriving (Eq, Generic, Ord, Read, Show, Bounded, ToJSON, Named, Enum, Finite, MessageField) knownLanguage :: Language -> Bool diff --git a/types.proto b/types.proto index ed0cc94ab..bacadc811 100644 --- a/types.proto +++ b/types.proto @@ -1,16 +1,16 @@ syntax = "proto3"; package semantic; -enum Language {Go = 0; - Haskell = 1; - JavaScript = 2; - JSON = 3; - JSX = 4; - Markdown = 5; - Python = 6; - Ruby = 7; - TypeScript = 8; - PHP = 9; - Unknown = 10;} +enum Language {Unknown = 0; + Go = 1; + Haskell = 2; + JavaScript = 3; + JSON = 4; + JSX = 5; + Markdown = 6; + Python = 7; + Ruby = 8; + TypeScript = 9; + PHP = 10;} message Blob { bytes blobSource = 1; string blobPath = 2; Language blobLanguage = 3; @@ -43,4 +43,4 @@ message Term { oneof syntax {Array array = 1; KeyValue keyValue = 5; Null null = 6; TextElement textElement = 7;} - } \ No newline at end of file + } From e5c3408b93df7a98e0d21993b969f2461c181e6e Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Mon, 4 Jun 2018 14:53:21 -0700 Subject: [PATCH 09/19] Appease hlint --- src/Language/Haskell/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 0855f30c7..1cf28814e 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -130,7 +130,7 @@ context' :: Assignment context' = makeTerm <$> symbol Context <*> children (Syntax.Context' <$> many (type' <|> contextPattern)) contextPattern :: Assignment -contextPattern = symbol ContextPattern *> children (type') +contextPattern = symbol ContextPattern *> children type' derivingClause :: Assignment derivingClause = makeTerm <$> symbol Deriving <*> children (Syntax.Deriving <$> many typeConstructor) @@ -200,7 +200,7 @@ listType :: Assignment listType = makeTerm <$> symbol ListType <*> children (Literal.Array <$> many type') parenthesizedTypePattern :: Assignment -parenthesizedTypePattern = symbol ParenthesizedTypePattern *> children (typeParameters) +parenthesizedTypePattern = symbol ParenthesizedTypePattern *> children typeParameters strictType :: Assignment strictType = makeTerm' <$> symbol StrictType <*> children ((inject <$> (Syntax.StrictType <$> typeConstructor <*> typeParameters)) From b3eae027f6d2cb087b33c605cac4068d5ce5b803 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 17:55:49 -0400 Subject: [PATCH 10/19] This should fix the issues associated with off-by-ones --- src/Data/Language.hs | 2 +- types.proto | 19 ++++++++++--------- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 635a18801..19f4170ca 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -38,7 +38,7 @@ instance Primitive Language where primType _ = primType (Proxy @(Enumerated Language)) encodePrimitive f = encodePrimitive f . Enumerated . Right decodePrimitive = decodePrimitive >>= \case - (Enumerated (Right r)) -> pure (succ r) + (Enumerated (Right r)) -> pure r other -> Prelude.fail ("Language decodeMessageField: unexpected value" <> show other) -- | Returns a Language based on the file extension (including the "."). diff --git a/types.proto b/types.proto index bacadc811..7d586835e 100644 --- a/types.proto +++ b/types.proto @@ -3,14 +3,15 @@ package semantic; enum Language {Unknown = 0; Go = 1; Haskell = 2; - JavaScript = 3; - JSON = 4; - JSX = 5; - Markdown = 6; - Python = 7; - Ruby = 8; - TypeScript = 9; - PHP = 10;} + Java = 3; + JavaScript = 4; + JSON = 5; + JSX = 6; + Markdown = 7; + Python = 8; + Ruby = 9; + TypeScript = 10; + PHP = 11;} message Blob { bytes blobSource = 1; string blobPath = 2; Language blobLanguage = 3; @@ -43,4 +44,4 @@ message Term { oneof syntax {Array array = 1; KeyValue keyValue = 5; Null null = 6; TextElement textElement = 7;} - } + } \ No newline at end of file From a8212b14a30160192a41bf7e4d372ccad5b7b410 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:03:16 -0400 Subject: [PATCH 11/19] pretty-fication --- src/Data/Language.hs | 49 +++++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 23 deletions(-) diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 19f4170ca..daddd8000 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-} +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase #-} module Data.Language where -import Prologue import Data.Aeson -import Debug.Trace +import Prologue import Proto3.Suite --- | A programming language. +-- | The various languages we support. +-- Please do not reorder any of the field names: the current implementation of 'Primitive' +-- delegates to the auto-generated 'Enum' instance. data Language = Unknown | Go @@ -22,14 +23,16 @@ data Language | PHP deriving (Eq, Generic, Ord, Read, Show, Bounded, ToJSON, Named, Enum, Finite, MessageField) +-- | Predicate failing on 'Unknown' and passing in all other cases. knownLanguage :: Language -> Bool knownLanguage = (/= Unknown) +-- | Returns 'Nothing' when passed 'Unknown'. ensureLanguage :: Language -> Maybe Language ensureLanguage Unknown = Nothing -ensureLanguage x = Just x +ensureLanguage x = Just x --- | Defaults to 'PACKAGE'. +-- | Defaults to 'Unknown'. instance HasDefault Language where def = Unknown -- | Piggybacks on top of the 'Enumerated' instance, as the generated code would. @@ -46,26 +49,26 @@ languageForType :: String -> Language languageForType mediaType = case mediaType of ".java" -> Java ".json" -> JSON - ".hs" -> Haskell - ".md" -> Markdown - ".rb" -> Ruby - ".go" -> Go - ".js" -> JavaScript - ".ts" -> TypeScript - ".tsx" -> TypeScript - ".jsx" -> JSX - ".py" -> Python - ".php" -> PHP + ".hs" -> Haskell + ".md" -> Markdown + ".rb" -> Ruby + ".go" -> Go + ".js" -> JavaScript + ".ts" -> TypeScript + ".tsx" -> TypeScript + ".jsx" -> JSX + ".py" -> Python + ".php" -> PHP ".phpt" -> PHP - _ -> Unknown + _ -> Unknown extensionsForLanguage :: Language -> [String] extensionsForLanguage language = case language of - Go -> [".go"] - Haskell -> [".hs"] + Go -> [".go"] + Haskell -> [".hs"] JavaScript -> [".js"] - PHP -> [".php"] - Python -> [".py"] - Ruby -> [".rb"] + PHP -> [".php"] + Python -> [".py"] + Ruby -> [".rb"] TypeScript -> [".ts", ".tsx", ".d.tsx"] - _ -> [] + _ -> [] From 16066c1f7d34b1d2f40b6e5b58d9bb3f13aa358d Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:10:00 -0400 Subject: [PATCH 12/19] fewer spurious changes --- src/Data/Project.hs | 8 +------- src/Parsing/Parser.hs | 1 + src/Rendering/Imports.hs | 5 +++-- src/Rendering/Symbol.hs | 3 ++- 4 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Data/Project.hs b/src/Data/Project.hs index 6214bdd7b..0cecffed0 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE MultiWayIf #-} - module Data.Project where -import Data.ByteString.Char8 as BC (pack, writeFile) -import Data.Blob +import Data.ByteString.Char8 as BC (pack) import Data.Language import Prologue import System.FilePath.Posix @@ -33,6 +30,3 @@ data File = File file :: FilePath -> File file path = File path (languageForFilePath path) where languageForFilePath = languageForType . takeExtension - -blobToFile :: Blob -> File -blobToFile (Blob _ f l) = File f l diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 6324a93b7..35d678bfe 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -138,6 +138,7 @@ someParser Python = SomeParser pythonParser someParser Ruby = SomeParser rubyParser someParser TypeScript = SomeParser typescriptParser someParser PHP = SomeParser phpParser +someParser Unknown = error "No parser suitable for an unknown language." goParser :: Parser Go.Term diff --git a/src/Rendering/Imports.hs b/src/Rendering/Imports.hs index 24d0bb87e..ee7f5d8e2 100644 --- a/src/Rendering/Imports.hs +++ b/src/Rendering/Imports.hs @@ -9,6 +9,7 @@ import Analysis.Declaration import Analysis.PackageDef import Data.Aeson import Data.Blob +import Data.Language (ensureLanguage) import Data.Record import Data.Span import Data.Term @@ -44,7 +45,7 @@ renderToImports blob term = ImportSummary $ toMap (termToModule blob term) _ -> defaultModuleName makeModule :: (HasField fields Span, HasField fields (Maybe Declaration)) => T.Text -> Blob -> [Record fields] -> Module -makeModule name Blob{..} ds = Module name [T.pack blobPath] (T.pack (show blobLanguage)) (mapMaybe importSummary ds) (mapMaybe (declarationSummary name) ds) (mapMaybe referenceSummary ds) +makeModule name Blob{..} ds = Module name [T.pack blobPath] (T.pack . show <$> ensureLanguage blobLanguage) (mapMaybe importSummary ds) (mapMaybe (declarationSummary name) ds) (mapMaybe referenceSummary ds) getPackageDef :: HasField fields (Maybe PackageDef) => Record fields -> Maybe PackageDef @@ -79,7 +80,7 @@ referenceSummary record = case getDeclaration record of data Module = Module { moduleName :: T.Text , modulePaths :: [T.Text] - , moduleLanguage :: T.Text + , moduleLanguage :: Maybe T.Text , moduleImports :: [ImportStatement] , moduleDeclarations :: [SymbolDeclaration] , moduleCalls :: [CallExpression] diff --git a/src/Rendering/Symbol.hs b/src/Rendering/Symbol.hs index c08260c78..a13271377 100644 --- a/src/Rendering/Symbol.hs +++ b/src/Rendering/Symbol.hs @@ -10,6 +10,7 @@ import Prologue import Analysis.Declaration import Data.Aeson import Data.Blob +import Data.Language (ensureLanguage) import Data.Record import Data.Span import Data.Term @@ -43,7 +44,7 @@ symbolSummary SymbolFields{..} path _ record = case getDeclaration record of Just declaration -> Just Symbol { symbolName = when symbolFieldsName (declarationIdentifier declaration) , symbolPath = when symbolFieldsPath (T.pack path) - , symbolLang = when symbolFieldsLang (T.pack (show (declarationLanguage declaration))) + , symbolLang = join (when symbolFieldsLang (T.pack . show <$> ensureLanguage (declarationLanguage declaration))) , symbolKind = when symbolFieldsKind (toCategoryName declaration) , symbolLine = when symbolFieldsLine (declarationText declaration) , symbolSpan = when symbolFieldsSpan (getField record) From 6abb7b9a2a2754d0ee574cf07611f9baf4f65a3f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:17:02 -0400 Subject: [PATCH 13/19] tighten up some Maybes now that Unknown is a thing --- src/Parsing/Parser.hs | 48 +++++++++++++++++++++---------------------- src/Semantic/AST.hs | 3 +-- src/Semantic/Diff.hs | 4 ++-- src/Semantic/Parse.hs | 2 +- 4 files changed, 28 insertions(+), 29 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 35d678bfe..c5c3c47b6 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -126,19 +126,19 @@ someParser :: ( ApplyAll typeclasses (Sum Go.Syntax) , ApplyAll typeclasses (Sum PHP.Syntax) ) => Language   -- ^ The 'Language' to select. - -> Parser (SomeTerm typeclasses (Record Location)) -- ^ A 'SomeParser' abstracting the syntax type to be produced. -someParser Go = SomeParser goParser -someParser Java = SomeParser javaParser -someParser JavaScript = SomeParser typescriptParser -someParser JSON = SomeParser jsonParser -someParser Haskell = SomeParser haskellParser -someParser JSX = SomeParser typescriptParser -someParser Markdown = SomeParser markdownParser -someParser Python = SomeParser pythonParser -someParser Ruby = SomeParser rubyParser -someParser TypeScript = SomeParser typescriptParser -someParser PHP = SomeParser phpParser -someParser Unknown = error "No parser suitable for an unknown language." + -> Maybe (Parser (SomeTerm typeclasses (Record Location))) -- ^ A 'SomeParser' abstracting the syntax type to be produced. +someParser Go = Just (SomeParser goParser) +someParser Java = Just (SomeParser javaParser) +someParser JavaScript = Just (SomeParser typescriptParser) +someParser JSON = Just (SomeParser jsonParser) +someParser Haskell = Just (SomeParser haskellParser) +someParser JSX = Just (SomeParser typescriptParser) +someParser Markdown = Just (SomeParser markdownParser) +someParser Python = Just (SomeParser pythonParser) +someParser Ruby = Just (SomeParser rubyParser) +someParser TypeScript = Just (SomeParser typescriptParser) +someParser PHP = Just (SomeParser phpParser) +someParser Unknown = Nothing goParser :: Parser Go.Term @@ -182,14 +182,14 @@ data SomeASTParser where => Parser (AST [] grammar) -> SomeASTParser -someASTParser :: Language -> SomeASTParser -someASTParser Go = SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar)) -someASTParser Haskell = SomeASTParser (ASTParser tree_sitter_haskell :: Parser (AST [] Haskell.Grammar)) -someASTParser JavaScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) -someASTParser JSON = SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar)) -someASTParser JSX = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) -someASTParser Python = SomeASTParser (ASTParser tree_sitter_python :: Parser (AST [] Python.Grammar)) -someASTParser Ruby = SomeASTParser (ASTParser tree_sitter_ruby :: Parser (AST [] Ruby.Grammar)) -someASTParser TypeScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) -someASTParser PHP = SomeASTParser (ASTParser tree_sitter_php :: Parser (AST [] PHP.Grammar)) -someASTParser l = error $ "Tree-Sitter AST parsing not supported for: " <> show l +someASTParser :: Language -> Maybe SomeASTParser +someASTParser Go = Just (SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar))) +someASTParser Haskell = Just (SomeASTParser (ASTParser tree_sitter_haskell :: Parser (AST [] Haskell.Grammar))) +someASTParser JavaScript = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) +someASTParser JSON = Just (SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar))) +someASTParser JSX = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) +someASTParser Python = Just (SomeASTParser (ASTParser tree_sitter_python :: Parser (AST [] Python.Grammar))) +someASTParser Ruby = Just (SomeASTParser (ASTParser tree_sitter_ruby :: Parser (AST [] Ruby.Grammar))) +someASTParser TypeScript = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) +someASTParser PHP = Just (SomeASTParser (ASTParser tree_sitter_php :: Parser (AST [] PHP.Grammar))) +someASTParser l = Nothing diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index a7b382732..292029172 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -18,8 +18,7 @@ withSomeAST f (SomeAST ast) = f ast astParseBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs SomeAST astParseBlob blob@Blob{..} - | Just (SomeASTParser parser) <- someASTParser <$> (Just blobLanguage) - = SomeAST <$> parse parser blob + | Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob | otherwise = noLanguageForBlob blobPath diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 9225a5cc1..d100e7e57 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -54,6 +54,6 @@ withParsedBlobPair :: (Member (Distribute WrappedTask) effs, Member (Exc SomeExc -> BlobPair -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (Record fields)) withParsedBlobPair decorate blobs - | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] <$> (Just (languageForBlobPair blobs)) - = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob)) + | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs) + = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob)) | otherwise = noLanguageForBlob (pathForBlobPair blobs) diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index d8f84589b..42ff4b81a 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -31,4 +31,4 @@ withParsedBlobs :: (Member (Distribute WrappedTask) effs, Monoid output) => (for withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob))) parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] (Record Location)) -parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) (ensureLanguage blobLanguage) +parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob) (someParser blobLanguage) From 10a863f57c6eedba839c262a1bd0e0791c7a195a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:26:47 -0400 Subject: [PATCH 14/19] Fix tests --- test/Data/Functor/Listable.hs | 2 +- test/Rendering/TOC/Spec.hs | 2 +- test/Semantic/CLI/Spec.hs | 8 ++++---- test/Semantic/IO/Spec.hs | 12 ++++++------ test/Semantic/Spec.hs | 6 +++--- 5 files changed, 15 insertions(+), 15 deletions(-) diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 1989447b5..8814052a3 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -274,7 +274,7 @@ instance Listable Declaration where tiers = cons4 MethodDeclaration \/ cons3 FunctionDeclaration - \/ cons2 (\ a b -> ErrorDeclaration a b Nothing) + \/ cons2 (\ a b -> ErrorDeclaration a b Language.Unknown) instance Listable CyclomaticComplexity where tiers = cons1 CyclomaticComplexity diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index e6173fdd8..031733b0c 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -174,7 +174,7 @@ numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) programWithChange :: Term' -> Diff' programWithChange body = merge (programInfo, programInfo) (inject [ function' ]) where - function' = merge (Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject [ inserting body ])))) + function' = merge (Just (FunctionDeclaration "foo" mempty Ruby) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Ruby) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject [ inserting body ])))) name' = let info = Nothing :. emptyInfo in merge (info, info) (inject (Syntax.Identifier (name "foo"))) -- Return a diff where term is inserted in the program, below a function found on both sides of the diff. diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 1c474875b..2a9b1e539 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -39,9 +39,9 @@ parseFixtures = , (show (SymbolsTermRenderer defaultSymbolFields), runParse (SymbolsTermRenderer defaultSymbolFields), path'', prefix "parse-tree.symbols.json") , (show TagsTermRenderer, runParse TagsTermRenderer, path'', prefix "parse-tree.tags.json") ] - where path = [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby)] - path' = [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)] - path'' = [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)] + where path = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby] + path' = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby, File "test/fixtures/ruby/corpus/and-or.B.rb" Ruby] + path'' = [File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby] prefix = "test/fixtures/cli" diffFixtures :: [(String, [BlobPair] -> TaskEff Builder, [Both File], FilePath)] @@ -50,5 +50,5 @@ diffFixtures = , (show SExpressionDiffRenderer, runDiff SExpressionDiffRenderer, pathMode, "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt") , (show ToCDiffRenderer, runDiff ToCDiffRenderer, pathMode, prefix "diff-tree.toc.json") ] - where pathMode = [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)) (File "test/fixtures/ruby/corpus/method-declaration.B.rb" (Just Ruby))] + where pathMode = [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby) (File "test/fixtures/ruby/corpus/method-declaration.B.rb" Ruby)] prefix = "test/fixtures/cli" diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index 20cf1d070..e2ae50316 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -23,15 +23,15 @@ spec :: Spec spec = parallel $ do describe "readFile" $ do it "returns a blob for extant files" $ do - Just blob <- readFile (File "semantic.cabal" Nothing) + Just blob <- readFile (File "semantic.cabal" Unknown) blobPath blob `shouldBe` "semantic.cabal" it "throws for absent files" $ do - readFile (File "this file should not exist" Nothing) `shouldThrow` anyIOException + readFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException describe "readBlobPairsFromHandle" $ do - let a = sourceBlob "method.rb" (Just Ruby) "def foo; end" - let b = sourceBlob "method.rb" (Just Ruby) "def bar(x); end" + let a = sourceBlob "method.rb" Ruby "def foo; end" + let b = sourceBlob "method.rb" Ruby "def bar(x); end" it "returns blobs for valid JSON encoded diff input" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff.json" blobs `shouldBe` [blobPairDiffing a b] @@ -56,7 +56,7 @@ spec = parallel $ do it "returns blobs for unsupported language" $ do h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json" blobs <- readBlobPairsFromHandle h - let b' = sourceBlob "test.kt" Nothing "fun main(args: Array) {\nprintln(\"hi\")\n}\n" + let b' = sourceBlob "test.kt" Unknown "fun main(args: Array) {\nprintln(\"hi\")\n}\n" blobs `shouldBe` [blobPairInserting b'] it "detects language based on filepath for empty language" $ do @@ -97,7 +97,7 @@ spec = parallel $ do it "returns blobs for valid JSON encoded parse input" $ do h <- openFileForReading "test/fixtures/cli/parse.json" blobs <- readBlobsFromHandle h - let a = sourceBlob "method.rb" (Just Ruby) "def foo; end" + let a = sourceBlob "method.rb" Ruby "def foo; end" blobs `shouldBe` [a] it "throws on blank input" $ do diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 442eec578..80c5fb014 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -11,8 +11,8 @@ import SpecHelpers spec :: Spec spec = parallel $ do describe "parseBlob" $ do - it "throws if not given a language" $ do - runTask (runParse SExpressionTermRenderer [methodsBlob { blobLanguage = Nothing }]) `shouldThrow` (\ code -> case code of + it "throws if given an unknown language" $ do + runTask (runParse SExpressionTermRenderer [methodsBlob { blobLanguage = Unknown }]) `shouldThrow` (\ code -> case code of ExitFailure 1 -> True _ -> False) @@ -20,4 +20,4 @@ spec = parallel $ do output <- fmap runBuilder . runTask $ runParse SExpressionTermRenderer [methodsBlob] output `shouldBe` "(Statements\n (Method\n (Empty)\n (Identifier)\n (Statements)))\n" where - methodsBlob = Blob "def foo\nend\n" "methods.rb" (Just Ruby) + methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby From 6e273d8b6e6ba8198d2f1293fe597fac979003cb Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:31:53 -0400 Subject: [PATCH 15/19] Fix lints --- src/Parsing/Parser.hs | 3 ++- src/Semantic/CLI.hs | 4 ++-- src/Semantic/Parse.hs | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index c5c3c47b6..cf1b2d1d3 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -185,6 +185,7 @@ data SomeASTParser where someASTParser :: Language -> Maybe SomeASTParser someASTParser Go = Just (SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar))) someASTParser Haskell = Just (SomeASTParser (ASTParser tree_sitter_haskell :: Parser (AST [] Haskell.Grammar))) +someASTParser Java = Just (SomeASTParser (ASTParser tree_sitter_java :: Parser (AST [] Java.Grammar))) someASTParser JavaScript = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) someASTParser JSON = Just (SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar))) someASTParser JSX = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) @@ -192,4 +193,4 @@ someASTParser Python = Just (SomeASTParser (ASTParser tree_sitter_python :: someASTParser Ruby = Just (SomeASTParser (ASTParser tree_sitter_ruby :: Parser (AST [] Ruby.Grammar))) someASTParser TypeScript = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) someASTParser PHP = Just (SomeASTParser (ASTParser tree_sitter_php :: Parser (AST [] PHP.Grammar))) -someASTParser l = Nothing +someASTParser Unknown = Nothing diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 3c238749a..f932f75b9 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -105,8 +105,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of - [a, b] | (Just lang) <- (readMaybe b >>= ensureLanguage) -> Right (File a lang) - | (Just lang) <- (readMaybe a >>= ensureLanguage) -> Right (File b lang) + [a, b] | (Just lang) <- readMaybe b >>= ensureLanguage -> Right (File a lang) + | (Just lang) <- readMaybe a >>= ensureLanguage -> Right (File b lang) [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path) (ensureLanguage (languageForFilePath path)) args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE") diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index 42ff4b81a..42f256343 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -31,4 +31,4 @@ withParsedBlobs :: (Member (Distribute WrappedTask) effs, Monoid output) => (for withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob))) parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] (Record Location)) -parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob) (someParser blobLanguage) +parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (`parse` blob) (someParser blobLanguage) From c0f31c9531625238440626b51a5fd7dadb183663 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:41:14 -0400 Subject: [PATCH 16/19] fix warning --- src/Parsing/Parser.hs | 1 + src/Semantic/Parse.hs | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index cf1b2d1d3..fc68770b9 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -193,4 +193,5 @@ someASTParser Python = Just (SomeASTParser (ASTParser tree_sitter_python :: someASTParser Ruby = Just (SomeASTParser (ASTParser tree_sitter_ruby :: Parser (AST [] Ruby.Grammar))) someASTParser TypeScript = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) someASTParser PHP = Just (SomeASTParser (ASTParser tree_sitter_php :: Parser (AST [] PHP.Grammar))) +someASTParser Markdown = Nothing someASTParser Unknown = Nothing diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index 42f256343..b0d7bb2d7 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -9,7 +9,6 @@ import Data.Blob import Data.JSON.Fields import Data.Record import Data.Term -import Data.Language (ensureLanguage) import Parsing.Parser import Prologue hiding (MonadError(..)) import Rendering.Graph From 96771f8ebf23cde82126b0e7181fd597f877f4da Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:53:24 -0400 Subject: [PATCH 17/19] fix tests --- test/Rendering/TOC/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 942b5ad4d..f87be0e5b 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -181,7 +181,7 @@ programWithChange body = merge (programInfo, programInfo) (inject [ function' ]) programWithChangeOutsideFunction :: Term' -> Diff' programWithChangeOutsideFunction term = merge (programInfo, programInfo) (inject [ function', term' ]) where - function' = merge (Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Nothing) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject [])))) + function' = merge (Just (FunctionDeclaration "foo" mempty Unknown) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Unknown) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject [])))) name' = let info = Nothing :. emptyInfo in merge (info, info) (inject (Syntax.Identifier (name "foo"))) term' = inserting term @@ -198,7 +198,7 @@ programOf :: Diff' -> Diff' programOf diff = merge (programInfo, programInfo) (inject [ diff ]) functionOf :: Text -> Term' -> Term' -functionOf n body = termIn (Just (FunctionDeclaration n mempty Nothing) :. emptyInfo) (inject (Declaration.Function [] name' [] (termIn (Nothing :. emptyInfo) (inject [body])))) +functionOf n body = termIn (Just (FunctionDeclaration n mempty Unknown) :. emptyInfo) (inject (Declaration.Function [] name' [] (termIn (Nothing :. emptyInfo) (inject [body])))) where name' = termIn (Nothing :. emptyInfo) (inject (Syntax.Identifier (name n))) From 11d116d89336902059af4df25dd6dfda3ab9b813 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:59:15 -0400 Subject: [PATCH 18/19] remove inaccurate comment --- src/Data/Blob.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index d65842d4e..13378b1b7 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -26,7 +26,7 @@ import Data.Source as Source data Blob = Blob { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. , blobPath :: FilePath -- ^ The file path to the blob. - , blobLanguage :: Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet. + , blobLanguage :: Language -- ^ The language of this blob. } deriving (Show, Eq, Generic, Message, Named) From fa5ccc668ac7056e2a64b93361727d91e1b14aec Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 5 Jun 2018 12:17:04 -0400 Subject: [PATCH 19/19] tighten up languageForBlobPair --- src/Data/Blob.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 13378b1b7..7c6f17de6 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -53,7 +53,11 @@ blobPairDeleting = Join . This languageForBlobPair :: BlobPair -> Language languageForBlobPair (Join (This Blob{..})) = blobLanguage languageForBlobPair (Join (That Blob{..})) = blobLanguage -languageForBlobPair (Join (These _ Blob{..})) = blobLanguage +languageForBlobPair (Join (These a b)) + | blobLanguage a == Unknown || blobLanguage b == Unknown + = Unknown + | otherwise + = blobLanguage b pathForBlobPair :: BlobPair -> FilePath pathForBlobPair (Join (This Blob{..})) = blobPath