content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module Jikka.Common.Parse.ShuntingYardSpec
    ( spec,
    )
  where
  
  import Data.Either (isLeft)
  import qualified Data.Map.Strict as M
  import Jikka.Common.Error
  import Jikka.Common.Location
  import Jikka.Common.Parse.ShuntingYard (BinOpInfo (..), Fixity (..), run)
  import Test.Hspec
  
  -- Haskell's one
  builtInOps :: M.Map String BinOpInfo
  builtInOps =
    let op fixity prec name = (name, BinOpInfo fixity prec)
     in M.fromList
          [ op Rightfix 8 "**",
            op Leftfix 7 "*",
            op Leftfix 7 "/",
            op Leftfix 7 "%",
            op Leftfix 6 "+",
            op Leftfix 6 "-",
            op Nonfix 4 "==",
            op Nonfix 4 "/=",
            op Nonfix 4 "<",
            op Nonfix 4 "<=",
            op Nonfix 4 ">",
            op Nonfix 4 ">=",
            op Rightfix 3 "&&",
            op Rightfix 2 "||"
          ]
  
  run' :: [String] -> Either Error String
  run' tokens = value <$> run info apply (f (map putPos tokens))
    where
      info op = maybeToError (Error (show op ++ " is not defined")) $ M.lookup op builtInOps
      apply op x y = putPos $ "(" ++ value x ++ " " ++ value op ++ " " ++ value y ++ ")"
      f [] = error "the length of tokens must be odd"
      f [z] = (z, [])
      f (x : y : zs) = let (z, ws) = f zs in (x, (y, z) : ws)
      putPos = WithLoc (Loc 0 0 (-1))
  
  spec :: Spec
  spec = describe "run" $ do
    it "works" $ do
      let tokens = ["a", "+", "b", "**", "c", "*", "d"]
      let tree = "(a + ((b ** c) * d))"
      run' tokens `shouldBe` Right tree
    it "recognizes left-fixity" $ do
      let tokens = ["a", "-", "b", "-", "c", "-", "d"]
      let tree = "(((a - b) - c) - d)"
      run' tokens `shouldBe` Right tree
    it "recognizes right-fixity" $ do
      let tokens = ["a", "&&", "b", "&&", "c", "&&", "d"]
      let tree = "(a && (b && (c && d)))"
      run' tokens `shouldBe` Right tree
    it "reports the error on chained non-fix ops" $ do
      let tokens = ["a", "==", "b", "==", "c"]
      run' tokens `shouldSatisfy` isLeft
  