{-# 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 {
    CompOpts -> String
coptsThisFunc :: String,        
    -- ^Immediate name to use when creating a compiled function.
    --  Presumably there is other code that is expecting
    --  to call into it.

    CompOpts -> Bool
coptsThisFuncUseValue :: Bool,
    -- ^Whether to include the /value/ parameter in the current function
    
    CompOpts -> Bool
coptsThisFuncUseArgs :: Bool,
    -- ^Whether to include the /args/ parameter in the current function
    
    CompOpts -> Maybe String
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 :: String -> CompOpts
defaultCompileOptions String
thisFunc = String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing

-- |Options passed to the compiler library module
data CompLibOpts = CompileLibraryOptions {
    CompLibOpts
-> String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compBlock :: String -> Maybe String -> Env 
              -> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST],
    CompLibOpts
-> Env
-> String
-> String
-> Maybe String
-> IOThrowsError [HaskAST]
compLisp :: Env -> String -> String -> Maybe String 
              -> IOThrowsError [HaskAST]
    }

-- |Runtime reference to module data structure
moduleRuntimeVar :: String
moduleRuntimeVar :: String
moduleRuntimeVar = String
" modules "

-- |Create code for a function
createAstFunc 
  :: CompOpts  -- ^ Compilation options
  -> [HaskAST] -- ^ Body of the function
  -> HaskAST -- ^ Complete function code
createAstFunc :: CompOpts -> [HaskAST] -> HaskAST
createAstFunc (CompileOptions String
thisFunc Bool
useVal Bool
useArgs Maybe String
_) [HaskAST]
funcBody = do
  let val :: String
val = if Bool
useVal then String
"value" else String
"_"
      args :: String
args = if Bool
useArgs then String
"(Just args)" else String
"_"
  String -> String -> [HaskAST] -> HaskAST
AstFunction String
thisFunc (String
" env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") [HaskAST]
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 :: CompOpts -> String -> String -> HaskAST
createAstCont (CompileOptions String
_ Bool
_ Bool
_ (Just String
nextFunc)) String
var String
indentation = do
  String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
indentation String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (Just [])"
createAstCont (CompileOptions String
_ Bool
_ Bool
_ Maybe String
Nothing) String
var String
indentation = do
  String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
indentation String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  continueEval env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 {HaskAST -> String
astfName :: String,
--                 astfType :: String,
                 HaskAST -> String
astfArgs :: String,
                 HaskAST -> [HaskAST]
astfCode :: [HaskAST]
                } 
 | AstValue String
 | AstRef String
 | AstContinuation {HaskAST -> String
astcNext :: String,
                    HaskAST -> String
astcArgs :: String
                   }

-- |Generate code based on the given Haskell AST
showValAST :: HaskAST -> String
showValAST :: HaskAST -> String
showValAST (AstAssignM String
var HaskAST
val) = String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HaskAST -> String
forall a. Show a => a -> String
show HaskAST
val
showValAST (AstFunction String
name String
args [HaskAST]
code) = do
  let typeSig :: String
typeSig = String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal "
  let fheader :: String
fheader = String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = do "
  let fbody :: String
fbody = [String] -> String
unwords ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
x ) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (HaskAST -> String) -> [HaskAST] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map HaskAST -> String
showValAST [HaskAST]
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
  String
typeSig String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fheader String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fbody 
#endif
showValAST (AstValue String
v) = String
v
showValAST (AstRef String
v) = String
v
showValAST (AstContinuation String
nextFunc String
args) =
    String
