{-
    Kaya - My favourite toy language.
    Copyright (C) 2004, 2005 Edwin Brady

    This file is distributed under the terms of the GNU General
    Public Licence. See COPYING for licence.
-}

-- Functions for helping with the module system; finding libraries, writing
-- .ki, linking and dealing with library paths.

module Module(importVersion, findFile, findLib,
              writeIface, nameToRelPath,
              getAllLibDirs, linkFiles, getObjs) where

import Language
import Control.Exception
import Debug.Trace
import System.Directory (doesFileExist)
import Data.List
import Lib
import Options
import Portability
import Inliner

importVersion :: Int
importVersion = 5

-- If something is inlinable and very small (e.g. just a constant)
-- write out its definition. We pass in the inlinable definitions, but
-- this is currently unused, we just work it out ourselves here since
-- it's not quite the same functions which can be exported inlinable
-- (complications with globals and privates)

writeIface :: Inlinable -> FilePath -> Program -> IO ()
writeIface inls fn prog
  = do let str = mkIface prog
       writeFile fn str

mkIface :: Program -> String
mkIface [] = ""
mkIface (CInclude str:xs) = mkIface xs
mkIface (Imported str:xs) = "%imported "++show str++";\n"++mkIface xs
mkIface (Linker str:xs) = "%link "++show str++";\n"++mkIface xs
mkIface ((FunBind (f,l,n,ty,fopts,Unbound) _ _):xs) 
    | elem Repeatable fopts = mkIface xs
    | elem Export fopts = mkExt n ty fopts Nothing ++ "\n" ++ mkIface xs
    | otherwise = mkExt n ty (delete Public fopts) Nothing ++ "\n" ++ mkIface xs
--    | otherwise = "%fnmap \"" ++ show n ++ mangling ty ++ "\""
--                     ++ "\n" ++ mkIface xs
mkIface ((FunBind (f,l,n,ty,fopts,ExtInlinable def) _ _):xs) 
    | elem Repeatable fopts = mkIface xs
    | elem Export fopts = mkExt n ty fopts (showInl def) ++ "\n" ++ mkIface xs
    | otherwise = mkExt n ty (delete Public fopts) (showInl def) 
                     ++ "\n" ++ mkIface xs
--    | otherwise = "%fnmap \"" ++ show n ++ mangling ty ++ "\"" ++ "\n" ++ mkIface xs
mkIface ((FunBind (f,l,n,ty,fopts,ExceptionFn nm ar _) _ _):xs) 
    -- always export exception declarations
    = mkExcept nm ty ++ "\n" ++ mkIface xs
mkIface ((FunBind (f,l,n,ty,fopts,Defined def) _ _):xs)
   | not (Generated `elem` fopts) = mkExt n ty fopts (showInl def) 
                                       ++ "\n" ++ mkIface xs
   | otherwise = mkExtCName n ty ++ "\n" ++ 
                 mkIface xs -- write the C name, to keep FunMap correct
--mkIface (FunBind (n,ty,DataCon i ar):xs) = 
--   mkExtCon n ty i ar ++ "\n" ++ mkIface xs
mkIface ((DataDecl f l dopts n tys cons comm):xs) 
   | DAbstract `elem` dopts && DExport `elem` dopts 
       = mkData n tys dopts [] ++ "\n" ++ mkIface xs
   | DPublic `elem` dopts && DExport `elem` dopts 
       = mkData n tys dopts cons ++ "\n" ++ mkIface xs
   | otherwise = mkIface xs
--       = mkData n tys [] [] ++ "\n" ++ mkIface xs

mkIface ((TySyn (f,l,n,ps,ty,True)):xs) =
   mkTySyn n ps ty ++ "\n" ++ mkIface xs
mkIface (_:xs) = mkIface xs

mkExcept nm (Fn _ args ret) = 
    "%except " ++ showuser nm ++ "(" ++ showargs args ++ ");"
  where showargs [] = ""
	showargs [x] = show x
	showargs (x:xs) = show x ++ "," ++ showargs xs

mkExtCName n ty = "%lifted \"" ++ show n ++ mangling ty ++ "\""

