never executed always true always false

    1 module ElmFormat.AST.BinaryOperatorPrecedence (parseElm0_19, parsePrecedence, Tree(..), Precedence(..), Associativity(..)) where
    2 
    3 import ElmFormat.AST.Shared
    4 import Data.Map.Strict (Map)
    5 import qualified Data.Map.Strict as Map
    6 import Data.Maybe (fromMaybe)
    7 import Data.Text (Text)
    8 
    9 
   10 data Tree op e
   11     = Leaf e
   12     | Branch op (Tree op e) (Tree op e)
   13     deriving (Eq, Show, Functor)
   14 
   15 data Precedence
   16     = Precedence
   17         { precedence :: Int
   18         , associativity :: Associativity
   19         }
   20 
   21 data Associativity
   22     = LeftAssociate
   23     | RightAssociate
   24     | NonAssociate
   25     deriving (Eq)
   26 
   27 
   28 elm0_19 :: Ord ns => Map (Ref ns) Precedence
   29 elm0_19 =
   30     Map.fromList $ fmap (\(op, p, a) -> (OpRef $ SymbolIdentifier op, Precedence p a))
   31         -- From https://github.com/elm/core/blob/1.0.5/src/Basics.elm#L68-L89
   32         [ ( "<|", 0, RightAssociate )
   33         , ( "|>", 0, LeftAssociate )
   34         , ( "||", 2, RightAssociate )
   35         , ( "&&", 3, RightAssociate )
   36         , ( "==", 4, NonAssociate )
   37         , ( "/=", 4, NonAssociate )
   38         , ( "<", 4, NonAssociate )
   39         , ( ">", 4, NonAssociate )
   40         , ( "<=", 4, NonAssociate )
   41         , ( ">=", 4, NonAssociate )
   42         , ( "++", 5, RightAssociate )
   43         , ( "+", 6, LeftAssociate )
   44         , ( "-", 6, LeftAssociate )
   45         , ( "*", 7, LeftAssociate )
   46         , ( "/", 7, LeftAssociate )
   47         , ( "//", 7, LeftAssociate )
   48         , ( "^", 8, RightAssociate )
   49         , ( "<<", 9, LeftAssociate )
   50         , ( ">>", 9, RightAssociate )
   51 
   52         -- From https://github.com/elm/core/blob/1.0.5/src/List.elm#L41
   53         , ( "::", 5, RightAssociate )
   54 
   55         -- From https://github.com/elm/url/blob/1.0.0/src/Url/Parser.elm#L46-L50
   56         , ( "</>", 7, RightAssociate )
   57         , ( "<?>", 8, LeftAssociate )
   58 
   59         -- From https://github.com/elm/parser/blob/1.1.0/src/Parser.elm#L55-L59
   60         , ( "|=", 5, LeftAssociate )
   61         , ( "|.", 6, LeftAssociate )
   62         ]
   63 
   64 parseElm0_19 :: (Ord ns, Show ns) => e -> List (Ref ns, e) -> Either Text (Tree (Ref ns) e)
   65 parseElm0_19 = parsePrecedence elm0_19
   66 
   67 
   68 parsePrecedence :: (Ord op, Show op) => Map op Precedence -> e -> List (op, e) -> Either Text (Tree op e)
   69 parsePrecedence precedenceMap first = parsePrecedence' precedenceMap (Leaf first) []
   70 
   71 -- https://en.wikipedia.org/wiki/Shunting-yard_algorithm
   72 parsePrecedence' :: (Ord op, Show op) => Map op Precedence -> Tree op e -> List (Tree op e, op) -> List (op, e) -> Either Text (Tree op e)
   73 parsePrecedence' precedenceMap b ((a, op) : rest) [] =
   74     parsePrecedence' precedenceMap (Branch op a b) rest []
   75 parsePrecedence' _ last [] [] = Right last
   76 parsePrecedence' precedenceMap prev stack ((op, next) : rest) =
   77     let
   78         prec o = fromMaybe (error ("operator is not defined: " <> show o)) $ Map.lookup o precedenceMap
   79     in
   80     case stack of
   81         (a, opPrev) : restStack
   82           | precedence (prec opPrev) > precedence (prec op)
   83             || (precedence (prec opPrev) == precedence (prec op)
   84                 && associativity (prec op) == LeftAssociate
   85                 && associativity (prec opPrev) == LeftAssociate)
   86           ->
   87             parsePrecedence' precedenceMap
   88                 (Branch opPrev a prev)
   89                 restStack
   90                 ((op, next) : rest)
   91 
   92         (_, opPrev) : _
   93           | precedence (prec opPrev) == precedence (prec op)
   94             && (associativity (prec op) == NonAssociate
   95                 || associativity (prec opPrev) /= associativity (prec op))
   96           ->
   97             Left "conflicting associativity"
   98 
   99         _ ->
  100             parsePrecedence' precedenceMap
  101                 (Leaf next)
  102                 ((prev, op) : stack)
  103                 rest