Explode module «Module» into several parts specialized in Imports, Environment handling and simple File parsing and compiling

SJW.cabal

@@ -22,6 +22,9 @@ executable sjw
   other-modules:       Compiler
                      , Context
                      , Module
+                     , Module.Environment
+                     , Module.File
+                     , Module.Imports
                      , Paths_SJW
                      , Priority
   -- other-extensions:

src/Compiler.hs

@@ -1,21 +1,28 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 module Compiler (
     main
   ) where
 
-import Context (Context(..), Path)
+import Context (Context(..), Contextual, Path)
+import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.RWS (asks, gets)
-import Data.List (intercalate)
 import Data.Map ((!))
-import qualified Data.Map as Map (member, toList)
+import qualified Data.Map as Map (member)
 import Data.Text (Text, cons)
-import qualified Data.Text as Text (null, pack, unlines)
+import qualified Data.Text as Text (null, unlines)
-import Module (Compiler, Entry(..), ImportTree(..), Module(..), Modules, Reference(..))
+import Module (Environment, Failable, Log, Module(..), Log)
-import qualified Module (ModuleSpace(..), buildEntry, parse, register, reorder)
+import qualified Module (parse)
+import qualified Module.Environment as Environment (
+    Environment(..), register, reorder
+  )
+import Module.File (File(..), variables)
+import qualified Module.File as File (header, footer)
 import qualified Priority (set, toList)
-import Text.Printf (printf)
+
+type Compiler m = (Contextual m, Log m, Environment m, MonadIO m, Failable m)
 
 indent :: [Text] -> [Text]
 indent = fmap indentLine
@@ -24,58 +31,29 @@ indent = fmap indentLine
       | Text.null t = t
       | otherwise = cons '\t' t
 
-variables :: ImportTree -> [(String, String)]
+include :: Environment m => (Int, Path) -> m [Text]
-variables = fmap (fmap computeValue) . Map.toList . children
-  where
-    computeValue :: ImportTree -> String
-    computeValue subTree =
-      let subModules = intercalate ", " $ f <$> Map.toList (children subTree) in
-      case target subTree of
-        Nothing -> printf "Object.create(null, {%s})" subModules
-        Just (ModulePath {modulePath}) ->
-          printf "Object.create(modules['%s'], {%s})"
-            (show modulePath)
-            subModules
-        Just (Object {modulePath, field}) ->
-          printf "modules['%s'].%s" (show modulePath) field
-    f (name, subTree) = printf "%s: {value: %s}" name $ computeValue subTree
-
-moduleHeader :: Bool -> Path -> [String] -> Text
-moduleHeader isMain path names = Text.pack (outside isMain ++ arguments)
-  where
-    outside True = ""
-    outside False = printf "modules['%s'] = " (show path)
-    arguments = printf "(function(%s) {" (intercalate ", " $ names ++ ["modules"])
-
-moduleFooter :: [String] -> [Text]
-moduleFooter values = [Text.pack $ printf "})(%s);" (intercalate ", " values)]
-
-include :: Modules m => (Int, Path) -> m [Text]
 include (priority, path) = do
-  Module {imports, payload} <- getModule path
+  File {imports, payload} <- gets (file . (! path) . Environment.modules)
   let (names, values) = unzip $ variables imports
-  return $ moduleHeader isMain path names : indent payload ++ moduleFooter values
+  return $ File.header isMain path names : indent payload ++ File.footer values
   where
     isMain = priority == 0
 
-getModule :: Modules m => Path -> m Module
-getModule path = gets (content . (! path) . Module.entries)
-
 scan :: Compiler m => Int -> Path -> m ()
 scan priority modulePath = do
-  Module.reorder $ Priority.set modulePath priority
+  Environment.reorder $ Priority.set modulePath priority
-  alreadyLoaded <- gets (Map.member modulePath . Module.entries)
+  alreadyLoaded <- gets (Map.member modulePath . Environment.modules)
   if alreadyLoaded then return () else load
   where
     load :: Compiler m => m ()
     load = do
-      newEntry <- Module.buildEntry <$> Module.parse modulePath
+      newModule <- Module.parse modulePath
-      Module.register modulePath newEntry
+      Environment.register modulePath newModule
-      mapM_ (scan (priority + 1)) $ dependencies newEntry
+      mapM_ (scan (priority + 1)) $ dependencies newModule
 
 body :: Compiler m => m [Text]
 body = do
