packages feed

SJW (empty) → 0.1.2.2

raw patch · 14 files changed

+835/−0 lines, 14 filesdep +Cabaldep +SJWdep +attoparsecsetup-changed

Dependencies added: Cabal, SJW, attoparsec, base, containers, directory, filepath, mtl, optparse-applicative, random, text, time, unix

Files

+ CHANGELOG.md view
@@ -0,0 +1,28 @@+# Revision history for SJW++## 0.1.2.2 -- 2020-12-08++* Add tests and a benchmark+* Fix compilation warning about Monoid++## 0.1.2.1 -- 2020-05-21++* Fix bug in loop reporting causing in some cases the display of an inaccurate loop instead of the one actually detected++## 0.1.2.0 -- 2020-01-10++* Expose SJW as a library and make sjw executable use it+* Check all sources directories for existence instead of delaying the fail to individual modules++## 0.1.1.1 -- 2020-01-09++* Fix bug in dependency ordering due to using too naive an approach+* Compiled successfully with base == 4.11++## 0.1.1.0 -- 2020-01-03++* Imports can now span several lines++## 0.1.0.0 -- 2020-01-01++* First working version with a small example
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Tissevert++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tissevert nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ SJW.cabal view
@@ -0,0 +1,81 @@+cabal-version:       >=1.10+-- Initial package description 'SJW.cabal' generated by 'cabal init'.  For+-- further documentation, see http://haskell.org/cabal/users-guide/++name:                SJW+version:             0.1.2.2+synopsis:            The Simple Javascript Wrench+description:+  SJW is a very simple tool to pack several JS «modules» into a single script.+  It doesn't really do proper compilation work (yet) except resolving the+  modules dependencies and detecting import loops but it provides each module+  with an independent execution context in the resulting script.+homepage:            https://git.marvid.fr/Tissevert/SJW+-- bug-reports:+license:             BSD3+license-file:        LICENSE+author:              Tissevert+maintainer:          tissevert+devel@marvid.fr+-- copyright:+category:            Web+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules:     SJW+  other-modules:       SJW.Compiler+                     , SJW.Dependencies+                     , SJW.Module+                     , SJW.Module.File+                     , SJW.Module.Imports+                     , SJW.Source+  build-depends:       attoparsec >= 0.13.2 && < 0.14+                     , base >=4.9 && <4.15+                     , containers >= 0.6.0 && < 0.7+                     , directory >= 1.3.3 && < 1.4+                     , filepath >= 1.4.2 && < 1.5+                     , mtl >= 2.2.2 && < 2.3+                     , random >= 1.1 && < 1.3+                     , text >= 1.2.3 && < 1.3+                     , time >= 1.9.0 && < 1.12+                     , unix >= 2.7.2 && < 2.8+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall++executable sjw+  main-is:             src/Main.hs+  other-modules:       Paths_SJW+  -- other-extensions:+  build-depends:       attoparsec+                     , base+                     , optparse-applicative >= 0.15 && < 0.17+                     , SJW+                     , text+  default-language:    Haskell2010+  ghc-options:         -Wall++benchmark big-src+  type:                exitcode-stdio-1.0+  main-is:             benchmark/Main.hs+  build-depends:       base+                     , directory+                     , filepath+                     , random+                     , SJW+                     , time+  default-language:    Haskell2010+  ghc-options:         -Wall++test-suite tests+  type:                detailed-0.9+  test-module:         Tests+  build-depends:       base+                     , Cabal+                     , directory+                     , filepath+                     , random+                     , SJW+  hs-source-dirs:      test+  default-language:    Haskell2010+  ghc-options:         -Wall
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Main.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE NamedFieldPuns #-}+module Main where++import SJW (Path(..), compile, source, sourceCode)+import Control.Monad (foldM)+import Data.Time.Clock (diffUTCTime, getCurrentTime)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist)+import System.FilePath ((</>), (<.>))+import System.Random (randomRIO)+import Text.Printf (printf)++data FakeModule = FakeModule {+      name :: Path+    , dependencies :: [Path]+  } deriving Show+type DAG = [FakeModule]++moduleNames :: [String]+moduleNames = (:[]) <$> ['A'..'Z']++emptyModule :: Path -> FakeModule+emptyModule name = FakeModule {name, dependencies = []}++addDependency :: Path -> FakeModule -> FakeModule+addDependency path fakeModule = fakeModule {+    dependencies = path : (dependencies fakeModule)+  }++destDir :: FilePath+destDir = "/tmp/SJW-benchmark/giant"++generateCode :: FakeModule -> String+generateCode (FakeModule {dependencies}) = unlines $+  (printf "import %s;" . show <$> dependencies)+  ++ [+      ""+    , "return {"+    , " s: 'truc'"+    , "};"+  ]++combinations :: [a] -> [[a]]+combinations l = ((:[]) <$> l) ++ concat [(:m) <$> l | m <- combinations l]++edit :: Int -> (a -> a) -> [a] -> [a]+edit 0 _ l = l+edit 1 _ [] = []+edit 1 f (x:xs) = (f x):xs+edit n f l =+  let (beginning, end) = splitAt half l in+  edit m f beginning ++ edit (n - m) f end+  where+    half = length l `div` 2+    m = n `div` 2++generateDAG :: Int -> Int -> (Int, Int) -> IO DAG+generateDAG size maxTargets generationSize =+  let paths = ["Main"] : (take size $ combinations moduleNames) in+  addEdges [] $ emptyModule . Path <$> paths+  where+    addEdges ready nodes+      | length nodes < 2 = return $ nodes ++ ready+      | otherwise = do+        (targets, chosen) <- generation nodes+        addEdges (chosen ++ ready) =<< foldM edgesTo targets chosen+    generation nodes = do+      genSize <- randomRIO generationSize+      return $ splitAt (max 1 (length nodes - genSize)) nodes+    edgesTo [mainModule] (FakeModule {name}) =+      return [addDependency name mainModule]+    edgesTo targets (FakeModule {name}) = do+      nTargets <- randomRIO (1, maxTargets)+      (intact, nextGen) <- generation targets+      return (intact ++ edit nTargets (addDependency name) nextGen)++writeFakeModule :: FakeModule -> IO ()+writeFakeModule fakeModule@(FakeModule {name = Path components}) =+  let (parents, fileName) = splitAt (length components - 1) components in+  let directory = foldl (</>) destDir parents in do+  createDirectoryIfMissing True directory+  writeFile (directory </> head fileName <.> "js") $ generateCode fakeModule++main :: IO ()+main = do+  directoryExists <- doesDirectoryExist destDir+  if not directoryExists+  then do+    createDirectoryIfMissing True destDir+    generateDAG 10000 10 (50, 100) >>= mapM_ writeFakeModule+  else return ()+  start <- getCurrentTime+  maybe (return ()) (\_ -> return ()) =<< sourceCode =<< compile (source [destDir])+  end <- getCurrentTime+  mapM_ putStrLn [+        "Compiled 10k modules in " ++ show (diffUTCTime end start)+      , "Left the fake project in " ++ destDir ++ " if you want to poke around"+    ]
+ src/Main.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}+module Main where++import Control.Applicative (many, optional)+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+import qualified Data.Text as Text (unpack)+import Data.Version (showVersion)+import Options.Applicative (+      Parser, execParser, fullDesc, info, header, help, helper, long, metavar+    , short, strArgument, strOption, value+  )+import Paths_SJW (version)+import SJW (Source, compile, mainIs, source, sourceCode)++data Config = Config {+      includes :: [String]+    , mainModuleName :: Maybe String+    , outputFile :: FilePath+    , target :: FilePath+  } deriving (Show)++configParser :: Parser Config+configParser = Config+    <$> many (strOption (+          long "include"+        <> short 'I'+        <> metavar "PACKAGE"+        <> help "Include this package during compilation"+      ))+    <*> optional (strOption (+          long "main-is"+        <> short 'm'+        <> metavar "MODULE_NAME"+        <> help "The name of the main module containing the code to run"+      ))+    <*> strOption (+          long "output"+        <> short 'o'+        <> metavar "OUTPUT_PATH"+        <> help "The path where to create the compiled script (stdout if \"-\" or if the option is missing)"+        <> value "-"+      )+    <*> strArgument (+          metavar "SOURCE_DIR"+        <> help "The path where to look for the sources"+      )++getConfig :: IO Config+getConfig = execParser $+  info+    (helper <*> configParser)+    (fullDesc <> header ("SJW v" ++ showVersion version))++getSource :: Config -> Source+getSource (Config {includes, mainModuleName = Nothing, target}) =+  source (target:includes)+getSource (Config {includes, mainModuleName = Just moduleName, target}) =+  source (target:includes) `mainIs` moduleName++main :: IO ()+main = do+  config@(Config {outputFile}) <- getConfig+  result <- SJW.sourceCode =<< SJW.compile (getSource config)+  case result of+    Nothing -> return ()+    Just code -> output outputFile $ Text.unpack code+  where+    output "-" = putStr+    output fileName = writeFile fileName
+ src/SJW.hs view
@@ -0,0 +1,72 @@+{-# 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
+ src/SJW/Compiler.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+module SJW.Compiler (+    main+  ) where++import SJW.Source (Source(..), HasSource, Path)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.RWS (ask, gets)+import Data.Map ((!))+import qualified Data.Map as Map (member)+import Data.Text (Text, cons)+import qualified Data.Text as Text (null, unlines)+import SJW.Dependencies as Dependencies (Failable, solve)+import SJW.Module (Environment, Log, Module(..), Modules(..))+import qualified SJW.Module as Module (parse, register)+import SJW.Module.File (File(..), variables)+import qualified SJW.Module.File as File (header, footer)++type Compiler m = (HasSource m, Log m, Environment m, MonadIO m, Failable m)++indent :: [Text] -> [Text]+indent = fmap indentLine+  where+    indentLine t+      | Text.null t = t+      | otherwise = cons '\t' t++include :: Environment m => Path -> m [Text]+include path = do+  File {isMain, imports, payload} <- gets (file . (! path) . modules)+  let (names, values) = unzip $ variables imports+  return $ File.header isMain path names : indent payload ++ File.footer values++scan :: Compiler m => Bool -> Path -> m ()+scan isMain modulePath = do+  alreadyLoaded <- gets (Map.member modulePath . modules)+  if alreadyLoaded then return () else load+  where+    load :: Compiler m => m ()+    load = do+      newModule <- Module.parse isMain modulePath+      Module.register modulePath newModule+      mapM_ (scan False) $ dependencies newModule++body :: Compiler m => m [Text]+body = do+  sortedPath <- Dependencies.solve =<< dependenciesGraph+  includes <- concat <$> mapM include sortedPath+  return $ "var modules = {};" : includes+  where+    dependenciesGraph = gets (fmap dependencies . modules)++main :: Compiler m => m Text+main = do+  Source {mainModule} <- ask+  scan True mainModule+  codeBody <- body+  return . Text.unlines $ openOnLoad : indent codeBody ++ [closeOnLoad]+  where+    openOnLoad = "window.addEventListener('load', function() {"+    closeOnLoad = "});"
+ src/SJW/Dependencies.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+module SJW.Dependencies (+      Dependencies+    , Failable+    , solve+  ) where++import SJW.Source (Path)+import Control.Monad.Except (MonadError(..))+import Control.Monad.RWS (MonadState, MonadWriter, evalRWST, gets, modify, tell)+import Data.List (intercalate)+import Data.Map (Map, (!))+import qualified Data.Map as Map (adjust, toList)+import Data.Set (Set)+import Text.Printf (printf)++type Dependencies = Map Path (Set Path)+type Failable = MonadError String++solve :: Failable m => Dependencies -> m [Path]+solve dependencies = snd <$> evalRWST dfs () initState+  where+    initState = State {graph = (,) New <$> dependencies, ariadne = []}++data Flag = New | Temporary | Permanent deriving (Eq, Ord)+data State = State {+      graph :: Map Path (Flag, Set Path)+    , ariadne :: [Path]+  }++type DFSComputation m = (MonadWriter [Path] m, MonadState State m, MonadError String m)++dfs :: DFSComputation m => m ()+dfs = do+  maybeNewNode <- gets (popNew . Map.toList . graph)+  case maybeNewNode of+    Nothing -> return ()+    Just newNode -> visit newNode >> dfs+  where+    popNew [] = Nothing+    popNew ((k, v@(New, _)):_) = Just (k, v)+    popNew (_:others) = popNew others++modifyState :: MonadState State m => ((Path, Flag), [Path] -> [Path]) -> m ()+modifyState ((path, flag), f) = modify $ \state -> state {+      graph = Map.adjust (\(_, set) -> (flag, set)) path $ graph state+    , ariadne = f $ ariadne state+  }++visit :: DFSComputation m => (Path, (Flag, Set Path)) -> m ()+visit (_, (Permanent, _)) = return ()+visit (loopStart, (Temporary, _)) = do+  loop <- gets (dropWhile (/= loopStart) . reverse . ariadne)+  throwError $ printLoop loop+visit (path, (New, set)) = do+  modifyState ((path, Temporary), (path:))+  mapM_ (\depPath -> (,) depPath <$> gets ((!depPath) . graph) >>= visit) set+  modifyState ((path, Permanent), (drop 1))+  tell [path]++printLoop :: [Path] -> String+printLoop [] = "Weird dependencies cycle found"+printLoop (path:paths) = beginning ++ description paths+  where+    beginning = "Dependencies cycle found: "+    description [] = printf "module %s requires itself." (show path)+    description _ =+      printf "%s requires %s which itself requires %s." first others first+    first = show path+    others = intercalate " which requires " $ show <$> paths
+ src/SJW/Module.hs view
@@ -0,0 +1,71 @@+{-# 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"
+ src/SJW/Module/File.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+module SJW.Module.File (+      File(..)+    , header+    , footer+    , parser+    , variables+  ) where++import SJW.Source (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 SJW.Module.Imports (Reference(..), Tree(..))+import qualified SJW.Module.Imports as Imports (parser)+import Prelude hiding (takeWhile)+import Text.Printf (printf)++data File = File {+      isMain :: Bool+    , imports :: Tree+    , payload :: [Text]+  } deriving Show++parser :: Bool -> Parser File+parser isMain = File isMain+  <$> 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/SJW/Module/Imports.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+module SJW.Module.Imports (+      Reference(..)+    , Tree(..)+    , parser+    , recurse+  ) where++import SJW.Source (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\r\n") *> 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 ';')
+ src/SJW/Source.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE ConstraintKinds #-}+module SJW.Source (+      CodePath(..)+    , Source(..)+    , HasSource+    , Path(..)+    , source+  ) where++import Control.Monad.Reader (MonadReader)+import Data.List (intercalate)+import Text.ParserCombinators.ReadP (char, munch, sepBy)+import Text.ParserCombinators.ReadPrec (lift)+import Text.Read (readPrec)++newtype Path = Path [String] deriving (Eq, Ord)+newtype CodePath = CodePath [FilePath]++data Source = Source {+      code :: CodePath+    , mainModule :: Path+  }++type HasSource = MonadReader Source++instance Show Path where+  show (Path components) = intercalate "." components++instance Read Path where+  readPrec = fmap Path . lift $+    munch (/= '.') `sepBy` char '.'++instance Show CodePath where+  show (CodePath dirs) = intercalate ":" dirs++source :: [String] -> Source+source paths = Source {+      code = CodePath paths+    , mainModule = Path ["Main"]+  }
+ test/Tests.hs view
@@ -0,0 +1,42 @@+module Tests (+    tests+  ) where++import Distribution.TestSuite+import SJW (compile, source)+import System.FilePath ((</>))+import Text.Printf (printf)++testData :: FilePath+testData = "test" </> "data"++checkResult :: (String, Bool) -> IO Progress+checkResult (dirName, expected) = do+  result <- either failed passed =<< compile (source [testData </> dirName])+  return . Finished $ if result == expected then Pass else Fail (explain message)+  where+    failed s = putStrLn s>> return False+    passed _ = return True+    explain = uncurry (printf "Compilation %sed when it was expected to %s")+    message = if expected then ("fail", "succeed") else ("succeed", "fail")++makeTest :: (String, Bool) -> TestInstance+makeTest (patternName, expected) = testInstance+  where+    testInstance = TestInstance {+          run = checkResult (patternName, expected)+        , name = patternName+        , tags = []+        , options = []+        , setOption = \_ _ -> Right testInstance+      }++tests :: IO [Test]+tests = return $ (Test . makeTest) <$> [+      ("cycle", False)+    , ("diamond", True)+    , ("loop", False)+    , ("q", False)+    , ("simple", True)+    , ("triangle", True)+  ]