Haskell: emit {-# LANGUAGE Safe #-} (and Trustworthy in Lex/Par.hs)

source/CHANGELOG.md

@@ -1,6 +1,7 @@
 # 2.9.5
 
 Unreleased
+* Haskell: label produced code as `Safe` (and parser as `Trustworthy`)
 
 # 2.9.4
 

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"
     , ""

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,19 +51,20 @@ 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 <> "." ]
     , [ hsep [ "module", text name, "where" ] ]
 
     -- 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)
+-- <BLANKLINE>
+-- 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)
+-- <BLANKLINE>
+-- instance Data.String.IsString Ident where
+--   fromString = Ident . Data.String.fromString
 --
 -- >>> prSpecialData ByteStringToken False ["Show"] catIdent
 -- newtype Ident = Ident BS.ByteString
 --   deriving (Show)
+-- <BLANKLINE>
+-- 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
 --

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"
     , ""

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"

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"

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"

source/src/BNFC/Backend/Haskell/CFtoTemplate.hs

@@ -13,14 +13,17 @@ 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
   [ [ "-- Templates for pattern matching on abstract syntax"
     , ""
     , noWarnUnusedMatches
     , ""
+    ]
+  , languageSafe
+  , [ ""
     , "module "++ skelName ++ " where"
     , ""
     , "import Prelude (($), Either(..), String, (++), Show, show)"

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"
     ]
+  ]

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

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,",

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 #-}"

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"