{-# LANGUAGE OverloadedStrings #-}
module Language.Eiffel.PrettyPrint where

import           Control.Lens hiding (to, lens, from, assign, op)

import           Data.Hashable
import qualified Data.HashMap.Strict as Map
import qualified Data.Set as Set
import           Data.Set (Set)
import qualified Data.Text as Text
import           Data.Text (Text)

import           Text.PrettyPrint

import           Language.Eiffel.Syntax
import           Language.Eiffel.Position

ttext = text . Text.unpack

defaultIndent = 2
nestDef = nest defaultIndent

renderWithTabs = fullRender (mode style) (lineLength style) (ribbonsPerLine style) spacesToTabs ""
  where
    spacesToTabs :: TextDetails -> String -> String
    spacesToTabs (Chr c) s  = c:s
    spacesToTabs (Str s1) s2 = spaceAppend s1 s2
    spacesToTabs (PStr s1) s2 = spaceAppend s1 s2
    
    spaceAppend s1 s2 = 
      if s1 == replicate (length s1) ' ' && length s1 > 1 
      then replicate (length s1 `div` defaultIndent) '\t' ++ s2 
      else s1 ++ s2

newline = char '\n'
emptyLine = text ""

ups = Text.toUpper

toDoc :: Clas -> Doc
toDoc = toDocWith False routineBodyDoc

toInterfaceDoc :: ClasInterface -> Doc
toInterfaceDoc = toDocWith True interfaceBodyDoc

interfaceBodyDoc :: EmptyBody -> Doc
interfaceBodyDoc = const (text "do")

toDocWith fullAttr bodyDoc c =   
  let defer = if deferredClass c then text "deferred" else empty
      froz  = if frozenClass c then text "frozen" else empty
      expnd = if expandedClass c then text "expanded" else empty 
  in vsep [ notes (classNote c) $+$ (if null (classNote c) then empty else emptyLine)
          , defer <+> froz <+> expnd <+> text "class"
          , nestDef (ttext (ups $ className c)) <+> genericsDoc (generics c) <+> procGenDoc (procGeneric c)
          , emptyLine
          , inheritance (inherit c)
          , vsep (map createClause (creates c))
          , convertClause (converts c)
          , vsep (featureClauses fullAttr bodyDoc (featureMap c))
          , invars (invnts c)
          , text "end"
          ]


inheritance is = vsep (map inheritanceClauses is)

inheritanceClauses (Inheritance nonConform cs) =
  let conformMark | nonConform = text "{NONE}"
                  | otherwise  = empty
  in (text "inherit" <+> conformMark) $+$ nestDef (vsep (map inheritClause cs))

inheritClause (InheritClause cls renames exports undefs redefs selects) = 
  let renameDoc (Rename orig new alias) =
        ttext orig <+> text "as" <+> ttext new <+> 
          maybe empty (\a -> text "alias" <+> doubleQuotes (ttext a)) alias
      exportListDoc (ExportFeatureNames l) = vCommaSep (map ttext l)
      exportListDoc ExportAll = text "all"
      exportDoc (Export to what) =
        braces (commaSep (map ttext to)) $+$ nestDef (exportListDoc what)
  in type' cls $+$ nestDef (vsep
          [ text "rename" $?$ nestDef (vCommaSep (map renameDoc renames))
          , text "export" $?$ nestDef (vsep (map exportDoc exports))
          , text "undefine" $?$ nestDef (vCommaSep (map ttext undefs))
          , text "redefine" $?$ nestDef (vCommaSep (map ttext redefs))
          , text "select" $?$ nestDef (vCommaSep (map ttext selects))
          , if null renames && null exports && null undefs && null redefs && null selects
            then empty else text "end"
          , emptyLine
          ])
      
createClause (CreateClause exports names) = 
  let exps = if null exports 
             then empty 
             else  braces (commaSep (map ttext exports))
  in (text "create" <+> exps) $+$ nestDef (commaSep (map ttext names)) $+$ emptyLine
  
