From 28bb5a53a81a51c791d42422d51663b722df9314 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Thu, 31 Mar 2022 18:33:22 +0200 Subject: [PATCH] Haskell: emit `{-# LANGUAGE Safe #-}` (and `Trustworthy` in Lex/Par.hs) Had to get rid of GeneralizedNewtypeDeriving extension in Abs.hs. --- source/CHANGELOG.md | 1 + source/src/BNFC/Backend/Haskell.hs | 4 +- .../src/BNFC/Backend/Haskell/CFtoAbstract.hs | 57 ++++++++++++++----- source/src/BNFC/Backend/Haskell/CFtoAlex3.hs | 1 + source/src/BNFC/Backend/Haskell/CFtoHappy.hs | 2 + source/src/BNFC/Backend/Haskell/CFtoLayout.hs | 5 +- .../src/BNFC/Backend/Haskell/CFtoPrinter.hs | 6 +- .../src/BNFC/Backend/Haskell/CFtoTemplate.hs | 5 +- source/src/BNFC/Backend/Haskell/MkErrM.hs | 9 ++- source/src/BNFC/Backend/Haskell/Utils.hs | 9 ++- source/src/BNFC/Backend/HaskellGADT.hs | 4 +- .../Backend/HaskellGADT/CFtoAbstractGADT.hs | 10 +++- .../Backend/HaskellGADT/CFtoTemplateGADT.hs | 10 ++-- 13 files changed, 88 insertions(+), 35 deletions(-) diff --git a/source/CHANGELOG.md b/source/CHANGELOG.md index 8cecc996..9dd19be4 100644 --- a/source/CHANGELOG.md +++ b/source/CHANGELOG.md @@ -1,6 +1,7 @@ # 2.9.5 Unreleased +* Haskell: label produced code as `Safe` (and parser as `Trustworthy`) # 2.9.4 diff --git a/source/src/BNFC/Backend/Haskell.hs b/source/src/BNFC/Backend/Haskell.hs index 93d3600f..31d7d4fd 100644 --- a/source/src/BNFC/Backend/Haskell.hs +++ b/source/src/BNFC/Backend/Haskell.hs @@ -298,7 +298,9 @@ makefile opts cf makeFile = vcat testfile :: Options -> CF -> String testfile opts cf = unlines $ concat $ - [ [ "-- | Program to test parser." + [ languageSafe + , [ "" + , "-- | Program to test parser." , "" , "module Main where" , "" diff --git a/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs b/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs index 8c551694..808690c4 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs @@ -22,13 +22,14 @@ import qualified Data.List as List import BNFC.CF import BNFC.Options ( SharedOptions(..), TokenText(..) ) import BNFC.PrettyPrint -import BNFC.Utils ( when, applyWhen ) +import BNFC.Utils ( when, unless, applyWhen ) import BNFC.Backend.Haskell.Utils ( avoidReservedWords, catToType, mkDefName , tokenTextImport, tokenTextType, typeToHaskell' , posType, posConstr, noPosConstr , hasPositionClass, hasPositionMethod + , languageSafe ) -- | Create a Haskell module containing data type definitions for the abstract syntax. @@ -50,10 +51,11 @@ cf2Abstract Options{ lang, tokenText, generic, functor } name cf = vsep . concat , [ "{-# LANGUAGE DeriveGeneric #-}" | gen ] , [ "{-# LANGUAGE DeriveTraversable #-}" | fun ] , [ "{-# LANGUAGE FlexibleInstances #-}" | fun ] - , [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | hasIdentLikeNoPos ] -- for IsString + -- , [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | hasIdentLikeNoPos ] -- for IsString , [ "{-# LANGUAGE LambdaCase #-}" | fun ] , [ "{-# LANGUAGE PatternSynonyms #-}" | defPosition ] , [ "{-# LANGUAGE OverloadedStrings #-}" | not (null definitions), tokenText /= StringToken ] + , languageSafe ] ] , [ "-- | The abstract syntax of language" <+> text lang <> "." ] @@ -61,8 +63,8 @@ cf2Abstract Options{ lang, tokenText, generic, functor } name cf = vsep . concat -- Imports , [ vcat . concat $ - [ [ text $ "import Prelude (" ++ List.intercalate ", " typeImports ++ ")" - | not $ null typeImports ] + [ [ text $ "import Prelude (" ++ List.intercalate ", " preludeImports ++ ")" + | not $ null preludeImports ] , [ prettyList 2 "import qualified Prelude as C" "(" ")" "," $ qualifiedPreludeImports | not $ null qualifiedPreludeImports ] , [ "import qualified Data.String" @@ -85,7 +87,7 @@ cf2Abstract Options{ lang, tokenText, generic, functor } name cf = vsep . concat -- Token definition types , (`map` specialCats cf) $ \ c -> let hasPos = isPositionCat cf c - in prSpecialData tokenText hasPos (derivingClassesTokenType hasPos) c + in prSpecialData tokenText hasPos (derivingClasses False) c -- BNFC'Position type -- We generate these synonyms for position info when --functor, @@ -146,15 +148,20 @@ cf2Abstract Options{ lang, tokenText, generic, functor } name cf = vsep . concat , when functor funClasses , when generic genClasses ] - derivingClassesTokenType hasPos = concat - [ derivingClasses False - , [ "Data.String.IsString" | not hasPos ] - ] + -- derivingClassesTokenType hasPos = concat + -- [ derivingClasses False + -- , [ "Data.String.IsString" | not hasPos ] + -- ] + -- import Prelude (Char, Double, Integer, String) typeImports = filter (\ s -> hasData && s `elem` cfgLiterals cf || hasTextualToks && tokenText == StringToken && s == "String") baseTokenCatNames + preludeImports = concat + [ typeImports + , [ "(.)" | hasTextualToks && tokenText /= StringToken ] + ] qualifiedPreludeImports = concat [ [ text $ List.intercalate ", " stdClasses | hasTextualToks || hasData ] , [ text $ List.intercalate ", " funClasses | fun ] @@ -235,21 +242,30 @@ instanceHasPositionData (cat, rules) = vcat . concat $ -- | Generate a newtype declaration for Ident types -- --- >>> prSpecialData StringToken False ["Show","Data.String.IsString"] catIdent +-- >>> prSpecialData StringToken False ["Show","Eq"] catIdent -- newtype Ident = Ident String --- deriving (Show, Data.String.IsString) +-- deriving (Show, Eq) +-- +-- instance Data.String.IsString Ident where +-- fromString = Ident -- --- >>> prSpecialData StringToken True ["Show"] catIdent +-- >>> prSpecialData StringToken True ["Show","Eq","Ord"] catIdent -- newtype Ident = Ident ((C.Int, C.Int), String) --- deriving (Show) +-- deriving (Show, Eq, Ord) -- -- >>> prSpecialData TextToken False ["Show"] catIdent -- newtype Ident = Ident Data.Text.Text -- deriving (Show) +-- +-- instance Data.String.IsString Ident where +-- fromString = Ident . Data.String.fromString -- -- >>> prSpecialData ByteStringToken False ["Show"] catIdent -- newtype Ident = Ident BS.ByteString -- deriving (Show) +-- +-- instance Data.String.IsString Ident where +-- fromString = Ident . Data.String.fromString -- -- >>> prSpecialData ByteStringToken True ["Show"] catIdent -- newtype Ident = Ident ((C.Int, C.Int), BS.ByteString) @@ -261,14 +277,25 @@ prSpecialData -> [String] -- ^ Derived classes. -> TokenCat -- ^ Token category name. -> Doc -prSpecialData tokenText position classes cat = vcat - [ hsep [ "newtype", text cat, "=", text cat, contentSpec ] +prSpecialData tokenText position classes cat = vcat $ concat + [ [ hsep [ "newtype", ident, "=", ident, contentSpec ] , nest 2 $ deriving_ classes ] + , unless position + [ "" + , hsep [ "instance", "Data.String.IsString", ident, "where" ] + , nest 2 $ hsep [ "fromString", "=", fromString ] + ] + ] where + ident = text cat contentSpec | position = parens ( "(C.Int, C.Int), " <> stringType) | otherwise = stringType stringType = text $ tokenTextType tokenText + fromString + | tokenText == StringToken = ident + | otherwise = hsep [ ident, ".", "Data.String.fromString" ] + -- | Generate 'deriving' clause -- diff --git a/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs b/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs index 65d0dbf5..032d3d4b 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs @@ -41,6 +41,7 @@ prelude name tokenText = concat , "{-# OPTIONS_GHC -w #-}" , "" , "{-# LANGUAGE PatternSynonyms #-}" + , "{-# LANGUAGE Trustworthy #-}" , "" , "module " ++ name ++ " where" , "" diff --git a/source/src/BNFC/Backend/Haskell/CFtoHappy.hs b/source/src/BNFC/Backend/Haskell/CFtoHappy.hs index f21f9aba..4a75996b 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoHappy.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoHappy.hs @@ -63,7 +63,9 @@ header modName absName lexName tokenText eps = unlines $ concat [ [ "-- Parser definition for use with Happy" , "{" , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}" + , "" , "{-# LANGUAGE PatternSynonyms #-}" + , "{-# LANGUAGE Trustworthy #-}" , "" , "module " ++ modName , " ( happyError" diff --git a/source/src/BNFC/Backend/Haskell/CFtoLayout.hs b/source/src/BNFC/Backend/Haskell/CFtoLayout.hs index 38322e03..277c63b8 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoLayout.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoLayout.hs @@ -14,6 +14,7 @@ import Data.Maybe ( fromMaybe, mapMaybe ) import BNFC.CF import BNFC.PrettyPrint import BNFC.Utils ( caseMaybe, for, whenJust ) +import BNFC.Backend.Haskell.Utils ( languageSafe ) data TokSymbol = TokSymbol String Int deriving Show @@ -28,7 +29,9 @@ cf2Layout layName lexName cf = unlines $ concat , "{-# LANGUAGE LambdaCase #-}" , "{-# LANGUAGE PatternGuards #-}" , "{-# LANGUAGE OverloadedStrings #-}" - , "" + ] + , languageSafe + , [ "" , "module " ++ layName ++ " where" , "" , "import Prelude" diff --git a/source/src/BNFC/Backend/Haskell/CFtoPrinter.hs b/source/src/BNFC/Backend/Haskell/CFtoPrinter.hs index 44be12fa..a953e6d6 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoPrinter.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoPrinter.hs @@ -60,17 +60,15 @@ prologue :: TokenText -> Bool -> String -> [AbsMod] -> CF -> [Doc] prologue tokenText useGadt name absMod cf = map text $ concat [ [ "{-# LANGUAGE CPP #-}" , "{-# LANGUAGE FlexibleInstances #-}" - , "{-# LANGUAGE LambdaCase #-}" ] , [ "{-# LANGUAGE GADTs #-}" | useGadt ] + , [ "{-# LANGUAGE LambdaCase #-}" ] , [ "#if __GLASGOW_HASKELL__ <= 708" , "{-# LANGUAGE OverlappingInstances #-}" , "#endif" ] + , languageSafe , [ "" - -- -- WAS: Needed for precedence category lists, e.g. @[Exp2]@: - -- , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}" - -- , "" , "-- | Pretty-printer for " ++ takeWhile ('.' /=) name ++ "." , "" , "module " ++ name +++ "where" diff --git a/source/src/BNFC/Backend/Haskell/CFtoTemplate.hs b/source/src/BNFC/Backend/Haskell/CFtoTemplate.hs index 73def78e..d1ffde9a 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoTemplate.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoTemplate.hs @@ -13,7 +13,7 @@ import Prelude hiding ((<>)) import BNFC.CF import BNFC.PrettyPrint import BNFC.Utils ( ModuleName ) -import BNFC.Backend.Haskell.Utils ( catvars, noWarnUnusedMatches ) +import BNFC.Backend.Haskell.Utils ( catvars, languageSafe, noWarnUnusedMatches ) cf2Template :: ModuleName -> ModuleName -> Bool -> CF -> String cf2Template skelName absName functor cf = unlines $ concat @@ -21,6 +21,9 @@ cf2Template skelName absName functor cf = unlines $ concat , "" , noWarnUnusedMatches , "" + ] + , languageSafe + , [ "" , "module "++ skelName ++ " where" , "" , "import Prelude (($), Either(..), String, (++), Show, show)" diff --git a/source/src/BNFC/Backend/Haskell/MkErrM.hs b/source/src/BNFC/Backend/Haskell/MkErrM.hs index 6c452577..8d490ebd 100644 --- a/source/src/BNFC/Backend/Haskell/MkErrM.hs +++ b/source/src/BNFC/Backend/Haskell/MkErrM.hs @@ -10,12 +10,14 @@ module BNFC.Backend.Haskell.MkErrM where +import BNFC.Backend.Haskell.Utils (languageSafe) import BNFC.PrettyPrint mkErrM :: String -> Doc -mkErrM errMod = vcat - [ "{-# LANGUAGE CPP #-}" - , "" +mkErrM errMod = vcat $ concat + [ [ "{-# LANGUAGE CPP #-}" ] + , languageSafe + , [ "" , "#if __GLASGOW_HASKELL__ >= 708" , "---------------------------------------------------------------------------" , "-- Pattern synonyms exist since ghc 7.8." @@ -104,3 +106,4 @@ mkErrM errMod = vcat , "" , "#endif" ] + ] diff --git a/source/src/BNFC/Backend/Haskell/Utils.hs b/source/src/BNFC/Backend/Haskell/Utils.hs index 72c36268..f6dd38b5 100644 --- a/source/src/BNFC/Backend/Haskell/Utils.hs +++ b/source/src/BNFC/Backend/Haskell/Utils.hs @@ -5,7 +5,7 @@ module BNFC.Backend.Haskell.Utils ( comment, commentWithEmacsModeHint , posType, posConstr, noPosConstr , hasPositionClass, hasPositionMethod - , noWarnUnusedMatches + , languageSafe, noWarnUnusedMatches , parserName , hsReservedWords, avoidReservedWords, mkDefName , typeToHaskell, typeToHaskell' @@ -43,6 +43,13 @@ noWarnUnusedMatches = -- ALT: only from GHC 8 -- "{-# OPTIONS_GHC -Wno-unused-matches #-}" +languageSafe :: IsString a => [a] +languageSafe = + [ "{-# LANGUAGE Safe #-}" + , "{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}" + , " -- needed with Safe in language GHC2021, GHC 9.2 issue #19605" + ] + -- * Names for position data type. posType, posConstr, noPosConstr :: IsString a => a diff --git a/source/src/BNFC/Backend/HaskellGADT.hs b/source/src/BNFC/Backend/HaskellGADT.hs index 40a65ce2..32c88517 100644 --- a/source/src/BNFC/Backend/HaskellGADT.hs +++ b/source/src/BNFC/Backend/HaskellGADT.hs @@ -12,7 +12,7 @@ module BNFC.Backend.HaskellGADT (makeHaskellGadt) where import BNFC.Options import BNFC.Backend.Base hiding (Backend) import BNFC.Backend.Haskell.HsOpts -import BNFC.Backend.Haskell.Utils (comment, commentWithEmacsModeHint) +import BNFC.Backend.Haskell.Utils (comment, commentWithEmacsModeHint, languageSafe) import BNFC.CF import BNFC.Backend.Haskell.CFtoHappy import BNFC.Backend.Haskell.CFtoAlex3 @@ -61,7 +61,7 @@ makeHaskellGadt opts cf = do mkHsFileHint x = mkfile x commentWithEmacsModeHint composOp :: String -> String -composOp composOpMod = unlines +composOp composOpMod = unlines $ languageSafe ++ [ "{-# LANGUAGE Rank2Types, PolyKinds #-}", "module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,", diff --git a/source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs b/source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs index f0cc2ef9..044927c2 100644 --- a/source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs +++ b/source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs @@ -22,11 +22,15 @@ cf2Abstract :: TokenText -> String -> CF -> String -> String cf2Abstract tokenText name cf composOpMod = unlines $ concat $ [ [ "-- For GHC version 7.10 or higher" , "" - , "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}" + , "{-# LANGUAGE DataKinds #-}" ] , [ "{-# LANGUAGE EmptyCase #-}" | emptyTree ] - , [ "{-# LANGUAGE LambdaCase #-}" - , "" + , [ "{-# LANGUAGE GADTs #-}" + , "{-# LANGUAGE KindSignatures #-}" + , "{-# LANGUAGE LambdaCase #-}" + ] + , languageSafe + , [ "" , "{-# OPTIONS_GHC -fno-warn-unused-binds #-}" -- unused-local-binds would be sufficient, but parses only from GHC 8.0 , "{-# OPTIONS_GHC -fno-warn-unused-imports #-}" diff --git a/source/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs b/source/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs index a86d8e55..63681bfe 100644 --- a/source/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs +++ b/source/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs @@ -12,14 +12,16 @@ import Data.List ( groupBy ) import BNFC.CF import BNFC.Utils ( ModuleName, (+++) ) -import BNFC.Backend.Haskell.Utils ( noWarnUnusedMatches ) +import BNFC.Backend.Haskell.Utils ( languageSafe, noWarnUnusedMatches ) import BNFC.Backend.HaskellGADT.HaskellGADTCommon cf2Template :: ModuleName -> ModuleName -> CF -> String cf2Template skelName absName cf = unlines $ concat - [ [ "{-# LANGUAGE GADTs #-}" - , "{-# LANGUAGE EmptyCase #-}" - , "" + [ [ "{-# LANGUAGE EmptyCase #-}" + , "{-# LANGUAGE GADTs #-}" + ] + , languageSafe + , [ "" , noWarnUnusedMatches , "" , "module "++ skelName ++ " where"