{-# 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 Control.Monad.State (State, gets, modify, evalState)

import Data.Char     ( toLower )
import Data.Either   ( lefts )
import Data.Function ( on )
import Data.List     ( groupBy, intercalate, intersperse, nub, sort )
import Data.Maybe    ( mapMaybe )
import Data.Set      ( Set )

import qualified Data.Set as Set

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


-- | 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 -> [String] -> [Data] -> CF -> String
mkHFile RecordPositions
rp [String]
classes [Data]
datas CF
cf, [Data] -> CF -> String
mkCFile [Data]
datas CF
cf)
  where
  datas :: [Data]
  datas :: [Data]
datas = CF -> [Data]
getAbstractSyntax CF
cf
  classes :: [String]
  classes :: [String]
classes = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Data -> String) -> [Data] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> String
identCat (Cat -> String) -> (Data -> Cat) -> Data -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> Cat
forall a b. (a, b) -> a
fst) [Data]
datas

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

-- | Makes the Header file.

mkHFile :: RecordPositions -> [String] -> [Data] -> CF -> String
mkHFile :: RecordPositions -> [String] -> [Data] -> CF -> String
mkHFile RecordPositions
rp [String]
classes [Data]
datas 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]
posixC
  , [ String
""
    , String
"#include <stddef.h>  /* NULL */"
    , String
"#include <string.h>  /* strdup */"
    , String
""
    , String
"/* C++ Abstract Syntax Interface.*/"
    , 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]
datas

  -- Cloning
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
classes) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [String]
cloneComment
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
prCloneH [String]
classes
    , [ String
"" ]
    ]

  -- Freeing
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
classes) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [String]
destructorComment
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
prFreeH [String]
classes
    , [ String
"" ]
    ]

  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([Define] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Define]
definedConstructors)
    [ String
"/********************   Defined Constructors    ***********************/"
    , String
""
    ]
  , String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Define -> String) -> [Define] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Define -> String
prDefH [String]
user) [Define]
definedConstructors

  , [ String
""
    , String
"#endif"
    ]
  ]
  where
  user  :: [TokenCat]
  user :: [String]
user   = CF -> [String]
forall f. CFG f -> [String]
tokenNames CF
cf
  prForward :: String -> String
  prForward :: String -> String
prForward 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
";"
    ]
  prCloneH :: String -> String
  prCloneH :: String -> String
prCloneH String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" clone_" 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
" p);"
  prFreeH :: String -> String
  prFreeH :: String -> String
prFreeH String
s = String
"void free_" 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
" p);"
  definedConstructors :: [Define]
definedConstructors = CF -> [Define]
forall f. CFG f -> [Define]
definitions CF
cf

cloneComment :: [String]
cloneComment :: [String]
cloneComment =
  [ String
"/***************************   Cloning   ******************************/"
  , String
""
  ]

destructorComment :: [String]
destructorComment :: [String]
destructorComment =
  [ String
"/********************   Recursive Destructors    **********************/"
  , String
""
  , String
"/* These free an entire abstract syntax tree"
  , String
" * including all subtrees and strings."
  , String
" *"
  , String
" * Will not work properly if there is sharing in the tree,"
  , String
" * i.e., when some pointers are aliased.  In this case"
  , String
" * it will attempt to free the same memory twice."
  , String
" */"
  , String
""
  ]

-- | For @define@d constructors, make a CPP definition.
--
-- >>> prDefH [] (Define "iSg" [("i",undefined)] (App "ICons" undefined [Var "i", App "INil" undefined []]) undefined)
-- "#define make_iSg(i) \\\n  make_ICons (i, make_INil())"
--
-- >>> prDefH [] (Define "snoc" (map (,undefined) ["xs","x"]) (App "Cons" undefined [Var "x", Var "xs"]) undefined)
-- "#define make_snoc(xs,x) \\\n  make_Cons (x, xs)"
--
prDefH
  :: [TokenCat] -- ^ Names of the token constructors (silent in C backend).
  -> Define
  -> String