convertClause []    = empty
convertClause convs =
  let go (ConvertFrom fname ts) = ttext fname <+> 
                                  parens (braces (commaSep (map type' ts)))
      go (ConvertTo fname ts) = ttext fname <> colon <+> 
                                braces (commaSep (map type' ts))
  in text "convert" $+$ nestDef (vCommaSep (map go convs)) $+$ emptyLine

featureClauses :: (Ord body)
                  => Bool 
                  -> (body -> Doc)
                  -> FeatureMap body Expr
                  -> [Doc]
featureClauses fullAttr bodyDoc featMap = 
  concat [ allExports fmRoutines routDoc'
         , allExports fmAttrs attrDoc'
         , allExports fmConsts constDoc'
         ]
  where
    insertExport expMap (ExportedFeature exports feat) = 
      Map.insertWith Set.union exports (Set.singleton feat) expMap
    exportMap lens = Map.foldl' insertExport Map.empty (view lens featMap)
    exportDoc exports 
      | Set.null exports = empty 
      | otherwise = braces (commaSep (map ttext $ Set.toList exports))
    
    routDoc' r = routineDoc bodyDoc r $+$ emptyLine
    attrDoc' a = attrDoc fullAttr a $+$ emptyLine
    constDoc' c = constDoc c $+$ emptyLine
    
    printExports featDoc exports someFeats =
      vsep [ text "feature" <+> exportDoc exports
           , emptyLine
           , nestDef $ vsep $ map featDoc $ Set.toList someFeats
           ]

    allExports lens featDoc = 
      map (uncurry $ printExports featDoc) $ Map.toList (exportMap lens)

vsep = foldr ($+$) empty
commaSep = hsep . punctuate comma
vCommaSep = vsep . punctuate comma
angles d = langle <> d <> rangle
langle = char '<'
rangle = char '>'
squareQuotes t = text "\"[" <> t <> text "]\""
                      
anyStringLiteral s
  | Text.isPrefixOf "\n" s = squareQuotes $ ttext s
  | Text.isPrefixOf "\r\n" s = squareQuotes $ ttext s
  | otherwise =  doubleQuotes $ stringLiteral s


stringLiteral s = ttext s'
  where s' = go' s
        go' = go . Text.uncons
        go (Just ('\n', cs)) = Text.append "%N" $ go' cs
        go (Just ('\r', cs)) = Text.append "%R" $ go' cs
        go (Just ('\t', cs)) = Text.append "%T" $ go' cs
        go (Just ('"', cs)) = Text.append "%\"" $ go' cs
        go (Just (c, cs)) = Text.cons c (go' cs)
        go Nothing = Text.empty

procDoc (Proc s) = ttext s
procDoc Dot = text "<procdot>"

genericsDoc [] = empty
genericsDoc gs = brackets (commaSep (map go gs))
  where go (Generic name constr createsMb) = 
          ttext name <+> constraints constr <+> maybe empty create createsMb
        constraints []  = empty
        constraints [t] = text "->" <+> type' t
        constraints ts  = text "->" <+> braces (commaSep (map type' ts))
        create cs = hsep [ text "create"
                          , commaSep (map ttext cs)
                          , text"end"
                          ]
                            
notes [] = empty
notes ns = vsep [ text "note"
                , nestDef (vsep $ map note ns)
                ]

note (Note tag content) = ttext tag <> colon <+> commaSep (map (expr' 0) content)

invars is = text "invariant" $?$ clausesDoc is
                 

procGenDoc [] = empty
procGenDoc ps = go ps
  where go = angles . hsep . punctuate comma . map procDoc

decl :: Decl -> Doc
decl (Decl label typ) = ttext label <> typeDoc typ

typeDoc NoType = empty
typeDoc t = text ":" <+> type' t

frozen b = if b then text "frozen" else empty

require (Contract inh c) = (if inh then text "require else" else text "require") $?$ clausesDoc c
ensure (Contract inh c) = (if inh then text "ensure then" else text "ensure") $?$ clausesDoc c

constDoc :: Constant Expr -> Doc
constDoc (Constant froz d val) = frozen froz <+> decl d <+> text "=" <+> expr val

attrDoc :: Bool -> Attribute Expr -> Doc
attrDoc fullAttr (Attribute froz d assn ns reqs ens) = 
  frozen froz <+> decl d <+> assignText assn $+$
  nestDef (vsep [ notes ns
       , require reqs
       , attrKeyword
       , ensure ens
       , endKeyword
       ])
  where assignText Nothing  = empty
        assignText (Just a) = text "assign" <+> ttext a
        hasBody     = not (null (contractClauses ens) && null (contractClauses reqs) && null ns)
        attrKeyword | hasBody || fullAttr = text "attribute"
                    | otherwise = empty
        endKeyword  | hasBody || fullAttr = text "end"
                    | otherwise = empty

type' :: Typ -> Doc
type' (ClassType str gens) = ttext (ups str) <+> genDoc gens
type' VoidType   = text "NONE"
type' (Like s)   = text "like" <+> ttext s
type' NoType     = empty
type' (Sep mP ps str) = sepDoc <+> procM mP <+> procs ps <+> ttext str
type' (TupleType typeDecls) = 
  let typeArgs = 
        case typeDecls of
          Left types -> commaSep (map type' types)
          Right decls -> hcat (punctuate (text ";") (map decl decls))
      tupleGen | isEmpty typeArgs = empty
               | otherwise        = text "[" <> typeArgs <> text "]"
  in text "TUPLE" <+> tupleGen

routineDoc :: (body -> Doc) -> AbsRoutine body Expr -> Doc
routineDoc bodyDoc f 
    = let header = frozen (routineFroz f) <+>
                   ttext (routineName f) <+>
                   alias <+>
                   formArgs (routineArgs f) <> 
                   typeDoc (routineResult f) <+>
                   procs (routineProcs f)
          alias = 
            case routineAlias f of
              Nothing   -> empty
              Just name -> text "alias" <+> doubleQuotes (ttext name)
          assign =
            case routineAssigner f of
              Nothing -> empty
              Just name -> text "assign" <+> ttext name
          rescue =
            case routineRescue f of
              Nothing -> empty
              Just stmts -> text "rescue" $+$
                nestDef (vsep $ map stmt stmts)
      in header <+> assign $+$ 
          (nestDef $ vsep 
           [ notes (routineNote f)
           , require (routineReq f)
           , text "require-order" $?$ nestDef (procExprs f)
           , text "lock" $?$ nestDef (locks (routineEnsLk f))
           , bodyDoc $ routineImpl f
           , ensure (routineEns f)
           , rescue
           , text "end"
           ]
          )

routineBodyDoc RoutineDefer = text "deferred"
routineBodyDoc (RoutineExternal s aliasMb) = 
  vcat [ text "external" 
       , nestDef (anyStringLiteral s)
       , text "alias" $?$ maybe empty anyStringLiteral aliasMb
       ]
routineBodyDoc ft = vsep [ locals ft
                         , text "do"
                         , nestDef $ stmt $ routineBody ft
                         ]

locals ft = text "local" $?$ nestDef (vsep $ map decl (routineLocal ft))

procExprs = vCommaSep . map procExprD . routineReqLk

($?$) :: Doc -> Doc -> Doc
($?$) l e 
    | isEmpty e = empty
    | otherwise = l $+$ e

(<?>) :: Doc -> Doc -> Doc
(<?>) l e 
    | isEmpty e = empty
    | otherwise = l <?> e


clausesDoc :: [Clause Expr] -> Doc
clausesDoc cs = nestDef (vsep $ map clause cs)

clause :: Clause Expr -> Doc
clause (Clause nameMb e) = maybe empty (\n -> ttext n <> colon) nameMb <+> expr e

stmt = stmt' . contents

stmt' (Assign l e) = expr l <+> text ":=" <+> expr e
stmt' (AssignAttempt l e) = expr l <+> text "?=" <+> expr e
stmt' (CallStmt e) = expr e
stmt' (If cond body elseParts elseMb) = 
  let elsePart = case elseMb of
        Just elsee -> vsep [text "else", nestDef (stmt elsee)]
        Nothing -> empty
      elseifPart (ElseIfPart c s) =
        vsep [ text "elseif" <+> expr c <+> text "then"
             , nestDef (stmt s)
             ]
      elseifParts es = vsep (map elseifPart es)
  in vsep [ text "if" <+> expr cond <+> text "then"
          , nestDef (stmt body)
          , elseifParts elseParts
          , elsePart
          , text "end"
          ]
stmt' (Inspect e whens elseMb) =
  let elsePart = case elseMb of
        Nothing -> empty
        Just s -> text "else" $+$ nestDef (stmt s)
      whenParts (es', s) = 
        (text "when" <+> commaSep (map expr es') <+> text "then") $+$ 
        nestDef (stmt s)
  in vsep [ text "inspect" <+> expr e
          , vsep (map whenParts whens)
          , elsePart
          , text "end"
          ]
stmt' (Across e asIdent body) =
  vcat [ text "across"
       , nestDef (expr e <+> text "as" <+> ttext asIdent)
       , text "loop"
       , nestDef (stmt body)
       , text "end"
       ]
stmt' (BuiltIn)  = text "builtin"
stmt' (Create t tar n es) = text "create" <+> maybe empty (braces . type') t <+> 
  if n == defaultCreate then expr tar else expr' 0 (QualCall tar n es)
stmt' (Block ss) = vsep (map stmt ss)
stmt' (Check cs) = vsep [ text "check"
                        , nestDef (vsep (map clause cs))
                        , text "end"
                        ]
stmt' (CheckBlock cs body) = 
  vsep [ text "check" <+> vsep (map clause cs) <+> text "then"
       , stmt body
       , text "end"
       ]
stmt' (Loop from invs cond loop var) = 
  vsep [ text "from"
       , nestDef (stmt from)
       , text "invariant" $?$ clausesDoc invs
       , text "until"
       , nestDef (expr cond)
       , text "loop"
       , nestDef (stmt loop)
       , text "variant" $?$ maybe empty (nestDef . expr) var
       , text "end"
       ]
stmt' (Debug str body) = 
  vsep [ text "debug" <+> (if Text.null str 
                           then empty 
                           else (parens . anyStringLiteral) str)
       , nestDef (stmt body)
       , text "end"
       ]
stmt' Retry = text "retry"
stmt' s = error ("PrettyPrint.stmt': " ++ show s)

expr = exprPrec 0

exprPrec :: Int -> Expr -> Doc
exprPrec i = expr' i . contents

expr' _ (UnqualCall n es) = ttext n <+> actArgs es
expr' _ (QualCall t n es) = target <> ttext n <+> actArgs es
    where 
      target = case contents t of
                 CurrentVar -> empty
                 _ -> exprPrec 13 t <> char '.'
expr' _ (PrecursorCall cname es) = 
  text "Precursor" <+> maybe empty (braces . ttext) cname <+> actArgs es
expr' i (AcrossExpr e as q body) =
  hsep [ text "across"
       , exprPrec i e
       , text "as"
       , ttext as
       , quant q
       , expr body
       , text "end"
       ]
expr' i (UnOpExpr uop e) = condParens (i > 12) $ ttext (unop uop) <+> exprPrec 12 e
expr' i (Lookup targ args) = case targ of
  Pos _ (Lookup _ _) -> parens (exprPrec i targ) <+> brackets (commaSep (map expr args))
  _ -> exprPrec i targ <+> brackets (commaSep (map expr args))
expr' i (BinOpExpr (SymbolOp op) e1 e2)
  | op == "[]" = exprPrec i e1 <+> brackets (expr e2)
  | otherwise =  condParens (i > 11) 
                 (exprPrec 11 e1 <+> ttext op <+> exprPrec 12 e2)
expr' i (BinOpExpr bop e1 e2) = 
  condParens (i > p) 
             (exprPrec lp e1 <+> ttext op <+> exprPrec rp e2)
  where (op, p) = binop bop
        lp = p
        rp = p + 1
expr' _ (Attached t e asVar) = 
  text "attached" <+> maybe empty (braces . type') t <+> 
  expr e <+> maybe empty (\s -> text "as" <+> ttext s) asVar
expr' _ (CreateExpr t n es) = 
  text "create" <+> braces (type' t) <> if n == defaultCreate then empty else char '.' <> ttext n <+> actArgs es
expr' _ (StaticCall t i args) = 
  braces (type' t) <> char '.' <> ttext i <+> actArgs args
expr' _ (LitArray es) = text "<<" <+> commaSep (map expr es) <+> text ">>"
expr' _ (ManifestCast t e) = braces (type' t) <+> expr e
expr' _ (OnceStr s)   = text "once" <+> ttext s
expr' _ (Address e)   = text "$" <> expr e
expr' _ (VarOrCall s) = ttext s
expr' _ ResultVar     = text "Result"
expr' _ CurrentVar    = text "Current"
expr' _ LitVoid       = text "Void"
expr' i (LitChar c)   = condParens (i >= 13) $ quotes (char c)
expr' i (LitString s) = condParens (i >= 13) $ anyStringLiteral s
expr' i (LitInt int') = condParens (i >= 13) $ integer int'
expr' i (LitBool b)   = condParens (i >= 13) $ text (show b)
expr' i (LitDouble d) = condParens (i >= 13) $ double d
expr' i (LitType t)   = condParens (i >= 13) $ braces (type' t)
expr' _ (Tuple es)    = brackets (hcat $ punctuate comma (map expr es))
expr' _ (Agent e)     = text "agent" <+> case contents e of
  QualCall t n es -> case contents t of
    VarOrCall _name -> expr e
    _ -> parens (expr t) <> char '.' <> ttext n <+> actArgs es
  _ -> expr e
expr' _ (InlineAgent ds resMb ss args)  = 
  let decls = formArgs ds
      res   = maybe empty (\t -> colon <+> type' t) resMb
  in vsep [ text "agent" <+> decls <+> res
          , text "do"
          , nestDef $ vsep (map stmt ss)
          , text "end" <+> condParens (not $ null args)
                                      (commaSep (map expr args))
          ]
expr' _ s                 = error ("expr': " ++ show s)

quant All = text "all"
quant Some = text "some"

condParens True  e = parens e
condParens False e = e

unop Neg = "-"
unop Not = "not"
unop Old = "old"

opList = [ (Pow, ("^", 10))
         , (Mul, ("*", 9))
         , (Div, ("/", 9))
         , (Quot, ("//", 9))
         , (Rem, ("\\\\", 9))
         , (Add, ("+", 8))
         , (Sub, ("-", 8))
         , (And, ("and", 5))
         , (AndThen, ("and then", 5))
         , (Or,  ("or", 4))
         , (Xor, ("xor", 4))
         , (OrElse,  ("or else", 4))
         , (Implies, ("implies", 3))
         ]

binop :: BinOp -> (Text, Int)
binop (SymbolOp o) = (o, 11)
binop (RelOp r _)  = (relop r, 6)
binop o = 
  case lookup o opList of
    Just (n,p) -> (n,p)
    Nothing -> error "binop: could not find operator"

relop Lt  = "<"
relop Lte = "<="
relop Gt  = ">"
relop Gte = ">="
relop Eq  = "="
relop Neq = "/="
relop TildeEq = "~"
relop TildeNeq = "/~"

actArgs [] = empty
actArgs es = parens $ hsep $ punctuate comma (map expr es)

formArgs [] = empty
formArgs ds = parens $ hsep $ punctuate semi (map decl ds) 

genDoc :: [Typ] -> Doc
genDoc [] = empty
genDoc ps = brackets $ hcat $ punctuate comma (map type' ps)

procExprD (LessThan a b) = proc a <+> langle <+> proc b
locks [] = empty
locks ps = hsep $ punctuate comma (map proc ps)

procs [] = empty
procs ps = angles $ locks ps
proc (Proc p) = ttext p
proc Dot      = text "dot_proc"
procM = maybe empty (angles . proc)
sepDoc = text "separate"

instance Hashable a => Hashable (Set a) where
  hashWithSalt salt v = hashWithSalt salt (Set.toAscList v)