content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  {-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings, CPP #-}
  module Haste.AST.Print () where
  import Prelude hiding (LT, GT)
  import Haste.Config
  import Haste.AST.Syntax
  import Haste.AST.Op
  import Haste.AST.PP as PP
  import Haste.AST.PP.Opts as PP
  import Data.ByteString.Builder
  import Control.Monad
  import Data.Char
  import Numeric (showHex)
  import qualified Data.ByteString.Char8 as BS
  import qualified Data.ByteString.UTF8 as BS
  
  instance Pretty Var where
    pp (Foreign name) = do
      put name
      doComment <- getOpt externalAnnotation
      when doComment . put $ byteString "/* EXTERNAL */"
    pp (Internal name@(Name u _) comment _) = do
      hsnames <- getOpt preserveNames
      if hsnames
        then put $ buildStgName name
        else do
          pp name
          doComment <- getOpt nameComments
          when doComment $ do
            put $ byteString "/* "
            if BS.null comment
              then put u
              else put comment
            put $ byteString " */"
                
  
  instance Pretty Name where
    pp name = finalNameFor name >>= put . buildFinalName
  
  instance Pretty LHS where
    pp (NewVar _ v)  = "var " .+. pp v
    pp (LhsExp _ ex) = pp ex
  
  instance Pretty Lit where
    pp (LNum d) | d >= 0    = put d
    pp (LNum d) | otherwise = " " .+. put d
    pp (LStr s)             = "\"" .+. put (fixQuotes $ BS.toString s) .+. "\""
      where
        fixQuotes ('\\':xs) = "\\\\" ++ fixQuotes xs
        fixQuotes ('"':xs)  = '\\':'"'  : fixQuotes xs
        fixQuotes ('\'':xs) = '\\':'\'' : fixQuotes xs
        fixQuotes ('\r':xs) = '\\':'r'  : fixQuotes xs
        fixQuotes ('\n':xs) = '\\':'n' : fixQuotes xs
        fixQuotes (x:xs)
          | ord x <= 127    = x : fixQuotes xs
          | otherwise       = toHex x ++ fixQuotes xs
        fixQuotes _         = []
    pp (LBool b) = put b
    pp (LInt n)  = put n
    pp (LNull)   = "null"
  
  -- | Generate a Haskell \uXXXX escape sequence for a char if it's >127.
  toHex :: Char -> String
  toHex c =
    case ord c of
      n | n < 127   -> [c]
        | otherwise -> "\\u" ++ exactlyFour (showHex (n `rem` 65536) "")
  
  -- | Truncate and pad a string to exactly four characters. '0' is used for padding.
  exactlyFour :: String -> String
  exactlyFour s =
      pad (4-len) $ drop (len-4) s
    where
      len = length s
      pad 0 cs = cs
      pad n cs = '0' : pad (n-1) cs
  
  
  -- | Default separator; comma followed by space, if spaces are enabled.
  sep :: PP ()
  sep = "," .+. sp
  
  instance Pretty Exp where
    pp (Var v) =
      pp v
    pp (Lit l) =
      pp l
    pp (JSLit l) =
      put l
    pp (Not ex) = do
      case neg ex of
        Just ex' -> pp ex'
        _ -> if expPrec (Not ex) > expPrec ex
               then "!(" .+. pp ex .+. ")"
               else "!" .+. pp ex
    pp bop@(BinOp _ _ _) =
      case norm bop of
        BinOp op a b -> opParens op a b
        ex           -> pp ex
    pp (Fun args body) = do
      "function(" .+. ppList sep args .+. "){" .+. newl
      indent $ pp body
      ind .+. "}"
    pp (Call _ call f args) = do
        case call of
          Normal True  -> "B(" .+. normalCall .+. ")"
          Normal False -> normalCall
          Fast True    -> "B(" .+. fastCall .+. ")"
          Fast False   -> fastCall
          Method m     ->
            pp f .+. put (BS.cons '.' m) .+. "(" .+. ppList sep args .+. ")"
      where
        normalCall =
          case args of
            [x]     -> "A1(" .+. pp f .+. "," .+. pp x .+. ")"
            [_,_]   -> "A2(" .+. pp f .+. "," .+. ppList sep args .+. ")"
            [_,_,_] -> "A3(" .+. pp f .+. "," .+. ppList sep args .+. ")"
            _       -> "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])"
        fastCall = ppCallFun f .+. "(" .+. ppList sep args .+. ")"
        ppCallFun fun@(Fun _ _) = "(" .+. pp fun .+. ")"
        ppCallFun fun           = pp fun
    pp e@(Index arr ix) = do
      if expPrec e > expPrec arr
         then "(" .+. pp arr .+. ")"
         else pp arr
      "[" .+. pp ix .+. "]"
    pp (Member obj m) = do
      pp obj .+. "." .+. put m
    pp (Obj ms) | and $ zipWith (==) ["_","a","b","c","d","e"] (map fst ms) =
      ppADT ms
    pp (Obj members) = do
      "{" .+. ppList "," members .+. "}"
    pp (Arr exs) = do
      "[" .+. ppList sep exs .+. "]"
    pp (AssignEx l r) = do
      pp l .+. sp .+. "=" .+. sp .+. pp r
    pp e@(IfEx c th el) = do
      if expPrec e > expPrec c
         then "(" .+. pp c .+. ")"
         else pp c
      sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el
    pp (Eval x) = do
      "E(" .+. pp x .+. ")"
    pp (Thunk True x) = do
      "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "})"
    pp (Thunk False x) = do
      "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "},1)"
  
  -- | Pretty-print an object representing an ADT.
  ppADT :: [(BS.ByteString, Exp)] -> PP ()
  ppADT ms = do
      useClassy <- getCfg useClassyObjects
      if useClassy && args <= 6
        then "new T" .+. put args .+. "(" .+. ppList "," (map snd ms) .+. ")"
        else "{" .+. ppList "," ms .+. "}"
    where
      args = length ms-1
  
  instance Pretty (BS.ByteString, Exp) where
    pp (n, x) = put n .+. ":" .+. pp x
  
  instance Pretty (Var, Exp) where
    pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex
  
  instance Pretty Bool where
    pp True  = "true"
    pp False = "false"
  
  -- | Print a series of NewVars at once, to avoid unnecessary "var" keywords.
  ppAssigns :: Stm -> PP ()
  ppAssigns stm = do
      line $ "var " .+. ppList ("," .+. newl .+. ind) assigns .+. ";"
      pp next
    where
      (assigns, next) = gather [] stm
      gather as (Assign (NewVar _ v) ex nxt) = gather ((v, ex):as) nxt
      gather as nxt                          = (reverse as, nxt)
  
  -- | Returns the final statement in a case branch.
  finalStm :: Stm -> PP Stm
  finalStm s =
    case s of
      Assign _ _ s'   -> finalStm s'
      Case _ _ _ next -> finalStm next
      Forever s'      -> finalStm s'
      _               -> return s
  
  instance Pretty Stm where
    pp (Case cond def alts next) = do
      prettyCase cond def alts
      pp next
    pp (Forever stm) = do
      line "while(1){"
      indent $ pp stm
      line "}"
    pp s@(Assign lhs ex next) = do
      case lhs of
        _ | lhs == blackHole ->
          line (pp ex .+. ";") >> pp next
        NewVar _ _ ->
          ppAssigns s
        LhsExp _ _ ->
          line (pp lhs .+. sp .+. "=" .+. sp .+. pp ex .+. ";") >> pp next
    pp (Return ex) = do
      line $ "return " .+. pp ex .+. ";"
    pp (Cont) = do
      line "continue;"
    pp (Stop) = do
      return ()
    pp (Tailcall call) = do
      b <- getCfg tailChainBound
      if b <= 1
        then line $ "return new F(function(){return " .+. pp call .+. ";});"
        else line $ "return C > " .+. put (b-1) .+. " ? new F(function(){return "
                      .+. pp call .+. ";}) : (++C," .+. pp call .+. ");"
    pp (ThunkRet ex) = do
      line $ "return " .+. pp ex .+. ";"
  
  neg :: Exp -> Maybe Exp
  neg (BinOp Eq a b)  = Just $ BinOp Neq a b
  neg (BinOp Neq a b) = Just $ BinOp Eq a b
  neg (BinOp GT a b)  = Just $ BinOp LTE a b
  neg (BinOp LT a b)  = Just $ BinOp GTE a b
  neg (BinOp GTE a b) = Just $ BinOp LT a b    
  neg (BinOp LTE a b) = Just $ BinOp GT a b
  neg _               = Nothing
  
  -- | Turn eligible case statements into if statements.
  prettyCase :: Exp -> Stm -> [Alt] -> PP ()
  prettyCase cond def [(con, branch)] = do
    case (def, branch) of
      (_, Stop) -> do
        line $ "if(" .+. pp (neg' (test con)) .+. "){"
        indent $ pp def
        line "}"
      (Stop, _) -> do
        line $ "if(" .+. pp (test con) .+. "){"
        indent $ pp branch
        line "}"
      _ -> do
        line $ "if(" .+. pp (test con) .+."){"
        indent $ pp branch
        line "}else{"
        indent $ pp def
        line "}"
    where
      test (Lit (LBool True))  = cond
      test (Lit (LBool False)) = Not cond
      test (Lit (LNum 0))      = Not cond
      test c                   = BinOp Eq cond c
      neg' c = maybe (Not c) id (neg c)
  prettyCase _ def [] = do
    pp def
  prettyCase cond def alts = do
    line $ "switch(" .+. pp cond .+. "){"
    indent $ do
      mapM_ pp alts
      line $ "default:"
      indent $ pp def
    line "}"
  
  instance Pretty Alt where
    pp (con, branch) = do
      line $ "case " .+. pp con .+. ":"
      indent $ do
        pp branch
        s <- finalStm branch
        case s of
          Return _ -> return ()
          Cont     -> return ()
          _        -> line "break;";
  
  opParens :: BinOp -> Exp -> Exp -> PP ()
  opParens Sub a (BinOp Sub (Lit (LNum 0)) b) =
    opParens Add a b
  opParens Sub a (Lit (LNum n)) | n < 0 =
    opParens Add a (Lit (LNum (-n)))
  opParens Sub (Lit (LNum 0)) b =
    case b of
      BinOp _ _ _ -> " -(" .+. pp b .+. ")"
      _           -> " -" .+. pp b
  opParens op a b = do
    let bparens = case b of
                    Lit (LNum n) | n < 0 -> \x -> "(".+. pp x .+. ")"
                    _                          -> parensR
    parensL a .+. put (stringUtf8 $ show op) .+. bparens b
    where
      parensL x = if expPrec x < opPrec op
                    then "(" .+. pp x .+. ")"
                    else pp x
      parensR x = if expPrec x <= opPrec op
                    then "(" .+. pp x .+. ")"
                    else pp x
  
  -- | Normalize an operator expression by shifting parentheses to the left for
  --   all associative operators and eliminating comparisons with true/false.
  norm :: Exp -> Exp
  norm (BinOp op a (BinOp op' b c)) | op == op' && opIsAssoc op =
    norm (BinOp op (BinOp op a b) c)
  norm (BinOp Eq a (Lit (LBool True)))   = norm a
  norm (BinOp Eq (Lit (LBool True)) b)   = norm b
  norm (BinOp Eq a (Lit (LBool False)))  = Not (norm a)
  norm (BinOp Eq (Lit (LBool False)) b)  = Not (norm b)
  norm (BinOp Neq a (Lit (LBool True)))  = Not (norm a)
  norm (BinOp Neq (Lit (LBool True)) b)  = Not (norm b)
  norm (BinOp Neq a (Lit (LBool False))) = norm a
  norm (BinOp Neq (Lit (LBool False)) b) = norm b
  norm e = e
  