ToHaskell.hs

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

module Sifflet.Foreign.ToHaskell
    (
      HaskellOptions(..)
    , HasParens(..)
    , defaultHaskellOptions
    , exportHaskell
    , functionsToHsModule
    , functionToHsDecl
    , exprToHsExp
    , valueToHsExp
    , prettyModule
    )
where

import Char (toUpper)
import Language.Haskell.Parser -- only for reverse engineering
import Language.Haskell.Syntax
import qualified Language.Haskell.Pretty as HsPretty

import Sifflet.Foreign.Exporter
import Sifflet.Language.Expr
import Sifflet.Examples

import System.FilePath (dropExtension, takeFileName)

-- Main types and functions

-- | User configurable options for export to Haskell.
-- Currently just a place-holder.
data HaskellOptions = HaskellOptions
                    deriving (Eq, Show)

-- | The default options for export to Haskell.
defaultHaskellOptions :: HaskellOptions
defaultHaskellOptions = HaskellOptions

-- | Export functions with specified options to a file
-- Work needed: add a declaration "import Sifflet.Data.Number".
exportHaskell :: HaskellOptions -> Exporter
exportHaskell _options functions path =
    let header = "-- File: " ++ path ++
                 "\n-- Generated by the Sifflet->Haskell exporter.\n\n"
    in writeFile path (header ++ 
                       hspp (simplifyParens
                             (functionsToHsModule 
                              (pathToModuleName path)
                              functions)))


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

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

-- | Shortcuts for Hs*** data constructors,
-- with lots of defaults for features I'm not using.

-- | There is no source location in the conventional sense.
srcLoc :: SrcLoc
srcLoc = SrcLoc {srcFilename = "", srcLine = 0, srcColumn = 0}
                -- {srcFileName = "<unknown", srcLine = 1, srcColumn = 1}

-- | A Haskell module.
hsModule :: String -> [HsImportDecl] -> [HsDecl] -> HsModule
hsModule name importDecls decls =
    HsModule srcLoc (Module name)  
                    Nothing -- :: Maybe [HsExportSpec]
                    importDecls 
                    decls

-- | A Haskell import declaration
hsImportDecl :: String -> HsImportDecl
hsImportDecl name =
    HsImportDecl {importLoc = srcLoc,
                  importModule = Module name,
                  importQualified = False,
                  importAs = Nothing,
                  importSpecs = Nothing}


-- | A function binding (declaration and definition)
hsFunBind :: [HsMatch] -> HsDecl
hsFunBind matches =
    HsFunBind matches

-- | Identifier, as the name of a function
hsIdent :: String -> HsName
hsIdent = HsIdent 

-- | Symbol, as the name of an operator
hsSymbol :: String -> HsName
hsSymbol = HsSymbol

-- | Pattern variable, as in the argument list of a function
-- (pattern match)

hsPVar :: String -> HsPat
hsPVar = HsPVar . hsIdent

-- | A variable used in an expression (rather than in an argument list)
hsVar :: String -> HsExp
hsVar = HsVar . UnQual . hsIdent

-- | An infix operator application.
-- Probably needs parentheses added.
hsOperate :: HsExp -> HsQOp -> HsExp -> HsExp
hsOperate left qop right =
    HsInfixApp left qop right

-- | A prefix function application.
-- Need to work some parentheses in here, probably.
hsCall :: HsExp -> [HsExp] -> HsExp
hsCall hfunc hargs = 
    case hargs of 
      [] -> 
          case hfunc of
            HsVar (UnQual (HsIdent name)) -> hfunc
            _ -> error ("hsCall: unexpected form of unary function: " ++
                        show hfunc)
      a : [] -> HsApp hfunc a
      a : as -> hsCall (HsApp hfunc a) as

-- | An infix operator
hsOp :: String -> HsQOp
-- hsOp name = HsQVarOp (UnQual (HsSymbol name))
hsOp = HsQVarOp . UnQual . hsSymbol

-- | A clause of a function binding
-- hsMatch :: ??

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

-- | Converting Sifflet to Haskell syntax tree

-- | Create a module from a module name and Functions.
functionsToHsModule :: String -> Functions -> HsModule
functionsToHsModule mname (Functions fs) =
    hsModule mname 
             [hsImportDecl "Sifflet.Data.Number"] -- sifflet-Haskell library
             (map functionToHsDecl fs)
 
-- | Create a declaration from a Function.
-- Needs work: infer and declare the type of the function.
functionToHsDecl :: Function -> HsDecl
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) ->
          -- forget about type declarations for now
          -- ...
          HsFunBind [HsMatch srcLoc
                             (hsIdent fname)
                             (map hsPVar args)
                             (HsUnGuardedRhs (exprToHsExp body))
                             [] -- decls (??)
                    ]
    
exprToHsExp :: Expr -> HsExp
exprToHsExp expr =
    case expr of
      EUndefined -> hsVar "undefined"
      ESymbol (Symbol s) -> hsVar s
      ELit v -> valueToHsExp v
      EIf c a b -> 
          HsIf (exprToHsExp c) (exprToHsExp a) (exprToHsExp b)
      EList es -> HsList (map exprToHsExp es)
      ECall (Symbol fname) args -> 
          case nameToHaskell fname of
            HsSymbol opName ->
                case args of
                  [left, right] -> 
                      HsParen (hsOperate (exprToHsExp left) 
                                         (hsOp opName)
                                         (exprToHsExp right))
                  _ -> error "exprToHsExp: operation does not have 2 operands"
            HsIdent funcName ->
                HsParen (hsCall (hsVar funcName) (map exprToHsExp args))

