Module.hs

{-# 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"