{-
    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 :: ModuleName -> ModuleName -> Bool -> CF -> ModuleName
cf2Template ModuleName
skelName ModuleName
absName Bool
functor CF
cf = [ModuleName] -> ModuleName
unlines
    [ ModuleName
"-- Haskell module generated by the BNF converter"
    , ModuleName
""
    , ModuleName
"module "ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
skelName ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" where"
    , ModuleName
""
    , ModuleName
"import qualified " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
absName
    , ModuleName
""
    , ModuleName
"type Err = Either String"
    , ModuleName
"type Result = Err String"
    , ModuleName
""
    , ModuleName
"failure :: Show a => a -> Result"
    , ModuleName
"failure x = Left $ \"Undefined case: \" ++ show x\n"
    , [ModuleName] -> ModuleName
unlines ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ ((Cat, [(ModuleName, [Cat])]) -> ModuleName)
-> [(Cat, [(ModuleName, [Cat])])] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> ModuleName
render (Doc -> ModuleName)
-> ((Cat, [(ModuleName, [Cat])]) -> Doc)
-> (Cat, [(ModuleName, [Cat])])
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(Cat
s,[(ModuleName, [Cat])]
xs) -> ModuleName -> Bool -> Cat -> [(ModuleName, [Cat])] -> Doc
case_fun ModuleName
absName Bool
functor Cat
s [(ModuleName, [Cat])]
xs) ([(Cat, [(ModuleName, [Cat])])] -> [ModuleName])
-> [(Cat, [(ModuleName, [Cat])])] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [(ModuleName, [Cat])])]
specialData CF
cf [(Cat, [(ModuleName, [Cat])])]
-> [(Cat, [(ModuleName, [Cat])])] -> [(Cat, [(ModuleName, [Cat])])]
forall a. [a] -> [a] -> [a]
++ CF -> [(Cat, [(ModuleName, [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 :: ModuleName -> Bool -> Cat -> [(ModuleName, [Cat])] -> Doc
case_fun ModuleName
absName Bool
functor' Cat
cat [(ModuleName, [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 (((ModuleName, [Cat]) -> Doc) -> [(ModuleName, [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, [Cat]) -> Doc
mkOne [(ModuleName, [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' =  ModuleName -> Doc
text (Cat -> ModuleName
forall a. Show a => a -> ModuleName
show Cat
cat)
    mkOne :: (ModuleName, [Cat]) -> Doc
mkOne (ModuleName
cons, [Cat]
args) =
        let ns :: [Doc]
ns = [Cat] -> [Doc]
catvars [Cat]
args -- names False (map (checkRes .var) args) 1
        in  Doc -> Doc
qualify (ModuleName -> Doc
text ModuleName
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
      | ModuleName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ModuleName
absName = Doc -> Doc
forall a. a -> a
id
      | Bool
otherwise    = (ModuleName -> Doc
text ModuleName
absName Doc -> Doc -> Doc
<> Doc
"." Doc -> Doc -> Doc
<>)