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)