{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module TclUtils(
    ExpandInfoBag(..),
    ExpandInfoHelper(..),
    checkEmptyList,
    eieDump,
    eieSearch,
    eMsgsToTcl,
    genId,
    getChildren,
    getEIElement,
    getInfo,
    getPositionPair,
    initExpandInfoBag,
    isRealPosition,
    lookupEIElement,
    lookupError,
    reportErrorsToTcl,
    showTaggedPosition,
    tclPosition,
    toPrintable,
    toPrintableDEBUG,
) where

--------
import Data.Char(isPrint,ord)
import Data.List(elemIndices)
import Control.Monad(foldM, unless)
import Text.Regex
import Text.Printf(printf)
import System.IO(hPutStr, stderr)
import qualified Data.Map as Map

import HTcl
import Error(internalError, EMsg, WMsg, showErrorList, showWarningList)
import PPrint
import PVPrint
import Id
import CSyntax
import ISyntax
import Pragma(DefProp(..))
import SymTab
import Assump
import Scheme
import Position
import FStringCompat
import FileNameUtil(baseName, getFullFilePath, getRelativeFilePath, dropSuf)
import Util(fst3)

---------------------------------------------
-- generate a qualified ID from the string Foo::x
genId :: String -> Id
genId s =  case (elemIndices ':' s)  of
             [] -> mk_homeless_id s
             [a,b] -> let q = take (a) s
                          n = drop (b+1) s
                      in setIdQualString  (mk_homeless_id n) q
             _  -> error $ "Ill formed identifier name: '" ++ s ++ "'"

--------------------------------------------------------------------------------
-- Error Handling

-- Expect an empty list otherwise throw an error
-- TODO might be a good place to add a new IOError error to hold the list and message
-- so it can be turned back to a regular tcl object.
checkEmptyList :: (Show a) => String -> [a] -> IO ()
checkEmptyList _ [] = return ()
checkEmptyList ms os = ioError $ userError ( ms ++ "\n" ++ show os)

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

lookupError :: String -> String -> IO a
lookupError o s = ioError $ userError ( "Could not find a \""
                                         ++ o ++ "\" object with name \""
                                         ++ s ++ "\"." )


-- pass bluespec errors back to Tcl land  ie  $errorInfo
-- warnings are sent to stderr

reportErrorsToTcl :: [WMsg] -> [EMsg] -> IO ()
reportErrorsToTcl wms ems = do
  unless (null wms) $ hPutStr stderr (showWarningList wms)
  if null ems
  then return ()
  else eMsgsToTcl ems

eMsgsToTcl :: [EMsg] -> IO a
eMsgsToTcl [] = ioError $ userError "Unknown Error"
eMsgsToTcl ems = do
  let s = showErrorList ems
  error s


-------------------------------------------------------------------------------
-- Instances for bsc specific types
instance TclObjCvt Doc where
    toTclObj = toTclObj . toPrintable . docToOneLine

instance TclObjCvt Id where
    toTclObj i = toTclObj (pvpString i)

instance TclObjCvt (IDef a) where
    toTclObj (IDef i it _ie ps) = do --- why is expr dropped? XXX
      ti <- toTclObj i
      tit <- toTclObj it
      tps <- toTclObj ps
      toTclObj (TLst [TStr "IDef", TCL ti, TCL tit, TCL tps])

instance TclObjCvt DefProp where
  toTclObj (DefP_Rule i) = do ti <- toTclObj i ; toTclObj (TLst [TStr "DefP_Rule", TCL ti])
  toTclObj (DefP_Method i) = do ti <- toTclObj i ; toTclObj (TLst [TStr "DefP_Method", TCL ti])
  toTclObj (DefP_Instance i) = do ti <- toTclObj i ; toTclObj (TLst [TStr "DefP_Instance", TCL ti])
  toTclObj DefP_NoCSE = toTclObj "DefP_NoCSE"

instance TclObjCvt Type where
    toTclObj x = toTclObj (pvPrint PDReadable 0 x)

instance TclObjCvt Kind where
    toTclObj x = toTclObj (pvPrint PDReadable 0 x)

-- XXX
instance TclObjCvt IType where
    toTclObj (ITForAll i ik it) = do
                           ti <- toTclObj i
                           tit <- toTclObj it
                           tik <- toTclObj ik
                           toTclObj (TLst [TStr "ITForAll", TCL ti, TCL tik])
    toTclObj (ITAp t1 t2) =
                           toTclObj (TLst [TStr "ITAP", TStr (show t1), TStr (show t2)])
    toTclObj (ITVar i) = do
                           ti <- toTclObj i
                           toTclObj (TLst [TStr "ITVar", TCL ti])
    toTclObj (ITCon i ik tis) = do
                           ti <- toTclObj i
                           toTclObj (TLst [TStr "ITCon", TCL ti])
    toTclObj (ITNum n) = do
      tn <- toTclObj n
      toTclObj (TLst [TStr "ITNum", TCL tn])
    toTclObj (ITStr s) = do
      tn <- toTclObj $ getFString s
      toTclObj (TLst [TStr "ITStr", TCL tn])

instance TclObjCvt IKind where
    toTclObj k = toTclObj (pPrint PDReadable 0 k)

instance TclObjCvt IdK where
    toTclObj k = toTclObj (pvPrint PDReadable 0 k)

-- XXX incomplete
instance TclObjCvt CDefn where
    toTclObj k@(Cdata {} ) = toTclObj (pvPrint PDReadable 0 k)
    toTclObj k = case getName k of
                   Right i -> toTclObj i
                   Left p  -> toTclObj (dummyId p)
    --toTclObj k = toTclObj (pPrint PDReadable 0 k)
    --toTclObj (Ctype k ids ct)

-- ?? Take care of ID
instance TclObjCvt Assump where
    toTclObj (i :>: s) = toTclObj s

instance TclObjCvt Scheme where
    toTclObj x = toTclObj (pvPrint PDReadable 0 x)

-- Conversion for SymTab Types
instance TclObjCvt VarInfo where
    toTclObj (VarInfo vk a d) = do
        ta <- toTclObj a
        tk <- toTclObj (show vk)
        td <- toTclObj d
        toTclObj $ TLst [TCL tk, TCL ta, TCL td]

instance TclObjCvt ConInfo where
    toTclObj (ConInfo i v a cti) = do
                             ti <- toTclObj i
                             ta <- toTclObj a
                             toTclObj $ TLst [TCL ti, TCL ta]

instance TclObjCvt TypeInfo where
    toTclObj (TypeInfo mi k vs tis) = do
                              i <- toTclObj (maybe "??" getIdString mi)
                              tk <- toTclObj k
                              tvs <- toTclObj vs
                              ttis <- toTclObj tis
                              toTclObj $ TLst [TCL i, TCL tk, TCL tvs, TCL ttis]

instance TclObjCvt TISort where
    toTclObj (TItype i t) = do
                            tfs <- toTclObj t
                            toTclObj $ TLst [TStr "alias", TCL tfs]

    toTclObj (TIdata is enum)  = do
                            tfs <- mapM toTclObj is
                            let name = if enum then "enum" else "union"
                            toTclObj $ TLst [TStr name, TLst (map TCL tfs)]

    toTclObj (TIstruct SStruct fs) = do
                            tfs <- mapM toTclObj fs
                            toTclObj $ TLst [TStr "structure", TLst (map TCL tfs)]

    toTclObj (TIstruct SClass fs) = do
                            tfs <- mapM toTclObj fs
                            toTclObj $ TLst [TStr "class", TLst (map TCL tfs)]

    toTclObj (TIstruct (SDataCon i _) fs) = do
                            tfs <- mapM toTclObj fs
                            toTclObj $ TLst [TStr "DataCon", TLst (map TCL tfs)]

    toTclObj (TIstruct (SInterface ps) fs) = do
                            tfs <- mapM toTclObj fs
                            toTclObj $ TLst [TStr "interface", TLst (map TCL tfs)]

    toTclObj (TIstruct (SPolyWrap _ _ _) fs) = do
                            tfs <- mapM toTclObj fs
                            toTclObj $ TLst [TStr "PolyWrap", TLst (map TCL tfs)]

    toTclObj TIabstract = toTclObj "Abstract"


instance TclObjCvt FieldInfo where
    toTclObj x = toTclObj $ pPrint PDReadable 0 x


instance TclObjCvt Position where
    toTclObj pos = toTclObj $ tclPosition pos

tclPosition :: Position -> [String]
tclPosition  (Position fs l c pred) =
    let f = getFString fs
        rf = getRelativeFilePath f
        ff = getFullFilePath f
        bf = addBSDir ff
        pf = if bf == ff then rf else bf
        base_name = baseName f
        lib = dropSuf base_name
    in if l==(-2) && c<0 && f=="" then ["Command","",""] else
           if l<0 && c<0 && f=="" then ["Unknown","",""] else
               if pred then [pf, show l, show c, "Library " ++ lib] else
               [pf, show l, show c]

addBSDir :: String -> String
addBSDir ff | ff' /= ff = ff'
 where regex = mkRegex "^[ ]*/.+/src/Libraries/Base.+/"
       ff'   = subRegex regex ff "%/Libraries/"
addBSDir ff = ff

showTaggedPosition :: (HasPosition a) => a -> [HTclObj]
showTaggedPosition i =
    let pos = getPosition i
        res = [tagManyStr "position" (tclPosition pos)]
        isUseful = isRealPosition pos
    in  if isUseful then res else []

getPositionPair :: (HasPosition a) => a -> [HTclObj]
getPositionPair i =
    let pos = getPosition i
        res = [TStr "position",  positionToTObj pos]
        isUseful = isRealPosition pos
    in  if isUseful then res else []

isRealPosition :: Position -> Bool
isRealPosition pos@(Position fs line column pred) =
    pos /= noPosition

--------------------------------------------------------------------------
-- Help functions and structure for dealing with hierarchy trees in an easy way

data ExpandInfoBag a = ExpandInfoBag { mbag         :: Map.Map Int (ExpandInfoElem a)
                                     ,maxIdx        :: Int
                                     }

initExpandInfoBag ::  ExpandInfoBag a
initExpandInfoBag = ExpandInfoBag { mbag    = Map.singleton 0 Root
                                  ,maxIdx   = 0
                                  }

-- TODO this can be generalize from IO to Monad
class ExpandInfoHelper a where
    getRootElem :: IO a  -- The root element
    getChildrenf :: a -> IO [a]
    getTextf     :: a -> IO String
    getTagsf     :: a -> IO [String]
    getInfof     :: a -> IO HTclObj

-- TODO add left| branch attr to tuple for iwidgets
type EIDisplay = [(Int,String,[String])]

data ExpandInfoElem a = Root -- unpopulated tree
                      |TrueLeaf a
                      | CurrentLeaf a
                      | Branch a EIDisplay

getEIElement :: ExpandInfoElem a -> a
getEIElement Root            = internalError ("TclUtil::getEIElement Root")
getEIElement (TrueLeaf x)    = x
getEIElement (CurrentLeaf x) = x
getEIElement (Branch x _)    = x


eieDump :: ExpandInfoHelper a => ExpandInfoBag a -> IO [HTclObj]
eieDump bag =
    do
      let
          genOneObj :: ExpandInfoHelper a => (Int,ExpandInfoElem a) -> IO HTclObj
          genOneObj (k,o) = do
            i <- case o of
                   Root  -> return $ TStr "Root"
                   _     -> getTextf (getEIElement o) >>= (return .  TStr)
            return $ TLst [TInt k, i]
      mapM genOneObj (Map.toList (mbag bag))

-- flow is to lookup,  then update the global state and then return
getChildren :: ExpandInfoHelper a => ExpandInfoBag a -> Int -> IO (ExpandInfoBag a, EIDisplay)
getChildren bagin key =
    let
        updateCurrent :: ExpandInfoElem a -> ExpandInfoBag a ->  ExpandInfoBag a
        updateCurrent elem b = b { mbag = Map.insert key elem (mbag b)}
        --
        -- expansion for a current leaf
        expandCLeaf :: (ExpandInfoHelper a) => [a] -> ExpandInfoBag a -> IO (ExpandInfoBag a, EIDisplay)
        expandCLeaf [] bag = return (bag,[])
        expandCLeaf cas bag = do
          let
              -- next set of indexes
              nextIndexs :: [Int]
              nextIndexs = [(1 + maxIdx bag) ..]
              -- new elements for the bag
              eileafs = (map CurrentLeaf cas)
              newElems = Map.fromList (zip nextIndexs eileafs)
              m' = Map.union newElems (mbag bag)
              b' = bag { mbag = m', maxIdx = maxIdx bag + length cas }

          -- generate the displaed text
          cTestStrs <- mapM getTextf cas
          tags      <- mapM getTagsf  cas
          let
              children :: EIDisplay
              children = zip3 nextIndexs cTestStrs tags
          return (b', children)
        --
    --
    in case lookupEIElement bagin key of
         Root          -> do root <- getRootElem
                             cas  <- getChildrenf root
                             (b',d) <- expandCLeaf cas bagin
                             let replaceElem = if null cas then TrueLeaf root
                                               else Branch root d
                                 b'' = updateCurrent replaceElem b'
                             return (b'',d)
         TrueLeaf x    -> return (bagin, [])
         CurrentLeaf x -> do cas <- getChildrenf x
                             (b',d) <- expandCLeaf cas bagin
                             let replaceElem = if null cas then TrueLeaf x
                                               else Branch x d
                                 b'' = updateCurrent replaceElem b'
                             return (b'',d)

         Branch x d    -> return (bagin,d)

getInfo :: ExpandInfoHelper a => ExpandInfoBag a -> Int -> IO HTclObj
getInfo b key = getInfof (getRawEIElement b key)

getRawEIElement ::  ExpandInfoBag a -> Int -> a
getRawEIElement b key = getEIElement $ lookupEIElement b key

lookupEIElement ::  ExpandInfoBag a -> Int -> ExpandInfoElem a
lookupEIElement b key = let err = error ("lookupEIElement: Invalid lookup of element " ++ show key)
                        in Map.findWithDefault err key (mbag b)

eieSearch :: (ExpandInfoHelper a) => (a -> Bool)  -> ExpandInfoBag a -> IO (ExpandInfoBag a, [EIDisplay])
eieSearch testf obag = do
  let searchLevel path (bag,found) key = do
            (bag',children) <- getChildren  bag key
            let elem = getRawEIElement bag' key
            s <- getTextf elem
            t <- getTagsf elem
            let path'  = if key /= 0 then (key,s,t):path else path
                found' = if testf elem then (reverse path'):found else found
            foldM (searchLevel path') (bag',found') (map fst3 children)
  searchLevel [] (obag,[]) 0

positionToTObj ::  Position -> HTclObj
positionToTObj p = toHTObj $ tclPosition p

-----------------------------------------------------------------------------
instance HTclObjCvt Doc where
    toHTObj = TStr . toPrintable . docToOneLine

instance HTclObjCvt Id  where
    toHTObj i = toHTObj $  pvPrint PDReadable 0 i

instance HTclObjCvt CType where
    toHTObj i = toHTObj $ pvPrint PDReadable 0 i

instance HTclObjCvt Position  where
    toHTObj p = toHTObj $ tclPosition p

instance (HTclObjCvt a) => HTclObjCvt (Maybe a)  where
    toHTObj (Just i) = tag "Just" [toHTObj i]
    toHTObj Nothing  = TStr "Nothing"

instance HTclObjCvt [EMsg] where
    toHTObj es = toHTObj $ showErrorList es


------------------------------------------------------------------------
toPrintable :: String -> String
toPrintable = filter isPrint

toPrintableDEBUG :: String -> String
toPrintableDEBUG = concatMap toPrintable'
    where toPrintable' c | isPrint c = [c]
                         | otherwise = printf "<%X>" (ord c)