hashirama/waza-hs
hashirama/waza-hs
Watch
1
0
Fork
You've already forked waza-hs
 0
Code Issues Pull requests Projects Releases Wiki Activity Actions

fix & update

Browse source
This commit is contained in:
千住柱間 2025-09-12 21:36:11 -04:00
commit 2277a8a59f
Signed by: hashirama
GPG key ID: 53E62470A86BC185
14 changed files with 46 additions and 950 deletions
Download patch file Download diff file Expand all files Collapse all files

23
README.md
View file

@ -5,26 +5,9 @@ wazajisho library for handling japanese text in haskell
<img src="https://git.ajattix.org/hashirama/waza-hs/raw/branch/main/misc/cover.jpg" alt="cover" width="30%" height="30%">
### FileUtils.h
for managing dictionaries we have a custom data structure, and you can use it that way:
```haskell
-- Access all directories in the list of FileGroups
let directories = map directory fileGroups
print directories -- ["/mnt/data1", "/mnt/data2"]
-- Access all file lists in the list of FileGroups
let filesList = map files fileGroups
print filesList -- [["file1.mdx", "file2.css"], ["file3.mdx", "file4.png"]]
-- Filter the FileGroups where any file in the files list contains ".mdx"
let mdict_filter = filter (\group -> any (isSuffixOf ".mdx") (files group)) fileGroups
-- Access all files of the filtered FileGroups
let mdict_files = map files mdict_files
### usage:
``` shell
$ ghc -o myprog examples/Main.hs -i./src
```
you can for example, pass that list as a parameter for loading all of those dictionaries in [mdict-cpp](https://github.com/dictlab/mdict-cpp)
TODO: move those functions to be some kind of helpers or operators

BIN
examples/Main.hi Normal file
View file

Binary file not shown.

9
examples/Main.hs
View file

@ -1,7 +1,8 @@
import KanaConv (convertHalfToFull)
module Main where
import Wazahs (listFiles)
main :: IO ()
main = do
let input = "おいそこのｷﾐ｡あっはいはいはいは～い｡"
let output = convertHalfToFull input
putStrLn output
files <- listFiles "/mnt/Data/Japanese_Resources/Dictionaries/Own_Collection/"
mapM_ putStrLn files

BIN
examples/Main.o Normal file
View file

Binary file not shown.

180
src/FileUtils.hs
View file

@ -1,180 +0,0 @@
-- Copyright © 2024 Hashirama Senju
import System.Clock -- To measure time
import System.Console.ANSI -- For colored output
--
import Z.Data.CBytes (pack, unpack)
import Z.IO.FileSystem (scandirRecursively)
import System.FilePath (takeDirectory)
import Data.List (groupBy, isSuffixOf, isPrefixOf, nub)
import System.IO
import qualified Data.Map as Map
import Control.Concurrent.Async (mapConcurrently)
import Control.Concurrent
import Control.Monad
import Data.Char (isSpace)
-- Derived version with automatic string handling
scanDirectoryRecursivelyStr :: String -> IO [String]
scanDirectoryRecursivelyStr path = do
result <- scandirRecursively (pack path) (\p _ -> return True)
return (map unpack result) -- Ensures all results are decoded to Strings (UTF-8)
-- Function to filter files with a specific extension
filterMdx :: [String] -> String -> [String]
filterMdx files ext = filter (isSuffixOf ext) files
-- Custom implementation of takeDirectory for UTF-8 strings
takeDirectory' :: String -> String
takeDirectory' path = reverse . dropWhile (/= '/') . reverse $ path
data FileGroup = FileGroup
{ directory :: String -- The directory part of the file path (UTF-8 String)
, files :: [String] -- List of file paths in that directory (UTF-8 Strings)
} deriving (Show, Eq)
-- Create a map from directory to list of .mdx files
groupMdxByDirectory :: [String] -> Map.Map String [String]
groupMdxByDirectory mdxFiles =
Map.fromListWith (++) [(takeDirectory' file, [file]) | file <- mdxFiles]
-- Group files by their directory, including additional files that belong to the same directory
groupFilesByDirectory :: [String] -> [String] -> IO [FileGroup]
groupFilesByDirectory mdxFiles additionalFiles = do
-- Create a map of directories to .mdx files
let mdxMap = groupMdxByDirectory mdxFiles
-- Function to process each directory group in parallel
let processGroup dir mdxFilesInDir = do
let -- Filter additional files that belong to the same directory
additionalFilesInDir = filter (\f -> takeDirectory' f == dir) additionalFiles
-- Remove matching files from additional files (those that are already in the .mdx list)
remainingAdditionalFiles = filter (\f -> not (f `elem` mdxFilesInDir)) additionalFilesInDir
-- Combine and remove duplicates
allFiles = nub (mdxFilesInDir ++ remainingAdditionalFiles)
return $ FileGroup dir allFiles
-- Process each directory group concurrently
groupedFiles <- mapConcurrently (\(dir, mdxFilesInDir) -> processGroup dir mdxFilesInDir) (Map.toList mdxMap)
return groupedFiles
-- Function to convert FileGroup to a string representation for file output
fileGroupToString :: FileGroup -> String
fileGroupToString (FileGroup dir files) =
"Directory: " ++ dir ++ "\n" ++
unlines (map (" " ++) files)
-- Box-like animation function with green color
boxAnimation :: IO ()
boxAnimation = do
let frames = ["[ ]", "[. ]", "[ . ]", "[ .]"] -- Frame progression for box
let loop frames' = do
mapM_ (\frame -> do
setSGR [SetColor Foreground Vivid Green] -- Set the box color to green
putStr "\r" -- Move cursor to the start of the line
putStr frame -- Print the current frame
hFlush stdout -- Flush output buffer
threadDelay 200000) frames' -- Wait 0.2 seconds between frames
loop frames' -- Recursively call to keep the loop running
loop frames -- Start the looping animation
-- A simple trim function to remove leading/trailing whitespace
trim :: String -> String
trim = f . f
where f = reverse . dropWhile isSpace
-- Process lines to produce a list of (directory, [file paths]) tuples.
-- It ignores lines until the first "Directory:" is found (and discards it),
-- then uses subsequent "Directory:" lines to start new groups.
processLines :: [String] -> [(String, [String])]
processLines = reverse . go False []
where
-- The Bool flag indicates whether we've encountered the first "Directory:" line.
go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])]
go _ acc [] = acc
-- Before the first "Directory:" has been seen:
go False acc (line:rest)
| "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence.
| otherwise = go False acc rest
-- After the first "Directory:" has been skipped, but before starting any group:
go True [] (line:rest)
| "Directory:" `isPrefixOf` line =
let dir = trim (drop 11 line)
in go True [(dir, [])] rest
| otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence.
-- When a group has been started:
go True ((currentDir, files):xs) (line:rest)
| "Directory:" `isPrefixOf` line =
let dir = trim (drop 11 line)
in go True ((dir, []):(currentDir, files):xs) rest
| otherwise =
go True ((currentDir, files ++ [trim line]) : xs) rest
{-
this should be used that way:
result <- getData "output.txt"
let finalresult = processLines result -- that way we maintain purity
-}
getData :: FilePath -> IO [String]
getData f = do
content <- readFile f
return (lines content)
-- Main function
main :: IO ()
main = do
-- Start timing the operation
start <- getTime Monotonic
-- Notify the start of processing with color
setSGR [SetColor Foreground Vivid Blue]
putStrLn "Processing started..."
setSGR [Reset] -- Reset colors
-- Create a thread for the box animation
animationThread <- forkIO boxAnimation
allFiles <- scanDirectoryRecursivelyStr "/mnt/Data/Japanese_Resources/"
-- Filter files with '.mdx' extension
let mdxFiles = filterMdx allFiles ".mdx"
-- Group the files by their directories concurrently
groupedFiles <- groupFilesByDirectory mdxFiles allFiles
-- just to show that we finished processing, might be faster than doing I/O
putStrLn "Processing complete. Data is grouped."
-- Kill the animation thread
killThread animationThread
-- Stop timing the operation
end <- getTime Monotonic
let elapsed = toNanoSecs (diffTimeSpec end start) `div` 1000000 -- Convert to milliseconds
-- Show a colorful message after processing with elapsed time
setSGR [SetColor Foreground Vivid Green]
putStrLn $ "Processing complete. Time taken: " ++ show elapsed ++ " ms."
setSGR [Reset] -- Reset colors
putStrLn "Starting to write results..."
animationThread <- forkIO boxAnimation
-- Open the output file and set its encoding to UTF-8
withFile "output.txt" WriteMode $ \handle -> do
hSetEncoding handle utf8
-- Write the grouped files to the file
mapM_ (hPutStrLn handle . fileGroupToString) groupedFiles
killThread animationThread

290
src/IconToolbar.hs
View file

@ -1,290 +0,0 @@
{-# LANGUAGE OverloadedStrings, OverloadedLabels, ImplicitParams #-}
-- Copyright © 2025 Hashirama Senju
import System.Clock -- To measure time
import System.Console.ANSI -- For colored output
--
import Z.Data.CBytes (pack, unpack)
import Z.IO.FileSystem (scandirRecursively)
import System.FilePath (takeDirectory, dropExtension, takeExtension)
import Data.List (groupBy, isSuffixOf, isPrefixOf, nub, find)
import System.IO
import qualified Data.Map as Map
import Control.Concurrent.Async (mapConcurrently)
import Control.Concurrent
import Control.Monad
import Data.Char (isSpace)
import Data.Maybe (mapMaybe, maybeToList)
import qualified GI.Gtk as Gtk
import GI.Gtk (Grid(..), Image(..), Orientable(..))
import GI.Gio
import Control.Monad (void)
import qualified Data.Text as T
{-# LANGUAGE OverloadedStrings #-}
import qualified GI.Gtk as Gtk
import GI.Gtk (AttrOp((:=)))
import Data.Text (Text)
import qualified Data.Text as T
createIconToolbar' :: [FilePath] -> IO Gtk.Box
createIconToolbar' iconPaths = do
toolbar <- Gtk.boxNew Gtk.OrientationHorizontal 0
Gtk.widgetSetHalign toolbar Gtk.AlignCenter
Gtk.widgetSetValign toolbar Gtk.AlignCenter
cssProvider <- Gtk.cssProviderNew
Gtk.cssProviderLoadFromString cssProvider $ T.pack $
".classic-button {"
++ " -gtk-appearance: none;"
++ " background-image: linear-gradient(to bottom, #f3f3f3, #d8d8d8);"
++ " border: 1px solid #bbb;"
++ " border-radius: 4px;"
++ " color: #333;"
++ " box-shadow: inset 0 1px 0 rgba(255,255,255,0.7);"
++ " padding: 4px 8px;"
++ "}"
++ ".classic-button:hover {"
++ " background-image: linear-gradient(to bottom, #e6e6e6, #ccc);"
++ "}"
++ ".classic-button:active {"
++ " background-image: linear-gradient(to bottom, #ccc, #e6e6e6);"
++ "}"
mapM_ (\path -> do
icon <- Gtk.imageNewFromFile path
Gtk.widgetSetSizeRequest icon 64 64 -- Force minimum size
btn <- Gtk.buttonNew
Gtk.widgetAddCssClass btn "glass-button"
Gtk.widgetSetSizeRequest btn 80 80 -- Button size (icon + padding)
Gtk.widgetSetHalign btn Gtk.AlignCenter
Gtk.widgetSetValign btn Gtk.AlignCenter
Gtk.buttonSetChild btn (Just icon)
-- Add click handler
void $ Gtk.on btn #clicked $ do
putStrLn $ "Selected: " ++ path
-- Add your click handler logic here
Gtk.boxAppend toolbar btn
) iconPaths
return toolbar
-- Wrap the toolbar in a ScrolledWindow that scrolls horizontally
createIconToolbar :: [FilePath] -> IO Gtk.Widget
createIconToolbar iconPaths = do
-- Get your original toolbar (horizontal box)
toolbar <- createIconToolbar' iconPaths
-- Create a new scrolled window
scrolled <- Gtk.scrolledWindowNew
-- Show the horizontal scrollbar automatically, never show the vertical one
Gtk.scrolledWindowSetPolicy scrolled Gtk.PolicyTypeAutomatic Gtk.PolicyTypeNever
-- Put the horizontal box (your toolbar) inside the scrolled window
Gtk.scrolledWindowSetChild scrolled (Just toolbar)
-- Return as a general Widget
Gtk.toWidget scrolled
---
type FileList = [(String, [String])] -- (Directory, Files)
extractIcons :: FileList -> [String] -- List of icon paths
extractIcons = concatMap processGroup
where
processGroup (_, files) = maybeToList (findIcon files)
findIcon :: [String] -> Maybe String
findIcon files = do
mdxFile <- find isMdxFile files
let baseName = dropExtension mdxFile
find (isIconFile baseName) files
where
isMdxFile file = takeExtension file == ".mdx"
isIconFile base file =
dropExtension file == base &&
takeExtension file `elem` imageExtensions
imageExtensions :: [String]
imageExtensions = [".png", ".jpg", ".jpeg", ".gif", ".bmp", ".svg"]
-- Derived version with automatic string handling
scanDirectoryRecursivelyStr :: String -> IO [String]
scanDirectoryRecursivelyStr path = do
result <- scandirRecursively (pack path) (\p _ -> return True)
return (map unpack result) -- Ensures all results are decoded to Strings (UTF-8)
-- Function to filter files with a specific extension
filterMdx :: [String] -> String -> [String]
filterMdx files ext = filter (isSuffixOf ext) files
-- Custom implementation of takeDirectory for UTF-8 strings
takeDirectory' :: String -> String
takeDirectory' path = reverse . dropWhile (/= '/') . reverse $ path
data FileGroup = FileGroup
{ directory :: String -- The directory part of the file path (UTF-8 String)
, files :: [String] -- List of file paths in that directory (UTF-8 Strings)
} deriving (Show, Eq)
-- Create a map from directory to list of .mdx files
groupMdxByDirectory :: [String] -> Map.Map String [String]
groupMdxByDirectory mdxFiles =
Map.fromListWith (++) [(takeDirectory' file, [file]) | file <- mdxFiles]
-- Group files by their directory, including additional files that belong to the same directory
groupFilesByDirectory :: [String] -> [String] -> IO [FileGroup]
groupFilesByDirectory mdxFiles additionalFiles = do
-- Create a map of directories to .mdx files
let mdxMap = groupMdxByDirectory mdxFiles
-- Function to process each directory group in parallel
let processGroup dir mdxFilesInDir = do
let -- Filter additional files that belong to the same directory
additionalFilesInDir = filter (\f -> takeDirectory' f == dir) additionalFiles
-- Remove matching files from additional files (those that are already in the .mdx list)
remainingAdditionalFiles = filter (\f -> not (f `elem` mdxFilesInDir)) additionalFilesInDir
-- Combine and remove duplicates
allFiles = nub (mdxFilesInDir ++ remainingAdditionalFiles)
return $ FileGroup dir allFiles
-- Process each directory group concurrently
groupedFiles <- mapConcurrently (\(dir, mdxFilesInDir) -> processGroup dir mdxFilesInDir) (Map.toList mdxMap)
return groupedFiles
-- Function to convert FileGroup to a string representation for file output
fileGroupToString :: FileGroup -> String
fileGroupToString (FileGroup dir files) =
"Directory: " ++ dir ++ "\n" ++
unlines (map (" " ++) files)
-- Box-like animation function with green color
boxAnimation :: IO ()
boxAnimation = do
let frames = ["[ ]", "[. ]", "[ . ]", "[ .]"] -- Frame progression for box
let loop frames' = do
mapM_ (\frame -> do
setSGR [SetColor Foreground Vivid Green] -- Set the box color to green
putStr "\r" -- Move cursor to the start of the line
putStr frame -- Print the current frame
hFlush stdout -- Flush output buffer
threadDelay 200000) frames' -- Wait 0.2 seconds between frames
loop frames' -- Recursively call to keep the loop running
loop frames -- Start the looping animation
-- A simple trim function to remove leading/trailing whitespace
trim :: String -> String
trim = f . f
where f = reverse . dropWhile isSpace
-- Process lines to produce a list of (directory, [file paths]) tuples.
-- It ignores lines until the first "Directory:" is found (and discards it),
-- then uses subsequent "Directory:" lines to start new groups.
processLines :: [String] -> [(String, [String])]
processLines = reverse . go False []
where
-- The Bool flag indicates whether we've encountered the first "Directory:" line.
go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])]
go _ acc [] = acc
-- Before the first "Directory:" has been seen:
go False acc (line:rest)
| "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence.
| otherwise = go False acc rest
-- After the first "Directory:" has been skipped, but before starting any group:
go True [] (line:rest)
| "Directory:" `isPrefixOf` line =
let dir = trim (drop 11 line)
in go True [(dir, [])] rest
| otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence.
-- When a group has been started:
go True ((currentDir, files):xs) (line:rest)
| "Directory:" `isPrefixOf` line =
let dir = trim (drop 11 line)
in go True ((dir, []):(currentDir, files):xs) rest
| otherwise =
go True ((currentDir, files ++ [trim line]) : xs) rest
{-
this should be used that way:
result <- getData "output.txt"
let finalresult = processLines result -- that way we maintain purity
-}
getData :: FilePath -> IO [String]
getData f = do
content <- readFile f
return (lines content)
main :: IO ()
main = do
-- Function that builds the cache
{- allFiles <- scanDirectoryRecursivelyStr "/mnt/Data/Japanese_Resources/"
-- Filter files with '.mdx' extension
let mdxFiles = filterMdx allFiles ".mdx"
-- Group the files by their directories concurrently
groupedFiles <- groupFilesByDirectory mdxFiles allFiles
putStrLn "Starting to write results..."
-- Open the output file and set its encoding to UTF-8
withFile "output.txt" WriteMode $ \handle -> do
hSetEncoding handle utf8
-- Write the grouped files to the file
mapM_ (hPutStrLn handle . fileGroupToString) groupedFiles
putStrLn "Finished."
-}
-- Get raw data through IO
rawData <- getData "output.txt"
-- Pure transformations
let processed = processLines rawData
let icons = extractIcons processed
-- Output results
mapM_ putStrLn icons
app <- Gtk.applicationNew (Just "com.example.DictionaryIcons") []
void $ Gtk.on app #activate $ do
window <- Gtk.applicationWindowNew app
Gtk.windowSetTitle window (Just "Dictionary Toolbar") -- Fixed line
Gtk.windowSetDefaultSize window 800 100
-- Rest of the code remains the same
mainBox <- Gtk.boxNew Gtk.OrientationVertical 0
toolbar <- createIconToolbar icons
Gtk.boxAppend mainBox toolbar
Gtk.windowSetChild window (Just mainBox)
Gtk.widgetShow window
_ <- applicationRun app Nothing
return ()

36
src/KanaConv.hs
View file

@ -1,36 +0,0 @@
-- Copyright © 2024 Hashirama Senju
{-# LANGUAGE OverloadedStrings #-}
module KanaConv (convertHalfToFull) where -- Export convertHalfToFull function
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
-- The Kana mapping for half-width to full-width katakana
halfToFullMapping :: Map.Map String String
halfToFullMapping = Map.fromList
[ ("ｱ", "ア"), ("ｲ", "イ"), ("ｳ", "ウ"), ("ｴ", "エ"), ("ｵ", "オ")
, ("ｶ", "カ"), ("ｷ", "キ"), ("ｸ", "ク"), ("ｹ", "ケ"), ("ｺ", "コ")
, ("ｻ", "サ"), ("ｼ", "シ"), ("ｽ", "ス"), ("ｾ", "セ"), ("ｿ", "ソ")
, ("ﾀ", "タ"), ("ﾁ", "チ"), ("ﾂ", "ツ"), ("ﾃ", "テ"), ("ﾄ", "ト")
, ("ﾅ", "ナ"), ("ﾆ", "ニ"), ("ﾇ", "ヌ"), ("ﾈ", "ネ"), ("ﾉ", "ノ")
, ("ﾊ", "ハ"), ("ﾋ", "ヒ"), ("ﾌ", "フ"), ("ﾍ", "ヘ"), ("ﾎ", "ホ")
, ("ﾏ", "マ"), ("ﾐ", "ミ"), ("ﾑ", "ム"), ("ﾒ", "メ"), ("ﾓ", "モ")
, ("ﾤ", "ヤ"), ("ﾦ", "ユ"), ("ﾧ", "ヨ"), ("ﾨ", "ラ"), ("ﾩ", "リ")
, ("ﾪ", "ル"), ("ﾬ", "レ"), ("ﾮ", "ロ"), ("ﾜ", "ワ"), ("ｦ", "ヲ")
, ("ﾝ", "ン"), ("ｧ", "ァ"), ("ｨ", "ィ"), ("ｩ", "ゥ"), ("ｪ", "ェ")
, ("ｫ", "ォ"), ("ｯ", "ッ"), ("ｬ", "ャ"), ("ｭ", "ュ"), ("ｮ", "ョ")
, ("｡", "。"), ("､", "、"), ("･", "・"), ("゛", "ﾞ"), ("゜", "ﾟ")
, ("｢", "「"), ("｣", "」"), ("ｰ", "ー")
]
-- Function to replace half-width characters with full-width characters
replaceChar :: Char -> String
replaceChar char
| Just full <- Map.lookup [char] halfToFullMapping = full
| otherwise = [char]
-- Function to convert the entire string
convertHalfToFull :: String -> String
convertHalfToFull = concatMap replaceChar

BIN
src/Wazahs.hi Normal file
View file

Binary file not shown.

19
src/Wazahs.hs Normal file
View file

@ -0,0 +1,19 @@
module Wazahs (
listFiles
) where
-- imports
import qualified Data.Conduit.Combinators as CC
import Data.Conduit
import System.Environment (getArgs)
import System.FilePath (takeExtension)
import Conduit
-- | Recursively list all files in the given directory with .mdx extension.
listFiles :: FilePath -> IO [FilePath]
listFiles dir = runConduitRes $
CC.sourceDirectoryDeep False dir
.| filterC (\fp -> takeExtension fp == ".mdx")
.| sinkList

19
src/Wazahs.hs~ Normal file
View file

@ -0,0 +1,19 @@
module Wazahs (
) where
-- imports
import qualified Data.Conduit.Combinators as CC
import Data.Conduit
import System.Environment (getArgs)
import System.FilePath (takeExtension)
import Conduit
-- | Recursively list all files in the given directory with .mdx extension.
listFiles :: FilePath -> IO [FilePath]
listFiles dir = runConduitRes $
CC.sourceDirectoryDeep False dir
.| filterC (\fp -> takeExtension fp == ".mdx")
.| sinkList

BIN
src/Wazahs.o Normal file
View file

Binary file not shown.

51
src/getDictionaries.hs
View file

@ -1,51 +0,0 @@
-- Copyright © 2025 Hashirama Senju
{-# LANGUAGE OverloadedStrings #-}
import Prelude hiding (FilePath)
import System.IO (hSetEncoding, stdout, utf8)
import System.FilePath ((</>), takeDirectory)
import qualified System.FilePath as FP
import Filesystem.Path.CurrentOS (FilePath, encodeString, decodeString)
import qualified Filesystem.Path.CurrentOS as FP
import qualified Filesystem as FS
import qualified Data.Text as T
import Pipes
import Pipes.Safe (runSafeT, MonadSafe)
import Data.DirStream
import Control.Monad.State.Strict
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.IO as TIO
import Data.Maybe (fromMaybe)
import Control.Monad (when, filterM)
import Data.List (sort)
type MdxIndex = HM.HashMap String (FilePath, [FilePath])
main :: IO ()
main = do
hSetEncoding stdout utf8
mdxMap <- execStateT (runSafeT $ runEffect pipeline) (HM.empty :: MdxIndex)
-- print everything
forM_ (HM.toList mdxMap) $ \(mdx, (folder, files)) -> do
TIO.putStrLn $ "MDX: " <> T.pack mdx
TIO.putStrLn $ "Folder: " <> T.pack (encodeString folder)
mapM_ (TIO.putStrLn . (" " <>) . T.pack . encodeString) (sort files)
TIO.putStrLn ""
pipeline :: forall m. (MonadSafe m, MonadState MdxIndex m, MonadFail m) => Effect m ()
pipeline =
for (every (descendentOf "/mnt/Data/Japanese_Resources/Dictionaries/")) $ \fp ->
when (FP.extension fp == Just "mdx") $ do
let folder = FP.directory fp
allFiles <- liftIO $ FS.listDirectory folder
modify' (HM.insert (encodeString fp) (folder, allFiles))

161
src/getIcons.hs
View file

@ -1,161 +0,0 @@
-- Copyright © 2024 Hashirama Senju
import System.Clock -- To measure time
import System.Console.ANSI -- For colored output
--
import Z.Data.CBytes (pack, unpack)
import Z.IO.FileSystem (scandirRecursively)
import System.FilePath (takeDirectory, dropExtension, takeExtension)
import Data.List (groupBy, isSuffixOf, isPrefixOf, nub, find)
import System.IO
import qualified Data.Map as Map
import Control.Concurrent.Async (mapConcurrently)
import Control.Concurrent
import Control.Monad
import Data.Char (isSpace)
import Data.Maybe (mapMaybe, maybeToList)
type FileList = [(String, [String])] -- (Directory, Files)
extractIcons :: FileList -> [String] -- List of icon paths
extractIcons = concatMap processGroup
where
processGroup (_, files) = maybeToList (findIcon files)
findIcon :: [String] -> Maybe String
findIcon files = do
mdxFile <- find isMdxFile files
let baseName = dropExtension mdxFile
find (isIconFile baseName) files
where
isMdxFile file = takeExtension file == ".mdx"
isIconFile base file =
dropExtension file == base &&
takeExtension file `elem` imageExtensions
imageExtensions :: [String]
imageExtensions = [".png", ".jpg", ".jpeg", ".gif", ".bmp", ".svg"]
-- Derived version with automatic string handling
scanDirectoryRecursivelyStr :: String -> IO [String]
scanDirectoryRecursivelyStr path = do
result <- scandirRecursively (pack path) (\p _ -> return True)
return (map unpack result) -- Ensures all results are decoded to Strings (UTF-8)
-- Function to filter files with a specific extension
filterMdx :: [String] -> String -> [String]
filterMdx files ext = filter (isSuffixOf ext) files
-- Custom implementation of takeDirectory for UTF-8 strings
takeDirectory' :: String -> String
takeDirectory' path = reverse . dropWhile (/= '/') . reverse $ path
data FileGroup = FileGroup
{ directory :: String -- The directory part of the file path (UTF-8 String)
, files :: [String] -- List of file paths in that directory (UTF-8 Strings)
} deriving (Show, Eq)
-- Create a map from directory to list of .mdx files
groupMdxByDirectory :: [String] -> Map.Map String [String]
groupMdxByDirectory mdxFiles =
Map.fromListWith (++) [(takeDirectory' file, [file]) | file <- mdxFiles]
-- Group files by their directory, including additional files that belong to the same directory
groupFilesByDirectory :: [String] -> [String] -> IO [FileGroup]
groupFilesByDirectory mdxFiles additionalFiles = do
-- Create a map of directories to .mdx files
let mdxMap = groupMdxByDirectory mdxFiles
-- Function to process each directory group in parallel
let processGroup dir mdxFilesInDir = do
let -- Filter additional files that belong to the same directory
additionalFilesInDir = filter (\f -> takeDirectory' f == dir) additionalFiles
-- Remove matching files from additional files (those that are already in the .mdx list)
remainingAdditionalFiles = filter (\f -> not (f `elem` mdxFilesInDir)) additionalFilesInDir
-- Combine and remove duplicates
allFiles = nub (mdxFilesInDir ++ remainingAdditionalFiles)
return $ FileGroup dir allFiles
-- Process each directory group concurrently
groupedFiles <- mapConcurrently (\(dir, mdxFilesInDir) -> processGroup dir mdxFilesInDir) (Map.toList mdxMap)
return groupedFiles
-- Function to convert FileGroup to a string representation for file output
fileGroupToString :: FileGroup -> String
fileGroupToString (FileGroup dir files) =
"Directory: " ++ dir ++ "\n" ++
unlines (map (" " ++) files)
-- Box-like animation function with green color
boxAnimation :: IO ()
boxAnimation = do
let frames = ["[ ]", "[. ]", "[ . ]", "[ .]"] -- Frame progression for box
let loop frames' = do
mapM_ (\frame -> do
setSGR [SetColor Foreground Vivid Green] -- Set the box color to green
putStr "\r" -- Move cursor to the start of the line
putStr frame -- Print the current frame
hFlush stdout -- Flush output buffer
threadDelay 200000) frames' -- Wait 0.2 seconds between frames
loop frames' -- Recursively call to keep the loop running
loop frames -- Start the looping animation
-- A simple trim function to remove leading/trailing whitespace
trim :: String -> String
trim = f . f
where f = reverse . dropWhile isSpace
-- Process lines to produce a list of (directory, [file paths]) tuples.
-- It ignores lines until the first "Directory:" is found (and discards it),
-- then uses subsequent "Directory:" lines to start new groups.
processLines :: [String] -> [(String, [String])]
processLines = reverse . go False []
where
-- The Bool flag indicates whether we've encountered the first "Directory:" line.
go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])]
go _ acc [] = acc
-- Before the first "Directory:" has been seen:
go False acc (line:rest)
| "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence.
| otherwise = go False acc rest
-- After the first "Directory:" has been skipped, but before starting any group:
go True [] (line:rest)
| "Directory:" `isPrefixOf` line =
let dir = trim (drop 11 line)
in go True [(dir, [])] rest
| otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence.
-- When a group has been started:
go True ((currentDir, files):xs) (line:rest)
| "Directory:" `isPrefixOf` line =
let dir = trim (drop 11 line)
in go True ((dir, []):(currentDir, files):xs) rest
| otherwise =
go True ((currentDir, files ++ [trim line]) : xs) rest
getData :: FilePath -> IO [String]
getData f = do
content <- readFile f
return (lines content)
main :: IO ()
main = do
-- Get raw data through IO
rawData <- getData "output.txt"
-- Pure transformations
let processed = processLines rawData
let icons = extractIcons processed
-- Output results
mapM_ putStrLn icons

208
src/make_package.hs
View file

@ -1,208 +0,0 @@
-- currently not working, needs refactoring.
import Control.Exception (bracket_)
import qualified Control.Lens as Lens
import Control.Lens.Operators
import Control.Monad (when, unless, filterM)
import Data.Foldable (traverse_)
import qualified System.Directory as Dir
import qualified System.Environment as Env
import System.FilePath ((</>), takeFileName, takeDirectory)
import qualified System.Info as SysInfo
import System.Process (readProcess, callProcess)
import Prelude
interestingLibs :: [String]
interestingLibs =
[ "libGLEW"
, "libGLU"
, "libXcursor"
, "libXi"
, "libXinerama"
, "libXrandr"
, "libXrender"
, "libbsd"
, "libbz2"
, "libcares"
, "libcrypto"
, "libdw"
, "libelf"
, "libgflags"
, "libgmp"
, "libicudata"
, "libicui18n"
, "libicuuc"
, "liblzma"
, "libnghttp2"
, "libnode"
, "librocksdb"
, "libsnappy"
, "libssl"
, "libuv"
]
isInteresting :: FilePath -> Bool
isInteresting path =
baseName `elem` interestingLibs
where
-- takeBaseName removes one extension, we remove all:
baseName = takeFileName path & takeWhile (/= '.')
parseLddOut :: String -> [FilePath]
parseLddOut lddOut =
lines lddOut
>>= parseLine
& filter isInteresting
where
parseLine line =
case words line & dropWhile (/= "=>") of
[] -> []
"=>":libPath:_ -> [libPath]
_ -> error "unexpected break output"
otoolMinMacosVersion :: FilePath -> IO Float
otoolMinMacosVersion path =
readProcess "otool" ["-l", path] "" <&>
(^?! Lens.to lines . traverse .
Lens.to words .
Lens.filteredBy (Lens.ix 0 . (Lens.only "minos" <> Lens.only "version")) .
Lens.ix 1 . Lens._Show)
-- Use `otool` to recursively find macOS deps
findDylibs :: FilePath -> IO [FilePath]
findDylibs path =
do
deps <-
readProcess "otool" ["-L", path] ""
<&> lines <&> tail <&> map words <&> (>>= take 1)
<&> filter (/= path)
>>= filterM Dir.doesPathExist
traverse findDylibs deps <&> concat <&> (deps <>)
-- Slightly nicer syntax than using a sum type with case everywhere
isMacOS :: Bool
isMacOS = SysInfo.os == "darwin"
isWindows :: Bool
isWindows = SysInfo.os == "mingw32"
isLinux :: Bool
isLinux = SysInfo.os == "linux"
pkgDir :: FilePath
pkgDir
| isMacOS = "Lamdu.app"
| otherwise = "lamdu"
toPackageWith :: FilePath -> FilePath -> IO ()
toPackageWith srcPath relPath =
do
putStrLn $ "Packaging " ++ srcPath ++ " to " ++ destPath
Dir.createDirectoryIfMissing True (takeDirectory destPath)
callProcess "cp" ["-aLR", srcPath, destPath]
where
destPath = contentsDir </> relPath
contentsDir
| isMacOS = pkgDir </> "Contents"
| otherwise = pkgDir
toPackage :: FilePath -> IO ()
toPackage srcPath = toPackageWith srcPath (takeFileName srcPath)
libToPackage :: FilePath -> IO ()
libToPackage srcPath =
toPackageWith srcPath (dir </> filename)
where
filename = takeFileName srcPath
dir
| isWindows = "."
| isMacOS = "MacOS"
| otherwise = "lib"
findDeps :: String -> IO [FilePath]
findDeps exec
| isWindows =
[ "libwinpthread-1.dll"
, "libstdc++-6.dll"
, "libgcc_s_seh-1.dll"
, "librocksdb.dll"
, "libbz2-1.dll"
, "liblz4.dll"
, "zlib1.dll"
, "libzstd.dll"
] <&> ("/mingw64/bin" </>)
& pure
| isMacOS =
findDylibs exec
| otherwise =
readProcess "ldd" [exec] "" <&> parseLddOut
fixDylibPaths :: FilePath -> IO ()
fixDylibPaths targetName =
findDylibs target >>=
traverse_ fixDep
where
target = pkgDir </> "Contents" </> "MacOS" </> targetName
fixDep dep =
do
callProcess "chmod" ["+w", target]
callProcess "install_name_tool"
["-change", dep, "@executable_path/" ++ takeFileName dep, target]
parseLamduVersion :: String -> String
parseLamduVersion info =
case lines info <&> words of
(["Lamdu", result]:_) -> result
_ -> error "failed parsing version number"
whichCmd :: String
whichCmd
| isWindows = "where"
| otherwise = "which"
main :: IO ()
main =
do
[lamduExec] <- Env.getArgs
nodePath <- readProcess whichCmd ["node"] "" <&> takeWhile (`notElem` "\r\n")
nodeDeps <- findDeps nodePath
when isMacOS $
do
unless (null nodeDeps) $ fail "nodejs not statically linked!"
minos <- otoolMinMacosVersion lamduExec
when (minos > 10.9) (fail "Lamdu executable only runs on new macOS versions")
version <- readProcess lamduExec ["--version"] "" <&> parseLamduVersion
lamduDeps <- findDeps lamduExec
let allDeps = nodeDeps <> lamduDeps
bracket_ (Dir.createDirectory pkgDir) (unless isMacOS (Dir.removeDirectoryRecursive pkgDir)) $
do
toPackageWith lamduExec destPath
toPackageWith "data" dataDir
toPackageWith nodePath (dataDir </> "bin/node.exe")
traverse_ libToPackage allDeps
when isWindows $
callProcess "iscc.exe" ["/Flamdu-" ++ version ++ "-win-setup", "tools\\data\\lamdu.iss"]
when isLinux $
do
toPackage "tools/data/run-lamdu.sh"
callProcess "tar" ["-c", "-z", "-f", "lamdu-" ++ version ++ "-linux.tgz", pkgDir]
when isMacOS $
do
toPackage "tools/data/Info.plist"
traverse_ fixDylibPaths ("lamdu" : (allDeps <&> takeFileName))
callProcess "sh"
[ "tools/data/macos_icon.sh"
, "data/Lamdu.png"
, pkgDir </> "Contents" </> "Resources" </> "lamdu.icns"
]
-- The next steps of signing, notarization, and stapling happen in a seperate script
putStrLn "Done"
where
destPath
| isWindows = "lamdu.exe"
| isMacOS = "MacOS/lamdu"
| otherwise = "bin/lamdu"
dataDir
| isMacOS = "Resources"
| otherwise = "data"