-- run doFiles on a SYSCALL_DEFINEx(...) copy-pasted from the kernel
-- sources (get rid of "__user", "const", tabs and empty lines, see
-- examples), and paste the contents of the individual files at the
-- right location in src/System/Hatrace.hs
--
-- handling for structs and other buffers needs to be added manually
--
-- TODO: parse syscalls from prototypes instead of kernel defines

import Data.List (intercalate, intersperse)

type Syscall = (String, [(String,String)])

wordsBy c [] = []
wordsBy c s  = let (a,s') = span (/=c) s
               in if null s' then [a] else a : wordsBy c (tail s')

mkPairs [] = []
mkPairs (a:b:cs) = (haskellType a,b) : mkPairs cs

haskellType "char" = "CChar"
haskellType "short" = "CShort"
haskellType "int" = "CInt"
haskellType "long" = "CLong"
haskellType "void" = "Void"
haskellType "size_t" = "CSize"
haskellType "mode_t" = "CMode"
haskellType "umode_t" = "CMode"
haskellType s
  | last s == '*' = "Ptr " ++ haskellType (reverse . dropWhile (== ' ') . tail . reverse $ s)
  | take 7 s == "struct " = haskellStruct $ drop 7 s
  | take 9 s == "unsigned " = haskellUnsigned $ drop 9 s
  | take 7 s == "signed " = haskellSigned $ drop 7 s
  | otherwise = error $ "unknown type " ++ s

haskellSigned "char" = "CSChar"
haskellSigned "short" = "CSShort"
haskellSigned "int" = "CSInt"
haskellSigned "long" = "CSLong"
haskellSigned s = error $ "unknown signed type " ++ s

haskellUnsigned "char" = "CUChar"
haskellUnsigned "short" = "CUShort"
haskellUnsigned "int" = "CUInt"
haskellUnsigned "long" = "CULong"
haskellUnsigned s = error $ "unknown unsigned type " ++ s


isInt s = s `elem` ["CChar", "CShort", "CInt", "CLong", "Void", "CSize", "CMode", "CSChar", "CSShort", "CSInt", "CSLong", "CUChar", "CUShort", "CUInt", "CULong"]
isPtr s = take 4 s == "Ptr "
isString = (== "Ptr CChar")

haskellStruct s = "Struct" ++ s -- TODO: convert snake_case to CamelCase

readSyscall :: String -> Syscall
readSyscall = (\(a:as) -> (a,mkPairs as)) . map (dropWhile (==' ')) . wordsBy ',' . takeWhile (/= ')') . drop 16

syscallTypeEnter :: Syscall -> String
syscallTypeEnter sys@(sys_name, sys_args) = unlines [ "data SyscallEnterDetails_" ++ sys_name ++ " = SyscallEnterDetails_" ++ sys_name
                                                    , "  { " ++ args sys_args
                                                    , "  } deriving (Eq, Ord, Show)"
                                                    ]
  where args = intercalate "\n  , " . map arg
        arg ("Ptr CChar", s) = s ++ " :: Ptr CChar\n  , " ++ s ++ "BS :: ByteString"
        arg (t,s) = s ++ " :: " ++ t


syscallTypeExit :: Syscall -> String
syscallTypeExit sys@(sys_name, sys_args) = unlines [ "data SyscallExitDetails_" ++ sys_name ++ " = SyscallExitDetails_" ++ sys_name
                                                   , "  { enterDetail :: SyscallEnterDetails_" ++ sys_name
                                                   , "  , retval :: CInt"
                                                   , "  } deriving (Eq, Ord, Show)"
                                                   ]

syscallDetailedEnter :: Syscall -> String
syscallDetailedEnter sys@(sys_name, sys_args) = "  | DetailedSyscallEnter_" ++ sys_name ++ " SyscallEnterDetails_" ++ sys_name ++ "\n"

syscallDetailedExit :: Syscall -> String
syscallDetailedExit sys@(sys_name, sys_args) = "  | DetailedSyscallExit_" ++ sys_name ++ " SyscallExitDetails_" ++ sys_name ++ "\n"

