{-# language InstanceSigs, ScopedTypeVariables, TypeApplications #-}
{-# language LambdaCase #-}
{-# language MultiParamTypeClasses, FlexibleInstances #-}
{-# language DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric #-}
{-# language TemplateHaskell #-}

{-|
Module      : Language.Python.Syntax.Operator.Binary
Copyright   : (C) CSIRO 2017-2019
License     : BSD3
Maintainer  : Isaac Elliott <isaace71295@gmail.com>
Stability   : experimental
Portability : non-portable

This module contains a datatype for binary operators and a precedence table
with associated operations. This presentation of operators is simpler and more
flexible than hard-coding them into the syntax tree.
-}

module Language.Python.Syntax.Operator.Binary where

import Control.Lens.Getter ((^.))
import Control.Lens.Lens (Lens', lens)
import Control.Lens.TH (makeLenses)
import Data.Functor (($>))
import Data.Generics.Product.Typed (typed)
import Data.Semigroup ((<>))
import GHC.Generics (Generic)

import Language.Python.Syntax.Ann
import Language.Python.Syntax.Whitespace

-- | A Python binary operator, such as @+@, along with its trailing 'Whitespace'
data BinOp a
  -- | @a is b@
  = Is (Ann a) [Whitespace]
  -- | @a is not b@
  | IsNot (Ann a) [Whitespace] [Whitespace]
  -- | @a in b@
  | In (Ann a) [Whitespace]
  -- | @a not in b@
  | NotIn (Ann a) [Whitespace] [Whitespace]
  -- | @a - b@
  | Minus (Ann a) [Whitespace]
  -- | @a ** b@
  | Exp (Ann a) [Whitespace]
  -- | @a and b@
  | BoolAnd (Ann a) [Whitespace]
  -- | @a or b@
  | BoolOr (Ann a) [Whitespace]
  -- | @a == b@
  | Eq (Ann a) [Whitespace]
  -- | @a < b@
  | Lt (Ann a) [Whitespace]
  -- | @a <= b@
  | LtEq (Ann a) [Whitespace]
  -- | @a > b@
  | Gt (Ann a) [Whitespace]
  -- | @a >= b@
  | GtEq (Ann a) [Whitespace]
  -- | @a != b@
  | NotEq (Ann a) [Whitespace]
  -- | @a * b@
  | Multiply (Ann a) [Whitespace]
  -- | @a / b@
  | Divide (Ann a) [Whitespace]
  -- | @a // b@
  | FloorDivide (Ann a) [Whitespace]
  -- | @a % b@
  | Percent (Ann a) [Whitespace]
  -- | @a + b@
  | Plus (Ann a) [Whitespace]
  -- | @a | b@
  | BitOr (Ann a) [Whitespace]
  -- | @a ^ b@
  | BitXor (Ann a) [Whitespace]
  -- | @a & b@
  | BitAnd (Ann a) [Whitespace]
  -- | @a << b@
  | ShiftLeft (Ann a) [Whitespace]
  -- | @a >> b@
  | ShiftRight (Ann a) [Whitespace]
  -- | @a @ b@
  | At (Ann a) [Whitespace]
  deriving (Eq, Show, Functor, Foldable, Traversable, Generic)

instance HasAnn BinOp where
  annot :: forall a. Lens' (BinOp a) (Ann a)
  annot = typed @(Ann a)

instance HasTrailingWhitespace (BinOp a) where
  trailingWhitespace =
    lens
      (\case
         Is _ a -> a
         IsNot _ _ a -> a
         In _ a -> a
         NotIn _ _ a -> a
         Minus _ a -> a
         Exp _ a -> a
         BoolAnd _ a -> a
         BoolOr _ a -> a
         Multiply _ a -> a
         Divide _ a -> a
         FloorDivide _ a -> a
         Plus _ a -> a
         Eq _ a -> a
         Lt _ a -> a
         LtEq _ a -> a
         Gt _ a -> a
         GtEq _ a -> a
         NotEq _ a -> a
         BitOr _ a -> a
         BitXor _ a -> a
         BitAnd _ a -> a
         ShiftLeft _ a -> a
         ShiftRight _ a -> a
         Percent _ a -> a
         At _ a -> a)
      (\op ws ->
         case op of
           Is a _ -> Is a ws
           IsNot a b _ -> IsNot a b ws
           In a _ -> In a ws
           NotIn a b _ -> NotIn a b ws
           Minus a _ -> Minus a ws
           Exp a _ -> Exp a ws
           BoolAnd a _ -> BoolAnd a ws
           BoolOr a _ -> BoolOr a ws
           Multiply a _ -> Multiply a ws
           Divide a _ -> Divide a ws
           FloorDivide a _ -> FloorDivide a ws
           Plus a _ -> Plus a ws
           Eq a _ -> Eq a ws
           Lt a _ -> Lt a ws
           LtEq a _ -> LtEq a ws
           Gt a _ -> Gt a ws
           GtEq a _ -> GtEq a ws
           NotEq a _ -> NotEq a ws
           BitOr a _ -> BitOr a ws
           BitAnd a _ -> BitAnd a ws
           BitXor a _ -> BitXor a ws
           ShiftLeft a _ -> ShiftLeft a ws
           ShiftRight a _ -> ShiftRight a ws
           Percent a _ -> Eq a ws
           At a _ -> At a ws)

-- | The associativity of an operator. Each operator is either left-associative or right associative.
--
-- Left associative:
--
-- @
-- x + y + z = (x + y) + z
-- @
--
-- Right associative:
--
-- @
-- x + y + z = x + (y + z)
-- @
data Assoc = L | R deriving (Eq, Show)

-- | An operator along with its precedence and associativity.
data OpEntry
  = OpEntry
  { _opOperator :: BinOp ()
  , _opPrec :: Int
  , _opAssoc :: Assoc
  }
makeLenses ''OpEntry

-- | 'operatorTable' is a list of all operators in ascending order of precedence.
operatorTable :: [OpEntry]
operatorTable =
  [ entry BoolOr 4 L
  , entry BoolAnd 5 L
  , entry Is 10 L
  , entry1 IsNot 10 L
  , entry In 10 L
  , entry1 NotIn 10 L
  , entry Eq 10 L
  , entry Lt 10 L
  , entry LtEq 10 L
  , entry Gt 10 L
  , entry GtEq 10 L
  , entry NotEq 10 L
  , entry BitOr 14 L
  , entry BitXor 15 L
  , entry BitAnd 16 L
  , entry ShiftLeft 17 L
  , entry ShiftRight 17 L
  , entry Minus 20 L
  , entry Plus 20 L
  , entry Multiply 25 L
  , entry At 25 L
  , entry Divide 25 L
  , entry FloorDivide 25 L
  , entry Percent 25 L
  , entry Exp 30 R
  ]
  where
    entry a = OpEntry (a (Ann ()) [])
    entry1 a = OpEntry (a (Ann ()) [] [])

-- | Compare two 'BinOp's to determine whether they represent the same operator, ignoring annotations and trailing whitespace.
sameOperator :: BinOp a -> BinOp a' -> Bool
sameOperator op op' =
  case (op, op') of
    (BoolOr{}, BoolOr{}) -> True
    (BoolAnd{}, BoolAnd{}) -> True
    (Is{}, Is{}) -> True
    (IsNot{}, IsNot{}) -> True
    (In{}, In{}) -> True
    (NotIn{}, NotIn{}) -> True
    (Eq{}, Eq{}) -> True
    (Lt{}, Lt{}) -> True
    (LtEq{}, LtEq{}) -> True
    (Gt{}, Gt{}) -> True
    (GtEq{}, GtEq{}) -> True
    (NotEq{}, NotEq{}) -> True
    (Minus{}, Minus{}) -> True
    (Plus{}, Plus{}) -> True
    (Multiply{}, Multiply{}) -> True
    (Divide{}, Divide{}) -> True
    (FloorDivide{}, FloorDivide{}) -> True
    (Exp{}, Exp{}) -> True
    (Percent{}, Percent{}) -> True
    (BitOr{}, BitOr{}) -> True
    (BitXor{}, BitXor{}) -> True
    (BitAnd{}, BitAnd{}) -> True
    (ShiftLeft{}, ShiftLeft{}) -> True
    (ShiftRight{}, ShiftRight{}) -> True
    (At{}, At{}) -> True
    _ -> False

-- | Is a 'BinOp' a comparison, such as @<=@
isComparison :: BinOp a -> Bool
isComparison a =
  case a of
    Is{} -> True
    IsNot{} -> True
    In{} -> True
    NotIn{} -> True
    Eq{} -> True
    Lt{} -> True
    LtEq{} -> True
    Gt{} -> True
    GtEq{} -> True
    NotEq{} -> True
    _ -> False

-- | Retrieve the information for a given operator from the operator table.
lookupOpEntry :: BinOp a -> [OpEntry] -> OpEntry
lookupOpEntry op =
  go (op $> ())
  where
    go op [] = error $ show op <> " not found in operator table"
    go op (x:xs)
      | sameOperator (x ^. opOperator) op = x
      | otherwise = go op xs