TypeString.hs

module FFICXX.SWIG.TypeString where

import Text.ParserCombinators.Parsec
import qualified FFICXX.Generate.Type.Class as FFICXX
import qualified Data.Map.Strict as Map
import Data.Functor ((<$>))
import Data.Map ((!))
import Text.StringLike (StringLike)
import Control.Applicative ((<*>), (<*), liftA2)

data CPPType = Ptr        CPPType -- ^ Pointer to a type
             | Ref        CPPType -- ^ Reference to a type
             | Arr        Int       CPPType -- ^ Array of a type
             | Fun        [CPPType] CPPType -- ^ A function
             | QConst     CPPType -- ^ const type
             | QVolatile  CPPType -- ^ volatile type
             | QRestrict  CPPType -- ^ restrict type, not supported, will give an error if passed such type
             | MPtr       String    CPPType -- ^ Member pointer to class
             | PrimType   PrimitiveTypes -- ^ Primitive c/c++ types
             deriving (Show, Eq)

data PrimitiveTypes = CPTChar
                    | CPTInt
                    | CPTLong
                    | CPTUChar
                    | CPTUInt
                    | CPTULong
                    | CPTLongLong
                    | CPTULongLong
                    | CPTDouble
                    | CPTLongDouble
                    | CPTBool
                    | CPTVoid
                    | CPTClass String
                    deriving (Show, Eq)

-- Translate parsed type string to FFICXX.Types
toCType ::  CPPType -> FFICXX.CTypes
toCType (Ptr (Ptr (PrimType CPTChar))) = FFICXX.CTCharStarStar
toCType (Ptr (PrimType CPTChar)) = FFICXX.CTString
toCType (Ptr (PrimType CPTInt)) = FFICXX.CTIntStar
toCType (Ptr (PrimType CPTLong)) = FFICXX.CPointer FFICXX.CTLong
toCType (Ptr (PrimType CPTDouble)) = FFICXX.CTDoubleStar
toCType (Ptr (PrimType CPTVoid)) = FFICXX.CTVoidStar
toCType (Ptr t@(Ptr _)) = FFICXX.CPointer $ toCType t
toCType (Ptr t@(PrimType _)) = FFICXX.CPointer $ toCType t
-- FIXME: Add array support
toCType (Arr _ _) = error "FIXME: Add array support"
-- FIXME: Add member pointers to classes support
toCType (MPtr _ _) = error "FIXME: Add member pointers to classes support"
-- FIXME: Add pointer to function support in FFICXX
toCType (Fun _ _) = error "FIXME: Add pointer to function support"
toCType (PrimType t) =
  case t of
    CPTChar -> FFICXX.CTChar
    -- FIXME: Add CTUChar in FFICXX
    CPTUChar -> FFICXX.CTChar
    CPTInt -> FFICXX.CTInt
    CPTUInt -> FFICXX.CTUInt
    CPTLong -> FFICXX.CTULong
    CPTULong -> FFICXX.CTULong
    -- FIXME: Add CTLongLong in FFICXX
    CPTLongLong -> FFICXX.CTLong
    -- FIXME: Add CTULongLong in FFICXX
    CPTULongLong -> FFICXX.CTULong
    CPTDouble -> FFICXX.CTDouble
    CPTBool -> FFICXX.CTBool
    -- FIXME: Add CTLongDouble in FFICXX
    CPTLongDouble -> FFICXX.CTDouble
    -- FIXME: FFICXX.Void should be of type CTypes
    CPTVoid -> undefined
    -- FIXME: This can be solved if FFICXX put CTypes,
    -- CPPTypes and Types into a single recursive type
    CPTClass _ -> undefined

toTypes ::  Map.Map String FFICXX.Class -> CPPType -> FFICXX.Types
toTypes clsMap (QConst (Ref (PrimType (CPTClass cls)))) = FFICXX.CPT (FFICXX.CPTClassRef (clsMap ! cls)) FFICXX.Const
toTypes clsMap (QConst (PrimType (CPTClass cls))) = FFICXX.CPT (FFICXX.CPTClassRef (clsMap ! cls)) FFICXX.Const
-- FIXME: Add volatile support in FFICXX
--toTypes (QVolatile t) = undefined
-- TODO: Investigate the behavior of `restrict`
toTypes clsMap (QRestrict t) = toTypes clsMap t
toTypes clsMap (Ref (PrimType (CPTClass cls))) = FFICXX.CPT (FFICXX.CPTClassRef (clsMap ! cls)) FFICXX.NoConst
-- FIXME: Add support for pointers to classes in FFICXX
toTypes clsMap (Ptr (PrimType (CPTClass cls))) = undefined
toTypes clsMap (PrimType (CPTClass cls)) = FFICXX.CPT (FFICXX.CPTClass (clsMap ! cls)) FFICXX.NoConst
-- FIXME: Add support ref to ctypes in FFICXX
toTypes clsMap (Ref t@(PrimType _)) = undefined
toTypes clsMap t@(Ptr (PrimType _)) = FFICXX.CT (toCType t) FFICXX.NoConst
toTypes clsMap t@(PrimType _) = FFICXX.CT (toCType t) FFICXX.NoConst

