elm-review/tests/Simplify/Normalize.elm
2022-09-01 16:22:25 +02:00

670 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.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 "::" 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