PiReader.hs

module Language.Java.Paragon.Monad.PiReader 
    ( 
      module Language.Java.Paragon.Monad.Base,

      PiPath, PiReader, runPiReader,

      MonadPR(..),

      getPiPath, 
      doesPkgExist, doesTypeExist, 
      getPkgContents, getTypeContents,
      getPiPathContents

    ) where

import Language.Java.Paragon.Syntax
import Language.Java.Paragon.Pretty
import Language.Java.Paragon.Parser
import Language.Java.Paragon.Interaction
import Language.Java.Paragon.Monad.Base

import System.FilePath
import System.Directory

import qualified Data.ByteString.Char8 as B

import Control.Monad
import Control.Applicative

piReaderModule :: String
piReaderModule = libraryBase ++ ".Monad.PiReader"

-- import System.FilePath

type PiPath = [FilePath] -- Should be a choice of many different

newtype PiReader a = PiReader ( PiPath -> BaseM a )

runPiReader :: PiPath -> PiReader a -> BaseM a
runPiReader pp (PiReader f) = f pp

instance Monad PiReader where
  return x = PiReader $ \_ -> return x

  PiReader f >>= k = PiReader $ \pp -> do
                          a <- f pp
                          let PiReader g = k a
                           in g pp

  fail = liftBase . fail

instance Functor PiReader where
  fmap = liftM

instance MonadBase PiReader where
  liftBase ba = PiReader $ \_ -> ba
  withErrCtxt' ecf (PiReader f) = PiReader $ withErrCtxt' ecf . f
  tryM (PiReader f) = PiReader $ tryM . f

instance MonadIO PiReader where
  liftIO = liftBase . liftIO

class MonadBase m => MonadPR m where
  liftPR :: PiReader a -> m a
--  liftPRWith :: (PiReader a -> PiReader a) -> m a -> m a

instance MonadPR PiReader where
  liftPR = id
--  liftPRWith = id


getPiPathPR :: PiReader PiPath
getPiPathPR = PiReader return

getPiPath :: MonadPR m => m PiPath
getPiPath = liftPR getPiPathPR

---------------------------------------------------
-- The real functionality: reading pi files

doesPkgExist :: MonadPR m => Name () -> m Bool
doesPkgExist n = liftPR $ do
  path <- pNameToDir n
  piPath <- getPiPath
  or <$> mapM (\p -> liftIO $ doesDirectoryExist $ p </> path) piPath

doesTypeExist :: MonadPR m => Name () -> m Bool
doesTypeExist n = liftPR $ do
  path <- tNameToFile n
  piPath <- getPiPath
  liftIO $ go piPath path

  where go [] _ = return False
        go (p:pis) path = do
              let fp = p </> path
              debugPrint $ "Checking for " ++ fp
              found <- doesFileExist fp
              if found
               then do
                 debugPrint $ "Found " ++ fp
                 return True
               else go pis path

getPkgContents :: MonadPR m => Name () -> m [B.ByteString]
getPkgContents n = liftPR $ do
  path <- pNameToDir n
  piPath <- getPiPath
  findFirstPkg path piPath

      where findFirstPkg :: FilePath -> [FilePath] -> PiReader [B.ByteString]
            findFirstPkg _ [] = panic (piReaderModule ++ ".getPkgContents")
                                ("No such package exists - doesPkgExist not called successfully"
                                 ++ show n)
            findFirstPkg path (pip:pips) = do
                     isP <- liftIO $ doesDirectoryExist $ pip </> path
                     if isP
                      then do files <- liftIO $ getDirectoryContents $ pip </> path
                              let fnses = map splitExtension files
                              return [ B.pack str | (str, ".pi") <- fnses, not (null str), head str /= '.' ]
                      else findFirstPkg path pips

getPiPathContents :: MonadPR m => m ([B.ByteString], [B.ByteString])
getPiPathContents = do
  pp <- getPiPath
  liftIO $ go pp ([],[])

      where go :: [FilePath] -> ([B.ByteString], [B.ByteString]) 
               -> IO ([B.ByteString], [B.ByteString]) 
            go [] acc = return acc
            go (p:pis) (ts,ps) = do
                       isDir <- doesDirectoryExist p
                       if isDir then do
                                  files <- getDirectoryContents p
                                  pkgs  <- filterPkgIdentsM files
                                  let tys = filterPiIdents files
                                  go pis (tys++ts,pkgs++ps)
                        else go pis (ts,ps)

getTypeContents :: MonadPR m => Name () -> m (CompilationUnit ())
getTypeContents n = liftPR $ do
  path <- tNameToFile n
  piPath <- getPiPath
  findFirstPi path piPath

      where findFirstPi :: FilePath -> [FilePath] -> PiReader (CompilationUnit ())
            findFirstPi _ [] = panic (piReaderModule ++ ".getTypeContents")
                               ("No such type exists - doesTypeExist not called successfully: "
                                ++ show n)
            findFirstPi path (pip:pips) = do
                      isT <- liftIO $ doesFileExist $ pip </> path
                      if isT
                       then do fc <- liftIO $ readFile $ pip </> path
                               let pRes = parser compilationUnit fc
                               case pRes of
                                 Right cu -> return cu
                                 Left pe  -> fail $ "Parse error in pi file for type " 
                                                   ++ prettyPrint n ++ ":\n"
                                                   ++ show pe
                       else findFirstPi path pips



---- Helper functions

filterPiIdents :: [FilePath] -> [B.ByteString]
filterPiIdents files =
    let fnses = map splitExtension files
    in [ B.pack str | (str, ".pi") <- fnses ]

filterPkgIdentsM :: MonadIO m => [FilePath] -> m [B.ByteString]
filterPkgIdentsM files = liftIO $ do
    fs <- filterM doesDirectoryExist files    
    return [ B.pack f | f <- fs, head f /= '.' ]


pNameToDir :: Name () -> PiReader FilePath
pNameToDir (Name _ PName mPre (Ident _ str)) = do
    pf <- case mPre of
            Nothing -> return id
            Just pre -> do
                      fp <- pNameToDir pre
                      return (fp </>)
    return $ pf (B.unpack str)
pNameToDir (Name _ TName _ _) = fail "Inner types not supported"
pNameToDir n = panic (piReaderModule ++ ".pNameToDir") $ show n

tNameToFile :: Name () -> PiReader FilePath
tNameToFile (Name _ TName mPre (Ident _ str)) = do
    pf <- case mPre of
            Nothing -> return id
            Just pre -> do
                      fp <- pNameToDir pre
                      return (fp </>)
    return $ pf (B.unpack str) <.> "pi"
tNameToFile n = panic (piReaderModule ++ ".tNameToFile") $ show n