<commit_before>module Main where

import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import Data.Typeable
import System.Environment
import Language.C.Analysis
import Language.C.Pretty
import Language.C.Data.Ident

import Parser

{--
Usage:
$ pwd
/home/kiwamu/src/netbsd-arafura-s1
$ struct2hs $HOME/src/netbsd-arafura-s1/obj/tooldir/bin/i486--netbsdelf-gcc "-Di386 -I$HOME/src/netbsd-arafura-s1/sys/arch/i386/compile/obj/GENERIC_HS -I$HOME/src/netbsd-arafura-s1/common/include -I$HOME/src/netbsd-arafura-s1/sys/arch -I$HOME/src/netbsd-arafura-s1/sys -nostdinc -I$HOME/src/netbsd-arafura-s1/metasepi/sys/hsbuild/cbits -I$HOME/src/netbsd-arafura-s1/metasepi/sys/hsbuild -I$HOME/src/netbsd-arafura-s1/metasepi/sys/hsdummy -DMAXUSERS=64 -D_KERNEL -D_KERNEL_OPT -DNDEBUG -D_JHC_GC=_JHC_GC_JGC -D_JHC_CONC=_JHC_CONC_CUSTOM -D_JHC_USE_OWN_STDIO -D_JHC_STANDALONE=0 -I$HOME/src/netbsd-arafura-s1/common/lib/libc/quad -I$HOME/src/netbsd-arafura-s1/common/lib/libc/string -I$HOME/src/netbsd-arafura-s1/common/lib/libc/arch/i386/string -I$HOME/src/netbsd-arafura-s1/sys/dist/ipf -I$HOME/src/netbsd-arafura-s1/sys/external/isc/atheros_hal/dist -I$HOME/src/netbsd-arafura-s1/sys/external/isc/atheros_hal/ic -I$HOME/src/netbsd-arafura-s1/sys/external/bsd/drm/dist/bsd-core -I$HOME/src/netbsd-arafura-s1/sys/external/bsd/drm/dist/shared-core -I$HOME/src/netbsd-arafura-s1/common/include -I$HOME/src/netbsd-arafura-s1/sys/external/bsd/acpica/dist/include" sys/dev/pci/auich_extern_SNATCHED.h
--}

cToHsName :: String -> String
cToHsName = concat . fmap (\(x:xs) -> toUpper x:xs) . filter (not . null) . fmap (filter isAlphaNum) . groupBy (\a b -> isAlphaNum a && isAlphaNum b)

cToHsTypeName :: TypeName -> Maybe String
cToHsTypeName TyVoid                 = Just "()"
cToHsTypeName (TyIntegral TyBool)    = Just "Bool"
cToHsTypeName (TyIntegral TyChar)    = Just "Char"
cToHsTypeName (TyIntegral TySChar)   = Just "CSChar"
cToHsTypeName (TyIntegral TyUChar)   = Just "CUChar"
cToHsTypeName (TyIntegral TyShort)   = Just "CShort"
cToHsTypeName (TyIntegral TyUShort)  = Just "CUShort"
cToHsTypeName (TyIntegral TyInt)     = Just "Int"
cToHsTypeName (TyIntegral TyUInt)    = Just "CUInt"
cToHsTypeName (TyIntegral TyLong)    = Just "CLong"
cToHsTypeName (TyIntegral TyULong)   = Just "CULong"
cToHsTypeName (TyIntegral TyLLong)   = Just "CLLong"
cToHsTypeName (TyIntegral TyULLong)  = Just "CULLong"
cToHsTypeName (TyFloating TyFloat)   = Just "Float"
cToHsTypeName (TyFloating TyDouble)  = Just "Double"
cToHsTypeName (TyFloating TyLDouble) = Just "CLDouble"
cToHsTypeName (TyComp (CompTypeRef (NamedRef (Ident name _ _)) StructTag _)) = Just $ cToHsName name
cToHsTypeName _                      = Nothing

showParam :: ParamDecl -> String
showParam (ParamDecl (VarDecl _ _ t) _)         = cToHsType t
showParam (AbstractParamDecl (VarDecl _ _ t) _) = cToHsType t

