mirror of
https://github.com/jfmengels/elm-review.git
synced 2024-12-01 15:53:00 +03:00
674 lines
24 KiB
Elm
674 lines
24 KiB
Elm
module Simplify.Normalize exposing (Comparison(..), areAllTheSame, compare, compareWithoutNormalization, getNumberValue, normalize)
|
|
|
|
import Dict
|
|
import Elm.Syntax.Expression as Expression exposing (Expression)
|
|
import Elm.Syntax.Infix as Infix
|
|
import Elm.Syntax.Node as Node exposing (Node(..))
|
|
import Elm.Syntax.Pattern as Pattern exposing (Pattern)
|
|
import Elm.Syntax.Range as Range
|
|
import Elm.Writer
|
|
import Review.ModuleNameLookupTable as ModuleNameLookupTable exposing (ModuleNameLookupTable)
|
|
import Simplify.Infer as Infer
|
|
|
|
|
|
areAllTheSame : Infer.Resources a -> Node Expression -> List (Node Expression) -> Bool
|
|
areAllTheSame resources first rest =
|
|
let
|
|
normalizedFirst : Node Expression
|
|
normalizedFirst =
|
|
normalize resources first
|
|
in
|
|
List.all (\node -> normalize resources node == normalizedFirst) rest
|
|
|
|
|
|
normalize : Infer.Resources a -> Node Expression -> Node Expression
|
|
normalize resources node =
|
|
case Node.value node of
|
|
Expression.ParenthesizedExpression expr ->
|
|
normalize resources expr
|
|
|
|
Expression.Application nodes ->
|
|
case nodes of
|
|
fn :: arg1 :: restOrArgs ->
|
|
let
|
|
normalizedArg1 : Node Expression
|
|
normalizedArg1 =
|
|
normalize resources arg1
|
|
in
|
|
case normalize resources fn of
|
|
Node _ (Expression.RecordAccessFunction fieldAccess) ->
|
|
let
|
|
recordAccess : Node Expression
|
|
recordAccess =
|
|
Expression.RecordAccess normalizedArg1 (toNode (String.dropLeft 1 fieldAccess))
|
|
|> toNode
|
|
in
|
|
if List.isEmpty restOrArgs then
|
|
recordAccess
|
|
|
|
else
|
|
(recordAccess :: List.map (normalize resources) restOrArgs)
|
|
|> Expression.Application
|
|
|> toNode
|
|
|
|
normalizedFn ->
|
|
(normalizedFn :: normalizedArg1 :: List.map (normalize resources) restOrArgs)
|
|
|> Expression.Application
|
|
|> toNode
|
|
|
|
_ ->
|
|
node
|
|
|
|
Expression.OperatorApplication "<|" _ function extraArgument ->
|
|
addToFunctionCall
|
|
(normalize resources function)
|
|
(normalize resources extraArgument)
|
|
|
|
Expression.OperatorApplication "|>" _ extraArgument function ->
|
|
addToFunctionCall
|
|
(normalize resources function)
|
|
(normalize resources extraArgument)
|
|
|
|
Expression.OperatorApplication "<<" _ left right ->
|
|
toNode (Expression.OperatorApplication ">>" Infix.Right (normalize resources right) (normalize resources left))
|
|
|
|
Expression.OperatorApplication "::" infixDirection element list ->
|
|
let
|
|
normalizedElement : Node Expression
|
|
normalizedElement =
|
|
normalize resources element
|
|
|
|
normalizedList : Node Expression
|
|
normalizedList =
|
|
normalize resources list
|
|
in
|
|
case Node.value normalizedList of
|
|
Expression.ListExpr elements ->
|
|
toNode (Expression.ListExpr (normalizedElement :: elements))
|
|
|
|
_ ->
|
|
toNode (Expression.OperatorApplication "::" infixDirection normalizedElement normalizedList)
|
|
|
|
Expression.OperatorApplication ">" infixDirection left right ->
|
|
toNode (Expression.OperatorApplication "<" infixDirection (normalize resources right) (normalize resources left))
|
|
|
|
Expression.OperatorApplication ">=" infixDirection left right ->
|
|
toNode (Expression.OperatorApplication "<=" infixDirection (normalize resources right) (normalize resources left))
|
|
|
|
Expression.OperatorApplication operator infixDirection l r ->
|
|
let
|
|
left : Node Expression
|
|
left =
|
|
normalize resources l
|
|
|
|
right : Node Expression
|
|
right =
|
|
normalize resources r
|
|
in
|
|
if List.member operator [ "+", "*", "||", "&&", "==", "/=" ] && toComparable left > toComparable right then
|
|
toNode (Expression.OperatorApplication operator infixDirection right left)
|
|
|
|
else
|
|
toNode (Expression.OperatorApplication operator infixDirection left right)
|
|
|
|
Expression.FunctionOrValue rawModuleName string ->
|
|
Expression.FunctionOrValue
|
|
(ModuleNameLookupTable.moduleNameFor resources.lookupTable node
|
|
|> Maybe.withDefault rawModuleName
|
|
)
|
|
string
|
|
|> toNodeAndInfer resources
|
|
|
|
Expression.IfBlock cond then_ else_ ->
|
|
let
|
|
reverseIfConditionIsNegated : Node Expression -> Node Expression -> Node Expression -> Node Expression
|
|
reverseIfConditionIsNegated condArg thenArg elseArg =
|
|
case Node.value condArg of
|
|
Expression.Application [ Node _ (Expression.FunctionOrValue [ "Basics" ] "not"), negatedCondition ] ->
|
|
reverseIfConditionIsNegated negatedCondition elseArg thenArg
|
|
|
|
_ ->
|
|
toNode (Expression.IfBlock condArg thenArg elseArg)
|
|
in
|
|
reverseIfConditionIsNegated
|
|
(normalize resources cond)
|
|
(normalize resources then_)
|
|
(normalize resources else_)
|
|
|
|
Expression.Negation expr ->
|
|
let
|
|
normalized : Node Expression
|
|
normalized =
|
|
normalize resources expr
|
|
in
|
|
case Node.value normalized of
|
|
Expression.Integer int ->
|
|
toNode (Expression.Integer -int)
|
|
|
|
Expression.Floatable float ->
|
|
toNode (Expression.Floatable -float)
|
|
|
|
_ ->
|
|
toNode (Expression.Negation normalized)
|
|
|
|
Expression.TupledExpression nodes ->
|
|
toNode (Expression.TupledExpression (List.map (normalize resources) nodes))
|
|
|
|
Expression.LetExpression letBlock ->
|
|
toNode
|
|
(Expression.LetExpression
|
|
{ declarations =
|
|
List.map
|
|
(\decl ->
|
|
case Node.value decl of
|
|
Expression.LetFunction function ->
|
|
let
|
|
declaration : Expression.FunctionImplementation
|
|
declaration =
|
|
Node.value function.declaration
|
|
in
|
|
toNode
|
|
(Expression.LetFunction
|
|
{ documentation = Nothing
|
|
, signature = Nothing
|
|
, declaration =
|
|
toNode
|
|
{ name = toNode (Node.value declaration.name)
|
|
, arguments = List.map (normalizePattern resources.lookupTable) declaration.arguments
|
|
, expression = normalize resources declaration.expression
|
|
}
|
|
}
|
|
)
|
|
|
|
Expression.LetDestructuring pattern expr ->
|
|
toNode (Expression.LetDestructuring (normalizePattern resources.lookupTable pattern) (normalize resources expr))
|
|
)
|
|
letBlock.declarations
|
|
, expression = normalize resources letBlock.expression
|
|
}
|
|
)
|
|
|
|
Expression.CaseExpression caseBlock ->
|
|
toNode
|
|
(Expression.CaseExpression
|
|
{ cases = List.map (\( pattern, expr ) -> ( normalizePattern resources.lookupTable pattern, normalize resources expr )) caseBlock.cases
|
|
, expression = normalize resources caseBlock.expression
|
|
}
|
|
)
|
|
|
|
Expression.LambdaExpression lambda ->
|
|
toNode
|
|
(Expression.LambdaExpression
|
|
{ args = List.map (normalizePattern resources.lookupTable) lambda.args
|
|
, expression = normalize resources lambda.expression
|
|
}
|
|
)
|
|
|
|
Expression.ListExpr nodes ->
|
|
toNode (Expression.ListExpr (List.map (normalize resources) nodes))
|
|
|
|
Expression.RecordAccess expr (Node _ field) ->
|
|
toNode (Expression.RecordAccess (normalize resources expr) (toNode field))
|
|
|
|
Expression.RecordExpr nodes ->
|
|
nodes
|
|
|> List.sortBy (\(Node _ ( Node _ fieldName, _ )) -> fieldName)
|
|
|> List.map (\(Node _ ( Node _ fieldName, expr )) -> toNode ( toNode fieldName, normalize resources expr ))
|
|
|> Expression.RecordExpr
|
|
|> toNode
|
|
|
|
Expression.RecordUpdateExpression (Node _ value) nodes ->
|
|
nodes
|
|
|> List.sortBy (\(Node _ ( Node _ fieldName, _ )) -> fieldName)
|
|
|> List.map (\(Node _ ( Node _ fieldName, expr )) -> toNode ( toNode fieldName, normalize resources expr ))
|
|
|> Expression.RecordUpdateExpression (toNode value)
|
|
|> toNode
|
|
|
|
Expression.Hex int ->
|
|
Expression.Integer int
|
|
|> toNode
|
|
|
|
expr ->
|
|
toNode expr
|
|
|
|
|
|
toNodeAndInfer : Infer.Resources a -> Expression -> Node Expression
|
|
toNodeAndInfer resources element =
|
|
case Infer.get element (Tuple.first resources.inferredConstants) of
|
|
Just value ->
|
|
toNode value
|
|
|
|
Nothing ->
|
|
toNode element
|
|
|
|
|
|
toComparable : Node Expression -> String
|
|
toComparable a =
|
|
Elm.Writer.write (Elm.Writer.writeExpression a)
|
|
|
|
|
|
addToFunctionCall : Node Expression -> Node Expression -> Node Expression
|
|
addToFunctionCall functionCall extraArgument =
|
|
case Node.value functionCall of
|
|
Expression.ParenthesizedExpression expr ->
|
|
addToFunctionCall expr extraArgument
|
|
|
|
Expression.Application (fnCall :: args) ->
|
|
Expression.Application (fnCall :: (args ++ [ extraArgument ]))
|
|
|> toNode
|
|
|
|
Expression.LetExpression { declarations, expression } ->
|
|
Expression.LetExpression { declarations = declarations, expression = addToFunctionCall expression extraArgument }
|
|
|> toNode
|
|
|
|
Expression.IfBlock condition ifBranch elseBranch ->
|
|
Expression.IfBlock condition (addToFunctionCall ifBranch extraArgument) (addToFunctionCall elseBranch extraArgument)
|
|
|> toNode
|
|
|
|
Expression.CaseExpression { expression, cases } ->
|
|
Expression.CaseExpression { expression = expression, cases = List.map (\( cond, expr ) -> ( cond, addToFunctionCall expr extraArgument )) cases }
|
|
|> toNode
|
|
|
|
Expression.RecordAccessFunction fieldAccess ->
|
|
Expression.RecordAccess extraArgument (toNode (String.dropLeft 1 fieldAccess))
|
|
|> toNode
|
|
|
|
_ ->
|
|
Expression.Application [ functionCall, extraArgument ]
|
|
|> toNode
|
|
|
|
|
|
normalizePattern : ModuleNameLookupTable -> Node Pattern -> Node Pattern
|
|
normalizePattern lookupTable node =
|
|
case Node.value node of
|
|
Pattern.TuplePattern patterns ->
|
|
toNode (Pattern.TuplePattern (List.map (normalizePattern lookupTable) patterns))
|
|
|
|
Pattern.RecordPattern fields ->
|
|
toNode
|
|
(Pattern.RecordPattern
|
|
(fields
|
|
|> List.sortBy (\(Node _ fieldName) -> fieldName)
|
|
|> List.map (\(Node _ field) -> toNode field)
|
|
)
|
|
)
|
|
|
|
Pattern.UnConsPattern element list ->
|
|
case normalizePattern lookupTable list of
|
|
Node _ (Pattern.ListPattern elements) ->
|
|
toNode (Pattern.ListPattern (normalizePattern lookupTable element :: elements))
|
|
|
|
normalizedList ->
|
|
toNode (Pattern.UnConsPattern (normalizePattern lookupTable element) normalizedList)
|
|
|
|
Pattern.ListPattern patterns ->
|
|
toNode (Pattern.ListPattern (List.map (normalizePattern lookupTable) patterns))
|
|
|
|
Pattern.NamedPattern qualifiedNameRef patterns ->
|
|
let
|
|
nameRef : Pattern.QualifiedNameRef
|
|
nameRef =
|
|
{ moduleName =
|
|
ModuleNameLookupTable.moduleNameFor lookupTable node
|
|
|> Maybe.withDefault qualifiedNameRef.moduleName
|
|
, name = qualifiedNameRef.name
|
|
}
|
|
in
|
|
toNode (Pattern.NamedPattern nameRef (List.map (normalizePattern lookupTable) patterns))
|
|
|
|
Pattern.AsPattern pattern (Node _ asName) ->
|
|
toNode (Pattern.AsPattern (normalizePattern lookupTable pattern) (toNode asName))
|
|
|
|
Pattern.ParenthesizedPattern pattern ->
|
|
normalizePattern lookupTable pattern
|
|
|
|
Pattern.HexPattern int ->
|
|
toNode (Pattern.IntPattern int)
|
|
|
|
pattern ->
|
|
toNode pattern
|
|
|
|
|
|
toNode : a -> Node a
|
|
toNode =
|
|
Node Range.emptyRange
|
|
|
|
|
|
|
|
-- COMPARE
|
|
|
|
|
|
type Comparison
|
|
= ConfirmedEquality
|
|
| ConfirmedInequality
|
|
| Unconfirmed
|
|
|
|
|
|
compare : Infer.Resources a -> Node Expression -> Node Expression -> Comparison
|
|
compare resources leftNode right =
|
|
compareHelp
|
|
(normalize resources leftNode)
|
|
(normalize resources right)
|
|
True
|
|
|
|
|
|
compareWithoutNormalization : Node Expression -> Node Expression -> Comparison
|
|
compareWithoutNormalization leftNode right =
|
|
compareHelp leftNode right True
|
|
|
|
|
|
compareHelp : Node Expression -> Node Expression -> Bool -> Comparison
|
|
compareHelp leftNode right canFlip =
|
|
let
|
|
fallback : () -> Comparison
|
|
fallback () =
|
|
if canFlip then
|
|
compareHelp right leftNode False
|
|
|
|
else if leftNode == right then
|
|
ConfirmedEquality
|
|
|
|
else
|
|
Unconfirmed
|
|
in
|
|
case Node.value leftNode of
|
|
Expression.Integer left ->
|
|
compareNumbers (Basics.toFloat left) right
|
|
|
|
Expression.Floatable left ->
|
|
compareNumbers left right
|
|
|
|
Expression.OperatorApplication leftOp _ leftLeft leftRight ->
|
|
if List.member leftOp [ "+", "-", "*", "/" ] then
|
|
case getNumberValue leftNode of
|
|
Just leftValue ->
|
|
case getNumberValue right of
|
|
Just rightValue ->
|
|
fromEquality (leftValue == rightValue)
|
|
|
|
Nothing ->
|
|
fallback ()
|
|
|
|
Nothing ->
|
|
fallback ()
|
|
|
|
else
|
|
case Node.value (removeParens right) of
|
|
Expression.OperatorApplication rightOp _ rightLeft rightRight ->
|
|
if leftOp == rightOp then
|
|
compareEqualityOfAll
|
|
[ leftLeft, leftRight ]
|
|
[ rightLeft, rightRight ]
|
|
|
|
else
|
|
fallback ()
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.Literal left ->
|
|
case Node.value (removeParens right) of
|
|
Expression.Literal rightValue ->
|
|
fromEquality (left == rightValue)
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.CharLiteral left ->
|
|
case Node.value (removeParens right) of
|
|
Expression.CharLiteral rightValue ->
|
|
fromEquality (left == rightValue)
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.FunctionOrValue moduleNameLeft leftName ->
|
|
case Node.value right of
|
|
Expression.FunctionOrValue moduleNameRight rightName ->
|
|
if leftName == rightName && moduleNameRight == moduleNameLeft then
|
|
ConfirmedEquality
|
|
|
|
else
|
|
fallback ()
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.ListExpr leftList ->
|
|
case Node.value (removeParens right) of
|
|
Expression.ListExpr rightList ->
|
|
if List.length leftList /= List.length rightList then
|
|
ConfirmedInequality
|
|
|
|
else
|
|
compareLists leftList rightList ConfirmedEquality
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.TupledExpression leftList ->
|
|
case Node.value (removeParens right) of
|
|
Expression.TupledExpression rightList ->
|
|
compareLists leftList rightList ConfirmedEquality
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.RecordExpr leftList ->
|
|
case Node.value (removeParens right) of
|
|
Expression.RecordExpr rightList ->
|
|
compareRecords leftList rightList ConfirmedEquality
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.RecordUpdateExpression leftBaseValue leftList ->
|
|
case Node.value (removeParens right) of
|
|
Expression.RecordUpdateExpression rightBaseValue rightList ->
|
|
if Node.value leftBaseValue == Node.value rightBaseValue then
|
|
compareRecords leftList rightList ConfirmedEquality
|
|
|
|
else
|
|
compareRecords leftList rightList Unconfirmed
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.Application leftArgs ->
|
|
case Node.value (removeParens right) of
|
|
Expression.Application rightArgs ->
|
|
compareEqualityOfAll leftArgs rightArgs
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.RecordAccess leftExpr leftName ->
|
|
case Node.value (removeParens right) of
|
|
Expression.RecordAccess rightExpr rightName ->
|
|
if Node.value leftName == Node.value rightName then
|
|
compareHelp leftExpr rightExpr canFlip
|
|
|
|
else
|
|
Unconfirmed
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
Expression.UnitExpr ->
|
|
ConfirmedEquality
|
|
|
|
Expression.IfBlock leftCond leftThen leftElse ->
|
|
case Node.value (removeParens right) of
|
|
Expression.IfBlock rightCond rightThen rightElse ->
|
|
compareEqualityOfAll
|
|
[ leftCond, leftThen, leftElse ]
|
|
[ rightCond, rightThen, rightElse ]
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
_ ->
|
|
fallback ()
|
|
|
|
|
|
compareNumbers : Float -> Node Expression -> Comparison
|
|
compareNumbers leftValue right =
|
|
case getNumberValue right of
|
|
Just rightValue ->
|
|
fromEquality (leftValue == rightValue)
|
|
|
|
Nothing ->
|
|
Unconfirmed
|
|
|
|
|
|
getNumberValue : Node Expression -> Maybe Float
|
|
getNumberValue node =
|
|
case Node.value node of
|
|
Expression.Integer value ->
|
|
Just (Basics.toFloat value)
|
|
|
|
Expression.Hex int ->
|
|
Just (Basics.toFloat int)
|
|
|
|
Expression.Floatable float ->
|
|
Just float
|
|
|
|
Expression.ParenthesizedExpression expr ->
|
|
getNumberValue expr
|
|
|
|
Expression.LetExpression { expression } ->
|
|
getNumberValue expression
|
|
|
|
Expression.OperatorApplication "+" _ left right ->
|
|
Maybe.map2 (+)
|
|
(getNumberValue left)
|
|
(getNumberValue right)
|
|
|
|
Expression.OperatorApplication "-" _ left right ->
|
|
Maybe.map2 (-)
|
|
(getNumberValue left)
|
|
(getNumberValue right)
|
|
|
|
Expression.OperatorApplication "*" _ left right ->
|
|
Maybe.map2 (*)
|
|
(getNumberValue left)
|
|
(getNumberValue right)
|
|
|
|
Expression.OperatorApplication "/" _ left right ->
|
|
Maybe.map2 (/)
|
|
(getNumberValue left)
|
|
(getNumberValue right)
|
|
|
|
Expression.Negation expr ->
|
|
getNumberValue expr
|
|
|> Maybe.map negate
|
|
|
|
_ ->
|
|
Nothing
|
|
|
|
|
|
compareLists : List (Node Expression) -> List (Node Expression) -> Comparison -> Comparison
|
|
compareLists leftList rightList acc =
|
|
case ( leftList, rightList ) of
|
|
( left :: restOfLeft, right :: restOfRight ) ->
|
|
case compareWithoutNormalization left right of
|
|
ConfirmedEquality ->
|
|
compareLists restOfLeft restOfRight acc
|
|
|
|
ConfirmedInequality ->
|
|
ConfirmedInequality
|
|
|
|
Unconfirmed ->
|
|
compareLists restOfLeft restOfRight Unconfirmed
|
|
|
|
_ ->
|
|
acc
|
|
|
|
|
|
compareEqualityOfAll : List (Node Expression) -> List (Node Expression) -> Comparison
|
|
compareEqualityOfAll leftList rightList =
|
|
case ( leftList, rightList ) of
|
|
( left :: restOfLeft, right :: restOfRight ) ->
|
|
case compareHelp left right True of
|
|
ConfirmedEquality ->
|
|
compareEqualityOfAll restOfLeft restOfRight
|
|
|
|
ConfirmedInequality ->
|
|
Unconfirmed
|
|
|
|
Unconfirmed ->
|
|
Unconfirmed
|
|
|
|
_ ->
|
|
ConfirmedEquality
|
|
|
|
|
|
type RecordFieldComparison
|
|
= MissingOtherValue
|
|
| HasBothValues (Node Expression) (Node Expression)
|
|
|
|
|
|
compareRecords : List (Node Expression.RecordSetter) -> List (Node Expression.RecordSetter) -> Comparison -> Comparison
|
|
compareRecords leftList rightList acc =
|
|
let
|
|
leftFields : List ( String, Node Expression )
|
|
leftFields =
|
|
List.map (Node.value >> Tuple.mapFirst Node.value) leftList
|
|
|
|
rightFields : List ( String, Node Expression )
|
|
rightFields =
|
|
List.map (Node.value >> Tuple.mapFirst Node.value) rightList
|
|
|
|
recordFieldComparisons : List RecordFieldComparison
|
|
recordFieldComparisons =
|
|
Dict.merge
|
|
(\key _ -> Dict.insert key MissingOtherValue)
|
|
(\key a b -> Dict.insert key (HasBothValues a b))
|
|
(\key _ -> Dict.insert key MissingOtherValue)
|
|
(Dict.fromList leftFields)
|
|
(Dict.fromList rightFields)
|
|
Dict.empty
|
|
|> Dict.values
|
|
in
|
|
compareRecordFields recordFieldComparisons acc
|
|
|
|
|
|
compareRecordFields : List RecordFieldComparison -> Comparison -> Comparison
|
|
compareRecordFields recordFieldComparisons acc =
|
|
case recordFieldComparisons of
|
|
[] ->
|
|
acc
|
|
|
|
MissingOtherValue :: rest ->
|
|
compareRecordFields rest Unconfirmed
|
|
|
|
(HasBothValues a b) :: rest ->
|
|
case compareHelp a b True of
|
|
ConfirmedInequality ->
|
|
ConfirmedInequality
|
|
|
|
ConfirmedEquality ->
|
|
compareRecordFields rest acc
|
|
|
|
Unconfirmed ->
|
|
compareRecordFields rest Unconfirmed
|
|
|
|
|
|
fromEquality : Bool -> Comparison
|
|
fromEquality bool =
|
|
if bool then
|
|
ConfirmedEquality
|
|
|
|
else
|
|
ConfirmedInequality
|
|
|
|
|
|
removeParens : Node Expression -> Node Expression
|
|
removeParens node =
|
|
case Node.value node of
|
|
Expression.ParenthesizedExpression expr ->
|
|
removeParens expr
|
|
|
|
_ ->
|
|
node
|