{-# 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    ( (+++), uncurry3, 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 -> [Char] -> CF -> ([Char], [Char])
cf2CAbs RecordPositions
rp [Char]
_ CF
cf = (RecordPositions -> [[Char]] -> [Data] -> CF -> [Char]
mkHFile RecordPositions
rp [[Char]]
classes [Data]
datas CF
cf, [Data] -> CF -> [Char]
mkCFile [Data]
datas CF
cf)
  where
  datas :: [Data]
  datas :: [Data]
datas = CF -> [Data]
getAbstractSyntax CF
cf
  classes :: [String]
  classes :: [[Char]]
classes = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (Data -> [Char]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> [Char]
identCat (Cat -> [Char]) -> (Data -> Cat) -> Data -> [Char]
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 -> [[Char]] -> [Data] -> CF -> [Char]
mkHFile RecordPositions
rp [[Char]]
classes [Data]
datas 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]]
posixC
  , [ [Char]
""
    , [Char]
"#include <stddef.h>  /* NULL */"
    , [Char]
"#include <string.h>  /* strdup */"
    , [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]
datas

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

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

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

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

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

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

-- | 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 :: [[Char]] -> Define -> [Char]
prDefH [[Char]]
tokenCats (Define RFun
fun Telescope
args Exp
e Base
_t) =
  [[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]
") \\\n  ", Exp -> State (Set [Char]) [Char]
prExp Exp
e State (Set [Char]) [Char] -> Set [Char] -> [Char]
forall s a. State s a -> s -> a
`evalState` Set [Char]
forall a. Monoid a => a
mempty ]
  where
  f :: [Char]
f  = RFun -> [Char]
forall a. IsFun a => a -> [Char]
funName RFun
fun
  xs :: [[Char]]
xs = (([Char], Base) -> [Char]) -> Telescope -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Base) -> [Char]
forall a b. (a, b) -> a
fst Telescope
args

  toCat :: Base -> Cat
  toCat :: Base -> Cat
toCat = [[Char]] -> Base -> Cat
catOfType ([[Char]] -> Base -> Cat) -> [[Char]] -> Base -> Cat
forall a b. (a -> b) -> a -> b
$ [[Char]]
specialCatsP [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
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 [Char]) [Char]
prExp = \case

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

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

-- | 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]
identCat 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 :: [Data] -> CF -> String
mkCFile :: [Data] -> CF -> [Char]
mkCFile [Data]
datas 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]
datas
  , [[Char]] -> [Char]
unlines [ [Char]
"", [Char]
"" ]
  -- Cloning
  , [[Char]] -> [Char]
unlines [[Char]]
cloneComment
  , [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Data -> [[Char]]) -> [Data] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Data -> [[Char]]
prCloneC [Data]
datas
  -- Freeing
  , [[Char]] -> [Char]
unlines [[Char]]
destructorComment
  , [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Data -> [[Char]]) -> [Data] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Data -> [[Char]]
prDestructorC [Data]
datas
  ]
  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]
""
    ]

-- |
-- >>> 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 -> [[Char]]
prCloneC (Cat
cat, [([Char], [Cat])]
rules)
  | Cat -> Bool
isList Cat
cat =
    [ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" clone_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
+++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    , [Char]
"{"
    , [Char]
"  if (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    , [Char]
"  {"
    , [Char]
"    /* clone of non-empty list */"
    , Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc -> Doc -> Doc -> [Doc] -> Doc
prettyList Int
6 ([Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"    return make_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl) Doc
"(" Doc
");" Doc
","
        [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
visitMember
        , [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"clone_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_)"
        ]
    , [Char]
"  }"
    , [Char]
"  else return NULL; /* clone of empty list */"
    , [Char]
"}"
    , [Char]
""
    ]
  | Bool
otherwise = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" clone_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p)"
      , [Char]
"{"
      , [Char]
"  switch(p->kind)"
      , [Char]
"  {"
      ]
    , (([Char], [Cat]) -> [[Char]]) -> [([Char], [Cat])] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char], [Cat]) -> [[Char]]
prCloneRule [([Char], [Cat])]
rules
    , [ [Char]
"  default:"
      , [Char]
"    fprintf(stderr, \"Error: bad kind field when cloning " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!\\n\");"
      , [Char]
"    exit(1);"
      , [Char]
"  }"
      , [Char]
"}"
      , [Char]
""
      ]
    ]
  where
  cl :: [Char]
cl          = Cat -> [Char]
identCat Cat
cat
  vname :: [Char]
vname       = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
cl
  visitMember :: String
  visitMember :: [Char]
