reorder-expression (empty) → 0.1.0.0
raw patch · 9 files changed
+928/−0 lines, 9 filesdep +basedep +hspecdep +optics
Dependencies added: base, hspec, optics, parsec, reorder-expression
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- README.md +14/−0
- reorder-expression.cabal +75/−0
- src/Expression/Reorder.hs +325/−0
- test/Expression/ReorderSpec.hs +254/−0
- test/Main.hs +1/−0
- test/Test/Expr.hs +124/−0
- test/Test/Parser.hs +110/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for reorder-expression++## 0.1.0.0++* Initial release.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,14 @@+# reorder-expression++[](./LICENSE)+[](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.
+ reorder-expression.cabal view
@@ -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
+ src/Expression/Reorder.hs view
@@ -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+-}
+ test/Expression/ReorderSpec.hs view
@@ -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 @infixl n@ operator.+* @>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)))"
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Test/Expr.hs view
@@ -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 <> "]"
+ test/Test/Parser.hs view
@@ -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