{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE PatternGuards     #-}
{-# LANGUAGE OverloadedStrings #-}

{-
    BNF Converter: C Abstract syntax
    Copyright (C) 2004  Author:  Michael Pellauer

    Description   : This module generates the C Abstract Syntax
                    tree classes. It generates both a Header file
                    and an Implementation file, and Appel's C
                    method.

    Author        : Michael Pellauer
    Created       : 15 September, 2003
-}

module BNFC.Backend.C.CFtoCAbs (cf2CAbs) where

import Prelude hiding ((<>))
import Data.Char     (toLower)
import Data.Function (on)
import Data.List     (groupBy, intercalate, nub, sort)

import BNFC.CF
import BNFC.PrettyPrint
import BNFC.Options (RecordPositions(..))
import BNFC.Utils   ((+++), uncurry3, unless)
import BNFC.Backend.Common.NamedVariables


-- | The result is two files (.H file, .C file)
cf2CAbs
  :: RecordPositions
  -> String -- ^ Ignored.
  -> CF     -- ^ Grammar.
  -> (String, String) -- ^ @.H@ file, @.C@ file.
cf2CAbs :: RecordPositions -> [Char] -> CF -> ([Char], [Char])
cf2CAbs RecordPositions
rp [Char]
_ CF
cf = (RecordPositions -> CF -> [Char]
mkHFile RecordPositions
rp CF
cf, CF -> [Char]
mkCFile CF
cf)

{- **** Header (.H) File Functions **** -}

-- | Makes the Header file.

mkHFile :: RecordPositions -> CF -> String
mkHFile :: RecordPositions -> CF -> [Char]
mkHFile RecordPositions
rp 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]
"#ifndef ABSYN_HEADER"
    , [Char]
"#define ABSYN_HEADER"
    , [Char]
""
    , [Char]
"/* C++ Abstract Syntax Interface generated by the BNF Converter.*/"
    , [Char]
""
    , [[Char]] -> [Char]
prTypeDefs [[Char]]
user
    , [Char]
"/********************   Forward Declarations    ***********************/"
    ]
  , ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
prForward [[Char]]
classes
  , [ [Char]
"/********************   Abstract Syntax Classes    ********************/"
    , [Char]
""
    ]
  , (Data -> [Char]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (RecordPositions -> Data -> [Char]
prDataH RecordPositions
rp) ([Data] -> [[Char]]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [Data]
getAbstractSyntax CF
cf
  , Bool -> [[Char]] -> [[Char]]
forall m. Monoid m => Bool -> m -> m
unless ([([Char], [[Char]], Exp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], [[Char]], Exp)]
definedConstructors)
    [ [Char]
"/********************   Defined Constructors    ***********************/"
    , [Char]
""
    ]
  , (([Char], [[Char]], Exp) -> [Char])
-> [([Char], [[Char]], Exp)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [[Char]] -> Exp -> [Char])
-> ([Char], [[Char]], Exp) -> [Char]
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 ([[Char]] -> [Char] -> [[Char]] -> Exp -> [Char]
prDefH [[Char]]
user)) [([Char], [[Char]], Exp)]
definedConstructors
  , [ [Char]
""
    , [Char]
"#endif"
    ]
  ]
  where
  user  :: [TokenCat]
  user :: [[Char]]
user   = CF -> [[Char]]
forall f. CFG f -> [[Char]]
tokenNames CF
cf
  rules :: [String]
  rules :: [[Char]]
rules = CF -> [[Char]]
forall {a}. IsFun a => CFG a -> [[Char]]
getRules CF
cf
  classes :: [[Char]]
classes = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]]
rules [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Cat] -> [[Char]]
getClasses (CF -> [Cat]
allCatsNorm CF
cf))
  prForward :: [Char] -> [Char]
prForward [Char]
s | Bool -> Bool
not ([Char] -> Bool
forall a. IsFun a => a -> Bool
isCoercion [Char]
s) = [[Char]] -> [Char]
unlines
    [ [Char]
"struct " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_;"
    , [Char]
"typedef struct " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_ *" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
    ]
  prForward [Char]
_ = [Char]
""
  getRules :: CFG a -> [[Char]]
