content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE TypeApplications #-}
  
  module Main where
  
  -- base
  import Control.Arrow
    ( first )
  import Control.Exception
    ( throwIO )
  import Data.List
    ( isPrefixOf )
  import Data.String
    ( IsString(fromString) )
  import Control.Monad
    ( when )
  
  import Data.Maybe
    ( catMaybes, isNothing )
  import Data.Traversable
    ( for )
  import System.Exit
  
  -- containers
  import Data.Map.Strict
    ( Map )
  import Data.Map.Strict qualified as Map
  
  -- directory
  import System.Directory
    ( doesFileExist, listDirectory, getCurrentDirectory )
  
  -- filepath
  import System.FilePath
    ( (</>), (-<.>) )
  
  -- fin
  import Data.Type.Nat
  
  -- text
  import Data.Text qualified as Text
    ( pack )
  
  -- vec
  import Data.Vec.Lazy
    ( Vec(..) )
  
  -- clang
  import Clang.Args qualified as Clang
  
  -- c-expr
  import C.Type
  import C.Type.Internal.Universe
  
  import C.Operators
    ( Op(..), UnaryOp(..), BinaryOp(..)
    , opResType, pprOpApp, pprOp
    )
  
  -- c-expr:test
  import CallClang
    ( CType(..)
  --  , queryClangBuildTargetTriple
    , queryClangForResultType, getExpansionTypeMapping
    )
  
  --------------------------------------------------------------------------------
  
  -- | We want to pass pre-defined @musl@ standard library headers to Clang
  -- for the testsuite. These are currently in the @hs-bindgen@ package, so we
  -- do a bit of faff to be able to find them.
  findPackageDirectory :: FilePath -> String -> IO (Maybe FilePath)
  findPackageDirectory root pkgname = do
    dirs0 <- listDirectory root
    dirs1 <- listDirectory (root </> "..")
    let attempts = "." : ".." : filter (pkgname `isPrefixOf`) dirs0 ++ map (".." </>) (filter (pkgname `isPrefixOf`) dirs1)
    try attempts
    where
      try :: [FilePath] -> IO (Maybe FilePath)
      try [] =
        return Nothing
      try (dir:dirs) = do
        mbRes <- tryOne dir
        case mbRes of
          Nothing -> try dirs
          Just r  -> return $ Just r
      tryOne :: FilePath -> IO (Maybe FilePath)
      tryOne dir = do
        here <- doesFileExist (root </> dir </> pkgname -<.> ".cabal")
        return $
          if here
          then Just dir
          else Nothing
  
  main :: IO ()
  main = do
  
    cwd <- getCurrentDirectory
    mbHsBindgenDir <- findPackageDirectory cwd "hs-bindgen"
    when (isNothing mbHsBindgenDir) $
      putStrLn $ unlines
        [ "WARNING: unable to find 'hs-bindgen' directory"
        , "The test-suite will use whichever C header files it finds on your system."
        ]
  
    stdClangArg <- either throwIO return $
      Clang.getStdClangArg Clang.C23 Clang.DisableGnu
    let platform = hostPlatform
        clangArgs = Clang.ClangArgs $ stdClangArg :
          case platformOS hostPlatform of
            Windows -> ["-target", "x86_64-pc-windows"]
            Posix   -> ["-target", "x86_64-pc-linux"] ++
              case mbHsBindgenDir of
                Just hsBindgenDir ->
                  ["-I", fromString (hsBindgenDir </> "musl-include/x86_64")]
                Nothing -> []
  
    let extendedInts = [ PtrDiff, Size ]
    canonTys <-
      getExpansionTypeMapping clangArgs
        [ CType $ Arithmetic $ Integral $ IntLike extInt
        | extInt <- extendedInts
        ]
  
  {-
    -- Quick debugging
    putStrLn $ "Canonical type mapping: " ++ show canonTys
    let intTy  = Arithmetic $ Integral $ IntLike $ Int Signed
        ptrTy1 = Ptr $ Arithmetic $ Integral $ IntLike $ Int Signed
    testRes <- queryClangForResultType ( ptrTy1 ::: intTy ::: VNil ) ( pprOpApp ( BinaryOp MRelEQ ) )
    putStrLn $ "Result of ty_1* == int: " ++ show testRes
  -}
  
    putStrLn "Unary operators"
    unaries <- unaryTests platform clangArgs canonTys
    badUnary <-
      fmap catMaybes <$> for unaries $ \ ( op, tests ) -> do
        putStrLn $ pprOp ( UnaryOp op )
        let ( ok, bad ) = partitionTests tests
        if null bad
        then do
          putStrLn $ "   PASSED (" ++ show (length ok) ++ " tests)"
          return Nothing
        else do
          putStrLn $ unlines $
            ( "   FAILED:" )
            : map ( showFailure . first show ) bad
          return $ Just bad
    putStrLn "Binary operators"
    binaries <- binaryTests platform clangArgs canonTys
    badBinary <-
      fmap catMaybes <$> for binaries $ \ ( op, tests ) -> do
        putStrLn $ pprOp ( BinaryOp op )
        let ( ok, bad ) = partitionTests tests
        if null bad
        then do
          putStrLn $ "   PASSED (" ++ show (length ok) ++ " tests)"
          return Nothing
        else do
          putStrLn $ unlines $
            ( "   FAILED:" )
            : map ( showFailure . first show ) bad
          return $ Just bad
    if null badUnary && null badBinary
    then exitSuccess
    else exitFailure
  
  
  showFailure :: ( String, ( Maybe CType, Maybe CType ) ) -> String
  showFailure ( input, ( mbOurs, mbClang ) ) =
    unlines
      [ "   " ++ input
      , "     - computed type: " ++ showMaybeType mbOurs
      , "     -  Clang's type: " ++ showMaybeType mbClang
      ]
    where
      showMaybeType Nothing     = "<n/a>"
      showMaybeType ( Just ty ) = show ty
  
  data TestResult a
    = TestOK !a
    | TestFailed
      { ours, clang's :: !a }
    deriving stock Show
  
  partitionTests :: [ ( x, TestResult a ) ] -> ( [ ( x, a ) ], [ ( x, ( a, a ) ) ] )
  partitionTests = foldMap $ \case
    ( x, TestOK a ) -> ( [ ( x, a ) ], [] )
    ( x, TestFailed b1 b2 ) -> ( [], [ ( x, ( b1, b2 ) ) ] )
  
  eqTypeUpToExpansion :: Map CType CType -> Maybe CType -> Maybe CType -> Bool
  eqTypeUpToExpansion canonTys ourTy clangTy = go ourTy
    where
      go mbTy
        | mbTy == clangTy
        = True
        | Just ty <- mbTy
        , Just ty' <- Map.lookup ty canonTys
        = go ( Just ty' )
        | otherwise
        = False
  
  unaryTests :: Platform -> Clang.ClangArgs -> Map CType CType -> IO [ ( UnaryOp, [ ( CType, TestResult ( Maybe CType ) ) ] ) ]
  unaryTests platform clangArgs canonTys =
    sequence
      [ ( op, ) <$> sequence
           [ do let ours = fmap CType $ opResType platform ( UnaryOp op ) ( ty ::: VNil )
                clang's <- queryClangForResultType clangArgs ( CType ty ::: VNil ) ( pprOpApp ( UnaryOp op ) )
                return $ ( CType ty , ) $
                  if eqTypeUpToExpansion canonTys ours clang's
                  then TestOK ours
                  else TestFailed { ours, clang's }
           | ( ty ::: VNil ) <- mkCTypes <$> enumerateTypeTuples @( S Z )
           ]
      | op <- [ ( minBound :: UnaryOp ) .. maxBound ] ]
  
  
  binaryTests :: Platform -> Clang.ClangArgs -> Map CType CType -> IO [ ( BinaryOp, [ ( ( CType, CType ), TestResult ( Maybe CType ) ) ] ) ]
  binaryTests platform clangArgs canonTys =
    sequence
      [ ( op, ) <$>
        sequence
          [ do let ours = fmap CType $ opResType platform ( BinaryOp op ) ( ty1 ::: ty2 ::: VNil )
               clang's <- queryClangForResultType clangArgs ( CType ty1 ::: CType ty2 ::: VNil ) ( pprOpApp ( BinaryOp op ) )
               return $ ( ( CType ty1, CType ty2 ), ) $
                 if eqTypeUpToExpansion canonTys ours clang's
                 then TestOK ours
                 else TestFailed { ours, clang's }
          | ( ty1 ::: ty2 ::: VNil ) <- mkCTypes <$> enumerateTypeTuples @( S ( S Z ) )
          ]
      | op <- [ ( minBound :: BinaryOp ) .. maxBound ] ]
  
  mkCTypes :: Vec n ( Type OpaqueTy ) -> Vec n ( Type CType )
  mkCTypes = fmap $ fmap $ \ ( OpaqueTy i ) -> TypeDef $ Text.pack ( "ty_" ++ show i )
  