{-# LANGUAGE OverloadedStrings #-}
module BNFC.Backend.Haskell.CFtoTemplate (cf2Template) where
import Prelude hiding ((<>))
import BNFC.CF
import BNFC.PrettyPrint
import BNFC.Utils ( ModuleName )
import BNFC.Backend.Haskell.Utils ( catvars, noWarnUnusedMatches )
cf2Template :: ModuleName -> ModuleName -> Bool -> CF -> String
cf2Template :: String -> String -> Bool -> CF -> String
cf2Template String
skelName String
absName Bool
functor CF
cf = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"-- Templates for pattern matching on abstract syntax"
, String
""
, forall a. IsString a => a
noWarnUnusedMatches
, String
""
, String
"module "forall a. [a] -> [a] -> [a]
++ String
skelName forall a. [a] -> [a] -> [a]
++ String
" where"
, String
""
, String
"import Prelude (($), Either(..), String, (++), Show, show)"
]
, [ String
"import qualified " forall a. [a] -> [a] -> [a]
++ String
absName | Bool
importAbsMod ]
, [ String
""
, String
"type Err = Either String"
, String
"type Result = Err String"
, String
""
, String
"failure :: Show a => a -> Result"
, String
"failure x = Left $ \"Undefined case: \" ++ show x"
, String
""
, Doc -> String
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> Bool -> Cat -> [(String, [Cat])] -> Doc
case_fun String
absName Bool
functor)) [Data]
datas
]
]
where
datas :: [Data]
datas = CF -> [Data]
specialData CF
cf forall a. [a] -> [a] -> [a]
++ CF -> [Data]
cf2data CF
cf
importAbsMod :: Bool
importAbsMod = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Data]
datas
case_fun :: ModuleName -> Bool -> Cat -> [(Fun,[Cat])] -> Doc
case_fun :: String -> Bool -> Cat -> [(String, [Cat])] -> Doc
case_fun String
absName Bool
functor' Cat
cat [(String, [Cat])]
xs = [Doc] -> Doc
vcat
[ Doc
fname Doc -> Doc -> Doc
<+> Doc
"::" Doc -> Doc -> Doc
<+> Doc -> Doc
iffunctor Doc
"Show a =>" Doc -> Doc -> Doc
<+> Doc
type_ Doc -> Doc -> Doc
<+> Doc
"-> Result"
, Doc
fname Doc -> Doc -> Doc
<+> Doc
"x = case x of"
, Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (String, [Cat]) -> Doc
mkOne [(String, [Cat])]
xs)
]
where
iffunctor :: Doc -> Doc
iffunctor Doc
doc | Bool
functor' Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isTokenCat Cat
cat) = Doc
doc
| Bool
otherwise = Doc
empty
type_ :: Doc
type_ = Doc -> Doc
qualify forall a b. (a -> b) -> a -> b
$ Doc
cat' Doc -> Doc -> Doc
<> Doc -> Doc
iffunctor Doc
"' a"
fname :: Doc
fname = Doc
"trans" Doc -> Doc -> Doc
<> Doc
cat'
cat' :: Doc
cat' = forall a. Pretty a => a -> Doc
pretty Cat
cat
mkOne :: (String, [Cat]) -> Doc
mkOne (String
cons, [Cat]
args) =
let ns :: [Doc]
ns = [String] -> [Cat] -> [Doc]
catvars [Doc -> String
render Doc
fname] [Cat]
args
in Doc -> Doc
qualify (String -> Doc
text String
cons) Doc -> Doc -> Doc
<+> Doc -> Doc
iffunctor Doc
"_" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep [Doc]
ns Doc -> Doc -> Doc
<+> Doc
"-> failure x"
qualify :: Doc -> Doc
qualify :: Doc -> Doc
qualify
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
absName = forall a. a -> a
id
| Bool
otherwise = (String -> Doc
text String
absName Doc -> Doc -> Doc
<> Doc
"." Doc -> Doc -> Doc
<>)