getRules CFG a
cf = (Rul a -> [Char]) -> [Rul a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Rul a -> [Char]
forall {a}. IsFun a => Rul a -> [Char]
testRule (CFG a -> [Rul a]
forall function. CFG function -> [Rul function]
cfgRules CFG a
cf)
  getClasses :: [Cat] -> [[Char]]
getClasses = (Cat -> [Char]) -> [Cat] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> [Char]
forall a. Show a => a -> [Char]
show ([Cat] -> [[Char]]) -> ([Cat] -> [Cat]) -> [Cat] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> Bool) -> [Cat] -> [Cat]
forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
isDataCat
  testRule :: Rul a -> [Char]
testRule (Rule a
f (WithPosition Position
_ Cat
c) SentForm
_ InternalRule
_)
    | Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& a -> Bool
forall a. IsFun a => a -> Bool
isConsFun a
f = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
c)
    | Bool
otherwise = [Char]
"_"
  definedConstructors :: [([Char], [[Char]], Exp)]
definedConstructors = [ (RFun -> [Char]
forall a. IsFun a => a -> [Char]
funName RFun
f, [[Char]]
xs, Exp
e) | FunDef RFun
f [[Char]]
xs Exp
e <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]

-- | For @define@d constructors, make a CPP definition.
--
-- >>> prDefH [] "iSg" ["i"] (App "ICons" [Var "i", App "INil" []])
-- "#define make_iSg(i) make_ICons(i,make_INil())"
--
-- >>> prDefH [] "snoc" ["xs","x"] (App "Cons" [Var "x", Var "xs"])
-- "#define make_snoc(xs,x) make_Cons(x,xs)"
--
prDefH
  :: [TokenCat] -- ^ Names of the token constructors (silent in C backend).
  -> String     -- ^ Name of the defined constructor.
  -> [String]   -- ^ Names of the arguments.
  -> Exp        -- ^ Definition (referring to arguments and rule labels).
  -> String
prDefH :: [[Char]] -> [Char] -> [[Char]] -> Exp -> [Char]
prDefH [[Char]]
tokenCats [Char]
f [[Char]]
xs Exp
e = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
"#define make_", [Char]
f, [Char]
"(", [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]]
xs, [Char]
") ", Exp -> [Char]
prExp Exp
e ]
  where
  prExp :: Exp -> String
  prExp :: Exp -> [Char]
prExp = \case
    Var [Char]
x       -> [Char]
x
    -- Andreas, 2021-02-13, issue #338
    -- Token categories are just @typedef@s in C, so no constructor needed.
    App [Char]
g [Exp
e] | [Char]
g [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
tokenCats
                -> Exp -> [Char]
prExp Exp
e
    App [Char]
g [Exp]
es    -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
"make_", [Char]
g, [Char]
"(", [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ((Exp -> [Char]) -> [Exp] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> [Char]
prExp [Exp]
es), [Char]
")" ]
    LitInt    Integer
i -> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i
    LitDouble Double
d -> Double -> [Char]
forall a. Show a => a -> [Char]
show Double
d
    LitChar   Char
c -> Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c
    LitString [Char]
s -> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s

-- | Prints struct definitions for all categories.
prDataH :: RecordPositions -> Data -> String
prDataH :: RecordPositions -> Data -> [Char]
prDataH RecordPositions
rp (Cat
cat, [([Char], [Cat])]
rules)
  | Cat -> Bool
isList Cat
cat = [[Char]] -> [Char]
unlines
      [ [Char]
"struct " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
      , [Char]
"{"
      , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mem [Char] -> [Char] -> [Char]
+++ [Char] -> [Char]
varName [Char]
mem [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
      , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
+++ [Char] -> [Char]
varName [Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
      , [Char]
"};"
      , [Char]
""
      , [Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" make_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mem [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p1, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p2);"
      ]
  | Bool
otherwise = [[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]
"struct " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
forall a. Show a => a -> [Char]
show Cat
cat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
      , [Char]
"{"
      ]
    , [ [Char]
"  int line_number, char_number;" | RecordPositions
rp RecordPositions -> RecordPositions -> Bool
forall a. Eq a => a -> a -> Bool
== RecordPositions
RecordPositions ]
    , [ [Char]
"  enum { " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((([Char], [Cat]) -> [Char]) -> [([Char], [Cat])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Cat]) -> [Char]
forall {b}. ([Char], b) -> [Char]
prKind [([Char], [Cat])]
rules) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" } kind;"
      , [Char]
"  union"
      , [Char]
"  {"
      , (([Char], [Cat]) -> [Char]) -> [([Char], [Cat])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char], [Cat]) -> [Char]
prUnion [([Char], [Cat])]
rules [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  } u;"
      , [Char]
"};"
      , [Char]
""
      ]
    , (([Char], [Cat]) -> [[Char]]) -> [([Char], [Cat])] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat -> ([Char], [Cat]) -> [[Char]]
prRuleH Cat
cat) [([Char], [Cat])]
rules
    ]
  where
    c' :: [Char]
c' = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat)
    mem :: [Char]
mem = Cat -> [Char]
identCat (Cat -> Cat
normCatOfList Cat
cat)
    prKind :: ([Char], b) -> [Char]
prKind ([Char]
fun, b
_) = [Char]
"is_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fun
    prUnion :: ([Char], [Cat]) -> [Char]
prUnion ([Char]
_, []) = [Char]
""
    prUnion ([Char]
fun, [Cat]
cats) = [Char]
"    struct { " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ [([Char], Int)] -> Doc
prInstVars ([Cat] -> [([Char], Int)]
getVars [Cat]
cats)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" } " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]
memName [Char]
fun) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";\n"


-- | Interface definitions for rules vary on the type of rule.
prRuleH :: Cat -> (Fun, [Cat]) -> [String]
prRuleH :: Cat -> ([Char], [Cat]) -> [[Char]]
prRuleH Cat
c ([Char]
fun, [Cat]
cats)
  | [Char] -> Bool
forall a. IsFun a => a -> Bool
isNilFun [Char]
fun Bool -> Bool -> Bool
|| [Char] -> Bool
forall a. IsFun a => a -> Bool
isOneFun [Char]
fun Bool -> Bool -> Bool
|| [Char] -> Bool
forall a. IsFun a => a -> Bool
isConsFun [Char]
fun = [] -- these are not represented in the AbSyn
  | Bool
otherwise = [Char] -> [[Char]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ Cat -> [Char]
catToStr Cat
c, [Char]
" make_", [Char]
fun, [Char]
"(", [([Char], Int)] -> [Char]
forall a. [([Char], a)] -> [Char]
prParamsH ([Cat] -> [([Char], Int)]
getVars [Cat]
cats), [Char]
");" ]
  where
    prParamsH :: [(String, a)] -> String
    prParamsH :: forall a. [([Char], a)] -> [Char]
prParamsH [] = [Char]
"void"
    prParamsH [([Char], a)]
ps = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (([Char], a) -> Integer -> [Char])
-> [([Char], a)] -> [Integer] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([Char], a) -> Integer -> [Char]
forall {a} {b}. Show a => ([Char], b) -> a -> [Char]
par [([Char], a)]
ps [Integer
0..]
      where par :: ([Char], b) -> a -> [Char]
par ([Char]
t, b
_) a
n = [Char]
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
n

-- typedefs in the Header make generation much nicer.
prTypeDefs :: [[Char]] -> [Char]
prTypeDefs [[Char]]
user = [[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]
"/********************   TypeDef Section    ********************/"
    , [Char]
""
    , [Char]
"typedef int Integer;"
    , [Char]
"typedef char Char;"
    , [Char]
"typedef double Double;"
    , [Char]
"typedef char* String;"
    , [Char]
"typedef char* Ident;"
    ]
  , ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
prUserDef [[Char]]
user
  ]
  where
    prUserDef :: [Char] -> [Char]
prUserDef [Char]
s = [Char]
"typedef char* " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"

-- | A class's instance variables. Print the variables declaration by grouping
-- together the variables of the same type.
-- >>> prInstVars [("A", 1)]
-- A a_1;
-- >>> prInstVars [("A",1),("A",2),("B",1)]
-- A a_1, a_2; B b_1;
prInstVars :: [IVar] -> Doc
prInstVars :: [([Char], Int)] -> Doc
prInstVars =
    [Doc] -> Doc
