-- Create a Haskell module out of the parsed Edoc XML.

module Language.Edoc.Xml2Hs.Haskell where

import Language.Haskell.Syntax
import Language.Haskell.Pretty
import Data.Char
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad
import Control.Monad.State

import Language.Edoc.Xml2Hs.Type

-- A State monad for the converter.

data EH = EH {
  stateCnt :: Int                           -- unique number generator
 ,ldMap :: M.Map LDMap ErlType              -- map for localdefs 
 ,ctxSet :: S.Set (String, [String])        -- set for type contexts (Class, variables)
}

initEH = EH {
  stateCnt = 1
 ,ctxSet = S.empty
 ,ldMap = M.empty}

data LDMap = T String | A String deriving (Eq, Ord, Show)

getCnt :: EHM Int
                
getCnt = do     
  c <- gets stateCnt
  st <- get       
  put st {stateCnt = c + 1}
  return c

type EHM a = State EH a



-- Create a Haskell module out of the parsed edoc XML.

-- Utility functions.

renameMod "" = ""
renameMod (m:odule) = toUpper m : renameMod' odule where
  renameMod' "" = ""
  renameMod' ('.':o:dule) = '.' : toUpper o : renameMod' dule
  renameMod' (o:dule) = o : renameMod' dule

renameType "" = ""
renameType (t:ype) = toUpper t : ype

renameFun "" = ""
renameFun (f:unc) = toLower f : unc

funName ef = renameFun (ef_name ef) ++ "'" ++ show (ef_arity ef)

nullLoc = SrcLoc {srcFilename = "", srcLine = 0, srcColumn = 0}

-- All together.

edoc2mod em = flip evalState initEH $ do
  toptds <- mapM td2hs (em_tdefs em)
  funtypes <- mapM ft2hs (em_funcs em)
  let mname = (Module . renameMod . em_name) em
      hsfnames = map funName (em_funcs em)
      expfuns = map (HsEVar . UnQual . HsIdent) hsfnames
      exps = expfuns
      decls = toptds ++ funtypes
  return $ HsModule nullLoc mname (Just exps) [] decls

-- Produce Haskell type declaration out of TypeDef

td2hs td = do
  hstype <- mapM et2ht (td_type td : td_argtypes td) >>= return . ts2tsig
  let tname = (HsIdent . renameType . en_name . td_ename) td
  return $ HsTypeDecl nullLoc tname [] hstype

-- Single type remains as is. List of types becomes function's type

ts2tsig [t] = t
ts2tsig (t:ts) = HsTyFun t $ ts2tsig ts

-- Map an Erlang type to a Haskell type

et2ht (EAtom _) = return $ HsTyVar $ HsIdent "Atom"

et2ht (EAbsType en []) = return $ HsTyVar $ HsIdent $ renameType $ en_name en

et2ht (ETuple ets) = do
  hets <- mapM et2ht ets
  return $ HsTyTuple hets

et2ht (EList et) = do
  het <- et2ht et
  return $ HsTyApp (HsTyCon $ Special HsListCon) het

et2ht (ENothing) = do
  return $ HsTyCon $ Special HsUnitCon

et2ht (EFun ats rt) = do
  (hrt:hets) <- mapM et2ht (rt:ats)
  let restyp = HsTyApp (HsTyCon $ UnQual $ HsIdent "IO") hrt
  return $ ts2tsig (hets ++ [restyp])

et2ht (ETypeVar tv) = do
  let tvr = renameType tv
  ldmap <- gets ldMap
  case (M.lookup (T tvr) ldmap) of
    Just t -> et2ht t
    Nothing -> return $ HsTyVar $ HsIdent $ renameType tvr

-- EAny corresponds to any Erlang term. We are assuming that the 'ErlTerm' class
-- is defined elsewhere, so once EAny occurs, we allocate a type variable, and
-- create type context for it.

et2ht (EAny) = do
  un <- getCnt
  let tvar = 't' : show un
  ctxs <- gets ctxSet >>= return . S.insert ("ErlTerm", [tvar])
  st <- get
  put st {ctxSet = ctxs}
  return $ HsTyVar $ HsIdent tvar

-- ENil corresponds to the list of any Erlang terms.

et2ht (ENil) = et2ht $ EList EAny

et2ht z = do
  un <- getCnt
  return $ HsTyVar $ HsIdent $ 'u':show un ++  " {- " ++ show z ++ " -}"

-- Produce a function type declaration. If type signature is absent, produce
-- the most general one, based on arity and argument names. Otherwise use
-- the type spec.

ft2hs ef | null (ef_tspec ef) = do
  let atvars = if null (ef_args ef)
                 then map show (take (ef_arity ef) [1 .. ])
                 else ef_args ef
      ntvars = map (HsTyVar . HsIdent . ("a" ++ )) atvars
      resvar = HsTyApp (HsTyCon $ UnQual $ HsIdent "IO") 
                       (HsTyVar $ HsIdent $ "r_" ++ funName ef)
      ft = ts2tsig (ntvars ++ [resvar])
  return $ HsTypeSig nullLoc [HsIdent $ funName ef] (HsQualType [] ft)

ft2hs ef = do
  let eft = ts_type $ head $ ef_tspec ef
      ldmap = mkldmap $ ts_ldef $ head $ ef_tspec ef
  st <- get
  put st {ldMap = ldmap}
  st <- get
  put st {ctxSet = S.empty}
  eht <- et2ht eft
  ctxs <- gets ctxSet >>= return . S.toList
  let ctx = map mkctx ctxs
      mkctx (c, vs) = (c', vs') where
        c' = UnQual $ HsIdent c
        vs' = map (HsTyVar . HsIdent) vs
      hs = HsTypeSig nullLoc [HsIdent $ funName ef] (HsQualType ctx eht)
  st <- get
  put st {ldMap = M.empty}
  st <- get
  put st {ctxSet = S.empty}
  return hs

-- Build a localdef map to lookup real types for abstract types and typevars.

mkldmap = M.fromList . concat . map oneldef where
  oneldef (ELocDef (ETypeVar ev) t) = [(T ev, t)]
  oneldef (ELocDef (EAbsType (ErlName {en_name = en}) []) t) = [(A $ renameType en, t)]
  oneldef _ = []