{-# 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 -> String -> CF -> (String, String)
cf2CAbs RecordPositions
rp String
_ CF
cf = (RecordPositions -> CF -> String
mkHFile RecordPositions
rp CF
cf, CF -> String
mkCFile CF
cf)

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

-- | Makes the Header file.

mkHFile :: RecordPositions -> CF -> String
mkHFile :: RecordPositions -> CF -> String
mkHFile RecordPositions
rp CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"#ifndef ABSYN_HEADER"
    , String
"#define ABSYN_HEADER"
    , String
""
    , String
"/* C++ Abstract Syntax Interface generated by the BNF Converter.*/"
    , String
""
    , [String] -> String
prTypeDefs [String]
user
    , String
"/********************   Forward Declarations    ***********************/"
    ]
  , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
prForward [String]
classes
  , [ String
"/********************   Abstract Syntax Classes    ********************/"
    , String
""
    ]
  , (Data -> String) -> [Data] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (RecordPositions -> Data -> String
prDataH RecordPositions
rp) ([Data] -> [String]) -> [Data] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [Data]
getAbstractSyntax CF
cf
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([(String, [String], Exp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, [String], Exp)]
definedConstructors)
    [ String
"/********************   Defined Constructors    ***********************/"
    , String
""
    ]
  , ((String, [String], Exp) -> String)
-> [(String, [String], Exp)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> [String] -> Exp -> String)
-> (String, [String], Exp) -> String
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 String -> [String] -> Exp -> String
prDefH) [(String, [String], Exp)]
definedConstructors
  , [ String
""
    , String
"#endif"
    ]
  ]
  where
  user :: [String]
user   = ((String, Reg) -> String) -> [(String, Reg)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Reg) -> String
forall a b. (a, b) -> a
fst ([(String, Reg)] -> [String]) -> [(String, Reg)] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf
  rules :: [String]
  rules :: [String]
rules = CF -> [String]
forall a. IsFun a => CFG a -> [String]
getRules CF
cf
  classes :: [String]
classes = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String]
rules [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Cat] -> [String]
getClasses (CF -> [Cat]
allCatsNorm CF
cf))
  prForward :: String -> String