-- ... and somewhere we need to work in HsParen hsExp as needed :-(

valueToHsExp :: Value -> HsExp
valueToHsExp value =
    case value of
      VBool b -> HsCon (UnQual (HsIdent (if b then "True" else "False")))
      VChar c -> HsLit (HsChar c)
      -- Should negative numbers get wrapped in parentheses??
      VInt i -> HsLit (HsInt i)
      VFloat x -> HsLit (HsFrac (toRational x))
      VStr s -> HsLit (HsString s)
      VFun _ -> error "valueToHsLiteral: I don't know how to convert a VFun"
      VList vs -> HsList (map valueToHsExp vs)

-- | Map Sifflet names to Haskell names.
-- Returns the variant HsSymbol for operator names, HsIdent for others
-- (function names, variables, etc.).
-- This might need to be extended with fixity and associativity information,
-- but that can come later when I start to deal with parentheses.
nameToHaskell :: String -> HsName
nameToHaskell name =
    if elem name ["+", "-", "*", "/",
                   "==", "/=", "<", ">", "<=", ">=",
                   ":"]
    then HsSymbol name
    else 
        -- some special cases will need to be inserted here,
        -- for zero?, positive? negative?, at least;
        -- add1, sub1 too.
        HsIdent (case name of
                   "zero?" -> "eqZero"
                   "positive?" -> "gtZero"
                   "negative?" -> "ltZero"
                   _ -> name)

-- ------------------------------------------------------------------------
-- | Simplifying parentheses
-- This belongs elsewhere, since non-Haskelly things can also
-- be instances.

class HasParens a where
    simplifyParens :: a -> a

instance HasParens HsModule where
    simplifyParens (HsModule locus name exportDecls importDecls decls) =
        HsModule locus name exportDecls importDecls (map simplifyParens decls)

instance HasParens HsDecl where
    simplifyParens decl =
        case decl of
          HsFunBind [HsMatch locus fname args 
                     (HsUnGuardedRhs body)
                     []] ->
              HsFunBind [HsMatch locus fname args 
                         (HsUnGuardedRhs (simplifyParens body))
                         []]
          _ ->
              decl

instance HasParens HsExp where
    simplifyParens hexp =
        let t = simplifyParens
            ut = unpar . t
            unpar e =
                case e of
                  HsParen e' -> e'
                  _ -> e
        in case hexp of
             HsIf c a b -> HsIf (ut c) (ut a) (ut b)
             HsList es -> HsList (map t es)

             HsParen e -> 
                 if atomic e then e
                 else case e of
                        -- work needed here ...
                        _ -> hexp
             -- Infix operator application
             HsInfixApp left qop right ->
                 -- This *** needs work *** along the lines of Python.hs
                 HsInfixApp left qop right
             -- Function applications:
             -- (f a) b ---> f a b.
             -- So why put the parentheses around f a in the first place?
             HsApp (HsParen (HsApp hf ha)) hb ->
                 HsApp (HsApp hf ha) hb
             _ -> hexp

-- | Is an expression atomic?  Yes if it's a value, a boolean value
-- (i.e., the unary constructor True or False), or a literal; otherwise no.
-- Actually *any* unary constructor could be considered atomic,
-- but I'm not sure how to deal with this.  Not urgent,
-- since Sifflet export uses no unary constructors but True and False.

atomic :: HsExp -> Bool
atomic hexp =
    case hexp of
      HsVar (UnQual (HsIdent _)) -> True -- variable
      HsCon (UnQual (HsIdent _)) -> True -- unary constructors: True, False
      HsLit _ -> True                    -- literals
      HsList _ -> False                  -- list
      HsIf _ _ _ -> False                -- if expression
      HsInfixApp _ _ _ -> False
      HsApp _ _ -> False
      -- well what are the other cases?
      _ -> error ("atomic: don't know how to handle: " ++ show hexp)

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

-- | Facilities for testing

asModule :: [String] -> String
asModule strings = unlines ("module Test where" : strings)

test1 :: String
test1 = asModule [
                  -- "foo :: Int -> Int -> Int",
                  "foo x y = x + y"]

test2 :: String
test2 = asModule [
                  "foo1 x = bar (codd x)",
                  "foo2 = bar . codd"]

prettyDS :: [String] -> IO ()
prettyDS declStrings = prettyModule (asModule declStrings)

prettyES :: String -> IO ()
prettyES expString = prettyModule (asModule ["x = " ++ expString])

hspp :: (HsPretty.Pretty a) => a -> String
hspp = HsPretty.prettyPrint

prettyModule :: String -> IO ()
prettyModule string =
    case parseModule string of
         ParseOk m -> putStrLn (hspp m)
         ParseFailed loc msg -> putStrLn (show loc ++ ": " ++ msg)

prettyE :: Expr -> IO ()
prettyE expr =
    putStrLn (hspp (exprToHsExp expr))

prettyV :: Value -> IO ()
prettyV value =
    putStrLn (hspp (valueToHsExp value))

testParse :: String -> ParseResult HsModule
testParse string = parseModule string

testCallPrefix :: IO ()
testCallPrefix = prettyE $ ECall (Symbol "mod") [ELit (VInt 7), ELit (VInt 5)]

testCallInfix :: IO ()
testCallInfix = prettyE $ ECall (Symbol "+") [ELit (VInt 7), ELit (VInt 5)]

testFunBind :: Function -> IO ()
testFunBind f = putStrLn (hspp (simplifyParens (functionToHsDecl f)))

testExportModule :: String -> [Function] -> IO ()
testExportModule moduleName fs = 
    putStrLn (hspp (simplifyParens
                    (functionsToHsModule moduleName (Functions fs))))

-- | Test export of an example function, specified by name
testEF :: String -> IO ()
testEF = testFunBind . getExampleFunction