visitMember = Cat -> [Char] -> [Char]
cloner Cat
el ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
member [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
    where
    el :: Cat
el     = Cat -> Cat
normCatOfList Cat
cat
    member :: [Char]
member = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> [Char]
identCat Cat
el

  prCloneRule :: (String, [Cat]) -> [String]
  prCloneRule :: ([Char], [Cat]) -> [[Char]]
prCloneRule ([Char]
fun, [Cat]
cats) | Bool -> Bool
not ([Char] -> Bool
forall a. IsFun a => a -> Bool
isCoercion [Char]
fun) =
    [ [Char]
"  case is_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fnm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":"
    , Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc -> Doc -> Doc -> [Doc] -> Doc
prettyList Int
6 ([Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"    return make_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 ([Char] -> Doc
text ([Char] -> Doc) -> ((Cat, Doc) -> [Char]) -> (Cat, Doc) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> (Cat, Doc) -> [Char]
prCloneCat [Char]
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 :: [Char]
fnm = [Char] -> [Char]
forall a. IsFun a => a -> [Char]
funName [Char]
fun
  prCloneRule ([Char], [Cat])
_ = []

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

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

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


-- |
-- >>> 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 -> [[Char]]
prDestructorC (Cat
cat, [([Char], [Cat])]
rules)
  | Cat -> Bool
isList Cat
cat = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [Char]
"void free_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
+++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
      , [Char]
"{"
      , [Char]
"  if (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
      , [Char]
"  {"
      ]
    , ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [[Char]]
visitMember
    , [ [Char]
"    free_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_);"
      , [Char]
"    free(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
");"
      , [Char]
"  }"
      , [Char]
"}"
      , [Char]
""
      ]
    ]
  | Bool
otherwise = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [Char]
"void free_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p)"
      , [Char]
"{"
      , [Char]
"  switch(p->kind)"
      , [Char]
"  {"
      ]
    , (([Char], [Cat]) -> [[Char]]) -> [([Char], [Cat])] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char], [Cat]) -> [[Char]]
prFreeRule [([Char], [Cat])]
rules
    , [ [Char]
"  default:"
      , [Char]
"    fprintf(stderr, \"Error: bad kind field when freeing " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!\\n\");"
      , [Char]
"    exit(1);"
      , [Char]
"  }"
      , [Char]
"  free(p);"
      , [Char]
"}"
      , [Char]
""
      ]
    ]
  where
  cl :: [Char]
cl          = Cat -> [Char]
identCat Cat
cat
  vname :: [Char]
vname       = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
cl
  visitMember :: [[Char]]
visitMember =
    case Cat
ecat of
      TokenCat [Char]
c
        | [Char]
c [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"Char", [Char]
"Double", [Char]
"Integer"] -> []
        | Bool
otherwise -> [ [Char]
"free" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest ]
      Cat
_             -> [ [Char]
"free_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ecl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest ]
    where
    rest :: [Char]
rest   = [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
member [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_);"
    member :: [Char]
member = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
ecl
    ecl :: [Char]
ecl    = Cat -> [Char]
identCat Cat
ecat
    ecat :: Cat
ecat   = Cat -> Cat
normCatOfList Cat
cat

  prFreeRule :: (String, [Cat]) -> [String]
  prFreeRule :: ([Char], [Cat]) -> [[Char]]
prFreeRule ([Char]
fun, [Cat]
cats) | Bool -> Bool
not ([Char] -> Bool
forall a. IsFun a => a -> Bool
isCoercion [Char]
fun) = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [Char]
"  case is_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fnm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":"
      ]
    , ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ((Cat, Doc) -> Maybe [Char]) -> [(Cat, Doc)] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char] -> (Cat, Doc) -> Maybe [Char]
prFreeCat [Char]
fnm) ([(Cat, Doc)] -> [[Char]]) -> [(Cat, Doc)] -> [[Char]]
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
    , [ [Char]
"    break;"
      , [Char]
""
      ]
    ]
    where
    fnm :: [Char]
fnm = [Char] -> [Char]
forall a. IsFun a => a -> [Char]
funName [Char]
fun
  prFreeRule ([Char], [Cat])
_ = []

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

  prFreeCat :: String -> (Cat, Doc) -> Maybe String
  prFreeCat :: [Char] -> (Cat, Doc) -> Maybe [Char]
prFreeCat [Char]
fnm (TokenCat [Char]
c, Doc
nt)
    | [Char]
c [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"Char", [Char]
"Double", [Char]
"Integer"] = Maybe [Char]
forall a. Maybe a
Nothing
      -- Only pointer need to be freed.
  prFreeCat [Char]
fnm (Cat
cat, Doc
nt) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char]
"free_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat)) ([Char] -> [Char] -> [Char]
forall a b. a -> b -> a
const [Char]
"free") (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Maybe [Char]
maybeTokenCat Cat
cat
      , [Char]
"(p->u."
      , (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
fnm
      , [Char]
"_.", Doc -> [Char]
render Doc
nt, [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]
"_"