content: {-# LANGUAGE CPP #-}
  
  {- |
  Module      : Language.Scheme.Compiler.Types
  Copyright   : Justin Ethier
  Licence     : MIT (see LICENSE in the distribution)
  
  Maintainer  : github.com/justinethier
  Stability   : experimental
  Portability : portable
  
  This module contains data types used by the compiler.
  -}
  
  module Language.Scheme.Compiler.Types 
      (
      -- * Data types
        CompOpts (..)
      , CompLibOpts (..)
      , defaultCompileOptions
      , HaskAST (..)
      -- * Utility functions
      , ast2Str
      , asts2Str
      , createAstFunc 
      , createAstCont 
      , joinL 
      , moduleRuntimeVar
      , showValAST
      -- * Headers appended to output file
      , header
      , headerComment
      , headerModule
      , headerImports
      )
  where 
  import qualified Language.Scheme.Core as LSC (version) 
  import Language.Scheme.Types
  import qualified Language.Scheme.Util (escapeBackslashes)
  import qualified Data.Array
  import qualified Data.ByteString as BS
  import qualified Data.Complex as DC
  import qualified Data.List
  import qualified Data.Map
  import qualified Data.Ratio as DR
  
  -- |A type to store options passed to compile.
  --  Eventually all of this might be able to be 
  --  integrated into a Compile monad.
  data CompOpts = CompileOptions {
      coptsThisFunc :: String,        
      -- ^Immediate name to use when creating a compiled function.
      --  Presumably there is other code that is expecting
      --  to call into it.
  
      coptsThisFuncUseValue :: Bool,
      -- ^Whether to include the /value/ parameter in the current function
      
      coptsThisFuncUseArgs :: Bool,
      -- ^Whether to include the /args/ parameter in the current function
      
      coptsNextFunc :: Maybe String
      -- ^The name to use for the next function after the current
      --  compiler recursion is finished. For example, after compiling
      --  a block of code, the control flow would be expected to go
      --  to this function.
      }
  
  -- |The default compiler options
  defaultCompileOptions :: String -> CompOpts
  defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing
  
  -- |Options passed to the compiler library module
  data CompLibOpts = CompileLibraryOptions {
      compBlock :: String -> Maybe String -> Env 
                -> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST],
      compLisp :: Env -> String -> String -> Maybe String 
                -> IOThrowsError [HaskAST]
      }
  
  -- |Runtime reference to module data structure
  moduleRuntimeVar :: String
  moduleRuntimeVar = " modules "
  
  -- |Create code for a function
  createAstFunc 
    :: CompOpts  -- ^ Compilation options
    -> [HaskAST] -- ^ Body of the function
    -> HaskAST -- ^ Complete function code
  createAstFunc (CompileOptions thisFunc useVal useArgs _) funcBody = do
    let val = if useVal then "value" else "_"
        args = if useArgs then "(Just args)" else "_"
    AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") funcBody
  
  -- |Create code for a continutation
  createAstCont 
    :: CompOpts -- ^ Compilation options
    -> String -- ^ Value to send to the continuation
    -> String -- ^ Extra leading indentation (or blank string if none)
    -> HaskAST -- ^ Generated code
  createAstCont (CompileOptions _ _ _ (Just nextFunc)) var indentation = do
    AstValue $ indentation ++ "  " ++ nextFunc ++ " env cont " ++ var ++ " (Just [])"
  createAstCont (CompileOptions _ _ _ Nothing) var indentation = do
    AstValue $ indentation ++ "  continueEval env cont " ++ var ++ " Nothing"
  
  
  --  FUTURE: is this even necessary? Would just a string be good enough?
  
  -- |A very basic type to store a Haskell AST.
  data HaskAST = AstAssignM String HaskAST
    | AstFunction {astfName :: String,
  --                 astfType :: String,
                   astfArgs :: String,
                   astfCode :: [HaskAST]
                  } 
   | AstValue String
   | AstRef String
   | AstContinuation {astcNext :: String,
                      astcArgs :: String
                     }
  
  -- |Generate code based on the given Haskell AST
  showValAST :: HaskAST -> String
  showValAST (AstAssignM var val) = "  " ++ var ++ " <- " ++ show val
  showValAST (AstFunction name args code) = do
    let typeSig = "\n" ++ name ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal "
    let fheader = "\n" ++ name ++ args ++ " = do "
    let fbody = unwords . map (\x -> '\n' : x ) $ map showValAST code
  #ifdef UseDebug
    let appendArg arg = do
          if Data.List.isInfixOf arg args
             then " ++ \" \" ++ " ++ (show arg) ++ 
                  " ++ \" [\" ++ (show " ++ arg ++ ")" ++ 
                  " ++ \"] \""
             else ""
    let fdebug = "\n  _ <- liftIO $ (trace (\"" ++ 
                 name ++ "\"" ++ 
                 (appendArg "value") ++ 
                 (appendArg "args") ++ 
                 ") getCPUTime)"
    typeSig ++ fheader ++ fdebug ++ fbody 
  #else
    typeSig ++ fheader ++ fbody 
  #endif
  showValAST (AstValue v) = v
  showValAST (AstRef v) = v
  showValAST (AstContinuation nextFunc args) =
      "  continueEval env (makeCPSWArgs env cont " ++ 
         nextFunc ++ " " ++ args ++ ") (Nil \"\") Nothing "
  
  instance Show HaskAST where show = showValAST
  
  -- |A utility function to join list members together
  joinL 
    :: forall a. [[a]] -- ^ Original list-of-lists
    -> [a] -- ^ Separator 
    -> [a] -- ^ Joined list
  joinL ls sep = Data.List.intercalate sep ls
  
  -- |Convert abstract syntax tree to a string
  ast2Str :: LispVal -> String 
  ast2Str (String s) = "String " ++ show s
  ast2Str (Char c) = "Char " ++ show c
  ast2Str (Atom a) = "Atom " ++ show a
  ast2Str (Number n) = "Number (" ++ show n ++ ")"
  ast2Str (Complex c) = "Complex $ (" ++ (show $ DC.realPart c) ++ ") :+ (" ++ (show $ DC.imagPart c) ++ ")"
  ast2Str (Rational r) = "Rational $ (" ++ (show $ DR.numerator r) ++ ") % (" ++ (show $ DR.denominator r) ++ ")"
  ast2Str (Float f) = "Float (" ++ show f ++ ")"
  ast2Str (Bool True) = "Bool True"
  ast2Str (Bool False) = "Bool False"
  ast2Str (HashTable ht) = do
   let ls = Data.Map.toList ht 
       conv (a, b) = "(" ++ ast2Str a ++ "," ++ ast2Str b ++ ")"
   "HashTable $ Data.Map.fromList $ [" ++ joinL (map conv ls) "," ++ "]"
  ast2Str (Vector v) = do
    let ls = Data.Array.elems v
        size = (length ls) - 1
    "Vector (listArray (0, " ++ show size ++ ")" ++ "[" ++ joinL (map ast2Str ls) "," ++ "])"
  ast2Str (ByteVector bv) = do
    let ls = BS.unpack bv
    "ByteVector ( BS.pack " ++ "[" ++ joinL (map show ls) "," ++ "])"
  ast2Str (List ls) = "List [" ++ joinL (map ast2Str ls) "," ++ "]"
  ast2Str (DottedList ls l) = 
    "DottedList [" ++ joinL (map ast2Str ls) "," ++ "] $ " ++ ast2Str l
  ast2Str l = show l -- Error?
  
  -- |Convert a list of abstract syntax trees to a list of strings
  asts2Str :: [LispVal] -> String
  asts2Str ls = do
      "[" ++ (joinL (map ast2Str ls) ",") ++ "]"
  
  -- |Header comment used at the top of a Haskell program generated
  --  by the compiler
  headerComment:: [String]
  headerComment = [
     "--"
   , "-- This file was automatically generated by the husk scheme compiler (huskc)"
   , "--"
   , "--  http://justinethier.github.io/husk-scheme "
   , "--  (c) 2010 Justin Ethier "
   , "--  Version " ++ LSC.version
   , "--"]
  
  -- |Main module used in a compiled Haskell program
  headerModule :: [String]
  headerModule = ["module Main where "]
  
  -- |Imports used for a compiled program
  headerImports :: [String]
  headerImports = [
     "Language.Scheme.Core "
   , "Language.Scheme.Numerical "
   , "Language.Scheme.Macro "
   , "Language.Scheme.Primitives "
   , "Language.Scheme.Types     -- Scheme data types "
   , "Language.Scheme.Variables -- Scheme variable operations "
   , "Control.Monad.Error "
   , "Data.Array "
   , " qualified Data.ByteString as BS "
   , "Data.Complex "
   , " qualified Data.Map "
   , "Data.Ratio "
   , "Data.Word "
   , "System.IO "
  #ifdef UseDebug
   , "System.CPUTime "
   , "Debug.Trace "
  #endif
   ]
  
  -- |Block of code used in the header of a Haskell program 
  --  generated by the compiler.
  header :: String -> Bool -> String -> [String]
  header filepath useCompiledLibs langRev = do
    let env = if useCompiledLibs
              then "primitiveBindings"
              else case langRev of
                     "7" -> "r7rsEnv"
                     _ -> "r5rsEnv"
        initSrfi55 = 
          case langRev of
            "7" -> []
            _ -> [ "exec55_3 env cont _ _ = do "
                 , "  liftIO $ registerExtensions env getDataFileName' "
                 , "  continueEval env (makeCPSWArgs env cont exec []) (Nil \"\") Nothing"]
    [ " "
      , " "
      , "-- |Get variable at runtime "
      , "getRTVar env var = do " 
      , "  v <- getVar env var " 
      , "  return $ case v of "
      , "    List _ -> Pointer var env "
      , "    DottedList _ _ -> Pointer var env "
      , "    String _ -> Pointer var env "
      , "    Vector _ -> Pointer var env "
      , "    ByteVector _ -> Pointer var env "
      , "    HashTable _ -> Pointer var env "
      , "    _ -> v "
      , " "
  -- TODO:  this is just a temporary function until calls to continueEval can be purged from the compiler
      , "continueEval' env cont value = continueEval env cont value Nothing "
      , " "
      , "applyWrapper env cont (Nil _) (Just (a:as))  = do "
      , "  apply cont a as "
      , " "
      , "applyWrapper env cont value (Just (a:as))  = do "
      , "  apply cont a $ as ++ [value] "
      , " "
      , "getDataFileName' :: FilePath -> IO FilePath "
      , "getDataFileName' name = return $ \"" ++ (Language.Scheme.Util.escapeBackslashes filepath) ++ "\" ++ name "
      , " "]
      ++ initSrfi55 ++ 
      [ " "
      , "main :: IO () "
      , "main = do "
      , "  env <- " ++ env ++ " "
      , "  result <- (runIOThrows $ liftM show $ hsInit env (makeNullContinuation env) (Nil \"\") Nothing) "
      , "  case result of "
      , "    Just errMsg -> putStrLn errMsg "
      , "    _ -> return () "
      , " "
      , "hsInit env cont _ _ = do "
      , "  _ <- defineVar env \"" ++ moduleRuntimeVar ++ "\" $ HashTable $ Data.Map.fromList [] "
      , "  run env cont (Nil \"\") (Just [])"
      , " "]
  
  