add associate block tests

src/Language/Fortran/Parser/Fortran2003.y

@@ -1,8 +1,10 @@
 -- -*- Mode: Haskell -*-
+-- vim: ft=haskell
 {
 -- Incomplete work-in-progress.
 module Language.Fortran.Parser.Fortran2003 ( functionParser
                                            , statementParser
+                                           , blockParser
                                            , fortran2003Parser
                                            , fortran2003ParserWithTransforms
                                            , fortran2003ParserWithModFiles
@@ -32,9 +34,10 @@ import Debug.Trace
 
 }
 
-%name programParser PROGRAM
+%name programParser   PROGRAM
+%name functionParser  SUBPROGRAM_UNIT
+%name blockParser     BLOCK
 %name statementParser STATEMENT
-%name functionParser SUBPROGRAM_UNIT
 %monad { LexAction }
 %lexer { lexer } { TEOF _ }
 %tokentype { Token }

src/Language/Fortran/PrettyPrint.hs

@@ -327,14 +327,16 @@ instance IndentablePretty (Block a) where
             then indent i (pprint' v label <+> stDoc)
             else pprint' v mLabel `overlay` indent i stDoc
 
+    -- Note that binary expressions such as @a*b@ will always be wrapped in
+    -- brackets. It appears to be built into 'Expression''s 'Pretty' instance.
     pprint v (BlAssociate _ _ mLabel mName abbrevs bodies mEndLabel) i
-      | v >= Fortran90 =
+      | v >= Fortran2003 =
         labeledIndent mLabel
           $  pprint' v mName <?> colon
                 <+> ("associate" <+> "(" <> pprint' v abbrevs <> ")" <> newline)
           <> pprint v bodies nextI
           <> labeledIndent mEndLabel ("end associate" <+> pprint' v mName <> newline)
-      | otherwise = tooOld v "Associate block" Fortran90
+      | otherwise = tooOld v "Associate block" Fortran2003
       where
         nextI = incIndentation i
         labeledIndent label stDoc =
@@ -359,7 +361,6 @@ instance Pretty String where
 instance Pretty (e a) => Pretty (AList e a) where
     pprint' v es = commaSep (map (pprint' v) (aStrip es))
 
--- TODO associate
 instance (Pretty (t1 a), Pretty (t2 a)) => Pretty (ATuple t1 t2 a) where
     pprint' v (ATuple _ _ t1 t2) = pprint' v t1 <+> "=>" <+> pprint' v t2
 

test/Language/Fortran/Parser/Fortran2003Spec.hs

@@ -21,13 +21,18 @@ eParser sourceCode =
     paddedSourceCode = B.pack $ "      a = " ++ sourceCode
     parseState =  initParseState paddedSourceCode Fortran2003 "<unknown>"
 
+simpleParser :: Parse AlexInput Token a -> String -> a
+simpleParser p sourceCode =
+  evalParse p $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"
+
 sParser :: String -> Statement ()
-sParser sourceCode =
-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"
+sParser = simpleParser statementParser
 
 fParser :: String -> ProgramUnit ()
-fParser sourceCode =
-  evalParse functionParser $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"
+fParser = simpleParser functionParser
+
+bParser :: String -> Block ()
+bParser = simpleParser blockParser
 
 spec :: Spec
 spec =
@@ -141,16 +146,32 @@ spec =
         sParser "real, protected, public :: x" `shouldBe'` st1
         sParser "protected x" `shouldBe'` st2
 
-      describe "labelled where" $ do
-        it "parses where construct statement" $
-          sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue
-
-        it "parses elsewhere statement" $
-          sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing
-
-        it "parses elsewhere statement" $ do
-          let exp = ExpBinary () u GT (varGen "a") (varGen "b")
-          sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp)
-
-        it "parses endwhere statement" $
-          sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")
+    describe "labelled where" $ do
+      it "parses where construct statement" $
+        sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue
+
+      it "parses elsewhere statement" $
+        sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing
+
+      it "parses elsewhere statement" $ do
+        let exp = ExpBinary () u GT (varGen "a") (varGen "b")
+        sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp)
+
+      it "parses endwhere statement" $
+        sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")
+
+    describe "associate block" $ do
+      it "parses multiple assignment associate block" $ do
+        let text = unlines [ "associate (x => a, y => (a * b))"
+                           , "  print *, x"
+                           , "  print *, y"
+                           , "end associate" ]
+            expected = BlAssociate () u Nothing Nothing abbrevs body' Nothing
+            body'   = [blStmtPrint "x", blStmtPrint "y"]
+            blStmtPrint x = BlStatement () u Nothing (stmtPrint x)
+            stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])
+            abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]
+            abbrev var expr = ATuple () u (expValVar var) expr
+            expValVar x = ExpValue () u (ValVariable x)
+            expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)
+        bParser text `shouldBe'` expected

test/Language/Fortran/PrettyPrintSpec.hs

@@ -404,6 +404,43 @@ spec =
                                , "42 end select" ]
           pprint Fortran90 bl (Just 0) `shouldBe` text expect
 
+      describe "Case" $
+        it "prints multi-case select case construct" $ do
+          let range = IxRange () u (Just $ intGen 2) (Just $ intGen 4) Nothing
+          let cases = [ Just (AList () u [range])
+                      , Just (AList () u [ IxSingle () u Nothing (intGen 7) ])
+                      , Nothing ]
+          let bodies = replicate 3 body
+          let bl = BlCase () u Nothing Nothing (varGen "x") cases bodies (Just (intGen 42))
+          let expect = unlines [ "select case (x)"
+                               , "  case (2:4)"
+                               , "    print *, i"
+                               , "    i = (i - 1)"
+                               , "  case (7)"
+                               , "    print *, i"
+                               , "    i = (i - 1)"
+                               , "  case default"
+                               , "    print *, i"
+                               , "    i = (i - 1)"
+                               , "42 end select" ]
+          pprint Fortran90 bl (Just 0) `shouldBe` text expect
+
+      describe "Associate" $
+        it "prints multi-abbreviation associate block (Fortran2003)" $ do
+          let bl      = BlAssociate () u Nothing Nothing abbrevs body' Nothing
+              body'   = [blStmtPrint "x", blStmtPrint "y"]
+              blStmtPrint x = BlStatement () u Nothing (stmtPrint x)
+              stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])
+              abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]
+              abbrev var expr = ATuple () u (expValVar var) expr
+              expValVar x = ExpValue () u (ValVariable x)
+              expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)
+          let expect = unlines [ "associate (x => a, y => (a * b))"
+                               , "  print *, x"
+                               , "  print *, y"
+                               , "end associate" ]
+          pprint Fortran2003 bl (Just 0) `shouldBe` text expect
+
     describe "Program units" $ do
       describe "Main" $ do
         it "prints 90 style main without sub programs" $ do