cToHsType :: Type -> String
cToHsType t = fromMaybe (show $ pretty t) $ cToHsType' t

cToHsType' :: Type -> Maybe String
cToHsType' (DirectType tn _ _) = cToHsTypeName tn
cToHsType' (PtrType t _ _) = fmap (\a -> "(Ptr " ++ a ++ ")") $ cToHsType' t
cToHsType' (FunctionType (FunType rt para _) _) =
  let ret = fmap ("IO " ++) $ cToHsType' rt
      args = concat $ zipWith (++) (fmap showParam para) $ repeat " -> "
  in fmap (\a -> "(FunPtr (" ++ args ++ a ++ "))") $ ret
cToHsType' _ = Nothing

showNewType :: String -> String
showNewType stn = let hsStn = cToHsName stn in
  "newtype {-# CTYPE \"struct " ++ stn ++ "\" #-} " ++ hsStn ++ " = " ++ hsStn ++ " ()"

showHsCode :: String -> (String, Type) -> String
showHsCode stn (n, t) = let hsStn = cToHsName stn in
  "foreign import primitive \"const.offsetof(" ++ "struct " ++ stn ++ ", " ++ n ++
  ")\"\n  offsetOf_" ++ hsStn ++ "_" ++ n ++ " :: Int\n" ++
  "p_" ++ hsStn ++ "_" ++ n ++ " :: Ptr " ++ hsStn ++ " -> IO (Ptr " ++ cToHsType t ++ ")\n" ++
  "p_" ++ hsStn ++ "_" ++ n ++ " p = return $ plusPtr p offsetOf_" ++ hsStn ++ "_" ++ n

checkResult :: (Show a) => String -> (Either a b) -> IO b
checkResult label = either (error . (label++) . show) return

onlyStruct :: TagDef -> Bool<commit_msg>Create stripFunPtr function.<commit_after>module Main where

import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import Data.Typeable
import System.Environment
import Language.C.Analysis
import Language.C.Pretty
import Language.C.Data.Ident

import Parser

{--
Usage:
$ pwd
/home/kiwamu/src/netbsd-arafura-s1
$ struct2hs $HOME/src/netbsd-arafura-s1/obj/tooldir/bin/i486--netbsdelf-gcc "-Di386 -I$HOME/src/netbsd-arafura-s1/sys/arch/i386/compile/obj/GENERIC_HS -I$HOME/src/netbsd-arafura-s1/common/include -I$HOME/src/netbsd-arafura-s1/sys/arch -I$HOME/src/netbsd-arafura-s1/sys -nostdinc -I$HOME/src/netbsd-arafura-s1/metasepi/sys/hsbuild/cbits -I$HOME/src/netbsd-arafura-s1/metasepi/sys/hsbuild -I$HOME/src/netbsd-arafura-s1/metasepi/sys/hsdummy -DMAXUSERS=64 -D_KERNEL -D_KERNEL_OPT -DNDEBUG -D_JHC_GC=_JHC_GC_JGC -D_JHC_CONC=_JHC_CONC_CUSTOM -D_JHC_USE_OWN_STDIO -D_JHC_STANDALONE=0 -I$HOME/src/netbsd-arafura-s1/common/lib/libc/quad -I$HOME/src/netbsd-arafura-s1/common/lib/libc/string -I$HOME/src/netbsd-arafura-s1/common/lib/libc/arch/i386/string -I$HOME/src/netbsd-arafura-s1/sys/dist/ipf -I$HOME/src/netbsd-arafura-s1/sys/external/isc/atheros_hal/dist -I$HOME/src/netbsd-arafura-s1/sys/external/isc/atheros_hal/ic -I$HOME/src/netbsd-arafura-s1/sys/external/bsd/drm/dist/bsd-core -I$HOME/src/netbsd-arafura-s1/sys/external/bsd/drm/dist/shared-core -I$HOME/src/netbsd-arafura-s1/common/include -I$HOME/src/netbsd-arafura-s1/sys/external/bsd/acpica/dist/include" sys/dev/pci/auich_extern_SNATCHED.h
--}

