ToHaskell.hs

-- | Exports Sifflet to Haskell
-- Requires haskell-src package.

module Language.Sifflet.Export.ToHaskell
    (
      HaskellOptions(..)
    , defaultHaskellOptions
    , exportHaskell
    , functionsToHsModule
    , functionToHsDecl
    , exprToHsExpr
    )
where

import Data.Char (toUpper)
import qualified Data.Map as M
import System.FilePath (dropExtension, takeFileName)

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


-- Main types and functions

-- | User configurable options for export to Haskell.
-- Currently these options are unused.
-- The line width options should probably go somewhere else,
-- maybe as PrettyOptions.
data HaskellOptions = 
    HaskellOptions {optionsSoftMaxLineWidth :: Int
                   , optionsHardMaxLineWidth :: Int
                   }
                    deriving (Eq, Show)

-- | The default options for export to Haskell.
defaultHaskellOptions :: HaskellOptions
defaultHaskellOptions = HaskellOptions {optionsSoftMaxLineWidth = 72,
                                        optionsHardMaxLineWidth = 80}

-- | Export functions with specified options to a file
exportHaskell :: HaskellOptions -> Exporter
exportHaskell _options functions path =
    let header = "-- File: " ++ path ++
                 "\n-- Generated by the Sifflet->Haskell exporter.\n\n"
    in writeFile path (header ++ 
                       hsPretty (functionsToHsModule 
                                (pathToModuleName path)
                                functions))


pathToModuleName :: FilePath -> String
pathToModuleName path =
    case dropExtension (takeFileName path) of
      [] -> "Test"
      c : cs -> toUpper c : cs

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

-- | Converting Sifflet to Haskell syntax tree

-- | Create a module from a module name and Functions.
functionsToHsModule :: String -> Functions -> Module
functionsToHsModule modname (Functions fs) =
    Module {moduleName = modname
           , moduleExports = Nothing
           , moduleImports = ImportDecl ["Data.Number.Sifflet"]
           , moduleDecls = map functionToHsDecl fs
           }

-- | Create a declaration from a Function.
-- Needs work: infer and declare the type of the function.
-- Minimally parenthesized.
functionToHsDecl :: Function -> Decl
functionToHsDecl (Function mname _atypes _rtype impl) =
    case (mname, impl) of
      (Nothing, _) -> error "functionToHsDecl: function has no name"
      (_, Primitive _) -> error "functionToHsDecl: function is primitive"
      (Just fname, Compound args body) ->
          Decl {declIdent = fname
               , declType = Nothing -- to be improved later
               , declParams = args
               , declExpr = (simplifyExpr haskellRules)
                            (exprToHsExpr body)}

haskellRules :: [Expr -> Expr]
haskellRules = commonRulesForSimplifyingExprs ++ 
               [ruleIfRight, ruleRightToLeft]

-- | Converts a Sifflet Expr to a fully parenthesized Haskell Expr
exprToHsExpr :: Expr -> Expr
exprToHsExpr expr =
    case expr of
      EUndefined -> ESymbol (Symbol "undefined")
      ESymbol _ -> expr
      EBool _ -> expr
      EChar _ -> expr
      ENumber _ -> expr
      EString _ -> expr

      EIf c a b -> EIf (exprToHsExpr c) (exprToHsExpr a) (exprToHsExpr b)
      EList es -> EList (map exprToHsExpr es)
      ELambda x body -> ELambda x (EGroup body)
      ECall (Symbol fname) args -> 
          case nameToHaskell fname of
            Left op ->      -- operator
                case args of
                  [left, right] -> 
                      EOp op (EGroup (exprToHsExpr left))
                             (EGroup (exprToHsExpr right))
                  _ -> error 
                       "exprToHsExpr: operation does not have 2 operands"
            Right funcName ->   -- function
                   ECall (Symbol funcName) (map (EGroup . exprToHsExpr) args)
      _ -> errcats ["exprToHsExpr: extended expr:", show expr]

-- | Map Sifflet names to Haskell names.
-- Returns a Left Operator for Haskell operators,
-- which always have the same name as their corresponding Sifflet 
-- functions, or a Right String for Haskell function and variable names.
nameToHaskell :: String -> Either Operator String
nameToHaskell name =
    case M.lookup name operatorTable of
      Just op -> Left op
      Nothing ->
        -- Most names would have the same names in Haskell,
        -- but there are a few special cases.
        Right (case name of
                 "zero?" -> "eqZero"
                 "positive?" -> "gtZero"
                 "negative?" -> "ltZero"
                 "add1" -> "succ"
                 "sub1" -> "pred"
                 _ -> name)