mkExt :: Name -> Type -> [FOpt] -> Maybe (String, [Name]) -> String
mkExt n (Fn defaults args ret) fopts def
   = extTok def ++ show importVersion ++ " "++ writefopts fopts ++ show ret ++ " " ++ showuser n ++ 
     (if elem NoArgs fopts then "" else "(" ++ showargs defaults args (getArgs def) ++ ")")
     ++ extShowDef def
  where showargs [] [] _ = ""
	showargs [d] [x] [a] = show x ++ " " ++ showuser a ++ showdef d
	showargs [d] [x] [] = show x ++ showdef d
	showargs (d:ds) (x:xs) [] 
            = show x ++ showdef d ++ "," ++ showargs ds xs []
	showargs (d:ds) (x:xs) (a:as) 
            = show x ++ " " ++ showuser a ++ showdef d ++ "," 
              ++ showargs ds xs as

        showdef Nothing = "";
	showdef (Just a) = " = " ++ showDefaultArg a -- FIXME: Do it properly
        getArgs (Just (_,as)) = as
        getArgs _ = []
	writefopts (Public:xs) = "public " ++ writefopts xs
	writefopts (Pure:xs) = "pure " ++ writefopts xs
	writefopts (StartupFn:xs) = "%startup " ++ writefopts xs
	writefopts (DeprecatedFn:xs) = "%deprecated " ++ writefopts xs
	writefopts (_:xs) = writefopts xs
	writefopts [] = ""
mkExt n t fopts def = extTok def ++ show importVersion ++ " " ++ 
                  writefopts fopts ++ 
		  show t ++ " " ++ showuser n ++ 
     (if elem NoArgs fopts then "" else "()") ++
     extShowDef def
   where writefopts (Public:xs) = "public " ++ writefopts xs
	 writefopts (Pure:xs) = "pure " ++ writefopts xs
	 writefopts (_:xs) = writefopts xs
	 writefopts [] = ""

extTok Nothing = "%extern "
extTok (Just _) = "%extinline "
extShowDef Nothing = ";"
extShowDef (Just (def, _)) = "{ " ++ def ++ " };"


mkData :: Name -> [Type] -> [DOpt] -> [ConDecl] -> String
mkData n args opts cons = "%data " ++ show importVersion ++ " " ++ 
                          showopts opts ++ showuser n ++ 
			  params args ++ " = " ++ showcons cons ++ ";"
   where params [] = ""
	 params (x:xs) = "<" ++ p' (x:xs) ++ ">"
	 showopts [] = ""
	 showopts (DPublic:xs) = "public "++showopts xs
	 showopts (DAbstract:xs) = "abstract "++showopts xs
	 showopts (x:xs) = showopts xs

         p' [] = ""
	 p' [x] = show x
	 p' (x:xs) = show x ++ "," ++ p' xs
	 showcons [] = ""
	 showcons [x] = showcon x
	 showcons (x:xs) = showcon x ++ " | " ++ showcons xs
	 showcon (Con n (Fn _ ts _) ns _) = showuser n ++ "(" ++ 
					    showargs ts ns ++ ")"
	 showargs [] [] = ""
	 showargs (t:[]) (n:[]) = showarg n t
	 showargs (t:ts) (n:ns) = showarg n t ++ "," ++ showargs ts ns
	 showarg n t = show t ++ case n of
		          None -> ""
			  x -> " " ++ showuser x

mkTySyn :: Name -> [Name] -> Type -> String
mkTySyn n ps t = "%type " ++ show importVersion ++ " " ++
                 showuser n ++ params ps ++ " = " ++ show t ++ ";"
   where params [] = ""
	 params (x:xs) = "<" ++ p' (x:xs) ++ ">"
         p' [] = ""
	 p' [x] = showuser x
	 p' (x:xs) = showuser x ++ "," ++ p' xs

