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

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

  qualify :: [Char] -> [Char]
qualify [Char]
x = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
absName, [Char]
".", [Char]
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