{-# LANGUAGE UnicodeSyntax, Rank2Types, FlexibleInstances, UndecidableInstances, RelaxedPolyRec, PatternGuards, OverlappingInstances, CPP #-}

module Cxx.Show (pretty_with_precedence, show_simple, show_plural, show_pretty, Highlighter, Highlightable(..), noHighlighting, dataType_productionName, dataType_abbreviated_productionName) where

import qualified Data.List as List
import qualified Data.Char as Char
import Util ((.), strip, orElse)
import Control.Applicative (Applicative(..))
import Data.Generics (cast, Data, gmapQr, ext1Q, dataTypeName, Constr, DataType)
import Data.Foldable (toList)

import Cxx.Basics
import Prelude hiding ((.))
import Prelude.Unicode

instance Show Chunk where
  show (CharLiteral c) = "'" ++ c ++ "'"
  show (StringLiteral' s) = "\"" ++ s ++ "\""
  show (RawStringLiteral x y) = "R\"" ++ x ++ "(" ++ y ++ ")" ++ x ++ "\""
  show (Plain s) = s
  show (Parens c) = "(" ++ show c ++ ")"
  show (Curlies c) = "{" ++ show c ++ "}"
  show (Squares c) = "[" ++ show c ++ "]"
  show (MultiComment s) = "/*" ++ s ++ "*/"
  show (SingleComment s) = "//" ++ s
  showList l s = concat (show . l) ++ s

type PrettyA a = PrettyOptions → a
data ExtraParenOpts = NoExtraParens | ExtraParens | ChildrenExtraParens

data Highlightable = Keyword | CurlyParen | RoundParen | Literal
type Highlighter = Highlightable → (String, String)

wrap :: (String, String) → String → String
wrap (x, y) s = x ++ s ++ y

noHighlighting :: Highlighter
noHighlighting = const ("", "")

data PrettyOptions = PrettyOptions
  { extra_parentheses :: ExtraParenOpts
  , highlighter :: Highlighter
  }

camel_components :: String → [String]
camel_components s = case s of
  (x:xs) → let (y, z) = span Char.isLower xs in (Char.toLower x : y) : camel_components z
  _ → []

camel_to_prod :: String → String
camel_to_prod = concat . List.intersperse "-" . camel_components

abbreviations :: [(String, String)]
abbreviations =
  [ ("expression", "expr")
  , ("statement", "stmt")
  , ("initializer", "init")
  , ("assignment", "ass")
  , ("primary", "prim")
  , ("qualified", "qual")
  , ("qualifier", "qual")
  , ("unqualified", "unqual")
  , ("destructor", "dtor")
  , ("operator", "op")
  , ("definition", "def")
  , ("function", "func")
  , ("specifier", "spec")
  , ("specification", "spec")
  , ("declaration", "decl'ion")
  , ("declarator", "decl'or")
  , ("elaborated", "elab")
  , ("enumerator", "enum")
  , ("abstract", "abs")
  , ("member", "mem")
  , ("translation", "trans")
  , ("parameter", "param")
  , ("parameters", "params")
  , ("argument", "arg")
  , ("arguments", "args")
  , ("identifier", "ident")
  , ("lambda", "λ") ]

abbreviate :: String → String
abbreviate w = lookup w abbreviations `orElse` w

dataType_to_camelProd :: DataType → String
dataType_to_camelProd = reverse . takeWhile (≠ '.') . reverse . dataTypeName

dataType_productionName :: DataType → String
dataType_productionName = camel_to_prod . dataType_to_camelProd

dataType_abbreviated_productionName :: DataType → String
dataType_abbreviated_productionName =
  concat . List.intersperse "-" . map abbreviate . camel_components . dataType_to_camelProd

constr_productionName :: Constr → String
constr_productionName = camel_to_prod . show

instance Show Findable where
  show (DeclarationOf d) = "free declaration of " ++ strip (show d)
  show (BodyOf d) = "body of " ++ strip (show d)
  show (FindableDataType dt) = dataType_productionName dt
  show (FindableConstr c) = constr_productionName c
  show Constructor = "free constructor"
  show Destructor = "free destructor"
  show ConversionFunction = "free conversion-function"
  show FindableParameterDeclaration = "parameter-declaration"
  show TemplateParameter = "template-parameter"
  show TemplateArgument = "template-argument"

show_plural :: Findable → String
show_plural (DeclarationOf did) = "free declarations of " ++ strip (show did)
show_plural (BodyOf did) = "bodies of " ++ strip (show did)
show_plural f = show f ++ "s"

-- SingleTokenType instances.

instance SingleTokenType AssignmentOperator where
  token_class_name _ = "binary operator"
  token AssignmentOperator_Assign = Right Is
  token AssignmentOperator_MultiplyAssign = Right StarIs
  token AssignmentOperator_DivideAssign = Right SlashIs
  token AssignmentOperator_PercentAssign = Right PercentIs
  token AssignmentOperator_PlusAssign = Right PlusIs
  token AssignmentOperator_MinusAssign = Right MinusIs
  token AssignmentOperator_RightShiftAssign = Right CloseTwoAnglesIs
  token AssignmentOperator_LeftShiftAssign = Right OpenTwoAnglesIs
  token AssignmentOperator_BitAndAssign = Right AmperIs
  token AssignmentOperator_BitXorAssign = Right HatIs
  token AssignmentOperator_BitOrAssign = Right PipeIs
  token AssignmentOperator_AltBitAndAssign = Left "and_eq"
  token AssignmentOperator_AltBitXorAssign = Left "xor_eq"
  token AssignmentOperator_AltBitOrAssign = Left "or_eq"
instance SingleTokenType ClassKey where
  token_class_name _ = "class-key"
  token Class = Left "class"; token Struct = Left "struct"; token Union = Left "union"
instance SingleTokenType MemberOperator where
  token_class_name _ = "binary-operator"
  token MemberPeriod = Right Period; token MemberArrow = Right Arrow
instance SingleTokenType UnaryOperator where
  token_class_name _ = "unary operator"
  token PrefixDecrement = Right MinusMinus; token PrefixIncrement = Right PlusPlus
  token Dereference' = Right Star; token AddressOf' = Right Amper
  token Negate' = Right MinusTok; token Positive' = Right PlusTok
  token LogicalNot' = Right Exclamation; token AltLogicalNot = Left "not"
  token Complement' = Right Tilde; token AltComplement = Left "compl"
instance SingleTokenType PmOperator where
  token_class_name _ = "binary operator"
  token PmOperator_MemPtr = Right PeriodStar; token PmOperator_PtrMemPtr = Right ArrowStar
instance SingleTokenType MultiplicativeOperator where
  token_class_name _ = "binary operator"
  token MultiplicativeOperator_Multiply = Right Star
  token MultiplicativeOperator_Divide = Right Slash
  token MultiplicativeOperator_Modulo = Right Percent
instance SingleTokenType AdditiveOperator where
  token_class_name _ = "binary operator"
  token AdditiveOperator_Plus = Right PlusTok
  token AdditiveOperator_Minus = Right MinusTok
instance SingleTokenType ShiftOperator where
  token_class_name _ = "binary operator"
  token ShiftOperator_Left = Right OpenTwoAngles; token ShiftOperator_Right = Right CloseTwoAngles
instance SingleTokenType RelationalOperator where
  token_class_name _ = "binary operator"
  token RelationalOperator_Less = Right OpenAngle; token RelationalOperator_Greater = Right CloseAngle
  token RelationalOperator_LessEqual = Right OpenAngleIs; token RelationalOperator_GreaterEqual = Right CloseAngleIs
instance SingleTokenType EqualityOperator where
  token_class_name _ = "binary operator"
  token EqualityOperator_Equal = Right IsIs
  token EqualityOperator_Unequal = Right ExclamationIs
  token EqualityOperator_AltUnequal = Left "not_eq"
instance SingleTokenType NewStyleCast where
  token_class_name _ = "new-style cast"
  token StaticCast = Left "static_cast"; token DynamicCast = Left "dynamic_cast"
  token ReinterpretCast = Left "reinterpret_cast"; token ConstCast = Left "const_cast"
instance SingleTokenType BasicType where
  token_class_name _ = "basic type"
  token Char' = Left "char"; token Wchar = Left "wchar_t"
  token Char32 = Left "char32_t"; token Char16 = Left "char16_t"
  token Void = Left "void"; token Bool' = Left "bool"; token Int' = Left "int"
  token Float' = Left "float"; token Double' = Left "double"
instance SingleTokenType StorageClassSpecifier where
  token_class_name _ = "storage-class-specifier"
  token Register = Left "register"; token Static = Left "static"
  token ThreadLocal = Left "thread_local"; token Extern = Left "extern"
  token Mutable = Left "mutable"
instance SingleTokenType FunctionSpecifier where
  token_class_name _ = "function-specifier"
  token Inline = Left "inline"; token Virtual = Left "virtual"; token Explicit = Left "explicit"
instance SingleTokenType Sign where
  token_class_name _ = "signedness"
  token Signed = Left "signed"; token Unsigned = Left "unsigned"
instance SingleTokenType LengthSpec where
  token_class_name _ = "integer length specifier"
  token LongSpec = Left "long"; token ShortSpec = Left "short"
instance SingleTokenType CvQualifier where
  token_class_name _ = "cv-qualifier"; token Const = Left "const"; token Volatile = Left "volatile"
instance SingleTokenType RefQualifier where
  token_class_name _ = "ref-qualifier"
  token Lvalue = Right Amper; token Rvalue = Right AmperAmper
instance SingleTokenType AccessSpecifier where
  token_class_name _ = "access-specifier"
  token Private = Left "private"; token Protected = Left "protected"; token Public = Left "public"

-- Show instances.

instance SingleTokenType t ⇒ Show t where show = either id show . token
instance Show White where show (White w) = w

pretty :: forall a. (Data a) ⇒ a → PrettyOptions → String
pretty =
  ext1Q  (\x → let au = gmapQr (<++>) (pure "") pretty x in case () of
#define KWD(t) ()| Just s ← cast x → \o → wrap (highlighter o Keyword) (show (s :: t));
    KWD(KwdSizeof) KWD(KwdIf) KWD(KwdNew) KWD(KwdAlignof) KWD(KwdTypeid) KWD(KwdTemplate) KWD(KwdClass) KWD(KwdFor) KWD(KwdExtern) KWD(KwdWhile) KWD(KwdDo) KWD(KwdGoto) KWD(KwdContinue) KWD(KwdElse) KWD(KwdAuto) KWD(KwdDefault) KWD(KwdSwitch) KWD(KwdCase) KWD(KwdBreak) KWD(KwdNamespace) KWD(KwdTypedef) KWD(KwdThis) KWD(KwdFriend) KWD(KwdDelete) KWD(KwdStaticAssert) KWD(KwdConstexpr) KWD(KwdExport) KWD(KwdThrow) KWD(KwdUsing) KWD(KwdTry) KWD(KwdDecltype) KWD(KwdAsm) KWD(KwdCatch) KWD(KwdStruct) KWD(KwdEnum) KWD(KwdTypename) KWD(KwdOperator) KWD(KwdReturn) KWD(NewStyleCast) KWD(FunctionSpecifier) KWD(StorageClassSpecifier) KWD(CvQualifier) KWD(LengthSpec) KWD(BasicType) KWD(ClassKey) KWD(KwdMutable) KWD(KwdInline) KWD(KwdVirtual) KWD(KwdThreadLocal)
#undef KWD

    ()| Just s ← cast x → \o → wrap (highlighter o Literal) (show (s :: Literal))

    ()| Just s ← cast x → \o → wrap (highlighter o CurlyParen) (show (s :: OpenCurly_))
    ()| Just s ← cast x → \o → wrap (highlighter o CurlyParen) (show (s :: CloseCurly_))

    ()| Just s ← cast x → \o → wrap (highlighter o RoundParen) (show (s :: OpenParen_))
    ()| Just s ← cast x → \o → wrap (highlighter o RoundParen) (show (s :: CloseParen_))

#define SHOW(t) ()| Just s ← cast x → pure $ show (s :: t);
    SHOW(SemicolonOperator) SHOW(CommaOp) SHOW(ScopeRes) SHOW(UnaryOperator) SHOW(AssignmentOperator) SHOW(RelationalOperator) SHOW(QuestionOp) SHOW(ColonOp) SHOW(IncDecOperator) SHOW(AdditiveOperator) SHOW(MultiplicativeOperator) SHOW(PmOperator)  SHOW(MemberOperator) SHOW(IsOperator) SHOW(Tilde_) SHOW(Sign) SHOW(OpenSquare_) SHOW(CloseSquare_) SHOW(LeftShiftOp) SHOW(OpenAngle_) SHOW(CloseAngle_) SHOW(AccessSpecifier) SHOW(StarOperator) SHOW(AndOperator) SHOW(LogicalAndOperator) SHOW(LogicalOrOperator) SHOW(ExclusiveOrOperator) SHOW(InclusiveOrOperator) SHOW(EqualityOperator) SHOW(ShiftOperator) SHOW(RefQualifier) SHOW(StringLiteral) SHOW(KwdZero) SHOW(ArrowOp) SHOW(Ellipsis_) SHOW(EncodingPrefix) SHOW(AmperProd)
#undef SHOW
    ()| Just (Identifier s (White w)) ← cast x → pure $ s ++ w
    ()| Just s ← cast x → pure s
    ()| Just (White w) ← cast x → pure w
    ()| Just (IfStatement w c s me) ← cast x → pretty w <++> pretty c <++> extraCurliesStmt s <++> maybe (pure "") (\(v, s') → pretty v <++> extraCurliesStmt s') me
    ()| Just (UnaryExpression _ _) ← cast x → extraParentheses au
    ()| Just (UnaryExpression_Sizeof_UnaryExpression _ _) ← cast x → extraParentheses au
    ()| Just (NewExpression _ _ _ _ _) ← cast x → extraParentheses au
    ()| Just (DeleteExpression _ _ _ _) ← cast x → extraParentheses au
    ()| Just (ConditionalExpression _ _ _ _ _) ← cast x → extraParentheses au
    ()| Just (LogicalOrExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (CastExpression_Cast _ _) ← cast x → extraParentheses au
    ()| Just (PmExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (MultiplicativeExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (AdditiveExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (ShiftExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (RelationalExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (EqualityExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (AndExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (ExclusiveOrExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (InclusiveOrExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (LogicalAndExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (AssignmentExpression _ _ _) ← cast x → extraParentheses au
    ()| Just (PostfixExpression_Squared _ _) ← cast x → extraParentheses au
    ()| Just (PostfixExpression_FunctionCall _ _) ← cast x → extraParentheses au
    ()| Just (PostfixExpression_Conversion _ _) ← cast x → extraParentheses au
    ()| Just (PostfixExpression_Member _ _ _ _) ← cast x → extraParentheses au
    ()| Just (PostfixExpression_IncDec _ _) ← cast x → extraParentheses au
    ()| Just (Expression_Comma _ _ _) ← cast x → extraParentheses au
    ()| Just (ThrowExpression _ (Just _)) ← cast x → extraParentheses au
    ()| otherwise → au
   ) (\(Enclosed x) → prettyEnclosed $ pretty x)

  -- This pretty is very slow, probably due to all the list concatenations. Use the ShowS trick.

extraCurliesStmt :: Statement → PrettyA String
extraCurliesStmt (Statement_CompoundStatement s) = pretty s
extraCurliesStmt s = extraCurlies (pretty s)

pretty_with_precedence :: Data a ⇒ a → String
pretty_with_precedence e = pretty e PrettyOptions{ extra_parentheses = ChildrenExtraParens, highlighter = noHighlighting }

show_simple :: Data a ⇒ a → String
show_simple x = pretty x PrettyOptions{ extra_parentheses = NoExtraParens, highlighter = noHighlighting }

prettyEnclosed :: PrettyA String → PrettyA String
prettyEnclosed x o | ExtraParens ← extra_parentheses o = x (o { extra_parentheses = ChildrenExtraParens })
prettyEnclosed x o = x o

show_pretty :: Data a ⇒ Bool → Highlighter → a → String
show_pretty x y z = pretty z $ PrettyOptions (if x then ChildrenExtraParens else NoExtraParens) y

extraWrapping :: String → String → PrettyA String → PrettyA String
extraWrapping open close p o | ExtraParens ← extra_parentheses o =
  open ++ reverse y ++ close ++ x where (x, y) = span (== ' ') (reverse $ p o)
extraWrapping _ _ p o = p o

extraParentheses, extraCurlies :: PrettyA String → PrettyA String
extraParentheses = extraWrapping "(" ")"
extraCurlies = extraWrapping "{ " " }"

(<++>) :: PrettyA [a] → PrettyA [a] → PrettyA [a]
(<++>) x y o = x (if not $ null $ y o then o' else o) ++ y (if not $ null $ x o then o' else o)
  where o' = o { extra_parentheses = case extra_parentheses o of ChildrenExtraParens → ExtraParens; z → z }

instance Show Literal where
  show (Literal_CharacterLiteral l w) = show l ++ show w
  show (Literal_StringLiteral l) = show l
  show (Literal_FloatingLiteral l w) = show l ++ show w; show (Literal_IntegerLiteral l w) = show l ++ show w
  show (BooleanLiteral b w) = (if b then "true" else "false") ++ show w
  show (PointerLiteral w) = "nullptr" ++ show w
instance Show CharacterLiteral where show (CharacterLiteral k s) = show k ++ '\'' : s ++ "'"
instance Show SingleStringLiteral where show (SingleStringLiteral k s) = maybe "" show k ++ '"' : s ++ "\""
instance Show StringLiteral where show (StringLiteral l) = concatMap (\(x, y) → show x ++ show y) $ toList l
instance Show IntegerLiteral where show (IntegerLiteral s) = s
instance Show CharacterLiteralKind where
  show CharacterLiteral_Plain = ""; show CharacterLiteralKind_u = "u"
  show CharacterLiteralKind_U = "U"; show CharacterLiteralKind_L = "L"
instance Show FloatingLiteral where show (FloatingLiteral s) = s
instance Show EncodingPrefix where
  show EncodingPrefix_L = "L"; show EncodingPrefix_u8 = "u8"
  show EncodingPrefix_u = "u"; show EncodingPrefix_U = "U"

instance Show DeclaratorId where show = Cxx.Show.show_simple