{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Haskell.Brittany.Internal.Components.OpTree where

import           Language.Haskell.Brittany.Internal.Prelude

import qualified Data.Text                     as Text
import           GHC.Types.Fixity               ( Fixity(Fixity)
                                                , FixityDirection
                                                  ( InfixL
                                                  , InfixN
                                                  , InfixR
                                                  )
                                                )
import           GHC.Types.SourceText           ( SourceText(NoSourceText) )
import qualified Safe
import qualified Data.Char
import           Data.Data                      ( toConstr )

import           Language.Haskell.Brittany.Internal.Components.BriDoc
import           Language.Haskell.Brittany.Internal.Utils
import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal.Config.Types
                                                ( UnknownFixityHandling(..) )



displayOpTree :: OpTree -> String
displayOpTree = \case
  OpUnknown p _ _ leftTree rs ->
    (  "(OpUnknown "
    ++ show p
    ++ " "
    ++ displayOpTree leftTree
    ++ " ["
    ++ intercalate
         ","
         [ ("(" ++ showOp op ++ "," ++ displayOpTree x ++ ")") | (op, x) <- rs ]
    ++ "])"
    )
  OpKnown p _ _ _ fixity tree ops ->
    (  "OpKnown "
    ++ show p
    ++ " "
    ++ showOutputable fixity
    ++ " ("
    ++ displayOpTree tree
    ++ ")"
    ++ join [ (showOp op ++ "(" ++ displayOpTree t ++ ")") | (op, t) <- ops ]
    )
  OpLeaf _ (x, _) -> show x
 where
  showOp :: BriDocNumbered -> String
  showOp = \case
    (_, BDFlushCommentsPrior _ x) -> showOp x
    (_, BDQueueComments _ x     ) -> showOp x
    (_, BDLit x                 ) -> Text.unpack x
    -- (_, BDFlushCommentsPrior _ (_, BDFlushCommentsPrior _ (_, x)))
    --   | trace (show $ toConstr x) False -> "meow"
    (i, _                       ) -> show i


-- lookupFixities :: Monad m => OpTree -> m OpTree
-- lookupFixities = \case
--   OpNode par Nothing opDoc chldrn -> do
--     pure $ OpNode par (hardcodedFixity (Text.unpack opDoc)) opDoc chldrn
--   x@OpNode{} -> pure x
--   x@OpLeaf{} -> pure x

data ReformatParenMode
  = ReformatParenModeKeep  -- don't modify parens at all
  | ReformatParenModeClean -- remove unnecessary parens
  | ReformatParenModeAll   -- add superfluous parens everywhere

-- [(Bool, Fixity, Text, [OpTree])]

-- a == b + c || d * e /= f
-- _ a
-- == a, _ b
-- == a, + b, _ c
-- == a, + b c
-- == a (+ b c)
-- || (== a (+ b c)), _ d
-- || (== a (+ b c)), * d, _ e
-- || (== a (+ b c)), * d e
-- || (== a (+ b c)), /= (* d e), _ f
-- || (== a (+ b c)), /= (* d e) f
-- || (== a (+ b c)) (/= (* d e) f)

data StackElem = StackElem (Bool, Fixity) [(OpTree, BriDocNumbered)]
type Stack = [StackElem]

balanceOpTree
  :: UnknownFixityHandling -> Bool -> OpTree -> ([BrittanyError], OpTree)
balanceOpTree unknownFixityHandling allowUnqualify = outer
 where
  outer = \case
    x@OpLeaf{} -> ([], x)
    OpKnown paren allowT locO locC fixity@(Fixity _ (-1) _) left rest ->
      let
          (warnsLeft, balancedLeft) = outer left
          opRes = [ (op, outer argTree) | (op, argTree) <- rest ]
      in  ( warnsLeft ++ [ w | (_, (warns, _)) <- opRes, w <- warns ]
          , OpKnown paren
                    allowT
                    locO
                    locC
                    fixity
                    balancedLeft
                    [ (op, balanced) | (op, (_, balanced)) <- opRes ]
          )
    x@OpKnown{} -> ([], x)
    x@(OpUnknown paren locO locC left rest) ->
      let (warns, balancedLeft) = outer left
      in  case go [] rest balancedLeft of
            Right (leaf@OpLeaf{}) -> (warns, leaf)
            Right (OpKnown _paren allowT _ _ fixity c cs) ->
              (warns, OpKnown paren allowT locO locC fixity c cs)
            Right t         -> (warns, t)
            Left  moreWarns -> ((warns ++ moreWarns), x)
  -- singleton :: BriDocNumbered -> StackElem
  -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) []
  go
    :: Stack
    -> [(BriDocNumbered, OpTree)]
    -> OpTree
    -> Either [BrittanyError] OpTree
  go [] [] _ = Left []
  go [StackElem fxty cs] [] c =
    let (e1, eops) = shiftOps cs c in Right (known fxty e1 eops)
  go (StackElem fxty cs : StackElem fixity cs2 : rest) [] c =
    -- go (StackElem fixity (OpKnown False fxty (reverse cs) : cs2) : rest) []
    let (e1, eops) = shiftOps cs c
    in  go (StackElem fixity cs2 : rest) [] (known fxty e1 eops)
  go stack input@((opDoc, val) : inputR) c = case stack of
    [] -> do
      fxty <- docFixity opDoc
      go [StackElem fxty [(c, opDoc)]] inputR val
    (StackElem fixityS cs : stackR) -> do
      let (_, Fixity _ precS dirS) = fixityS
      fxty@(_, Fixity _ prec dir) <- docFixity opDoc
      case compare prec precS of
        GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR val
        LT -> do
          let (e1, eops) = shiftOps cs c
          go stackR input (known fixityS e1 eops)
        EQ -> case (dir, dirS) of
          (InfixR, InfixR) ->
            go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
          (InfixL, InfixL) ->
            go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
          _ -> Left []
  docFixity :: BriDocNumbered -> Either [BrittanyError] (Bool, Fixity)
  docFixity (_, x) = case x of
    BDLit (Text.unpack -> s) -> case hardcodedFixity allowUnqualify s of
      Just f  -> Right (True, f)
      Nothing -> case unknownFixityHandling of
        UFHSafeWarn -> Left
          [LayoutWarning ("Fixity of operator not known: " ++ s)]
        UFHSafeIgnore       -> Left []
        UFHDefaultFixity    -> Right (False, defaultFixity)
        UFHDangerousDefault -> Right (True, defaultFixity)
    BDFlushCommentsPrior _ d -> docFixity d
    BDQueueComments      _ d -> docFixity d
    _                        -> Left
      [ ( LayoutWarning
        $ "internal brittany warning: "
          ++ "Unknown form of operator "
          ++ show (toConstr x)
          ++ "!"
        )
      ]
  shiftOps
    :: [(OpTree, BriDocNumbered)]
    -> OpTree
    -> (OpTree, [(BriDocNumbered, OpTree)])
  shiftOps ops final = case reverse ops of
    [] -> (final, [])
    ((e1, o1) : rest) ->
      ( e1
      , let (finalOp, list) =
              mapAccumL (\op (nextE, nextOp) -> (nextOp, (op, nextE))) o1 rest
        in  list ++ [(finalOp, final)]
      )
  known (allowT, fixity) = OpKnown NoParen allowT Nothing Nothing fixity

