1 files changed, 170 insertions, 0 deletions
diff --git a/Omni/Namespace.hs b/Omni/Namespace.hs
new file mode 100644
index 0000000..ef8cefd
--- /dev/null
+++ b/Omni/Namespace.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Omni.Namespace
+  ( Namespace (..),
+    Ext (..),
+    fromPath,
+    toPath,
+    toModule,
+    fromHaskellContent,
+    fromHaskellModule,
+    toHaskellModule,
+    toSchemeModule,
+    fromPythonModule,
+    isCab,
+    groupByExt,
+  )
+where
+
+import Alpha
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.List.Split as List
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+import qualified Text.Regex.Applicative as Regex
+
+data Ext
+  = C
+  | Css
+  | Hs
+  | Html
+  | Json
+  | Keys
+  | Lisp
+  | Md
+  | Nix
+  | None
+  | Py
+  | Rs
+  | Scm
+  | Sh
+  | Toml
+  deriving (Eq, Show, Generic, Aeson.ToJSON, Ord)
+
+data Namespace = Namespace {path :: [String], ext :: Ext}
+  deriving (Eq, Show, Generic, Aeson.ToJSON, Ord)
+
+instance Aeson.ToJSONKey Namespace where
+  toJSONKey = Aeson.toJSONKeyText (Text.pack <. toPath)
+
+fromPath :: String -> String -> Maybe Namespace
+fromPath coderoot absPath =
+  List.stripPrefix coderoot absPath
+    +> List.stripPrefix "/"
+    +> Regex.match (Namespace </ rePath <* dot <*> reExt)
+
+toPath :: Namespace -> FilePath
+toPath (Namespace parts ext) =
+  joinWith "/" parts <> toExt ext
+
+toExt :: Ext -> String
+toExt =
+  ("." <>) <. \case
+    C -> "c"
+    Css -> "css"
+    Hs -> "hs"
+    Html -> "html"
+    Json -> "json"
+    Keys -> "pub"
+    Lisp -> "lisp"
+    Md -> "md"
+    Nix -> "nix"
+    None -> "none"
+    Py -> "py"
+    Rs -> "rs"
+    Scm -> "scm"
+    Sh -> "sh"
+    Toml -> "toml"
+
+fromHaskellContent :: String -> Maybe Namespace
+fromHaskellContent c = case Regex.findFirstInfix haskellModule c of
+  Nothing -> Nothing
+  Just (_, Namespace {..}, _) -> Just <| Namespace (filter (/= ".") path) ext
+  where
+    haskellModule =
+      Namespace
+        </ (Regex.string "\nmodule " *> Regex.many (name <|> dot))
+        <*> pure Hs
+
+toModule :: Namespace -> String
+toModule (Namespace parts Hs) = joinWith "." parts
+toModule (Namespace parts Py) = joinWith "." parts
+toModule (Namespace parts Scm) = "(" ++ joinWith " " parts ++ ")"
+toModule (Namespace parts Rs) = joinWith "::" parts
+toModule (Namespace parts C) = joinWith "/" parts <> ".c"
+toModule (Namespace parts Nix) = joinWith "/" parts <> ".nix"
+toModule (Namespace {..}) = panic <| "toModule not implemented for " <> show ext
+
+toHaskellModule :: Namespace -> String
+toHaskellModule = toModule
+
+fromHaskellModule :: String -> Namespace
+fromHaskellModule s = Namespace (List.splitOn "." s) Hs
+
+toSchemeModule :: Namespace -> String
+toSchemeModule = toModule
+
+fromPythonModule :: String -> Namespace
+fromPythonModule s = Namespace (List.splitOn "." s) Py
+
+dot :: Regex.RE Char String
+dot = Regex.some <| Regex.sym '.'
+
+name :: Regex.RE Char String
+name =
+  Regex.many (Regex.psym Char.isUpper)
+    <> ( Regex.many
+           <| Regex.psym
+           <| \c -> Char.isAlphaNum c || c == '_' || c == '-'
+       )
+
+rePath :: Regex.RE Char [String]
+rePath = Regex.many (name <* Regex.string "/" <|> name)
+
+reExt :: Regex.RE Char Ext
+reExt =
+  C
+    <$ Regex.string "c"
+    <|> Css
+    <$ Regex.string "css"
+    <|> Hs
+    <$ Regex.string "hs"
+    <|> Html
+    <$ Regex.string "html"
+    <|> Json
+    <$ Regex.string "json"
+    <|> Keys
+    <$ Regex.string "pub"
+    <|> Lisp
+    <$ Regex.string "lisp"
+    <|> Md
+    <$ Regex.string "md"
+    <|> Nix
+    <$ Regex.string "nix"
+    <|> Py
+    <$ Regex.string "py"
+    <|> Rs
+    <$ Regex.string "rs"
+    <|> Scm
+    <$ Regex.string "scm"
+    <|> Sh
+    <$ Regex.string "sh"
+    <|> Toml
+    <$ Regex.string "toml"
+
+-- | The cab dir is for temporary files and build outputs, not for source
+-- inputs.
+isCab :: FilePath -> Bool
+isCab ('_' : _) = True
+isCab fp = "/_/" `List.isInfixOf` fp
+
+-- | Group a list of Namespaces keyed by their extensions
+groupByExt :: [Namespace] -> Map Ext [Namespace]
+groupByExt ns's = Map.fromListWith (++) [(ext ns, [ns]) | ns <- ns's]