module Parse.Templates where
import Aux (tupToList)
import qualified Data.Text as T
import CGen.Typed (CShow(..), showForC)
import Control.Applicative ((<|>))
import Control.Monad (liftM, mfilter)
import Data.List ((\\))
import Data.Maybe (listToMaybe)
import Data.Text.Aux (parens)
import Data.Tuple (swap)
import Data.Typeable (typeOf, Typeable(..), TyCon(..), TypeRep(..), mkTyConApp, splitTyConApp)
import Foreign.C.Types
import Foreign.Ptr
import TextShow (TextShow(..), fromText, showt)
import TextShow.Generic (genericShowbPrec)
import GHC.Generics (Generic(..))
import qualified Data.Text as T (Text, append, concat, intercalate, singleton, pack, unwords)
data NamedVar = NameVar { varType :: T.Text
, varName :: T.Text
} deriving (Eq, Generic, Show)
instance TextShow NamedVar where
showb NameVar {varType = vt, varName = vn} = fromText $ T.append vt $ T.cons ' ' vn
data CFunctionTemplate = CFunTempl { returnType :: T.Text
, functionName :: T.Text
, inputVars :: [NamedVar]
, functionBody :: T.Text
} deriving (Eq, Generic, Show)
instance TextShow CFunctionTemplate where
showbPrec = genericShowbPrec
data NamedVal a = NameVal { valName :: T.Text,
value :: a
} deriving (Eq, Generic, Show)
instance TextShow a => TextShow (NamedVal a) where
showbPrec = genericShowbPrec
unTemplate :: CFunctionTemplate -> T.Text
unTemplate ct = T.concat [ returnType ct
, T.singleton ' '
, functionName ct
, parens . T.intercalate (T.pack ", ") . map showt . inputVars $ ct
, functionBody ct
]
fetchVar :: NamedVal a -> [NamedVar] -> (Maybe NamedVar, [NamedVar])
fetchVar nv@(NameVal {valName = vn}) vs = (listToMaybe fetched, vs \\ fetched)
where
fetched = filter ((== vn) . varName) vs
dumifyNamedVar :: NamedVar -> NamedVar
dumifyNamedVar NameVar {varType = vt, varName = vn} = NameVar {varType = vt, varName = T.append "dummy_" vn}
updateInputVar :: NamedVal a -> CFunctionTemplate -> [(T.Text, T.Text)]
updateInputVar ct v = undefined
insertAfterNewline :: T.Text -> T.Text -> T.Text
insertAfterNewline x y = before `T.append` x `T.append` after
where
(before, after) = T.span (/= '\n') y
namedVarDeclaration :: (CShow a, CTypeable a) => NamedVal a -> T.Text
namedVarDeclaration v = T.concat [ toCType . value $ v
, valName v
, "="
, showForC . value $ v
, ";\n"
]
declareNamedVar :: (CShow a, CTypeable a) => CFunctionTemplate -> NamedVal a -> T.Text
declareNamedVar ct v = namedVarDeclaration v `insertAfterNewline` functionBody ct
update :: (a -> Maybe a) -> a -> a
update f x = let Just y = f x <|> Just x in y
cTypeRep :: T.Text -> TypeRep
cTypeRep "char" = typeOf (undefined :: CChar)
cTypeRep "signed char" = typeOf (undefined :: CSChar)
cTypeRep "unsigned char" = typeOf (undefined :: CUChar)
cTypeRep "short" = typeOf (undefined :: CShort)
cTypeRep "short int" = typeOf (undefined :: CShort)
cTypeRep "signed short" = typeOf (undefined :: CShort)
cTypeRep "signed short int" = typeOf (undefined :: CShort)
cTypeRep "unsigned short" = typeOf (undefined :: CUShort)
cTypeRep "unsigned short int" = typeOf (undefined :: CUShort)
cTypeRep "int" = typeOf (undefined :: CInt)
cTypeRep "signed" = typeOf (undefined :: CInt)
cTypeRep "signed int" = typeOf (undefined :: CInt)
cTypeRep "unsigned" = typeOf (undefined :: CUInt)
cTypeRep "unsigned int" = typeOf (undefined :: CUInt)
cTypeRep "long" = typeOf (undefined :: CLong)
cTypeRep "long int" = typeOf (undefined :: CLong)
cTypeRep "signed long" = typeOf (undefined :: CLong)
cTypeRep "signed long int" = typeOf (undefined :: CLong)
cTypeRep "unsigned long" = typeOf (undefined :: CULong)
cTypeRep "unsigned long int" = typeOf (undefined :: CULong)
cTypeRep "long long" = typeOf (undefined :: CLLong)
cTypeRep "long long int" = typeOf (undefined :: CLLong)
cTypeRep "signed long long" = typeOf (undefined :: CLLong)
cTypeRep "signed long long int" = typeOf (undefined :: CLLong)
cTypeRep "unsigned long long" = typeOf (undefined :: CULLong)
cTypeRep "unsigned long long int" = typeOf (undefined :: CULLong)
cTypeRep "float" = typeOf (undefined :: CFloat)
cTypeRep "double" = typeOf (undefined :: CDouble)
cTypeRep str | T.last stripped == '*' = toPtrTypeRep . cTypeRep . T.strip . T.init $ stripped
| T.last stripped == ']' = error $ "cTypeRep needs to support arrays with length: " ++ show stripped
| otherwise = error $ "cTypeRep does not support: " ++ show stripped
where
stripped = T.strip str
class Typeable a => CTypeable a where
toCType :: a -> T.Text
toPtrTypeRep :: TypeRep -> TypeRep
toPtrTypeRep = applyTypeRep (undefined :: Ptr ())
toFunPtrTypeRep :: TypeRep -> TypeRep
toFunPtrTypeRep = applyTypeRep (undefined :: FunPtr ())
applyTypeRep :: Typeable a => a -> TypeRep -> TypeRep
applyTypeRep = typeRepCons . typeConHead
typeRepCons :: TyCon -> TypeRep -> TypeRep
typeRepCons = (. return) . mkTyConApp
typeConHead :: Typeable a => a -> TyCon
typeConHead = fst . splitTyConApp . typeOf