Skip to content

Commit

Permalink
[ #278 ] fixed for Haskell: use qualified imports
Browse files Browse the repository at this point in the history 
Abs      : import Prelude qualified
Par/Skel : import Abs qualified

The printer already used qualified import.
  • Loading branch information
@andreasabel
andreasabel committed Dec 16, 2019
1 parent a102973 commit b7c83c5
Show file tree
Hide file tree
Showing 7 changed files with 166 additions and 106 deletions.
30 changes: 17 additions & 13 deletions source/src/BNFC/Backend/Haskell.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ import qualified BNFC.Backend.Common.Makefile as Makefile

import BNFC.CF
import BNFC.Options hiding (Backend)
import BNFC.Utils (when, unless, getZonedTimeTruncatedToSeconds)
import BNFC.Utils (when, unless, table, getZonedTimeTruncatedToSeconds)


-- | Entrypoint for the Haskell backend.
Expand Down Expand Up @@ -317,7 +317,8 @@ makefile opts makeFile = vcat

testfile :: Options -> CF -> String
testfile opts cf = unlines $ concat $
[ [ "-- automatically generated by BNF Converter"
[ [ "-- Program to test parser, automatically generated by BNF Converter."
, ""
, "module Main where"
, ""
]
Expand All @@ -334,19 +335,22 @@ testfile opts cf = unlines $ concat $
, "import qualified Data.ByteString.Char8 as BS"
]
, [ "import System.Environment ( getArgs, getProgName )"
, "import System.Exit ( exitFailure, exitSuccess )"
, "import Control.Monad (when)"
, "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 ]
, table "" $ concat
[ [ [ "import " , alexFileM opts , " ( Token )" ]
, [ "import " , happyFileM opts , " ( " ++ firstParser ++ ", myLexer )" ]
, [ "import " , templateFileM opts , " ()" ]
, [ "import " , printerFileM opts , " ( Print, printTree )" ]
, [ "import " , absFileM opts , " ()" ]
]
, [ [ "import " , layoutFileM opts , " ( resolveLayout )" ] | lay ]
, [ [ "import " , xmlFileM opts , " ( printXML )" ] | use_xml ]
]
, [ "import qualified Data.Map ( Map, lookup, toList )" | use_glr ]
, [ "import Data.Maybe ( fromJust )" | use_glr ]
, [ ""
, "type Err = Either String"
, if use_glr
Expand Down
53 changes: 35 additions & 18 deletions source/src/BNFC/Backend/Haskell/CFtoAbstract.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,30 +52,46 @@ cf2Abstract tokenText generic functor name cf = vsep . concat $
| generic
]
, [ hsep [ "module", text name, "where" ] ]
, [ vcat
[ text $ "import Prelude (Char, Double, Integer, String" ++ functorImportsUnqual ++ ")"
, text $ "import qualified Prelude as C (Eq, Ord, Show, Read" ++ functorImportsQual ++ ")"
]
]
, [ vcat . concat $
[ map text $ tokenTextImport tokenText
, [ "import Data.Data (Data, Typeable)" | generic ]
, [ "import GHC.Generics (Generic)" | generic ]
, [ "import qualified Data.Data as C (Data, Typeable)" | generic ]
, [ "import qualified GHC.Generics as C (Generic)" | generic ]
]
]
, map (\ c -> prSpecialData tokenText (isPositionCat cf c) derivingClasses c) $ specialCats cf
, concatMap (prData functor derivingClasses) $ cf2data cf
, concatMap (prData functorName derivingClasses) $ cf2data cf
, [ "" ] -- ensure final newline
]
where
derivingClasses = concat
derivingClasses = map ("C." ++) $ concat
[ [ "Eq", "Ord", "Show", "Read" ]
, when generic ["Data","Typeable","Generic"]
]
functorImportsUnqual
| functor = ", map, fmap"
| otherwise = ""
functorImportsQual
| functor = ", Functor"
| otherwise = ""
functorName
| functor = "C.Functor"
| otherwise = ""

type FunctorName = String

-- |
--
-- >>> vsep $ prData False ["Eq", "Ord", "Show", "Read"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [Cat "Ident"])])
-- >>> vsep $ prData "" ["Eq", "Ord", "Show", "Read"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [Cat "Ident"])])
-- data C = C1 C | CIdent Ident
-- deriving (Eq, Ord, Show, Read)
--
-- Note that the layout adapts if it does not fit in one line:
-- >>> vsep $ prData False ["Show"] (Cat "C", [("CAbracadabra",[]),("CEbrecedebre",[]),("CIbricidibri",[]),("CObrocodobro",[]),("CUbrucudubru",[])])
-- >>> vsep $ prData "" ["Show"] (Cat "C", [("CAbracadabra",[]),("CEbrecedebre",[]),("CIbricidibri",[]),("CObrocodobro",[]),("CUbrucudubru",[])])
-- data C
-- = CAbracadabra
-- | CEbrecedebre
Expand All @@ -84,8 +100,8 @@ cf2Abstract tokenText generic functor name cf = vsep . concat $
-- | CUbrucudubru
-- deriving (Show)
--
-- If the first argument is True, generate a functor:
-- >>> vsep $ prData True ["Show"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- If the first argument is not null, generate a functor:
-- >>> vsep $ prData "Functor" ["Show"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- data C a = C1 a (C a) | CIdent a Ident
-- deriving (Show)
-- <BLANKLINE>
Expand All @@ -95,45 +111,46 @@ cf2Abstract tokenText generic functor name cf = vsep . concat $
-- CIdent a ident -> CIdent (f a) ident
--
-- The case for lists:
-- >>> vsep $ prData True ["Show"] (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])])
-- >>> vsep $ prData "Functor" ["Show"] (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])])
-- data ExpList a = Exps a [Exp a]
-- deriving (Show)
-- <BLANKLINE>
-- instance Functor ExpList where
-- fmap f x = case x of
-- Exps a exps -> Exps (f a) (map (fmap f) exps)
--
prData :: Bool -> [String] -> Data -> [Doc]
prData functor derivingClasses (cat,rules) = concat
prData :: FunctorName -> [String] -> Data -> [Doc]
prData functorName derivingClasses (cat,rules) = concat
[ [ hang ("data" <+> dataType) 4 (constructors rules)
$+$ nest 2 (deriving_ derivingClasses)
]
, [ genFunctorInstance (cat, rules) | functor ]
, [ genFunctorInstance functorName (cat, rules) | functor ]
]
where
functor = not $ null functorName
prRule (fun, cats) = hsep $ concat [ [text fun], ["a" | functor], map prArg cats ]
dataType = hsep $ concat [ [text (show cat)], ["a" | functor] ]
prArg = catToType $ if functor then Just "a" else Nothing
prArg = catToType id $ if functor then "a" else empty
constructors [] = empty
constructors (h:t) = sep $ ["=" <+> prRule h] ++ map (("|" <+>) . prRule) t

