diff --git a/.gitmodules b/.gitmodules index 011108b59..75085f50f 100644 --- a/.gitmodules +++ b/.gitmodules @@ -16,12 +16,6 @@ [submodule "vendor/fastsum"] path = vendor/fastsum url = git@github.com:patrickt/fastsum.git -[submodule "vendor/proto3-wire"] - path = vendor/proto3-wire - url = https://github.com/joshvera/proto3-wire -[submodule "vendor/proto3-suite"] - path = vendor/proto3-suite - url = https://github.com/joshvera/proto3-suite [submodule "vendor/semilattices"] path = vendor/semilattices url = https://github.com/robrix/semilattices.git diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 000000000..bc767d285 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,51 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint + +- arguments: [--color=auto, -XDataKinds, -XDeriveFoldable, -XDeriveFunctor, -XDeriveGeneric, -XDeriveTraversable, -XFlexibleContexts, -XFlexibleInstances, -XMultiParamTypeClasses, -XOverloadedStrings, -XRecordWildCards, -XStandaloneDeriving, -XStrictData, -XTypeApplications] + +# Blacklist some functions by default. +- functions: + - {name: unsafePerformIO, within: []} + - {name: unsafeCoerce, within: []} + - {name: head, within: []} + - {name: tail, within: []} + - {name: init, within: []} + - {name: last, within: []} + - {name: fromJust, within: []} + +# Replace a $ b $ c with a . b $ c +- group: {name: dollar, enabled: true} + +# Generalise map to fmap, ++ to <> +- group: {name: generalise, enabled: true} + +# Ignore some builtin hints +- ignore: {name: Use mappend} +- ignore: {name: Redundant do} +- ignore: {name: Use lambda-case} # TODO: investigate whether cost-center analysis is better with lambda-case than it was +- ignore: {name: Use fmap} # Ignored because map has better type inference. + +# Change the severity of hints we don’t want to fail CI for +- suggest: {name: Eta reduce} + +# Our customized warnings + +# AMP fallout +- warning: {lhs: mapM, rhs: traverse, name: Generalize mapM} +- warning: {lhs: mapM_, rhs: traverse_, name: Generalize mapM_} +- warning: {lhs: forM, rhs: for, name: Generalize forM} +- warning: {lhs: forM_, rhs: for_, name: Generalize forM_} +- warning: {lhs: sequence, rhs: sequenceA, name: Generalize sequence} +- warning: {lhs: sequence_, rhs: sequenceA_, name: Generalize sequence_} +- warning: {lhs: return, rhs: pure, name: Avoid return} + +# Terms +- warning: {lhs: termFAnnotation . unTerm, rhs: termAnnotation, name: Use termAnnotation} +- warning: {lhs: termFOut . unTerm, rhs: termOut, name: Use termOut} + +# Conveniences +- warning: {lhs: maybe a pure, rhs: maybeM a, name: Use maybeM} + +# Applicative style +- warning: {lhs: f <$> pure a <*> b, rhs: f a <$> b, name: Avoid redundant pure} +- warning: {lhs: f <$> pure a <* b, rhs: f a <$ b, name: Avoid redundant pure} diff --git a/HLint.hs b/HLint.hs deleted file mode 100644 index e02ff38b5..000000000 --- a/HLint.hs +++ /dev/null @@ -1,35 +0,0 @@ -import "hint" HLint.Default -import "hint" HLint.Dollar -import "hint" HLint.Generalise - -ignore "Use mappend" -ignore "Redundant do" --- TODO: investigate whether cost-center analysis is better with lambda-case than it was -ignore "Use lambda-case" - -error "generalize ++" = (++) ==> (<>) --- AMP fallout -error "generalize mapM" = mapM ==> traverse -error "generalize mapM_" = mapM_ ==> traverse_ -error "generalize forM" = forM ==> for -error "generalize forM_" = forM_ ==> for_ -error "Avoid return" = - return ==> pure - where note = "return is obsolete as of GHC 7.10" - -error "use termAnnotation" = termFAnnotation . unTerm ==> termAnnotation -error "use termOut" = termFOut . unTerm ==> termOut - -error "avoid head" = head - where note = "head is partial; consider using Data.Maybe.listToMaybe" - -error "avoid tail" = tail - where note = "tail is partial; consider pattern-matching" - -error "avoid init" = init - where note = "init is partial; consider pattern-matching" - -error "avoid last" = last - where note = "last is partial; consider pattern-matching" - -error "use maybeM" = maybe a pure ==> maybeM a diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 00485ade9..33fa6a180 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -92,7 +92,7 @@ convergingModules :: ( AbstractValue address value effects convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache $ raiseHandler locally $ do + cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 06184761d..530b8da95 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -61,7 +61,7 @@ class Show1 constr => Evaluatable constr where , Member Trace effects ) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef address)) - eval expr = rvalBox =<< throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "")) + eval expr = rvalBox =<< throwResumable (Unspecialized ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")) -- | Evaluate a given package. diff --git a/src/Data/Functor/Classes/Generic.hs b/src/Data/Functor/Classes/Generic.hs index c5a001ad5..08d0180cc 100644 --- a/src/Data/Functor/Classes/Generic.hs +++ b/src/Data/Functor/Classes/Generic.hs @@ -163,7 +163,7 @@ instance (GShow1Body f, GShow1Body g) => GShow1Body (f :*: g) where else foldr (.) id (intersperse (showString " ") (gliftShowsPrecAll opts conIsRecord sp sl 11 (a :*: b))) Infix _ prec -> showParen (d > prec) $ gliftShowsPrec opts sp sl (succ prec) a . showChar ' ' . showString conName . showChar ' ' . gliftShowsPrec opts sp sl (succ prec) b - gliftShowsPrecAll opts conIsRecord sp sl d (a :*: b) = gliftShowsPrecAll opts conIsRecord sp sl d a ++ gliftShowsPrecAll opts conIsRecord sp sl d b + gliftShowsPrecAll opts conIsRecord sp sl d (a :*: b) = gliftShowsPrecAll opts conIsRecord sp sl d a <> gliftShowsPrecAll opts conIsRecord sp sl d b instance GShow1 f => GShow1 (M1 S c f) where gliftShowsPrec opts sp sl d (M1 a) = gliftShowsPrec opts sp sl d a diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 2e2f98af7..60902815f 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -17,11 +17,11 @@ infixr 0 :. -- | Get the first element of a non-empty record. rhead :: Record (head ': tail) -> head -rhead (head :. _) = head +rhead (head_ :. _) = head_ -- | Get the first element of a non-empty record. rtail :: Record (head ': tail) -> Record tail -rtail (_ :. tail) = tail +rtail (_ :. tail_) = tail_ -- Classes diff --git a/src/Data/Scientific/Exts.hs b/src/Data/Scientific/Exts.hs index a275002a9..911e58099 100644 --- a/src/Data/Scientific/Exts.hs +++ b/src/Data/Scientific/Exts.hs @@ -106,3 +106,5 @@ parser = signed (choice [hex, oct, bin, dec]) where attemptUnsafeArithmetic :: a -> Either ArithException a attemptUnsafeArithmetic = unsafePerformIO . Exc.try . evaluate {-# NOINLINE attemptUnsafeArithmetic #-} + +{-# ANN attemptUnsafeArithmetic ("HLint: ignore Avoid restricted function" :: String) #-} diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index a340a1038..a64676e78 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -23,6 +23,7 @@ import GHC.Types (Constraint) import GHC.TypeLits import qualified Proto3.Suite.DotProto as Proto import Data.Char (toLower) + -- Combinators -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. @@ -108,7 +109,9 @@ instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => liftDecodeMessage decodeMessage _ = oneof undefined listOfParsers where listOfParsers = - generate @Message1 @fs @fs (\ (_ :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) + generate @Message1 @fs @fs (\ (_ :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, trustMe <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) + trustMe (Just a) = a + trustMe Nothing = error "liftDecodeMessage (Sum): embedded parser returned Nothing" liftDotProto _ = [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @Named1 @fs @fs (\ (_ :: proxy f) i -> let diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index 9496463e8..084d77c0d 100644 --- a/src/Language/Go/Assignment.hs +++ b/src/Language/Go/Assignment.hs @@ -316,7 +316,7 @@ sliceType :: Assignment sliceType = makeTerm <$> symbol SliceType <*> children (Type.Slice <$> expression) structType :: Assignment -structType = makeTerm <$> symbol StructType <*> children (Declaration.Constructor <$> pure [] <*> emptyTerm <*> expressions) +structType = makeTerm <$> symbol StructType <*> children (Declaration.Constructor [] <$> emptyTerm <*> expressions) typeAlias :: Assignment typeAlias = makeTerm <$> symbol TypeAlias <*> children (Declaration.TypeAlias [] <$> expression <*> expression) @@ -367,7 +367,7 @@ defaultExpressionCase :: Assignment defaultExpressionCase = makeTerm <$> symbol DefaultCase <*> (Go.Syntax.DefaultPattern <$ rawSource <*> (expressions <|> emptyTerm)) callExpression :: Assignment -callExpression = makeTerm <$> symbol CallExpression <*> children (Expression.Call <$> pure [] <*> expression <*> manyTerm expression <*> emptyTerm) +callExpression = makeTerm <$> symbol CallExpression <*> children (Expression.Call [] <$> expression <*> manyTerm expression <*> emptyTerm) expressionCase :: Assignment expressionCase = makeTerm <$> symbol ExpressionCase <*> (Statement.Pattern <$> children expressions <*> expressions) @@ -403,7 +403,7 @@ importDeclaration = makeTerm'' <$> symbol ImportDeclaration <*> children (manyTe plainImport = inject <$> (symbol InterpretedStringLiteral >>= \loc -> do from <- importPath <$> source let alias = makeTerm loc (Syntax.Identifier (defaultAlias from)) -- Go takes `import "lib/Math"` and uses `Math` as the qualified name (e.g. `Math.Sin()`) - Go.Syntax.QualifiedImport <$> pure from <*> pure alias) + pure $! Go.Syntax.QualifiedImport from alias) dot = makeTerm <$> symbol Dot <*> (Literal.TextElement <$> source) underscore = makeTerm <$> symbol BlankIdentifier <*> (Literal.TextElement <$> source) @@ -487,13 +487,13 @@ varDeclaration :: Assignment varDeclaration = (symbol ConstDeclaration <|> symbol VarDeclaration) *> children expressions variadicArgument :: Assignment -variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic <$> pure [] <*> expression) +variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic [] <$> expression) variadicParameterDeclaration :: Assignment variadicParameterDeclaration = makeTerm <$> symbol VariadicParameterDeclaration <*> children (flip Go.Syntax.Variadic <$> (expression <|> emptyTerm) <* token AnonDotDotDot <*> many expression) varSpecification :: Assignment -varSpecification = makeTerm <$> (symbol ConstSpec <|> symbol VarSpec) <*> children (Statement.Assignment <$> pure [] <*> (annotatedLHS <|> identifiers) <*> expressions) +varSpecification = makeTerm <$> (symbol ConstSpec <|> symbol VarSpec) <*> children (Statement.Assignment [] <$> (annotatedLHS <|> identifiers) <*> expressions) where annotatedLHS = makeTerm <$> location <*> (Type.Annotation <$> (makeTerm <$> location <*> manyTermsTill identifier (void (symbol TypeIdentifier))) <*> expression) @@ -585,7 +585,7 @@ receiveStatement :: Assignment receiveStatement = makeTerm <$> symbol ReceiveStatement <*> children (Go.Syntax.Receive <$> (expression <|> emptyTerm) <*> expression) shortVarDeclaration :: Assignment -shortVarDeclaration = makeTerm <$> symbol ShortVarDeclaration <*> children (Statement.Assignment <$> pure [] <*> expression <*> expression) +shortVarDeclaration = makeTerm <$> symbol ShortVarDeclaration <*> children (Statement.Assignment [] <$> expression <*> expression) selectStatement :: Assignment selectStatement = makeTerm <$> symbol SelectStatement <*> children (Go.Syntax.Select <$> expressions) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index de0378bf3..b7ad86982 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -85,7 +85,7 @@ instance Evaluatable QualifiedImport where eval (QualifiedImport importPath aliasTerm) = do paths <- resolveGoImport importPath alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) - void $ letrec' alias $ \addr -> do + void . letrec' alias $ \addr -> do for_ paths $ \p -> do traceResolve (unPath importPath) p importedEnv <- maybe lowerBound snd <$> require p diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index b71965423..c11fb6149 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -369,14 +369,13 @@ functionBody :: Assignment functionBody = makeTerm <$> symbol FunctionBody <*> children (manyTerm expression) functionConstructor :: Assignment -functionConstructor = makeTerm <$> token FunctionConstructor <*> pure Syntax.FunctionConstructor +functionConstructor = makeTerm <$> token FunctionConstructor <*> pure Syntax.FunctionConstructor functionDeclaration :: Assignment functionDeclaration = makeTerm <$> symbol FunctionDeclaration - <*> children (Declaration.Function - <$> pure [] - <*> expression + <*> children (Declaration.Function [] + <$> expression <*> (manyTermsTill expression (symbol FunctionBody) <|> pure []) <*> functionBody) diff --git a/src/Language/Java/Assignment.hs b/src/Language/Java/Assignment.hs index 62683569e..203afc1c5 100644 --- a/src/Language/Java/Assignment.hs +++ b/src/Language/Java/Assignment.hs @@ -252,7 +252,7 @@ superInterfaces = symbol SuperInterfaces *> children (symbol InterfaceTypeList * class' :: Assignment class' = makeTerm <$> symbol ClassDeclaration <*> children (makeClass <$> many modifier <*> term identifier <*> (typeParameters <|> pure []) <*> optional superClass <*> (superInterfaces <|> pure []) <*> classBody) where - makeClass modifiers identifier typeParams superClass superInterfaces = Declaration.Class (modifiers ++ typeParams) identifier (maybeToList superClass ++ superInterfaces) -- not doing an assignment, just straight up function + makeClass modifiers identifier typeParams superClass superInterfaces = Declaration.Class (modifiers <> typeParams) identifier (maybeToList superClass <> superInterfaces) -- not doing an assignment, just straight up function classBody = makeTerm <$> symbol ClassBody <*> children (manyTerm expression) superClass = symbol Superclass *> children type' -- TODO: superclass @@ -269,7 +269,7 @@ method = makeTerm <$> symbol MethodDeclaration <*> children (makeMethod <$> many methodBody = symbol MethodBody *> children (term expression <|> emptyTerm) methodDeclarator = symbol MethodDeclarator *> children ( (,) <$> identifier <*> formalParameters) methodHeader = symbol MethodHeader *> children ((,,,,) <$> (typeParameters <|> pure []) <*> manyTerm annotation <*> type' <*> methodDeclarator <*> (throws <|> pure [])) - makeMethod modifiers receiver (typeParams, annotations, returnType, (name, params), throws) = Declaration.Method (returnType : modifiers ++ typeParams ++ annotations ++ throws) receiver name params + makeMethod modifiers receiver (typeParams, annotations, returnType, (name, params), throws) = Declaration.Method (returnType : modifiers <> typeParams <> annotations <> throws) receiver name params -- methodHeader needs to include typeParameters (it does) generic :: Assignment @@ -299,7 +299,7 @@ interface = makeTerm <$> symbol InterfaceDeclaration <*> children (normal <|> an where interfaceBody = makeTerm <$> symbol InterfaceBody <*> children (manyTerm interfaceMemberDeclaration) normal = symbol NormalInterfaceDeclaration *> children (makeInterface <$> manyTerm modifier <*> identifier <*> (typeParameters <|> pure []) <*> interfaceBody) - makeInterface modifiers identifier typeParams = Declaration.InterfaceDeclaration (modifiers ++ typeParams) identifier + makeInterface modifiers identifier typeParams = Declaration.InterfaceDeclaration (modifiers <> typeParams) identifier annotationType = symbol AnnotationTypeDeclaration *> children (Declaration.InterfaceDeclaration [] <$> identifier <*> annotationTypeBody) annotationTypeBody = makeTerm <$> symbol AnnotationTypeBody <*> children (many expression) interfaceMemberDeclaration = symbol InterfaceMemberDeclaration *> children (term expression) diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 1114e4278..85aebd336 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -420,8 +420,8 @@ methodDeclaration :: Assignment methodDeclaration = (makeTerm <$> symbol MethodDeclaration <*> children (makeMethod1 <$> manyTerm methodModifier <*> emptyTerm <*> functionDefinitionParts)) <|> makeTerm <$> symbol MethodDeclaration <*> children (makeMethod2 <$> someTerm methodModifier <*> emptyTerm <*> term name <*> parameters <*> term (returnType <|> emptyTerm) <*> emptyTerm) where functionDefinitionParts = symbol FunctionDefinition *> children ((,,,) <$> term name <*> parameters <*> term (returnType <|> emptyTerm) <*> (term compoundStatement <|> emptyTerm)) - makeMethod1 modifiers receiver (name, params, returnType, compoundStatement) = Declaration.Method (modifiers ++ [returnType]) receiver name params compoundStatement - makeMethod2 modifiers receiver name params returnType compoundStatement = Declaration.Method (modifiers ++ [returnType]) receiver name params compoundStatement + makeMethod1 modifiers receiver (name, params, returnType, compoundStatement) = Declaration.Method (modifiers <> [returnType]) receiver name params compoundStatement + makeMethod2 modifiers receiver name params returnType compoundStatement = Declaration.Method (modifiers <> [returnType]) receiver name params compoundStatement classBaseClause :: Assignment classBaseClause = makeTerm <$> symbol ClassBaseClause <*> children (Syntax.ClassBaseClause <$> term qualifiedName) @@ -505,7 +505,7 @@ selectionStatement :: Assignment selectionStatement = ifStatement <|> switchStatement ifStatement :: Assignment -ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term expression <*> (makeTerm <$> location <*> manyTerm statement) <*> (makeTerm <$> location <*> ((\as b -> as ++ [b]) <$> manyTerm elseIfClause <*> (term elseClause <|> emptyTerm)))) +ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term expression <*> (makeTerm <$> location <*> manyTerm statement) <*> (makeTerm <$> location <*> ((\as b -> as <> [b]) <$> manyTerm elseIfClause <*> (term elseClause <|> emptyTerm)))) switchStatement :: Assignment switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term expression <*> (makeTerm <$> location <*> manyTerm (caseStatement <|> defaultStatement))) @@ -575,7 +575,7 @@ throwStatement = makeTerm <$> symbol ThrowStatement <*> children (Statement.Thro tryStatement :: Assignment -tryStatement = makeTerm <$> symbol TryStatement <*> children (Statement.Try <$> term compoundStatement <*> (((\as b -> as ++ [b]) <$> someTerm catchClause <*> term finallyClause) <|> someTerm catchClause <|> someTerm finallyClause)) +tryStatement = makeTerm <$> symbol TryStatement <*> children (Statement.Try <$> term compoundStatement <*> (((\as b -> as <> [b]) <$> someTerm catchClause <*> term finallyClause) <|> someTerm catchClause <|> someTerm finallyClause)) catchClause :: Assignment catchClause = makeTerm <$> symbol CatchClause <*> children (Statement.Catch <$> (makeTerm <$> location <*> ((\a b -> [a, b]) <$> term qualifiedName <*> term variableName)) <*> term compoundStatement) @@ -766,10 +766,10 @@ string = makeTerm <$> (symbol Grammar.String <|> symbol Heredoc) <*> (Literal.Te -- Helpers append :: a -> [a] -> [a] -append x xs = xs ++ [x] +append x xs = xs <> [x] bookend :: a -> [a] -> a -> [a] -bookend head list last = head : append last list +bookend head_ list last_ = head_ : append last_ list term :: Assignment -> Assignment term term = contextualize (comment <|> textInterpolation) (postContextualize (comment <|> textInterpolation) term) diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index e90980b6b..62ee8b8da 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -271,12 +271,12 @@ parameter = postContextualize comment (term uncontextualizedParameter) optionalParameter = symbol OptionalParameter *> children (lhsIdent <* expression) method :: Assignment -method = makeTerm <$> symbol Method <*> (withNewScope . children) (Declaration.Method <$> pure [] <*> emptyTerm <*> methodSelector <*> params <*> expressions') +method = makeTerm <$> symbol Method <*> (withNewScope . children) (Declaration.Method [] <$> emptyTerm <*> methodSelector <*> params <*> expressions') where params = symbol MethodParameters *> children (many parameter) <|> pure [] expressions' = makeTerm <$> location <*> many expression singletonMethod :: Assignment -singletonMethod = makeTerm <$> symbol SingletonMethod <*> (withNewScope . children) (Declaration.Method <$> pure [] <*> expression <*> methodSelector <*> params <*> expressions) +singletonMethod = makeTerm <$> symbol SingletonMethod <*> (withNewScope . children) (Declaration.Method [] <$> expression <*> methodSelector <*> params <*> expressions) where params = symbol MethodParameters *> children (many parameter) <|> pure [] lambda :: Assignment @@ -289,18 +289,18 @@ block :: Assignment block = makeTerm <$> symbol DoBlock <*> scopedBlockChildren <|> makeTerm <$> symbol Block <*> scopedBlockChildren where scopedBlockChildren = withExtendedScope blockChildren - blockChildren = children (Declaration.Function <$> pure [] <*> emptyTerm <*> params <*> expressions) + blockChildren = children (Declaration.Function [] <$> emptyTerm <*> params <*> expressions) params = symbol BlockParameters *> children (many parameter) <|> pure [] comment :: Assignment comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) alias :: Assignment -alias = makeTerm <$> symbol Alias <*> children (Expression.Call <$> pure [] <*> name' <*> some expression <*> emptyTerm) +alias = makeTerm <$> symbol Alias <*> children (Expression.Call [] <$> name' <*> some expression <*> emptyTerm) where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) undef :: Assignment -undef = makeTerm <$> symbol Undef <*> children (Expression.Call <$> pure [] <*> name' <*> some expression <*> emptyTerm) +undef = makeTerm <$> symbol Undef <*> children (Expression.Call [] <$> name' <*> some expression <*> emptyTerm) where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) if' :: Assignment @@ -445,7 +445,7 @@ unary = symbol Unary >>= \ location -> makeTerm location . Expression.Complement <$> children ( symbol AnonTilde *> expression ) <|> makeTerm location . Expression.Not <$> children ( symbol AnonBang *> expression ) <|> makeTerm location . Expression.Not <$> children ( symbol AnonNot *> expression ) - <|> makeTerm location <$> children (Expression.Call <$> pure [] <*> (makeTerm <$> symbol AnonDefinedQuestion <*> (Syntax.Identifier . name <$> source)) <*> some expression <*> emptyTerm) + <|> makeTerm location <$> children (Expression.Call [] <$> (makeTerm <$> symbol AnonDefinedQuestion <*> (Syntax.Identifier . name <$> source)) <*> some expression <*> emptyTerm) <|> makeTerm location . Expression.Negate <$> children ( symbol AnonMinus' *> expression ) <|> children ( symbol AnonPlus *> expression ) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 79a13c9bc..7074b3202 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -291,7 +291,7 @@ null' :: Assignment null' = makeTerm <$> symbol Null <*> (Literal.Null <$ rawSource) anonymousClass :: Assignment -anonymousClass = makeTerm <$> symbol Grammar.AnonymousClass <*> children (Declaration.Class <$> pure [] <*> emptyTerm <*> (classHeritage' <|> pure []) <*> classBodyStatements) +anonymousClass = makeTerm <$> symbol Grammar.AnonymousClass <*> children (Declaration.Class [] <$> emptyTerm <*> (classHeritage' <|> pure []) <*> classBodyStatements) abstractClass :: Assignment abstractClass = makeTerm <$> symbol Grammar.AbstractClass <*> children (TypeScript.Syntax.AbstractClass <$> term identifier <*> (term typeParameters <|> emptyTerm) <*> (classHeritage' <|> pure []) <*> classBodyStatements) @@ -350,7 +350,7 @@ identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax class' :: Assignment class' = makeClass <$> symbol Class <*> children ((,,,,) <$> manyTerm decorator <*> term identifier <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) <*> (classHeritage' <|> pure []) <*> classBodyStatements) - where makeClass loc (decorators, expression, typeParams, classHeritage, statements) = makeTerm loc (Declaration.Class (decorators ++ typeParams) expression classHeritage statements) + where makeClass loc (decorators, expression, typeParams, classHeritage, statements) = makeTerm loc (Declaration.Class (decorators <> typeParams) expression classHeritage statements) object :: Assignment object = makeTerm <$> (symbol Object <|> symbol ObjectPattern) <*> children (Literal.Hash <$> manyTerm (pair <|> spreadElement <|> methodDefinition <|> assignmentPattern <|> shorthandPropertyIdentifier)) @@ -460,13 +460,13 @@ methodSignature = makeMethodSignature <$> symbol Grammar.MethodSignature <*> chi where makeMethodSignature loc (modifier, readonly, propertyName, (typeParams, params, annotation)) = makeTerm loc (Declaration.MethodSignature [modifier, readonly, typeParams, annotation] propertyName params) formalParameters :: Assignment.Assignment [] Grammar [Term] -formalParameters = symbol FormalParameters *> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as ++ [b]) <$> manyTerm decorator <*> term parameter)) <*> many comment)) +formalParameters = symbol FormalParameters *> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term parameter)) <*> many comment)) where contextualize' (cs, formalParams) = case nonEmpty cs of - Just cs -> toList cs ++ formalParams + Just cs -> toList cs <> formalParams Nothing -> formalParams postContextualize' formalParams cs = case nonEmpty cs of - Just cs -> formalParams ++ toList cs + Just cs -> formalParams <> toList cs Nothing -> formalParams @@ -573,13 +573,13 @@ statementBlock :: Assignment statementBlock = makeTerm <$> symbol StatementBlock <*> children (manyTerm statement) classBodyStatements :: Assignment -classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as ++ [b]) <$> manyTerm decorator <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature <|> abstractMethodSignature))) <*> many comment)) +classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature <|> abstractMethodSignature))) <*> many comment)) where contextualize' (cs, formalParams) = case nonEmpty cs of - Just cs -> toList cs ++ formalParams + Just cs -> toList cs <> formalParams Nothing -> formalParams postContextualize' formalParams cs = case nonEmpty cs of - Just cs -> formalParams ++ toList cs + Just cs -> formalParams <> toList cs Nothing -> formalParams publicFieldDefinition :: Assignment diff --git a/test/Lint.hs b/test/Lint.hs index 78bbb30b9..7c9bf7b25 100644 --- a/test/Lint.hs +++ b/test/Lint.hs @@ -1,9 +1,9 @@ module Main (main) where -import Language.Haskell.HLint (hlint) +import Language.Haskell.HLint (Severity(..), hlint, suggestionSeverity) import System.Exit (exitFailure, exitSuccess) main :: IO () main = do - hints <- hlint [ "--language=TypeApplications", "src" ] - if null hints then exitSuccess else exitFailure + hints <- hlint [ "src" ] + if null (filter ((>= Warning) . suggestionSeverity) hints) then exitSuccess else exitFailure diff --git a/vendor/grpc-haskell b/vendor/grpc-haskell index d5fc83214..0a84f9ec3 160000 --- a/vendor/grpc-haskell +++ b/vendor/grpc-haskell @@ -1 +1 @@ -Subproject commit d5fc83214eefa669dddd01f3be37250db7c94153 +Subproject commit 0a84f9ec3a5532183538726c86608c56dfe2c1db diff --git a/vendor/proto3-suite b/vendor/proto3-suite deleted file mode 160000 index c75b250e8..000000000 --- a/vendor/proto3-suite +++ /dev/null @@ -1 +0,0 @@ -Subproject commit c75b250e82481e23d2ff586b3e841834b5d93ff9 diff --git a/vendor/proto3-wire b/vendor/proto3-wire deleted file mode 160000 index c8792bc33..000000000 --- a/vendor/proto3-wire +++ /dev/null @@ -1 +0,0 @@ -Subproject commit c8792bc33154e849239b1c91ffe06af2e765d734