module Curry.ExactPrint where

import Data.List
import Data.Maybe

import Curry.Ident
import Curry.Types
import Curry.Comment
import Curry.Position
import Curry.Span
import Curry.SpanInfo
import Curry.ExactPrintClass

import Prelude hiding ( empty )

import Debug.Trace ( trace, traceShowId )

instance ExactPrint (Module a) where
  printS (Module spi _ ps mid mex im ds) = fill $
    if null ss
      then do
        printNode ps
        printNode im
        printNode ds
      else do
        printNode ps
        printHeader
        printNode im
        printNode ds
    where
      SpanInfo _ ss = spi
      printHeader = case mex of
        Nothing -> printNode mid
        Just ex -> printNode mid >> printNode ex
  keywords (Module spi _ _ _ _ _ _) =
    if null ss then [] else ["module", "where"]
    where
      SpanInfo _ ss = spi

instance ExactPrint ExportSpec where
  printS (Exporting _ ex) = fill $ printNode ex
  keywords (Exporting _ ex) =
    ["("] ++ replicate (length ex - 1) "," ++ [")"]

instance ExactPrint Export where
  printS (Export         _ i   ) = fill $ printNode i
  printS (ExportTypeWith _ i is) = fill $ printNode i >> printNode is
  printS (ExportTypeAll  _ i   ) = fill $ printNode i
  printS (ExportModule   _ i   ) = fill $ printNode i
  keywords (Export         _ _   ) = []
  keywords (ExportTypeWith _ _ is) =
    ["("] ++ replicate (length is - 1) "," ++ [")"]
  keywords (ExportTypeAll  _ _   ) = ["(", "..", ")"]
  keywords (ExportModule   _ _   ) = ["module"]

instance ExactPrint ImportDecl where
  printS (ImportDecl _ mid _ as spec) = fill $ do
    printNode mid
    maybe empty printNode as
    maybe empty printNode spec
  keywords (ImportDecl _ _ q as _) =
    ["import"] ++
    (if q         then ["qualified"] else []) ++
    (if isJust as then ["as"]        else [])

instance ExactPrint ImportSpec where
  printS (Importing _ im) = fill $ printNode im
  printS (Hiding    _ im) = fill $ printNode im
  keywords (Importing _ im) =
              ["("] ++ replicate (length im - 1) "," ++ [")"]
  keywords (Hiding    _ im) =
    ["hiding", "("] ++ replicate (length im - 1) "," ++ [")"]

instance ExactPrint Import where
  printS (Import         _ i   ) = fill $ printNode i
  printS (ImportTypeWith _ i is) = fill $ printNode i >> printNode is
  printS (ImportTypeAll  _ i   ) = fill $ printNode i
  keywords (Import         _ _   ) = []
  keywords (ImportTypeWith _ _ is) =
    ["("] ++ replicate (length is - 1) "," ++ [")"]
  keywords (ImportTypeAll  _ _   ) = ["(", "..", ")"]

instance ExactPrint ModulePragma where
  printS (LanguagePragma _ es) = fill $ printListAt es
  printS (OptionsPragma spi t s) = fill $
    let str = ppTool t s
        SpanInfo sp _ = spi
    in printStringAt (Span (incr (start sp) 12)
                           (incr (start sp) (12 + length str)))
                     str

  keywords (LanguagePragma _ es)  =
    ["{-# LANGUAGE"] ++ replicate (length es - 1) "," ++  [" #-}"]
  keywords (OptionsPragma _ _ _) = ["{-# OPTIONS", " #-}"]

ppTool :: Maybe Tool -> String -> String
ppTool Nothing  opts = opts
ppTool (Just (KnownTool t)) opts = case t of
  KICS2         -> "_KICS2 "       ++ opts
  PAKCS         -> "_PAKCS "       ++ opts
  CYMAKE        -> "_CYMAKE "      ++ opts
  FRONTEND      -> "_FRONTEND "    ++ opts
ppTool (Just (UnknownTool s)) opts = "_" ++ s ++ " " ++ opts