{-
mkExtTy :: Name -> [Type] -> String
mkExtTy (UN n) tys = "%datatype " ++ n ++ "<" ++ showtys tys ++ ">;"
   where showtys [] = ""
	 showtys [x] = show x
	 showtys (x:xs) = show x ++ "," ++ show xs

mkExtCon :: Name -> Type -> Int -> Int -> String
mkExtCon (UN n) (Fn tvars args ret) i ar
    = "%datacon " ++ show ret ++ " " ++ n ++ 
      "(" ++ showargs args ++ ")[" ++ show i ++ "," ++ show ar ++"];"
  where showargs [] = ""
	showargs [x] = show x
	showargs (x:xs) = show x ++ "," ++ showargs xs
mkExtCon (UN n) t i ar = "%datacon " ++ show t ++ " " ++ n ++ "()[" ++ show i ++ "," ++ show ar ++"];"
-}

-- Take a list of dynamic link package files (.ddl), and return a mapping
-- from .o files to the libraries to link instead.
linkFiles :: [FilePath] -> [String] -> IO [(String,String)]
linkFiles libs [] = return []
linkFiles libs (f:fs) 
    = do ds <- linkFiles libs fs
	 libdata <- findFile libs (f++".ddl")
	 case libdata of
             (Just d) -> do
--	        putStrLn $ show d
	        let file = lines d
	        let info = words (file!!0)
		let linkinfo = (file!!1)
		let lmap = map (\x -> (x,"-l"++(head info)++" "++linkinfo)) (tail info)
--		putStrLn (show lmap)
		return $ nub (lmap++ds)
	     Nothing -> return ds
		   
-- Get a list of the object files and libraries to link to the program.

getObjs :: Program -> [FilePath] -> [(String,String)] -> 
	   IO ([FilePath],[String])
getObjs p fp dls = do (fp,libs) <- go' p
		      return (nub fp, nub libs) 
    where go' [] = return ([],[])
	  go' ((Imported str):xs) = 
	      do ofile <- findFile fp (str++".o")
		 (rest,lops) <- go' xs
		 case (lookup (str++".o") dls) of
		    Nothing -> return (ofile:rest, lops)
		    (Just lib) -> return (rest,nub (lib:lops))
	  go' ((Linker str):xs) =
              do (rest,lops) <- go' xs
		 return (rest,('-':'l':str):lops)
	  go' (x:xs) = go' xs

          findFile [] path
	      = fail $ "No such module " ++ path
	  findFile (x:xs) path 
	      = do --putStrLn $ "Looking in " ++ (x++path)
		   exist <- doesFileExist (x++path)
		   if exist 
		      then return (x++path)
		      else findFile xs path



-- Given the library paths and the file name we're looking for, see if
-- it's there and return the full path if so

findLib :: [FilePath] -> FilePath -> IO (Maybe FilePath)
findLib [] path
  = return Nothing -- fail $ "Can't find " ++ path
findLib (x:xs) path 
  = do ex <- doesFileExist (x++path)
       if ex then return $ Just (x++path)
	  else findLib xs path

-- Given the library paths and the file name we're looking for, see if
-- it's there and if so, read it

findFile :: [FilePath] -> FilePath -> IO (Maybe String)
findFile [] path
  = return Nothing
findFile (x:xs) path 
  = catch
         (do --putStrLn $ "Trying " ++ x ++ path
	     f <- readFile (x++path)
	     return (Just f))
         (\(e :: IOException) -> findFile xs path)

-- Get all the library directories, looking at the options and the
-- KAYA_LIBRARY_PATH environment variable.

getAllLibDirs :: Options -> IO [FilePath]
getAllLibDirs opts = do
     let cds = getlibdir opts ["./"]
     let lds = getlibdir opts ("./":
                               (map ((++"/").stripSlash) libpath) ++ 
                               (map ((++"/imports/").stripSlash) libpath))
     env <- environment "KAYA_LIBRARY_PATH"
     return $ if (noenvlibs opts) then cds else (filter (\x -> length x > 0) $ splitBy pathsep env) ++ lds 

splitBy sep (Just xs) = splitBy' sep xs []
splitBy sep _ = []
splitBy' sep [] acc = [reverse acc]
splitBy' sep (x:xs) acc | x == sep = (reverse acc):(splitBy' sep xs [])
                        | otherwise = splitBy' sep xs (x:acc)

nameToRelPath :: Name -> FilePath
nameToRelPath (UN n) = n
nameToRelPath (NS s n) = nameToRelPath s ++ "/" ++ nameToRelPath n