SJW-0.1.2.2: src/SJW.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module SJW (
      Source
    , Path(..)
    , compile
    , mainIs
    , source
    , sourceCode
  ) where

import Control.Applicative ((<|>))
import Control.Monad.Except (MonadError(..), runExceptT)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.RWS (evalRWST)
import qualified Data.Map as Map (empty)
import Data.Text (Text)
import qualified SJW.Compiler as Compiler (main)
import SJW.Dependencies (Failable)
import SJW.Module (Modules(..))
import SJW.Source (CodePath(..), Source(..), Path(..), source)
import System.Directory (doesDirectoryExist)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import System.IO (stderr, hPutStrLn)
import System.Posix.User (getRealUserID, getUserEntryForID, homeDirectory)
import Text.Printf (printf)

type Result = Either String (Text, [String])

compile :: Source -> IO Result
compile inputSource = runExceptT $ do
  checkedPackages <- check packages
  let checkedSource = inputSource {code = CodePath checkedPackages}
  evalRWST Compiler.main checkedSource emptyEnvironment
  where
    CodePath packages = code inputSource
    emptyEnvironment = Modules {
        modules = Map.empty
      }

sourceCode :: Result -> IO (Maybe Text)
sourceCode (Left errorMessage) = hPutStrLn stderr errorMessage >> return Nothing
sourceCode (Right (output, logs)) =
  mapM_ (hPutStrLn stderr) logs >> return (Just output)

mainIs :: Source -> String -> Source
mainIs context dotSeparated = context {mainModule = read dotSeparated}

(<||>) :: (Monad m) => m (Maybe a) -> a -> m a
(<||>) value defaultValue = maybe defaultValue id <$> value

dbDirectory :: MonadIO m => m FilePath
dbDirectory = liftIO $ do
  unixHome <- homeDirectory <$> (getUserEntryForID =<< getRealUserID)
  homeDB <- lookupEnv "HOME" <||> unixHome
  lookupEnv "SJW_PACKAGE_DB" <||> (homeDB </> ".sjw")

checkPath :: MonadIO m => FilePath -> m (Maybe FilePath)
checkPath filePath = liftIO $ do
  directoryExists <- doesDirectoryExist filePath
  return $ if directoryExists then Just filePath else Nothing

check :: (MonadIO m, Failable m) => [String] -> m [FilePath]
check names = do
  db <- dbDirectory
  mapM (pathOrPackageName db) names
  where
    notFound = throwError . printf "%s: package and directory not found"
    pathOrPackageName db name =
      (<|>) <$> checkPath name <*> checkPath (db </> name)
      >>= maybe (notFound name) return