module Language.Scheme.Compiler.Types
(
CompOpts (CompileOptions)
, CompLibOpts (..)
, defaultCompileOptions
, HaskAST (..)
, ast2Str
, asts2Str
, createAstFunc
, createAstCont
, joinL
, moduleRuntimeVar
, showValAST
, 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
data CompOpts = CompileOptions {
coptsThisFunc :: String,
coptsThisFuncUseValue :: Bool,
coptsThisFuncUseArgs :: Bool,
coptsNextFunc :: Maybe String
}
defaultCompileOptions :: String -> CompOpts
defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing
data CompLibOpts = CompileLibraryOptions {
compBlock :: String -> Maybe String -> Env
-> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST],
compLisp :: Env -> String -> String -> Maybe String
-> IOThrowsError [HaskAST]
}
moduleRuntimeVar = " modules "
createAstFunc
:: CompOpts
-> [HaskAST]
-> HaskAST
createAstFunc (CompileOptions thisFunc useVal useArgs _) funcBody = do
let val = case useVal of
True -> "value"
_ -> "_"
args = case useArgs of
True -> "(Just args)"
_ -> "_"
AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") funcBody
createAstCont
:: CompOpts
-> String
-> String
-> HaskAST
createAstCont (CompileOptions _ _ _ (Just nextFunc)) var indentation = do
AstValue $ indentation ++ " continueEval env (makeCPS env cont " ++ nextFunc ++ ") " ++ var
createAstCont (CompileOptions _ _ _ Nothing) var indentation = do
AstValue $ indentation ++ " continueEval env cont " ++ var
data HaskAST = AstAssignM String HaskAST
| AstFunction {astfName :: String,
astfArgs :: String,
astfCode :: [HaskAST]
}
| AstValue String
| AstContinuation {astcNext :: String,
astcArgs :: String
}
showValAST :: HaskAST -> String
showValAST (AstAssignM var val) = " " ++ var ++ " <- " ++ show val
showValAST (AstFunction name args code) = do
let fheader = "\n" ++ name ++ args ++ " = do "
let fbody = unwords . map (\x -> "\n" ++ x ) $ map showValAST code
fheader ++ fbody
showValAST (AstValue v) = v
showValAST (AstContinuation nextFunc args) =
" continueEval env (makeCPSWArgs env cont " ++
nextFunc ++ " " ++ args ++ ") $ Nil \"\""
instance Show HaskAST where show = showValAST
joinL
:: forall a. [[a]]
-> [a]
-> [a]
joinL ls sep = concat $ Data.List.intersperse sep ls
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
asts2Str :: [LispVal] -> String
asts2Str ls = do
"[" ++ (joinL (map ast2Str ls) ",") ++ "]"
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
, "--"]
headerModule :: [String]
headerModule = ["module Main where "]
headerImports :: [String]
headerImports = [
"Language.Scheme.Core "
, "Language.Scheme.Numerical "
, "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 "]
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 (makeCPS env cont exec) (Nil \"\")"]
[ " "
, "-- |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 "
, " "
, "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 \"\") []"
, " "]