{-
    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, noWarnUnusedMatches )

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] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [[ModuleName]] -> [ModuleName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ ModuleName
"-- Templates for pattern matching on abstract syntax"
    , ModuleName
""
    , ModuleName
forall a. IsString a => a
noWarnUnusedMatches
    , 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 Prelude (($), Either(..), String, (++), Show, show)"
    ]
  , [ ModuleName
"import qualified " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
absName | Bool
importAbsMod ]
  , [ 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"
    , ModuleName
""
    , Doc -> ModuleName
render (Doc -> ModuleName) -> ([Doc] -> Doc) -> [Doc] -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vsep ([Doc] -> ModuleName) -> [Doc] -> ModuleName
forall a b. (a -> b) -> a -> b
$ ((Cat, [(ModuleName, [Cat])]) -> Doc)
-> [(Cat, [(ModuleName, [Cat])])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat -> [(ModuleName, [Cat])] -> Doc)
-> (Cat, [(ModuleName, [Cat])]) -> Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ModuleName -> Bool -> Cat -> [(ModuleName, [Cat])] -> Doc
case_fun ModuleName
absName Bool
functor)) [(Cat, [(ModuleName, [Cat])])]
datas
    ]
  ]
  where
  datas :: [(Cat, [(ModuleName, [Cat])])]
datas        = 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
  importAbsMod :: Bool
importAbsMod = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Cat, [(ModuleName, [Cat])])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cat, [(ModuleName, [Cat])])]
datas


-- |
-- >>> 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' = Cat -> Doc
forall a. Pretty a => a -> Doc
pretty Cat
cat
    mkOne :: (ModuleName, [Cat]) -> Doc
mkOne (ModuleName
cons, [Cat]
args) =
        let ns :: [Doc]
ns = [ModuleName] -> [Cat] -> [Doc]
catvars [Doc -> ModuleName
render Doc
fname] [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
<>)