-  sortedPath <- gets (Priority.toList . Module.queue)
+  sortedPath <- gets (Priority.toList . Environment.queue)
   includes <- concat <$> mapM include sortedPath
   return $ "var modules = {};" : includes
 

src/Context.hs

@@ -1,10 +1,13 @@
+{-# LANGUAGE ConstraintKinds #-}
 module Context (
       CodePath(..)
     , Context(..)
+    , Contextual
     , Path(..)
     , packages
   ) where
 
+import Control.Monad.Reader (MonadReader)
 import Data.List (intercalate)
 import System.Directory (doesDirectoryExist)
 import System.Environment (lookupEnv)
@@ -22,6 +25,8 @@ data Context = Context {
     , mainModule :: Path
   }
 
+type Contextual = MonadReader Context
+
 instance Show Path where
   show (Path components) = intercalate "." components
 

src/Main.hs

@@ -9,7 +9,7 @@ import Control.Monad.RWS (evalRWST)
 import Data.Text (Text)
 import qualified Data.Text as Text (unpack)
 import Data.Version (showVersion)
-import qualified Module (emptySpace)
+import qualified Module.Environment as Environment (empty)
 import Options.Applicative (
       Parser, execParser, fullDesc, info, header, help, helper, long, metavar
     , short, strArgument, strOption, value
@@ -61,7 +61,7 @@ runCompiler :: Config -> IO (Either String (Text, [String]))
 runCompiler (Config {includes, mainIs, target}) = do
   codePaths <- CodePath . (target:) <$> packages includes
   let initialContext = Context {codePaths, mainModule = read mainIs}
-  runExceptT $ evalRWST Compiler.main initialContext Module.emptySpace
+  runExceptT $ evalRWST Compiler.main initialContext Environment.empty
 
 main :: IO ()
 main = do

src/Module.hs

@@ -1,176 +1,44 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 module Module (
-      Compiler
+      Environment
-    , Contextual
-    , Entry(..)
     , Failable
-    , ImportTree(..)
     , Log
     , Module(..)
-    , Modules
-    , ModuleSpace(..)
-    , Reference(..)
-    , buildEntry
-    , emptySpace
     , parse
-    , register
-    , reorder
   ) where
 
-import Context (CodePath(..), Context(..), Path(..))
+import Context (CodePath(..), Context(..), Contextual, 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 Control.Monad.RWS (MonadWriter, asks)
-import Data.Attoparsec.Text (
+import Data.Attoparsec.Text (parseOnly)
-      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 Module.Environment (HasEnvironment)
+import Module.File (File(..))
+import qualified Module.File (parser)
+import Module.Imports (Reference(..), recurse)
 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
+      file :: Module.File.File
-    , payload :: [Text]
-  } deriving Show
-
-data Entry = Entry {
-      content :: Module
     , dependencies :: [Path]
   }
 
-data ModuleSpace = ModuleSpace {
+type Environment = HasEnvironment Module
-      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 ()
+build :: File -> Module
-space = takeWhile (inClass " \t") *> pure ()
+build file = Module {file, dependencies}
-
-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
+      Set.toList . recurse pushDependency Set.empty $ imports file
     pushDependency set _ ref = Set.insert (modulePath ref) set
 
 parse :: (Contextual m, MonadIO m, Failable m) => Path -> m Module
@@ -180,8 +48,8 @@ parse path = do
   case maybeSource of
     Nothing -> throwError $
       printf "Module %s not found in paths : %s" (show path) (show searchPath)
-    Just source -> either throwError return =<<
+    Just source -> either throwError (return . build) =<<
-      parseOnly moduleParser . Text.pack <$> liftIO (readFile source)
+      parseOnly Module.File.parser . Text.pack <$> liftIO (readFile source)
 
 find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath)
 find (CodePath []) _ = return Nothing

src/Module/Environment.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Module.Environment (
+      Environment(..)
+    , HasEnvironment
+    , empty
+    , register
+    , reorder
+  ) where
+
+import Context (Path)
+import Control.Monad.State (MonadState, modify)
+import Data.Map (Map)
+import qualified Data.Map as Map (empty, insert)
+import Priority (Queue)
+import qualified Priority (empty)
+
+data Environment a = Environment {
+      modules :: Map Path a
+    , queue :: Queue Path
+  }
+
+type HasEnvironment a = MonadState (Environment a)
+
+register :: HasEnvironment a m => Path -> a -> m ()
+register path module_ = modify $ \moduleSpace -> moduleSpace {
+    modules = Map.insert path module_ (modules moduleSpace)
+  }
+
+reorder :: HasEnvironment a m => (Queue Path -> Queue Path) -> m ()
+reorder f = modify $ \moduleSpace -> moduleSpace {
+    queue = f (queue moduleSpace)
+  }
+
+empty :: Environment a
+empty = Environment {
+      modules = Map.empty
+    , queue = Priority.empty
+  }

src/Module/File.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Module.File (
+      File(..)
+    , header
+    , footer
+    , parser
+    , variables
+  ) where
+
+import Context (Path)
+import Control.Applicative ((<|>))
+import Data.Attoparsec.Text (
+      Parser, inClass, isEndOfLine, sepBy, string, takeTill, takeWhile
+  )
+import Data.List (intercalate)
+import qualified Data.Map as Map (toList)
+import Data.Text (Text)
+import qualified Data.Text as Text (pack)
+import Module.Imports (Reference(..), Tree(..))
+import qualified Module.Imports (parser)
+import Prelude hiding (takeWhile)
+import Text.Printf (printf)
+
+data File = File {
+      imports :: Tree
+    , payload :: [Text]
+  } deriving Show
+
+parser :: Parser File
+parser = File
+  <$> Module.Imports.parser
+  <*> (blank *> line `sepBy` eol)
+  where
+    eol = string "\r\n" <|> string "\r" <|> string "\n"
+    blank = takeWhile (inClass " \t\r\n")
+    line = takeTill isEndOfLine
+
+header :: Bool -> Path -> [String] -> Text
+header isMain path names = Text.pack (outside isMain ++ arguments)
+  where
+    outside True = ""
+    outside False = printf "modules['%s'] = " (show path)
+    arguments = printf "(function(%s) {" (intercalate ", " $ names ++ ["modules"])
+
+footer :: [String] -> [Text]
+footer values = [Text.pack $ printf "})(%s);" (intercalate ", " values)]
+
+variables :: Tree -> [(String, String)]
+variables = fmap (fmap computeValue) . Map.toList . children
+  where
+    computeValue :: Tree -> String
+    computeValue subTree =
+      let subModules = intercalate ", " $ f <$> Map.toList (children subTree) in
+      case target subTree of
+        Nothing -> printf "Object.create(null, {%s})" subModules
+        Just (ModulePath {modulePath}) ->
+          printf "Object.create(modules['%s'], {%s})"
+            (show modulePath)
+            subModules
+        Just (Object {modulePath, field}) ->
+          printf "modules['%s'].%s" (show modulePath) field
+    f (name, subTree) = printf "%s: {value: %s}" name $ computeValue subTree

src/Module/Imports.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Module.Imports (
+      Reference(..)
+    , Tree(..)
+    , parser
+    , recurse
+  ) where
+
+import Context (Path(..))
+import Control.Applicative ((<|>), many, optional)
+import Data.Attoparsec.Text (
+    Parser, char, count, digit, inClass, letter, sepBy, string, takeWhile
+  )
+import Data.Map (Map, foldlWithKey)
+import qualified Data.Map as Map (empty, insert, lookup)
+import qualified Data.Text as Text (pack)
+import Prelude hiding (takeWhile)
+
+data Reference =
+    ModulePath {modulePath :: Path}
+  | Object {modulePath :: Path, field :: String}
+  deriving Show
+
+data Tree = Tree {
+      target :: Maybe Reference
+    , children :: Map String Tree
+  } deriving Show
+
+data Mapping = Mapping {
+      exposedName :: Path
+    , reference :: Reference
+  }
+
+recurse :: (a -> [String] -> Reference -> a) -> a -> Tree -> 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)
+
+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
+
+emptyTree :: Tree
+emptyTree = Tree {
+      target = Nothing
+    , children = Map.empty
+  }
+
+insertMapping :: Tree -> Mapping -> Tree
+insertMapping tmpTree (Mapping {exposedName, reference}) =
+  insertAt components tmpTree
+  where
+    Path components = exposedName
+    insertAt [] tree = tree {target = Just reference}
+    insertAt (next:restOfPath) tree@(Tree {children}) =
+      let subTree = maybe emptyTree id $ Map.lookup next children in tree {
+        children = Map.insert next (insertAt restOfPath subTree) children
+      }
+
+parser :: Parser Tree
+parser = foldl (foldl insertMapping) emptyTree <$> importParser `sepBy` blank
+  where
+    blank = takeWhile (inClass " \t\r\n")
+    importParser = mappingParser `between` (string "import", char ';')