120 lines
4.0 KiB
Haskell
120 lines
4.0 KiB
Haskell
--- SJW -- Clean Javascript modules for front-end development
|
|
--- Copyright © 2022 Tissevert <tissevert+devel@marvid.fr>
|
|
---
|
|
--- This file is part of SJW.
|
|
---
|
|
--- SJW is free software: you can redistribute it and/or modify it under the
|
|
--- terms of the GNU General Public License as published by the Free Software
|
|
--- Foundation, either version 3 of the License, or (at your option) any later
|
|
--- version.
|
|
---
|
|
--- SJW is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
|
--- FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
|
|
--- details.
|
|
---
|
|
--- You should have received a copy of the GNU General Public License along
|
|
--- with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
{-# 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 ';')
|