SJW/src/Module.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Module (
      Compiler
    , Contextual
    , Entry(..)
    , Failable
    , ImportTree(..)
    , Log
    , Module(..)
    , Modules
    , ModuleSpace(..)
    , Reference(..)
    , buildEntry
    , emptySpace
    , parse
    , register
    , reorder
  ) where

import Context (CodePath(..), Context(..), Path(..))
import Control.Applicative ((<|>), many, optional)
import Control.Monad.Except (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.RWS (MonadReader, MonadState, MonadWriter, asks, modify)
import Data.Attoparsec.Text (
      Parser, char, count, digit, inClass, isEndOfLine, letter, parseOnly, sepBy
    , string, takeTill, takeWhile
  )
import Data.Map (Map, foldlWithKey)
import qualified Data.Map as Map (empty, insert, lookup)
import qualified Data.Set as Set (empty, insert, toList)
import Data.Text (Text)
import qualified Data.Text as Text (pack)
import Prelude hiding (takeWhile)
import Priority (Queue, empty)
import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>))
import Text.Printf (printf)

data Reference =
    ModulePath {modulePath :: Path}
  | Object {modulePath :: Path, field :: String}
  deriving Show

data ImportTree = ImportTree {
      target :: Maybe Reference
    , children :: Map String ImportTree
  } deriving Show

recurse :: (a -> [String] -> Reference -> a) -> a -> ImportTree -> a
recurse f initValue = recAux [] initValue
  where
    next _ value Nothing = value
    next stack value (Just ref) = f value (reverse stack) ref
    recAux stack value tree =
      let nextValue = next stack value (target tree) in
      foldlWithKey (\a k b -> recAux (k:stack) a b) nextValue (children tree)

data Mapping = Mapping {
      exposedName :: Path
    , reference :: Reference
  }

data Module = Module {
      imports :: ImportTree
    , payload :: [Text]
  } deriving Show

data Entry = Entry {
      content :: Module
    , dependencies :: [Path]
  }

data ModuleSpace = ModuleSpace {
      entries :: Map Path Entry
    , queue :: Queue Path
  }

register :: Modules m => Path -> Entry -> m ()
register path entry = modify $ \moduleSpace -> moduleSpace {
    entries = Map.insert path entry (entries moduleSpace)
  }

reorder :: Modules m => (Queue Path -> Queue Path) -> m ()
reorder f = modify $ \moduleSpace -> moduleSpace {
    queue = f (queue moduleSpace)
  }

emptySpace :: ModuleSpace
emptySpace = ModuleSpace {
      entries = Map.empty
    , queue = Priority.empty
  }

type Contextual = MonadReader Context
type Log = MonadWriter [String]
type Modules = MonadState ModuleSpace
type Failable = MonadError String
type Compiler m = (Contextual m, Log m, Modules m, MonadIO m, Failable m)

space :: Parser ()
space = takeWhile (inClass " \t") *> pure ()

between :: Parser a -> (Parser b, Parser c) -> Parser a
between p (left, right) = left *> space *> p <* space <* right

keyword :: String -> Parser ()
keyword k = space <* string (Text.pack k) <* space

name :: Parser String
name = (:) <$> letter <*> many (letter <|> digit)

aliasedName :: Parser (Maybe String, String)
aliasedName =
    ((,) <$> (Just <$> name) <* keyword "as" <*> name)
  <|> ((\s -> (Just s, s)) <$> name)

buildMappings :: Maybe [(Maybe String, String)] -> Path -> [Mapping]
buildMappings Nothing modulePath =
  [Mapping modulePath (ModulePath modulePath)]
buildMappings (Just nameAssocs) modulePath = mappingOf <$> nameAssocs
  where
    mappingOf (Nothing, dest) = Mapping (Path [dest]) (ModulePath modulePath)
    mappingOf (Just source, dest) =
      Mapping (Path [dest]) (Object modulePath source)

mappingParser :: Parser [Mapping]
mappingParser =
  buildMappings <$> optional fromClause <*> (Path <$> name `sepBy` char '.')
  where
    fromClause =
      (count 1 (aliasedName <|> star) <|> namesBlock) <* keyword "from"
    namesBlock =
      (aliasedName `sepBy` (char ',' *> space)) `between` (char '{', char '}')
    star = (,) <$> (char '*' *> pure Nothing) <* keyword "as" <*> name

importParser :: Parser [Mapping]
importParser = mappingParser `between` (string "import", char ';')

emptyTree :: ImportTree
emptyTree = ImportTree {
      target = Nothing
    , children = Map.empty
  }

insertMapping :: ImportTree -> Mapping -> ImportTree
insertMapping tmpTree (Mapping {exposedName, reference}) =
  insertAt components tmpTree
  where
    Path components = exposedName
    insertAt [] tree = tree {target = Just reference}
    insertAt (next:restOfPath) tree@(ImportTree {children}) =
      let subTree = maybe emptyTree id $ Map.lookup next children in tree {
        children = Map.insert next (insertAt restOfPath subTree) children
      }

moduleParser :: Parser Module
moduleParser = Module
  <$> (foldl (foldl insertMapping) emptyTree <$> importParser `sepBy` blank)
  <*> (blank *> line `sepBy` eol)
  where
    eol = string "\r\n" <|> string "\r" <|> string "\n"
    blank = takeWhile (inClass " \t\r\n")
    line = takeTill isEndOfLine

buildEntry :: Module -> Entry
buildEntry content = Entry {content, dependencies}
  where
    dependencies =
      Set.toList . recurse pushDependency Set.empty $ imports content
    pushDependency set _ ref = Set.insert (modulePath ref) set

parse :: (Contextual m, MonadIO m, Failable m) => Path -> m Module
parse path = do
  searchPath <- asks codePaths
  maybeSource <- find searchPath path
  case maybeSource of
    Nothing -> throwError $
      printf "Module %s not found in paths : %s" (show path) (show searchPath)
    Just source -> either throwError return =<<
      parseOnly moduleParser . Text.pack <$> liftIO (readFile source)

find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath)
find (CodePath []) _ = return Nothing
find (CodePath (dir:otherDirs)) path@(Path components) = do
  fileExists <- liftIO $ doesFileExist filePath
  if fileExists
  then return (Just filePath)
  else find (CodePath otherDirs) path
  where
    filePath = foldl (</>) dir components <.> "js"