module HsBindgen.Test.C (
    genTestsC
  ) where

import HsBindgen.Backend.Category
import HsBindgen.Backend.Hs.AST qualified as Hs
import HsBindgen.Errors
import HsBindgen.Frontend.RootHeader

{-------------------------------------------------------------------------------
  Generation
-------------------------------------------------------------------------------}

-- | Generate C test header and source files
genTestsC ::
     FilePath              -- ^ C test header file path
  -> FilePath              -- ^ C test source file path
  -> [HashIncludeArg]      -- ^ C header paths
  -> ByCategory_ [Hs.Decl] -- ^ Declarations
  -> IO ()
genTestsC = throwPure_TODO 22 "generate test suite"

{-
genTestsC cTestHeaderPath cTestSourcePath lineLength cHeaderPath decls = do
    writeFile cTestHeaderPath $ renderPretty ctx CTestHeader{..}
    writeFile cTestSourcePath $ renderPretty ctx CTestSource{..}
  where
    ctx :: Context
    ctx = mkContext lineLength

    cTestHeaderFilename, cHeaderFilename :: FilePath
    cTestHeaderFilename = FilePath.takeFileName cTestHeaderPath
    cHeaderFilename = Posix.takeFileName $ getHashIncludeArg cHeaderPath

    cFunPrefix :: CFunPrefix
    cFunPrefix = getCFunPrefix cTestHeaderFilename

    cTestHeaderIncludeGuard :: IncludeGuard
    cTestHeaderIncludeGuard = getIncludeGuard cTestHeaderFilename

    cTestHeaderUsrIncludes, cTestHeaderSysIncludes :: [IncludeFile]
    cTestHeaderUsrIncludes = [cHeaderFilename]
    cTestHeaderSysIncludes = ["stdbool.h", "stddef.h"]

    cTestHeaderDecls :: [CTestDecl]
    cTestHeaderDecls = concatMap (getTestHeaderDecls cFunPrefix) decls

    cTestSourceUsrIncludes, cTestSourceSysIncludes :: [IncludeFile]
    cTestSourceUsrIncludes = List.sort
      ["hs_bindgen_test_runtime.h" , cHeaderFilename , cTestHeaderFilename]
    cTestSourceSysIncludes = ["stdalign.h", "stdbool.h", "stddef.h"]

    cTestSourceDefns :: [CTestDefn]
    cTestSourceDefns = concatMap (getTestSourceDefns cFunPrefix) decls

getTestHeaderDecls :: CFunPrefix -> Hs.Decl -> [CTestDecl]
getTestHeaderDecls cFunPrefix = \case
    Hs.DeclDefineInstance instanceDecl -> case instanceDecl of
      Hs.InstanceStorable Hs.Struct{..} _storableInstance ->
        case getStructCTypeSpelling structOrigin of
          Just cts ->
            [ CTestSizeofDecl   cFunPrefix structName
            , CTestAlignofDecl  cFunPrefix structName
            , CTestGenseqhsDecl cFunPrefix structName cts
            , CTestGenseqcDecl  cFunPrefix structName cts
            , CTestPreturbDecl  cFunPrefix structName cts
            ]
          Nothing -> []
      _otherwise -> []
    _otherwise -> []

getTestSourceDefns :: CFunPrefix -> Hs.Decl -> [CTestDefn]
getTestSourceDefns cFunPrefix = \case
    Hs.DeclDefineInstance instanceDecl -> case instanceDecl of
      Hs.InstanceStorable Hs.Struct{..} _storableInstance ->
        case getStructCTypeSpelling structOrigin of
          Just cts ->
            let fieldPs = getFieldP <$> Vec.toList structFields
            in  [ CTestSizeofDefn   cFunPrefix structName cts
                , CTestAlignofDefn  cFunPrefix structName cts
                , CTestGenseqhsDefn cFunPrefix structName cts fieldPs
                , CTestGenseqcDefn  cFunPrefix structName cts fieldPs
                , CTestPreturbDefn  cFunPrefix structName cts fieldPs
                ]
          Nothing -> []
      _otherwise -> []
    _otherwise -> []

getStructCTypeSpelling :: Hs.StructOrigin -> Maybe CTypeSpelling
getStructCTypeSpelling = \case
    Hs.StructOriginStruct C.Struct{..} -> case structDeclPath of
      C.DeclPathAnon ctxt ->
        case ctxt of
          C.DeclPathCtxtTypedef typedefName ->
            Just $ T.unpack (C.getName typedefName)
          _otherwise ->
            Nothing
      C.DeclPathName cName ->
          Just $ "struct " ++ T.unpack (C.getName cName)
    Hs.StructOriginEnum{} -> Nothing

getFieldP :: Hs.Field -> FieldP
getFieldP Hs.Field{..} = (cName, hsTypeName)
  where
    cName :: C.Name
    cName = case fieldOrigin of
      Hs.FieldOriginNone -> panicPure "unexpected FieldOriginNone in struct"
      Hs.FieldOriginStructField cStructField -> C.fieldName cStructField

    hsTypeName :: HsTypeName
    hsTypeName = case fieldType of
      Hs.HsPrimType hsPrimType -> case hsPrimType of
        HsT.HsPrimCChar    -> "CChar"
        HsT.HsPrimCSChar   -> "CSChar"
        HsT.HsPrimCUChar   -> "CUChar"
        HsT.HsPrimCInt     -> "CInt"
        HsT.HsPrimCUInt    -> "CUInt"
        HsT.HsPrimCShort   -> "CShort"
        HsT.HsPrimCUShort  -> "CUShort"
        HsT.HsPrimCLong    -> "CLong"
        HsT.HsPrimCULong   -> "CULong"
        HsT.HsPrimCLLong   -> "CLLong"
        HsT.HsPrimCULLong  -> "CULLong"
        HsT.HsPrimCBool    -> "CBool"
        HsT.HsPrimCFloat   -> "CFloat"
        HsT.HsPrimCDouble  -> "CDouble"
        HsT.HsPrimCPtrDiff -> "CPtrdiff"
        HsT.HsPrimCSize    -> "CSize"
        x -> throwPure_TODO 447 $ "not supported: " ++ show (typeOf x)
      x -> throwPure_TODO 447 $ "not supported: " ++ show (typeOf x)

{-------------------------------------------------------------------------------
  AST
-------------------------------------------------------------------------------}

type CTypeSpelling = String
type FieldP        = (C.Name, HsTypeName)
type HsTypeName    = String
type IncludeFile   = String
type IncludeGuard  = String

data CTestHeader = CTestHeader {
      cTestHeaderIncludeGuard :: IncludeGuard
    , cTestHeaderUsrIncludes  :: [IncludeFile]
    , cTestHeaderSysIncludes  :: [IncludeFile]
    , cTestHeaderDecls        :: [CTestDecl]
    }

data CTestDecl =
      CTestSizeofDecl   CFunPrefix (HsName NsTypeConstr)
    | CTestAlignofDecl  CFunPrefix (HsName NsTypeConstr)
    | CTestGenseqhsDecl CFunPrefix (HsName NsTypeConstr) CTypeSpelling
    | CTestGenseqcDecl  CFunPrefix (HsName NsTypeConstr) CTypeSpelling
    | CTestPreturbDecl  CFunPrefix (HsName NsTypeConstr) CTypeSpelling

data CTestSource = CTestSource {
      cTestSourceUsrIncludes :: [IncludeFile]
    , cTestSourceSysIncludes :: [IncludeFile]
    , cTestSourceDefns       :: [CTestDefn]
    }

data CTestDefn =
      CTestSizeofDefn   CFunPrefix (HsName NsTypeConstr) CTypeSpelling
    | CTestAlignofDefn  CFunPrefix (HsName NsTypeConstr) CTypeSpelling
    | CTestGenseqhsDefn CFunPrefix (HsName NsTypeConstr) CTypeSpelling [FieldP]
    | CTestGenseqcDefn  CFunPrefix (HsName NsTypeConstr) CTypeSpelling [FieldP]
    | CTestPreturbDefn  CFunPrefix (HsName NsTypeConstr) CTypeSpelling [FieldP]

{-------------------------------------------------------------------------------
  Pretty printing
-------------------------------------------------------------------------------}

instance Pretty CTestHeader where
  pretty CTestHeader{..} = vsep $
      vcat
        [ "#ifndef" <+> string cTestHeaderIncludeGuard
        , "#define" <+> string cTestHeaderIncludeGuard
        ]
    : vcat ["#include \"" >< string inc >< "\"" | inc <- cTestHeaderUsrIncludes]
    : vcat ["#include <" >< string inc >< ">" | inc <- cTestHeaderSysIncludes]
    : map pretty cTestHeaderDecls
    ++ ["#endif //" <+> string cTestHeaderIncludeGuard]

instance Pretty CTestDecl where
  pretty = \case
    CTestSizeofDecl pfx name ->
      prettyFun
        (hcat ["size_t ", string pfx, "_sizeof_", prettyHsName name])
        ["void"]
        ";"
    CTestAlignofDecl pfx name ->
      prettyFun
        (hcat ["size_t ", string pfx, "_alignof_", prettyHsName name])
        ["void"]
        ";"
    CTestGenseqhsDecl pfx name cts ->
      prettyFun
        (hcat ["bool ", string pfx, "_genseqhs_", prettyHsName name])
        [string cts <+> "const *const"]
        ";"
    CTestGenseqcDecl pfx name cts ->
      prettyFun
        (hcat ["void ", string pfx, "_genseqc_", prettyHsName name])
        [string cts <+> "*const"]
        ";"
    CTestPreturbDecl pfx name cts ->
      prettyFun
        (hcat ["void ", string pfx, "_preturb_", prettyHsName name])
        [ "long"
        , string cts <+> "const *const"
        , string cts <+> "*const"
        ]
        ";"

instance Pretty CTestSource where
  pretty CTestSource{..} = vsep $
      vcat ["#include \"" >< string inc >< "\"" | inc <- cTestSourceUsrIncludes]
    : vcat ["#include <" >< string inc >< ">" | inc <- cTestSourceSysIncludes]
    : map pretty cTestSourceDefns

instance Pretty CTestDefn where
  pretty = \case
    CTestSizeofDefn pfx name cts -> vcat
      [ prettyFun
          (hcat ["size_t ", string pfx, "_sizeof_", prettyHsName name])
          ["void"]
          " {"
      , nest 2 $ hcat ["return sizeof(", string cts, ");"]
      , "}"
      ]
    CTestAlignofDefn pfx name cts -> vcat
      [ prettyFun
          (hcat ["size_t ", string pfx, "_alignof_", prettyHsName name])
          ["void"]
          " {"
      , nest 2 $ hcat ["return alignof(", string cts, ");"]
      , "}"
      ]
    CTestGenseqhsDefn pfx name cts fieldPairs ->
      let numFieldPairs = length fieldPairs
      in  vcat
            [ prettyFun
                (hcat ["bool ", string pfx, "_genseqhs_", prettyHsName name])
                [string cts <+> "const *const source"]
                " {"
            , nest 2 $ "return" <+> fsep
                [ hcat
                    [ "source->"
                    , prettyCName cField
                    , " == hsbg_genseq_"
                    , string hsFieldType
                    , "("
                    , showToCtxDoc idx
                    , ")"
                    , if idx == numFieldPairs
                        then ";"
                        else " &&"
                    ]
                | (idx, (cField, hsFieldType)) <- zip [1..] fieldPairs
                ]
            , "}"
            ]
    CTestGenseqcDefn pfx name cts fieldPairs -> vcat $
        prettyFun
          (hcat ["void ", string pfx, "_genseqc_", prettyHsName name])
          [string cts <+> "*const target"]
          " {"
      : [ nest 2 $ hcat
            [ "target->"
            , prettyCName cField
            , " = hsbg_genseq_"
            , string hsFieldType
            , "("
            , showToCtxDoc @Int idx
            , ");"
            ]
        | (idx, (cField, hsFieldType)) <- zip [1..] fieldPairs
        ]
      ++ ["}"]
    CTestPreturbDefn pfx name cts fieldPairs -> vcat $
        prettyFun
          (hcat ["void ", string pfx, "_preturb_", prettyHsName name])
          [ "long size"
          , string cts <+> "const *const source"
          , string cts <+> "*const target"
          ]
          " {"
      : [ nest 2 $ hcat
            [ "target->"
            , prettyCName cField
            , " = hsbg_preturb_"
            , string hsFieldType
            , "(size, source->"
            , prettyCName cField
            , ");"
            ]
        | (cField, hsFieldType) <- fieldPairs
        ]
      ++ ["}"]

{-------------------------------------------------------------------------------
  Auxillary functions
-------------------------------------------------------------------------------}

getIncludeGuard ::
     FilePath  -- ^ C test header filename
  -> String
getIncludeGuard = List.map aux
  where
    aux :: Char -> Char
    aux c
      | Char.isAlphaNum c = Char.toUpper c
      | otherwise         = '_'

prettyCName :: C.Name -> CtxDoc
prettyCName = string . T.unpack . C.getName

prettyFun ::
     CtxDoc    -- ^ Part before opening paren
  -> [CtxDoc]  -- ^ Parameters/arguments
  -> CtxDoc    -- ^ Part after closing paren
  -> CtxDoc
prettyFun lDoc args rDoc = lDoc >< "(" >< fsep
    [ if idx < numArgs then arg >< "," else arg >< ")" >< rDoc
    | (idx, arg) <- zip [1..] args
    ]
  where
    numArgs :: Int
    numArgs = length args
-}