"  continueEval env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
       String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (Nil \"\") Nothing "

instance Show HaskAST where show :: HaskAST -> String
show = HaskAST -> String
showValAST

-- |A utility function to join list members together
joinL 
  :: forall a. [[a]] -- ^ Original list-of-lists
  -> [a] -- ^ Separator 
  -> [a] -- ^ Joined list
joinL :: [[a]] -> [a] -> [a]
joinL [[a]]
ls [a]
sep = [a] -> [[a]] -> [a]
forall a. [a] -> [[a]] -> [a]
Data.List.intercalate [a]
sep [[a]]
ls

-- |Convert abstract syntax tree to a string
ast2Str :: LispVal -> String 
ast2Str :: LispVal -> String
ast2Str (String String
s) = String
"String " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
ast2Str (Char Char
c) = String
"Char " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c
ast2Str (Atom String
a) = String
"Atom " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
a
ast2Str (Number Integer
n) = String
"Number (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
ast2Str (Complex Complex Double
c) = String
"Complex $ (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Double -> String
forall a. Show a => a -> String
show (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ Complex Double -> Double
forall a. Complex a -> a
DC.realPart Complex Double
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :+ (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Double -> String
forall a. Show a => a -> String
show (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ Complex Double -> Double
forall a. Complex a -> a
DC.imagPart Complex Double
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
ast2Str (Rational Rational
r) = String
"Rational $ (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
DR.numerator Rational
r) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") % (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
DR.denominator Rational
r) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
ast2Str (Float Double
f) = String
"Float (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
ast2Str (Bool Bool
True) = String
"Bool True"
ast2Str (Bool Bool
False) = String
"Bool False"
ast2Str (HashTable Map LispVal LispVal
ht) = do
 let ls :: [(LispVal, LispVal)]
ls = Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map LispVal LispVal
ht 
     conv :: (LispVal, LispVal) -> String
conv (LispVal
a, LispVal
b) = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
 String
"HashTable $ Data.Map.fromList $ [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. [[a]] -> [a] -> [a]
joinL (((LispVal, LispVal) -> String) -> [(LispVal, LispVal)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (LispVal, LispVal) -> String
conv [(LispVal, LispVal)]
ls) String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
ast2Str (Vector Array Int LispVal
v) = do
  let ls :: [LispVal]
ls = Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
Data.Array.elems Array Int LispVal
v
      size :: Int
size = ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
ls) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  String
"Vector (listArray (0, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. [[a]] -> [a] -> [a]
joinL ((LispVal -> String) -> [LispVal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> String
ast2Str [LispVal]
ls) String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"])"
ast2Str (ByteVector ByteString
bv) = do
  let ls :: [Word8]
ls = ByteString -> [Word8]
BS.unpack ByteString
bv
  String
"ByteVector ( BS.pack " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. [[a]] -> [a] -> [a]
joinL ((Word8 -> String) -> [Word8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> String
forall a. Show a => a -> String
show [Word8]
ls) String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"])"
ast2Str (List [LispVal]
ls) = String
"List [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. [[a]] -> [a] -> [a]
joinL ((LispVal -> String) -> [LispVal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> String
ast2Str [LispVal]
ls) String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
ast2Str (DottedList [LispVal]
ls LispVal
l) = 
  String
"DottedList [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. [[a]] -> [a] -> [a]
joinL ((LispVal -> String) -> [LispVal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> String
ast2Str [LispVal]
ls) String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
l
ast2Str LispVal
l = LispVal -> String
forall a. Show a => a -> String
show LispVal
l -- Error?

-- |Convert a list of abstract syntax trees to a list of strings
asts2Str :: [LispVal] -> String
asts2Str :: [LispVal] -> String
asts2Str [LispVal]
ls = do
    String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([String] -> String -> String
forall a. [[a]] -> [a] -> [a]
joinL ((LispVal -> String) -> [LispVal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> String
ast2Str [LispVal]
ls) String
",") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"

-- |Header comment used at the top of a Haskell program generated
--  by the compiler
headerComment:: [String]
headerComment :: [String]
headerComment = [
   String
"--"
 , String
"-- This file was automatically generated by the husk scheme compiler (huskc)"
 , String
"--"
 , String
"--  http://justinethier.github.io/husk-scheme "
 , String
"--  (c) 2010 Justin Ethier "
 , String
"--  Version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
LSC.version
 , String
"--"]

-- |Main module used in a compiled Haskell program
headerModule :: [String]
headerModule :: [String]
headerModule = [String
"module Main where "]

-- |Imports used for a compiled program
headerImports :: [String]
headerImports :: [String]
headerImports = [
   String
"Language.Scheme.Core "
 , String
"Language.Scheme.Numerical "
 , String
"Language.Scheme.Macro "
 , String
"Language.Scheme.Primitives "
 , String
"Language.Scheme.Types     -- Scheme data types "
 , String
"Language.Scheme.Variables -- Scheme variable operations "
 , String
"Control.Monad.Error "
 , String
"Data.Array "
 , String
" qualified Data.ByteString as BS "
 , String
"Data.Complex "
 , String
" qualified Data.Map "
 , String
"Data.Ratio "
 , String
"Data.Word "
 , String
"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 :: String -> Bool -> String -> [String]
header String
filepath Bool
useCompiledLibs String
langRev = do
  let env :: String
env = if Bool
useCompiledLibs
            then String
"primitiveBindings"
            else case String
langRev of
                   String
"7" -> String
"r7rsEnv"
                   String
_ -> String
"r5rsEnv"
      initSrfi55 :: [String]
initSrfi55 = 
        case String
langRev of
          String
"7" -> []
          String
_ -> [ String
"exec55_3 env cont _ _ = do "
               , String
"  liftIO $ registerExtensions env getDataFileName' "
               , String
"  continueEval env (makeCPSWArgs env cont exec []) (Nil \"\") Nothing"]
  [ String
" "
    , String
" "
    , String
"-- |Get variable at runtime "
    , String
"getRTVar env var = do " 
    , String
"  v <- getVar env var " 
    , String
"  return $ case v of "
    , String
"    List _ -> Pointer var env "
    , String
"    DottedList _ _ -> Pointer var env "
    , String
"    String _ -> Pointer var env "
    , String
"    Vector _ -> Pointer var env "
    , String
"    ByteVector _ -> Pointer var env "
    , String
"    HashTable _ -> Pointer var env "
    , String
"    _ -> v "
    , String
" "
-- TODO:  this is just a temporary function until calls to continueEval can be purged from the compiler
    , String
"continueEval' env cont value = continueEval env cont value Nothing "
    , String
" "
    , String
"applyWrapper env cont (Nil _) (Just (a:as))  = do "
    , String
"  apply cont a as "
    , String
" "
    , String
"applyWrapper env cont value (Just (a:as))  = do "
    , String
"  apply cont a $ as ++ [value] "
    , String
" "
    , String
"getDataFileName' :: FilePath -> IO FilePath "
    , String
"getDataFileName' name = return $ \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
Language.Scheme.Util.escapeBackslashes String
filepath) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" ++ name "
    , String
" "]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
initSrfi55 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ 
    [ String
" "
    , String
"main :: IO () "
    , String
"main = do "
    , String
"  env <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
    , String
"  result <- (runIOThrows $ liftM show $ hsInit env (makeNullContinuation env) (Nil \"\") Nothing) "
    , String
"  case result of "
    , String
"    Just errMsg -> putStrLn errMsg "
    , String
"    _ -> return () "
    , String
" "
    , String
"hsInit env cont _ _ = do "
    , String
"  _ <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
moduleRuntimeVar String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" $ HashTable $ Data.Map.fromList [] "
    , String
"  run env cont (Nil \"\") (Just [])"
    , String
" "]