73 lines
2.4 KiB
Haskell
73 lines
2.4 KiB
Haskell
{-# 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
|