manage associate assignments another way

Copy the AList approach for tuples. Nice and easy approach that seems
sensible to me.

Author: raehik

src/Language/Fortran/AST.hs

@@ -347,7 +347,7 @@ data Block a =
   | BlAssociate a SrcSpan
                 (Maybe (Expression a))       -- Label
                 (Maybe String)               -- Construct name
-                [(Expression a, Expression a)] -- Expression abbreviations
+                (AList (ATuple Expression Expression) a) -- Expression abbreviations
                 [ Block a ]                  -- Body
                 (Maybe (Expression a))       -- Label to END IF
   -- ^ The first 'Expression' in the abbreviation tuple is always an

src/Language/Fortran/AST/AList.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 module Language.Fortran.AST.AList where
 
@@ -63,3 +64,14 @@ aStrip' (Just a) = aStrip a
 
 aMap :: (t a -> r a) -> AList t a -> AList r a
 aMap f (AList a s xs) = AList a s (map f xs)
+
+--------------------------------------------------------------------------------
+
+data ATuple t1 t2 a = ATuple a SrcSpan (t1 a) (t2 a)
+    deriving (Eq, Show, Data, Typeable, Generic, Functor)
+
+instance FirstParameter (ATuple t1 t2 a) a
+instance SecondParameter (ATuple t1 t2 a) SrcSpan
+instance Spanned (ATuple t1 t2 a)
+instance (Out a, Out (t1 a), Out (t2 a)) => Out (ATuple t1 t2 a)
+instance (NFData a, NFData (t1 a), NFData (t2 a)) => NFData (ATuple t1 t2 a)

src/Language/Fortran/Parser/Fortran90.y

@@ -411,17 +411,17 @@ ASSOCIATE_BLOCK :: { Block A0 }
           mLabel     = Just $1;
           TId _ name = $2;
           mName      = Just name;
-          abbrevs    = $6;
-          body       = $10;
+          abbrevs    = fromReverseList $6;
+          body       = reverse $10;
           (endSpan, mEndLabel) = $11;
           span       = getTransSpan startSpan endSpan }
      in BlAssociate () span mLabel mName abbrevs body mEndLabel }
 | INTEGER_LITERAL        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
   { let { startSpan  = getSpan $1;
           mLabel     = Just $1;
           mName      = Nothing;
-          abbrevs    = $4;
-          body       = $8;
+          abbrevs    = fromReverseList $4;
+          body       = reverse $8;
           (endSpan, mEndLabel) = $9;
           span       = getTransSpan startSpan endSpan }
      in BlAssociate () span mLabel mName abbrevs body mEndLabel }
@@ -430,17 +430,17 @@ ASSOCIATE_BLOCK :: { Block A0 }
           TId _ name = $1;
           mLabel     = Nothing;
           mName      = Just name;
-          abbrevs    = $5;
-          body       = $9;
+          abbrevs    = fromReverseList $5;
+          body       = reverse $9;
           (endSpan, mEndLabel) = $10;
           span       = getTransSpan startSpan endSpan }
      in BlAssociate () span mLabel mName abbrevs body mEndLabel }
 |                        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
   { let { startSpan  = getSpan $1;
           mLabel     = Nothing;
           mName      = Nothing;
-          abbrevs    = $3;
-          body       = $7;
+          abbrevs    = fromReverseList $3;
+          body       = reverse $7;
           (endSpan, mEndLabel) = $8;
           span       = getTransSpan startSpan endSpan }
      in BlAssociate () span mLabel mName abbrevs body mEndLabel }
@@ -453,11 +453,11 @@ END_ASSOCIATE :: { (SrcSpan, Maybe (Expression A0)) }
 | INTEGER_LITERAL endassociate id { (getSpan $3, Just $1) }
 
 -- (var (ExpValue (ValVariable)), assoc. expr)
-ABBREVIATIONS :: { [(Expression A0, Expression A0)] }
+ABBREVIATIONS :: { [(ATuple Expression Expression A0)] }
 : ABBREVIATIONS ',' ABBREVIATION { $3 : $1 }
 |                   ABBREVIATION { [ $1 ]  }
-ABBREVIATION :: { (Expression A0, Expression A0) }
-: VARIABLE '=>' EXPRESSION { ($1, $3) }
+ABBREVIATION :: { ATuple Expression Expression A0 }
+: VARIABLE '=>' EXPRESSION { ATuple () (getTransSpan $1 $3) $1 $3 }
 
 MAYBE_EXPRESSION :: { Maybe (Expression A0) }
 : EXPRESSION { Just $1 }

src/Language/Fortran/PrettyPrint.hs

@@ -327,14 +327,46 @@ instance IndentablePretty (Block a) where
             then indent i (pprint' v label <+> stDoc)
             else pprint' v mLabel `overlay` indent i stDoc
 
+    -- TODO associate
     pprint v (BlAssociate _ _ mLabel mName abbrevs bodies mEndLabel) i
       | v >= Fortran90 =
-        indent i ("associate" <+> "ABBREVS" <> newline) <>
-        pprint v bodies nextI <>
-        indent i ("end associate" <> newline)
+        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
       where
         nextI = incIndentation i
+        labeledIndent label stDoc =
+          if v >= Fortran90
+            then indent i (pprint' v label <+> stDoc)
+            else pprint' v mLabel `overlay` indent i stDoc
+{-
+    pprint v (BlIf _ _ mLabel mName conds bodies el) i
+      | v >= Fortran77 =
+        labeledIndent mLabel
+          $  (pprint' v mName <?> colon
+                <+> "if" <+> parens (pprint' v firstCond) <+> "then" <> newline)
+          <> pprint v firstBody nextI
+          <> foldl' (<>) empty (map displayCondBlock restCondsBodies)
+          <> labeledIndent el ("end if" <+> pprint' v mName <> newline)
+      | otherwise = tooOld v "Structured if" Fortran77
+      where
+        ((firstCond, firstBody): restCondsBodies) = zip conds bodies
+        displayCondBlock (mCond, block) =
+          indent i
+            (case mCond of {
+              Just cond -> "else if" <+> parens (pprint' v cond) <+> "then";
+              Nothing -> "else"
+            } <> newline) <>
+          pprint v block nextI
+        nextI = incIndentation i
+        labeledIndent label stDoc =
+          if v >= Fortran90
+            then indent i (pprint' v label <+> stDoc)
+            else pprint' v mLabel `overlay` indent i stDoc
+-}
 
     pprint v (BlComment _ _ (Comment comment)) i
       | v >= Fortran90 = indent i (char '!' <> text comment <> newline)
@@ -353,6 +385,10 @@ 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
+
 instance Pretty BaseType where
     pprint' _ TypeInteger = "integer"
     pprint' _ TypeReal    = "real"