{-# OPTIONS -fglasgow-exts -cpp #-}

#include "../../undefined.h"

{-| main module.
-}

module Compiler.Agate.Main where

import Compiler.Agate.TranslateName
import Compiler.Agate.OptimizedPrinter
import Compiler.Agate.UntypedPrinter

import GHC.Base (map)

import Syntax.Internal
import Syntax.Scope
import Text.PrettyPrint
import Syntax.Common

import Control.Monad.State
import Control.Monad.Error

import Data.List as List
import Data.Map as Map
--import Data.Maybe

import Syntax.Abstract.Test
import Syntax.Abstract.Name

import Interaction.Options
import Interaction.Monad

import TypeChecker
import TypeChecking.Monad

import Utils.Monad

import Version

-- | The main function
compilerMain :: IM () -> IM ()
compilerMain typeCheck = do
	typeCheck
	sig <- gets stSignature
	let sigs = toList sig
	let definitions = mdefDefs (snd (head sigs)) -- :: Map Name Definition
	let defs = toList definitions
	maxconargs <- maxConArgs (GHC.Base.map snd defs)
	liftIO $ do
	    putStrLn "{-# OPTIONS -fglasgow-exts -cpp #-}"
	    putStrLn ""
	    putStrLn "-- Generated by Agate 2"
	    putStrLn ""
	    printConsts definitions
	    putStrLn ""
	    putStrLn "data Value = VAbs (Value -> Value)"
	    putStrLn "           | VCon0 !Int"
	    putStrLn "           | VCon1 !Int Value"
	    putStrLn "           | VCon2 !Int Value Value"
	    putStrLn "           | VCon3 !Int Value Value Value"
	    putStrLn "           | VNonData"
	    --putStrLn "           | VStruct [(Int,Value)]"
	    putStrLn "           | VIO      !(IO Value)"
	    putStrLn "           | VInt     !Integer"
	    putStrLn "           | VFloat   !Double"
	    putStrLn "           | VString  !String"
	    putStrLn "           | VChar    !Char"
	    putStrLn ""
	    putStrLn "instance Show Value where"
	    putStrLn "  show v = case v of"
	    putStrLn "    VAbs     f     -> \"<func>\""
	    putStrLn "    VCon0    c     -> getConString c"
	    putStrLn "    VCon1    c a1       -> showCons c [a1]"
	    putStrLn "    VCon2    c a1 a2    -> showCons c [a1,a2]"
	    putStrLn "    VCon3    c a1 a2 a3 -> showCons c [a1,a2,a3]"
	    -- putStrLn "    VStruct binds -> \"struct { \" ++ join \", \" (map showBind binds) ++ \" }\""
	    putStrLn "    VNonData       -> \"<nondata>\""
	    putStrLn "    VIO      m     -> \"<IO>\""
	    putStrLn "    VInt     i     -> show i"
	    putStrLn "    VFloat   f     -> show f"
	    putStrLn "    VString  s     -> show s"
	    putStrLn "    VChar    c     -> show c"
	    putStrLn ""
	    --putStrLn "join sep []     = \"\""
	    --putStrLn "join sep [a]    = a"
	    --putStrLn "join sep (a:as) = a ++ sep ++ join sep as"
	    putStrLn ""
	    putStrLn "showCons c as = \"(\" ++ unwords (getConString c : map show as) ++ \")\""
	    putStrLn "showBind (f,v) = show v"
	    putStrLn ""
	    putStrLn "getConString c = show c"
	    putStrLn ""
    	    putStrLn "(|$|) :: Value -> Value -> Value"
	    putStrLn "(VAbs f) |$| x = f x"
	    --putStrLn "(|.|) :: Value -> Int -> Value"
	    --putStrLn "(VStruct ((i,e):xs)) |.| i0 | i == i0 = e"
	    --putStrLn "(VStruct (_    :xs)) |.| i0           = (VStruct xs) |.| i0"
	    --putStrLn "deIO (VIO m) = m"
	    putStrLn ""
	    putStrLn "class Trans a where"
	    putStrLn "    unbox :: Value -> a"
	    putStrLn "    box   :: a -> Value"
	    putStrLn ""
	    putStrLn "instance Trans () where"
	    putStrLn "    unbox VNonData = ()"
	    putStrLn "    box () = VNonData"
	    putStrLn ""
	    putStrLn "instance (Trans a, Trans b) => Trans (a -> b) where"
	    putStrLn "    unbox (VAbs f) = unbox . f . box"
	    putStrLn "    box f = VAbs ( box . f . unbox )"
	    putStrLn ""
	    putStrLn "instance Trans Integer where"
	    putStrLn "    unbox (VInt i) = i"
	    putStrLn "    box i = VInt i"
	    putStrLn ""
	    putStrLn "instance Trans Double where"
	    putStrLn "    unbox (VFloat f) = f"
	    putStrLn "    box f = VFloat f"
	    putStrLn ""
	    putStrLn "instance Trans String where"
	    putStrLn "    unbox (VString s) = s"
	    putStrLn "    box s = VString s"
	    putStrLn ""
	    putStrLn "instance Trans Char where"
	    putStrLn "    unbox (VChar c) = c"
	    putStrLn "    box c = VChar c"
	    putStrLn ""
	    putStrLn "main = undefined {- putStrLn $ show x_main -}"
	liftIO $ putStrLn $ "--"
	ddefs <- mapM showNDefinition defs
	liftIO $ putStrLn $ render $ vcat ddefs
	showOptimizedDefinitions definitions

maxConArgs :: [Definition] -> IM Int
maxConArgs dfs = return 3


enumCon :: Definitions -> [Name]
enumCon = concatMap f . toList
    where f (name, d) = case theDef d of
                          (Constructor _ _ _) -> [name]
                          _                   -> []

printConsts :: Definitions -> IO ()
printConsts = go 0 . enumCon
    where go :: Nat -> [Name] -> IO ()
          go _ []     = return ()
          go n (x:xs) = do
          	let cname = translateNameAsUntypedConstructor $ show x
          	putStrLn $ "#define " ++ cname ++ " " ++ show n
                go (n+1) xs

----------------------------------------------------------------