{-# OPTIONS -fglasgow-exts #-}

module Perl
            (runPerl, PerlResult (..), evalString, evalStringThrow,
             PerlSV, PerlHV, PerlAV,
             getVar, newVar, 
             setIntVal, getIntVal,
             setStringVal, getStringVal, 
             setDoubleVal, getDoubleVal,
             newHash, storeHash, fetchHash,
             newArray, makeArray, storeArray, fetchArray,
             hashToRef, refToHash,
             arrayToRef, refToArray,
             useModule, runSub) where

import Foreign hiding (newArray)
import Foreign.C
import Control.Exception
import Data.List

#include <EXTERN.h>
#include <perl.h>

runPerl f = bracket_ initPerl' cleanupPerl f
               where initPerl' = initPerl ["-e","-e","0"]

#def PerlInterpreter *my_perl;
#def void xs_init(pTHX);

data PerlResult = SV PerlSV | Fail String

data PerlAV_

type PerlAV = Ptr PerlAV_

data PerlHV_

type PerlHV = Ptr PerlHV_

data PerlSV_

type PerlSV = Ptr PerlSV_


#{def
  void initPerl_(int argc, char *argv[]) 
  { 
     my_perl=perl_alloc(); 
     perl_construct(my_perl);
     perl_parse(my_perl,xs_init,argc,argv,NULL);
     perl_run(my_perl);
  }
 }
foreign import ccall initPerl_ :: CInt -> Ptr CString -> IO ()

initPerl :: [String] -> IO ()
initPerl argv = do let argc_ = fromIntegral (length argv)
                   argv_ <- mapM newCString argv
                   withArray argv_ $ \argv__ -> initPerl_ argc_ argv__

#{def
  inline SV* getVar_(char *name)
  {
     return get_sv(name,TRUE);
  }
 }
foreign import ccall getVar_ :: CString -> IO PerlSV

getVar name = withCString name getVar_

#{def
  inline SV* newVar_()
  {
     return newSV(0);
  }
 }
foreign import ccall newVar_ :: IO PerlSV

newVar = newVar_

#{def
  inline AV* newArray()
  {
     AV* av = newAV();
     return av;
  }
 }

foreign import ccall newArray :: IO PerlAV
 
#{def
  inline AV* makeArray_(int count, SV** vals)
  {
     return av_make(count,vals);
  }
 }

foreign import ccall makeArray_ :: CInt -> Ptr PerlSV -> IO PerlAV

makeArray :: [PerlSV] -> IO PerlAV
makeArray args = withArray args $ \args_ -> 
                   makeArray_ (fromIntegral $ length args) args_


#{def
   inline void storeArray_(AV *av, int ind, SV *sv)
   {
      av_store(av, ind, sv);
   }
 }

foreign import ccall storeArray_ :: PerlAV -> CInt -> PerlSV -> IO ()

storeArray av ind sv = storeArray_ av (fromIntegral ind) sv

#{def
   inline SV* fetchArray_(AV* av, int ind)
   {
      return *(av_fetch(av, ind, 0));
   }
 }

foreign import ccall fetchArray_ :: PerlAV -> CInt -> IO PerlSV

fetchArray av ind = fetchArray_ av (fromIntegral ind)


#{def
  inline HV* newHash_()
  {
     HV* hv = newHV();
//     sv_2mortal((SV*) hv);
     return hv;
  }
 }

foreign import ccall newHash_ :: IO PerlHV

newHash = newHash_

#{def
   inline void storeHash_(HV *hv, char *key, SV *sv)
   {
      hv_store(hv, key, strlen(key), sv, 0);
   }
 }

foreign import ccall storeHash_ :: PerlHV -> CString -> PerlSV -> IO ()

storeHash hv str sv = withCString str (\cstr -> storeHash_ hv cstr sv)

#{def
   inline SV* fetchHash_(HV* hv, char* key)
   {
      return *(hv_fetch(hv, key, strlen(key), 0));
   }
 }

foreign import ccall fetchHash_ :: PerlHV -> CString -> IO PerlSV

fetchHash hv str = withCString str (\cstr -> fetchHash_ hv cstr)

#{def
   inline SV* hashToRef(HV* hv)
   {
      return newRV((SV*) hv);
   }
 }

foreign import ccall hashToRef :: PerlHV -> IO PerlSV

#{def
   inline HV* refToHash(SV* sv)
   {
      return (HV*) SvRV(sv);
   }
 }

foreign import ccall refToHash :: PerlSV -> IO PerlHV

#{def
   inline SV* arrayToRef(AV* av)
   {
      return newRV((SV*) av);
   }
 }