hsep ([Doc] -> Doc)
-> ([([Char], Int)] -> [Doc]) -> [([Char], Int)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([Char], Int)] -> Doc) -> [[([Char], Int)]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [([Char], Int)] -> Doc
forall {a}. (Eq a, Num a, Show a) => [([Char], a)] -> Doc
prInstVarsOneType ([[([Char], Int)]] -> [Doc])
-> ([([Char], Int)] -> [[([Char], Int)]])
-> [([Char], Int)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], Int) -> ([Char], Int) -> Bool)
-> [([Char], Int)] -> [[([Char], Int)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Char] -> [Char] -> Bool)
-> (([Char], Int) -> [Char])
-> ([Char], Int)
-> ([Char], Int)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Char], Int) -> [Char]
forall a b. (a, b) -> a
fst) ([([Char], Int)] -> [[([Char], Int)]])
-> ([([Char], Int)] -> [([Char], Int)])
-> [([Char], Int)]
-> [[([Char], Int)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Char], Int)] -> [([Char], Int)]
forall a. Ord a => [a] -> [a]
sort
  where
    prInstVarsOneType :: [([Char], a)] -> Doc
prInstVarsOneType [([Char], a)]
ivars = [Char] -> Doc
text (([Char], a) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], a)] -> ([Char], a)
forall a. [a] -> a
head [([Char], a)]
ivars))
                              Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((([Char], a) -> Doc) -> [([Char], a)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], a) -> Doc
forall {a}. (Eq a, Num a, Show a) => ([Char], a) -> Doc
prIVar [([Char], a)]
ivars))
                              Doc -> Doc -> Doc
<> Doc
semi
    prIVar :: ([Char], a) -> Doc
prIVar ([Char]
s, a
i) = [Char] -> Doc
text ([Char] -> [Char]
varName [Char]
s) Doc -> Doc -> Doc
<> [Char] -> Doc
text (a -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
showNum a
i)

{- **** Implementation (.C) File Functions **** -}

-- | Makes the .C file
mkCFile :: CF -> String
mkCFile :: CF -> [Char]
mkCFile CF
cf = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [Char]
header
  , Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Data -> [Doc]) -> [Data] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Data -> [Doc]
prDataC ([Data] -> [Doc]) -> [Data] -> [Doc]
forall a b. (a -> b) -> a -> b
$ CF -> [Data]
getAbstractSyntax CF
cf
  ]
  where
  header :: [Char]
header = [[Char]] -> [Char]
unlines
    [ [Char]
"/* C Abstract Syntax Implementation generated by the BNF Converter. */"
    , [Char]
""
    , [Char]
"#include <stdio.h>"
    , [Char]
"#include <stdlib.h>"
    , [Char]
"#include \"Absyn.h\""
    , [Char]
""
    ]

