{-
    BNF Converter: Template Generator
    Copyright (C) 2004  Author:  Markus Forsberg

-}

{-# 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 )

cf2Template :: ModuleName -> ModuleName -> Bool -> CF -> String
cf2Template :: [Char] -> [Char] -> Bool -> CF -> [Char]
cf2Template [Char]
skelName [Char]
absName Bool
functor CF
cf = [[Char]] -> [Char]
unlines
    [ [Char]
"-- Haskell module generated by the BNF converter"
    , [Char]
""
    , [Char]
"module "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
skelName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" where"
    , [Char]
""
    , [Char]
"import qualified " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
absName
    , [Char]
""
    , [Char]
"type Err = Either String"
    , [Char]
"type Result = Err String"
    , [Char]
""
    , [Char]
"failure :: Show a => a -> Result"
    , [Char]
"failure x = Left $ \"Undefined case: \" ++ show x\n"
    , [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ((Cat, [([Char], [Cat])]) -> [Char])
-> [(Cat, [([Char], [Cat])])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> [Char]
render (Doc -> [Char])
-> ((Cat, [([Char], [Cat])]) -> Doc)
-> (Cat, [([Char], [Cat])])
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(Cat
s,[([Char], [Cat])]
xs) -> [Char] -> Bool -> Cat -> [([Char], [Cat])] -> Doc
case_fun [Char]
absName Bool
functor Cat
s [([Char], [Cat])]
xs) ([(Cat, [([Char], [Cat])])] -> [[Char]])
-> [(Cat, [([Char], [Cat])])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [([Char], [Cat])])]
specialData CF
cf [(Cat, [([Char], [Cat])])]
-> [(Cat, [([Char], [Cat])])] -> [(Cat, [([Char], [Cat])])]
forall a. [a] -> [a] -> [a]
++ CF -> [(Cat, [([Char], [Cat])])]
cf2data CF
cf
    ]

-- |
-- >>> case_fun "M" False (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])]
-- transExpr :: M.Expr -> Result
-- transExpr x = case x of
--   M.EInt integer -> failure x
--   M.EAdd expr1 expr2 -> failure x
--
-- >>> case_fun "" True (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])]
-- transExpr :: Show a => Expr a -> Result
-- transExpr x = case x of
--   EInt _ integer -> failure x
--   EAdd _ expr1 expr2 -> failure x
--
-- TokenCat are not generated as functors:
-- >>> case_fun "" True (TokenCat "MyIdent") [("MyIdent", [TokenCat "String"])]
-- transMyIdent :: MyIdent -> Result
-- transMyIdent x = case x of
--   MyIdent string -> failure x
case_fun :: ModuleName -> Bool -> Cat -> [(Fun,[Cat])] -> Doc
case_fun :: [Char] -> Bool -> Cat -> [([Char], [Cat])] -> Doc
case_fun [Char]
absName Bool
functor' Cat
cat [([Char], [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 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((([Char], [Cat]) -> Doc) -> [([Char], [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Cat]) -> Doc
mkOne [([Char], [Cat])]
xs)
    ]
  where
    -- If the functor option is set AND the category is not a token type,
    -- then the type is a functor.
    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 (Doc -> Doc) -> Doc -> Doc
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' =  [Char] -> Doc
text (Cat -> [Char]
forall a. Show a => a -> [Char]
show Cat
cat)
    mkOne :: ([Char], [Cat]) -> Doc
mkOne ([Char]
cons, [Cat]
args) =
        let ns :: [Doc]
ns = [Cat] -> [Doc]
catvars [Cat]
args -- names False (map (checkRes .var) args) 1
        in  Doc -> Doc
qualify ([Char] -> Doc
text [Char]
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
      | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
absName = Doc -> Doc
forall a. a -> a
id
      | Bool
otherwise    = ([Char] -> Doc
text [Char]
absName Doc -> Doc -> Doc
<> Doc
"." Doc -> Doc -> Doc
<>)