{-
    BNF Converter: GADT Template Generator
    Copyright (C) 2004-2005  Author:  Markus Forsberg, Björn Bringert

-}


module BNFC.Backend.HaskellGADT.CFtoTemplateGADT (cf2Template) where

import Data.List  ( groupBy )

import BNFC.CF
import BNFC.Utils ( ModuleName, (+++) )

import BNFC.Backend.Haskell.Utils ( noWarnUnusedMatches )
import BNFC.Backend.HaskellGADT.HaskellGADTCommon

cf2Template :: ModuleName -> ModuleName -> CF -> String
cf2Template :: ModuleName -> ModuleName -> CF -> ModuleName
cf2Template ModuleName
skelName ModuleName
absName 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
"{-# LANGUAGE GADTs #-}"
    , ModuleName
"{-# LANGUAGE EmptyCase #-}"
    , 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(..), Show(..), String, ($), (++))"
    , 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"
    , ModuleName
""
    , ModuleName
"transTree :: " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName -> ModuleName
qualify ModuleName
"Tree" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" c -> Result"
    , ModuleName
"transTree t = case t of"
    ]
  , (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Constructor -> ModuleName
prConsCase (CF -> [Constructor]
cf2cons CF
cf)
  , [ ModuleName
"" ]
  , ((Cat, [Constructor]) -> [ModuleName])
-> [(Cat, [Constructor])] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName
""]) ([ModuleName] -> [ModuleName])
-> ((Cat, [Constructor]) -> [ModuleName])
-> (Cat, [Constructor])
-> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> [Constructor] -> [ModuleName])
-> (Cat, [Constructor]) -> [ModuleName]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Cat -> [Constructor] -> [ModuleName]
prCatTrans) (CF -> [(Cat, [Constructor])]
catCons CF
cf)
  ]
  where
  prCatTrans :: Cat -> [Constructor] -> [String]
  prCatTrans :: Cat -> [Constructor] -> [ModuleName]
prCatTrans Cat
cat [Constructor]
cs = [[ModuleName]] -> [ModuleName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ ModuleName
"trans" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
s ModuleName -> ModuleName -> ModuleName
+++ ModuleName
"::" ModuleName -> ModuleName -> ModuleName
+++ ModuleName -> ModuleName
qualify ModuleName
s ModuleName -> ModuleName -> ModuleName
+++ ModuleName
"-> Result"
      , ModuleName
"trans" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
s ModuleName -> ModuleName -> ModuleName
+++ ModuleName
"t = case t of"
      ]
    , (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Constructor -> ModuleName
prConsCase [Constructor]
cs
    ]
    where
    s :: ModuleName
s = Cat -> ModuleName
catToStr Cat
cat

  prConsCase :: Constructor -> String
  prConsCase :: Constructor -> ModuleName
prConsCase Constructor
c =
    ModuleName
"  " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName -> ModuleName
qualify (Constructor -> ModuleName
consFun Constructor
c) ModuleName -> ModuleName -> ModuleName
+++ [ModuleName] -> ModuleName
unwords (((Cat, ModuleName) -> ModuleName)
-> [(Cat, ModuleName)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, ModuleName) -> ModuleName
forall a b. (a, b) -> b
snd (Constructor -> [(Cat, ModuleName)]
consVars Constructor
c)) ModuleName -> ModuleName -> ModuleName
+++ ModuleName
"-> failure t"

  qualify :: ModuleName -> ModuleName
qualify ModuleName
x = [ModuleName] -> ModuleName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ModuleName
absName, ModuleName
".", ModuleName
x ]

catCons :: CF -> [(Cat,[Constructor])]
catCons :: CF -> [(Cat, [Constructor])]
catCons CF
cf = [ (Constructor -> Cat
consCat ([Constructor] -> Constructor
forall a. [a] -> a
head [Constructor]
cs),[Constructor]
cs) | [Constructor]
cs <- (Constructor -> Constructor -> Bool)
-> [Constructor] -> [[Constructor]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy Constructor -> Constructor -> Bool
catEq ([Constructor] -> [[Constructor]])
-> [Constructor] -> [[Constructor]]
forall a b. (a -> b) -> a -> b
$ CF -> [Constructor]
cf2cons CF
cf]

catEq :: Constructor -> Constructor -> Bool
catEq :: Constructor -> Constructor -> Bool
catEq Constructor
c1 Constructor
c2 = Constructor -> Cat
consCat Constructor
c1 Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Constructor -> Cat
consCat Constructor
c2