module Language.Trans.CStructs2Copilot where
import Data.Char ( isUpper, toLower )
import Data.List ( intercalate )
import Data.List.Extra ( toHead, toTail )
import qualified Language.C.AbsC as C
import Language.Copilot.CStruct ( CField (CArray, CPlain),
CStruct (..) )
import Language.Trans.CStruct2CopilotStruct ( camelCaseTypeName, mkCStruct )
cstructs2CopilotDecls :: C.TranslationUnit -> Either String [ String ]
cstructs2CopilotDecls :: TranslationUnit -> Either String [String]
cstructs2CopilotDecls (C.MkTranslationUnit [ExternalDeclaration]
gs) =
[[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> Either String [[String]] -> Either String [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExternalDeclaration -> Either String [String])
-> [ExternalDeclaration] -> Either String [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((CStruct -> [String])
-> Either String CStruct -> Either String [String]
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CStruct -> [String]
cstruct2CopilotDecls (Either String CStruct -> Either String [String])
-> (ExternalDeclaration -> Either String CStruct)
-> ExternalDeclaration
-> Either String [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExternalDeclaration -> Either String CStruct
mkCStruct) [ExternalDeclaration]
gs
cstruct2CopilotDecls :: CStruct -> [ String ]
cstruct2CopilotDecls :: CStruct -> [String]
cstruct2CopilotDecls CStruct
cstruct = [ CStruct -> String
cStructToCopilotStruct CStruct
cstruct
, CStruct -> String
structInstance CStruct
cstruct
, CStruct -> String
typedInstance CStruct
cstruct
]
cStructToCopilotStruct :: CStruct -> String
cStructToCopilotStruct :: CStruct -> String
cStructToCopilotStruct CStruct
cstruct = [String] -> String
unlines
[ String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatype String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constructor
, String
" deriving Generic"
]
where
datatype :: String
datatype = String -> String
cStructName2Haskell (CStruct -> String
cStructName CStruct
cstruct)
constructor :: String
constructor = String -> String
cStructName2Haskell (CStruct -> String
cStructName CStruct
cstruct) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fields
fields :: String
fields = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"}"])
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
toTail (String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
toHead (String
"{ " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (CField -> String) -> [CField] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CStruct -> CField -> String
toField CStruct
cstruct) (CStruct -> [CField]
cStructFields CStruct
cstruct)
toField :: CStruct -> CField -> String
toField :: CStruct -> CField -> String
toField CStruct
cstruct' (CPlain String
t String
n) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty
where
name :: String
name = CStruct -> String -> String
fieldName CStruct
cstruct' String
n
ty :: String
ty = String
"Field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cTypeName2HaskellType String
t
toField CStruct
cstruct' (CArray String
t String
n Integer
l) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty
where
name :: String
name = CStruct -> String -> String
fieldName CStruct
cstruct' String
n
ty :: String
ty = String
"Field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Array"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cTypeName2HaskellType String
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
structInstance :: CStruct -> String
structInstance :: CStruct -> String
structInstance CStruct
cstruct = [String] -> String
unlines
[ String
"instance Struct " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
instanceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
, String
" typeName = typeNameDefault"
, String
" toValues = toValuesDefault"
]
where
instanceName :: String
instanceName = String -> String
cStructName2Haskell (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CStruct -> String
cStructName CStruct
cstruct
typedInstance :: CStruct -> String
typedInstance :: CStruct -> String
typedInstance CStruct
cstruct = [String] -> String
unlines
[ String
"instance Typed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
instanceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
, String
" typeOf = typeOfDefault"
]
where
instanceName :: String
instanceName = String -> String
cStructName2Haskell (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CStruct -> String
cStructName CStruct
cstruct
fieldName :: CStruct -> String -> String
fieldName :: CStruct -> String -> String
fieldName CStruct
cstruct String
n =
String -> String
summary (String -> String
cStructName2Haskell (CStruct -> String
cStructName CStruct
cstruct)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cStructName2Haskell String
n
where
summary :: String -> String
summary :: String -> String
summary = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isUpper
cStructName2Haskell :: String -> String
cStructName2Haskell :: String -> String
cStructName2Haskell = String -> String
camelCaseTypeName
cTypeName2HaskellType :: String -> String
cTypeName2HaskellType :: String -> String
cTypeName2HaskellType String
"float" = String
"Float"
cTypeName2HaskellType String
"double" = String
"Double"
cTypeName2HaskellType String
"int" = String
"Int"
cTypeName2HaskellType String
"uint8_t" = String
"Word8"
cTypeName2HaskellType String
"uint16_t" = String
"Word16"
cTypeName2HaskellType String
"uint32_t" = String
"Word32"
cTypeName2HaskellType String
"uint64_t" = String
"Word64"
cTypeName2HaskellType String
"int8_t" = String
"Int8"
cTypeName2HaskellType String
"int16_t" = String
"Int16"
cTypeName2HaskellType String
"int32_t" = String
"Int32"
cTypeName2HaskellType String
"int64_t" = String
"Int64"
cTypeName2HaskellType String
"bool" = String
"Bool"
cTypeName2HaskellType String
t = String -> String
camelCaseTypeName String
t