prDefH :: [String] -> Define -> String
prDefH [String]
tokenCats (Define RFun
fun Telescope
args Exp
e Base
_t) =
  [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
") \\\n  ", Exp -> State (Set String) String
prExp Exp
e State (Set String) String -> Set String -> String
forall s a. State s a -> s -> a
`evalState` Set String
forall a. Monoid a => a
mempty ]
  where
  f :: String
f  = RFun -> String
forall a. IsFun a => a -> String
funName RFun
fun
  xs :: [String]
xs = ((String, Base) -> String) -> Telescope -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Base) -> String
forall a b. (a, b) -> a
fst Telescope
args

  toCat :: Base -> Cat
  toCat :: Base -> Cat
toCat = [String] -> Base -> Cat
catOfType ([String] -> Base -> Cat) -> [String] -> Base -> Cat
forall a b. (a -> b) -> a -> b
$ [String]
specialCatsP [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
tokenCats

  -- Issue #363, #348.
  -- Duplicate occurrences of variables in expression need to be cloned,
  -- because deallocation assumes that the AST is in fact a tree.
  -- Duplicate occurrences introduce sharing and thus turn it into a DAG
  -- (directed acyclic graph).
  -- We maintain a set of variables we have already encountered.
  prExp :: Exp -> State (Set String) String
  prExp :: Exp -> State (Set String) String
prExp = \case

    Var String
x -> (Set String -> Bool) -> StateT (Set String) Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
x) StateT (Set String) Identity Bool
-> (Bool -> State (Set String) String) -> State (Set String) String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- The first use is not cloned.
      Bool
False -> String
x String
-> StateT (Set String) Identity () -> State (Set String) String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Set String -> Set String) -> StateT (Set String) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
x)
      -- Subsequent uses are cloned.
      Bool
True  -> case String -> Telescope -> Maybe Base
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x Telescope
args of
        Just Base
t -> String -> State (Set String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State (Set String) String)
-> String -> State (Set String) String
forall a b. (a -> b) -> a -> b
$ Cat -> String -> String
cloner (Base -> Cat
toCat Base
t) String
x
        Maybe Base
Nothing -> State (Set String) String
forall a. HasCallStack => a
undefined -- impossible

    -- Andreas, 2021-02-13, issue #338
    -- Token categories are just @typedef@s in C, so no constructor needed.
    App String
g Type
_ [Exp
e] | String
g String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tokenCats
                -> Exp -> State (Set String) String
prExp Exp
e
    App String
"[]" Type
_ [] -> String -> State (Set String) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"NULL"
    App String
g Type
t [Exp]
es  -> do
      [String]
es' <- (Exp -> State (Set String) String)
-> [Exp] -> StateT (Set String) Identity [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> State (Set String) String
prExp [Exp]
es
      String -> State (Set String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State (Set String) String)
-> String -> State (Set String) String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"make_", String -> Type -> String
con String
g Type
t, [Exp] -> String
forall f. [Exp' f] -> String
lparen [Exp]
es, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
es', String
")" ]
    LitInt    Integer
i -> String -> State (Set String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State (Set String) String)
-> String -> State (Set String) String
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i
    LitDouble Double
d -> String -> State (Set String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State (Set String) String)
-> String -> State (Set String) String
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
d
    LitChar   Char
c -> String -> State (Set String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State (Set String) String)
-> String -> State (Set String) String
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. Show a => a -> String
show Char
c
    LitString String
s -> String -> State (Set String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State (Set String) String)
-> String -> State (Set String) String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"strdup(", String -> String
forall a. Show a => a -> String
show String
s, String
")" ]  -- so that free() does not crash!
  con :: String -> Type -> String
con String
g ~(FunT [Base]
_ts Base
t)
    | String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
g = Base -> String
identType Base
t
    | Bool