instance PrintAt Extension where
  printString (KnownExtension   _ e) = show e
  printString (UnknownExtension _ e) = e
  printSpan (KnownExtension p' e) = case p' of
    SpanInfo (Span p _) _ -> Span p (incr p (length (show e)))
    _ -> error "printSpan Extension: NoSpan"
  printSpan (UnknownExtension p' e) = case p' of
    SpanInfo (Span p _) _ -> Span p (incr p (length e))
    _ -> error "printSpan Extension: NoSpan"

instance ExactPrint (Decl a) where
  printS (InfixDecl _ _ _ ids) = fill $ printNode ids
  printS (DataDecl _ ty vs cns der) = fill $
    printNode ty >> printNode vs >> printNode cns >> printNode der
  printS (ExternalDataDecl _ ty vs) = fill $
    printNode ty >> printNode vs
  printS (NewtypeDecl _ ty vs cn der) = fill $
    printNode ty >> printNode vs >> printNode cn >> printNode der
  printS (TypeDecl _ ty vs ty') = fill $
    printNode ty >> printNode vs >> printNode ty'
  printS (TypeSig _ fs ty) = fill $ printNode fs >> printNode ty
  printS (FunctionDecl _ _ _ eqs) = fill $ printNode eqs
  printS (ExternalDecl _ vs) = fill $ printNode $ map unVar vs
    where unVar (Var _ i) = i
  printS (PatternDecl _ p r) = fill $ printNode p >> printNode r
  printS (FreeDecl _ vs) = fill $ printNode $ map unVar vs
    where unVar (Var _ i) = i
  printS (DefaultDecl _ tys) = fill $ printNode tys
  printS (ClassDecl _ _ ctx c v fdeps ds) = fill $
    printNode ctx >> printNode c >> printNode v >> printNode fdeps >> printNode ds
  printS (InstanceDecl _ _ ctx c ts ds) = fill $
    printNode ctx >> printNode c >> printNode ts >> printNode ds

  keywords (InfixDecl _ f Nothing ids) =
    [ppInfix f] ++          replicate (length ids - 1) ","
  keywords (InfixDecl _ f (Just pr) ids) =
    [ppInfix f, show pr] ++ replicate (length ids - 1) ","
  keywords (DataDecl spi _ _ cns der) =
    ["data"] ++ (if null cns then [] else ["="]) ++
    replicate (length cns - 1) "|" ++
    case br of
      0 -> []
      1 -> ["deriving"]
      _ -> ["deriving", "("] ++ replicate (length der - 1) "," ++ [")"]
    where
      SpanInfo _ ss  = spi
      br = length ss - length cns - length der
  keywords (ExternalDataDecl _ _ _) = ["external", "data"]
  keywords (NewtypeDecl spi _ _ _ der) =
    ["newtype", "="] ++
    case br of
      0 -> []
      1 -> ["deriving"]
      _ -> ["deriving", "("] ++ replicate (length der - 1) "," ++ [")"]
    where
      SpanInfo _ ss = spi
      br = length ss - 2 - length der
  keywords (TypeDecl _ _ _ _) =
    ["type", "="]
  keywords (TypeSig _ fs _) =
    replicate (length fs - 1) "," ++ ["::"]
  keywords (FunctionDecl _ _ _ _) = []
  keywords (ExternalDecl _ vs) =
    replicate (length vs - 1) "," ++ ["external"]
  keywords (PatternDecl _ _ _) = []
  keywords (FreeDecl _ vs) =
    replicate (length vs - 1) "," ++ ["free"]
  keywords (DefaultDecl _ vs) =
    ["default", "("] ++ replicate (length vs - 1) "," ++ [")"]
  keywords (ClassDecl spi _ ctx _ _ fd _) =
    ["class"] ++ cs ++ fds ++ ["where"]
   where
    SpanInfo _ ss = spi

    br = length ss - 2 - length fd > 1
    cs | null ctx && not br = []
       | not br             = ["=>"]
       | otherwise          = ["("] ++ replicate (length ctx - 1) "," ++ [")", "=>"]
    fds | null fd   = []
        | otherwise = ["|"] ++ replicate (length fd - 1) ","
  keywords (InstanceDecl spi _ ctx _ _ _) =
    ["instance"] ++ cs ++ ["where"]
   where
    SpanInfo _ ss = spi

    br = length ss - 2 > 1
    cs | null ctx && not br = []
       | not br             = ["=>"]
       | otherwise          = ["("] ++ replicate (length ctx - 1) "," ++ [")", "=>"]

ppInfix :: Infix -> String
ppInfix f = case f of
  Infix   -> "infix"
  InfixL  -> "infixl"
  InfixR  -> "infixr"

instance ExactPrint FunDep where
  printS (FunDep _ l r) = fill $ printNode l >> printNode r
  keywords _ = ["->"]

instance ExactPrint ConstrDecl where
  printS (ConstrDecl _ i tys) = fill $ printNode i >> printNode tys
  printS (ConOpDecl _ ty1 i ty2) = fill $
    printNode ty1 >> printNode i >> printNode ty2
  printS (RecordDecl _ c fs) = fill $ printNode c >> printNode fs

  keywords (ConstrDecl _ _ _) = []
  keywords (ConOpDecl _ _ _ _) = []
  keywords (RecordDecl _ _ fs) =
    ["{"] ++ replicate (length fs - 1) "," ++ ["}"]

instance ExactPrint NewConstrDecl where
  printS (NewConstrDecl _ idt ty) = fill $ printNode idt >> printNode ty
  printS (NewRecordDecl _ idt (f, ty)) = fill $
    printNode idt >> printNode f >> printNode ty

  keywords (NewConstrDecl _ _ _) = []
  keywords (NewRecordDecl _ _ _) = ["{", "::" , "}"]

instance ExactPrint FieldDecl where
  printS (FieldDecl _ is ty) = fill $ printNode is >> printNode ty
  keywords (FieldDecl _ is _) =
    replicate (length is - 1) "," ++ ["::"]

instance ExactPrint QualTypeExpr where
  printS (QualTypeExpr _ ctx ty) = fill $ printNode ctx >> printNode ty
  keywords (QualTypeExpr spi ctx _) =
    if len == 0
      then ["=>"]
      else ["("] ++ replicate (length ctx - 1) "," ++  [")", "=>"]
    where
      SpanInfo _ ss = spi
      len = length ss - length ctx

instance ExactPrint TypeExpr where
  printS (ConstructorType _ q) = fill $ printQualIdent q
  printS (ApplyType _ ty1 ty2) = fill $ printNode ty1 >> printNode ty2
  printS (VariableType _ i)    = fill $ printNode i
  printS (TupleType _ tys)     = fill $ printNode tys
  printS (ListType _ ty)       = fill $ printNode ty
  printS (ArrowType _ ty1 ty2) = fill $ printNode ty1 >> printNode ty2
  printS (ParenType _ ty)      = fill $ printNode ty
  printS (ForallType _ vs ty)  = fill $ printNode vs >> printNode ty

  keywords (ConstructorType sp _)
    | null ss   = []
    | otherwise = ["(", ")"]
   where
    SpanInfo _ ss = sp
  keywords (ApplyType _ _ _) = []
  keywords (VariableType _ _) = []
  keywords (TupleType _ tys) =
    ["("] ++ replicate (length tys - 1) "," ++ [")"]
  keywords (ListType _ _) = ["[", "]"]
  keywords (ArrowType _ _ _) = ["->"]
  keywords (ParenType _ _) = ["(", ")"]
  keywords (ForallType _ _ _) = ["forall", "."]

instance ExactPrint Constraint where
  printS (Constraint _ c ty) = fill $ printNode c >> printNode ty
  keywords (Constraint spi _ _) =
    if null ss then [] else ["(", ")"]
    where
      SpanInfo _ ss = spi

instance ExactPrint (Equation a) where
  printS (Equation _ _ l r) = fill $ printNode l >> printNode r
  keywords _ = []

instance ExactPrint (Lhs a) where
  printS (FunLhs _ i ps)   = fill $ printNode i >> printNode ps
  printS (OpLhs _ p1 i p2) = fill $ printNode p1 >> printNode i >> printNode p2
  printS (ApLhs _ l ps)    = fill $ printNode l >> printNode ps

  keywords (FunLhs _ _ _) = []
  keywords (OpLhs spi _ _ _) = zipWith const ["`","`"] ss
    where
      SpanInfo _ ss = spi
  keywords (ApLhs _ _ _)  = ["(",")"]

instance ExactPrint (Rhs a) where
  printS (SimpleRhs  _ _ e  ds) = fill $ printNode e  >> printNode ds
  printS (GuardedRhs _ _ cs ds) = fill $ printNode cs >> printNode ds

  keywords (SimpleRhs  spi _ _ _) =
    (if snd (spanLength (head ss)) == 0
       then ["="]
       else ["->"])
    ++ if length ss == 1 then [] else ["where"]
    where SpanInfo _ ss = spi

  -- TODO: The spanInfo of `GuardedRhs` contains the span info of first pipe (`|`) 
  --       and additionally, if it exists, the span info of the `where` keyword. 
  -- 
  --       Every conditional expression of this `GuardedRhs` also contains the span info 
  --       of the corresponding pipe (`|`), and thus should be resposible for printing
  --       the `|`. By not supplying the `|` keyword here, we avoid duplicate `|`s, but
  --       in order to print the `where` keyword, we also need to return an empty string
  --       here, so that the `where` keyword is associated with the correct span info 
  --       (the second one in the list, not the first one).
  --
  --       This is a workaround, and should be fixed in the future (in the front-end).
  keywords (GuardedRhs spi _ _ _) =
    if length ss == 1 then [] else ["", "where"]
    where SpanInfo _ ss = spi

instance ExactPrint (CondExpr a) where
  printS (CondExpr _ e1 e2) = fill $ printNode e1 >> printNode e2
  keywords (CondExpr spi _ _) =
    "|" :
    (if snd (spanLength (head (tail ss))) == 0
       then ["="]
       else ["->"])
    where SpanInfo _ ss = spi

instance ExactPrint (Pattern a) where
  printS (LiteralPattern  spi _ l) = fill $ printStringAt sp (ppLit l)
    where SpanInfo sp _ = spi
  printS (NegativePattern spi _ l) = fill $ printStringAt sp ('-' : ppLit l)
    where SpanInfo sp _ = spi
  printS (VariablePattern _ _ v) = fill $ printNode v
  printS (ConstructorPattern _ _ q ps) = fill $ printQualIdent q >> printNode ps
  printS (InfixPattern _ _ p1 q p2) =
    fill $ printNode p1 >> printNode q >> printNode p2
  printS (ParenPattern _ p) = fill $ printNode p
  printS (RecordPattern _ _ q fs) = fill $ printNode q >> printNode fs
  printS (TuplePattern _ ps) = fill$ printNode ps
  printS (ListPattern _ _ ps) = fill $ printNode ps
  printS (AsPattern _ i p) = fill $ printNode i >> printNode p
  printS (LazyPattern _ p) = fill $ printNode p
  printS (FunctionPattern _ _ f ps) = fill $ printNode f >> printNode ps
  printS (InfixFuncPattern _ _ p1 op p2) =
    fill $ printNode p1 >> printNode op >> printNode p2

  keywords (LiteralPattern  _ _ _) = []
  keywords (NegativePattern _ _ _) = []
  keywords (VariablePattern _ _ _) = []
  keywords (ConstructorPattern spi _ _ _) =
    ["("] ++ replicate (length ss - 2) "," ++ [")"]
    where
      SpanInfo _ ss = spi
  keywords (InfixPattern spi _ _ _ _) =
    if null ss then [] else ["`", "`"]
    where
      SpanInfo _ ss = spi
  keywords (ParenPattern _ _) = ["(", ")"]
  keywords (RecordPattern _ _ _ fs) =
    ["{"] ++ replicate (length fs - 1) "," ++ ["}"]
  keywords (TuplePattern _ ps) =
    ["("] ++ replicate (length ps - 1) "," ++ [")"]
  keywords (ListPattern _ _ ps) =
    ["["] ++ replicate (length ps - 1) "," ++ ["]"]
  keywords (AsPattern _ _ _) = ["@"]
  keywords (LazyPattern _ _) = ["~"]
  keywords (FunctionPattern _ _ _ _) = []
  keywords (InfixFuncPattern _ _ _ _ _) = []

ppLit :: Literal -> String
ppLit (Char   c) = ['\'', c, '\'']
ppLit (Int    i) = show i
ppLit (Float  f) = show f
ppLit (String s) = "\"" ++ s ++ "\""

instance ExactPrint (Expression a) where
  printS (Literal spi _ l) = fill $ printStringAt sp (ppLit l)
    where SpanInfo sp _ = spi
  printS (Variable _ _ qid) = fill $ printNode qid
  printS (Constructor _ _ qid) = fill $ printQualIdent qid
  printS (Paren _ e) = fill $ printNode e
  printS (Typed _ e ty) = fill $ printNode e >> printNode ty
  printS (Record _ _ q fs) = fill $ printNode q >> printNode fs
  printS (RecordUpdate _ e fs) = fill $ printNode e >> printNode fs
  printS (Tuple _ es) = fill $ printNode es
  printS (List _ _ es) = fill $ printNode es
  printS (ListCompr _ e stms) = fill $ printNode e >> printNode stms
  printS (EnumFrom _ e) = fill $ printNode e
  printS (EnumFromThen _ e1 e2) = fill $ printNode e1 >> printNode e2
  printS (EnumFromTo _ e1 e2) = fill $ printNode e1 >> printNode e2
  printS (EnumFromThenTo _ e1 e2 e3) =
    fill $ printNode e1 >> printNode e2 >> printNode e3
  printS (UnaryMinus _ e) = fill $ printNode e
  printS (Apply _ e1 e2) = fill $ printNode e1 >> printNode e2
  printS (InfixApply _ e1 op e3) =
    fill $ printNode e1 >> printNode (qidOp op) >> printNode e3
  printS (LeftSection _ e op) = fill $ printNode e >> printNode (qidOp op)
  printS (RightSection _ op e) = fill $ printNode (qidOp op) >> printNode e
  printS (Lambda _ ps e) = fill $ printNode ps >> printNode e
  printS (Let _ _ ds e) = fill $ printNode ds >> printNode e
  printS (Do _ _ stms e) = fill $ printNode stms >> printNode e
  printS (IfThenElse _ e1 e2 e3) =
    fill $ printNode e1 >> printNode e2 >> printNode e3
  printS (Case _ _ _ e as) = fill $ printNode e >> printNode as

  keywords (Literal _ _ _) = []
  keywords (Variable spi _ _) = if null ss then [] else ["(", ")"]
    where SpanInfo _ ss = spi
  keywords (Constructor spi _ _) =
    ["("] ++ replicate (length ss - 2) "," ++ [")"]
    where
      SpanInfo _ ss = spi
  keywords (Paren _ _) = ["(", ")"]
  keywords (Typed _ _ _) = ["::"]
  keywords (Record _ _ _ fs) =
    ["{"] ++ replicate (length fs - 1) "," ++ ["}"]
  keywords (RecordUpdate _ _ fs) =
    ["{"] ++ replicate (length fs - 1) "," ++ ["}"]
  keywords (Tuple _ es) =
    ["("] ++ replicate (length es - 1) "," ++ [")"]
  keywords (List _ _ es) =
    ["["] ++ replicate (length es - 1) "," ++ ["]"]
  keywords (ListCompr _ _ stms) =
    ["[", "|"] ++ replicate (length stms - 1) "," ++ ["]"]
  keywords (EnumFrom _ _) = ["[", "..", "]"]
  keywords (EnumFromTo _ _ _) = ["[", "..", "]"]
  keywords (EnumFromThen _ _ _) = ["[", ",", "..", "]"]
  keywords (EnumFromThenTo _ _ _ _) = ["[", ",", "..", "]"]
  keywords (UnaryMinus _ _) = ["-"]
  keywords (Apply _ _ _) = []
  keywords (InfixApply _ _ _ _) = []
  keywords (LeftSection _ _ _) = ["(", ")"]
  keywords (RightSection _ _ _) = ["(", ")"]
  keywords (Lambda _ _ _) = ["\\", "->"]
  keywords (Let _ layout ds _) = case layout of
    WhitespaceLayout -> ["let", "in"]
    ExplicitLayout _ -> ["let", "{"] ++ replicate (length ds - 1) ";" ++ ["}", "in"]
  keywords (Do _ layout stms _) = case layout of
    WhitespaceLayout -> ["do"]
    ExplicitLayout _ -> ["do", "{"] ++ replicate (length stms) ";" ++ ["}"]
  keywords (IfThenElse _ _ _ _) = ["if", "then", "else"]
  keywords (Case _ layout _ _ alts) = case layout of
    WhitespaceLayout -> ["case", "of"]
    ExplicitLayout _ -> ["case", "of", "{"] ++ replicate (length alts - 1) ";" ++ ["}"]

  extraSpans exp = case exp of
    (Do   _ (ExplicitLayout sps) _ _)   -> sps
    (Case _ (ExplicitLayout sps) _ _ _) -> sps
    (Let  _ (ExplicitLayout sps) _ _)   -> sps
    _                                   -> []

qidOp :: InfixOp a -> QualIdent
qidOp (InfixOp     _ q) = q
qidOp (InfixConstr _ q) = q

instance ExactPrint (Statement a) where
  printS (StmtExpr _ e   ) = fill $ printNode e
  printS (StmtDecl _ _ ds) = fill $ printNode ds
  printS (StmtBind _ p e ) = fill $ printNode p >> printNode e

  keywords (StmtExpr _ _  ) = []
  keywords (StmtDecl _ _ _) = ["let"]
  keywords (StmtBind _ _ _) = ["<-"]

instance ExactPrint (Alt a) where
  printS (Alt _ p r) = fill $ printNode p >> printNode r
  keywords _ = []

instance ExactPrint a => ExactPrint (Field a) where
  printS (Field _ qid a) = fill $ printNode qid >> printNode a
  keywords _ = ["="]

instance ExactPrint ModuleIdent where
  printS _ = noChilds
  keywords (ModuleIdent _ mods) = [intercalate "." mods]

instance ExactPrint Ident where
  printS _ = noChilds
  keywords (Ident spi name _)
    | length (getSrcInfoPoints spi)
       == 1         = [name]
    | isOpName name = ["(", name, ")"]
    | otherwise     = ["`", name, "`"]
    where
      isOpName = all (`elem` opChars)
      opChars  = "~!@#$%^&*+-=<>:?./|\\"

instance ExactPrint QualIdent where
  -- TODO: Currently, the front-end adds the complete span of the `QualIdent` to the
  --       keyword `SpanInfo` of the `QualIdent` itself, if the `QualIdent` contains 
  --       a module identifier (-> the identifier is qualified). 
  --       Thus, if we want to also print the module identifier (e.g., `Prelude.`), 
  --       we need to print the complete `QualIdent` (including the module identifier)
  --       as a keyword. 
  --
  --       Because the only valid syntax is `A.B` where `A ::= {A.}` and `B` is an identifier, 
  --       we can simply print the complete `QualIdent` as a keyword and the result should
  --       still be a correct exact-printed representation of the qualified identifier. Still,
  --       this is a workaround and should be fixed in the future.

  printS (QualIdent _ Nothing  i) = fill $ printNode i
  printS (QualIdent _ (Just _) _) = fill empty

  keywords (QualIdent spi mi i) = case mi of
    (Just (ModuleIdent _ mods))
      -> addTicks [intercalate "." (mods ++ [iName])]
    Nothing
      -> addTicks []
   where
    addTicks kws =
      if length ss <= 1 then kws else ["`"] ++ kws ++ ["`"]
      where SpanInfo _ ss = spi
    iName = case i of Ident _ n _ -> n

--- For the unit type `()`, the span information for the qualified identifier 
--- is missing, but the span information for the parentheses is stored in the 
--- outer `SpanInfo` (e.g., of a surrounding `ConstructorType`). 
--- In this case, we must not print the qualified identifier, but an empty string. 
--- Because the span information is part of the surrounding structure, 
--- the unit constructor `()` must be printed using the `keywords` function, instead.
printQualIdent :: QualIdent -> PutExact
printQualIdent qid = case qid of
  QualIdent _ _ (Ident _ "()" _) -> empty
  _                              -> printNode qid