-- | Generate a functor instance declaration:
--
-- >>> genFunctorInstance (Cat "C", [("C1", [Cat "C", Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- >>> genFunctorInstance "Functor" (Cat "C", [("C1", [Cat "C", Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- instance Functor C where
-- fmap f x = case x of
-- C1 a c1 c2 -> C1 (f a) (fmap f c1) (fmap f c2)
-- CIdent a ident -> CIdent (f a) ident
--
-- >>> genFunctorInstance (Cat "SomeLists", [("Ints", [ListCat (TokenCat "Integer")]), ("Exps", [ListCat (Cat "Exp")])])
-- >>> genFunctorInstance "Functor" (Cat "SomeLists", [("Ints", [ListCat (TokenCat "Integer")]), ("Exps", [ListCat (Cat "Exp")])])
-- instance Functor SomeLists where
-- fmap f x = case x of
-- Ints a integers -> Ints (f a) integers
-- Exps a exps -> Exps (f a) (map (fmap f) exps)
--
genFunctorInstance :: Data -> Doc
genFunctorInstance (cat, cons) =
"instance Functor" <+> text (show cat) <+> "where"
genFunctorInstance :: FunctorName -> Data -> Doc
genFunctorInstance functorName (cat, cons) =
"instance" <+> text functorName <+> text (show cat) <+> "where"
$+$ nest 4 ("fmap f x = case x of" $+$ nest 4 (vcat (map mkCase cons)))
where
mkCase (f, args) = hsep . concat $
Expand Down
74 changes: 41 additions & 33 deletions source/src/BNFC/Backend/Haskell/CFtoHappy.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,8 @@

module BNFC.Backend.Haskell.CFtoHappy (cf2Happy, convert) where

import Prelude hiding ((<>))

import Data.Char
import Data.List (intersperse)

Expand All @@ -43,9 +45,9 @@ tokenName = "Token"
-- | Generate a happy parser file from a grammar.

cf2Happy
:: String -- ^ This module's name.
-> String -- ^ Abstract syntax module name.
-> String -- ^ Lexer module name.
:: ModuleName -- ^ This module's name.
-> ModuleName -- ^ Abstract syntax module name.
-> ModuleName -- ^ Lexer module name.
-> HappyMode -- ^ Happy mode.
-> TokenText -- ^ Use @ByteString@ or @Text@?
-> Bool -- ^ AST is a functor?
Expand All @@ -56,19 +58,19 @@ cf2Happy name absName lexName mode tokenText functor cf = unlines
, render $ declarations mode (allEntryPoints cf)
, render $ tokens cf
, delimiter
, specialRules tokenText cf
, render $ prRules functor (rulesForHappy absName functor cf)
, specialRules absName tokenText cf
, render $ prRules absName functor (rulesForHappy absName functor cf)
, finalize cf
]

-- | Construct the header.
header :: String -> String -> String -> TokenText -> String
header :: ModuleName -> ModuleName -> ModuleName -> TokenText -> String
header modName absName lexName tokenText = unlines $ concat
[ [ "-- This Happy file was machine-generated by the BNF converter"
, "{"
, "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}"
, "module " ++ modName ++ " where"
, "import " ++ absName
, "import qualified " ++ absName
, "import " ++ lexName
]
, tokenTextImport tokenText
Expand Down Expand Up @@ -116,7 +118,7 @@ tokens cf
convert :: String -> Doc
convert = quotes . text . escapeChars

rulesForHappy :: String -> Bool -> CF -> Rules
rulesForHappy :: ModuleName -> Bool -> CF -> Rules
rulesForHappy absM functor cf = for (ruleGroups cf) $ \ (cat, rules) ->
(cat, map (constructRule absM functor) rules)

Expand Down Expand Up @@ -175,45 +177,48 @@ generatePatterns its =
-- so the only thing left is to merge them into one string.

-- |
-- >>> prRules False [(Cat "Expr", [("Integer", "EInt $1"), ("Expr '+' Expr", "EPlus $1 $3")])]
-- Expr :: { Expr }
-- Expr : Integer { EInt $1 } | Expr '+' Expr { EPlus $1 $3 }
-- >>> prRules "Foo" False [(Cat "Expr", [("Integer", "Foo.EInt $1"), ("Expr '+' Expr", "Foo.EPlus $1 $3")])]
-- Expr :: { Foo.Expr }
-- Expr : Integer { Foo.EInt $1 } | Expr '+' Expr { Foo.EPlus $1 $3 }
--
-- if there's a lot of cases, print on several lines:
-- >>> prRules False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5")])]
-- >>> prRules "" False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5")])]
-- Expr :: { Expr }
-- Expr : Abcd { Action }
-- | P2 { A2 }
-- | P3 { A3 }
-- | P4 { A4 }
-- | P5 { A5 }
--
-- >>> prRules False [(Cat "Internal", [])] -- nt has only internal use
-- >>> prRules "" False [(Cat "Internal", [])] -- nt has only internal use
-- <BLANKLINE>
--
-- The functor case:
-- >>> prRules True [(Cat "Expr", [("Integer", "EInt () $1"), ("Expr '+' Expr", "EPlus () $1 $3")])]
-- >>> prRules "" True [(Cat "Expr", [("Integer", "EInt () $1"), ("Expr '+' Expr", "EPlus () $1 $3")])]
-- Expr :: { (Expr ()) }
-- Expr : Integer { EInt () $1 } | Expr '+' Expr { EPlus () $1 $3 }
--
-- A list with coercion: in the type signature we need to get rid of the
-- coercion.
--
-- >>> prRules True [(ListCat (CoercCat "Exp" 2), [("Exp2", "(:[]) $1"), ("Exp2 ',' ListExp2","(:) $1 $3")])]
-- >>> prRules "" True [(ListCat (CoercCat "Exp" 2), [("Exp2", "(:[]) $1"), ("Exp2 ',' ListExp2","(:) $1 $3")])]
-- ListExp2 :: { [Exp ()] }
-- ListExp2 : Exp2 { (:[]) $1 } | Exp2 ',' ListExp2 { (:) $1 $3 }
--
prRules :: Bool -> Rules -> Doc
prRules functor = vcat . map prOne
prRules :: ModuleName -> Bool -> Rules -> Doc
prRules absM functor = vcat . map prOne
where
type' = catToType (if functor then Just "()" else Nothing)
prOne (_,[]) = empty -- nt has only internal use
prOne (nt,(p,a):ls) =
hsep [ nt', "::", "{", type' nt, "}" ]
$$ nt' <+> sep (pr ":" (p, a) : map (pr "|") ls)
where
nt' = text (identCat nt)
pr pre (p,a) = hsep [pre, text p, "{", text a , "}"]
prOne (_ , [] ) = empty -- nt has only internal use
prOne (nt, (p,a):ls) =
hsep [ nt', "::", "{", type' nt, "}" ]
$$ nt' <+> sep (pr ":" (p, a) : map (pr "|") ls)
where
nt' = text (identCat nt)
pr pre (p,a) = hsep [pre, text p, "{", text a , "}"]
type' = catToType qualify $ if functor then "()" else empty
qualify
| null absM = id
| otherwise = ((text absM <> ".") <>)

-- Finally, some haskell code.

Expand Down Expand Up @@ -255,18 +260,18 @@ definedRules cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]
-- | GF literals.
specialToks :: CF -> [String]
specialToks cf = (`map` literals cf) $ \case
"Ident" -> "L_ident { PT _ (TV $$) }"
"Ident" -> "L_Ident { PT _ (TV $$) }"
"String" -> "L_quoted { PT _ (TL $$) }"
"Integer" -> "L_integ { PT _ (TI $$) }"
"Double" -> "L_doubl { PT _ (TD $$) }"
"Char" -> "L_charac { PT _ (TC $$) }"
own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }"
where posn = if isPositionCat cf own then "_" else "$$"

specialRules :: TokenText -> CF -> String
specialRules tokenText cf = unlines . intersperse "" . (`map` literals cf) $ \case
"Ident" -> "Ident :: { Ident }"
++++ "Ident : L_ident { Ident $1 }"
specialRules :: ModuleName -> TokenText -> CF -> String
specialRules absName tokenText cf = unlines . intersperse "" . (`map` literals cf) $ \case
-- "Ident" -> "Ident :: { Ident }"
-- ++++ "Ident : L_ident { Ident $1 }"
"String" -> "String :: { String }"
++++ "String : L_quoted { " ++ stringUnpack "$1" ++ " }"
"Integer" -> "Integer :: { Integer }"
Expand All @@ -275,8 +280,11 @@ specialRules tokenText cf = unlines . intersperse "" . (`map` literals cf) $ \ca
++++ "Double : L_doubl { (read (" ++ stringUnpack "$1" ++ ")) :: Double }"
"Char" -> "Char :: { Char }"
++++ "Char : L_charac { (read (" ++ stringUnpack "$1" ++ ")) :: Char }"
own -> own ++ " :: { " ++ own ++ "}"
++++ own ++ " : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}"
where posn = if isPositionCat cf own then "mkPosToken " else ""
own -> own ++ " :: { " ++ qualify own ++ "}"
++++ own ++ " : L_" ++ own ++ " { " ++ qualify own ++ posn ++ " }"
where posn = if isPositionCat cf own then " (mkPosToken $1)" else " $1"
where
stringUnpack = tokenTextUnpack tokenText
qualify
| null absName = id
| otherwise = ((absName ++ ".") ++)
Loading

0 comments on commit b7c83c5

Please sign in to comment.