{-# LANGUAGE UnicodeSyntax, OverlappingInstances, UndecidableInstances, Arrows, FlexibleInstances, TypeSynonymInstances, CPP, PatternGuards #-}

module Editing.Parse (commandsP, finalCommandP) where

import qualified Cxx.Parse
import qualified Cxx.Basics
import qualified Cxx.Operations
import qualified Parsers as P
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty((:|)))
import Control.Category (Category, (.), id)
import Control.Arrow (Arrow, (>>>), first, second, arr, ArrowChoice(..), returnA)
import Data.Generics (DataType, Constr, toConstr, Data, dataTypeOf)
import Parsers (choice, eof, (<|>), (<?>), symbols, char, anySymbol, lookAhead, notFollowedBy, many1Till, optParser, try, many, satisfy, spaces)
import Util ((<<), liftA2, Ordinal(..), apply_if, cardinals, plural, indefinite, neElim)
import Cxx.Basics (DeclaratorId)
import Request (EvalOpt)

import Prelude hiding ((.), id, and)
import Prelude.Unicode
import Editing.Basics
import Editing.Commands

data Terminators = Terminators { term_eof :: Bool, term_keywords :: [String], and_conts :: [String] } deriving Eq
  -- term_eof states whether eof is a valid termination of a directly preceding verbatim stings.
  -- term_keywords lists keywords that should terminate directly preceding verbatim strings.
  -- and_conts lists keywords that should terminate directly preceding "and"-lists (when appearing after "and ").

data Parser a b = Parser { terminators :: Terminators, _p :: (Terminators → a → P.Parser Char (Either String b)) }

commit :: Parser a b → Parser a b
commit (Parser t f) = Parser t $ \t' → P.commit . f t'