addAllParens :: OpParenMode -> OpTree -> OpTree
addAllParens topLevelParen = \case
  OpKnown _paren True locO locC fixity c cs ->
    OpKnown topLevelParen
            True
            locO
            locC
            fixity
            (addAllParens ParenWithSpace c)
            [ (op, addAllParens ParenWithSpace tree) | (op, tree) <- cs ]
  x -> x

remSuperfluousParens :: Int -> OpTree -> OpTree
remSuperfluousParens outerFixity = \case
  OpUnknown _ locO locC c@(OpLeaf _ doc) [] | isLit doc ->
    OpUnknown NoParen locO locC c []
  OpUnknown _ locO locC c@(OpUnknown ParenWithSpace _ _ _ _) [] ->
    OpUnknown NoParen locO locC (remSuperfluousParens 11 c) []
  OpUnknown _ locO locC c@(OpUnknown ParenNoSpace _ _ _ _) [] ->
    OpUnknown NoParen locO locC (remSuperfluousParens 11 c) []
  OpKnown paren True locO locC fixity c cs ->
    OpKnown
      -- We do not support removing superfluous parens around
      -- function types yet:
      (if outerFixity > fixLevel fixity || fixLevel fixity < 0
        then paren
        else NoParen
      )
      True
      locO
      locC
      fixity
      (remSuperfluousParens (fixLevel fixity) c)
      [ (op, remSuperfluousParens (fixLevel fixity) tree) | (op, tree) <- cs ]
  x -> x
 where
  fixLevel (Fixity _ i _) = i
  isLit = \case
    (_, BDFlushCommentsPrior _ x ) -> isLit x
    (_, BDFlushCommentsPost _ _ x) -> isLit x
    (_, BDQueueComments _ x      ) -> isLit x
    (_, BDEntryDelta _ x         ) -> isLit x
    (_, BDForceAlt _ x           ) -> isLit x
    (_, BDDebug _ x              ) -> isLit x
    (_, BDAddBaseY _ x           ) -> isLit x
    (_, BDBaseYPushCur x         ) -> isLit x
    (_, BDIndentLevelPushCur x   ) -> isLit x
    (_, BDIndentLevelPop x       ) -> isLit x
    (_, BDLit{}                  ) -> True
    _                              -> False


