ToScheme.hs

module Language.Sifflet.Export.ToScheme
    (SExpr(..)
    , Atom(..)
    , Indent
    , Exporter
    , SchemeOptions(..)
    , defaultSchemeOptions
    , exprToSExpr
    , functionNameToSchemeName
    , valueToSExpr
    , exprToSchemeRepr
    , exprToSchemePretty
    , exprToScheme
    , inl
    , sepLines2
    , functionsToSExprs
    , functionsToPrettyScheme
    , defToSExpr
    , exportScheme
    )

where

import System.Sifflet.Paths

import Data.Number.Sifflet
import Graphics.UI.Sifflet.Types (VPUI(..))

import Language.Sifflet.Expr
import Language.Sifflet.Export.Exporter
import Language.Sifflet.Util

import Text.Sifflet.Pretty
import Text.Sifflet.Repr

-- Scheme S-exprs
-- --------------

-- Names beginning with S are generally Scheme things,
-- and of course, SExpr also stands for Symbolic Expression.

data SExpr = SAtom Atom | SList [SExpr]
           deriving (Eq, Show)

data Atom = SFloat Double
          | SInt Integer
          | SSymbol String
          | SString String
          | SChar Char
          | SBool Bool
          | SFunction Function
          deriving (Eq, Show)

type Indent = Int

