{-# LANGUAGE QuasiQuotes #-}

module Main where

import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit (Assertion, (@?=))

import qualified Data.ByteString.Char8 as B
import Data.Char (isSpace)
import Data.Loc (SrcLoc, noLoc, startPos)
import Control.Exception (SomeException)
import Language.C.Quote.C
import qualified Language.C.Quote.GCC as GCC
import qualified Language.C.Syntax as C
import qualified Language.C.Parser as P
import MainCPP
import Numeric (showHex)
import GCC (gccTests)
import Objc (objcTests, objcRegressionTests)
import CUDA (cudaTests)
import Text.PrettyPrint.Mainland
import Text.PrettyPrint.Mainland.Class

main :: IO ()
main = defaultMain tests

tests :: [Test]
tests = [ constantTests
        , constantAntiquotationsTests
        , cQuotationTests
        , cPatternAntiquotationTests
        , statementCommentTests
        , regressionTests
        , gccTests
        , objcTests
        , objcRegressionTests
        , cudaTests
        ]

constantTests :: Test
constantTests = testGroup "Constants"
    [ testCase "octal constant" test_octint
    , testCase "hex constant" test_hexint
    , testCase "unsigned hex constant" test_hexint_u
    , testCase "unsigned long hex constant" test_hexint_ul
    , testCase "unsigned long long hex constant hexint" test_hexint_ull
    ]
  where
    test_octint :: Assertion
    test_octint =
        [cexp|010|]
          @?= C.Const (C.IntConst "010" C.Signed 8 noLoc) noLoc

    test_hexint :: Assertion
    test_hexint =
        [cexp|0x10|]
          @?= C.Const (C.IntConst "0x10" C.Signed 16 noLoc) noLoc

    test_hexint_u :: Assertion
    test_hexint_u =
        [cexp|0x10U|]
          @?= C.Const (C.IntConst "0x10U" C.Unsigned 16 noLoc) noLoc

    test_hexint_ul :: Assertion
    test_hexint_ul =
        [cexp|0x10UL|]
          @?= C.Const (C.LongIntConst "0x10UL" C.Unsigned 16 noLoc) noLoc

    test_hexint_ull :: Assertion
    test_hexint_ull =
        [cexp|0x10ULL|]
          @?= C.Const (C.LongLongIntConst "0x10ULL" C.Unsigned 16 noLoc) noLoc

constantAntiquotationsTests :: Test
constantAntiquotationsTests = testGroup "Constant antiquotations" $
    [ testCase "int antiquotes" test_int
    , testCase "hex Const antiquote" test_hexconst
    , testCase "unsigned hex Const antiquote" test_hexconst_u
    , testGroup "float antiquotes" floatConstTests
    , testCase "char antiquote" test_char
    , testCase "string antiquote" test_string
    , testGroup "misc char constants" charConstTests
    ]
    ++ testCase_test_int_hsexp
  where
    test_int :: Assertion
    test_int =
        [cexp|$int:one + $uint:one + $lint:one + $ulint:one + $llint:one + $ullint:one|]
          @?= [cexp|1 + 1U + 1L + 1UL + 1LL + 1ULL|]
      where
        one :: Integer
        one = 1

    test_hexconst :: Assertion
    test_hexconst =
        [cexp|$const:(hexconst (10 :: Integer))|]
          @?= C.Const (C.IntConst "0xa" C.Signed 10 noLoc) noLoc
      where
        hexconst :: Integral a => a -> C.Const
        hexconst i = C.IntConst ("0x" ++ showHex x "") C.Signed x noLoc
          where
            x :: Integer
            x = fromIntegral i

    test_hexconst_u :: Assertion
    test_hexconst_u =
        [cexp|$const:(hexconst_u (10 :: Integer))|]
          @?= C.Const (C.IntConst "0xa" C.Unsigned 10 noLoc) noLoc
      where
        hexconst_u :: Integral a => a -> C.Const
        hexconst_u i = C.IntConst ("0x" ++ showHex x "") C.Unsigned x noLoc
          where
            x :: Integer
            x = fromIntegral i

    floatConstTests :: [Test]
    floatConstTests = [ testCase "float antiquotes" test_float
                      , testCase "NaN" test_NaN
                      , testCase "Infinity" test_infinity
                      ]
      where
        test_float :: Assertion
        test_float =
            [cexp|$float:one + $double:one + $ldouble:one|]
              @?= [cexp|1.0F + 1.0 + 1.0L|]
          where
            one :: Fractional a => a
            one = 1

        test_NaN :: Assertion
        test_NaN =
            showCompact [cexp|$double:nan|] @?= "NAN"
          where
            nan :: RealFloat a => a
            nan = acos 2

        test_infinity :: Assertion
        test_infinity =
            showCompact [cexp|$double:inf|] @?= "INFINITY"
          where
            inf :: RealFloat a => a
            inf = 1/0

    test_char :: Assertion
    test_char =
        [cexp|$char:a|] @?= [cexp|'a'|]
      where
        a = 'a'

    test_string :: Assertion
    test_string =
        [cexp|$string:hello|] @?= [cexp|"Hello, world\n"|]
      where
        hello = "Hello, world\n"

    charConstTests :: [Test]
    charConstTests = [ charConstTest '\0' "'\\0'"
                     , charConstTest '\xfff' "'\\u0fff'"
                     , charConstTest '\xfffff' "'\\U000fffff'"
                     ]
      where
        charConstTest :: Char -> String -> Test
        charConstTest c s =
          testCase ("character constant " ++ show c) $
          showCompact [cexp|$char:c|] @?= s

cQuotationTests :: Test
cQuotationTests = testGroup "C quotations"
    [ testCase "raw expression-level escape" test_escexp
    , testCase "raw statement-level escape" test_escstm
    , testCase "identifier antiquote" test_id
    , testCase "expression antiquote" test_exp
    , testCase "function antiquote" test_func
    , testCase "args antiquote" test_args
    , testCase "declaration antiquote" test_decl
    , testCase "struct declaration antiquote" test_sdecl
    , testCase "external declaration antiquote" test_edecl
    , testCase "enum antiquote" test_enum
    , testCase "statement antiquote" test_stm
    , testCase "parameter antiquote" test_param
    , testCase "type qualifier antiquote" test_tyqual
    , testCase "type qualifiers antiquote" test_tyquals
    , testCase "type antiquote" test_ty
    , testCase "initializer antiquote" test_init
    , testCase "initializers antiquote" test_inits
    , testCase "block items antiquote" test_item
    , testCase "qualifier with type antiquote 1" test_qual_antitype1
    , testCase "qualifier with type antiquote 2" test_qual_antitype2
    ]
  where
    test_id :: Assertion
    test_id =
        [cexp|$id:f($id:x, $id:y)|] @?= [cexp|f(x, y)|]
      where
        f :: String
        f = "f"

        x :: SrcLoc -> C.Id
        x = C.Id "x"

        y :: C.Id
        y = C.Id "y" noLoc

    test_escexp :: Assertion
    test_escexp =
        let rawstr = "a rather random string"
        in [cexp|$esc:rawstr|]
               @?= C.EscExp rawstr noLoc

    test_escstm :: Assertion
    test_escstm =
        let rawstr = "a rather random string"
        in [citems|$escstm:rawstr if (1) return;|]
               @?= [ C.BlockStm $ C.EscStm rawstr noLoc
                   , C.BlockStm $ C.If (C.Const (C.IntConst "1" C.Signed 1 noLoc) noLoc) (C.Return Nothing noLoc) Nothing noLoc ]

    test_exp :: Assertion
    test_exp =
        [cexp|$exp:e1 + $exp:e2|] @?= [cexp|1 + 2|]
      where
        e1 = [cexp|1|]
        e2 = [cexp|2|]

    test_func :: Assertion
    test_func =
        [cunit|$func:f|]
          @?= [cunit|int add(int x) { return x + 10; }|]
      where
        f = add (10 :: Integer)
        add n = [cfun|int add(int x) { return x + $int:n; } |]

    test_args :: Assertion
    test_args =
        [cstm|f($exp:e1, $args:args, $exp:e2);|]
          @?= [cstm|f(1, 2, 3, 4);|]
      where
        e1 = [cexp|1|]
        e2 = [cexp|4|]
        args = [[cexp|2|], [cexp|3|]]

    test_decl :: Assertion
    test_decl =
        [cfun|int inc(int n) {
                 $decl:d1;
                 $decls:decls

                 return n + 1;
              }|]
           @?= [cfun|int inc(int n) {
                         int i;
                         int j;
                         char c = 'c';

                         return n + 1;
                      }|]
      where
        d1 = [cdecl|int i;|]
        d2 = [cdecl|int j;|]
        d3 = [cdecl|char c = 'c';|]
        decls = [d2, d3]

    test_sdecl :: Assertion
    test_sdecl =
        [cty|struct foo { $sdecl:d1 $sdecls:decls }|]
          @?= [cty|struct foo { int i; int j; char c; }|]
      where
        d1 = [csdecl|int i;|]
        d2 = [csdecl|int j;|]
        d3 = [csdecl|char c;|]
        decls = [d2, d3]

    test_edecl :: Assertion
    test_edecl =
        [cunit|$edecl:d1 $edecls:decls|]
          @?= [cunit|int i; int j; char c = 'c';|]
      where
        d1 = [cedecl|int i;|]
        d2 = [cedecl|int j;|]
        d3 = [cedecl|char c = 'c';|]
        decls = [d2, d3]

    test_enum :: Assertion
    test_enum =
        [cty|enum foo { $enum:enum1, $enums:enums }|]
          @?= [cty|enum foo { A = 0, B, C = 2 }|]
      where
        enum1 = [cenum|A = 0|]
        enum2 = [cenum|B|]
        enum3 = [cenum|C = 2|]
        enums = [enum2, enum3]

    test_stm :: Assertion
    test_stm =
        [cfun|int add(int x) { $stms:stms return x + 1; }|]
          @?= [cfun|int add(int x) { a = 1; b = 2; return x + 1; }|]
      where
        one :: Integer
        one = 1
        stm1 = [cstm|a = $int:one;|]
        stm2 = [cstm|b = 2;|]
        stms = [stm1, stm2]

    test_param :: Assertion
    test_param =
        [cdecl|int f($param:ty1, $params:tys);|]
          @?= [cdecl|int f(char, int, float);|]
      where
        ty1 = [cparam|char|]
        ty2 = [cparam|int|]
        ty3 = [cparam|float|]
        tys = [ty2, ty3]

    test_tyqual :: Assertion
    test_tyqual =
        [cdecl|$tyqual:tyqual int i;|]
          @?= [cdecl|const int i;|]
      where
        tyqual = C.Tconst noLoc

    test_tyquals :: Assertion
    test_tyquals =
        [cdecl|$tyquals:tyquals int i;|]
          @?= [cdecl|const volatile int i;|]
      where
        tyquals = [ctyquals|const volatile|]

    test_ty :: Assertion
    test_ty =
        [cdecl|$ty:ty1 f(const $ty:ty2);|]
          @?= [cdecl|int f(const float);|]
      where
        ty1 = [cty|int|]
        ty2 = [cty|float|]

    test_init :: Assertion
    test_init =
        [cinit|{$init:initializer, .a = 10}|] @?= [cinit|{{.d = 1}, .a = 10}|]
      where
        initializer = [cinit|{.d = 1}|]

    test_inits :: Assertion
    test_inits =
        [cinit|{$inits:([initializer1, initializer2])}|] @?= [cinit|{{.d = 1},{.a = 10}}|]
      where
        initializer1 = [cinit|{.d = 1}|]
        initializer2 = [cinit|{.a = 10}|]

    test_item :: Assertion
    test_item =
        [cfun|int add(int x) { int y = 2; return x + y; }|]
          @?= [cfun|int add(int x) { $items:([item1, item2]) }|]
      where
        item1 = [citem|int y = 2;|]
        item2 = [citem|return x + y;|]

    test_qual_antitype1 :: Assertion
    test_qual_antitype1 =
        [cexp|(const $ty:tau) NULL|]
          @?= [cexp|(const int) NULL|]
      where
        tau = [cty|int|]

    test_qual_antitype2 :: Assertion
    test_qual_antitype2 =
        [cexp|(const $ty:tau *) NULL|]
          @?= [cexp|(const int*) NULL|]
      where
        tau = [cty|int|]

cPatternAntiquotationTests :: Test
cPatternAntiquotationTests = testGroup "C pattern antiquotations"
    [ testCase "arguments pattern antiquote" pat_args
    ]
  where
    pat_args :: Assertion
    pat_args =
        stms @?= [[cexp|2|], [cexp|3|]]
      where
        stms = case [cstm|f(1, 2, 3);|] of
                 [cstm|f(1, $args:es);|] -> es
                 _ -> []

statementCommentTests :: Test
statementCommentTests = testGroup "Statement comments"
    [ testCase "lbrace comment" test_lbrace_comment
    , testCase "semi comment" test_semi_comment
    , testCase "c comment" test_c_comment
    , testCase "c++ comment" test_cxx_comment
    , testCase "antiquote comment" test_antiquote_comment
    , testCase "comment at end of statements quote" test_stms_end_comment
    , testCase "comment before antiquoted statements" test_block_stms_comment
    , testCase "comment at beginning of a block" test_issue_55
    , testCase "comment inside cunit block" test_issue_76
    ]
  where
    test_lbrace_comment :: Assertion
    test_lbrace_comment =
        [cstm|{ $comment:("/* Test 1 */") return x + y; }|]
          @?= [cstm|{/* Test 1 */ return x + y; }|]

    test_semi_comment :: Assertion
    test_semi_comment =
        [cstms|x = 1; $comment:("/* Test 1 */") return x + y;|]
          @?= [cstms|x = 1; /* Test 1 */ return x + y;|]

    assign_a_equals_one =
      C.Exp (Just $ C.Assign (C.Var (C.Id "a" noLoc) noLoc)
                              C.JustAssign
                              (C.Const (C.IntConst "1" C.Signed 1 noLoc) noLoc)
                              noLoc)
            noLoc

    test_c_comment =
        [cstms|
        a = 1;
        /* c style comment */
        |]

        @?= [ assign_a_equals_one
            , C.Comment "/* c style comment */" (C.Exp Nothing noLoc) noLoc
            ]

    test_cxx_comment =
        [cstms|
        a = 1;
        // c++ style comment
        |]

        @?= [ assign_a_equals_one
            , C.Comment "// c++ style comment" (C.Exp Nothing noLoc) noLoc
            ]

    test_antiquote_comment =
        [cstms|
        $comment:("/* antiquote comment */")
        |]

        @?= [ C.Comment "/* antiquote comment */" (C.Exp Nothing noLoc) noLoc
            ]

    test_stms_end_comment :: Assertion
    test_stms_end_comment =
        [cstms|x = 1; return x + y; $comment:("// Test")|]
          @?= [cstms|x = 1; return x + y; // Test|]

    test_block_stms_comment :: Assertion
    test_block_stms_comment =
        [cstm|{ int a; $decl:decl; /* Test */ $stms:stms }|]
          @?= [cstm|{ int a; int b; a = 1; b = 2;}|]
      where
        decl = [cdecl|int b;|]
        stm1 = [cstm|a = 1;|]
        stm2 = [cstm|b = 2;|]
        stms = [stm1, stm2]

    test_issue_55 :: Assertion
    test_issue_55 =
        [cunit|int f(int x)
              { // Breaking comment.
                int y;
                return x;
              }|]
        @?=
        [cunit|int f(int x)
              { $comment:("// Breaking comment.")
                int y;
                return x;
              }|]

    test_issue_76 :: Assertion
    test_issue_76 =
        [cunit|
          $edecl:d1
          /* AAA */
          $edecl:d2
          struct A { int foo; };
          /* BBB */
          struct B { int bar; };
        |]
        @?=
        [cunit|
          int i;
          /* AAA */
          int j;
          struct A { int foo; };
          $comment:(" BBB ")
          struct B { int bar; };
        |]
      where
        d1 = [cedecl|int i;|]
        d2 = [cedecl|int j;|]

regressionTests :: Test
regressionTests = testGroup "Regressions"
    [ issue81
    , issue76
    , issue68
    , issue64
    , testCase "pragmas" test_pragmas
    , issue48
    , testCase "Issue #44" issue44
    , issue43
    ]
  where
    test_pragmas :: Assertion
    test_pragmas =
        [cstms|
        #pragma omp sections
        {
            #pragma omp section
            a = 1;
        }
        |]

        @?= [ C.Pragma "omp sections" noLoc
            , C.Block [ C.BlockStm (C.Pragma "omp section" noLoc)
                      , C.BlockStm (C.Exp (Just $ C.Assign (C.Var (C.Id "a" noLoc) noLoc)
                                                           C.JustAssign
                                                           (C.Const (C.IntConst "1" C.Signed 1 noLoc) noLoc)
                                                           noLoc)
                                          noLoc)
                      ]
                      noLoc
            ]

    issue81 :: Test
    issue81 = testCase "Issue #81"$
        showCompact [cstm|if (x > 1) { /* comment */ if (x > 2) x++; }|]
        @?=
        "if (x > 1) { /* comment */ if (x > 2) x++; }"

    issue76 :: Test
    issue76 = testCase "Issue #76" $
        [cunit|
          /* AAA */
          struct A { int foo; };
          /* BBB */
          struct B { int bar; };
        |]
        @?=
        [cunit|
          /* AAA */
          struct A { int foo; };
          $comment:(" BBB ")
          struct B { int bar; };
        |]

    issue68 :: Test
    issue68 = testCase "Issue #68"$
        showCompact [cstm|if (!initialized) { $stms:init_stms }|]
        @?=
        "if (!initialized) { return; }"
      where
        init_stms :: [C.Stm]
        init_stms = [[cstm|return;|]]

    issue64 :: Test
    issue64 = testGroup "Issue #64"
              [ testCase "-($int:i)"  test_issue64_1
              , testCase "--($int:i)" test_issue64_2
              ]
      where
        i :: Int
        i = -42

        test_issue64_1 :: Assertion
        test_issue64_1 = pretty 80 (ppr [cexp|-($int:i)|]) @?= "-(-42)"

        test_issue64_2 :: Assertion
        test_issue64_2 = pretty 80 (ppr [cexp|--$int:i|]) @?= "--(-42)"

    issue48 :: Test
    issue48 = testGroup "Issue #48"
              [ testCase "-(-42)"  test_issue48_1
              , testCase "--(-42)" test_issue48_2
              , testCase "-(--42)" test_issue48_3
              , testCase "+(+42)"  test_issue48_4
              , testCase "++(+42)" test_issue48_5
              , testCase "+(++42)" test_issue48_6
              ]
      where
        test_issue48_1 :: Assertion
        test_issue48_1 = pretty 80 (ppr [cexp|-(-42)|]) @?= "-(-42)"

        test_issue48_2 :: Assertion
        test_issue48_2 = pretty 80 (ppr [cexp|--(-42)|]) @?= "--(-42)"

        test_issue48_3 :: Assertion
        test_issue48_3 = pretty 80 (ppr [cexp|-(--42)|]) @?= "-(--42)"

        test_issue48_4 :: Assertion
        test_issue48_4 = pretty 80 (ppr [cexp|+(+42)|]) @?= "+(+42)"

        test_issue48_5 :: Assertion
        test_issue48_5 = pretty 80 (ppr [cexp|++(+42)|]) @?= "++(+42)"

        test_issue48_6 :: Assertion
        test_issue48_6 = pretty 80 (ppr [cexp|+(++42)|]) @?= "+(++42)"

    issue44 :: Assertion
    issue44 =
        case parseDecl "$ty:something c;" of
          Left err  -> fail (show err)
          Right grp -> (pretty 80 . ppr) grp @?= "$ty:something c"
      where
        parseDecl :: String -> Either SomeException C.InitGroup
        parseDecl s = P.parse [C.Antiquotation] [] P.parseDecl (B.pack s) (Just (startPos "<inline>"))

    issue43 :: Test
    issue43 = testGroup "Issue #43"
              [ testCase "float _Complex" test_issue43_1
              , testCase "long double _Complex" test_issue43_2
              , testCase "long _Complex double" test_issue43_3
              , testCase "_Imaginary long double" test_issue43_4
              ]
      where
        test_issue43_1 :: Assertion
        test_issue43_1 = [cty|float _Complex|] @?=
                         C.Type (C.DeclSpec [] [] (C.Tfloat_Complex noLoc) noLoc)
                                (C.DeclRoot noLoc)
                                noLoc

        test_issue43_2 :: Assertion
        test_issue43_2 = [cty|long double _Complex|] @?=
                         C.Type (C.DeclSpec [] [] (C.Tlong_double_Complex noLoc) noLoc)
                                (C.DeclRoot noLoc)
                                noLoc

        test_issue43_3 :: Assertion
        test_issue43_3 = [cty|long  _Complex double|] @?=
                         C.Type (C.DeclSpec [] [] (C.Tlong_double_Complex noLoc) noLoc)
                                (C.DeclRoot noLoc)
                                noLoc

        test_issue43_4 :: Assertion
        test_issue43_4 = [cty|_Imaginary long double|] @?=
                         C.Type (C.DeclSpec [] [] (C.Tlong_double_Imaginary noLoc) noLoc)
                                (C.DeclRoot noLoc)
                                noLoc

-- | Pretty-print a value on single line.
showCompact :: Pretty a => a -> String
showCompact = map space2space . flip displayS "" . renderCompact . ppr
  where
    space2space :: Char -> Char
    space2space c | isSpace c = ' '
                  | otherwise = c