content: 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>"
  