Explode module «Module» into several parts specialized in Imports, Environment handling and simple File parsing and compiling
This commit is contained in:
parent
f3c43c79e7
commit
73e7afc7e8
8 changed files with 251 additions and 194 deletions
|
|
@ -22,6 +22,9 @@ executable sjw
|
|||
other-modules: Compiler
|
||||
, Context
|
||||
, Module
|
||||
, Module.Environment
|
||||
, Module.File
|
||||
, Module.Imports
|
||||
, Paths_SJW
|
||||
, Priority
|
||||
-- other-extensions:
|
||||
|
|
|
|||
|
|
@ -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 Module (Compiler, Entry(..), ImportTree(..), Module(..), Modules, Reference(..))
|
||||
import qualified Module (ModuleSpace(..), buildEntry, parse, register, reorder)
|
||||
import qualified Data.Text as Text (null, unlines)
|
||||
import Module (Environment, Failable, Log, Module(..), Log)
|
||||
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)]
|
||||
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 :: Environment 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
|
||||
alreadyLoaded <- gets (Map.member modulePath . Module.entries)
|
||||
Environment.reorder $ Priority.set modulePath priority
|
||||
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
|
||||
Module.register modulePath newEntry
|
||||
mapM_ (scan (priority + 1)) $ dependencies newEntry
|
||||
newModule <- Module.parse modulePath
|
||||
Environment.register modulePath newModule
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
162
src/Module.hs
162
src/Module.hs
|
|
@ -1,176 +1,44 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Module (
|
||||
Compiler
|
||||
, Contextual
|
||||
, Entry(..)
|
||||
Environment
|
||||
, Failable
|
||||
, ImportTree(..)
|
||||
, Log
|
||||
, Module(..)
|
||||
, Modules
|
||||
, ModuleSpace(..)
|
||||
, Reference(..)
|
||||
, buildEntry
|
||||
, emptySpace
|
||||
, parse
|
||||
, register
|
||||
, reorder
|
||||
) where
|
||||
|
||||
import Context (CodePath(..), Context(..), Path(..))
|
||||
import Control.Applicative ((<|>), many, optional)
|
||||
import Context (CodePath(..), Context(..), Contextual, Path(..))
|
||||
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 Control.Monad.RWS (MonadWriter, asks)
|
||||
import Data.Attoparsec.Text (parseOnly)
|
||||
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
|
||||
, payload :: [Text]
|
||||
} deriving Show
|
||||
|
||||
data Entry = Entry {
|
||||
content :: Module
|
||||
file :: Module.File.File
|
||||
, 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 Environment = HasEnvironment Module
|
||||
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}
|
||||
build :: File -> Module
|
||||
build file = Module {file, 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 =<<
|
||||
parseOnly moduleParser . Text.pack <$> liftIO (readFile source)
|
||||
Just source -> either throwError (return . build) =<<
|
||||
parseOnly Module.File.parser . Text.pack <$> liftIO (readFile source)
|
||||
|
||||
find :: MonadIO m => CodePath -> Path -> m (Maybe FilePath)
|
||||
find (CodePath []) _ = return Nothing
|
||||
|
|
|
|||
39
src/Module/Environment.hs
Normal file
39
src/Module/Environment.hs
Normal file
|
|
@ -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
|
||||
}
|
||||
63
src/Module/File.hs
Normal file
63
src/Module/File.hs
Normal file
|
|
@ -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
|
||||
101
src/Module/Imports.hs
Normal file
101
src/Module/Imports.hs
Normal file
|
|
@ -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 ';')
|
||||
Loading…
Reference in a new issue