hardcodedFixity :: Bool -> String -> Maybe Fixity
hardcodedFixity allowUnqualify = \case
  --
  "->"          -> Just $ Fixity NoSourceText (-1) InfixR
  "."           -> Just $ Fixity NoSourceText 9 InfixR
  "!!"          -> Just $ Fixity NoSourceText 9 InfixL
  "**"          -> Just $ Fixity NoSourceText 8 InfixR
  "^"           -> Just $ Fixity NoSourceText 8 InfixR
  "^^"          -> Just $ Fixity NoSourceText 8 InfixR
  "*"           -> Just $ Fixity NoSourceText 7 InfixL
  "/"           -> Just $ Fixity NoSourceText 7 InfixL
  "`quot`"      -> Just $ Fixity NoSourceText 7 InfixL
  "`rem`"       -> Just $ Fixity NoSourceText 7 InfixL
  "`div`"       -> Just $ Fixity NoSourceText 7 InfixL
  "`mod`"       -> Just $ Fixity NoSourceText 7 InfixL
  "+"           -> Just $ Fixity NoSourceText 6 InfixL
  "-"           -> Just $ Fixity NoSourceText 6 InfixL
  ":"           -> Just $ Fixity NoSourceText 5 InfixR
  "=="          -> Just $ Fixity NoSourceText 4 InfixN
  "/="          -> Just $ Fixity NoSourceText 4 InfixN
  "<"           -> Just $ Fixity NoSourceText 4 InfixN
  "<="          -> Just $ Fixity NoSourceText 4 InfixN
  ">"           -> Just $ Fixity NoSourceText 4 InfixN
  ">="          -> Just $ Fixity NoSourceText 4 InfixN
  "&&"          -> Just $ Fixity NoSourceText 3 InfixR
  "||"          -> Just $ Fixity NoSourceText 2 InfixR
  ">>="         -> Just $ Fixity NoSourceText 1 InfixL
  ">>"          -> Just $ Fixity NoSourceText 1 InfixL
  "=<<"         -> Just $ Fixity NoSourceText 1 InfixR
  "$"           -> Just $ Fixity NoSourceText 0 InfixR
  "`seq`"       -> Just $ Fixity NoSourceText 0 InfixR
  "$!"          -> Just $ Fixity NoSourceText 0 InfixR
  "!"           -> Just $ Fixity NoSourceText 9 InfixL
  "//"          -> Just $ Fixity NoSourceText 9 InfixL
  "<>"          -> Just $ Fixity NoSourceText 6 InfixR
  "<+>"         -> Just $ Fixity NoSourceText 5 InfixR
  "<$"          -> Just $ Fixity NoSourceText 4 InfixL
  "$>"          -> Just $ Fixity NoSourceText 4 InfixL
  "<$>"         -> Just $ Fixity NoSourceText 4 InfixL
  "<&>"         -> Just $ Fixity NoSourceText 1 InfixL
  "&"           -> Just $ Fixity NoSourceText 1 InfixL
  "<*>"         -> Just $ Fixity NoSourceText 4 InfixL
  "<**>"        -> Just $ Fixity NoSourceText 4 InfixL
  "*>"          -> Just $ Fixity NoSourceText 4 InfixL
  "<*"          -> Just $ Fixity NoSourceText 4 InfixL
  "`elem`"      -> Just $ Fixity NoSourceText 4 InfixN
  "`notElem`"   -> Just $ Fixity NoSourceText 4 InfixN
  "++"          -> Just $ Fixity NoSourceText 5 InfixR
  "%"           -> Just $ Fixity NoSourceText 7 InfixL
  "<|>"         -> Just $ Fixity NoSourceText 3 InfixL
  ".&."         -> Just $ Fixity NoSourceText 7 InfixL
  ".|."         -> Just $ Fixity NoSourceText 5 InfixL
  "`xor`"       -> Just $ Fixity NoSourceText 6 InfixL
  "`shift`"     -> Just $ Fixity NoSourceText 8 InfixL
  "`rotate`"    -> Just $ Fixity NoSourceText 8 InfixL
  "`shiftL`"    -> Just $ Fixity NoSourceText 8 InfixL
  "`shiftR`"    -> Just $ Fixity NoSourceText 8 InfixL
  "`rotateL`"   -> Just $ Fixity NoSourceText 8 InfixL
  "`rotateR`"   -> Just $ Fixity NoSourceText 8 InfixL
  "+#"          -> Just $ Fixity NoSourceText 6 InfixL
  ".^."         -> Just $ Fixity NoSourceText 6 InfixL
  ".>>."        -> Just $ Fixity NoSourceText 8 InfixL
  ".<<."        -> Just $ Fixity NoSourceText 8 InfixL
  "!>>."        -> Just $ Fixity NoSourceText 8 InfixL
  "!<<."        -> Just $ Fixity NoSourceText 8 InfixL
  ">=>"         -> Just $ Fixity NoSourceText 1 InfixR
  "<=<"         -> Just $ Fixity NoSourceText 1 InfixR
  "&&&"         -> Just $ Fixity NoSourceText 3 InfixR
  "<$!>"        -> fixity InfixL 4

  "~"           -> fixity InfixN 4
  "~~"          -> fixity InfixN 4
  ":~:"         -> Just $ Fixity NoSourceText 4 InfixN
  ":~~:"        -> Just $ Fixity NoSourceText 4 InfixN
  ":+:"         -> fixity InfixR 5
  ":*:"         -> fixity InfixR 6
  ":.:"         -> fixity InfixR 7
  ":|"          -> fixity InfixR 5

  -- non-base from random sources.
  "<|"          -> Just $ Fixity NoSourceText 5 InfixR
  "|>"          -> Just $ Fixity NoSourceText 5 InfixL
  "><"          -> Just $ Fixity NoSourceText 5 InfixR
  "$+$"         -> Just $ Fixity NoSourceText 5 InfixL
  "\\\\"        -> Just $ Fixity NoSourceText 5 InfixN
  ".>"          -> Just $ Fixity NoSourceText 9 InfixL
  ":?"          -> Just $ Fixity NoSourceText 7 InfixN
  ":-"          -> Just $ Fixity NoSourceText 9 InfixR
  ".:"          -> Just $ Fixity NoSourceText 9 InfixR
  "$!!"         -> fixity InfixR 0
  "<$!!>"       -> fixity InfixL 4

  -- lens, not complete!
  "<|"          -> fixity InfixR 5
  "|>"          -> fixity InfixL 5
  "%~"          -> fixity InfixR 4
  ".~"          -> fixity InfixR 4
  "?~"          -> fixity InfixR 4
  "<.~"         -> fixity InfixR 4
  "<?~"         -> fixity InfixR 4
  "+~"          -> fixity InfixR 4
  "*~"          -> fixity InfixR 4
  "-~"          -> fixity InfixR 4
  "//~"         -> fixity InfixR 4
  "^~"          -> fixity InfixR 4
  "^^~"         -> fixity InfixR 4
  "**~"         -> fixity InfixR 4
  "||~"         -> fixity InfixR 4
  "&&~"         -> fixity InfixR 4
  ".="          -> fixity InfixN 4
  "%="          -> fixity InfixN 4
  "?="          -> fixity InfixN 4
  "+="          -> fixity InfixN 4
  "-="          -> fixity InfixN 4
  "*="          -> fixity InfixN 4
  "//="         -> fixity InfixN 4
  "^="          -> fixity InfixN 4
  "^^="         -> fixity InfixN 4
  "**="         -> fixity InfixN 4
  "&&="         -> fixity InfixN 4
  "||="         -> fixity InfixN 4
  "<~"          -> fixity InfixR 2
  "<.="         -> fixity InfixN 4
  "<?="         -> fixity InfixN 4
  "<>~"         -> fixity InfixR 4
  "<>="         -> fixity InfixN 4
  "^.."         -> fixity InfixL 8
  "^?"          -> fixity InfixL 8
  "^?!"         -> fixity InfixL 8
  "^@.."        -> fixity InfixL 8
  "^@?"         -> fixity InfixL 8
  "^@?!"        -> fixity InfixL 8
  "^."          -> fixity InfixL 8
  "^@."         -> fixity InfixL 8
  "<."          -> fixity InfixR 9
  ".>"          -> fixity InfixR 9
  "<.>"         -> fixity InfixR 9
  "@@~"         -> fixity InfixR 4
  "@@="         -> fixity InfixR 4
  "&~"          -> fixity InfixL 1
  "??"          -> fixity InfixL 1


  -- certain other operators
  -- "%."        -> Just $ Fixity NoSourceText _ _
  -- "%=="       -> Just $ Fixity NoSourceText _ _
  -- "%=>%"      -> Just $ Fixity NoSourceText _ _
  -- "&*"        -> Just $ Fixity NoSourceText _ _
  -- "&/"        -> Just $ Fixity NoSourceText _ _
  -- "&="        -> Just $ Fixity NoSourceText _ _
  -- "-->"       -> Just $ Fixity NoSourceText _ _
  -- ".*?"       -> fixity _ _
  -- ".+."       -> fixity _ _
  -- ".-."       -> fixity _ _
  ".&."         -> fixity InfixR 1
  ".&&."        -> fixity InfixR 1
  ".||."        -> fixity InfixR 1
  "==>"         -> fixity InfixR 0
  "=/="         -> fixity InfixN 4
  "==="         -> fixity InfixN 4
  ".:!"         -> fixity InfixL 9
  ".:?"         -> fixity InfixL 9
  -- ".:>"       -> fixity _ _
  -- ".:>?"      -> fixity _ _
  "<.>"         -> fixity InfixR 7
  "</>"         -> fixity InfixR 5
  "<?>"         -> fixity InfixL 9
  -- "~"         -> fixity _ _
  "==="         -> fixity InfixN 4
  "!?"          -> fixity InfixL 9
  "%=="         -> fixity InfixN 3
  ".*"          -> fixity InfixR 8
  ".**"         -> fixity InfixR 8
  ".***"        -> fixity InfixR 8
  ":?-"         -> fixity InfixN 1
  "::-"         -> fixity InfixN 0
  "&!"          -> fixity InfixL 1

  -- extra
  "||^"         -> fixity InfixL 9
  "&&^"         -> fixity InfixL 9

  -- quickcheck (-state-machine)
  ":&&"         -> fixity InfixL 9
  ":||"         -> fixity InfixL 9
  ":&&:"        -> fixity InfixL 9
  ":=>"         -> fixity InfixL 9
  ":=="         -> fixity InfixL 9
  ":/="         -> fixity InfixL 9
  ":<"          -> fixity InfixL 9
  ":<="         -> fixity InfixL 9
  ":>"          -> fixity InfixL 9
  ":>="         -> fixity InfixL 9
  ":->"         -> fixity InfixL 9
  ".=="         -> fixity InfixN 5
  "./"          -> fixity InfixN 5
  ".<"          -> fixity InfixN 5
  ".<="         -> fixity InfixN 5
  ".>"          -> fixity InfixN 5
  ".>="         -> fixity InfixN 5
  "`member`"    -> fixity InfixN 8
  "`notMember`" -> fixity InfixN 8
  ".//"         -> fixity InfixL 4
  ".&&"         -> fixity InfixR 3
  ".||"         -> fixity InfixR 2
  ".=>"         -> fixity InfixR 1

  -- servant
  ":>"          -> fixity InfixR 4
  ":<|>"        -> fixity InfixR 3
  ":-"          -> fixity InfixL 0

  -- postgresql-simple
  ":."          -> fixity InfixR 3 -- this has wildly different fixities in different libraries

  -- ?
  -- ":-:"       -> fixity _ _
  -- ":."        -> fixity _ _
  -- ":/:"       -> fixity _ _
  -- "::->"      -> fixity _ _
  -- ":<:"       -> fixity _ _
  -- ":<=:"      -> fixity _ _
  -- ":=:"       -> fixity _ _
  -- ":>:"       -> fixity _ _
  -- ":>=:"      -> fixity _ _

  str           -> case (Safe.headMay str, Safe.lastMay str) of
    (Just '\'', _) -> hardcodedFixity False (drop 1 str)
    (Just '`', Just '`') -> Just $ Fixity NoSourceText 9 InfixL
    (Just c, _) | Data.Char.isAlpha c && allowUnqualify -> hardcodedFixity False
      $ dropWhile (\x -> (Data.Char.isAlpha x || x == '.')) str
    _ -> Nothing
  where fixity a b = Just (Fixity NoSourceText b a)

defaultFixity :: Fixity
defaultFixity = Fixity NoSourceText 9 InfixL