prForward String
s | Bool -> Bool
not (String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
s) = [String] -> String
unlines
    [ String
"struct " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_;"
    , String
"typedef struct " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_ *" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    ]
  prForward String
_ = String
""
  getRules :: CFG a -> [String]
getRules CFG a
cf = (Rul a -> String) -> [Rul a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Rul a -> String
forall a. IsFun a => Rul a -> String
testRule (CFG a -> [Rul a]
forall function. CFG function -> [Rul function]
cfgRules CFG a
cf)
  getClasses :: [Cat] -> [String]
getClasses = (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
forall a. Show a => a -> String
show ([Cat] -> [String]) -> ([Cat] -> [Cat]) -> [Cat] -> [String]
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 -> String
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 -> String
identCat (Cat -> Cat
normCat Cat
c)
    | Bool
otherwise = String
"_"
  definedConstructors :: [(String, [String], Exp)]
definedConstructors = [ (RFun -> String
forall a. IsFun a => a -> String
funName RFun
f, [String]
xs, Exp
e) | FunDef RFun
f [String]
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
  :: String   -- ^ Name of the defined constructors.
  -> [String] -- ^ Names of the arguments.
  -> Exp      -- ^ Definition (referring to arguments and rule labels).
  -> String
prDefH :: String -> [String] -> Exp -> String
prDefH String
f [String]
xs Exp
e = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"#define make_", String
f, String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs, String
") ", Exp -> String
prExp Exp
e ]
  where
  prExp :: Exp -> String
  prExp :: Exp -> String
prExp = \case
    Var String
x       -> String
x
    App String
g [Exp]
es    -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"make_", String
g, String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((Exp -> String) -> [Exp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> String
prExp [Exp]
es), String
")" ]
    LitInt    Integer
i -> Integer -> String
forall a. Show a => a -> String
show Integer
i
    LitDouble Double
d -> Double -> String
forall a. Show a => a -> String
show Double
d
    LitChar   Char
c -> Char -> String
forall a. Show a => a -> String
show Char
c
    LitString String
s -> String -> String
forall a. Show a => a -> String
show String
s

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


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

-- typedefs in the Header make generation much nicer.
prTypeDefs :: [String] -> String
prTypeDefs [String]
user = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"/********************   TypeDef Section    ********************/"
    , String
""
    , String
"typedef int Integer;"
    , String
"typedef char Char;"
    , String
"typedef double Double;"
    , String
"typedef char* String;"
    , String
"typedef char* Ident;"
    ]
  , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
prUserDef [String]
user
  ]
  where
    prUserDef :: String -> String
prUserDef String
s = String
"typedef char* " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"

-- | 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 :: [IVar] -> Doc
prInstVars =
    [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([IVar] -> [Doc]) -> [IVar] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([IVar] -> Doc) -> [[IVar]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [IVar] -> Doc
forall a. (Eq a, Num a, Show a) => [(String, a)] -> Doc
prInstVarsOneType ([[IVar]] -> [Doc]) -> ([IVar] -> [[IVar]]) -> [IVar] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IVar -> IVar -> Bool) -> [IVar] -> [[IVar]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> (IVar -> String) -> IVar -> IVar -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IVar -> String
forall a b. (a, b) -> a
fst) ([IVar] -> [[IVar]]) -> ([IVar] -> [IVar]) -> [IVar] -> [[IVar]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IVar] -> [IVar]
forall a. Ord a => [a] -> [a]
sort
  where
    prInstVarsOneType :: [(String, a)] -> Doc
prInstVarsOneType [(String, a)]
ivars = String -> Doc
text ((String, a) -> String
forall a b. (a, b) -> a
fst ([(String, a)] -> (String, a)
forall a. [a] -> a
head [(String, a)]
ivars))
                              Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (((String, a) -> Doc) -> [(String, a)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> Doc
forall a. (Eq a, Num a, Show a) => (String, a) -> Doc
prIVar [(String, a)]
ivars))
                              Doc -> Doc -> Doc
<> Doc
semi
    prIVar :: (String, a) -> Doc
prIVar (String
s, a
i) = String -> Doc
text (String -> String
varName String
s) Doc -> Doc -> Doc
<> String -> Doc
text (a -> String
forall a. (Eq a, Num a, Show a) => a -> String
showNum a
i)

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

-- | Makes the .C file
mkCFile :: CF -> String
mkCFile :: CF -> String
mkCFile CF
cf = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
header
  , Doc -> String
render (Doc -> String) -> Doc -> String
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 :: String
header = [String] -> String
unlines
    [ String
"/* C Abstract Syntax Implementation generated by the BNF Converter. */"
    , String
""
    , String
"#include <stdio.h>"
    , String
"#include <stdlib.h>"
    , String
"#include \"Absyn.h\""
    , String
""
    ]

prDataC :: Data -> [Doc]
prDataC :: Data -> [Doc]
prDataC (Cat
cat, [(String, [Cat])]
rules) = ((String, [Cat]) -> Doc) -> [(String, [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> (String, [Cat]) -> Doc
prRuleC Cat
cat) [(String, [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 -> (String, [Cat]) -> Doc
prRuleC Cat
_ (String
fun, [Cat]
_) | String -> Bool
forall a. IsFun a => a -> Bool
isNilFun String
fun Bool -> Bool -> Bool
|| String -> Bool
forall a. IsFun a => a -> Bool
isOneFun String
fun = Doc
empty
prRuleC Cat
cat (String
fun, [Cat]
_) | String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
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 (String -> Doc
text String
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
        , String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"tmp->" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"p1;"
        , Doc
"tmp->" Doc -> Doc -> Doc
<> Doc
v Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
"p2;"
        , Doc
"return tmp;" ]
    , Doc
rbrace ]
  where
    icat :: String
icat = Cat -> String
identCat (Cat -> Cat
normCat Cat
cat)
    c :: Doc
c = String -> Doc
text String
icat
    v :: Doc
v = String -> Doc
text ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
icat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")
    ListCat Cat
c' = Cat
cat            -- We're making a list constructor, so we
                                -- expect a list category
    m :: String
m = Cat -> String
identCat (Cat -> Cat
normCat Cat
c')
    m' :: String
m' = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
prRuleC Cat
c (String
fun, [Cat]
cats) = [Doc] -> Doc
vcat'
    [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"/********************   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    ********************/"
    , Doc
""
    , Cat -> String -> [IVar] -> [Cat] -> Doc
prConstructorC Cat
c String
fun [IVar]
vs [Cat]
cats ]
  where
    vs :: [IVar]
vs = [Cat] -> [IVar]
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 -> String -> [IVar] -> [Cat] -> Doc
prConstructorC Cat
cat String
c [IVar]
vs [Cat]
cats = [Doc] -> Doc
vcat'
    [ String -> Doc
text (String
cat' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" make_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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'
        [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
cat' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tmp = (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") malloc(sizeof(*tmp));"
        , String -> Doc
text String
"if (!tmp)"
        , Doc
lbrace
        , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat'
            [ String -> Doc
text (String
"fprintf(stderr, \"Error: out of memory when allocating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!\\n\");")
            , String -> Doc
text String
"exit(1);" ]
        , Doc
rbrace
        , String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"tmp->kind = is_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
        , String -> [IVar] -> [Doc] -> Doc
prAssigns String
c [IVar]
vs [Doc]
params
        , String -> Doc
text String
"return tmp;" ]
    , Doc
rbrace ]
  where
    cat' :: String
cat' = Cat -> String
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 = (String -> Doc
text (Cat -> String
identCat Cat
c), String -> Doc
text (String
"p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
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 :: String -> [IVar] -> [Doc] -> Doc
prAssigns String
c [IVar]
vars [Doc]
params = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (IVar -> Doc -> Doc) -> [IVar] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith IVar -> Doc -> Doc
forall a. (Eq a, Num a, Show a) => (String, a) -> Doc -> Doc
prAssign [IVar]
vars [Doc]
params
  where
    prAssign :: (String, a) -> Doc -> Doc
prAssign (String
t,a
n) Doc
p =
        String -> Doc
text (String
"tmp->u." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> a -> String
forall a. (Eq a, Num a, Show a) => String -> a -> String
vname String
t a
n) Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
p Doc -> Doc -> Doc
<> Doc
semi
    vname :: String -> a -> String
vname String
t a
n
      | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1, [IVar
_] <- (IVar -> Bool) -> [IVar] -> [IVar]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (IVar -> String) -> IVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IVar -> String
forall a b. (a, b) -> a
fst) [IVar]
vars
                  = String -> String
varName String
t
      | Bool
otherwise = String -> String
varName String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. (Eq a, Num a, Show a) => a -> String
showNum a
n
    c' :: String
c' = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c

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

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