From 3a08227c0c25372e2495a54010bd82463c3d7bbf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Benno=20F=C3=BCnfst=C3=BCck?= <benno.fuenfstueck@gmail.com>
Date: Wed, 27 Aug 2014 22:05:35 +0200
Subject: [PATCH] Parse double unary - correctly and improve perf

We now don't use `buildExpressionParser` from parsers because it cannot
deal with double unary `-`, as in `--a`. Because nix doesn't have
operators which have the same precendence but different associativities,
we can greatly simplify the operator parser. This also has the effect of
improving performance and the error messages a bit.
---
 Nix/Parser.hs        | 16 ++++++++--------
 Nix/Types.hs         | 39 ++++++++++++++++++---------------------
 tests/ParserTests.hs |  4 ++++
 3 files changed, 30 insertions(+), 29 deletions(-)

diff --git a/Nix/Parser.hs b/Nix/Parser.hs
index e61c044..64f7897 100644
--- a/Nix/Parser.hs
+++ b/Nix/Parser.hs
@@ -19,14 +19,14 @@ nixExpr = whiteSpace *> (nixToplevelForm <|> foldl' makeParser nixOpArg nixOpera
   makeParser term (Left NSelectOp) = nixSelect term
   makeParser term (Left NAppOp) = chainl1 term $ pure $ \a b -> Fix (NApp a b)
   makeParser term (Left NHasAttrOp) = nixHasAttr term
-  makeParser term (Right ops) = buildExpressionParser [map buildOp ops] term
-
-  buildOp (NUnaryDef n op) = Prefix $ Fix . NOper . NUnary op <$ reservedOp n
-  buildOp (NBinaryDef n op a) = Infix (mkOper2 op <$ reservedOp n) (toAssoc a)
-
-  toAssoc NAssocNone = AssocNone
-  toAssoc NAssocLeft = AssocLeft
-  toAssoc NAssocRight = AssocRight
+  makeParser term (Right (NUnaryDef name op))
+    = build <$> many (void $ symbol name) <*> term
+   where build = flip $ foldl' (\t' () -> mkOper op t')
+  makeParser term (Right (NBinaryDef assoc ops)) = case assoc of
+    NAssocLeft  -> chainl1 term op
+    NAssocRight -> chainr1 term op
+    NAssocNone  -> term <**> (flip <$> op <*> term <|> pure id)
+   where op = choice . map (\(n,o) -> mkOper2 o <$ reservedOp n) $ ops
 
 antiStart :: Parser String
 antiStart = try (string "${") <?> show ("${" :: String)
diff --git a/Nix/Types.hs b/Nix/Types.hs
index 03985b0..7ff3fe4 100644
--- a/Nix/Types.hs
+++ b/Nix/Types.hs
@@ -209,28 +209,26 @@ data NAssoc = NAssocNone | NAssocLeft | NAssocRight
 
 data NOperatorDef
   = NUnaryDef String NUnaryOp
-  | NBinaryDef String NBinaryOp NAssoc
+  | NBinaryDef NAssoc [(String, NBinaryOp)]
   deriving (Eq, Ord, Generic, Typeable, Data, Show)
 
-nixOperators :: [Either NSpecialOp [NOperatorDef]]
+nixOperators :: [Either NSpecialOp NOperatorDef]
 nixOperators =
   [ Left NSelectOp
   , Left NAppOp
-  , Right [ NUnaryDef  "-"  NNeg           ]
+  , Right $ NUnaryDef  "-"  NNeg
   , Left NHasAttrOp
   ] ++ map Right
-  [ [ NBinaryDef "++" NConcat  NAssocRight ]
-  , [ NBinaryDef "*"  NMult    NAssocLeft  , NBinaryDef "/" NDiv   NAssocLeft ]
-  , [ NBinaryDef "+"  NPlus    NAssocLeft  , NBinaryDef "-" NMinus NAssocLeft ]
-  , [ NUnaryDef  "!"  NNot                 ]
-  , [ NBinaryDef "//" NUpdate NAssocRight  ]
-  , [ NBinaryDef "<"  NLt     NAssocLeft   , NBinaryDef ">"  NGt  NAssocLeft
-    , NBinaryDef "<=" NLte    NAssocLeft   , NBinaryDef ">=" NGte NAssocLeft
-    ]
-  , [ NBinaryDef "==" NEq     NAssocNone   , NBinaryDef "!=" NNEq NAssocNone  ]
-  , [ NBinaryDef "&&" NAnd    NAssocLeft   ]
-  , [ NBinaryDef "||" NOr     NAssocLeft   ]
-  , [ NBinaryDef "->" NImpl   NAssocNone   ]
+  [ NBinaryDef NAssocRight [("++", NConcat)]
+  , NBinaryDef NAssocLeft [("*", NMult), ("/", NDiv)]
+  , NBinaryDef NAssocLeft [("+", NPlus), ("-", NMinus)]
+  , NUnaryDef  "!"  NNot
+  , NBinaryDef NAssocRight [("//", NUpdate)]
+  , NBinaryDef NAssocLeft [("<", NLt), (">", NGt), ("<=", NLte), (">=", NGte)]
+  , NBinaryDef NAssocNone [("==", NEq), ("!=", NNEq)]
+  , NBinaryDef NAssocLeft [("&&", NAnd)]
+  , NBinaryDef NAssocLeft [("||", NOr)]
+  , NBinaryDef NAssocNone [("->", NImpl)]
   ]
 
 data OperatorInfo = OperatorInfo
@@ -242,16 +240,15 @@ data OperatorInfo = OperatorInfo
 getUnaryOperator :: NUnaryOp -> OperatorInfo
 getUnaryOperator = (m Map.!) where
   m = Map.fromList . concat . zipWith buildEntry [1..] . reverse $ nixOperators
-  buildEntry _ (Left _) = []
-  buildEntry i (Right ops) =
-    [ (op, OperatorInfo i NAssocNone name) | NUnaryDef name op <- ops ]
+  buildEntry i (Right (NUnaryDef name op)) = [(op, OperatorInfo i NAssocNone name)]
+  buildEntry _ _                           = []
 
 getBinaryOperator :: NBinaryOp -> OperatorInfo
 getBinaryOperator = (m Map.!) where
   m = Map.fromList . concat . zipWith buildEntry [1..] . reverse $ nixOperators
-  buildEntry _ (Left _) = []
-  buildEntry i (Right ops) =
-    [ (op, OperatorInfo i assoc name) | NBinaryDef name op assoc <- ops ]
+  buildEntry i (Right (NBinaryDef assoc ops)) =
+    [ (op, OperatorInfo i assoc name) | (name,op) <- ops ]
+  buildEntry _ _                              = []
 
 getSpecialOperatorPrec :: NSpecialOp -> Int
 getSpecialOperatorPrec = (m Map.!) where
diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs
index 7bee95f..a8f88f3 100644
--- a/tests/ParserTests.hs
+++ b/tests/ParserTests.hs
@@ -289,6 +289,10 @@ case_operators = do
   assertParseString "{ a = 3; } // rec { b = 4; }" $ mkOper2 NUpdate
     (Fix $ NSet NonRec [NamedVar (mkSelector "a") (mkInt 3)])
     (Fix $ NSet Rec    [NamedVar (mkSelector "b") (mkInt 4)])
+  assertParseString "--a" $ mkOper NNeg $ mkOper NNeg $ mkSym "a"
+  assertParseString "a - b - c" $ mkOper2 NMinus
+    (mkOper2 NMinus (mkSym "a") (mkSym "b")) $
+    mkSym "c"
 
 tests :: TestTree
 tests = $testGroupGenerator