Merge pull request #1 from Kroisse/rust-target

Replace module resolution algorithm

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,18 +68,32 @@ 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
  | otherwise = case path' of
                    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)

src/Nirum/Targets/Rust.hs

@@ -4,23 +4,28 @@
 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))
 
 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

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)

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"]

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"