%
% Copyright (C) 1997 Thomas Nordin and Alastair Reid
%

\begin{code}

module Proc
	( Proc, ppProc
	, genProc
	) where

import Maybe( maybeToList, fromJust, isJust )
import List( unzip4 )
import Pretty
import PrettyUtils
	( indent, textline
	, sepdBy, joinedBy
        , vcatMap
	, ppCIf, ppCDecl
	, ppCase, ppCases, ppIf, ppTuple, ppApply, ppRecord
	, ppBind, ppReturn
	)

import Name
import Type( Type(..), isPureType, ppType )
import DIS( DIS(..), ppDIS, ppDIS' ,simplify )
import Decl
import Casm
import NameSupply
import Target( Target )
--import NHCBackend (genProcNHC)

#if !defined(__HASKELL98__)
#define fmap map
#endif

\end{code}

%************************************************************************
%*									*
\subsection{Generating function declarations}
%*									*
%************************************************************************


\begin{code}

type Proc = (Sig, Call, CCode, Fail, Result)

\end{code}

\begin{code}

ppProc :: Proc -> Doc
ppProc ((n, t), ds, cexp, fs, res) = 
     text "%fun" <+> text n <+> text "::" <+> ppType t 
  $$ text "%call" <+> hsep (map (ppDIS' True) ds) 
  $$ text "%code" <+> prefix "% " cexp
  $$ hsep (map (\(a, b) -> text "%fail" <+> doubleQuotes (text a) 
                                        <+> doubleQuotes (text b)) fs)
  $$ text "%result" <+> ppDIS' True res
  where prefix :: String -> [String] -> Doc
        prefix pre = foldl (\x y-> x $$ text pre <> text y) empty

\end{code}

@genProc target gcSafe proc@ returns a triple @(hcode, ccode, entry)@
where

o @hcode@ is a Haskell function (and type declaration) which marshalls
  its arguments, performs a casm and unmarshalls the results.

o @ccode@ is any C code that has to be generated as part of the casm.
  (It is empty if the target is GHC.)

o @entry@ is a Hugs-specific piece of C --- the entry for the primtable.

\begin{code}

genProc :: Target -> Bool -> Proc -> (Doc, Doc, Doc)
--genProc NHC    gcSafe proc   = genProcNHC proc
genProc target gcSafe ((name, typ), ds, ctext, ofs, res)
  = ( text name <+> text "::" <+> ppType typ			
      $$ text name <+> hsep av   <+> text "="  			
      $$ indent (
             wrap 
      	   $ unpack						
      	   $ mkResult
           $ call 
      	   )
      $$ hdecl
    , cdecl
    , entry <> comma
    )
 where
    wrap d = if isPureType typ then unsafe d else d

    unsafe :: Doc -> Doc
    unsafe d = text "unsafePerformIO(" $$ indent d <> text ")"

    (av, unpack, adecls, as)               = marshallDISs ds
    (pack, rv, rdecls, rs)		   = unmarshallDIS res
    (fdecls, fs, if_no_failc, if_no_failh) = failureHandling ofs
    results                                = rs ++ fs

    casm = Casm ("prim_" ++ name) gcSafe 
                (adecls <> rdecls <> fdecls) 
	        (vcatMap text ctext $$ if_no_failc)
                as
                results
    (call, hdecl, cdecl, entry) = ppCasm target casm

    tuple = ppTuple [ text v | Param v _ k <- results ]

    -- The unmarshalling code avoids generating code of the
    -- form "call >>= \ (res1, ... resm) -> (res1, ... resm)"
    -- by performing a very simple-minded test.
    mkResult call
      | null ofs && render tuple == render rv && render (pack empty) == ""
      = call
      | otherwise
      = call `ppBind` (tuple, if_no_failh (pack $ ppReturn rv))

\end{code}

%************************************************************************
%*									*
\subsection{Error Handling}
%*									*
%************************************************************************

\begin{code}
    
failureHandling :: Fail -> (Doc, [Param], Doc, Doc -> Doc)
failureHandling [] = (empty, [], empty, id)
failureHandling rs = 
  ( ppCDecl "int" fn $$ ppCDecl "char*" fs
  , [Param fn fn Int, Param fs fs Addr]
  , ppCIf [ ( textline [ fn, "== (", p, ")" ]	-- ***FIXED assignment/test bug!
            , textline [ fs, "=", s, ";" ] 
            )
          | (p, s) <- rs ] 
          (Just (textline [ fn, "= 0;" ]))
  , \d -> ppIf (textline ["(", fn, "/= 0)"])
               (textline ["unmarshall_string_", fs, ">>= fail . userError"])
               d
  )
  where
    fn = "gc_failed"
    fs = "gc_failstring"

\end{code}


%************************************************************************
%*									*
\subsection{Generating the packing and unpacking of DISs}
%*									*
%************************************************************************

\begin{code}

marshallDISs  :: [DIS] -> ([Doc], Doc -> Doc, Doc, [Param])
marshallDISs ds = (ns, foldr (.) id ms, hsep decls, concat pss)
 where
  (ns, ms, decls, pss) = unzip4 foo
  (foo, _) = initNS (mapM (marshall.simplify) ds) (nameSupply "gc_arg")

unmarshallDIS :: DIS   -> (Doc -> Doc, Doc, Doc, [Param])
unmarshallDIS d = foo
 where
  (foo, _) = initNS ((unmarshall.simplify) d) (nameSupply "gc_res")

\end{code}


%************************************************************************
%*									*
\subsection{Marshalling code}
%*									*
%************************************************************************

@marshall dis@ returns a triple @(root, unpack, leaves)@ where

****EEEEEK!
[Based on what is written below, I think it actually generates a 4-tuple,
  (pat,unpack,decls,leaves)
]

o @pat@ is a pattern to match against
o @unpack@ is the code to do the unpacking
o @decls@ is a bunch of C declarations for the variables it unpacks into
o @leaves@ is the list of values it generates

eg @marshall (%%Int (declare "int" x), %%Float (declare "float" "0.0"),
               <fromfoo/tofoo> (int z))@
   returns something like this:
@
  ( (x,y,gc_arg1)
  , \ rest -> case fromfoo gc_arg1 of { z -> rest }
  , text "int x; float arg2; int z;"
  , [ Param "x" "x" Int, Param "arg2" "0.0" Float), Param "z" "z" Int ]
  )
@

****EEEEEK!
[This example needs changing to reflect the new DIS structure.]

\begin{code}

marshall :: DIS -> NSM (Doc, Doc -> Doc, Doc, [Param])

marshall (Var v) -- no baseTy info so it's not a casm argument (very weird)
  = return ( text v, id, empty, [])

marshall (Apply (BaseDIS k) [ Declare cty (Var v) ]) 
  = return ( text v, id, ppCDecl cty v, [Param v v k])

marshall (Apply (BaseDIS k) [ Declare cty (Exp e) ]) = do
  v <- getNewName
  return ( text v, id, empty, [Param v e k])

marshall Tuple = do             -- trivial case, probably not used
  return (ppTuple [], id, empty, [])

marshall (Apply Tuple ds) = do
  bits <- mapM marshall ds
  let (ns, ms, decls, pss) = unzip4 bits
  return (ppTuple ns, compose ms, hsep decls, concat pss)

marshall (Apply (Constructor c) ds) = do
  bits <- mapM marshall ds
  let (ns, ms, decls, pss) = unzip4 bits
  return (ppApply (text c) ns, compose ms, hsep decls, concat pss)

marshall (Apply (Record c fs) ds) = do
  bits <- mapM marshall ds
  let (ns, ms, decls, pss) = unzip4 bits
  return (ppRecord (text c) (map text fs) ns, compose ms, hsep decls, concat pss)

marshall (Apply (UserDIS _ n1 n2) ds) = do
--error ("Unrecognised userDIS <" ++n1++"/"++n2++">")
  bits <- mapM marshall ds
  let (ns, ms, decls, pss) = unzip4 bits
  return (ppApply (text n1) ns, compose ms, hsep decls, concat pss)

marshall (Apply (BaseDIS b) ds) = 
  error ("Unrecognised baseDIS %%"++show b)

marshall (Apply (Var ('%':t)) ds)
  | t == "Maybe"
  = case ds of [ Exp nothing, just ] -> marshallMaybe (text nothing) just
  | t == "Foreign"
  = case ds of -- This is just a special case of giving a kind
    [Exp cty, Var v, Exp free] 
      -> return (text v, id, ppCDecl cty v, [Param v v (Foreign free)])
    _ -> error "Malformed %Foreign"
  | otherwise
  = error ("Unrecognised DIS %" ++ t)

marshall dis@(Apply (Var t) [Var t']) = error $ "Don't know how to marshall " ++ show (ppDIS dis)

marshall (Apply (Var t) ds) = do
  nm   <- fmap text getNewName
  bits <- mapM marshall ds
  let (ns, ms, decls, pss) = unzip4 bits
  return (nm, \e -> ppApply fun [nm] `ppBind` (ppTuple ns, compose ms e), hsep decls, concat pss)
 where
  fun = text ("marshall_" ++ t)

marshall dis = error $ "Don't know how to marshall " ++ show (ppDIS dis)

\end{code}

The marshalling of @%Maybe nothing just@ is a little different.
We generate code like this:
@
      case x of 
      Nothing -> return nothing -- should be a tuple
      Just j  -> <unpack j> >>= \ ... ->
                 return (j1,..jn)
                                             >>= \ (j1 ... jn) -> <hole>
@
where @j1@ ... @jn@ are the leaf vars of the Just dis.

\begin{code}

marshallMaybe :: Doc -> DIS -> NSM (Doc, Doc -> Doc, Doc, [Param])
marshallMaybe nothing just = do
      nm <- fmap text getNewName
      (j, unpackj, decls, ps) <- marshall just
      let js = ppTuple [ text n | Param n _ _ <- ps ]
	  unpack = ppCases nm
		 [ (text "Nothing",            ppReturn nothing)
		 , (ppApply (text "Just") [j], unpackj (ppReturn js))
		 ]
      return (nm, \ hole -> parens unpack `ppBind` (js, hole), decls, ps)

\end{code}

%************************************************************************
%*									*
\subsection{UnMarshalling code}
%*									*
%************************************************************************

@unmarshall dis@ returns a quadruple @(pack, returnValue, decls, leaves)@ where

o @decls@ is a bunch of C declarations for resturn values

o @leaves@ is a list of parameters that should be returned from the casm.

o @pack@ is an expression builder which constructs parts of the result
  (by calling user marshalling code).   It is of the form:

  \ hole ->
       text "unmarshall_T1 x1 >>= \ y1 ->"
    $$ text "unmarshall_T2 x2 >>= \ y2 ->"
    $$ hole

o @returnValue@ is an expression which builds the return values from the
  @leaves@.

\begin{code}

unmarshall :: DIS -> NSM (Doc -> Doc, Doc, Doc, [Param])

unmarshall (Var v) -- no kind info so it's not a casm argument
  = return ( id, text v, empty, [])

unmarshall (Apply (BaseDIS k) [ Declare cty (Var v) ])
  = return ( id, text v, ppCDecl cty v, [Param v v k])

unmarshall (Apply (BaseDIS k) [ Declare cty (Exp e) ]) = do
  v <- getNewName
  return ( id, text v, empty, [Param v e k])

unmarshall Tuple = do
  return ( id, ppTuple [], empty, concat [])

unmarshall (Apply Tuple ds) = do
  bits <- mapM unmarshall ds
  let (packs, ms, decls, pss) = unzip4 bits
  return ( compose packs, ppTuple ms, hsep decls, concat pss)

unmarshall (Apply (Constructor c) ds) = do
  bits <- mapM unmarshall ds
  let (packs, ms, decls, pss) = unzip4 bits
  return (compose packs, ppApply (text c) ms, hsep decls, concat pss)

unmarshall (Apply (Record c fs) ds) = do
  bits <- mapM unmarshall ds
  let (packs, ms, decls, pss) = unzip4 bits
  return (compose packs, ppRecord (text c) (map text fs) ms, hsep decls, concat pss)

unmarshall (Apply (UserDIS _ n1 n2) ds) = 
  error ("Unrecognised userDIS <" ++n1++"/"++n2++">")

unmarshall (Apply (BaseDIS b) ds) = 
  error ("Unrecognised baseDIS %%"++show b)


unmarshall (Apply (Var ('%':t)) ds)
  | t == "Maybe"
  = case ds of [ Exp nothing, just ] -> unmarshallMaybe (text nothing) just
  | t == "Foreign"
  = case ds of -- This is just a special case of giving a kind
    [Exp cty, Var v, Exp free] 
      -> return (id, text v, ppCDecl cty v, [Param v v (Foreign free)])
    _ -> error "Malformed %Foreign"
  | otherwise
  = error ("Unrecognised DIS %" ++ t)

unmarshall dis@(Apply (Var t) [Var t']) = error $ "Don't know how to unmarshall " ++ show (ppDIS dis)

unmarshall (Apply (Var t) ds) = do
  nm   <- fmap text getNewName
  bits <- mapM unmarshall ds
  let (packs, ms, decls, pss) = unzip4 bits
      pack c = ppApply fun ms `ppBind` (nm, c)
  return (compose packs . pack, nm, hsep decls, concat pss)
 where
  fun = text ("unmarshall_" ++ t)

unmarshall dis = error $ "Don't know how to unmarshall " ++ show (ppDIS dis)

\end{code}

Again, the unmarshalling of @%Maybe nothing just@ is a little different.
We generate code like this:
@
  if (nothing == (j1, ...jn))
  then return Nothing
  else <pack j1 .. jn>
       return Just ( ... )              >>= \ v -> <hole>
@
where @j1@ ... @jn@ are the leaf vars of the Just dis.

\begin{code}

unmarshallMaybe :: Doc -> DIS -> NSM (Doc -> Doc, Doc, Doc, [Param])
unmarshallMaybe nothing just = do
  nm   <- fmap text getNewName
  (pack, m, decls, ps) <- unmarshall just
  let js = [ text n | Param n _ _ <- ps ]
  return ( \ hole ->
             parens (
               ppIf (nothing <+> text "==" <+> ppTuple js)
                  (text "return Nothing")
                  (pack $ ppReturn (ppApply (text "Just") [m])))
             `ppBind` (nm, hole)
         , nm
	 , decls
         , ps
         )

\end{code}


%************************************************************************
%*									*
\subsection{Utilities}
%*									*
%************************************************************************

\begin{code}

compose :: [ (a -> a) ] -> (a -> a)
compose = foldr (.) id 

\end{code}

%************************************************************************
%*									*
\subsection{Examples}
%*									*
%************************************************************************

\begin{code}

-- type Proc = (Sig, Call, [String], Fail, Result)

proc1 :: Proc
proc1 = 
    ( ("foo", TypeVar "Int" `Arrow` TypeVar "Float")
    , [tuple [int "arg1", int "arg2"]]
    , ["res=(float)(arg1+arg2);"]
    , [("res>42","\"loser\"")]
    , tuple [flt "res1", int "res2"]
    )
 where
  int nm   = Apply (BaseDIS Int) [Declare "int" (Var nm)]
  flt nm   = Apply (BaseDIS Float) [Declare "float" (Var nm)]
  tuple ds = Apply Tuple ds


tst :: Proc -> IO ()
tst p = case genProc Hugs False p of { (d1,d2,d3) ->
        putStr $ render (d1 $$ d2 $$ d3)
        }

\end{code}