-- pointer: generate Addr + Ptr
-- char *: generate BS
syscallGetEnter :: Syscall -> String
syscallGetEnter sys@(sys_name, sys_args) = unlines $ [ "  Syscall_" ++ sys_name ++ " -> do"
                                                     , "    let SyscallArgs{ " ++ args sys_args ++ " } = syscallArgs"
                                                     ] ++ pointers ++ [ "    pure $ DetailedSyscallEnter_" ++ sys_name ++ " $ SyscallEnterDetails_" ++ sys_name
                                                                      , "      { " ++ record sys_args
                                                                      , "      }"
                                                                      ]
  where args = intercalate ", " . zipWith arg [0..]
          where arg i (t, s) = "arg" ++ show i ++ " = " ++ (if isPtr t then s ++ "Addr" else s)
        pointers = map ("    " ++) $ [ "let " ++ s ++ "Ptr = word64ToPtr " ++ s ++ "Addr" | (t,s) <- sys_args, isPtr t ] ++ [ s ++ "BS <- peekNullTerminatedBytes proc " ++ s ++ "Ptr" | (t,s) <- sys_args, isString t ]
        record = intercalate "\n      , " . map arg
          where arg (t, s)
                  | isString t = s ++ " = " ++ s ++ "Ptr" ++ "\n      , " ++ s ++ "BS"
                  | isPtr t = s ++ " = " ++ s ++ "Ptr"
                  | isInt t = s ++ " = fromIntegral " ++ s
                  | otherwise = "TODO " ++ s ++ " " ++ t

syscallGetExit :: Syscall -> String
syscallGetExit sys@(sys_name, sys_args) = unlines [ "            DetailedSyscallEnter_" ++ sys_name
                                                  , "              enterDetail@SyscallEnterDetails_" ++ sys_name ++ "{} -> do"
                                                  , "                pure $ DetailedSyscallExit_" ++ sys_name ++ " $"
                                                  , "                  SyscallExitDetails_" ++ sys_name ++ "{ enterDetail, retval = fromIntegral result }"
                                                  ]

formatArgsIn  = intercalate ", " . map (drop 5 . formatArg)
formatArgsOut = intercalate " ++ \", \" ++ " . map formatArg
formatArg (t,s)
  | isString t = "show " ++ s ++ "BS"
  | otherwise  = "show " ++ s

syscallFormatEnter :: Syscall -> String
syscallFormatEnter sys@(sys_name, sys_args) = unlines [ "  DetailedSyscallEnter_" ++ sys_name
                                                      , "    SyscallEnterDetails_" ++ sys_name ++ "{ " ++ formatArgsIn sys_args ++ " } ->"
                                                      , "      \"" ++ sys_name ++ "(\" ++ " ++ formatArgsOut sys_args ++ " ++ \")\""
                                                      ]

syscallFormatExit :: Syscall -> String
syscallFormatExit sys@(sys_name, sys_args) = unlines [ "  DetailedSyscallExit_" ++ sys_name
                                                     , "    SyscallExitDetails_" ++ sys_name ++ "{ enterDetail = SyscallEnterDetails_" ++ sys_name ++ "{ " ++ formatArgsIn sys_args ++ " }, retval } ->"
                                                     , "      \"" ++ sys_name ++ "(\" ++ " ++ formatArgsOut sys_args ++ " ++ \") = \" ++ show retval"
                                                     ]

syscallExports :: Syscall -> String
syscallExports sys@(sys_name, sys_args) = unlines [ "  , SyscallEnterDetails_" ++ sys_name ++ "(..)"
                                                  , "  , SyscallExitDetails_" ++ sys_name ++ "(..)"
                                                  ]

allHunks = [ ("exports", syscallExports)
           , ("SyscallEnterDetails", syscallTypeEnter)
           , ("SyscallExitDetails", syscallTypeExit)
           , ("DetailedEnter", syscallDetailedEnter)
           , ("DetailedExit", syscallDetailedExit)
           , ("getSyscallEnter", syscallGetEnter)
           , ("getSyscallExit", syscallGetExit)
           , ("formatEnter", syscallFormatEnter)
           , ("formatExit", syscallFormatExit)
           ]

-- doFiles "SYSCALL_DEFINE3(socket, int, family, int, type, int, protocol)"
doFiles :: String -> IO ()
doFiles s = let sys = readSyscall s
            in mapM_ (uncurry (do1 sys)) allHunks
  where do1 sys@(sys_name,_) out f = writeFile (sys_name ++ "__" ++ out) (f sys)

examples = [ "SYSCALL_DEFINE3(socket, int, family, int, type, int, protocol)"
           , "SYSCALL_DEFINE2(access, char *, filename, int, mode)" -- from "SYSCALL_DEFINE2(access, const char __user *, filename, int, mode)"
           ]