data SchemeOptions = 
    SchemeOptions { defineWithLambda :: Bool 
                    -- ^ use explicit lambda in function definitions,
                    -- (define f (lambda (a b) ...)
                  }
    deriving (Eq, Show)

defaultSchemeOptions :: SchemeOptions
defaultSchemeOptions = SchemeOptions {defineWithLambda = False}

-- | An SExpr is "flattish" if it is an atom
-- or is a list containing only atoms, 
-- where the empty list () is an atom.

flattish :: [SExpr] -> Bool
flattish sexprs =
    case sexprs of
      [] -> True
      x:xs -> atom x && flattish xs

atom :: SExpr -> Bool
atom sexpr =
    case sexpr of
      SAtom _ -> True
      SList [] -> True
      _ -> False

-- Converting Sifflet Exprs to SExprs

exprToSExpr :: Expr -> SExpr
exprToSExpr expr =
    case expr of
      EUndefined -> 
          SAtom (SSymbol "*sifflet-undefined*")
      ESymbol (Symbol str) -> 
          SAtom (SSymbol (functionNameToSchemeName str))

      EBool b -> valueToSExpr (VBool b)
      EChar c -> valueToSExpr (VChar c)
      ENumber n -> valueToSExpr (VNumber n)
      EString s -> valueToSExpr (VString s)

      EIf cond action altAction ->
          SList [SAtom (SSymbol "if"), exprToSExpr cond,
                 exprToSExpr action, exprToSExpr altAction]
      EList exprs -> 
          -- This case is not likely to be used,
          -- but if it is, the exprs might need to be evaluated,
          -- so we have to use list instead of quote
          SList (SAtom (SSymbol "list") : (map exprToSExpr exprs))
      ELambda (Symbol x) body ->
          SList [SAtom (SSymbol "lambda"), SList [SAtom (SSymbol x)], 
                 exprToSExpr body] 
      ECall fsym args -> 
          SList (exprToSExpr (ESymbol fsym) :  map exprToSExpr args) 
      _ -> errcats ["exprToSExpr: extended expr:", show expr]

-- Convert Sifflet function names to corresponding Scheme function names.
-- There are a few special cases; otherwise, the names are the same.
-- In particular, all of these have the same names in Sifflet
-- as in standard (R5RS) Scheme:
--     +, -, *, 
-- All of these are defined in the library sifflet.scm, 
-- with the prefix "sifflet-" (e.g., sifflet-div):
--     div, add1, sub1, /, not-equal?
-- Notes: 1+ and 1- are commonly found in Scheme implementations,
-- but not standard.

functionNameToSchemeName :: String -> String
functionNameToSchemeName name =
    case name of
      "mod" -> "modulo"
      "add1" -> "sifflet-add1"
      "sub1" -> "sifflet-sub1"
      "==" -> "equal?"
      "/=" -> "sifflet-not-equal?"
      "null" -> "null?"
      "head" -> "car"
      "tail" -> "cdr"
      ":" -> "cons"
      _ -> name

-- Converting Sifflet Values to SExprs

valueToSExpr :: Value -> SExpr
valueToSExpr value =
    case value of
      VList vs -> 
          SList [SAtom (SSymbol "quote"), SList (map valueToSExpr vs)]
      _ ->
          SAtom (case value of
                   VBool b -> SBool b
                   VChar c -> SChar c
                   VNumber (Exact i) -> SInt i
                   VNumber (Inexact x) -> SFloat x
                   VString s -> SString s
                   VFun f -> SFunction f
                   VList _ -> 
                       error ("valueToSExpr: Impossible!  " ++
                              "We can't have VList here!")
                )

-- Converting Exprs to Strings of Scheme code

exprToSchemeRepr :: Expr -> String
exprToSchemeRepr = repr . exprToSExpr

exprToSchemePretty :: Expr -> String
exprToSchemePretty = pretty . exprToSExpr

exprToScheme :: Expr -> String
exprToScheme = exprToSchemePretty

-- Converting SExprs to Strings of Scheme code

instance Repr SExpr where
    repr sexpr =
        case sexpr of
          SAtom satom ->
              case satom of
                SFloat x -> show x
                SInt i -> show i
                SSymbol name -> name -- without ""
                SString str -> show str -- with ""
                SChar char -> show char
                SBool False -> "#f"
                SBool True -> "#t"
                -- SFunction: is this case really needed?
                -- Isn't the conversion to Scheme function names
                -- done in exprToSExpr?  
                SFunction (Function mname _ _ _) ->
                    case mname of
                      Nothing -> 
                          error "SExpr/repr: cannot repr unnamed function"
                      Just name -> 
                          functionNameToSchemeName name
          SList exprs ->
              "(" ++ unwords (map repr exprs) ++ ")"

instance Pretty SExpr where
    pretty = prettyLoop 0

prettyLoop :: Indent -> SExpr -> String
prettyLoop ind sexpr =
    case sexpr of
      SAtom _ -> repr sexpr
      SList xs ->
          if flattish xs
          then repr sexpr
          else
              case xs of
                [] -> error "prettyLoop: non-flattish xs cannot be []."
                [SAtom (SSymbol "if"), _, _, _] ->
                    displayList2 ind (ind + 4) xs
                [SAtom (SSymbol "define"), _, _] ->
                    displayList2 ind (ind + 4) xs
                [SAtom (SSymbol "lambda"), _, _] ->
                    displayList2 ind (ind + 4) xs
                SAtom (SSymbol name) : args ->
                    -- If it starts as a symbol, it's probably a function call,
                    -- so put function name and first argument on one line,
                    -- and indent everything following to first argument.
                    case args of
                      [] ->
                          -- no argument
                          displayList1 ind (ind + length name + 2) xs
                      _ ->
                          -- at least one argument, so at least two elements
                          -- in the list
                          displayList2 ind (ind + length name + 2) xs
                _ -> displayList1 ind (ind + 1) xs


-- | Newline and indent
inl :: Int -> String
inl ind = "\n" ++ replicate ind ' '

-- displayList1 "shows" the first list element on the first line
-- and then the rest on succeeding lines, so it must have at
-- least one element
displayList1 :: Indent -> Indent -> [SExpr] -> String
displayList1 ind ind' xs =
    case xs of
      [] -> error "displayList1: empty list"
      x:xs' -> "(" ++ 
               prettyLoop ind x ++ 
               displayTail ind' xs'

-- Like displayList1 but "shows" the first *two* list elements
-- on the first line.
displayList2 :: Indent -> Indent -> [SExpr] -> String
displayList2 ind ind' xs =
    case xs of
      x0:x1:xs' -> "(" ++ prettyLoop ind x0 ++
                   " " ++ prettyLoop ind' x1 ++
                   displayTail ind' xs'
      _ -> error "displayList2: list is too short"

-- displayTail "shows" the tail of an SExpr which is a list,
-- it assumes the initial "(" and first element have already
-- been "shown"
displayTail :: Indent -> [SExpr] -> String
displayTail ind xs =
    case xs of
       [] -> ")"
       -- to prevent final ")" from being on a line by itself
       x:[] -> inl ind ++ prettyLoop ind x ++ ")"
       x:xs' -> inl ind ++ prettyLoop ind x ++ displayTail ind xs'



-- Converting Sifflet definitions to Scheme definitions.

-- | Convert Sifflet Functions to Scheme SExprs
functionsToSExprs :: SchemeOptions -> Functions -> [SExpr]
functionsToSExprs options (Functions fs) =
    map (defToSExpr options . functionToDef) fs

-- | Convert Sifflet Functions to pretty Scheme
functionsToPrettyScheme :: SchemeOptions -> Functions -> String
functionsToPrettyScheme options = 
    sepLines2 . map pretty . functionsToSExprs options

-- | Convert a FunctionDefTuple to a Scheme SExpr.
-- Use the form (define (name . args) body)
-- except when there are zero arguments, which becomes a
-- Scheme constant rather than a function,
-- use (define name expr).

defToSExpr :: SchemeOptions -> FunctionDefTuple -> SExpr
defToSExpr options (name, args, _atypes, _rtype, body) =
    let asym = SAtom . SSymbol
        sdefine = asym "define"
        sname = asym name
        sbody = exprToSExpr body
    in case args of
         [] -> SList [sdefine, sname, sbody]
         _:_ ->
             let argAtoms = map asym args
             in if defineWithLambda options
                then let slambda = asym "lambda"
                         sargs = SList argAtoms
                         slambdaArgsBody = SList [slambda, sargs, sbody]
                     in SList [sdefine, sname, slambdaArgsBody]
                else let snameArgs = SList (sname : argAtoms)
                     in SList [sdefine, snameArgs, sbody]

-- | Export functions to a Scheme file.

-- This, too, could use an extra "explicit lambda" argument,
-- like defToSExpr.

exportScheme :: VPUI -> SchemeOptions -> Exporter
exportScheme vpui options functions path =
  
  let header = ";;; File: " ++ path ++ "\n" ++
               ";;; Generated by the Sifflet->Scheme exporter.\n" ++
               "\n" ++
               ";;; You may need to insert the contents of sifflet.scm,\n" ++
               ";;; from the Sifflet installation directory," ++ 
               " into this file\n"
  in do
      -- Get contents of sifflet.scm.
      -- It must be copied into the export file,
      -- since there is no standard way in Scheme to "include" or "import"
      -- a library.
      lib <- readLibFile vpui "sifflet.scm" path
      writeFile path 
              (sepLines2 [header,
                          functionsToPrettyScheme options functions,
                          lib])