diff --git a/src/Nirum/Constructs/ModulePath.hs b/src/Nirum/Constructs/ModulePath.hs index bad81cf..0f8579a 100644 --- a/src/Nirum/Constructs/ModulePath.hs +++ b/src/Nirum/Constructs/ModulePath.hs @@ -8,10 +8,14 @@ module Nirum.Constructs.ModulePath ( ModulePath ( ModuleName , fromIdentifiers , hierarchy , hierarchies + , isPrefixOf , replacePrefix + , root + , stripPrefix ) where import Data.Char (toLower) +import qualified Data.List as L import Data.Maybe (fromMaybe, mapMaybe) import GHC.Exts (IsList (Item, fromList, toList)) @@ -64,6 +68,9 @@ hierarchy m@(ModulePath parent _) = m `S.insert` hierarchy parent hierarchies :: S.Set ModulePath -> S.Set ModulePath hierarchies modulePaths = S.unions $ toList $ S.map hierarchy modulePaths +isPrefixOf :: ModulePath -> ModulePath -> Bool +a `isPrefixOf` b = toList a `L.isPrefixOf` toList b + replacePrefix :: ModulePath -> ModulePath -> ModulePath -> ModulePath replacePrefix from to path' | path' == from = to @@ -71,11 +78,22 @@ replacePrefix from to path' ModuleName {} -> path' ModulePath p n -> ModulePath (replacePrefix from to p) n +root :: ModulePath -> Identifier +root = head . toList + +stripPrefix :: ModulePath -> ModulePath -> Maybe ModulePath +stripPrefix a b = do + stripped <- L.stripPrefix (toList a) (toList b) + case stripped of + [] -> Nothing + xs -> Just $ fromList xs instance IsList ModulePath where type Item ModulePath = Identifier fromList identifiers = fromMaybe (error "ModulePath cannot be empty") (fromIdentifiers identifiers) - toList (ModuleName identifier) = [identifier] - toList (ModulePath path' identifier) = toList path' ++ [identifier] + toList mp = toList' mp [] + where + toList' (ModuleName identifier) xs = identifier:xs + toList' (ModulePath path' identifier) xs = toList' path' (identifier:xs) diff --git a/src/Nirum/Targets/Rust.hs b/src/Nirum/Targets/Rust.hs index 071ac97..5736477 100644 --- a/src/Nirum/Targets/Rust.hs +++ b/src/Nirum/Targets/Rust.hs @@ -4,15 +4,20 @@ module Nirum.Targets.Rust ( Rust , Code , CompileError + , childModules ) where import qualified Data.Map.Strict as M +import Data.Maybe import qualified Data.SemVer as SV +import Data.Semigroup +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy (toStrict) import Data.Typeable (Typeable) +import System.FilePath import GHC.Exts (IsList (toList)) @@ -20,7 +25,7 @@ import Text.Blaze.Renderer.Text import Text.Heterocephalus (compileText) import qualified Nirum.Constructs.Identifier as I -import Nirum.Constructs.ModulePath (ModulePath) +import Nirum.Constructs.ModulePath import Nirum.Constructs.TypeDeclaration import Nirum.Package.Metadata import qualified Nirum.Package.ModuleSet as MS @@ -70,7 +75,7 @@ compilePackage' package = , Right $ toStrict $ TL.append (buildPrologue mod') - (buildBody (mp >>= resolveWithModulePath)) + (buildBody (resolveWithModulePath mp)) ) | mod'@RustModule { filePath = fileName , modPath = mp @@ -81,7 +86,33 @@ compilePackage' package = resolveWithModulePath :: ModulePath -> Maybe (BoundModule Rust) resolveWithModulePath mp = resolveBoundModule mp package modules' :: [RustModule] - modules' = buildRustModuleList [mp | (mp, _) <- MS.toAscList $ modules package] + modules' = libModule : map (toRustModule expanded') (toList expanded') + expanded' = hierarchies $ S.fromList $ MS.keys $ modules package + libModule = RustModule { filePath = toFilePath True ["lib"] + , modPath = ["lib"] + , children = S.map root expanded' + } + +childModules :: Foldable f => f ModulePath -> ModulePath -> S.Set I.Identifier +childModules modPaths base = fromMaybe mempty $ getOption $ foldMap f modPaths + where + f = Option . fmap (S.singleton . root) . stripPrefix base + +toFilePath :: Bool -> ModulePath -> FilePath +toFilePath isLeaf p = joinPath ("src" : converted) ++ ".rs" + where + convert = map (toRustIdentifier I.toSnakeCaseText) . toList + converted = map T.unpack $ convert p ++ (if isLeaf then [] else ["mod"]) + +toRustModule :: Foldable f => f ModulePath -> ModulePath -> RustModule +toRustModule modPaths mp = RustModule { filePath = filePath' + , modPath = mp + , children = children' + } + where + children' = childModules modPaths mp + isLeaf = S.null children' + filePath' = toFilePath isLeaf mp instance Target Rust where type CompileResult Rust = Code diff --git a/src/Nirum/Targets/Rust/ModuleTree.hs b/src/Nirum/Targets/Rust/ModuleTree.hs index 1592311..fa92d9c 100644 --- a/src/Nirum/Targets/Rust/ModuleTree.hs +++ b/src/Nirum/Targets/Rust/ModuleTree.hs @@ -4,114 +4,15 @@ module Nirum.Targets.Rust.ModuleTree ( RustModule ( RustModule , modPath , children ) - , buildRustModuleList ) where -import Data.List -import qualified Data.Text as T -import Data.Tree - -import GHC.Exts (IsList (toList)) - -import System.FilePath (joinPath) +import qualified Data.Set as S import Nirum.Constructs.Identifier import Nirum.Constructs.ModulePath (ModulePath) -import Nirum.Targets.Rust.Keyword - -data UnpackedModule = UnpackedModule { unpackedModulePath :: [Identifier] - , originalModulePath :: ModulePath - } -data ModuleNode = ModuleNode { moduleName :: Identifier - , moduleNodePath :: Maybe ModulePath - } - -instance Eq UnpackedModule where - a == b = (unpackedModulePath a) == (unpackedModulePath b) -instance Ord UnpackedModule where - a <= b = (unpackedModulePath a) <= (unpackedModulePath b) - -type ModuleTree = Tree ModuleNode data RustModule = RustModule { filePath :: FilePath - , modPath :: Maybe ModulePath - , children :: [Identifier] + , modPath :: ModulePath + , children :: S.Set Identifier } - --- type a = Identifier --- type b = (Identifier, [UnpackedModule]) --- moduleUnfolder :: b -> (a, [b]) -moduleUnfolder :: (ModuleNode, [UnpackedModule]) - -> (ModuleNode, [(ModuleNode, [UnpackedModule])]) -moduleUnfolder (ident, mps) = - (ident, groupByParent mps) - where - isParentEqual :: UnpackedModule -> UnpackedModule -> Bool - isParentEqual UnpackedModule { unpackedModulePath = (a:_) } - UnpackedModule { unpackedModulePath = (b:_) } = - a == b - isParentEqual _ _ = False - extractCommonParent :: [UnpackedModule] -> (ModuleNode, [UnpackedModule]) - extractCommonParent mps' = - ( ModuleNode { moduleName = commonParent - , moduleNodePath = maybeModulePath - } - , [ UnpackedModule { unpackedModulePath = x:xs - , originalModulePath = omn - } - | UnpackedModule { unpackedModulePath = x:xs - , originalModulePath = omn - } <- mps' - ] - ) - where - commonParent :: Identifier - commonParent = head $ unpackedModulePath $ head mps' - maybeModulePath :: Maybe ModulePath - maybeModulePath = - fmap originalModulePath $ - find (((==) 1) . length . unpackedModulePath) mps' - groupByParent :: [UnpackedModule] -> [(ModuleNode, [UnpackedModule])] - groupByParent = (map extractCommonParent) . (groupBy isParentEqual) . sort - -buildModuleTree :: [ModulePath] -> ModuleTree -buildModuleTree mps = - unfoldTree moduleUnfolder seed - where - srcModule :: ModuleNode - srcModule = ModuleNode { moduleName = "src" - , moduleNodePath = Nothing - } - seed :: (ModuleNode, [UnpackedModule]) - seed = ( srcModule - , [ UnpackedModule { unpackedModulePath = toList mp - , originalModulePath = mp - } - | mp <- mps - ] - ) - -toRustModuleList :: [String] -> ModuleTree -> [RustModule] -toRustModuleList baseDir Node { rootLabel = ModuleNode { moduleName = modName - , moduleNodePath = modPath' - } - , subForest = children' - } = - RustModule { filePath = joinPath identPath - , modPath = modPath' - , children = map (moduleName . rootLabel) children' - } : - (concat $ map (toRustModuleList identPath) children') - where - libOrMod :: String - libOrMod = case baseDir of - [] -> "lib.rs" - _ -> "mod.rs" - identPath :: [String] - identPath = - baseDir ++ - [T.unpack $ toRustIdentifier toSnakeCaseText modName] ++ - [libOrMod] - -buildRustModuleList :: [ModulePath] -> [RustModule] -buildRustModuleList = (toRustModuleList []) . buildModuleTree + deriving (Eq, Show) diff --git a/test/Nirum/Targets/RustSpec.hs b/test/Nirum/Targets/RustSpec.hs new file mode 100644 index 0000000..f5c1e26 --- /dev/null +++ b/test/Nirum/Targets/RustSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedLists, PartialTypeSignatures #-} +module Nirum.Targets.RustSpec where + +import qualified Data.Set as S +import Test.Hspec.Meta + +import Nirum.Constructs.ModulePath +import Nirum.Targets.Rust + + +spec :: Spec +spec = parallel $ + describe "childModules" $ do + specify "empty list" $ do + childModules S.empty ["a"] `shouldBe` [] + childModules S.empty ["a", "b"] `shouldBe` [] + specify "singleton" $ do + childModules ([["a"]] :: [ModulePath]) ["a"] `shouldBe` [] + childModules (S.singleton ["foo"]) ["foo"] `shouldBe` [] + childModules ([["foo"]] :: [ModulePath]) ["bar"] `shouldBe` [] + specify "simple" $ do + let input = [ ["a"] + , ["a", "b"] + , ["a", "c", "e"] + , ["b"] + , ["b", "c"] + , ["b", "d"] + ] :: [ModulePath] + childModules input ["a"] `shouldBe` ["b", "c"] + childModules input ["b"] `shouldBe` ["c", "d"] + childModules input ["c"] `shouldBe` [] + childModules input ["a", "b"] `shouldBe` [] + childModules input ["a", "c"] `shouldBe` ["e"] diff --git a/test/nirum_fixture/package.toml b/test/nirum_fixture/package.toml index 79b9a3e..4cc9008 100644 --- a/test/nirum_fixture/package.toml +++ b/test/nirum_fixture/package.toml @@ -12,3 +12,5 @@ email = "dev@nirum.org" name = "nirum_fixture" [targets.python.renames] "renames.test" = "renamed" +[targets.rust] +name = "nirum_fixture"