cToHsName :: String -> String
cToHsName = concat . fmap (\(x:xs) -> toUpper x:xs) . filter (not . null) . fmap (filter isAlphaNum) . groupBy (\a b -> isAlphaNum a && isAlphaNum b)

cToHsTypeName :: TypeName -> Maybe String
cToHsTypeName TyVoid                 = Just "()"
cToHsTypeName (TyIntegral TyBool)    = Just "Bool"
cToHsTypeName (TyIntegral TyChar)    = Just "Char"
cToHsTypeName (TyIntegral TySChar)   = Just "CSChar"
cToHsTypeName (TyIntegral TyUChar)   = Just "CUChar"
cToHsTypeName (TyIntegral TyShort)   = Just "CShort"
cToHsTypeName (TyIntegral TyUShort)  = Just "CUShort"
cToHsTypeName (TyIntegral TyInt)     = Just "Int"
cToHsTypeName (TyIntegral TyUInt)    = Just "CUInt"
cToHsTypeName (TyIntegral TyLong)    = Just "CLong"
cToHsTypeName (TyIntegral TyULong)   = Just "CULong"
cToHsTypeName (TyIntegral TyLLong)   = Just "CLLong"
cToHsTypeName (TyIntegral TyULLong)  = Just "CULLong"
cToHsTypeName (TyFloating TyFloat)   = Just "Float"
cToHsTypeName (TyFloating TyDouble)  = Just "Double"
cToHsTypeName (TyFloating TyLDouble) = Just "CLDouble"
cToHsTypeName (TyComp (CompTypeRef (NamedRef (Ident name _ _)) StructTag _)) = Just $ cToHsName name
cToHsTypeName _                      = Nothing

showParam :: ParamDecl -> String
showParam (ParamDecl (VarDecl _ _ t) _)         = cToHsType t
showParam (AbstractParamDecl (VarDecl _ _ t) _) = cToHsType t

stripFunPtr :: Type -> Maybe String
stripFunPtr (FunctionType (FunType rt para _) _) =
  let ret = fmap ("IO " ++) $ cToHsType' rt
      args = concat $ zipWith (++) (fmap showParam para) $ repeat " -> "
  in fmap (args ++) $ ret

cToHsType :: Type -> String
cToHsType t = fromMaybe (show $ pretty t) $ cToHsType' t

cToHsType' :: Type -> Maybe String
cToHsType' (DirectType tn _ _) = cToHsTypeName tn
cToHsType' (PtrType t _ _) = fmap (\a -> "(Ptr " ++ a ++ ")") $ cToHsType' t
cToHsType' t@(FunctionType _ _) = fmap (\a -> "(FunPtr (" ++ a ++ "))") $ stripFunPtr t
cToHsType' _ = Nothing

showNewType :: String -> String
showNewType stn = let hsStn = cToHsName stn in
  "newtype {-# CTYPE \"struct " ++ stn ++ "\" #-} " ++ hsStn ++ " = " ++ hsStn ++ " ()"

showHsCode :: String -> (String, Type) -> String
showHsCode stn (n, t) = let hsStn = cToHsName stn in
  "foreign import primitive \"const.offsetof(" ++ "struct " ++ stn ++ ", " ++ n ++
  ")\"\n  offsetOf_" ++ hsStn ++ "_" ++ n ++ " :: Int\n" ++
  "p_" ++ hsStn ++ "_" ++ n ++ " :: Ptr " ++ hsStn ++ " -> IO (Ptr " ++ cToHsType t ++ ")\n" ++
  "p_" ++ hsStn ++ "_" ++ n ++ " p = return $ plusPtr p offsetOf_" ++ hsStn ++ "_" ++ n

checkResult :: (Show a) => String -> (Either a b) -> IO b
checkResult label = either (error . (label++) . show) return

onlyStruct :: TagDef -> Bool
{'fraction_non_alphanumeric': 0.15422768068020784, 'fraction_numerical': 0.00826641473783656, 'mean_word_length': 3.903879559930515, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 40, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5407462', 'n_tokens_mistral': 3567, 'n_tokens_neox': 3368, 'n_words': 672}