module IdPrint(
          pvpPId, pvpId, pfpId, ppId, ppConId, ppVarId, mkUId,
          getBSVIdString
         ) where

import Data.Char(isDigit)

import Id
import Util(dbgLevel)
import Lex(isIdChar, isSym)
import ErrorUtil(internalError)
import PreStrings(fsEmpty, fsPrelude, fsPreludeBSV)
import Classic
import PPrint
import PVPrint
import IOUtil(progArgs)

show_qual :: Bool
show_qual = "-show-qualifiers" `elem` progArgs

local_show :: Id -> String
local_show id =
    let
        pos = getIdPosition id
        mfs = getIdQualString id
        fs = getIdBaseString id
        str = show pos ++ " " ++
                show mfs ++ " " ++
                show fs
    in str

instance PPrint Id where
    pPrint PDDebug _ i = text (local_show i)
                -- <> text(" props: " ++  show (getIdProps i ))
    pPrint _ _ i =
        if (dbgLevel >= 1)
             then text ((getIdString i) ++
                        "_"  ++
                        (createPositionString (getIdPosition i)))
             else text (getIdString i)
--    pPrint _ _ i = text ((getIdString i) ++ "|" ++ (show (getIdPosition i)) ++ "|" ++ (show (getIdProps i)))
--    pPrint _ _ i = text ((getIdString i) ++ "|" ++ (show (getIdProps i)))

-- --------------------

instance PVPrint Id where
    pvPrint PDDebug _ i = text (show i)
    pvPrint PDNoqual _ i = text (getIdBaseString i)
    pvPrint _ _ i =
      let s = getBSVIdString i
      in text (if s=="not" then "!" else s)

pvpPId :: PDetail -> Id -> Doc
pvpPId d i =
    case getIdBaseString i of
    _   -> pvpId d i

pvpId :: PDetail -> Id -> Doc
pvpId PDDebug i = pvPrint PDDebug 0 i
pvpId PDNoqual i = pvPrint PDNoqual 0 i
pvpId d i =
    case getIdBaseString i of
    "->" -> text "(->)"
    ":=" -> text "<="
    "not" -> text "!"
    s@(c:_) | isDigit c -> text s
    c:_ | isIdChar c -> text (getBSVIdString i)
    _ -> text ("("++getBSVIdString i++")")

-- hack: suppress the package name for operators
getBSVIdString :: Id -> String
getBSVIdString a = (getBSVIdStringz a)
getBSVIdStringz :: Id -> String
getBSVIdStringz a
    | getIdBase a == fsEmpty = internalError "CVPrint.getIdStr: empty identifier"
    | getIdQual a == fsEmpty = getIdBaseStringz a
    | not (isIdChar (head (getIdBaseStringz a))) = getIdBaseStringz a -- operators
    | (not show_qual) && (getIdQual a == fsPrelude) =
          getIdBaseStringz a  -- suppress "Prelude::" unless flag is on
    | (not show_qual) && (getIdQual a == fsPreludeBSV) =
          getIdBaseStringz a  -- suppress "Prelude::" unless flag is on
    | otherwise = getIdQualString a ++ "::" ++ getIdBaseStringz a

getIdBaseStringz :: Id -> String
getIdBaseStringz a =
    let s = getIdBaseString a
    in if (not (isEse()) || length s < 7) then s
       else if (take 7 s == "ese_id_" || take 7 s == "Ese_id_") then drop 7 s
       else s

-- --------------------

pfpId :: PDetail -> Id -> Doc
pfpId = if isClassic() then ppId else pvpId

ppId :: PDetail -> Id -> Doc
ppId PDDebug i = pPrint PDDebug 0 i
ppId d i =
    if (dbgLevel >= 1)
    then case (getIdBaseString i) of
          "->" -> text "(->)"                          -- arrow
          s@(c:_) | isDigit c -> text( s ++ "_" ++ (createPositionString (getIdPosition i)))
          c:_ | isIdChar c -> text ((getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))
          '$':c:_ | isIdChar c -> text (getIdString i) -- task names
          _ -> text ("(" ++ (getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))
    else case (getIdBaseString i) of
          "->" -> text "(->)"                          -- arrow
          s@(c:_) | isDigit c -> text s                -- numbers
          c:_ | isIdChar c -> text (getIdString i)     -- identifiers
          '$':c:_ | isIdChar c -> text (getIdString i) -- task names
          _ -> text ("("++getIdString i++")")          -- infix operators

ppVarId :: PDetail -> Id -> Doc
ppVarId PDDebug i = pPrint PDDebug 0 i
ppVarId d i =
    if (dbgLevel >= 1)
    then case (getIdBaseString i) of
    s | all isSym s -> text ("("++ (getIdStringOp i) ++ (createPositionString (getIdPosition i)) ++
                             ")") -- infix operators
    '$':c:_ | isIdChar c -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))
    _ -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))
    else case (getIdBaseString i) of
    s | all isSym s -> text ("("++getIdStringOp i ++ ")") -- infix operators
    '$':c:_ | isIdChar c -> text (getIdStringVar i) -- task names
    _ -> text (getIdStringVar i)

ppConId :: PDetail -> Id -> Doc
ppConId PDDebug i = pPrint PDDebug 0 i
ppConId d i = -- text ( "props:" ++ show (getIdProps i)) <>
    case (getIdBaseString i) of
    "->" -> text "(->)"                -- arrow
    s@(c:_) | all isDigit s -> text s  -- numbers
    _ -> text (getIdStringCon i)       -- constructor-identifiers

-- These used to encode properties in .bi files
getIdStringCon :: Id -> String
getIdStringCon = getIdString
getIdStringVar :: Id -> String
getIdStringVar = getIdString
getIdStringOp :: Id -> String
getIdStringOp  = getIdString

-- --------------------

instance PPrint IdProp where
    pPrint d _ (IdPInlinedPositions poss) =
        pparen True (text "IdPInlinedPositions" <+> pPrint d 0 poss)
    pPrint _ _ prop = text (show prop)

{-
instance PVPrint IdProp where
    pvPrint d _ (IdPInlinedPositions poss) =
        pparen True (text "IdPInlinedPositions" <+> pvPrint d 0 poss)
    pvPrint _ _ prop = text (show prop)
-}