72 lines
2.3 KiB
Haskell
72 lines
2.3 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module SJW.Module (
|
|
Environment
|
|
, Log
|
|
, Module(..)
|
|
, Modules(..)
|
|
, parse
|
|
, register
|
|
) where
|
|
|
|
import SJW.Source (CodePath(..), Source(..), HasSource, Path(..))
|
|
import Control.Monad.Except (MonadError(..))
|
|
import Control.Monad.IO.Class (MonadIO(..))
|
|
import Control.Monad.RWS (MonadState, MonadWriter, asks, modify)
|
|
import Data.Attoparsec.Text (parseOnly)
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map (insert)
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set (empty, insert)
|
|
import qualified Data.Text as Text (pack)
|
|
import SJW.Dependencies (Failable)
|
|
import SJW.Module.File (File(..))
|
|
import qualified SJW.Module.File as File (parser)
|
|
import SJW.Module.Imports (Reference(..), recurse)
|
|
import Prelude hiding (takeWhile)
|
|
import System.Directory (doesFileExist)
|
|
import System.FilePath ((</>), (<.>))
|
|
import Text.Printf (printf)
|
|
|
|
data Module = Module {
|
|
file :: File
|
|
, dependencies :: Set Path
|
|
}
|
|
|
|
newtype Modules = Modules {
|
|
modules :: Map Path Module
|
|
}
|
|
|
|
type Environment = MonadState Modules
|
|
type Log = MonadWriter [String]
|
|
|
|
register :: Environment m => Path -> Module -> m ()
|
|
register path module_ = modify $
|
|
\(Modules modules) -> Modules $ Map.insert path module_ modules
|
|
|
|
build :: File -> Module
|
|
build file = Module {file, dependencies}
|
|
where
|
|
dependencies = recurse pushDependency Set.empty $ imports file
|
|
pushDependency set _ ref = Set.insert (modulePath ref) set
|
|
|
|
parse :: (HasSource m, MonadIO m, Failable m) => Bool -> Path -> m Module
|
|
parse isMain path = do
|
|
searchPath <- asks code
|
|
filePath <- find (CodePath [], searchPath) path
|
|
source <- Text.pack <$> liftIO (readFile filePath)
|
|
either throwError (return . build) $
|
|
parseOnly (File.parser isMain) source
|
|
|
|
find :: (Failable m, MonadIO m) => (CodePath, CodePath) -> Path -> m FilePath
|
|
find (stack, CodePath []) path = throwError $
|
|
printf "Module %s not found in paths : %s" (show path) (show $ stack)
|
|
find (CodePath stackedDirs, CodePath (dir:otherDirs)) path@(Path components) = do
|
|
fileExists <- liftIO $ doesFileExist filePath
|
|
if fileExists
|
|
then return filePath
|
|
else find (CodePath (dir:stackedDirs), CodePath otherDirs) path
|
|
where
|
|
filePath = foldl (</>) dir components <.> "js"
|