import GFCC.Abs
import GFCC.ErrM
import GFCC.Lex
import GFCC.Par
import Control.Monad
import Data.Char
import Data.List
import Numeric
import System.Environment
import System.Exit
import System.IO
constrType :: Grammar -> String
constrType g = unlines $
["typedef enum { "]
++ map (\x -> " " ++ x ++ "," ) ds
++ ["} Fun;"]
where fs = [id2c n | (n,_) <- constructors g ]
ds = case fs of
[] -> []
(x:xs) -> (x ++ " = ATOM_FIRST_FUN"):xs
mkFunSigs :: Grammar -> String
mkFunSigs g = unlines [mkFunSig n ats | (n,(ats,_)) <- constructors g]
mkFunSig :: CId -> [CId] -> String
mkFunSig n ats =
"extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ");"
where
adecls = map ("Tree *" ++) args
args = [ "x" ++ show x | x <- [0..c-1] ]
c = length ats
mkFuns :: Grammar -> String
mkFuns g = unlines [mkFun n ats | (n,(ats,_)) <- constructors g]
mkFun :: CId -> [CId] -> String
mkFun n ats = unlines $
["extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ") {",
" Tree *t = tree_fun(" ++ id2c n ++ "," ++ show c ++ ");"]
++ [" tree_set_child(" ++ commaSep ["t",show i, args!!i] ++ ");" | i <- [0..c-1]]
++ [" return t;",
"}"]
where
adecls = map ("Tree *" ++) args
args = [ "x" ++ show x | x <- [0..c-1] ]
c = length ats
doDie :: String -> [String] -> [String]
doDie s args = ["fprintf(" ++ commaSep ("stderr":show s':args) ++ ");",
"exit(1);"]
where s' = "Error: " ++ s ++ "\n"
mkLin :: Grammar -> CId -> String
mkLin g l = unlines $
["extern Term *" ++ langLinName_ l ++ "(Tree *t) {",
" Term **cs = NULL;",
" int n = arity(t);",
" if (n > 0) {",
" int i;",
" cs = (Term**)term_alloc(n * sizeof(Term *));", -- FIXME: handle failure
" for (i = 0; i < n; i++) {",
" cs[i] = " ++ langLinName_ l ++ "(tree_get_child(t,i));",
" }",
" }",
"",
" switch (t->type) {",
" case ATOM_STRING: return term_str(t->value.string_value);",
-- " case ATOM_INTEGER: return NULL;", -- FIXME!
-- " case ATOM_DOUBLE: return NULL;", -- FIXME!
" case ATOM_META: return term_meta();"]
++ [" case " ++ id2c n ++ ": return " ++ linFunName n ++ "(cs);"
| (n,_) <- constructors g]
++ [" default: "]
++ map (" " ++) (doDie (langLinName_ l ++ " %d") ["t->type"])
++ [" return NULL;",
" }",
"}",
"",
"extern Term *" ++ langLinName l ++ "(Tree *t) {",
" Term *r;",
" term_alloc_pool(1000000);", -- FIXME: size?
" r = " ++ langLinName_ l ++ "(t);",
" /* term_free_pool(); */", -- FIXME: copy term?
" return r;",
"}"]
langLinName :: CId -> String
langLinName n = id2c n ++ "_lin"
langLinName_ :: CId -> String
langLinName_ n = id2c n ++ "_lin_"
linFunName :: CId -> String
linFunName n = "lin_" ++ id2c n
mkLinFuns :: [CncDef] -> String
mkLinFuns cs = unlines $ map mkLinFunSig cs ++ [""] ++ map mkLinFun cs
mkLinFunSig :: CncDef -> String
mkLinFunSig (Lin n t) =
"static Term *" ++ linFunName n ++ "(Term **cs);"
mkLinFun :: CncDef -> String
mkLinFun (Lin (CId n) t) | "__" `isPrefixOf` n = ""
mkLinFun (Lin n t) = unlines [
"static Term *" ++ linFunName n ++ "(Term **cs) {",
" return " ++ term2c t ++ ";",
"}"
]
term2c :: Tree a -> String
term2c t = case t of
-- terms
R terms -> fun "term_array" terms
-- an optimization of t!n where n is a constant int
P term0 (C n) -> "term_sel_int("++ term2c term0 ++ "," ++ show n ++ ")"
P term0 term1 -> "term_sel(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
S terms -> fun "term_seq" terms
K tokn -> term2c tokn
V n -> "cs[" ++ show n ++ "]"
C n -> "term_int(" ++ show n ++ ")"
F cid -> linFunName cid ++ "(cs)"
FV terms -> fun "term_variants" terms
W str term -> "term_suffix(" ++ string2c str ++ "," ++ term2c term ++ ")"
RP term0 term1 -> "term_rp(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
TM -> "term_meta()"
-- tokens
KS s -> "term_str(" ++ string2c s ++ ")"
KP strs vars -> error $ show t -- FIXME: pre token
_ -> error $ show t
where fun f ts = f ++ "(" ++ commaSep (show (length ts):map term2c ts) ++ ")"
commaSep = concat . intersperse ","
id2c :: CId -> String
id2c (CId s) = s -- FIXME: convert ticks
string2c :: String -> String
string2c s = "\"" ++ concatEsc (map esc s) ++ "\""
where
esc c | isAscii c && isPrint c = [c]
esc '\n' = "\\n"
esc c = "\\x" ++ map toUpper (showHex (ord c) "")
concatEsc [] = ""
concatEsc (x:xs) | length x <= 2 = x ++ concatEsc xs
| otherwise = x ++ "\" \"" ++ concatEsc xs
lang2file :: CId -> String -> String
lang2file n ext = id2c n ++ "." ++ ext
constructors :: Grammar -> [(CId, ([CId],CId))]
constructors (Grm _ (Abs ads) _) = [(n,(ats,rt)) | Fun n (Typ ats rt) _ <- ads]
absHFile :: Grammar -> FilePath
absHFile (Grm (Hdr a _) _ _) = lang2file a "h"
cncHFile :: Concrete -> FilePath
cncHFile (Cnc l _) = lang2file l "h"
mkAbsH :: Grammar -> String
mkAbsH g = unlines ["#include \"gfcc-tree.h\"",
"#include \"gfcc-term.h\"",
constrType g,
"",
mkFunSigs g]
mkAbsC :: Grammar -> String
mkAbsC g = unlines [include (absHFile g),
"",
mkFuns g]
mkCncH :: Grammar -> Concrete -> String
mkCncH g (Cnc l _) = unlines
[include (absHFile g),
"",
"extern Term *" ++ langLinName l ++ "(Tree *);"]
mkCncC :: Grammar -> Concrete -> String
mkCncC g c@(Cnc l cds) = unlines $
["#include <stdio.h>",
"#include <stdlib.h>",
include (cncHFile c),
""]
++ [mkLinFuns cds, mkLin g l]
mkH :: FilePath -> String -> (FilePath, String)
mkH f c = (f, c')
where c' = unlines ["#ifndef " ++ s, "#define " ++ s, "", c, "#endif"]
s = [if x=='.' then '_' else toUpper x | x <- f]
include :: FilePath -> String
include f = "#include " ++ show f
-- returns list of file name, file contents
gfcc2c :: Grammar -> [(FilePath, String)]
gfcc2c g@(Grm (Hdr a _) _ cs) =
[mkH (absHFile g) (mkAbsH g), (lang2file a "c", mkAbsC g)]
++ concat [[mkH (cncHFile cnc) (mkCncH g cnc),(lang2file c "c", mkCncC g cnc)] | cnc@(Cnc c _) <- cs]
parse :: String -> Err Grammar
parse = pGrammar . myLexer
die :: String -> IO ()
die s = do hPutStrLn stderr "Usage: gfcc2c <gfcc file>"
exitFailure
createFile :: FilePath -> String -> IO ()
createFile f c = do hPutStrLn stderr $ "Writing " ++ f ++ "..."
writeFile f c
main :: IO ()
main = do args <- getArgs
case args of
[file] -> do c <- readFile file
case parse c of
Bad err -> die err
Ok g -> do let fs = gfcc2c g
mapM_ (uncurry createFile) fs
_ -> die "Usage: gfcc2c <gfcc file>"