From 638802592dcca83fb14b9d6f6ab3d31f7f5c4044 Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Fri, 28 Jul 2023 12:14:17 +0100
Subject: [PATCH] PrettyPrint: +more specific error wrapper

---
 src/Language/Fortran/PrettyPrint.hs | 49 ++++++++++++++++++-----------
 1 file changed, 31 insertions(+), 18 deletions(-)

diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs
index f48a9b1c..e3a991b4 100644
--- a/src/Language/Fortran/PrettyPrint.hs
+++ b/src/Language/Fortran/PrettyPrint.hs
@@ -5,6 +5,7 @@ module Language.Fortran.PrettyPrint where
 
 import Data.Maybe (isJust, isNothing, listToMaybe)
 import Data.List (foldl')
+import qualified Data.List as List
 
 import Prelude hiding (EQ,LT,GT,pred,exp,(<>))
 
@@ -16,11 +17,6 @@ import Language.Fortran.Version
 
 import Text.PrettyPrint
 
-tooOld :: FortranVersion -> String -> FortranVersion -> a
-tooOld currentVersion featureName featureVersion = prettyError $
-    featureName ++ " was introduced in " ++ show featureVersion ++
-    ". You called pretty print with " ++ show currentVersion ++ "."
-
 -- | Continue only if the given version is equal to or older than a "maximum"
 --   version, or emit a runtime error.
 olderThan :: FortranVersion -> String -> FortranVersion -> a -> a
@@ -33,6 +29,24 @@ olderThan verMax featureName ver cont =
             ++ show ver ++ "."
     else cont
 
+-- | Continue if the given version is one of the given "permitted" versions,
+--   else emit a runtime error.
+continueOnlyFor :: [FortranVersion] -> String -> FortranVersion -> a -> a
+continueOnlyFor permittedVers featureName ver cont =
+    if ver `List.elem` permittedVers then cont
+    else prettyError $
+            featureName
+            ++ " is only available for: " ++ show permittedVers
+            ++ ". You called pretty print with " ++ show ver ++ "."
+
+-- | Emit a runtime error due to bad pretty printing.
+--
+-- Intended to be used in the @otherwise@ guard.
+tooOld :: FortranVersion -> String -> FortranVersion -> a
+tooOld currentVersion featureName featureVersion = prettyError $
+    featureName ++ " was introduced in " ++ show featureVersion ++
+    ". You called pretty print with " ++ show currentVersion ++ "."
+
 (<?>) :: Doc -> Doc -> Doc
 doc1 <?> doc2 = if doc1 == empty || doc2 == empty then empty else doc1 <> doc2
 infixl 7 <?>
@@ -391,9 +405,9 @@ instance Pretty BaseType where
     pprint' _ TypeReal    = "real"
     pprint' _ TypeDoublePrecision = "double precision"
     pprint' _ TypeComplex = "complex"
-    pprint' v TypeDoubleComplex
-      | v == Fortran77Extended = "double complex"
-      | otherwise = tooOld v "Double complex" Fortran77Extended
+    pprint' v TypeDoubleComplex =
+        continueOnlyFor [Fortran77Extended] "Double complex" v $
+            "double complex"
     pprint' _ TypeLogical = "logical"
     pprint' v TypeCharacter
       | v >= Fortran77 = "character"
@@ -530,13 +544,13 @@ instance Pretty (Statement a) where
       | v >= Fortran90 = "data" <+> pprint' v aDataGroups
       | otherwise = "data" <+> hsep (map (pprint' v) dataGroups)
 
-    pprint' v (StAutomatic _ _ decls)
-      | v `elem` [Fortran77Extended, Fortran77Legacy] = "automatic" <+> pprint' v decls
-      | otherwise = tooOld v "Automatic statement" Fortran90
+    pprint' v (StAutomatic _ _ decls) =
+        continueOnlyFor [Fortran77Extended, Fortran77Legacy] "Automatic statement" v $
+            "automatic" <+> pprint' v decls
 
-    pprint' v (StStatic _ _ decls)
-      | v `elem` [Fortran77Extended, Fortran77Legacy] = "static" <+> pprint' v decls
-      | otherwise = tooOld v "Static statement" Fortran90
+    pprint' v (StStatic _ _ decls) =
+        continueOnlyFor [Fortran77Extended, Fortran77Legacy] "Static statement" v $
+            "static" <+> pprint' v decls
 
     pprint' v (StNamelist _ _ namelist)
       | v >= Fortran90 = "namelist" <+> pprint' v namelist
@@ -671,10 +685,9 @@ instance Pretty (Statement a) where
       "write" <+> parens (pprint' v cilist) <+> pprint' v mIolist
     pprint' v (StPrint _ _ formatId mIolist) =
       "print" <+> pprint' v formatId <> comma <?+> pprint' v mIolist
-    pprint' v (StTypePrint _ _ formatId mIolist)
-      | v == Fortran77Extended
-      = "type" <+> pprint' v formatId <> comma <?+> pprint' v mIolist
-      | otherwise = tooOld v "Type (print) statement" Fortran77Extended
+    pprint' v (StTypePrint _ _ formatId mIolist) =
+        continueOnlyFor [Fortran77Extended] "Type (print) statement" v $
+            "type" <+> pprint' v formatId <> comma <?+> pprint' v mIolist
 
     pprint' v (StOpen _ _ cilist) = "open" <+> parens (pprint' v cilist)
     pprint' v (StClose _ _ cilist) = "close" <+> parens (pprint' v cilist)