module BasicTypes 

	(
	  Name

	, QualName
	, qName
	, qOrigName
	, qModule
	, qDefModule
	, mkQualName
	, toQualName
	, prefixQName
	, prefixAppQName
	, setOrigQName

	, ScopedName
	, Inherit
	, GUID
	, Size(..)
	, CallConv(..)
	, BinaryOp(..)
	, UnaryOp(..)
	, ShiftDir(..)
	, Qualifier(..)
	, PointerType(..)

	, ParamDir(..)
	, isInOut

	, ppBinaryOp
	, ppUnaryOp
	, ppQualifier
	, ppSize
	, ppCallConv
	, ppName
	, ppQualName
	, ppDirection
	
	, strToCallConv
	
	, EnumKind(..)
	, classifyProgression

	) where

import PP
import Maybe ( fromMaybe )
import Opts  ( optNoQualNames, optIntIsInt )
import Utils ( mapMb )
import Int
{- BEGIN_GHC_ONLY
import GlaExts
   END_GHC_ONLY -}

-- a generic.. name.
type Name = String

-- a qualified.. Name - used throughout the backend to keep
-- track of home & name of types & values.
data QualName = QName {
		  qName       :: Name,
		  qOrigName   :: Name,
		  qModule     :: Maybe Name,
		  qDefModule  :: Maybe Name  -- where the name was originally defined.
		}
	        deriving Eq

mkQualName :: Maybe String -> String -> QualName
mkQualName md nm = QName nm nm md Nothing

toQualName :: String -> QualName
toQualName str = 
  case (break (=='.') (reverse str)) of
    (_,[])    -> mkQualName Nothing str
    (mn,_:dm) -> mkQualName (Just (reverse dm)) (reverse mn)

setOrigQName :: Name -> QualName -> QualName
setOrigQName nm qn = qn{qOrigName=nm}

prefixQName :: String -> QualName -> QualName
prefixQName v qn = qn{qName=v++qName qn , qDefModule=Nothing}

prefixAppQName :: String -> QualName -> QualName
prefixAppQName v qn = qn{qName=("(" ++v++" "++(qName qn)++")") , qDefModule=Nothing}

-- scoped names is OMG CORBA, as it allows
-- multi-level qualifiers on names, e.g., a::b::c
type ScopedName = [String]

-- an OMG interface can inherit from one or more interfaces.
-- DCE/MS IDL: just the one (with COM, you get the effect of
-- multiple inheritance from IUnknown.)
type Inherit = [Name]

-- A five element list
type GUID = [String]

data Size 
 = Short | Natural | Long | LongLong
   deriving (
              Show -- for Lex debugging only
	    , Eq
	    ) 

data CallConv = Stdcall | Pascal | Cdecl | Fastcall
	        deriving ( Eq, Show )

strToCallConv :: String -> Maybe CallConv
strToCallConv "stdcall" = Just Stdcall
strToCallConv "cdecl"   = Just Cdecl
strToCallConv _		= Nothing

data BinaryOp 
 = Xor | Or  | And | Shift ShiftDir 
 | Add | Sub | Div | Mod | Mul   
 | LogAnd | LogOr
 | Gt | Ge | Eq | Le | Lt | Ne
 deriving ( Eq, Show ) 

data UnaryOp  
 = Minus | Plus | Not | Negate | Deref
   deriving ( Eq, Show )

data ShiftDir 
 = L | R
   deriving ( Eq, Show )

data Qualifier 
 = Const | Volatile
   deriving (
              Show
	    , Eq
	    )

data PointerType 
  = Ptr 
  | Ref 
  | Unique
  deriving ( Eq, Show )

data ParamDir   = In | Out | InOut
                  deriving (Eq,Show) -- for Lex debugging only

isInOut :: ParamDir -> Bool
isInOut InOut = True
isInOut _     = False

ppBinaryOp :: BinaryOp -> PPDoc a
ppBinaryOp op =
   case op of
     Xor     -> char '^'
     Or      -> char '|'
     And     -> char '&'
     Shift d -> text (case d of { L -> "<<" ; R -> ">>" })
     Add     -> char '+'
     Sub     -> char '-'
     Div     -> char '/'
     Mod     -> char '%'
     Mul     -> char '*'
     LogAnd  -> text "&&"
     LogOr   -> text "||"
     Gt      -> char '>'
     Ge      -> text ">="
     Eq      -> text "=="
     Le      -> text "<="
     Lt      -> char '<'
     Ne      -> text "/="

ppUnaryOp :: UnaryOp -> PPDoc a
ppUnaryOp op =
 case op of
  Minus  -> char '-'
  Plus   -> char '+'
  Not    -> char '~'
  Negate -> char '!'
  Deref  -> char '*'

ppQualifier :: Qualifier -> PPDoc a
ppQualifier Const    = text "const"
ppQualifier Volatile = text "volatile"

ppSize :: Size -> PPDoc a
ppSize Short     = text "short"
ppSize Long      = text "long"
ppSize Natural 
  | optIntIsInt  = text "int"
  | otherwise    = text "long"
ppSize LongLong  = text "long long"

ppCallConv :: Bool -> CallConv -> PPDoc a
ppCallConv for_c c =
 text $
 case c of 
  Stdcall -> if for_c then "__stdcall" else "stdcall"
   -- it is hard to find definite information on this, but I believe
   -- that the Pascal calling convention is after all identical to
   -- Stdcall. (The MSDN docs seems to be utterly confused as to whether
   -- arguments are pushed L-to-R or R-to-L.)
  Pascal  -> if for_c then "__stdcall" else "stdcall"
--  Pascal  -> "pascal"
   -- _cdecl is not provided with gcc, just omit.
  Cdecl -> if for_c then "" else "ccall"
--  Cdecl -> if for_c then "_cdecl" else "ccall"
  Fastcall -> "fastcall"

ppName :: Name -> PPDoc a
ppName nm = text nm

ppQualName :: QualName -> PPDoc a
ppQualName (QName nm _ md def_mod)  
 | optNoQualNames = text nm
 | otherwise    =
    case def_mod of
      Nothing -> (fromMaybe empty (mapMb (\ m -> text m <> char '.') md)) <> text nm
      Just m  -> text m <> char '.' <> text nm

instance Show QualName where
  showsPrec _ q = showString (showPPDoc (ppQualName q) ())

ppDirection :: ParamDir -> PPDoc a
ppDirection d =
 text $
 case d of
   In    -> "in"
   Out   -> "out"
   InOut -> "in, out"

data EnumKind
 = EnumProgression
       Int     -- start offset
       Int     -- step. Note: *may* be < 0.
 | EnumFlags      -- 0, 1, 2, 4, 8, ..
       Int     -- start value
 | Unclassified
   deriving ( Show -- for debugging
            , Eq
	    )

 -- assume that the tag sequence is appropriately sorted.
 -- ('weird' int type of the tags is due to the fact that's
 --  the one we're using in Core.)
classifyProgression :: [Int32] -> EnumKind
classifyProgression []  = Unclassified
classifyProgression [x] = EnumProgression (fromIntegral x) 0
classifyProgression ls@(x:y:_)
  | x == y    			          = Unclassified
  | and (zipWith (==) ls (pow2Series x))  = EnumFlags (fromIntegral x)
  | and (zipWith (==) ls [x,(x+(y-x))..]) = EnumProgression (fromIntegral x) (fromIntegral (y-x))
  | otherwise                             = Unclassified
  where
   pow2Series n = n : pow2Series (doub n)

   doub n | n == 0    = 1
   	  | otherwise = 2*n