otherwise   = String
g
  -- If more than one argument, or complex argument, put space before opening parenthesis.
  lparen :: [Exp' f] -> String
lparen = \case
    Exp' f
_:Exp' f
_:[Exp' f]
_           -> String
" ("
    [App f
_ Type
_ (Exp' f
_:[Exp' f]
_)] -> String
" ("
    [Exp' f]
_               -> String
"("

-- | 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
identCat 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) -> Int -> String)
-> [(String, a)] -> [Int] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String, a) -> Int -> String
forall a b. Show a => (String, b) -> a -> String
par [(String, a)]
ps [Int
0::Int ..]
      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] -> 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
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 :: [IVar] -> Doc
prInstVarsOneType [IVar]
ivars = String -> Doc
text (IVar -> String
forall a b. (a, b) -> a
fst ([IVar] -> IVar
forall a. [a] -> a
head [IVar]
ivars))
                              Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((IVar -> Doc) -> [IVar] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map IVar -> Doc
prIVar [IVar]
ivars))
                              Doc -> Doc -> Doc
<> Doc
semi
    prIVar :: IVar -> Doc
prIVar (String
s, Int
i) = String -> Doc
text (String -> String
varName String
s) Doc -> Doc -> Doc
<> String -> Doc
text (Int -> String
showNum Int
i)

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

-- | Makes the .C file
mkCFile :: [Data] -> CF -> String
mkCFile :: [Data] -> CF -> String
mkCFile [Data]
datas 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]
datas
  , [String] -> String
unlines [ String
"", String
"" ]
  -- Cloning
  , [String] -> String
unlines [String]
cloneComment
  , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Data -> [String]) -> [Data] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Data -> [String]
prCloneC [Data]
datas
  -- Freeing
  , [String] -> String
unlines [String]
destructorComment
  , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Data -> [String]) -> [Data] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Data -> [String]
prDestructorC [Data]
datas
  ]
  where
  header :: String
header = [String] -> String
unlines
    [ String
"/* C Abstract Syntax Implementation. */"
    , String
""
    , String
"#include <stdio.h>"
    , String
"#include <stdlib.h>"
    , String
"#include \"Absyn.h\""
    , String
""
    ]

