PyLibGen.hs

{-# LANGUAGE GADTs #-}

import Data.List
import Data.Monoid
import Data.Typeable
import Data.Dynamic
import GHC.Err

import GHC.Prim


data PyVal = PyVal { valTy :: TypeRep, val :: String } | ErrorMsg String

data PyStatement where
  Import :: String -> PyStatement
  RawStmtm :: String -> PyStatement
  RawVal :: PyVal -> PyStatement

renderPyStatement :: PyStatement -> String
renderPyStatement (Import a) = "import " <> a
renderPyStatement (RawStmtm a) = a
renderPyStatement (RawVal (PyVal _ s)) = s
renderPyStatement (RawVal (ErrorMsg msg)) = error msg

-- ToDo: Ensure imports are Import
data PyLib = PyLib { imports :: [PyStatement]
                   , functions :: [PyFunction] }

data PyFunction = LocalFunction { arguments :: [String]
                                , name :: String
                                , funTy :: TypeRep
                                , statements :: [PyStatement] }
                | ImportedFunction { name :: String
                                   , funTy :: TypeRep }


f :: PyFunction
f = LocalFunction { arguments = ["a", "b", "c"]
                  , name = "f"
                  , funTy = typeRep (Proxy :: Proxy (Int -> Int -> Int -> Int))
                  , statements = [RawStmtm "return (a + b + c)"] }


-- From stdlib
pyPrint :: PyFunction
pyPrint = ImportedFunction { name = "print"
                           , funTy = typeRep (Proxy :: Proxy (Dynamic -> ()))}

-- For now, only things that have the same representation in
-- Haskell and in Python (e.g. Integers)
toPyVal :: (Typeable a, Show a) => a -> PyVal
toPyVal a = PyVal { valTy = typeOf a, val = show a }

funToVal :: PyFunction -> PyVal
funToVal f = PyVal { valTy = funTy f, val = name f}

py1 :: PyVal
py1 = toPyVal (1 :: Int)
py2 :: PyVal
py2 = toPyVal (2 :: Int)
py3 :: PyVal
py3 = toPyVal (3 :: Int)

fVal :: PyVal
fVal = funToVal f
printVal = funToVal pyPrint


showTyR :: TypeRep -> String
showTyR t = showsTypeRep t ""

arity :: TypeRep -> Int
arity rep = case (splitTyConApp rep) of
                (tc, [arg, result]) | tc == funcTyCon -> 1 + (arity result)
                _ -> 0
  where funcTyCon = typeRepTyCon $ typeRep (Proxy :: Proxy (Int -> Int))

applyPyVal :: PyVal -> PyVal -> PyVal
applyPyVal _ (ErrorMsg emsg) = ErrorMsg emsg
applyPyVal (ErrorMsg emsg) _ = ErrorMsg emsg
applyPyVal (PyVal {valTy = ft, val = nm }) (PyVal {valTy = vt, val = v })
 = case (funResultTy ft vt) of
     Just rt -> newVal rt
     Nothing -> case typeRepArgs ft of
                  [tr, rt] | typeRepTyCon tr == tyConOfDynamic -> newVal rt 
                  _ -> ErrorMsg ( "cannot apply function " <> nm <> " of type "
                                <> (showTyR ft) <> " to " <> v <> " of type "
                                <> showTyR vt )
  where newVal rt = PyVal { valTy = rt
                          , val = case arity rt of
                                    0 -> appl 
                                    _ -> "partial(" <> nm <> "," <> v <> ")"}
        appl = nm <> "(" <> v <> ")"
    
        tyConOfDynamic = typeRepTyCon $ typeRep (Proxy :: Proxy Dynamic)


renderPyFunc :: PyFunction -> String
renderPyFunc (LocalFunction {name = nm, arguments = args, statements = stmts, funTy = ty })
  = unlines $ [ ""
              ,  "# " <> show ty <> " of arity " <> show (arity ty)
              ,  "def " <> nm <> "(" <> (intercalate "," args) <> ")" <> ":"
              , unlines $ map ((<>) "  " . renderPyStatement) stmts]

myProg :: PyLib
myProg = PyLib { imports = map Import [ "datetime", "math", "random" ]
               , functions = [f] }

genPyLib :: PyLib -> String
genPyLib (PyLib { imports = imp, functions = functions }) =
  concat [ renderPyStatement $ RawStmtm "from functools import partial\n"
         , unlines $ map renderPyStatement imp
         , unlines $ map renderPyFunc functions]

main :: IO ()
main = do putStrLn $ genPyLib myProg
          putStrLn $ renderPyStatement $
                     RawVal $ applyPyVal printVal
                            $ applyPyVal (applyPyVal (applyPyVal fVal py1) py2) py3