prDataC :: Data -> [Doc]
prDataC :: Data -> [Doc]
prDataC (Cat
cat, [([Char], [Cat])]
rules) = (([Char], [Cat]) -> Doc) -> [([Char], [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> ([Char], [Cat]) -> Doc
prRuleC Cat
cat) [([Char], [Cat])]
rules

-- | Classes for rules vary based on the type of rule.
--
-- * Empty list constructor, these are not represented in the AbSyn
--
-- >>> prRuleC (ListCat (Cat "A")) ("[]", [Cat "A", Cat "B", Cat "B"])
-- <BLANKLINE>
--
-- * Linked list case. These are all built-in list functions.
-- Later we could include things like lookup, insert, delete, etc.
--
-- >>> prRuleC (ListCat (Cat "A")) ("(:)", [Cat "A", Cat "B", Cat "B"])
-- /********************   ListA    ********************/
-- <BLANKLINE>
-- ListA make_ListA(A p1, ListA p2)
-- {
--     ListA tmp = (ListA) malloc(sizeof(*tmp));
--     if (!tmp)
--     {
--         fprintf(stderr, "Error: out of memory when allocating ListA!\n");
--         exit(1);
--     }
--     tmp->a_ = p1;
--     tmp->lista_ = p2;
--     return tmp;
-- }
--
-- * Standard rule
--
-- >>> prRuleC (Cat "A") ("funa", [Cat "A", Cat "B", Cat "B"])
-- /********************   funa    ********************/
-- <BLANKLINE>
-- A make_funa(A p1, B p2, B p3)
-- {
--     A tmp = (A) malloc(sizeof(*tmp));
--     if (!tmp)
--     {
--         fprintf(stderr, "Error: out of memory when allocating funa!\n");
--         exit(1);
--     }
--     tmp->kind = is_funa;
--     tmp->u.funa_.a_ = p1;
--     tmp->u.funa_.b_1 = p2;
--     tmp->u.funa_.b_2 = p3;
--     return tmp;
-- }
prRuleC :: Cat -> (String, [Cat]) -> Doc
prRuleC :: Cat -> ([Char], [Cat]) -> Doc
prRuleC Cat
_ ([Char]
fun, [Cat]
_) | [Char] -> Bool
forall a. IsFun a => a -> Bool
isNilFun [Char]
fun Bool -> Bool -> Bool
|| [Char] -> Bool
forall a. IsFun a => a -> Bool
isOneFun [Char]
fun = Doc
empty
prRuleC Cat
cat ([Char]
fun, [Cat]
_) | [Char] -> Bool
forall a. IsFun a => a -> Bool
isConsFun [Char]
fun = [Doc] -> Doc
vcat'
    [ Doc
"/********************   " Doc -> Doc -> Doc
<> Doc
c Doc -> Doc -> Doc
<> Doc
"    ********************/"
    , Doc
""
    , Doc
c Doc -> Doc -> Doc
<+> Doc
"make_" Doc -> Doc -> Doc
<> Doc
c Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Char] -> Doc
text [Char]
m Doc -> Doc -> Doc
<+> Doc
"p1" Doc -> Doc -> Doc
<> Doc
"," Doc -> Doc -> Doc
<+> Doc
c Doc -> Doc -> Doc
<+> Doc
"p2")
    , Doc
lbrace
    , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat'
        [ Doc
c Doc -> Doc -> Doc
<+> Doc
"tmp = (" Doc -> Doc -> Doc
<> Doc
c Doc -> Doc -> Doc
<> Doc
") malloc(sizeof(*tmp));"
        , Doc
"if (!tmp)"
        , Doc
lbrace
        , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat'
            [ Doc
"fprintf(stderr, \"Error: out of memory when allocating " Doc -> Doc -> Doc
<> Doc
c Doc -> Doc -> Doc
<> Doc
"!\\n\");"
            , Doc
"exit(1);" ]
        , Doc
rbrace
        , [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"tmp->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"p1;"
        , Doc
"tmp->" Doc -> Doc -> Doc
<> Doc
v Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
"p2;"
        , Doc
"return tmp;" ]
    , Doc
rbrace ]
  where
    icat :: [Char]
icat = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat)
    c :: Doc
c = [Char] -> Doc
text [Char]
icat
    v :: Doc
v = [Char] -> Doc
text ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
icat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_")
    ListCat Cat
c' = Cat
cat            -- We're making a list constructor, so we
                                -- expect a list category
    m :: [Char]
m = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
c')
    m' :: [Char]
m' = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
prRuleC Cat
c ([Char]
fun, [Cat]
cats) = [Doc] -> Doc
vcat'
    [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"/********************   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fun [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"    ********************/"
    , Doc
""
    , Cat -> [Char] -> [([Char], Int)] -> [Cat] -> Doc
prConstructorC Cat
c [Char]
fun [([Char], Int)]
vs [Cat]
cats ]
  where
    vs :: [([Char], Int)]
vs = [Cat] -> [([Char], Int)]
getVars [Cat]
cats