-- |
-- >>> text $ unlines $ prCloneC (Cat "Exp", [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Exp", Cat "Exp"])])
-- Exp clone_Exp(Exp p)
-- {
--   switch(p->kind)
--   {
--   case is_EInt:
--     return make_EInt (p->u.eint_.integer_);
-- <BLANKLINE>
--   case is_EAdd:
--     return make_EAdd
--       ( clone_Exp(p->u.eadd_.exp_1)
--       , clone_Exp(p->u.eadd_.exp_2)
--       );
-- <BLANKLINE>
--   default:
--     fprintf(stderr, "Error: bad kind field when cloning Exp!\n");
--     exit(1);
--   }
-- }
-- <BLANKLINE>
-- <BLANKLINE>
prCloneC :: Data -> [String]
prCloneC :: Data -> [String]
prCloneC (Cat
cat, [(String, [Cat])]
rules)
  | Cat -> Bool
isList Cat
cat =
    [ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" clone_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"("String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
+++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    , String
"{"
    , String
"  if (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    , String
"  {"
    , String
"    /* clone of non-empty list */"
    , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc -> Doc -> Doc -> [Doc] -> Doc
prettyList Int
6 (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"    return make_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl) Doc
"(" Doc
");" Doc
","
        [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
visitMember
        , String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"clone_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_)"
        ]
    , String
"  }"
    , String
"  else return NULL; /* clone of empty list */"
    , String
"}"
    , String
""
    ]
  | Bool
otherwise = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" clone_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p)"
      , String
"{"
      , String
"  switch(p->kind)"
      , String
"  {"
      ]
    , ((String, [Cat]) -> [String]) -> [(String, [Cat])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [Cat]) -> [String]
prCloneRule [(String, [Cat])]
rules
    , [ String
"  default:"
      , String
"    fprintf(stderr, \"Error: bad kind field when cloning " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!\\n\");"
      , String
"    exit(1);"
      , String
"  }"
      , String
"}"
      , String
""
      ]
    ]
  where
  cl :: String
cl          = Cat -> String
identCat Cat
cat
  vname :: String
vname       = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cl
  visitMember :: String
  visitMember :: String
visitMember = Cat -> String -> String
cloner Cat
el (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
member String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
    where
    el :: Cat
el     = Cat -> Cat
normCatOfList Cat
cat
    member :: String
member = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
identCat Cat
el

  prCloneRule :: (String, [Cat]) -> [String]
  prCloneRule :: (String, [Cat]) -> [String]
prCloneRule (String
fun, [Cat]
cats) | Bool -> Bool
not (String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
fun) =
    [ String
"  case is_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
    , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc -> Doc -> Doc -> [Doc] -> Doc
prettyList Int
6 (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"    return make_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnm) Doc
"(" Doc
");\n" Doc
"," ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
        ((Cat, Doc) -> Doc) -> [(Cat, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> ((Cat, Doc) -> String) -> (Cat, Doc) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Cat, Doc) -> String
prCloneCat String
fnm) ([(Cat, Doc)] -> [Doc]) -> [(Cat, Doc)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [Either (Cat, Doc) Any] -> [(Cat, Doc)]
forall a b. [Either a b] -> [a]
lefts ([Either (Cat, Doc) Any] -> [(Cat, Doc)])
-> [Either (Cat, Doc) Any] -> [(Cat, Doc)]
forall a b. (a -> b) -> a -> b
$ [Either Cat Any] -> [Either (Cat, Doc) Any]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars ([Either Cat Any] -> [Either (Cat, Doc) Any])
-> [Either Cat Any] -> [Either (Cat, Doc) Any]
forall a b. (a -> b) -> a -> b
$ (Cat -> Either Cat Any) -> [Cat] -> [Either Cat Any]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Either Cat Any
forall a b. a -> Either a b
Left [Cat]
cats
    ]
    where
    fnm :: String
fnm = String -> String
forall a. IsFun a => a -> String
funName String
fun
  prCloneRule (String, [Cat])
_ = []

  -- | This goes on to recurse to the instance variables.

  prCloneCat :: String -> (Cat, Doc) -> String
  prCloneCat :: String -> (Cat, Doc) -> String
prCloneCat String
fnm (Cat
cat, Doc
nt) = Cat -> String -> String
cloner Cat
cat String
member
    where
    member :: String
member = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"p->u.", (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
fnm, String
"_.", Doc -> String
render Doc
nt ]

-- | Clone or not depending on the category.
--   Only pointers need to be cloned.
--
cloner :: Cat -> String -> String
cloner :: Cat -> String -> String
cloner Cat
cat String
x =
  case Cat
cat of
    TokenCat String
c
      | String
c String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"Char", String
"Double", String
"Integer"]
                  -> String
x
      | Bool
otherwise -> String
"strdup" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
parens String
x
    Cat
_             -> String
"clone_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (Cat -> Cat
normCat Cat
cat) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
parens String
x
  where parens :: String -> String
parens = (String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")


-- |
-- >>> text $ unlines $ prDestructorC (Cat "Exp", [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Exp", Cat "Exp"])])
-- void free_Exp(Exp p)
-- {
--   switch(p->kind)
--   {
--   case is_EInt:
--     break;
-- <BLANKLINE>
--   case is_EAdd:
--     free_Exp(p->u.eadd_.exp_1);
--     free_Exp(p->u.eadd_.exp_2);
--     break;
-- <BLANKLINE>
--   default:
--     fprintf(stderr, "Error: bad kind field when freeing Exp!\n");
--     exit(1);
--   }
--   free(p);
-- }
-- <BLANKLINE>
-- <BLANKLINE>
prDestructorC :: Data -> [String]
prDestructorC :: Data -> [String]
prDestructorC (Cat
cat, [(String, [Cat])]
rules)
  | Cat -> Bool
isList Cat
cat = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"void free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"("String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
+++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      , String
"{"
      , String
"  if (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      , String
"  {"
      ]
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
visitMember
    , [ String
"    free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_);"
      , String
"    free(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
      , String
"  }"
      , String
"}"
      , String
""
      ]
    ]
  | Bool
otherwise = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"void free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p)"
      , String
"{"
      , String
"  switch(p->kind)"
      , String
"  {"
      ]
    , ((String, [Cat]) -> [String]) -> [(String, [Cat])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [Cat]) -> [String]
prFreeRule [(String, [Cat])]
rules
    , [ String
"  default:"
      , String
"    fprintf(stderr, \"Error: bad kind field when freeing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!\\n\");"
      , String
"    exit(1);"
      , String
"  }"
      , String
"  free(p);"
      , String
"}"
      , String
""
      ]
    ]
  where
  cl :: String
cl          = Cat -> String
identCat Cat
cat
  vname :: String
vname       = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cl
  visitMember :: [String]
visitMember =
    case Cat
ecat of
      TokenCat String
c
        | String
c String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"Char", String
"Double", String
"Integer"] -> []
        | Bool
otherwise -> [ String
"free" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest ]
      Cat
_             -> [ String
"free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ecl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest ]
    where
    rest :: String
rest   = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
member String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_);"
    member :: String
member = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
ecl
    ecl :: String
ecl    = Cat -> String
identCat Cat
ecat
    ecat :: Cat
ecat   = Cat -> Cat
normCatOfList Cat
cat

  prFreeRule :: (String, [Cat]) -> [String]
  prFreeRule :: (String, [Cat]) -> [String]
prFreeRule (String
fun, [Cat]
cats) | Bool -> Bool
not (String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
fun) = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"  case is_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
      ]
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Cat, Doc) -> Maybe String) -> [(Cat, Doc)] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> (Cat, Doc) -> Maybe String
prFreeCat String
fnm) ([(Cat, Doc)] -> [String]) -> [(Cat, Doc)] -> [String]
forall a b. (a -> b) -> a -> b
$ [Either (Cat, Doc) Any] -> [(Cat, Doc)]
forall a b. [Either a b] -> [a]
lefts ([Either (Cat, Doc) Any] -> [(Cat, Doc)])
-> [Either (Cat, Doc) Any] -> [(Cat, Doc)]
forall a b. (a -> b) -> a -> b
$ [Either Cat Any] -> [Either (Cat, Doc) Any]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars ([Either Cat Any] -> [Either (Cat, Doc) Any])
-> [Either Cat Any] -> [Either (Cat, Doc) Any]
forall a b. (a -> b) -> a -> b
$ (Cat -> Either Cat Any) -> [Cat] -> [Either Cat Any]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Either Cat Any
forall a b. a -> Either a b
Left [Cat]
cats
    , [ String
"    break;"
      , String
""
      ]
    ]
    where
    fnm :: String
