Skip to content

Commit

Permalink
[ Haskell ] Option --text-token to use Data.Text in lexer and token c…
Browse files Browse the repository at this point in the history 
…ontent
  • Loading branch information
@andreasabel
andreasabel committed Sep 19, 2019
1 parent 48ded3b commit f8308a9
Show file tree
Hide file tree
Showing 14 changed files with 525 additions and 400 deletions.
3 changes: 3 additions & 0 deletions source/changelog
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,6 @@
2.8.4 Andreas Abel <andreas.abel@gu.se>
* Haskell: new option --text-token to use Data.Text instead of String in the lexer

2.8.3 Andreas Abel <andreas.abel@gu.se> August 2019
* GHC 8.8 compatibility
* Stack installation supported by provided .yaml files [#198]
Expand Down
189 changes: 104 additions & 85 deletions source/src/BNFC/Backend/Haskell.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,7 @@ import BNFC.Backend.Haskell.HsOpts
import BNFC.Backend.Haskell.MkErrM
import BNFC.Backend.Haskell.MkSharedString
import BNFC.Backend.Haskell.ToCNF as ToCNF
import BNFC.Backend.Haskell.Utils (parserName)
import BNFC.Backend.Haskell.Utils
import BNFC.Backend.Txt2Tag
import BNFC.Backend.XML
import qualified BNFC.Backend.Common.Makefile as Makefile
Expand All @@ -65,28 +65,29 @@ makeHaskell opts cf = do
shareMod = shareFileM opts
do
-- Generate abstract syntax and pretty printer.
mkfile (absFile opts) $ cf2Abstract (byteStrings opts) (ghcExtensions opts) (functor opts) absMod cf
mkfile (printerFile opts) $ cf2Printer (byteStrings opts) (functor opts) False prMod absMod cf
mkfile (absFile opts) $ cf2Abstract (tokenText opts) (ghcExtensions opts) (functor opts) absMod cf
mkfile (printerFile opts) $ cf2Printer (tokenText opts) (functor opts) False prMod absMod cf

-- Generate Alex lexer. Layout is resolved after lexing.
case alexMode opts of
Alex1 -> do
mkfile (alexFile opts) $ cf2alex lexMod errMod cf
liftIO $ printf "Use Alex 1.1 to compile %s.\n" (alexFile opts)
Alex2 -> do
mkfile (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf
mkfile (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (tokenText opts) cf
liftIO $ printf "Use Alex 2.0 to compile %s.\n" (alexFile opts)
Alex3 -> do
mkfile (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf
mkfile (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (tokenText opts) cf
liftIO $ printf "Use Alex 3.0 to compile %s.\n" (alexFile opts)

Ctrl.when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (byteStrings opts) cf
Ctrl.when (hasLayout cf) $ mkfile (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf
Ctrl.when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (tokenText opts) cf
Ctrl.when (hasLayout cf) $ mkfile (layoutFile opts) $
cf2Layout (tokenText opts) (alex1 opts) layMod lexMod cf

-- Generate Happy parser and matching test program unless --cnf.
Ctrl.unless (cnf opts) $ do
mkfile (happyFile opts) $
cf2Happy parMod absMod lexMod errMod (glr opts) (byteStrings opts) (functor opts) cf
cf2Happy parMod absMod lexMod errMod (glr opts) (tokenText opts) (functor opts) cf
-- liftIO $ printf "%s Tested with Happy 1.15\n" (happyFile opts)
mkfile (tFile opts) $ testfile opts cf

Expand Down Expand Up @@ -315,83 +316,101 @@ makefile opts makeFile = vcat
]

testfile :: Options -> CF -> String
testfile opts cf
= let lay = hasLayout cf
use_xml = xml opts > 0
xpr = if use_xml then "XPrint a, " else ""
use_glr = glr opts == GLR
if_glr s = if use_glr then s else ""
firstParser = if use_glr then "the_parser" else render (parserName topType)
topType = firstEntry cf
in unlines
["-- automatically generated by BNF Converter",
"module Main where\n",
"",
"import System.IO ( stdin, hGetContents )",
"import System.Environment ( getArgs, getProgName )",
"import System.Exit ( exitFailure, exitSuccess )",
"import Control.Monad (when)",
"",
"import " ++ alexFileM opts,
"import " ++ happyFileM opts,
"import " ++ templateFileM opts,
"import " ++ printerFileM opts,
"import " ++ absFileM opts,
if lay then "import " ++ layoutFileM opts else "",
if use_xml then "import " ++ xmlFileM opts else "",
if_glr "import qualified Data.Map(Map, lookup, toList)",
if_glr "import Data.Maybe(fromJust)",
"import " ++ errFileM opts,
"",
if use_glr
then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"
else "type ParseFun a = [Token] -> Err a",
"",
"myLLexer = " ++ if lay then "resolveLayout True . myLexer"
else "myLexer",
"",
"type Verbosity = Int",
"",
"putStrV :: Verbosity -> String -> IO ()",
"putStrV v s = when (v > 1) $ putStrLn s",
"",
"runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()",
"runFile v p f = putStrLn f >> readFile f >>= run v p",
"",
"run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()",
if use_glr then runGlr else runStd use_xml,
"",
"showTree :: (Show a, Print a) => Int -> a -> IO ()",
"showTree v tree",
" = do",
" putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree",
" putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree",
"",
"usage :: IO ()",
"usage = do",
" putStrLn $ unlines",
" [ \"usage: Call with one of the following argument combinations:\"",
" , \" --help Display this help message.\"",
" , \" (no arguments) Parse stdin verbosely.\"",
" , \" (files) Parse content of files verbosely.\"",
" , \" -s (files) Silent mode. Parse content of files silently.\"",
" ]",
" exitFailure",
"",
"main :: IO ()",
"main = do",
" args <- getArgs",
" case args of",
" [\"--help\"] -> usage",
" [] -> getContents >>= run 2 " ++ firstParser,
" \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs",
" fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs",
"",
if_glr $ "the_parser :: ParseFun " ++ show topType,
if_glr $ "the_parser = lift_parser " ++ render (parserName topType),
if_glr "",
if_glr liftParser
]
testfile opts cf = unlines $ concat $
[ [ "-- automatically generated by BNF Converter"
, "module Main where"
, ""
]
, case tokenText opts of
StringToken -> []
TextToken ->
[ "import Prelude hiding ( getContents, readFile )"
, "import Data.Text.IO ( getContents, readFile )"
, "import qualified Data.Text"
]
ByteStringToken ->
[ "import Prelude hiding ( getContents, readFile )"
, "import Data.ByteString.Char8 ( getContents, readFile )"
, "import qualified Data.ByteString.Char8 as BS"
]
, [ "import System.Environment ( getArgs, getProgName )"
, "import System.Exit ( exitFailure, exitSuccess )"
, "import Control.Monad (when)"
, ""
, "import " ++ alexFileM opts
, "import " ++ happyFileM opts
, "import " ++ templateFileM opts
, "import " ++ printerFileM opts
, "import " ++ absFileM opts
]
, [ "import " ++ layoutFileM opts | lay ]
, [ "import " ++ xmlFileM opts | use_xml ]
, [ "import qualified Data.Map (Map, lookup, toList)" | use_glr ]
, [ "import Data.Maybe (fromJust)" | use_glr ]
, [ "import " ++ errFileM opts
, ""
, if use_glr
then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"
else "type ParseFun a = [Token] -> Err a"
, ""
, "myLLexer = " ++ if lay then "resolveLayout True . myLexer"
else "myLexer"
, ""
, "type Verbosity = Int"
, ""
, "putStrV :: Verbosity -> String -> IO ()"
, "putStrV v s = when (v > 1) $ putStrLn s"
, ""
, "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()"
, "runFile v p f = putStrLn f >> readFile f >>= run v p"
, ""
, "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> " ++ tokenTextType (tokenText opts) ++ " -> IO ()"
, if use_glr then runGlr else runStd use_xml
, ""
, "showTree :: (Show a, Print a) => Int -> a -> IO ()"
, "showTree v tree"
, " = do"
, " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree"
, " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree"
, ""
, "usage :: IO ()"
, "usage = do"
, " putStrLn $ unlines"
, " [ \"usage: Call with one of the following argument combinations:\""
, " , \" --help Display this help message.\""
, " , \" (no arguments) Parse stdin verbosely.\""
, " , \" (files) Parse content of files verbosely.\""
, " , \" -s (files) Silent mode. Parse content of files silently.\""
, " ]"
, " exitFailure"
, ""
, "main :: IO ()"
, "main = do"
, " args <- getArgs"
, " case args of"
, " [\"--help\"] -> usage"
, " [] -> getContents >>= run 2 " ++ firstParser
, " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs"
, " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs"
, ""
]
, if use_glr then
[ "the_parser :: ParseFun " ++ show topType
, "the_parser = lift_parser " ++ render (parserName topType)
, ""
, liftParser
]
else []
]
where
lay = hasLayout cf
use_xml = xml opts > 0
xpr = if use_xml then "XPrint a, " else ""
use_glr = glr opts == GLR
if_glr s = if use_glr then s else ""
firstParser = if use_glr then "the_parser" else render (parserName topType)
topType = firstEntry cf


runStd xml
= unlines
Expand Down
51 changes: 27 additions & 24 deletions source/src/BNFC/Backend/Haskell/CFtoAbstract.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,21 +24,22 @@ module BNFC.Backend.Haskell.CFtoAbstract (cf2Abstract) where
import Prelude'

import BNFC.CF
import BNFC.Options ( TokenText(..) )
import BNFC.PrettyPrint
import BNFC.Utils ( when )

import BNFC.Backend.Haskell.Utils ( catToType, catvars )
import BNFC.Backend.Haskell.Utils ( catToType, catvars, tokenTextImport, tokenTextType )

-- | Create a Haskell module containing data type definitions for the abstract syntax.

cf2Abstract
:: Bool -- ^ Use ByteString instead of String
-> Bool -- ^ Use GHC specific extensions
-> Bool -- ^ Make the tree a functor
-> String -- ^ module name
-> CF -- ^ Grammar
:: TokenText -- ^ Use @ByteString@ or @Text@ instead of @String@?
-> Bool -- ^ Use GHC specific extensions?
-> Bool -- ^ Make the tree a functor?
-> String -- ^ Module name.
-> CF -- ^ Grammar.
-> Doc
cf2Abstract byteStrings ghcExtensions functor name cf = vsep . concat $
cf2Abstract tokenText ghcExtensions functor name cf = vsep . concat $
[ [ vcat
[ "-- Haskell data types for the abstract syntax."
, "-- Generated by the BNF converter."
Expand All @@ -52,12 +53,12 @@ cf2Abstract byteStrings ghcExtensions functor name cf = vsep . concat $
]
, [ hsep [ "module", text name, "where" ] ]
, [ vcat . concat $
[ [ "import qualified Data.ByteString.Char8 as BS" | byteStrings ]
, [ "import Data.Data (Data, Typeable)" | ghcExtensions ]
, [ "import GHC.Generics (Generic)" | ghcExtensions ]
[ map text $ tokenTextImport tokenText
, [ "import Data.Data (Data, Typeable)" | ghcExtensions ]
, [ "import GHC.Generics (Generic)" | ghcExtensions ]
]
]
, map (\ c -> prSpecialData byteStrings (isPositionCat cf c) derivingClasses c) $ specialCats cf
, map (\ c -> prSpecialData tokenText (isPositionCat cf c) derivingClasses c) $ specialCats cf
, concatMap (prData functor derivingClasses) $ cf2data cf
, [ "" ] -- ensure final newline
]
Expand Down Expand Up @@ -152,38 +153,40 @@ genFunctorInstance (cat, cons) =

-- | Generate a newtype declaration for Ident types
--
-- >>> prSpecialData False False ["Show"] catIdent
-- >>> prSpecialData StringToken False ["Show"] catIdent
-- newtype Ident = Ident String
-- deriving (Show)
--
-- >>> prSpecialData False True ["Show"] catIdent
-- >>> prSpecialData StringToken True ["Show"] catIdent
-- newtype Ident = Ident ((Int,Int),String)
-- deriving (Show)
--
-- >>> prSpecialData True False ["Show"] catIdent
-- >>> prSpecialData TextToken False ["Show"] catIdent
-- newtype Ident = Ident Data.Text.Text
-- deriving (Show)
--
-- >>> prSpecialData ByteStringToken False ["Show"] catIdent
-- newtype Ident = Ident BS.ByteString
-- deriving (Show)
--
-- >>> prSpecialData True True ["Show"] catIdent
-- >>> prSpecialData ByteStringToken True ["Show"] catIdent
-- newtype Ident = Ident ((Int,Int),BS.ByteString)
-- deriving (Show)
--
prSpecialData
:: Bool -- ^ If True, use ByteString instead of String
-> Bool -- ^ If True, store the token position
-> [String] -- ^ Derived classes
-> TokenCat -- ^ Token category name
:: TokenText -- ^ Format of token content.
-> Bool -- ^ If @True@, store the token position.
-> [String] -- ^ Derived classes.
-> TokenCat -- ^ Token category name.
-> Doc
prSpecialData byteStrings position classes cat = vcat
[ hsep [ "newtype", ppcat, "=", ppcat, contentSpec ]
prSpecialData tokenText position classes cat = vcat
[ hsep [ "newtype", text cat, "=", text cat, contentSpec ]
, nest 2 $ deriving_ classes
]
where
ppcat = text cat
contentSpec | position = parens ( "(Int,Int)," <> stringType)
| otherwise = stringType
stringType | byteStrings = "BS.ByteString"
| otherwise = "String"
stringType = text $ tokenTextType tokenText

-- | Generate 'deriving' clause
--
Expand Down
Loading

0 comments on commit f8308a9

Please sign in to comment.