strToTypes ::  Map.Map String FFICXX.Class -> String -> FFICXX.Types
strToTypes clsMap s =
  case parse parserTypeString "" s of
    Left e -> error $ "Error: failed to convert type string to FFICXX.Types:\n" ++ show e
    Right t -> toTypes clsMap t







----------------------------------- Type string parsing ----------------------------------
qualifierList ::  [String]
qualifierList = ["const", "volatile", "restrict"]

qualifierMap ::  Map.Map String (CPPType -> CPPType)
qualifierMap  = Map.fromList
  [("const", QConst)
  ,("volatile", QVolatile)
  ,("restrict", QRestrict)]

identifier :: Parser String
identifier = (:) <$> letter <*> liftA2 (++) (many alphaNum) (option "" tpl)
  where angleBracket = between (char '<') (char '>')
        tpl = angleBracket $ parentheses $ concat <$> sepBy identifier (char ',')

parentheses :: Parser a -> Parser a
parentheses = between (char '(') (char ')')

-- Theses are for tests
typeStringParser :: String -> Either ParseError CPPType
typeStringParser = parse parserTypeString ""

parserTypeString :: Parser CPPType
parserTypeString = parserDeclarator

parserDeclarator :: Parser CPPType
parserDeclarator = parserPointer
               <|> parserQualifier
               <|> parserArray
               <|> parserReference
               <|> parserFunction
               <|> parserMemberPointer
               <|> parserPrimType

parserPrimType :: Parser CPPType
parserPrimType = do
  t <- parserChar
        <|> parserUChar
        <|> parserInt
        <|> parserUInt
        <|> parserLong
        <|> parserULong
        <|> parserDouble
        <|> parserLongDouble
        <|> parserBool
        <|> parserVoid
        <|> parserClassName
  return $ PrimType t

-- Parsers for declarators

parserPointer :: Parser CPPType
parserPointer = try (string "p." >> Ptr <$> parserDeclarator)

parserQualifier :: Parser CPPType
parserQualifier = try $ do
  q <- char 'q' >> parentheses parserQualifiers
  _ <- char '.'
  qualifierMap Map.! q <$> parserDeclarator
  where parserQualifiers = foldl1 (<|>) $ map (try . string) qualifierList

parserArray :: Parser CPPType
parserArray = try $ do
  dem <- char 'a' >> parentheses (many1 digit)
  _ <- char '.'
  Arr (read dem) <$> parserDeclarator

parserReference :: Parser CPPType
parserReference = try $ do
  _ <- string "r."
  Ref <$> parserDeclarator

parserFunction :: Parser CPPType
parserFunction = try $ do
  parms <- char 'f' >> parentheses (sepBy parserTypeString (char ','))
  _ <- char '.'
  Fun parms <$> parserTypeString

parserMemberPointer :: Parser CPPType
parserMemberPointer = try $ do
  cls <- char 'm' >> parentheses identifier
  _ <- char '.'
  MPtr cls <$> parserDeclarator

-- Parsers for primitive types

-- | End of keyword
eok :: Parser ()
eok = notFollowedBy (alphaNum <|> space)

parserChoice :: [String] -> Parser String
parserChoice = choice . map (try . (<* eok) . string)

parserChar :: Parser PrimitiveTypes
parserChar = parserChoice ["char", "signed char"] >> return CPTChar

parserInt :: Parser PrimitiveTypes
parserInt = parserChoice ["int", "signed int", "short", "signed short", "short", "short int", "signed short int", "short signed int"] >>
  return CPTInt

parserLong :: Parser PrimitiveTypes
parserLong = parserChoice ["long", "signed long", "long int", "signed long int", "long signed int"] >>
  return CPTLong

parserLongLong :: Parser PrimitiveTypes
parserLongLong = parserChoice ["long long", "long long int", "signed long long", "signed long long int"] >>
  return CPTLongLong

parserBool :: Parser PrimitiveTypes
parserBool = parserChoice ["bool"] >> return CPTBool

parserDouble :: Parser PrimitiveTypes
parserDouble = parserChoice ["double", "float"] >> return CPTDouble

parserLongDouble :: Parser PrimitiveTypes
parserLongDouble = parserChoice ["long double"] >> return CPTLongDouble

parserUChar :: Parser PrimitiveTypes
parserUChar = parserChoice ["unsigned char"] >> return CPTUChar

parserUInt :: Parser PrimitiveTypes
parserUInt = parserChoice ["unsigned int", "unsigned short", "unsigned short int, short unsigned int"] >>
  return CPTUInt

parserULong :: Parser PrimitiveTypes
parserULong = parserChoice ["unsigned long", "unsigned long int", "long unsigned int"] >>
  return CPTULong

parserULongLong :: Parser PrimitiveTypes
parserULongLong = parserChoice ["unsigned long long", "unsigned long long int"] >>
  return CPTULongLong

parserVoid :: Parser PrimitiveTypes
parserVoid = parserChoice ["void"] >> return CPTVoid

parserClassName :: Parser PrimitiveTypes
parserClassName = try (CPTClass <$> identifier)