{-
    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 :: [Char] -> [Char] -> Bool -> CF -> [Char]
cf2Template [Char]
skelName [Char]
absName Bool
functor CF
cf = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ [Char]
"-- Templates for pattern matching on abstract syntax"
    , [Char]
""
    , [Char]
forall a. IsString a => a
noWarnUnusedMatches
    , [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 Prelude (($), Either(..), String, (++), Show, show)"
    ]
  , [ [Char]
"import qualified " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
absName | Bool
importAbsMod ]
  , [ [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"
    , [Char]
""
    , Doc -> [Char]
render (Doc -> [Char]) -> ([Doc] -> Doc) -> [Doc] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vsep ([Doc] -> [Char]) -> [Doc] -> [Char]
forall a b. (a -> b) -> a -> b
$ ((Cat, [([Char], [Cat])]) -> Doc)
-> [(Cat, [([Char], [Cat])])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat -> [([Char], [Cat])] -> Doc)
-> (Cat, [([Char], [Cat])]) -> Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([Char] -> Bool -> Cat -> [([Char], [Cat])] -> Doc
case_fun [Char]
absName Bool
functor)) [(Cat, [([Char], [Cat])])]
datas
    ]
  ]
  where
  datas :: [(Cat, [([Char], [Cat])])]
datas        = 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
  importAbsMod :: Bool
importAbsMod = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Cat, [([Char], [Cat])])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cat, [([Char], [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 :: [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' = Cat -> Doc
forall a. Pretty a => a -> Doc
pretty Cat
cat
    mkOne :: ([Char], [Cat]) -> Doc
mkOne ([Char]
cons, [Cat]
args) =
        let ns :: [Doc]
ns = [[Char]] -> [Cat] -> [Doc]
catvars [Doc -> [Char]
render Doc
fname] [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 (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
<>)