fnm = String -> String
forall a. IsFun a => a -> String
funName String
fun
  prFreeRule (String, [Cat])
_ = []

  -- | This goes on to recurse to the instance variables.

  prFreeCat :: String -> (Cat, Doc) -> Maybe String
  prFreeCat :: String -> (Cat, Doc) -> Maybe String
prFreeCat String
_fnm (TokenCat String
c, Doc
_nt)
    | String
c String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"Char", String
"Double", String
"Integer"] = Maybe String
forall a. Maybe a
Nothing
      -- Only pointer need to be freed.
  prFreeCat String
fnm (Cat
cat, Doc
nt) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
"free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (Cat -> Cat
normCat Cat
cat)) (String -> String -> String
forall a b. a -> b -> a
const String
"free") (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> Maybe String
maybeTokenCat Cat
cat
      , String
"(p->u."
      , (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
fnm
      , String
"_.", Doc -> String
render Doc
nt, 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
cat@(ListCat Cat
c') (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
"_")
    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 = (Int -> Cat -> (Doc, Doc)) -> [Int] -> [Cat] -> [(Doc, Doc)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Cat -> (Doc, Doc)
forall a. Show a => a -> Cat -> (Doc, Doc)
prParam [Int
1::Int ..]
  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
prAssign [IVar]
vars [Doc]
params
  where
    prAssign :: IVar -> Doc -> Doc
prAssign (String
t,Int
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 -> Int -> String
vname String
t Int
n) Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
p Doc -> Doc -> Doc
<> Doc
semi
    vname :: String -> Int -> String
vname String
t Int
n
      | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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]
++ Int -> String
showNum Int
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 -> 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
"_"