instance Category Parser where
  id = Parser (Terminators True [] []) $ const $ return . return
  p' . Parser (Terminators b t na) f =
    Parser (Terminators (b ∧ term_eof (terminators p')) (if null t then term_keywords $ terminators p' else t)
        (if null t then and_conts $ terminators p' else na))
     $ \(Terminators b'' t'' a) x → do
      let (Parser (Terminators b' t' na') f') = p'
        -- Todo: This match is delayed for a reason, I think. Document that reason.
      u ← f (Terminators (b' ∧ b'') (if b' then t' ++ t'' else t') (if b' then a++na' else na')) x
      case u of
        Left e → return $ Left e
        Right u' → f' (Terminators b'' t'' a) u'
  -- I suspect this composition might not actually be associative. Would be neat to check in Coq.

instance Arrow Parser where
  arr f = Parser (Terminators True [] []) $ \_ → return . return . f
  first (Parser ac f) = Parser ac $ \y (b, d) → fmap (fmap (\c' → (c', d))) (f y b)
  second (Parser ac f) = Parser ac $ \y (d, b) → fmap (fmap (\c' → (d, c'))) (f y b)

instance ArrowChoice Parser where
  left (Parser t p) = Parser t $ \t' x →
    case x of
      Left y → fmap Left `fmap` p t' y
      Right y → return $ Right $ Right y
  right (Parser t p) = Parser t $ \t' x →
    case x of
      Left y → return $ Right $ Left y
      Right y → fmap Right `fmap` p t' y

class Parse a where parse :: Parser x a
class ParsePlural a where parsePlural :: Parser x a

kwd :: [String] → Parser a String
kwd s = Parser (Terminators False s []) $ \(Terminators b _ _) _ → fmap Right $ try $
  choice (try `fmap` symbols `fmap` s) << apply_if b (eof <|>) (P.char_unit ' ')

label :: String → Parser a b → Parser a b
label s (Parser t f) = Parser t $ \l x → f l x <?> s

(<||>) :: Parser a b → Parser a b → Parser a b
Parser (Terminators b t a) f <||> Parser (Terminators b' t' a') f' =
  Parser (Terminators (b ∨ b') (t ++ t') (a ++ a')) $ \y x → f y x <|> f' y x

named_characters :: [(String, String)]
named_characters = [("comma", ","), ("space", " "), ("colon", ":"), ("semicolon", ";"), ("ampersand", "&"), ("tilde", "~"), ("slash", "/"), ("backslash", "\\"), ("asterisk", "*"), ("caret", "^"), ("period", "."), ("dot", "."), ("ellipsis", "...")]

instance Parse String where
  parse = label "verbatim string" $ (parsePlural <||>) $ (select cs <||>) $
    Parser (Terminators False [] []) $ \t _ → quoted <|> unquoted t
   where
    quoted = char '`' >> fmap Right (many $ satisfy (/= '`')) << char '`' << spaces
    unquoted t = fmap (Right . toList . fst) $ many1Till (P.silent anySymbol) $ try $ apply_if (term_eof t) (eof <|>) $ lookAhead
      (choice ((\k → try $ symbols (' ': k) >> (eof <|> P.char_unit ' ')) `fmap` term_keywords t)) >> P.char_unit ' '
    cs :: [([String], String)]
    cs = map (\(x, y) → ([x, indefinite x], y)) named_characters

instance ParsePlural String where
  parsePlural = label "verbatim string" $ select $ map (first ((:[]) . plural)) named_characters

instance Parse a ⇒ Parse (AndList a) where
  parse = liftA2 (:|) parse ((and parse >>> arr (toList . andList)) <||> arr (const [])) >>> arr AndList

pzero :: Parser x a
pzero = Parser (Terminators False [] []) $ \_ _ → P.pzero

and :: Parser x a → Parser x a
and (Parser (Terminators _ t _) p) = Parser (Terminators False ["and"] t) $
  \t' x → try $ do
    symbols "and "
    notFollowedBy (choice $ try `fmap` symbols `fmap` and_conts t')
    p t' x

instance (Parse a, Parse b) ⇒ Parse (Either a b) where parse = (parse >>> arr Left) <||> (parse >>> arr Right)
instance (ParsePlural a, ParsePlural b) ⇒ ParsePlural (Either a b) where
  parsePlural = (parsePlural >>> arr Left) <||> (parsePlural >>> arr Right)

select :: [([String], a)] → Parser x a
select = foldl1 (<||>) . map (\(s, r) → if null s then arr (const r) else kwd s >>> arr (const r))

optional :: Parser a b → Parser a ()
optional p = (p >>> arr (const ())) <||> arr (const ())

option :: Parser a b → Parser a (Maybe b)
option p = (p >>> arr Just) <||> arr (const Nothing)

auto1 :: Parse a ⇒ (a → b) → Parser x b
auto1 f = parse >>> arr f

auto2 :: (Parse a, Parse b) ⇒ (a → b → c) → Parser x c
auto2 f = liftA2 f parse parse

till, begin, end_kwds :: [String]
till = ["till", "until"]
begin = ["beginning", "begin", "front", "start"]
end_kwds = ["end", "back"]

instance Parse a ⇒ Parse (Ranked a) where parse = auto2 Ranked <||> auto1 Sole

instance Parse Side where parse = select [(["before"], Before), (["after"], After)]

instance Parse (AndList Side) where
  parse =
    (kwd ["around"] >>> arr (const $ AndList $ Before :| [After])) <||>
    (liftA2 (:|) parse ((and parse >>> arr (toList . andList)) <||> arr (const [])) >>> arr AndList)

instance Parse RelativeBound where
  parse = select [(end_kwds, Back), (begin, Front)] <||> auto2 RelativeBound

instance Parse Ordinal where
  parse = label "ordinal" $ (>>> arr Ordinal) $ proc _ → do
    optional $ kwd ["the"] -< ()
    (select [(["last"], -1), (["first"], 0)] -< ()) <||> do
     n ← select $ fmap (\n → ([show (Ordinal n)], n)) [1..9] -< ()
     b ← select [(["last"], True), ([], False)] -< ()
     returnA -< if b then - n - 1 else n

parseSmallPositiveCardinal :: Parser a Int
parseSmallPositiveCardinal = select $ map (\(x,y) → ([x {-, show y-}], y)) $ tail $ zip cardinals [0..]

instance Parse OccurrencesClause where
  parse = label "ordinal" $ (>>> arr OccurrencesClause) $  -- Todo: FIx inappropriate label.
    (optional (kwd ["the"]) >>> kwd ["first"] >>> parseSmallPositiveCardinal >>> arr (\n → fmap Ordinal $ 0 :| [1 .. n-1])) <||>
    (optional (kwd ["the"]) >>> kwd ["last"] >>> parseSmallPositiveCardinal >>> arr (\n → fmap Ordinal $ (-1) :| [-n .. -2])) <||>
    auto1 return

everything_kwds :: [String]
everything_kwds = ["everything", "code"]

instance Parse a ⇒ Parse (EverythingOr a) where
  parse = select [(everything_kwds, Everything)] <||> auto1 NotEverything

relative :: Parser a (Relative a)
relative = proc a → do x ← parse -< (); y ← parse -< (); returnA -< Relative a x y
  <||> do b ← parse -< (); returnA -< Between a b
  <||> do returnA -< Absolute a

instance Parse a ⇒ Parse (In a) where parse = auto2 In

instance Parse Bound where parse = select [(begin, front), (end_kwds, back)] <||> auto2 Bound

instance Parse Betw where
  parse = (kwd ["between"] >>>) $ proc _ → do
      Wrapping b a ← select namedWrappings -< ()
      returnA -< Betw (Bound Nothing $ NotEverything $ Sole $ Right b) (RelativeBound Nothing $ Absolute $ NotEverything $ Sole $ Right a)
    <||> do
      y ← parse -< ()
      do
        rank' ← and parse -< (); s ← parse -< ()
        returnA -< Betw (Bound Nothing $ NotEverything $ Ranked y s) $ RelativeBound Nothing $ Absolute $ NotEverything $ Ranked rank' s
       <||> do
        x ← parse -< (); v ← and parse -< ()
        returnA -< Betw (Bound Nothing (NotEverything $ Ranked y x)) v
    <||> do liftA2 Betw parse (and parse) -< ()

relative_everything_orA :: Parser y (Relative (EverythingOr a))
relative_everything_orA =
    (kwd till >>> auto1 (Between Everything . Betw front))
  <||> liftA2 FromTill (kwd ["from"] >>> parse) ((kwd till >>> parse) <||> arr (const Back))
  <||> (kwd everything_kwds >>>
    (liftA2 (\x → Between Everything . Betw x) (kwd ["from"] >>> parse) (kwd till >>> parse)
      <||> (kwd till >>> auto1 (Between Everything . Betw front))
      <||> (arr (const Everything) >>> relative)))
  <||> (proc _ → do
    kwd ["before"] -< ()
    y ← auto1 NotEverything -< ()
    x ← do z ← kwd till >>> parse -< (); returnA -< Betw (Bound (Just Before) y) z
      <||> do returnA -< Betw front $ RelativeBound (Just Before) $ Absolute y
    returnA -< Between Everything x)
  <||> auto1 (Between Everything)
  <||> proc _ → do
    x ← kwd ["after"] >>> parse -< ()
    y ← (kwd till >>> parse -< ()) <||> (returnA -< Back)
    returnA -< Between Everything (Betw (Bound (Just After) x) y)

instance Parse (Relative Substr) where
  parse = (relative_everything_orA <||>) $ parse >>> proc x → do
      u ← kwd till >>> parse -< ()
      returnA -< Between Everything $ Betw (Bound (Just Before) $ NotEverything x) u
    <||> (relative -< NotEverything x)

instance Parse a ⇒ Parse (Relative a) where parse = parse >>> relative

instance Parse (Relative (EverythingOr (Rankeds (Either Cxx.Basics.Findable String)))) where
  parse = (relative_everything_orA <||>) $ (parse >>>) $ proc x → case x of
    Rankeds (AndList l) s | (OccurrencesClause l', []) ← neElim l, (r, []) ← neElim l' → do
      -- Writing this with view patterns causes GHC to panic..
        u ← kwd till >>> parse -< ()
        returnA -< Between Everything (Betw (Bound (Just Before) $ NotEverything $ Ranked r s) u)
      <||> (relative -< NotEverything x)
    Sole' s → do
        u ← kwd till >>> parse -< ()
        returnA -< Between Everything (Betw (Bound (Just Before) $ NotEverything $ Sole s) u)
      <||> (relative -< NotEverything x)
    _ → (relative -< NotEverything x)

instance Parse ImplicitDeclarationOf where parse = auto1 ImplicitDeclarationOf
instance Parse ImplicitBodyOf where parse = auto1 ImplicitBodyOf
instance ParsePlural ImplicitBodyOf where parsePlural = pzero
instance ParsePlural ImplicitDeclarationOf where parsePlural = pzero

instance Parse Cxx.Basics.Findable where
  parse = (parsePlural <||>) $
    (kwd ["declaration"] >>> kwd ["of"] >>> auto1 Cxx.Basics.DeclarationOf) <||>
    (kwd ["body"] >>> kwd ["of"] >>> auto1 Cxx.Basics.BodyOf) <||>
    label "production-name" (
      auto1 Cxx.Basics.FindableDataType <||>
      auto1 Cxx.Basics.FindableConstr <||>
      (kwd ["loop"] >>> arr (const (Cxx.Basics.FindableDataType (dataTypeOf (undefined :: Cxx.Basics.IterationStatement))))) <||>
      (kwd ["constructor", "ctor"] >>> arr (const Cxx.Basics.Constructor)) <||>
      (kwd ["destructor", "dtor"] >>> arr (const Cxx.Basics.Destructor)) <||>
      (kwd ["conversion-function"] >>> arr (const Cxx.Basics.ConversionFunction)) <||>
      (kwd ["parameter-declaration"] >>> arr (const Cxx.Basics.FindableParameterDeclaration)) <||>
      (kwd ["template-parameter"] >>> arr (const Cxx.Basics.TemplateParameter)) <||>
      (kwd ["template-argument"] >>> arr (const Cxx.Basics.TemplateArgument)))

instance ParsePlural Cxx.Basics.Findable where
  parsePlural =
    (label "\"declaration\"" (kwd ["declarations"]) >>> kwd ["of"] >>> auto1 Cxx.Basics.DeclarationOf) <||>
    (label "\"body\"" (kwd ["bodies"]) >>> kwd ["of"] >>> auto1 Cxx.Basics.BodyOf) <||>
    label "production-name" (
      (parsePlural >>> arr Cxx.Basics.FindableDataType) <||>
      (parsePlural >>> arr Cxx.Basics.FindableConstr) <||>
      (kwd ["loops"] >>> arr (const (Cxx.Basics.FindableDataType (dataTypeOf (undefined :: Cxx.Basics.IterationStatement))))) <||>
      (kwd ["constructors", "ctors"] >>> arr (const Cxx.Basics.Constructor)) <||>
      (kwd ["destructors", "dtors"] >>> arr (const Cxx.Basics.Destructor)) <||>
      (kwd ["conversion-functions"] >>> arr (const Cxx.Basics.ConversionFunction)) <||>
      (kwd ["parameter-declarations"] >>> arr (const Cxx.Basics.FindableParameterDeclaration)) <||>
      (kwd ["template-parameters"] >>> arr (const Cxx.Basics.TemplateParameter)) <||>
      (kwd ["template-arguments"] >>> arr (const Cxx.Basics.TemplateArgument)))

class Constructor a where to_constr :: a → Constr
instance Data a ⇒ Constructor a where to_constr x = toConstr x
instance Constructor b ⇒ Constructor (a → b) where to_constr f = to_constr $ f undefined

instance Parse DataType where
  parse = parsePlural <||> select (map (\t → ([show $ Cxx.Basics.FindableDataType t], t)) Cxx.Operations.findable_productions)
instance ParsePlural DataType where
  parsePlural = select $ map (\t → ([show (Cxx.Basics.FindableDataType t) ++ "s"], t)) Cxx.Operations.findable_productions

parseableConstructors :: [Constr]
parseableConstructors =
#define P(n) to_constr Cxx.Basics.n
  [ P(BooleanLiteral), P(PointerLiteral), P(IfStatement), P(SwitchStatement), P(WhileStatement), P(DoWhileStatement)
  , P(ForStatement), P(BreakStatement), P(ContinueStatement), P(ReturnStatement), P(GotoStatement) ]
#undef P

instance Parse Constr where
  parse = parsePlural <||> select (map (\c → ([show $ Cxx.Basics.FindableConstr c], c)) parseableConstructors)
instance ParsePlural Constr where
  parsePlural = select $ map (\c → ([show (Cxx.Basics.FindableConstr c) ++ "s"], c)) parseableConstructors

instance Parse Position where
  parse = (select [(begin, Before), (end_kwds, After)] >>> arr (flip Position $ flip In Nothing $ Absolute Everything)) <||> auto2 Position

instance (Parse a, ParsePlural a) ⇒ Parse (Rankeds a) where
  parse =
    (parsePlural >>> arr All) <||> (kwd ["all"] >>> ((kwd ["except", "but"] >>> auto2 AllBut) <||> auto1 All))
    <||> (kwd ["any", "every", "each"] >>> auto1 All) <||> auto2 Rankeds <||> auto1 Sole'

instance Parse InClause where parse = kwd ["in"] >>> auto1 InClause

instance Parse AppendPositionsClause where
  parse = auto1 AppendIn <||> auto1 NonAppendPositionsClause
instance Parse PrependPositionsClause where
  parse = auto1 PrependIn <||> auto1 NonPrependPositionsClause

instance Parse Substrs where parse = auto1 Substrs
instance Parse MakeSubject where parse = auto1 MakeSubject

instance Parse PositionsClause where
  parse = (kwd ["at"] >>> select [(begin, Before), (end_kwds, After)] >>> arr (\ba → PositionsClause (and_one ba) $ Substrs $ and_one $ flip In Nothing $ Absolute Everything)) <||> auto2 PositionsClause

instance Parse Replacer where
  parse = liftA2 ReplaceOptions parse (wb >>> parse) <||> liftA2 Replacer parse (wb >>> parse)
    where wb = kwd ["with", "by"]

instance Parse Changer where
  parse = liftA2 ChangeOptions parse (wb >>> parse) <||> liftA2 Changer parse (wb >>> parse)
    where wb = kwd ["to"]

instance Parse Eraser where
  parse = liftA2 EraseAround parse (zw $ kwd ["around"] >>> parse >>> arr Around) <||>
      auto1 EraseOptions <||> auto1 EraseText
    where zw (Parser (Terminators _ x y) z) = Parser (Terminators True x y) z
      -- This use of 'zw' is a dirty hack.
instance Parse Mover where parse = liftA2 Mover parse (kwd ["to"] >>> parse)
instance Parse [EvalOpt] where parse = Parser (Terminators False [] []) $ \_ _ → optParser
instance Parse a ⇒ Parse (Around a) where parse = kwd ["around"] >>> auto1 Around
instance Parse UsePattern where parse = auto1 UsePattern
instance Parse (Relative UsePattern) where parse = parse >>> relative

instance Parse UseClause where parse = auto1 UseOptions <||> (parse {- >>> relative-} >>> arr UseString)

namedWrappings :: [([String], Wrapping)]
namedWrappings =
  [ (["curlies", "braces", "curly brackets"], Wrapping "{" "}")
  , (["parentheses", "parens", "round brackets"], Wrapping "(" ")")
  , (["square brackets"], Wrapping "[" "]")
  , (["angle brackets"], Wrapping "<" ">")
  , (["single quotes"], Wrapping "'" "'")
  , (["double quotes"], Wrapping "\"" "\"")
  , (["spaces"], Wrapping " " " ") ]

instance Parse Wrapping where
  parse = label "wrapping description" $ select namedWrappings <||> liftA2 Wrapping parse (and parse)

instance Parse Insertee where
  parse = label "wrapping description" (select namedWrappings >>> arr WrapInsert) <||>
    liftA2 (\x y → case y of Nothing → SimpleInsert x; Just y' → WrapInsert (Wrapping x y')) parse (option (and parse))

instance Parse a ⇒ Parse (Maybe a) where parse = (parse >>> arr Just) <||> arr (const Nothing)

instance Parse Command where
  parse = label "edit command" $
    (kwd ["insert", "add"] >>> commit ((parse >>> arr (Use `fmap` fmap UseOptions)) <||> auto2 Insert)) <||>
    (kwd ["append"] >>> commit (auto2 Append)) <||>
    (kwd ["prepend"] >>> commit ((parse >>> arr (Use `fmap` fmap UseOptions)) <||> auto2 Prepend)) <||>
    (kwd ["erase", "remove", "kill", "cut", "omit", "delete", "drop"] >>> commit (auto1 Erase)) <||>
    (kwd ["replace"] >>> commit (auto1 Replace)) <||>
    (kwd ["change"] >>> commit (auto1 Change)) <||>
    (kwd ["make"] >>> commit (auto2 Make)) <||>
    (kwd ["use"] >>> commit (auto1 Use)) <||>
    (kwd ["fix"] >>> commit (arr (const Fix))) <||>
    (kwd ["move"] >>> commit (auto1 Move)) <||>
    (kwd ["swap"] >>> commit (liftA2 Swap parse (option (kwd ["with"] >>> parse))))

instance Parse Cxx.Basics.MakeDeclaration where
  parse = Parser (Terminators False ["a", "an", "const"] []) $ \_ _ → Right `fmap` Cxx.Parse.makeDeclParser

instance Parse DeclaratorId where
  parse = Parser (Terminators False [] []) $ \_ _ → Right `fmap` Cxx.Parse.declaratorIdParser

instance Parse MakeClause where parse = auto2 MakeClause

instance Parse FinalCommand where
  parse = label "edit command" $
    (kwd ["show", "display"] >>> commit (option parse >>> arr Show)) <||>
    (kwd ["identify"] >>> commit (auto1 Identify)) <||>
    (kwd ["parse"] >>> arr (const Parse)) <||>
    (kwd ["diff"] >>> arr (const Diff)) <||>
    (((optional (kwd ["try"]) >>> kwd ["again"]) <||> kwd ["run"]) >>> arr (const Run))

instance Parse ([Command], Maybe FinalCommand) where
  parse = liftA2 (,) (parse >>> arr (toList . andList)) (option $ and parse)

uncool :: Parser () a → Terminators → P.Parser Char (Either String a)
uncool (Parser _ f) t = f t ()

commandsP :: P.Parser Char (Either String ([Command], Maybe FinalCommand))
commandsP = uncool parse $ Terminators True [] []

finalCommandP :: P.Parser Char (Either String FinalCommand)
finalCommandP = uncool parse $ Terminators True [] []