-- | The constructor just assigns the parameters to the corresponding instance
-- variables.
-- >>> prConstructorC (Cat "A") "funa" [("A",1),("B",2)] [Cat "O", Cat "E"]
-- A make_funa(O p1, E p2)
-- {
--     A tmp = (A) malloc(sizeof(*tmp));
--     if (!tmp)
--     {
--         fprintf(stderr, "Error: out of memory when allocating funa!\n");
--         exit(1);
--     }
--     tmp->kind = is_funa;
--     tmp->u.funa_.a_ = p1;
--     tmp->u.funa_.b_2 = p2;
--     return tmp;
-- }
prConstructorC :: Cat -> String -> [IVar] -> [Cat] -> Doc
prConstructorC :: Cat -> [Char] -> [([Char], Int)] -> [Cat] -> Doc
prConstructorC Cat
cat [Char]
c [([Char], Int)]
vs [Cat]
cats = [Doc] -> Doc
vcat'
    [ [Char] -> Doc
text ([Char]
cat' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" make_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c) Doc -> Doc -> Doc
<> Doc -> Doc
parens Doc
args
    , Doc
lbrace
    , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat'
        [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
cat' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" tmp = (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cat' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") malloc(sizeof(*tmp));"
        , [Char] -> Doc
text [Char]
"if (!tmp)"
        , Doc
lbrace
        , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat'
            [ [Char] -> Doc
text ([Char]
"fprintf(stderr, \"Error: out of memory when allocating " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!\\n\");")
            , [Char] -> Doc
text [Char]
"exit(1);" ]
        , Doc
rbrace
        , [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"tmp->kind = is_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
        , [Char] -> [([Char], Int)] -> [Doc] -> Doc
prAssigns [Char]
c [([Char], Int)]
vs [Doc]
params
        , [Char] -> Doc
text [Char]
"return tmp;" ]
    , Doc
rbrace ]
  where
    cat' :: [Char]
cat' = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat)
    ([Doc]
types, [Doc]
params) = [(Doc, Doc)] -> ([Doc], [Doc])
forall a b. [(a, b)] -> ([a], [b])
unzip ([Cat] -> [(Doc, Doc)]
prParams [Cat]
cats)
    args :: Doc
args = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
(<+>) [Doc]
types [Doc]
params

-- | Prints the constructor's parameters. Returns pairs of type * name
-- >>> prParams [Cat "O", Cat "E"]
-- [(O,p1),(E,p2)]
prParams :: [Cat] -> [(Doc, Doc)]
prParams :: [Cat] -> [(Doc, Doc)]
prParams = (Integer -> Cat -> (Doc, Doc))
-> [Integer] -> [Cat] -> [(Doc, Doc)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Cat -> (Doc, Doc)
forall {a}. Show a => a -> Cat -> (Doc, Doc)
prParam [Integer
1..]
  where
    prParam :: a -> Cat -> (Doc, Doc)
prParam a
n Cat
c = ([Char] -> Doc
text (Cat -> [Char]
identCat Cat
c), [Char] -> Doc
text ([Char]
"p" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
n))

-- | Prints the assignments of parameters to instance variables.
-- >>> prAssigns "A" [("A",1),("B",2)] [text "abc", text "def"]
-- tmp->u.a_.a_ = abc;
-- tmp->u.a_.b_2 = def;
prAssigns :: String -> [IVar] -> [Doc] -> Doc
prAssigns :: [Char] -> [([Char], Int)] -> [Doc] -> Doc
prAssigns [Char]
c [([Char], Int)]
vars [Doc]
params = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (([Char], Int) -> Doc -> Doc) -> [([Char], Int)] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([Char], Int) -> Doc -> Doc
forall {a}. (Eq a, Num a, Show a) => ([Char], a) -> Doc -> Doc
prAssign [([Char], Int)]
vars [Doc]
params
  where
    prAssign :: ([Char], a) -> Doc -> Doc
prAssign ([Char]
t,a
n) Doc
p =
        [Char] -> Doc
text ([Char]
"tmp->u." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> a -> [Char]
forall {a}. (Eq a, Num a, Show a) => [Char] -> a -> [Char]
vname [Char]
t a
n) Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
p Doc -> Doc -> Doc
<> Doc
semi
    vname :: [Char] -> a -> [Char]
vname [Char]
t a
n
      | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1, [([Char], Int)
_] <- (([Char], Int) -> Bool) -> [([Char], Int)] -> [([Char], Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char]
t [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==) ([Char] -> Bool)
-> (([Char], Int) -> [Char]) -> ([Char], Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Int) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], Int)]
vars
                  = [Char] -> [Char]
varName [Char]
t
      | Bool
otherwise = [Char] -> [Char]
varName [Char]
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
showNum a
n
    c' :: [Char]
c' = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
c

{- **** Helper Functions **** -}

memName :: [Char] -> [Char]
memName [Char]
s = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"