import Control.Applicative (Alternative (empty, many, some), asum)
import Control.Monad (ap, liftM, void)
import Data.Char (isAlpha, isSpace)
import GHC.Exts.Heap (StgTSOProfInfo)
import GHC.Internal.Base (Alternative ((<|>)))

data BExp
  = Lit Bool
  | Not BExp
  | Var String
  | And BExp BExp
  | Or BExp BExp
  deriving (Eq, Ord, Show)

-- var = ? any non empty sequence of alphabhetic characters ?
-- bexp ::= "true"
--        | "false"
--        | var
--        | "not" bexp
--        | bexp "and" bexp
--        | bexp "or" bexp

data Parser a = Parser ((Int, String) -> Either (Int, String) (a, (Int, String)))

instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
  fmap = liftM

instance Applicative Parser where
  pure a = Parser $ \s -> Right (a, s)
  (<*>) = ap

instance Monad Parser where
  Parser a >>= f = Parser $ \s -> do
    (a', s') <- a s
    let (Parser b) = f a'
    b s'

instance Alternative Parser where
  empty = Parser $ \(pos, s) -> Left (pos, "All branches exhausted")
  (Parser p1) <|> (Parser p2) = Parser $ \s -> case p1 s of
    Left err -> p2 s
    Right a -> pure a

satisfy :: (Char -> Bool) -> Parser Char
satisfy p = Parser $ \(pos, s) ->
  case s of
    "" -> Left (pos, "Empty input")
    c : (cs) ->
      if p c
        then
          pure (c, (pos + 1, cs))
        else Left (pos, "Invalid character: " ++ [c])

eof :: Parser ()
eof = Parser end
 where
  end :: (Int, String) -> Either (Int, String) ((), (Int, String))
  end s@(_, "") = pure ((), s)
  end (pos, _) = Left (pos, "EOF expected")

instance MonadFail Parser where
  fail s = Parser (\(pos, _) -> Left (pos, s))

spaces :: Parser ()
spaces = (many $ satisfy isSpace) *> pure ()

lexeme :: Parser a -> Parser a
lexeme p = do
  x <- p
  spaces
  pure x

parseString :: String -> Parser ()
parseString "" = pure ()
parseString (c : cs) = do
  satisfy (== c)
  parseString cs

lString :: String -> Parser ()
lString s = lexeme $ loop s
 where
  loop "" = pure ()
  loop (c : cs) = satisfy (== c) *> loop cs

parseBool :: Parser Bool
parseBool =
  do
    parseString "true"
    spaces
    pure True
    <|> do
      parseString "false"
      spaces
      pure False

fails :: (Alternative f) => f a -> f Bool
fails a = (False <$ a) <|> (pure True)

notFollowedBy :: (Alternative m, MonadFail m) => m a -> m b -> m a
notFollowedBy a b = do
  ra <- a
  rb <- fails b
  if rb then pure ra else fail "notFollowedBy violation"

-- notFollowedBy2 :: Parser a -> Parser ()
-- notFollowedBy2 a = do
--     a' <- a
--     Parser (\b -> )

lKeyword :: String -> Parser ()
lKeyword s = lexeme $ notFollowedBy (loop s) (satisfy isAlpha)
 where
  loop "" = pure ()
  loop (c : cs) = satisfy (== c) *> loop cs

pTrue :: Parser ()
pTrue = lKeyword "true"

pFalse :: Parser ()
pFalse = lKeyword "false"

pAnd :: Parser ()
pAnd = lKeyword "and"

pOr :: Parser ()
pOr = lKeyword "or"

pNot :: Parser ()
pNot = lKeyword "not"

pBool :: Parser Bool
pBool = (pTrue *> pure True) <|> (pFalse *> pure False)

keywords :: [String]
keywords = ["true", "false", "and", "or", "not"]

pVar :: Parser String
pVar = lexeme $ do
  s <- some $ satisfy isAlpha
  if elem s keywords
    then
      fail ""
    else pure s

-- atom :== "true"
--       |  "false"
--       |  var
--       |  not bexp

-- bexp' ::= epsilon
--         | "and" atom bexp'
--         | "or" atom bexp'
--
-- bexp ::= atom bexp'

-- delim? either, or he just does- this, yes
-- for now, yes, also assoc is not mentioned yet

lLParen :: Parser ()
lLParen = lexeme $ void $ satisfy (== '(')
lRParen :: Parser ()
lRParen = lexeme $ void $ satisfy (== '(')

parens :: Parser a -> Parser a
parens a = lLParen *> a <* lRParen

pAtom :: Parser BExp
pAtom =
  asum
    [ (pBool >>= pure . Lit)
    , (pVar >>= pure . Var)
    , (Not <$> (pNot *> pAtom))
    , -- ( :3 ) -- Invalid character: :
      parens pBExp
    ]

pBExp' :: BExp -> Parser BExp
pBExp' x =
  asum
    [ (And x <$> (pAnd *> pAtom))
    , (Or x <$> (pOr *> pAtom))
    , pure x
    ]

-- pAtom < pAnd < pOr

pBExpAnd :: BExp -> Parser BExp
pBExpAnd x =
  ( do
      y <- pAnd *> pAtom
      pBExpAnd (And x y)
  )
    <|> pure x

pBExpOr :: BExp -> Parser BExp
pBExpOr x =
  ( do
      y <- pOr *> pBExpAnd x
      pBExpOr (Or x y)
  )
    <|> pure x

pBExp :: Parser BExp
pBExp = do
  x <- pAtom
  -- pBExp' x
  pBExpOr x