diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for reorder-expression + +## 0.1.0.0 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2021 comp + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +# reorder-expression + +[![License MIT](https://img.shields.io/badge/license-MIT-blue.svg)](./LICENSE) +[![Hackage](https://img.shields.io/hackage/v/reorder-expression.svg)](https://hackage.haskell.org/package/reorder-expression) + +A library for reordering expressions in a syntax tree generically according to operator associativity and precedence. This is useful for languages with custom operators which require reordering expressions after collecting their fixities. + +Supports: + +- Any syntax tree data type, e.g. source position-annotated ones. +- Postfix, prefix, and infix operators, with any arity. +- Left, right, and non-associative operators and precedence with doubles. + +See documentation for an example. diff --git a/reorder-expression.cabal b/reorder-expression.cabal new file mode 100644 --- /dev/null +++ b/reorder-expression.cabal @@ -0,0 +1,75 @@ +cabal-version: 2.4 +name: reorder-expression +version: 0.1.0.0 +synopsis: Reorder expressions in a syntax tree according to operator fixities. +description: + A library for reordering expressions in a syntax tree generically according to operator associativity and precedence. + This is useful for languages with custom operators which require reordering expressions after collecting their fixities. +homepage: https://github.com/1Computer1/reorder-expression +bug-reports: https://github.com/1Computer1/reorder-expression/issues +license: MIT +license-file: LICENSE +author: comp +maintainer: onecomputer00@gmail.com +category: Language + +tested-with: + GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.4 + , GHC == 9.0.1 + +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: git@github.com:1Computer1/reorder-expression.git + +common common-options + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -Wpartial-fields + + build-depends: + base >= 4.12 && < 4.17 + + default-language: Haskell2010 + +library + import: common-options + hs-source-dirs: src + build-depends: + + exposed-modules: + Expression.Reorder + +test-suite reorder-expression-test + import: common-options + hs-source-dirs: test + main-is: Main.hs + type: exitcode-stdio-1.0 + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + + build-depends: + reorder-expression + , hspec >= 2.7 && < 3 + , parsec >= 3.1 && < 3.2 + , optics >= 0.4 && < 0.5 + + build-tool-depends: + hspec-discover:hspec-discover >= 2.7 && < 3 + + other-modules: + Test.Expr + Test.Parser + Expression.ReorderSpec diff --git a/src/Expression/Reorder.hs b/src/Expression/Reorder.hs new file mode 100644 --- /dev/null +++ b/src/Expression/Reorder.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Expression.Reorder +Copyright : (c) 2021 comp +License : MIT +Maintainer : onecomputer00@gmail.com +Stability : stable +Portability : portable + +Reorders expressions in a syntax tree so that prefix, postfix, and infix operator chains are correct according to their +associativity and precedence. + +Get started by creating a 'SyntaxTree' instance for your syntax types. +-} +module Expression.Reorder + ( -- * Syntax tree reordering + SyntaxTree(..) + , reorder + , Node(..) + , Validation(..) + -- * Operator properties + , Fixity(..) + , Assoc(..) + , Precedence + , Ambiguity(..) + -- * Example usage + -- $example + ) where + +import Data.Bifunctor +import Data.List.NonEmpty (NonEmpty) +import GHC.Generics (Generic) + +{- | Typeclass for syntax trees @t@ with ambiguity errors @e@. + +The reason for the error type is because there may be different types of expressions, e.g. value expressions and pattern +matching patterns, so there is no way to return the offending expression without combining the types first. +-} +class SyntaxTree t e | t -> e where + {- | Applies 'reorder' to all children of this node that may have expressions to reorder. + + This is usually in the form of a traversal over the children, which will aggregate errors via 'Validation'. + -} + reorderChildren :: t -> Validation (NonEmpty e) t + + {- | Gets the structure of a node. -} + structureOf :: t -> Node t + + {- | Builds an error for the ambiguous expression given. -} + makeError :: Ambiguity -> t -> e + +{- | Reorders a syntax tree to have correct precedence and associativity. + +Returns either the reordered tree or a list of ambiguous expression errors. +-} +reorder :: forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t +reorder = reorderChildren `thenValidate` goReorder + where + goReorder :: t -> Validation (NonEmpty e) t + goReorder expr = case structureOf expr of + NodeLeaf -> pure expr + NodePrefix p1 inner op1 -> case structureOf inner of + NodeInfix f2 pivot x op2 -> + goOpenRight expr (Fixity AssocLeft p1) f2 op1 (`op2` x) pivot + NodePostfix p2 pivot op2 -> + goOpenRight expr (Fixity AssocLeft p1) (Fixity AssocRight p2) op1 op2 pivot + _closedLeft -> pure expr + NodePostfix p1 inner op1 -> case structureOf inner of + NodeInfix f2 x pivot op2 -> + goOpenLeft expr (Fixity AssocRight p1) f2 op1 (x `op2`) pivot + NodePrefix p2 pivot op2 -> + goOpenLeft expr (Fixity AssocRight p1) (Fixity AssocLeft p2) op1 op2 pivot + _closedRight -> pure expr + NodeInfix f1 lhs rhs op1 -> case (structureOf lhs, structureOf rhs) of + -- Where both sides are open. + (NodeInfix f2 x pivotx op2, NodeInfix f3 pivoty y op3) -> + goOpenBoth expr f1 f2 f3 op1 lhs rhs (x `op2`) (`op3` y) pivotx pivoty + (NodeInfix f2 x pivotx op2, NodePostfix p3 pivoty op3) -> + goOpenBoth expr f1 f2 (Fixity AssocRight p3) op1 lhs rhs (x `op2`) op3 pivotx pivoty + (NodePrefix p2 pivotx op2, NodeInfix f3 pivoty y op3) -> + goOpenBoth expr f1 (Fixity AssocLeft p2) f3 op1 lhs rhs op2 (`op3` y) pivotx pivoty + (NodePrefix p2 pivotx op2, NodePostfix p3 pivoty op3) -> + goOpenBoth expr f1 (Fixity AssocLeft p2) (Fixity AssocRight p3) op1 lhs rhs op2 op3 pivotx pivoty + -- Where only the left side is open. + (NodeInfix f2 x pivot op2, _rightIsClosed) -> + goOpenLeft expr f1 f2 (`op1` rhs) (x `op2`) pivot + (NodePrefix p2 pivot op2, _rightIsClosed) -> + goOpenLeft expr f1 (Fixity AssocLeft p2) (`op1` rhs) op2 pivot + -- Where only the right side is open. + (_leftIsClosed, NodeInfix f3 pivot y op3) -> + goOpenRight expr f1 f3 (lhs `op1`) (`op3` y) pivot + (_leftIsClosed, NodePostfix p3 pivot op3) -> + goOpenRight expr f1 (Fixity AssocRight p3) (lhs `op1`) op3 pivot + -- Both sides are closed. + (_leftIsClosed, _rightIsClosed) -> pure expr + + goOpenBoth + :: t -- ^ Original expression + -> Fixity -- ^ Fixity of root node + -> Fixity -- ^ Fixity of LHS + -> Fixity -- ^ Fixity of RHS + -> (t -> t -> t) -- ^ Rebuild root node + -> t -- ^ LHS + -> t -- ^ RHS + -> (t -> t) -- ^ Rebuild LHS with new inner RHS + -> (t -> t) -- ^ Rebuild RHS with new inner LHS + -> t -- ^ The inner RHS of LHS + -> t -- ^ The inner LHS of RHS + -> Validation (NonEmpty e) t + goOpenBoth expr (Fixity a1 p1) (Fixity a2 p2) (Fixity a3 p3) op lhs rhs prefix suffix pivotx pivoty + -- Side precedences are equal to root, so associativity will tiebreak. + | p1 == p2 && p1 == p3 = if + | a1 /= a2 && a1 /= a3 && a2 /= a3 -> failure $ makeError AmbiguityMismatchAssoc expr + | a1 /= a2 -> failure $ makeError AmbiguityMismatchAssoc (lhs `op` pivoty) + | a1 /= a3 -> failure $ makeError AmbiguityMismatchAssoc (pivotx `op` rhs) + | AssocNone <- a1 -> failure $ makeError AmbiguityAssocNone expr + | AssocLeft <- a1 -> suffix <$> reorder (lhs `op` pivoty) + | AssocRight <- a1 -> prefix <$> reorder (pivotx `op` rhs) + -- Left-hand side has equal precedence to root, but not right-hand side. + | p1 == p2 = if + | a1 /= a2 -> failure $ makeError AmbiguityMismatchAssoc (lhs `op` pivoty) + | AssocNone <- a1 -> failure $ makeError AmbiguityAssocNone (lhs `op` pivoty) + | AssocLeft <- a1 -> if p1 < p3 + then pure expr + else suffix <$> reorder (lhs `op` pivoty) + | AssocRight <- a1 -> if p1 < p3 + then prefix <$> reorder (pivotx `op` rhs) + else suffix . prefix <$> reorder (pivotx `op` pivoty) + -- Similar to previous, but opposite direction. + | p1 == p3 = if + | a1 /= a3 -> failure $ makeError AmbiguityMismatchAssoc (pivotx `op` rhs) + | AssocNone <- a1 -> failure $ makeError AmbiguityAssocNone (pivotx `op` rhs) + | AssocRight <- a1 -> if p1 < p2 + then pure expr + else prefix <$> reorder (pivotx `op` rhs) + | AssocLeft <- a1 -> if p1 < p2 + then suffix <$> reorder (lhs `op` pivoty) + else prefix . suffix <$> reorder (pivotx `op` pivoty) + -- From here on, the two side precedences are different from the root. + | p1 > p2 && p1 > p3 = if + -- Two side precedences are equal, so associativity will tiebreak. + | p2 == p3 -> if + | a2 /= a3 -> failure $ makeError AmbiguityMismatchAssoc expr + | AssocNone <- a2 -> failure $ makeError AmbiguityAssocNone expr + | AssocLeft <- a2 -> suffix . prefix <$> reorder (pivotx `op` pivoty) + | AssocRight <- a2 -> prefix . suffix <$> reorder (pivotx `op` pivoty) + | p2 > p3 -> suffix . prefix <$> reorder (pivotx `op` pivoty) + | otherwise -> prefix . suffix <$> reorder (pivotx `op` pivoty) + | p1 > p2 && p1 < p3 = prefix <$> reorder (pivotx `op` rhs) + | p1 < p2 && p1 > p3 = suffix <$> reorder (lhs `op` pivoty) + | otherwise = pure expr + + goOpenLeft + :: t -- ^ Original expression + -> Fixity -- ^ Fixity of root node + -> Fixity -- ^ Fixity of LHS + -> (t -> t) -- ^ Rebuild root node + -> (t -> t) -- ^ Rebuild LHS with new inner RHS + -> t -- ^ The inner RHS of LHS + -> Validation (NonEmpty e) t + goOpenLeft expr (Fixity a1 p1) (Fixity a2 p2) op prefix pivot + | p1 == p2 = if + | a1 /= a2 -> failure $ makeError AmbiguityMismatchAssoc expr + | AssocNone <- a1 -> failure $ makeError AmbiguityAssocNone expr + | AssocLeft <- a1 -> pure expr + | AssocRight <- a1 -> prefix <$> reorder (op pivot) + | p1 > p2 = prefix <$> reorder (op pivot) + | otherwise = pure expr + + goOpenRight + :: t -- ^ Original expression + -> Fixity -- ^ Fixity of root node + -> Fixity -- ^ Fixity of RHS + -> (t -> t) -- ^ Rebuild root node + -> (t -> t) -- ^ Rebuild RHS with new inner LHS + -> t -- ^ The inner LHS of RHS + -> Validation (NonEmpty e) t + goOpenRight expr (Fixity a1 p1) (Fixity a3 p3) op suffix pivot + | p1 == p3 = if + | a1 /= a3 -> failure $ makeError AmbiguityMismatchAssoc expr + | AssocNone <- a1 -> failure $ makeError AmbiguityAssocNone expr + | AssocRight <- a1 -> pure expr + | AssocLeft <- a1 -> suffix <$> reorder (op pivot) + | p1 > p3 = suffix <$> reorder (op pivot) + | otherwise = pure expr + +{- | The structure of a node in a syntax tree in regards to operations. + +A non-leaf node is made up of: + +* An operator (associativity and precedence for infix nodes, just precedence for unary nodes). +* The open children of the node i.e. the children that may have reordering happen. +* A rebuilding function, which replaces the children of node and rebuilds it e.g. updating source locations. + +Note that the arity referred to is the number of open children, not the arity of the operation itself. +-} +data Node t + {- | A prefix operator, where only the right-hand side is open, e.g. @-n@ or @if p then x else y@. -} + = NodePrefix Precedence t (t -> t) + {- | A postfix operator, where only the left-hand side is open, e.g. @obj.field@ or @xs[n]@. -} + | NodePostfix Precedence t (t -> t) + {- | An infix operator, where both sides are open, e.g. @x + y@ or @p ? x : y@. -} + | NodeInfix Fixity t t (t -> t -> t) + {- | A leaf node where expressions may be contained, but are not open, e.g. @(x + y)@ or @do { x }@. -} + | NodeLeaf + +{- | Validation applicative, similar to 'Either' but aggregates errors. -} +data Validation e a + = Success a + | Failure e + deriving (Show, Eq, Generic) + +instance Functor (Validation e) where + fmap f (Success a) = Success (f a) + fmap _ (Failure e) = Failure e + +instance Bifunctor Validation where + bimap _ f (Success x) = Success (f x) + bimap f _ (Failure x) = Failure (f x) + +instance Semigroup e => Applicative (Validation e) where + pure x = Success x + + Success f <*> Success a = Success (f a) + Failure e <*> Success _ = Failure e + Success _ <*> Failure e = Failure e + Failure x <*> Failure y = Failure (x <> y) + +failure :: e -> Validation (NonEmpty e) a +failure = Failure . pure + +thenValidate :: (a -> Validation e b) -> (b -> Validation e c) -> a -> Validation e c +thenValidate f g x = case f x of + Failure e -> Failure e + Success y -> g y + +{- | The fixity of an operator. -} +data Fixity = Fixity + { fixityAssoc :: Assoc + , fixityPrec :: Precedence + } + deriving (Show, Eq, Generic) + +{- | The associativity of an operator. -} +data Assoc + {- | Associates to the left: @(a * b) * c@. -} + = AssocLeft + {- | Associates to the right: @a * (b * c)@. -} + | AssocRight + {- | Does not associate at all: @a * b * c@ would be ambiguous. -} + | AssocNone + deriving (Show, Eq, Generic) + +{- | The precedence of the operator. + +Higher precedence binds tighter. +-} +type Precedence = Double + +{- | An ambiguity in the operator chain. -} +data Ambiguity + {- | Multiple operators with same precedence but different associativities in a chain. -} + = AmbiguityMismatchAssoc + {- | Multiple non-associative infix operators in a chain e.g. @1 == 2 == 3@. -} + | AmbiguityAssocNone + deriving (Show, Eq, Generic) + +{- $example + +First, we implement the 'SyntaxTree' class for our expression type: + +> data Expr +> = ExprBinary BinOp Expr Expr +> | ExprPrefix PreOp Expr +> | ExprTuple [Expr] +> | ExprInt Int +> +> fixityOf :: BinOp -> Fixity +> precOf :: PreOp -> Precedence +> +> instance SyntaxTree Expr String where +> reorderChildren expr = case expr of +> ExprBinary op l r -> ExprBinary op <$> reorder l <*> reorder r +> ExprPrefix op x -> ExprPrefix op <$> reorder x +> ExprTuple xs -> ExprTuple <$> traverse reorder xs +> _ -> pure expr +> +> structureOf expr = case expr of +> ExprBinary binop l r -> NodeInfix (fixityOf binop) l r (ExprBinary binop) +> ExprPrefix preop x -> NodePrefix (precOf preop) x (ExprPrefix preop) +> _ -> NodeLeaf +> +> makeError err _ = show err + +Writing the traversals manually for 'reorderChildren' can be tedious, but can easily be done with other libraries, such +as @types@ from @generic-lens@ or @gplate@ from @optics@. + +Then, use 'reorder' to apply the reordering to a tree: + +>>> reorder $ ExprBinary BinOpMul (ExprBinary BinOpAdd (ExprInt 1) (ExprInt 2)) (ExprInt 3) -- (1 + 2) * 3 +ExprBinary BinOpAdd (ExprInt 1) (ExprBinary BinOpMul (ExprInt 2) (ExprInt 3)) -- 1 + (2 * 3) + +If your syntax tree is annotated with e.g. source positions, you can rebuild those in the function of 'Node': + +> (<~>) :: (HasSourcePos a, HasSourcePos b) => a -> b -> SourcePos +> +> structureOf (Located _ expr) = case expr of +> ExprBinary binop l r -> NodeInfix (fixityOf binop) l r (\l' r' -> Located (l' <~> r') $ ExprBinary binop l' r') +> ExprPrefix preop x -> NodePrefix (precOf preop) x (\x' -> Located (preop <~> x') $ ExprPrefix preop x') +> _ -> NodeLeaf + +Higher arity operations, where at most two child expressions are open, are supported; they can be treated as a prefix, +postfix, or infix operator depending on how many open child expressions there are: + +> structureOf expr = case expr of +> ExprTernary x y z -> NodeInfix ternaryFixity x z (\x' z' -> ExprTernary x' y z') -- x ? y : z +> ExprIfThenElse x y z -> NodePrefix ifThenElsePrec z (\z' -> ExprIfThenElse x y z') -- if x then y else z +> ExprIndex x y -> NodePostfix indexPrec x (\x' -> ExprIndex x' y) -- x[y] +> _ -> NodeLeaf +-} diff --git a/test/Expression/ReorderSpec.hs b/test/Expression/ReorderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Expression/ReorderSpec.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE OverloadedLists #-} + +module Expression.ReorderSpec + ( spec + ) where + +import Data.Bifunctor (first, second) +import Data.List.NonEmpty (NonEmpty) +import Test.Hspec +import Test.Expr (parenthesize, parenthesizeVerbose) +import Test.Parser (expr) +import Expression.Reorder (Validation(..), Ambiguity(..), reorder) + +{- Input: + +* @(...)@ is the association for the parser (default priority is postfix, prefix, then left infix). +* @{...}@ is grouping. +* @n.@ is an @infixr n@ operator. +* @=n.@ is an @infix n@ operator. +* @~n.@ is a @prefix n@ operator. +* @!n.@ is a @postfix n@ operator. +* @\@{x, y, ...}@ is a @postfix 99@ operator that can contain many expressions. + +Output: + +* @(...)@ is the actual tree structure of the expression. +* @[i:s-e]@ means the operator node has index @i@ and spans @s@ to @e@ in the source. +* Everything else is the same. +-} + +-- Include source position and operator index in output. +(~=) :: String -> String -> Expectation +l ~= r = parenthesizeVerbose l <$> reorder (expr l) `shouldBe` Success r + +-- Only include parentheses. +(~~) :: String -> String -> Expectation +l ~~ r = parenthesize <$> reorder (expr l) `shouldBe` Success r + +-- Test that the offending expression is correct. +(~!) :: String -> NonEmpty (Ambiguity, String) -> Expectation +l ~! r = f (reorder (expr l)) `shouldBe` Failure r + where + f = (first . fmap . second) parenthesize + +spec :: Spec +spec = do + describe "reorder" $ do + it "keeps closed both sides (atoms)" $ do + "a <1. b" + ~~ "(a <1. b)" + + it "keeps closed both sides (postfix, prefix)" $ do + "a !1. <1. ~1. b" + ~~ "((a !1.) <1. (~1. b))" + + it "keeps right associative" $ do + "a >4. (b >4. c)" + ~~ "(a >4. (b >4. c))" + + it "reorders left associativity out" $ do + "(a <1. b) <2. c" + ~~ "(a <1. (b <2. c))" + + it "keeps stronger left associativity" $ do + "(a <2. b) <1. c" + ~~ "((a <2. b) <1. c)" + + it "reorders stronger left, weaker right" $ do + "(a <7. b) <5. (c <3. d)" + ~~ "(((a <7. b) <5. c) <3. d)" + + it "reorders weaker left, stronger right" $ do + "(a <3. b) <5. (c <7. d)" + ~~ "(a <3. (b <5. (c <7. d)))" + + it "reorders weaker both sides" $ do + "(a <4. b) <5. (c <3. d)" + ~~ "((a <4. (b <5. c)) <3. d)" + + it "reorders weaker (equal left assoc) both sides" $ do + "(a <3. b) <5. (c <3. d)" + ~~ "((a <3. (b <5. c)) <3. d)" + + it "reorders weaker (equal right assoc) both sides" $ do + "(a >3. b) <5. (c >3. d)" + ~~ "(a >3. ((b <5. c) >3. d))" + + it "reorders weaker left, equal (assoc left) right" $ do + "(a <3. b) <5. (c <5. d)" + ~~ "(a <3. ((b <5. c) <5. d))" + + it "reorders weaker left, equal (assoc right) right" $ do + "(a <3. b) >5. (c >5. d)" + ~~ "(a <3. (b >5. (c >5. d)))" + + it "reorders equal (assoc left) left, weaker right" $ do + "(a <5. b) <5. (c <3. d)" + ~~ "(((a <5. b) <5. c) <3. d)" + + it "reorders equal (assoc right) left, weaker right" $ do + "(a >5. b) >5. (c <3. d)" + ~~ "((a >5. (b >5. c)) <3. d)" + + it "is ambiguous when equal (different assoc) left, weaker right" $ do + "(a <5. b) >5. (c <3. d)" + ~! [(AmbiguityMismatchAssoc, "((a <5. b) >5. c)")] + + it "is ambiguous when weaker (equal no assoc) both sides" $ do + "(a =3. b) <5. (c =3. d)" + ~! [(AmbiguityAssocNone, "((a =3. b) <5. (c =3. d))")] + + it "is ambiguous when weaker (different assoc) both sides" $ do + "(a <3. b) =5. (c >3. d)" + ~! [(AmbiguityMismatchAssoc, "((a <3. b) =5. (c >3. d))")] + + it "is ambiguous when equal (different assoc) both sides" $ do + "(a <5. b) =5. (c >5. d)" + ~! [(AmbiguityMismatchAssoc, "((a <5. b) =5. (c >5. d))")] + + it "is ambiguous when stronger left, equal (different assoc) right" $ do + "(a <7. b) <5. (c >5. d)" + ~! [(AmbiguityMismatchAssoc, "(b <5. (c >5. d))")] + + it "is ambiguous when equal (different assoc) left, stronger right" $ do + "(a >5. b) <5. (c =7. d)" + ~! [(AmbiguityMismatchAssoc, "((a >5. b) <5. c)")] + + it "reorders higher fixity in right-hand side" $ do + "a <3. b <4. c" + ~= "(a <3.[0:0-13] (b <4.[1:6-13] c))" + + it "keeps correct left associativity" $ do + "a <3. b <3. c" + ~= "((a <3.[0:0-7] b) <3.[1:0-13] c)" + + it "reorders a postfix into a binary" $ do + "(a <1. b) !2." + ~~ "(a <1. (b !2.))" + + it "reorders a prefix into a binary" $ do + "~2. (a <1. b)" + ~~ "((~2. a) <1. b)" + + it "reorders postfix over prefix" $ do + "~2. (a !1.)" + ~= "((~2.[0:0-6] a) !1.[1:0-10])" + + it "reorders prefix over postfix" $ do + "(~1. a) !2." + ~= "(~1.[0:1-11] (a !2.[1:5-11]))" + + it "reorders alternating prefix and postfix" $ do + "~2. ~4. a !5. !3." + ~= "(~2.[0:0-17] ((~4.[1:4-13] (a !5.[2:8-13])) !3.[3:4-17]))" + + it "reorders right associative operator" $ do + "a >4. b >4. c" + ~= "(a >4.[0:0-13] (b >4.[1:6-13] c))" + + it "reorders a prefix operator outside" $ do + "~1. a <2. b" + ~= "(~1.[0:0-11] (a <2.[1:4-11] b))" + + it "keeps a prefix operator inside" $ do + "~2. a <1. b" + ~= "((~2.[0:0-5] a) <1.[1:0-11] b)" + + it "reorders a postfix operator outside" $ do + "a <2. b !1." + ~= "((a <2.[0:0-7] b) !1.[1:0-11])" + + it "reorders higher fixity on both sides" $ do + "a <2. b <1. c <2. d" + ~= "((a <2.[0:0-7] b) <1.[1:0-19] (c <2.[2:12-19] d))" + + it "reorders inside leaves" $ do + "{a <3. b <4. c}" + ~="{(a <3.[0:1-14] (b <4.[1:7-14] c))}" + + it "reorders inside many leaves" $ do + "{a <3. b <4. c} @{a <3. b <4. c, a <3. b <4. c}" + ~= "({(a <3.[0:1-14] (b <4.[1:7-14] c))} @[2:0-47]{(a <3.[3:18-31] (b <4.[4:24-31] c)), (a <3.[5:33-46] (b <4.[6:39-46] c))})" + + it "reorders something complicated" $ do + "~2. ~4. {a >3. {b >3. c} <4. d <4. e =1. f} !5. !3." + ~= "(~2.[0:0-51] ((~4.[1:4-47] ({((a >3.[2:9-36] (({(b >3.[3:16-23] c)} <4.[4:15-30] d) <4.[5:15-36] e)) =1.[6:9-42] f)} !5.[7:8-47])) !3.[8:4-51]))" + + it "is ambiguous when chaining non-associative" $ do + "a =1. b =1. c" + ~! [(AmbiguityAssocNone, "((a =1. b) =1. c)")] + + it "is ambiguous when same precedence prefix and postfix" $ do + "~1. a !1." + ~! [(AmbiguityMismatchAssoc, "((~1. a) !1.)")] + + it "is ambiguous when same precedence left and right associative" $ do + "a <3. b >3. c" + ~! [(AmbiguityMismatchAssoc, "((a <3. b) >3. c)")] + + it "finds multiple ambiguities in closed children" $ do + "a @{a =1. b =1. c, a =2. b =2. c}" + ~! [ (AmbiguityAssocNone, "((a =1. b) =1. c)") + , (AmbiguityAssocNone, "((a =2. b) =2. c)") + ] + + it "finds multiple ambiguities in open children" $ do + "{a =1. b =1. c} <1. {a =2. b =2. c}" + ~! [ (AmbiguityAssocNone, "((a =1. b) =1. c)") + , (AmbiguityAssocNone, "((a =2. b) =2. c)") + ] + + it "finds multiple ambiguities in open and closed children" $ do + "{a =1. b =1. c} @{a =2. b =2. c}" + ~! [ (AmbiguityAssocNone, "((a =1. b) =1. c)") + , (AmbiguityAssocNone, "((a =2. b) =2. c)") + ] + + it "reorders something really complicated" $ do + "~2. a <4. (b <4. c) >5. (d >5. (e =3. f) !7.) =1. g" + ~~ "((~2. (((a <4. b) <4. (c >5. (d >5. e))) =3. (f !7.))) =1. g)" + + it "reorders binary containing binary and postfix" $ do + "(a <2. b) <2. (c !1.)" ~~ "(((a <2. b) <2. c) !1.)" + + it "reorders binary containing prefix and binary" $ do + "(~1. a) <2. (b <2. c)" ~~ "(~1. ((a <2. b) <2. c))" + + it "reorders postfix and prefix in a binary" $ do + "(~1. a) <3. (c !2.)" ~~ "(~1. ((a <3. c) !2.))" + + it "is ambiguous when all same precedence, all different associativity" $ do + "(a <3. b) =3. (c >3. d)" + ~! [(AmbiguityMismatchAssoc, "((a <3. b) =3. (c >3. d))")] + + it "is ambiguous when all same precedence, left different associativity" $ do + "(a <3. b) >3. (c >3. d)" + ~! [(AmbiguityMismatchAssoc, "((a <3. b) >3. c)")] + + it "is ambiguous when all same precedence, right different associativity" $ do + "(a <3. b) <3. (c >3. d)" + ~! [(AmbiguityMismatchAssoc, "(b <3. (c >3. d))")] + + it "is ambiguous when all same precedence, no associativity" $ do + "(a =3. b) =3. (c =3. d)" + ~! [(AmbiguityAssocNone, "((a =3. b) =3. (c =3. d))")] + + it "reorders all same precedence, left associative" $ do + "(a <3. b) <3. (c <3. d)" + ~~ "(((a <3. b) <3. c) <3. d)" + + it "reorders all same precedence, right associative" $ do + "(a >3. b) >3. (c >3. d)" + ~~ "(a >3. (b >3. (c >3. d)))" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test/Expr.hs b/test/Test/Expr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Expr.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Expr + ( Pos(..) + , Loc(..) + , (@@) + , (<~>) + , OpIndex(..) + , LExpr + , LOp + , Expr(..) + , parenthesize + , parenthesizeVerbose + ) where + +import Data.List (intercalate) +import GHC.Generics (Generic) +import Optics +import Expression.Reorder + +{- | Span in source (by char count). -} +data Pos = Pos Int Int + deriving (Show, Eq, Generic) + +instance Semigroup Pos where + Pos a b <> Pos c d = Pos (min a c) (max b d) + +{- | An item with source location. -} +data Loc a = Loc + { locPos :: Pos + , locItem :: a + } + deriving (Show, Eq, Generic) + +{- | Alias for @flip Loc@. -} +infix 1 @@ +(@@) :: a -> Pos -> Loc a +x @@ p = Loc p x + +{- | Alias for @(<>) `on` locPos@. -} +infix 2 <~> +(<~>) :: Loc a -> Loc b -> Pos +Loc p1 _ <~> Loc p2 _ = p1 <> p2 + +type LExpr = Loc Expr + +type LOp = Loc Fixity + +{- | Operation nodes are labelled with an index, for testing purposes. -} +newtype OpIndex = OpIndex Int + deriving (Show, Eq, Generic) + +data Expr + = ExprAtom Char + | ExprGroup LExpr + | ExprPrefix OpIndex LOp LExpr + | ExprPostfix OpIndex LOp LExpr + | ExprBinary OpIndex LOp LExpr LExpr + | ExprIndex OpIndex LExpr (Loc [LExpr]) + deriving (Show, Eq, Generic) + +instance SyntaxTree LExpr (Ambiguity, LExpr) where + -- We can write all the traversals manually, but that's too much effort! + reorderChildren = traverseOf (gplate @LExpr) reorder + + structureOf (Loc _ expr) = case expr of + ExprBinary i op l r -> NodeInfix (locItem op) l r (\l2 r2 -> ExprBinary i op l2 r2 @@ l2 <~> r2) + ExprPrefix i op x -> NodePrefix (fixityPrec $ locItem op) x (\x2 -> ExprPrefix i op x2 @@ op <~> x2) + ExprPostfix i op x -> NodePostfix (fixityPrec $ locItem op) x (\x2 -> ExprPostfix i op x2 @@ x2 <~> op) + ExprIndex i x xs -> NodePostfix 99 x (\x2 -> ExprIndex i x2 xs @@ x2 <~> xs) + _ -> NodeLeaf + + makeError = (,) + +{- | Prints the tree with parentheses everywhere. -} +parenthesize :: LExpr -> String +parenthesize (Loc _ expr) = case expr of + ExprAtom c -> [c] + ExprGroup x -> concat ["{", parenthesize x, "}"] + ExprPrefix _ (Loc _ (Fixity _ p)) x -> + concat ["(", "~", showRounded p, ".", " ", parenthesize x, ")"] + ExprPostfix _ (Loc _ (Fixity _ p)) x -> + concat ["(", parenthesize x, " ", "!", showRounded p, ".", ")"] + ExprBinary _ (Loc _ (Fixity a p)) l r -> + concat ["(", parenthesize l, " ", showBinA a, showRounded p, ".", " ", parenthesize r, ")"] + ExprIndex _ x (Loc _ xs) -> + concat ["(", parenthesize x, " ", "@{", intercalate ", " $ map parenthesize xs, "}", ")"] + where + showBinA a = case a of + AssocLeft -> "<" + AssocRight -> ">" + AssocNone -> "=" + showRounded = show @Int . round + +{- | Prints the tree with parentheses everywhere. + +For testing purposes, also prints: + +* The index of an operator node. +* The span of an operator node. +-} +parenthesizeVerbose :: String -> LExpr -> String +parenthesizeVerbose s (Loc w expr) = case expr of + ExprAtom c -> [c] + ExprGroup x -> concat ["{", parenthesizeVerbose s x, "}"] + ExprPostfix i (Loc _ (Fixity _ p)) x -> + concat ["(", parenthesizeVerbose s x, " ", "!", showRounded p, ".", showPos i w, ")"] + ExprPrefix i (Loc _ (Fixity _ p)) x -> + concat ["(", "~", showRounded p, ".", showPos i w, " ", parenthesizeVerbose s x, ")"] + ExprBinary i (Loc _ (Fixity a p)) l r -> + concat ["(", parenthesizeVerbose s l, " ", showBinA a, showRounded p, ".", showPos i w, " ", parenthesizeVerbose s r, ")"] + ExprIndex i x (Loc _ xs) -> + concat ["(", parenthesizeVerbose s x, " ", "@", showPos i w, "{", intercalate ", " . map (parenthesizeVerbose s) $ xs, "}", ")"] + where + showBinA a = case a of + AssocLeft -> "<" + AssocRight -> ">" + AssocNone -> "=" + showRounded = show @Int . round + showPos (OpIndex i) (Pos a b) = "[" <> show i <> ":" <> show a <> "-" <> show b <> "]" diff --git a/test/Test/Parser.hs b/test/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Test/Parser.hs @@ -0,0 +1,110 @@ +module Test.Parser + ( Parser + , expr + ) where + +import Text.Parsec +import Test.Expr +import Expression.Reorder (Fixity(..), Assoc(..)) + +type Parser = Parsec String Int + +expr :: String -> LExpr +expr s = case runParser pExpr 0 "" s of + Left e -> error $ "parse error" <> show e + Right x -> x + +getColumn :: Parser Int +getColumn = pred . sourceColumn . statePos <$> getParserState + +nextIndex :: Parser OpIndex +nextIndex = OpIndex <$> (getState <* modifyState succ) + +pExpr :: Parser LExpr +pExpr = pBinary <* eof + +pBinary :: Parser LExpr +pBinary = do + x <- pPostfix + xs <- many $ do + p1 <- getColumn + a <- AssocLeft <$ char '<' <|> AssocRight <$ char '>' <|> AssocNone <$ char '=' + p <- read <$> many1 digit + _ <- char '.' + p2 <- getColumn + spaces + i <- nextIndex + y <- pPostfix + pure (Fixity a p @@ Pos p1 p2, i, y) + pure $ foldl (\acc (op, i, y) -> ExprBinary i op acc y @@ acc <~> y) x xs + +pPostfix :: Parser LExpr +pPostfix = do + x <- pPrefix + os <- many $ choice + [ do + p1 <- getColumn + _ <- char '!' + p <- read <$> many1 digit + _ <- char '.' + p2 <- getColumn + spaces + i <- nextIndex + let op = Fixity AssocRight p @@ Pos p1 p2 + pure $ \acc -> ExprPostfix i op acc @@ acc <~> op + , do + p1 <- getColumn + i <- nextIndex + _ <- char '@' + _ <- char '{' + spaces + xs <- pBinary `sepBy` (char ',' >> spaces) + _ <- char '}' + p2 <- getColumn + spaces + let op = xs @@ Pos p1 p2 + pure $ \acc -> ExprIndex i acc op @@ acc <~> op + ] + pure $ foldl (\acc f -> f acc) x os + +pPrefix :: Parser LExpr +pPrefix = do + os <- many $ do + p1 <- getColumn + _ <- char '~' + p <- read <$> many1 digit + _ <- char '.' + p2 <- getColumn + spaces + i <- nextIndex + pure (Fixity AssocLeft p @@ Pos p1 p2, i) + x <- pAssoc <|> pGroup <|> pAtom + pure $ foldl (\acc (op, i) -> ExprPrefix i op acc @@ op <~> acc) x (reverse os) + +pAssoc :: Parser LExpr +pAssoc = do + _ <- char '(' + spaces + x <- pBinary + _ <- char ')' + spaces + pure x + +pGroup :: Parser LExpr +pGroup = do + p1 <- getColumn + _ <- char '{' + spaces + x <- pBinary + _ <- char '}' + p2 <- getColumn + spaces + pure $ ExprGroup x @@ Pos p1 p2 + +pAtom :: Parser LExpr +pAtom = do + p1 <- getColumn + x <- alphaNum + p2 <- getColumn + spaces + pure $ ExprAtom x @@ Pos p1 p2