foreign import ccall arrayToRef :: PerlAV -> IO PerlSV

#{def
   inline AV* refToArray(SV* sv)
   {
      return (AV*) SvRV(sv);
   }
 }

foreign import ccall refToArray :: PerlSV -> IO PerlAV


#{def
  inline void setIntVal_(SV *sv,int v)
  {
     sv_setiv_mg(sv,v);
  }
 }


foreign import ccall setIntVal_ :: PerlSV -> CInt -> IO ()

setIntVal sv i = setIntVal_ sv (fromIntegral i)

#{def
  inline void setDoubleVal_(SV *sv,double v)
  {
     sv_setnv_mg(sv,v);
  }
 }


foreign import ccall setDoubleVal_ :: PerlSV -> CDouble -> IO ()

setDoubleVal sv v = setDoubleVal_ sv (fromRational $ toRational v)

#{def
  inline void setStringVal_(SV *sv,char *s)
  {
     sv_setpv_mg(sv,s);
  }
 }
foreign import ccall setStringVal_ :: PerlSV -> CString -> IO ()

setStringVal sv str = withCString str (setStringVal_ sv)


#{def
  inline int getIntVal_(SV *sv) 
  {
     return SvIV(sv);
  }
 }
foreign import ccall getIntVal_ :: PerlSV -> IO CInt

getIntVal sv = getIntVal_ sv >>= return.fromIntegral

#{def
  inline double getDoubleVal_(SV *sv) 
  {
     return SvNV(sv);
  }
 }
foreign import ccall getDoubleVal_ :: PerlSV -> IO CDouble

getDoubleVal sv = getDoubleVal_ sv >>= return.fromRational.toRational

#{def
  inline char *getStringVal_(SV *sv)
  {
     return SvPV_nolen(sv);
  }
 }
foreign import ccall getStringVal_ :: PerlSV -> IO CString

getStringVal sv = getStringVal_ sv >>= peekCString

#{def
  inline SV* evalString_(char *str)
  {
     return eval_pv(str,FALSE);
  }
}
foreign import ccall evalString_ :: CString -> IO PerlSV

#{def
  inline SV* errSV()
  {
     return ERRSV;
  }
 }
foreign import ccall errSV :: IO PerlSV

#{def
  inline int getBoolVal_(SV *sv)
  {
     return SvTRUE(sv);
  }
 }
foreign import ccall getBoolVal_ :: PerlSV -> IO CInt

getBoolVal sv = getBoolVal_ sv >>= return.toBool

evalString str = withCString str $ \cstr ->
                   do res <- evalString_ cstr
                      errsv <- errSV
                      waserror <- getBoolVal errsv
                      if waserror then do errstr <- getStringVal errsv
                                          return (Fail errstr)
                                  else return (SV res)

evalStringThrow str 
 = do res <- evalString str
      case res of
        SV sv -> return sv
        Fail reason -> ioError (userError (reason++"Was running: "++str++"\n"))


#{def
  SV* runSub_(char* name, int argcount, SV* args[])
  {
      int i;
      SV* ret;
      dSP;                            /* initialize stack pointer         */
      ENTER;                          /* everything created after here    */
      SAVETMPS;                       /* ...is a temporary variable.      */
      PUSHMARK(SP);                   /* remember the stack pointer       */
      for(i=0;i<argcount;i++)
	      XPUSHs(args[i]);        /* push the argument onto the stack */
      PUTBACK;                        /* make local stack pointer global  */
      perl_call_pv(name, G_SCALAR);   /* call the subroutine              */
      SPAGAIN;                        /* refresh stack pointer            */
                                      /* pop the return value from stack  */
      ret = POPs;
      PUTBACK;
      // FREETMPS;                       /* free that return value           */
      LEAVE;                          /* ...and the XPUSHed "mortal" args.*/
      return ret;
  }
 }

foreign import ccall runSub_ :: CString -> Int -> Ptr PerlSV -> IO PerlSV

runSub :: String -> [PerlSV] -> IO PerlSV
runSub name args = do let count = fromIntegral (length args)
                      withCString name $ \name_ -> 
                        withArray args $ \args_ -> runSub_ name_ count args_

useModule :: String -> Maybe [String] -> IO ()
useModule name Nothing = do _ <- evalStringThrow $ "use "++name++";"
                            return ()
useModule name (Just imports) 
    = do _ <- evalStringThrow $ "use "++name++" ("
                             ++ concat (intersperse " " imports) ++ ");"
         return ()

#{def
  void cleanupPerl()
  {
     perl_destruct(my_perl);
     perl_free(my_perl);
  }
 }
foreign import ccall cleanupPerl :: IO ()