{-
Tock: a compiler for parallel languages
Copyright (C) 2008  University of Kent

This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation, either version 2 of the License, or (at your
option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

-- | Generate CHP code from the AST
--
-- These are the things that need to be done before the AST reaches this backend:
--
-- Need to convert anything that isn't a communication/PAR/ALT into a Continuation
-- Passing Style (CPS).  WHILEs become IFs in recursive PROCs.  SEQ replicators become
-- recursive PROCs.
--
-- Eventually, the code passed here should have only the following in SEQ blocks:
-- 
-- * Communications
--
-- * ALTs
--
-- * PARs
--
-- * assignments (from variables or function calls)
--
-- * process calls
--
-- It should never have SEQs nested in SEQs
module GenerateCHP where

import Control.Monad.State
import Control.Monad.Trans
import Data.Char
import Data.Generics (Data, showConstr, toConstr)
import Data.List
import Data.Maybe
import System.IO
import Text.Printf

import qualified AST as A
import CompState
import Errors
import EvalLiterals
import Metadata
import Pass
import Utils

-- Borrowed from GenerateCBased, and simplified:

-- A handle/string buffer, the current line, and indent stack (push at head)
type CGen = StateT (Either [String] Handle, String, [Int]) PassM

instance Die CGen where
  dieReport err = lift $ dieReport err
  
instance CSMR CGen where
  getCompState = lift getCompState

tell :: [String] -> CGen ()
tell x = do (hb, cur, curIndent:indentStack) <- get
            let cur' = replace ("\n","\n" ++ replicate curIndent ' ') (cur++concat x)
            let (cur'', prevLines)
                  = transformPair reverse reverse $
                     span (/= '\n') (reverse cur')
            hb' <- case hb of
                Left prev -> return $ Left (prev ++ lines prevLines)
                Right h -> do liftIO $ hPutStr h prevLines
                              return hb
            put (hb, cur'', curIndent:indentStack)

pushIndent :: CGen ()
pushIndent = modify $ \(hb, cur, indents) -> (hb, cur, length cur : indents)

popIndent :: CGen ()
popIndent = do
  (hb, cur, _:indents) <- get
  if all (== ' ') cur
    then put (hb, replicate (head indents) ' ', indents)
    else tell ["\n"] >> popIndent

withIndent :: CGen () -> CGen ()
withIndent f = pushIndent >> f >> popIndent

genName :: A.Name -> CGen ()
genName n = let unders = [if c == '.' then '_' else c | c <- A.nameName n] in
  -- Prefix underscore to anything beginning with upper-case:
  if isUpper (head unders)
    then tell ["_",unders]
    else tell [unders]


genMissing = flip genMissing' ()

genMissing' :: Data a => String -> a -> CGen()
genMissing' s x = tell ["(error \"",s,": ", showConstr $ toConstr x,"\")"] -- for now, everthing is missing!
  -- TODO in future generate a Die error

genHeader :: CGen ()
genHeader
  = tell ["import GHC.Prim\n"
         ,"import Control.Concurrent.CHP\n"
         ,"\n"
         ]

generateCHP :: Handle -> A.AST -> PassM ()
generateCHP h tr
  = flip evalStateT (Right h, "", [0]) $ genHeader >> genAST tr

genAST :: A.AST -> CGen ()
genAST = genStructured False return

genStructured :: Data a => Bool -> (a -> CGen()) -> A.Structured a -> CGen ()
genStructured False genOnly (A.Spec m spec scope)
  = do genSpec spec
       genStructured False genOnly scope
genStructured True genOnly (A.Spec m spec scope)
  = do tell ["let "]
       withIndent $ genSpec spec
       tell ["in "]
       withIndent $ genStructured True genOnly scope
genStructured addLet genOnly (A.ProcThen m proc scope) = genMissing "genStructured ProcThen"
  >> tell ["λn"] >> genStructured addLet genOnly scope
genStructured _ genOnly (A.Only m item) = genOnly item
genStructured addLet genOnly (A.Several m strs) = mapM_ (genStructured addLet genOnly) strs

-- | Should output a spec, or nothing
genSpec :: A.Specification -> CGen ()
genSpec (A.Specification _ n (A.Proc _ _ params body))
  = do genName n
       tell [" :: "]
       mapM doFormalAndArrow params -- TODO handle return vals
       tell [" CHP ()\n"]
       genName n
       sequence [genName pn >> tell [" "] | A.Formal _ _ pn <- params]
       tell ["= "]
       withIndent $ genProcess (fromJust body)
  where
    doFormalAndArrow :: A.Formal -> CGen ()
    doFormalAndArrow (A.Formal _ t _)
      = genType t >> tell [" -> "]     
genSpec (A.Specification _ n (A.Declaration _ t))
  = do genName n
       tell [" :: "]
       genType t
       tell ["\n"]
       genName n
       tell [" = error \"Variable ", A.nameName n, " used uninitialised\"\n"]
{-
genSpec (A.Specification _ n (A.IsExpr _ _ t e))
  = do genName n
       tell [" :: "]
       genType t
       tell ["\n"]
       genName n
       tell [" = "]
       genExpression e
       tell ["\n"]
-}
genSpec _ = genMissing "genSpec" >> tell ["\n"]

genProcess :: A.Process -> CGen ()
genProcess (A.Seq _ str) = tell ["do "] >> withIndent (genStructured True genProcess str)
genProcess (A.ProcCall _ n params)
  = do genName n
       sequence [tell [" "] >> genActual p | p <- params]
       tell ["\n"]
genProcess p = genMissing' "genProcess" p >> tell ["\n"]

genActual :: A.Actual -> CGen ()
genActual (A.ActualVariable v) = genVariable v
genActual (A.ActualExpression e) = genExpression e

genVariable :: A.Variable -> CGen ()
genVariable (A.Variable _ n) = genName n
genVariable v = genMissing' "genVariable" v

genExpression :: A.Expression -> CGen ()
genExpression (A.Literal _ t repr)
  = do tell ["(("]
       genLiteralRepr repr
       tell [")::"]
       genType t
       tell [")"]
genExpression (A.ExprVariable _ v) = genVariable v
genExpression (A.True _) = tell ["True"]
genExpression (A.False _) = tell ["False"]
genExpression e = genMissing' "genExpression" e

seqComma :: [CGen ()] -> CGen ()
seqComma ps = sequence_ $ intersperse (tell [","]) ps

genLiteralRepr :: A.LiteralRepr -> CGen ()
genLiteralRepr (A.ArrayListLiteral _ (A.Several _ elems))
  = do tell ["newListArray (0," ++ show (length elems - 1) ++ ") ["]
       seqComma $ map genArrayElem elems
       tell ["]"]
genLiteralRepr (A.IntLiteral _ str) = tell [str]
genLiteralRepr (A.RealLiteral _ str) = tell [str]
genLiteralRepr (A.ByteLiteral m str)
  = tell ["\'"] >> genByteLiteral m str >> tell ["\'"]
genLiteralRepr _ = genMissing "genLiteralRepr"

genByteLiteral :: Meta -> String -> CGen ()
genByteLiteral m s
    =  do c <- evalByte m s
          tell [convByte c]

convByte :: Char -> String
convByte '\'' = "\\'"
convByte '"' = "\\\""
convByte '\\' = "\\\\"
convByte '\r' = "\\r"
convByte '\n' = "\\n"
convByte '\t' = "\\t"
convByte c
  | o == 0              = "\\0"
  | (o < 32 || o > 127) = printf "\\%03o" o
  | otherwise           = [c]
  where o = ord c

genArrayElem :: A.Structured A.Expression -> CGen ()
genArrayElem (A.Only _ e) = genExpression e
genArrayElem _ = genMissing "genArrayElem"

genType :: A.Type -> CGen ()
genType A.Bool = tell ["Bool"]
genType A.Byte = tell ["Word8"]
genType A.UInt16 = tell ["Word16"]
genType A.UInt32 = tell ["Word32"]
genType A.UInt64 = tell ["Word64"]
genType A.Int8 = tell ["Int8"]
genType A.Int16 = tell ["Int16"]
genType A.Int = tell ["Int32"]
genType A.Int32 = tell ["Int32"]
genType A.Int64 = tell ["Int64"]
genType A.Real32 = tell ["Float"]
genType A.Real64 = tell ["Double"]
genType (A.Array _ t) = tell ["(IOUArray Int32 "] >> genType t >> tell [")"]
genType (A.List t) = tell["(Seq "] >> genType t >> tell [")"]
genType (A.ChanEnd dir attr inner)
  = do tell ["(", case dir of
         A.DirInput -> "Chanin"
         A.DirOutput -> "Chanout"]
       tell ["(IOUArray Word8)"]
       -- genType inner
       tell [")"]
genType (A.Chan attr inner)
  = do tell ["(One2OneChannel (IOUArray Word8))"]
       -- genType inner
genType _ = genMissing "genType"

--TODO compile IFs into case.  And case into case.