content: {-| Common tests for free-form Fortran.
  
  Fortran standards F90 and beyond are a lot more consistent than the
  previous 2. As such, there is lots of shared parsing, and lots of shared
  tests. This module encodes such shared/common tests, where no difference
  in behaviour between parsers is be expected.
  -}
  
  module Language.Fortran.Parser.Free.Common ( specFreeCommon ) where
  
  import TestUtil
  import Test.Hspec
  
  import Language.Fortran.AST
  import Language.Fortran.AST.Literal.Real
  
  specFreeCommon :: (String -> Block A0) -> (String -> Statement A0) -> (String -> Expression A0) -> Spec
  specFreeCommon bParser sParser eParser =
    describe "Common Fortran 90+ (free form) tests" $ do
      describe "Literals" $ do
        describe "Logical" $ do
          it "parses logical literal without kind parameter" $ do
            eParser ".true." `shouldBe'` valTrue
  
          it "parses logical literal with kind parameter" $ do
            let kp = KindParamVar () u "kind"
            eParser ".false._kind" `shouldBe'` valFalse' kp
  
          it "parses mixed-case logical literal" $ do
            eParser ".tRUe." `shouldBe'` valTrue
  
        -- Main parse testing is performed in @Language.Fortran.AST.RealLitSpec@.
        -- Here we mainly want to test kind parameter and sign behaviour.
        describe "Real" $ do
          let realLitExp r mkp = ExpValue () u (ValReal (parseRealLit r) mkp)
          it "parses various REAL literals" $ do
            eParser "1."      `shouldBe'` realLitExp "1."    Nothing
            eParser ".1e20_8" `shouldBe'` realLitExp ".1e20" (Just (KindParamInt () u "8"))
  
          it "parses \"negative\" real literal (unary op)" $ do
            let lit = "-1.0d-1_k8"
                kp  = KindParamVar () u "k8"
             in eParser lit `shouldBe'` ExpUnary () u Minus (realLitExp "1.0d-1" (Just kp))
  
        describe "Kind parameters" $ do
          it "parses var kind parameter with underscore" $ do
            let lit = "123_a_1"
                kp  = KindParamVar () u "a_1"
             in eParser lit `shouldBe'` ExpValue () u (ValInteger "123" (Just kp))
  
          it "fails to parse invalid kind parameter with underscore after numeric" $ do
            {- TODO can't test here because we push parse errors into runtime ones
            let lit = "123_4_8"
             in eParser lit `shouldBe'` undefined -- should error "last parsed was the 2nd underscore"
            -}
            pending
  
        -- Check various real/int literal forms and some kind parameters.
        describe "Complex" $ do
          let kp = Just . KindParamInt () u
          it "parses a complex literal via positive reals" $ do
            let cr = ComplexPartReal () u (parseRealLit "1.0E0") (kp "8")
                ci = ComplexPartReal () u (parseRealLit "0.2E1") Nothing
            eParser "(1.0E0_8, 0.2E1)" `shouldBe'` complexGen cr ci
          it "parses a complex literal via positive mixed lits" $ do
            let cr = ComplexPartInt  () u "1"                  Nothing
                ci = ComplexPartReal () u (parseRealLit "2D0") Nothing
            eParser "(1, 2D0)" `shouldBe'` complexGen cr ci
          it "parses a complex literal via negative ints" $ do
            let cr = ComplexPartInt  () u "-1" Nothing
                ci = ComplexPartInt  () u "-2" Nothing
            eParser "(-1, -2)" `shouldBe'` complexGen cr ci
          it "parses a complex literal via mixed sign mixed lits with kind parameters" $ do
            let cr = ComplexPartReal () u (parseRealLit "-1.2") (kp "8")
                ci = ComplexPartInt  () u "0"                    Nothing
            eParser "(-1.2_8, 0)" `shouldBe'` complexGen cr ci
          it "parses a complex literal via named constants" $ do
            let cr = ComplexPartNamed () u "a"
                ci = ComplexPartNamed () u "b_something"
            eParser "(a, b_something)" `shouldBe'` complexGen cr ci
  
      describe "Statement" $ do
        describe "Declaration" $ do
          it "parses scalar declaration with nonstandard kind param (non-CHAR)" $ do
            let stStr    = "integer x*8"
                expected = StDeclaration () u typeSpec Nothing decls
                typeSpec = TypeSpec () u TypeInteger Nothing
                decls    = AList () u
                  [ declVariable () u (varGen "x") (Just (intGen 8)) Nothing ]
            sParser stStr `shouldBe'` expected
  
          it "parses array declaration with nonstandard kind param (non-CHAR)" $ do
            let stStr    = "integer x(2)*8"
                expected = StDeclaration () u typeSpec Nothing decls
                typeSpec = TypeSpec () u TypeInteger Nothing
                decls    = AList () u
                  [ declArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]
                dims     = AList () u
                  [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]
            sParser stStr `shouldBe'` expected
  
          it "parses array declaration with nonstandard kind param (non-CHAR) and nonstandard dimension/charlen order" $ do
            let stStr    = "integer x*8(2)"
                expected = StDeclaration () u typeSpec Nothing decls
                typeSpec = TypeSpec () u TypeInteger Nothing
                decls    = AList () u
                  [ declArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]
                dims     = AList () u
                  [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]
            sParser stStr `shouldBe'` expected
  
        describe "Function call" $ do
          it "parses a simple function call" $ do
            let stStr    = "call double(i, i)"
                expected = StCall () u (varGen "double") args
                args     = AList () u [arg, arg]
                arg      = Argument () u Nothing (ArgExpr (varGen "i"))
            sParser stStr `shouldBe'` expected
  
          it "parses a parenthesized variable as a special indirect/copied variable reference" $ do
            let stStr    = "call double((i), i)"
                expected = StCall () u (varGen "double") args
                args     = AList () u [ genArg (ArgExprVar () u "i")
                                      , genArg (ArgExpr (varGen "i")) ]
                genArg   = Argument () u Nothing
            sParser stStr `shouldBe'` expected
  
        describe "Implicit" $ do
          it "parses implicit none" $ do
            let st = StImplicit () u Nothing
            sParser "implicit none" `shouldBe'` st
  
          it "parses implicit with single" $ do
            let typeSpec = TypeSpec () u TypeCharacter Nothing
                impEls = [ ImpElement () u 'k' Nothing ]
                impLists = [ ImpList () u typeSpec (fromList () impEls) ]
                st = StImplicit () u (Just $ fromList () impLists)
            sParser "implicit character (k)" `shouldBe'` st
  
          it "parses implicit with range" $ do
            let typeSpec = TypeSpec () u TypeLogical Nothing
                impEls = [ ImpElement () u 'x' (Just 'z') ]
                impLists = [ ImpList () u typeSpec (fromList () impEls) ]
                st = StImplicit () u (Just $ fromList () impLists)
            sParser "implicit logical (x-z)" `shouldBe'` st
  
          it "parses implicit statement" $ do
            let typeSpec1 = TypeSpec () u TypeCharacter Nothing
                typeSpec2 = TypeSpec () u TypeInteger Nothing
                impEls1 = [ ImpElement () u 's' Nothing, ImpElement () u 'a' Nothing ]
                impEls2 = [ ImpElement () u 'x' (Just 'z') ]
                impLists = [ ImpList () u typeSpec1 (fromList () impEls1)
                           , ImpList () u typeSpec2 (fromList () impEls2) ]
                st = StImplicit () u (Just $ fromList () impLists)
            sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st
  
      describe "Block" $ do
        describe "Case" $ do
          let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]
              printStmt = StPrint () u (ExpValue () u ValStar) . printArgs
              ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2
              ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing
  
          it "unlabelled case block (with inline comments to be stripped)" $ do
            let printBlock = BlStatement () u Nothing . printStmt
                clauses = [(ind2, [printBlock "foo"]), (ind3Plus, [printBlock "bar"])]
                caseDef = Just [printBlock "baz"]
            let src = unlines [ "select case (x) ! comment select"
                              , "! full line before first case (unrepresentable)"
                              , "case (2) ! comment case 1"
                              , "print *, 'foo'"
                              , "case (3:) ! comment case 2"
                              , "print *, 'bar'"
                              , "case default ! comment case 3"
                              , "print *, 'baz'"
                              , "end select ! comment end"
                              ]
                block = BlCase () u Nothing Nothing (varGen "x") clauses caseDef Nothing
            bParser src `shouldBe'` block
  
          it "labelled case block (with inline comments to be stripped" $ do
            let printBlock label = BlStatement () u (Just $ intGen label) . printStmt
                clauses = [(ind2, [printBlock 30 "foo"]), (ind3Plus, [printBlock 50 "bar"])]
                caseDef = Just [printBlock 70 "baz"]
            let src = unlines [ "10 mylabel: select case (x) ! comment select"
                              , "20 case (2) ! comment case 1"
                              , "30 print *, 'foo'"
                              , "40 case (3:) ! comment case 2"
                              , "50 print *, 'bar'"
                              , "60 case default ! comment case 3"
                              , "70 print *, 'baz'"
                              , "80 end select mylabel ! comment end"
                              ]
                block = BlCase () u
                               (Just $ intGen 10) (Just "mylabel") (varGen "x")
                               clauses caseDef
                               (Just $ intGen 80)
            bParser src `shouldBe'` block
  
        describe "If" $ do
          let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])
              inner   = [BlStatement () u Nothing stPrint]
          it "parser if block" $
            let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]
                ifBlock = BlIf () u Nothing Nothing ((valFalse, inner) :| []) Nothing Nothing
            in  bParser ifBlockSrc `shouldBe'` ifBlock
  
          it "parses named if block" $ do
            let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]
                ifBlock = BlIf () u Nothing (Just "mylabel") ((valTrue, inner) :| []) Nothing Nothing
            bParser ifBlockSrc `shouldBe'` ifBlock
  
          it "parses if-else block with inline comments (stripped)" $
            let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]
                ifBlock = BlIf () u Nothing Nothing ((valFalse, inner) :| []) (Just inner) Nothing
            in  bParser ifBlockSrc `shouldBe'` ifBlock
  
          it "parses logical if statement" $ do
            let assignment = StExpressionAssign () u (varGen "a") (varGen "b")
                stIf = StIfLogical () u valTrue assignment
            sParser "if (.true.) a = b" `shouldBe'` stIf
  
          it "parses arithmetic if statement" $ do
            let stIf = StIfArithmetic () u (varGen "x") (intGen 1)
                                                        (intGen 2)
                                                        (intGen 3)
            sParser "if (x) 1, 2, 3" `shouldBe'` stIf
  