Compare commits
| Author | SHA1 | Date | |
|---|---|---|---|
| a2b11fc82b | |||
| 72fdc2fffe | |||
| 309edca4f4 | |||
| cd8a22182d |
18 changed files with 102 additions and 1682 deletions
|
|
@ -1,122 +0,0 @@
|
|||
{-# OPTIONS_GHC -fplugin=LiquidHaskell #-}
|
||||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
|
||||
module LiquidExamples where
|
||||
import qualified Data.Vector as V
|
||||
import Foreign
|
||||
import Foreign.C.Types
|
||||
|
||||
|
||||
-- defining new types
|
||||
{-@ type Zero = {v:Int | v == 0} @-}
|
||||
{-@ type NonZero = {v:Int | v /= 0} @-}
|
||||
|
||||
|
||||
-- this is impossible to occur.
|
||||
-- meaning that programs with errors wont compile.
|
||||
{-@ die :: {v:String | false} -> a @-}
|
||||
die msg = error msg
|
||||
|
||||
|
||||
{-@ type TRUE = {v:Bool | v} @-}
|
||||
{-@ type FALSE = {v:Bool | not v} @-}
|
||||
|
||||
|
||||
{-@ ax0 :: TRUE @-}
|
||||
ax0 = 1 + 1 == 2
|
||||
|
||||
{-@ measure size @-}
|
||||
{-@ size :: [a] -> Nat @-}
|
||||
size :: [a] -> Int
|
||||
size [] = 0
|
||||
size (x:xs) = 1 + size xs
|
||||
|
||||
cannotDie = if 1 + 1 == 3
|
||||
then die "horrible death"
|
||||
else ()
|
||||
|
||||
-- canDie = if 1 + 1 == 2
|
||||
-- then die "horrible death"
|
||||
-- else ()
|
||||
|
||||
|
||||
|
||||
-- we can also use a pre-condition to say that it must be a nonzero
|
||||
{-@ divide :: Int -> NonZero -> Int @-}
|
||||
divide :: Int -> Int -> Int
|
||||
divide n d = n `div` d
|
||||
|
||||
|
||||
-- if you put zero at the end , it wont compile
|
||||
avg2 x y = divide (x + y) 2
|
||||
avg3 x y z = divide (x + y + z) 3
|
||||
|
||||
|
||||
-- here we could use "die" , because it's impossible to reach it.
|
||||
{-@ avg :: {xs:[Int] | len xs > 0} -> Int @-}
|
||||
avg :: [Int] -> Int
|
||||
avg [] = die "cannot average empty list"
|
||||
avg xs = divide total n
|
||||
where
|
||||
total = sum xs
|
||||
n = length xs
|
||||
|
||||
|
||||
{-@ abs :: Int -> Nat @-}
|
||||
abs :: Int -> Int
|
||||
abs n
|
||||
| 0 < n = n
|
||||
| otherwise = 0 - n -- indeed, this is non-negative
|
||||
|
||||
|
||||
{-@ type NEVector a = {v:Vector a | 0 < vlen v} @-}
|
||||
|
||||
|
||||
head'' :: V.Vector a -> Maybe a
|
||||
head'' v
|
||||
| V.length v > 0 = Just (v V.! 0)
|
||||
| otherwise = Nothing
|
||||
|
||||
-- unsafe here means no bounds check
|
||||
-- my fix was making the refinement type same as the concrete one
|
||||
{-@ unsafeLookup :: Nat -> V.Vector a -> a @-}
|
||||
unsafeLookup :: Int -> V.Vector a -> a
|
||||
unsafeLookup index vec = vec V.! index
|
||||
|
||||
|
||||
-- needs to be a measure, cannot be written in refinement
|
||||
{-@ measure vlen :: V.Vector a -> Int @-} -- type annotation
|
||||
vlen :: V.Vector a -> Int -- Haskell definition
|
||||
vlen v = V.length v
|
||||
|
||||
-- this assumes that vlen is always greater than zero, but what if the vector is empty?
|
||||
{-@ safeLookup :: {v:V.Vector a | 0 < vlen v} -> {i:Int | 0 <= i && i < vlen v} -> Maybe a @-}
|
||||
safeLookup x i
|
||||
| ok = Just (x V.! i) -- this doesnt mean equality
|
||||
| otherwise = Nothing
|
||||
where
|
||||
ok = V.length x > 0
|
||||
|
||||
----
|
||||
---- Pointers
|
||||
|
||||
|
||||
-- | A pointer tagged with its size
|
||||
{-@ data PtrSized a = PtrSized { ptrData :: Ptr a , ptrSz :: {n:Int | n >= 0}} @-}
|
||||
data PtrSized a = PtrSized
|
||||
{ ptrData :: Ptr a
|
||||
, ptrSz :: Int
|
||||
}
|
||||
|
||||
|
||||
{-@ type SafeIndex v = {i:Int | 0 <= i && i < ptrSz v} @-}
|
||||
|
||||
{-@ peekElemN :: Storable a
|
||||
=> v:PtrSized a
|
||||
-> SafeIndex v
|
||||
-> IO a
|
||||
@-}
|
||||
peekElemN :: Storable a => PtrSized a -> Int -> IO a
|
||||
peekElemN (PtrSized p _) i = peekElemOff p i
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
-- Copyright © 2025 Hashirama Senju
|
||||
|
||||
{-
|
||||
this program will skip directories with more than 10 xml files in it.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import System.IO (stdout, hSetEncoding, utf8)
|
||||
import Control.Monad (when, unless, filterM, mzero)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.DirStream (childOf)
|
||||
import Pipes (ListT, for, every, runEffect)
|
||||
import Pipes.Safe (SafeT, runSafeT)
|
||||
import Control.Applicative
|
||||
import qualified Filesystem as FS -- system-filepath
|
||||
import qualified Filesystem.Path.CurrentOS as FP
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
|
||||
-- | Count up to 11 immediate .xml files in `dir`.
|
||||
countImmediateXMLs :: FP.FilePath -> IO Int
|
||||
countImmediateXMLs dir = do
|
||||
children <- FS.listDirectory dir
|
||||
files <- filterM FS.isFile children
|
||||
let xmls = Prelude.filter (\f -> FP.extension f == Just "xml") files
|
||||
return (min 11 (Prelude.length xmls))
|
||||
|
||||
-- | Stream the tree under `dir`, pruning any directory with
|
||||
-- >10 immediate .xml files, yielding both files and dirs.
|
||||
walk :: FP.FilePath -> ListT (SafeT IO) FP.FilePath
|
||||
walk dir = do
|
||||
child <- childOf dir -- streams FP.FilePath directly
|
||||
isDir <- liftIO $ FS.isDirectory child
|
||||
|
||||
if isDir
|
||||
then do
|
||||
cnt <- liftIO $ countImmediateXMLs child
|
||||
if cnt > 10
|
||||
then mzero -- skip this entire subtree
|
||||
else return child <|> walk child
|
||||
else
|
||||
return child -- yield a file
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
hSetEncoding stdout utf8
|
||||
let root = FP.fromText "/mnt/Data/Japanese_Resources/"
|
||||
|
||||
-- Convert our ListT (SafeT IO) FP.FilePath into actual IO
|
||||
runSafeT . runEffect $
|
||||
for (every (walk root)) $ \fp ->
|
||||
liftIO $
|
||||
when (FP.extension fp == Just "mdx") $
|
||||
TIO.putStrLn (T.pack $ FP.encodeString fp)
|
||||
57
appleKit.hs
57
appleKit.hs
|
|
@ -1,57 +0,0 @@
|
|||
{-
|
||||
|
||||
install my lib: https://github.com/KonstantinDjairo/haskell-obj-c
|
||||
|
||||
then:
|
||||
|
||||
$ ghc -package-env - appleKit.hs -o hello \
|
||||
-package haskell-obj-c \
|
||||
-package libffi \
|
||||
-framework AppKit
|
||||
|
||||
|
||||
-}
|
||||
|
||||
|
||||
import Foreign.C.String (withCString)
|
||||
import Foreign.LibFFI (argPtr, retPtr, retVoid, retCULong)
|
||||
import Foreign.Ptr (castPtr)
|
||||
import ObjC.Runtime
|
||||
|
||||
main :: IO ()
|
||||
main = withAutoreleasePool $ do
|
||||
loadFramework "AppKit"
|
||||
|
||||
appClass <- getRequiredClass "NSApplication"
|
||||
_ <- sendClassMsg appClass (mkSelector "sharedApplication")
|
||||
(retPtr retVoid) []
|
||||
|
||||
alertClass <- getRequiredClass "NSAlert"
|
||||
alertPtr <- sendClassMsg alertClass (mkSelector "new")
|
||||
(retPtr retVoid) []
|
||||
let alert = RawId (castPtr alertPtr)
|
||||
|
||||
stringClass <- getRequiredClass "NSString"
|
||||
title <- makeString stringClass "Hello from Haskell"
|
||||
detail <- makeString stringClass "RawId-only AppKit test."
|
||||
|
||||
let RawId titlePtr = title
|
||||
RawId detailPtr = detail
|
||||
|
||||
_ <- sendRawMsg alert (mkSelector "setMessageText:")
|
||||
retVoid [argPtr titlePtr]
|
||||
|
||||
_ <- sendRawMsg alert (mkSelector "setInformativeText:")
|
||||
retVoid [argPtr detailPtr]
|
||||
|
||||
_ <- sendRawMsg alert (mkSelector "runModal")
|
||||
retCULong []
|
||||
|
||||
pure ()
|
||||
|
||||
makeString :: Class -> String -> IO RawId
|
||||
makeString cls s =
|
||||
withCString s $ \cs -> do
|
||||
ptr <- sendClassMsg cls (mkSelector "stringWithUTF8String:")
|
||||
(retPtr retVoid) [argPtr cs]
|
||||
pure (RawId (castPtr ptr))
|
||||
154
appleKitHello.hs
154
appleKitHello.hs
|
|
@ -1,154 +0,0 @@
|
|||
-- originally made by Ian Duncan
|
||||
|
||||
|
||||
{-
|
||||
|
||||
install my lib: https://github.com/KonstantinDjairo/haskell-obj-c
|
||||
|
||||
make sure all the dependencies can be seen (as in being visible).
|
||||
in some cases there are bugs in visibility, an example of how to solve is:
|
||||
|
||||
ENV="$HOME/.ghc/x86_64-darwin-9.14.1/environments/default"
|
||||
LOCAL=".ghc.environment.x86_64-darwin-9.14.1"
|
||||
|
||||
cp "$ENV" "$LOCAL"
|
||||
|
||||
cat >> "$LOCAL" <<'EOF'
|
||||
package-id haskell-obj-c-0.1.0.0-Bz2BQgarUWfIjLViTQm4VB
|
||||
package-id libffi-0.2.1-8ww0PruNfptGqXPccO6KJj
|
||||
EOF
|
||||
|
||||
|
||||
then conpile:
|
||||
|
||||
$ ghc -fforce-recomp appleKitHello.hs -o hello -framework AppKit
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Foreign.Ptr (nullPtr)
|
||||
|
||||
import ObjC.Runtime
|
||||
|
||||
-- Generated bindings — types and enums from per-class modules
|
||||
import ObjC.AppKit.NSApplication
|
||||
( NSApplication
|
||||
, pattern NSApplicationActivationPolicyRegular
|
||||
)
|
||||
import ObjC.AppKit.NSWindow
|
||||
( NSWindow
|
||||
, pattern NSWindowStyleMaskTitled
|
||||
, pattern NSWindowStyleMaskClosable
|
||||
, pattern NSWindowStyleMaskMiniaturizable
|
||||
, pattern NSWindowStyleMaskResizable
|
||||
, pattern NSBackingStoreBuffered
|
||||
)
|
||||
import ObjC.AppKit.NSTextField (NSTextField)
|
||||
import ObjC.AppKit.NSMenu (NSMenu)
|
||||
import ObjC.AppKit.NSMenuItem (NSMenuItem)
|
||||
import ObjC.AppKit.NSView (IsNSView(toNSView))
|
||||
import ObjC.Foundation.NSString (NSString) -- IsString (Id NSString) instance
|
||||
import ObjC.Foundation.Structs (NSRect(..), NSPoint(..), NSSize(..))
|
||||
|
||||
-- Generated bindings — methods (qualified)
|
||||
import qualified ObjC.AppKit.NSApplication as App
|
||||
import qualified ObjC.AppKit.NSWindow as Win
|
||||
import qualified ObjC.AppKit.NSTextField as TF
|
||||
import qualified ObjC.AppKit.NSView as View
|
||||
import qualified ObjC.AppKit.NSMenu as Menu
|
||||
import qualified ObjC.AppKit.NSMenuItem as MI
|
||||
import qualified ObjC.AppKit.NSControl as Ctrl
|
||||
import qualified ObjC.AppKit.NSFont as Font
|
||||
import ObjC.AppKit.Delegate.NSApplicationDelegate
|
||||
( NSApplicationDelegateOverrides(..)
|
||||
, defaultNSApplicationDelegateOverrides
|
||||
, newNSApplicationDelegate
|
||||
)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = withAutoreleasePool $ do
|
||||
loadFramework "AppKit"
|
||||
|
||||
-- [NSApplication sharedApplication]
|
||||
app <- App.sharedApplication
|
||||
|
||||
_ <- App.setActivationPolicy app NSApplicationActivationPolicyRegular
|
||||
|
||||
setupMenuBar app
|
||||
|
||||
-- Create the window
|
||||
let styleMask = NSWindowStyleMaskTitled <> NSWindowStyleMaskClosable
|
||||
<> NSWindowStyleMaskMiniaturizable <> NSWindowStyleMaskResizable
|
||||
backing = NSBackingStoreBuffered
|
||||
rect = NSRect (NSPoint 200 200) (NSSize 480 260)
|
||||
|
||||
window <- (alloc @NSWindow >>=
|
||||
\w -> Win.initWithContentRect_styleMask_backing_defer w rect styleMask backing False)
|
||||
Win.center window
|
||||
Win.setReleasedWhenClosed window False
|
||||
|
||||
Win.setTitle window ("Hello Haskell" :: Id NSString)
|
||||
|
||||
-- Create a label
|
||||
label <- TF.labelWithString ("Hello, World from Haskell!" :: Id NSString) :: IO (Id NSTextField)
|
||||
|
||||
-- Position the label within the window
|
||||
let labelRect = NSRect (NSPoint 40 80) (NSSize 400 100)
|
||||
View.setFrame label labelRect
|
||||
|
||||
-- Set the font to system 32pt
|
||||
font <- Font.systemFontOfSize 32
|
||||
Ctrl.setFont label font
|
||||
|
||||
Ctrl.setAlignment label Ctrl.NSTextAlignmentCenter
|
||||
|
||||
-- Add the label to the window's content view
|
||||
cv <- Win.contentView window
|
||||
View.addSubview cv (toNSView label)
|
||||
|
||||
appDelegate <- newNSApplicationDelegate defaultNSApplicationDelegateOverrides
|
||||
{ _applicationShouldTerminateAfterLastWindowClosed = Just (const (pure False))
|
||||
, _applicationShouldHandleReopen_hasVisibleWindows = Just $ \_ hasVisible ->
|
||||
if hasVisible then pure True
|
||||
else Win.makeKeyAndOrderFront window (RawId nullPtr) >> pure True
|
||||
}
|
||||
App.setDelegate app appDelegate
|
||||
|
||||
Win.makeKeyAndOrderFront window (RawId nullPtr)
|
||||
App.activateIgnoringOtherApps app True
|
||||
|
||||
-- Enter the AppKit run loop (blocks until app quits)
|
||||
App.run app
|
||||
|
||||
|
||||
-- | Set up a minimal menu bar with an application menu containing Quit (Cmd+Q).
|
||||
setupMenuBar :: Id NSApplication -> IO ()
|
||||
setupMenuBar app = do
|
||||
-- Menu bar
|
||||
menuBar <- alloc @NSMenu >>= \m -> Menu.initWithTitle m ("" :: Id NSString)
|
||||
|
||||
-- App menu item (container in the menu bar) — plain -init.
|
||||
appMenuItem <- new @NSMenuItem
|
||||
|
||||
Menu.addItem menuBar appMenuItem
|
||||
|
||||
-- App submenu
|
||||
appMenu <- alloc @NSMenu >>= \m -> Menu.initWithTitle m ("App" :: Id NSString)
|
||||
|
||||
-- "Quit" item with Cmd+Q
|
||||
quitItem <- alloc @NSMenuItem >>=
|
||||
\mi -> MI.initWithTitle_action_keyEquivalent mi ("Quit" :: Id NSString) (asSel App.terminateSelector) ("q" :: Id NSString)
|
||||
|
||||
Menu.addItem appMenu quitItem
|
||||
|
||||
-- Wire submenu and set the menu bar
|
||||
Menu.setSubmenu_forItem menuBar appMenu appMenuItem
|
||||
App.setMainMenu app menuBar
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
import Data.GI.Base (castTo)
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gdk as Gdk
|
||||
import qualified GI.GdkX11 as GdkX11
|
||||
import GI.GLib (mainContextInvokeFull)
|
||||
import GI.Gio
|
||||
import Control.Monad (void)
|
||||
import Foreign.Marshal.Array (withArray)
|
||||
import Foreign.Ptr (castPtr)
|
||||
import Foreign.C.Types (CULong)
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras (xChangeProperty, propModeReplace)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Gtk.Application [#applicationId := "org.example.test"]
|
||||
|
||||
on app #activate $ do
|
||||
win <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Dialog Window"
|
||||
, #defaultWidth := 400
|
||||
, #defaultHeight := 100
|
||||
, #resizable := False
|
||||
, #decorated := False
|
||||
]
|
||||
|
||||
|
||||
Gtk.windowSetDefaultSize win 400 100
|
||||
|
||||
|
||||
-- run in main context; returns IO Bool
|
||||
void $ mainContextInvokeFull Nothing (-99) $ do
|
||||
_ <- on win #realize $ do
|
||||
mSurface <- #getSurface win
|
||||
case mSurface of
|
||||
Just surface -> do
|
||||
mX11Surface <- castTo GdkX11.X11Surface surface
|
||||
display <- Gdk.surfaceGetDisplay surface
|
||||
mX11Display <- castTo GdkX11.X11Display display
|
||||
|
||||
case (mX11Display, mX11Surface) of
|
||||
(Just _gdkX11Disp, Just x11Surf) -> do
|
||||
xidCULong <- GdkX11.x11SurfaceGetXid x11Surf
|
||||
|
||||
dpy <- openDisplay ""
|
||||
|
||||
atomType <- internAtom dpy "_NET_WM_WINDOW_TYPE" False
|
||||
atomDialog <- internAtom dpy "_NET_WM_WINDOW_TYPE_DIALOG" False
|
||||
atomAtom <- internAtom dpy "ATOM" False
|
||||
|
||||
withArray [atomDialog] $ \ptr -> do
|
||||
let winX = fromIntegral (xidCULong :: CULong) :: Window
|
||||
void $ xChangeProperty dpy winX atomType atomAtom 32 propModeReplace (castPtr ptr) 1
|
||||
flush dpy
|
||||
|
||||
closeDisplay dpy
|
||||
_ -> putStrLn "Not running under X11."
|
||||
Nothing -> putStrLn "No surface available"
|
||||
|
||||
pure () -- <--- important: SourceFunc expects IO Bool
|
||||
|
||||
return False -- just indicate mainContextInvokeFull call succeeded
|
||||
|
||||
#realize win
|
||||
Gtk.widgetShow win
|
||||
|
||||
void $ applicationRun app Nothing
|
||||
|
|
@ -1,106 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
import Data.GI.Base (castTo)
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gdk as Gdk
|
||||
import qualified GI.GdkX11 as GdkX11
|
||||
import GI.GLib (mainContextInvokeFull)
|
||||
import Data.GI.Base.Signals
|
||||
import GI.Gio
|
||||
import Control.Monad (void)
|
||||
import Foreign.Marshal.Array (withArray)
|
||||
import Foreign.Ptr (castPtr)
|
||||
import Foreign.C.Types (CULong)
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras (xChangeProperty, propModeReplace)
|
||||
|
||||
-- Polymorphic: accepts any GTK window type
|
||||
setWindowAsDialog :: Gtk.IsWindow w => w -> IO ()
|
||||
setWindowAsDialog win = do
|
||||
-- upcast to concrete Gtk.Window right away (resolves ambiguity)
|
||||
wnd <- Gtk.toWindow win
|
||||
|
||||
-- now get surface with a concrete Window type in scope
|
||||
mSurface <- #getSurface wnd
|
||||
case mSurface of
|
||||
Just (surface :: Gdk.Surface) -> do
|
||||
-- cast to GDK X11 surface & display (explicit IO results)
|
||||
mX11Surface <- (castTo GdkX11.X11Surface surface) :: IO (Maybe GdkX11.X11Surface)
|
||||
display <- Gdk.surfaceGetDisplay surface
|
||||
mX11Display <- (castTo GdkX11.X11Display display) :: IO (Maybe GdkX11.X11Display)
|
||||
|
||||
case (mX11Display, mX11Surface) of
|
||||
(Just _gdkX11Disp, Just x11Surf) -> do
|
||||
-- get window XID and set ATOM via X11
|
||||
xidCULong <- GdkX11.x11SurfaceGetXid x11Surf
|
||||
|
||||
dpy <- openDisplay ""
|
||||
atomType <- internAtom dpy "_NET_WM_WINDOW_TYPE" False
|
||||
atomDialog <- internAtom dpy "_NET_WM_WINDOW_TYPE_DIALOG" False
|
||||
atomAtom <- internAtom dpy "ATOM" False
|
||||
|
||||
withArray [atomDialog] $ \ptr -> do
|
||||
let winX :: Window
|
||||
winX = fromIntegral (xidCULong :: CULong)
|
||||
void $ xChangeProperty dpy winX atomType atomAtom 32 propModeReplace (castPtr ptr) 1
|
||||
flush dpy
|
||||
|
||||
closeDisplay dpy
|
||||
_ -> putStrLn "Not running under X11."
|
||||
Nothing -> putStrLn "No surface available"
|
||||
|
||||
-- Polymorphic attach helper
|
||||
attachDialogOnRealize :: Gtk.IsWindow w => w -> IO SignalHandlerId
|
||||
attachDialogOnRealize win = do
|
||||
wnd <- Gtk.toWindow win
|
||||
on wnd #realize (setWindowAsDialog win)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Gtk.Application [#applicationId := "org.example.test"]
|
||||
|
||||
on app #activate $ do
|
||||
-- Main window
|
||||
win <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Dialog Window"
|
||||
, #defaultWidth := 400
|
||||
, #defaultHeight := 100
|
||||
, #resizable := False
|
||||
, #decorated := False
|
||||
]
|
||||
Gtk.windowSetDefaultSize win 400 100
|
||||
void $ mainContextInvokeFull Nothing (-99) $ do
|
||||
_ <- attachDialogOnRealize win
|
||||
return False
|
||||
#realize win
|
||||
Gtk.widgetShow win
|
||||
|
||||
-- Spawn a dialog window
|
||||
dlg <- new Gtk.Dialog
|
||||
[ #transientFor := win -- dialog is attached to main window
|
||||
, #title := "This is a Dialog"
|
||||
, #modal := True
|
||||
, #resizable := False
|
||||
, #decorated := False
|
||||
]
|
||||
Gtk.windowSetDefaultSize dlg 300 80
|
||||
|
||||
-- Add a label with text inside the dialog
|
||||
contentArea <- Gtk.dialogGetContentArea dlg
|
||||
lbl <- new Gtk.Label [#label := "Hello, I am a dialog!"]
|
||||
Gtk.boxAppend contentArea lbl
|
||||
|
||||
-- Attach dialog X11 role
|
||||
void $ mainContextInvokeFull Nothing (-99) $ do
|
||||
_ <- attachDialogOnRealize dlg
|
||||
return False
|
||||
|
||||
#realize dlg
|
||||
Gtk.widgetShow dlg
|
||||
|
||||
void $ applicationRun app Nothing
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
-- Copyright © 2025 Hashirama Senju
|
||||
|
||||
{-
|
||||
find dictionaries by using only conduits.
|
||||
-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Main where
|
||||
|
||||
import qualified Data.Conduit.Combinators as CC
|
||||
import Data.Conduit
|
||||
import Data.Text (pack,unpack)
|
||||
import System.Environment (getArgs)
|
||||
import System.IO (stdout)
|
||||
import System.FilePath (takeExtension)
|
||||
import Conduit
|
||||
|
||||
-- | Recursively list all files in the given directory, streaming each file path as UTF-8 bytes to stdout.
|
||||
listFiles :: FilePath -> IO ()
|
||||
listFiles dir = runConduitRes $
|
||||
-- 1) Walk the directory (produces `FilePath`)
|
||||
CC.sourceDirectoryDeep False dir
|
||||
.| -- 2) Filter *before* converting to Text
|
||||
filterC (\fp -> takeExtension fp == ".mdx")
|
||||
.| -- 3) Convert to Text, append newline, then encode
|
||||
CC.map (\fp -> pack fp <> "\n")
|
||||
.| CC.encodeUtf8
|
||||
.| CC.sinkHandle stdout
|
||||
|
||||
|
||||
-- | Entry point: use first CLI argument as directory, defaulting to current directory.
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
let targetDir = case args of
|
||||
(d:_) -> d
|
||||
[] -> "."
|
||||
listFiles targetDir
|
||||
93
dynamicUI.hs
Normal file
93
dynamicUI.hs
Normal file
|
|
@ -0,0 +1,93 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
|
||||
-- Copyright © 2025 Hashirama Senju
|
||||
|
||||
{-
|
||||
we dynamically update the UI when new data comes to the entry
|
||||
-}
|
||||
|
||||
module Main where
|
||||
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gio as Gio
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad (void)
|
||||
|
||||
createWordLabel :: T.Text -> IO Gtk.Widget
|
||||
createWordLabel word = do
|
||||
label <- Gtk.labelNew (Just word)
|
||||
|
||||
-- Gesture for hover detection
|
||||
motionController <- Gtk.eventControllerMotionNew
|
||||
Gtk.widgetAddController label motionController
|
||||
|
||||
-- Print only when hovering an actual word
|
||||
void $ Gtk.on motionController #enter $ \_ _ -> putStrLn (T.unpack word)
|
||||
|
||||
Gtk.toWidget label
|
||||
|
||||
updateUI :: Gtk.Box -> [String] -> IO ()
|
||||
updateUI outerBox sentence = do
|
||||
-- Remove all existing children from outerBox
|
||||
let removeChildren widget = do
|
||||
mChild <- Gtk.widgetGetFirstChild widget
|
||||
case mChild of
|
||||
Just child -> do
|
||||
Gtk.boxRemove outerBox child
|
||||
removeChildren widget
|
||||
Nothing -> return ()
|
||||
removeChildren outerBox
|
||||
|
||||
-- Create a new sentence box
|
||||
sentenceBox <- Gtk.boxNew Gtk.OrientationHorizontal 0
|
||||
Gtk.widgetSetHalign sentenceBox Gtk.AlignCenter
|
||||
|
||||
let tokens = map T.pack sentence
|
||||
widgets <- mapM createWordLabel tokens
|
||||
mapM_ (Gtk.boxAppend sentenceBox) widgets
|
||||
|
||||
Gtk.boxAppend outerBox sentenceBox
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- Gtk.applicationNew (Just "com.example.YomichanHover") []
|
||||
|
||||
void $ Gio.onApplicationActivate app $ do
|
||||
window <- Gtk.applicationWindowNew app
|
||||
Gtk.windowSetTitle window (Just "Yomichan Hover")
|
||||
Gtk.windowSetDefaultSize window 400 150
|
||||
|
||||
finalBox <- Gtk.boxNew Gtk.OrientationVertical 10
|
||||
Gtk.widgetSetHalign finalBox Gtk.AlignCenter
|
||||
Gtk.widgetSetValign finalBox Gtk.AlignCenter
|
||||
Gtk.windowSetChild window (Just finalBox)
|
||||
|
||||
-- Input field
|
||||
entry <- Gtk.entryNew
|
||||
Gtk.boxAppend finalBox entry
|
||||
Gtk.editableSetEditable entry True
|
||||
|
||||
-- Outer box (centers content)
|
||||
outerBox <- Gtk.boxNew Gtk.OrientationVertical 0
|
||||
Gtk.widgetSetHalign outerBox Gtk.AlignCenter
|
||||
Gtk.widgetSetValign outerBox Gtk.AlignCenter
|
||||
Gtk.boxAppend finalBox outerBox
|
||||
|
||||
|
||||
-- Connect signal to update UI when pressing Enter
|
||||
void $ Gtk.on entry #activate $ do
|
||||
text <- Gtk.editableGetText entry
|
||||
let sentence = words (T.unpack text)
|
||||
updateUI outerBox sentence
|
||||
|
||||
|
||||
|
||||
void $ Gtk.on window #closeRequest $ do
|
||||
Gio.applicationQuit app
|
||||
return False
|
||||
|
||||
Gtk.widgetSetVisible window True
|
||||
|
||||
_ <- Gio.applicationRun app Nothing
|
||||
return ()
|
||||
|
|
@ -1,47 +1,22 @@
|
|||
-- Copyright © 2025 Hashirama Senju
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
|
||||
|
||||
import Control.Concurrent
|
||||
import GI.Gtk
|
||||
import GI.Gtk
|
||||
import GI.Gio hiding (Application)
|
||||
import qualified GI.Gtk as GTK
|
||||
import Control.Monad (when, void, mzero, guard)
|
||||
import Data.Foldable (for_)
|
||||
import System.Directory (doesDirectoryExist, listDirectory)
|
||||
import System.FilePath ((</>))
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
|
||||
|
||||
selectFolder :: FileDialog -> ApplicationWindow -> (Maybe String -> IO ()) -> IO ()
|
||||
selectFolder fd w k =
|
||||
fileDialogSelectFolder fd (Just w) (Nothing :: Maybe Cancellable) $ Just $ \_ r -> do
|
||||
mbPath <- runMaybeT $ do
|
||||
f <- MaybeT $ handleDialogError (\_ _ -> pure Nothing) (fileDialogSelectFolderFinish fd r)
|
||||
p <- MaybeT $ fileGetPath f
|
||||
p <$ (liftIO (doesDirectoryExist p) >>= guard)
|
||||
k mbPath
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Application []
|
||||
onApplicationActivate app $ do
|
||||
|
||||
w <- new GI.Gtk.ApplicationWindow [#application := app,#title := "Wazajisho"]
|
||||
fd <- GTK.fileDialogNew
|
||||
GTK.fileDialogSetTitle fd "Select folder..."
|
||||
GTK.fileDialogSetModal fd True
|
||||
GTK.fileDialogSetAcceptLabel fd (Just "Select")
|
||||
|
||||
selectFolder fd w $ \mbPath -> case mbPath of
|
||||
Just p -> putStrLn $ "Selected directory: " ++ p
|
||||
Nothing -> putStrLn "No valid directory selected"
|
||||
|
||||
dlg <- new FileDialog [fileDialogInitialFolder :=> fileNewForPath "/"]
|
||||
window <- new GI.Gtk.ApplicationWindow [#application := app,
|
||||
#title := "Wazajisho"]
|
||||
{-
|
||||
This type is defined in the GI.Gio library, which we're importing (with import GI.Gio hiding (Application)).
|
||||
It’s a common pattern in GTK and GIO for asynchronous functions to accept a cancellable object.
|
||||
-}
|
||||
fileDialogSelectFolder dlg (Just window) (Nothing :: Maybe Cancellable) Nothing
|
||||
|
||||
applicationRun app Nothing
|
||||
threadDelay 30000000000
|
||||
|
|
|
|||
|
|
@ -1,51 +0,0 @@
|
|||
-- Copyright © 2025 Hashirama Senju
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
|
||||
|
||||
import Control.Concurrent
|
||||
import GI.Gtk
|
||||
import GI.Gio hiding (Application)
|
||||
import qualified GI.Gtk as GTK
|
||||
import Control.Monad (when, void, mzero, guard)
|
||||
import Data.Foldable (for_)
|
||||
import System.Directory (doesDirectoryExist, listDirectory)
|
||||
import System.FilePath ((</>))
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Wazahs
|
||||
|
||||
selectFolder :: FileDialog -> ApplicationWindow -> (Maybe String -> IO ()) -> IO ()
|
||||
selectFolder fd w k =
|
||||
fileDialogSelectFolder fd (Just w) (Nothing :: Maybe Cancellable) $ Just $ \_ r -> do
|
||||
mbPath <- runMaybeT $ do
|
||||
f <- MaybeT $ handleDialogError (\_ _ -> pure Nothing) (fileDialogSelectFolderFinish fd r)
|
||||
p <- MaybeT $ fileGetPath f
|
||||
p <$ (liftIO (doesDirectoryExist p) >>= guard)
|
||||
k mbPath
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Application []
|
||||
onApplicationActivate app $ do
|
||||
|
||||
w <- new GI.Gtk.ApplicationWindow [#application := app,#title := "Wazajisho"]
|
||||
fd <- GTK.fileDialogNew
|
||||
GTK.fileDialogSetTitle fd "Select folder..."
|
||||
GTK.fileDialogSetModal fd True
|
||||
GTK.fileDialogSetAcceptLabel fd (Just "Select")
|
||||
|
||||
selectFolder fd w $ maybe
|
||||
(putStrLn "No valid directory selected")
|
||||
(\dir -> do
|
||||
files <- listFiles dir
|
||||
putStrLn "Selected directory:"
|
||||
mapM_ putStrLn files)
|
||||
|
||||
|
||||
|
||||
applicationRun app Nothing
|
||||
threadDelay 30000000000
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
-- Copyright © 2025 Hashirama Senju
|
||||
{-
|
||||
this is an extremely fast and memory-constant program that lists mdx files in directories in recursive mode;
|
||||
the output is utf8, so that it can display japanese characters.
|
||||
|
||||
notice that you can remove the filter and generalize this to search for any file that you want.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Data.DirStream
|
||||
import Pipes
|
||||
import Pipes.Safe
|
||||
import System.IO (stdout, hSetEncoding, utf8)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Filesystem.Path.CurrentOS (encodeString, extension)
|
||||
import Control.Monad (when)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
hSetEncoding stdout utf8
|
||||
runSafeT $ runEffect $
|
||||
-- do a favor to yourself and please point to where the dictionaries actually are.
|
||||
for (every (descendentOf "/mnt/Data/Japanese_Resources/Dictionaries/")) $ \fp ->
|
||||
when (extension fp == Just "mdx") $
|
||||
liftIO $ TIO.putStrLn $ T.pack $ encodeString fp
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras
|
||||
import Foreign.Marshal.Array (withArray)
|
||||
import Foreign.Ptr (castPtr)
|
||||
import Control.Monad (void)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
dpy <- openDisplay ""
|
||||
|
||||
let screen = defaultScreen dpy -- pure value
|
||||
rootWin <- rootWindow dpy screen -- IO Window
|
||||
|
||||
win <- createSimpleWindow dpy rootWin 100 100 400 100 1 0 0
|
||||
|
||||
mapWindow dpy win
|
||||
|
||||
atomNetWm <- internAtom dpy "_NET_WM_WINDOW_TYPE" False
|
||||
atomDialog <- internAtom dpy "_NET_WM_WINDOW_TYPE_DIALOG" False
|
||||
atomAtom <- internAtom dpy "ATOM" False
|
||||
|
||||
withArray [atomDialog] $ \ptr ->
|
||||
void $ xChangeProperty dpy win atomNetWm atomAtom 32 propModeReplace (castPtr ptr) 1
|
||||
|
||||
flush dpy
|
||||
|
||||
putStrLn "Window created. Press Enter to exit."
|
||||
_ <- getLine
|
||||
|
||||
destroyWindow dpy win
|
||||
closeDisplay dpy
|
||||
252
hardcodedCss.hs
252
hardcodedCss.hs
|
|
@ -1,252 +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
|
||||
|
||||
|
||||
createScrollableToolbar :: [FilePath] -> IO Gtk.Widget
|
||||
createScrollableToolbar iconPaths = do
|
||||
-- Create scrolling container with infinite horizontal space
|
||||
scrolled <- Gtk.scrolledWindowNew
|
||||
Gtk.setScrolledWindowHscrollbarPolicy scrolled Gtk.PolicyTypeNever
|
||||
|
||||
|
||||
-- Create toolbar with subtle styling
|
||||
toolbar <- Gtk.boxNew Gtk.OrientationHorizontal 5 -- Reduced spacing
|
||||
adjustment <- new Gtk.Adjustment [#value := 50, #lower := 0, #upper := 100, #stepIncrement := 1]
|
||||
Gtk.scrolledWindowSetHadjustment scrolled (Just adjustment)
|
||||
|
||||
|
||||
-- Add modern visual effects
|
||||
cssProvider <- Gtk.cssProviderNew
|
||||
Gtk.cssProviderLoadFromString cssProvider $ T.pack $
|
||||
".glass-button {"
|
||||
++ "border: 1px solid rgba(255,255,255,0.2);" -- Thin white border
|
||||
++ "background-color: rgba(255,255,255,0.1);" -- Glass background
|
||||
++ "border-radius: 4px;" -- Rounded corners
|
||||
++ "backdrop-filter: blur(2px);" -- Blur effect
|
||||
++ "transition: all 0.2s ease;"
|
||||
++ "}"
|
||||
++ ".glass-button:hover {"
|
||||
++ "background-color: rgba(255,255,255,0.2);"
|
||||
++ "}"
|
||||
|
||||
mapM_ (\path -> do
|
||||
-- Create image with consistent aspect ratio
|
||||
icon <- Gtk.imageNewFromFile path
|
||||
Gtk.widgetSetSizeRequest icon 64 64
|
||||
Gtk.widgetSetHalign icon Gtk.AlignCenter
|
||||
|
||||
|
||||
-- Create styled button container
|
||||
btn <- Gtk.buttonNew
|
||||
Gtk.widgetAddCssClass btn "glass-button"
|
||||
Gtk.widgetSetSizeRequest btn 80 (-1)
|
||||
Gtk.buttonSetChild btn (Just icon)
|
||||
|
||||
-- Apply CSS styling
|
||||
context <- Gtk.widgetGetStyleContext btn
|
||||
Gtk.styleContextAddProvider context cssProvider 800 -- High priority
|
||||
|
||||
|
||||
|
||||
Gtk.boxAppend toolbar btn
|
||||
) iconPaths
|
||||
|
||||
Gtk.scrolledWindowSetChild scrolled (Just toolbar)
|
||||
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
|
||||
-- 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
|
||||
outer_toolbar <- new Gtk.Box [#orientation := Gtk.OrientationHorizontal, #spacing := 20,
|
||||
#baselinePosition := Gtk.BaselinePositionTop,
|
||||
#halign := Gtk.AlignFill,
|
||||
#hexpand := True, #widthRequest := 300,
|
||||
#marginTop := 10, #marginEnd := 10, #marginStart := 15]
|
||||
|
||||
window <- Gtk.applicationWindowNew app
|
||||
Gtk.windowSetTitle window (Just "Dictionary Toolbar")
|
||||
Gtk.windowSetDefaultSize window 800 100
|
||||
|
||||
|
||||
window <- Gtk.applicationWindowNew app
|
||||
toolbar <- createScrollableToolbar icons
|
||||
#append outer_toolbar toolbar
|
||||
Gtk.windowSetChild window (Just outer_toolbar)
|
||||
|
||||
Gtk.widgetShow window
|
||||
|
||||
_ <- applicationRun app Nothing
|
||||
return ()
|
||||
264
kanjiPicker.hs
264
kanjiPicker.hs
|
|
@ -1,264 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.GI.Base (castTo)
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gdk as Gdk
|
||||
import qualified GI.GdkX11 as GdkX11
|
||||
import GI.GLib (mainContextInvokeFull)
|
||||
import Data.GI.Base.Signals
|
||||
import GI.Gio
|
||||
import Control.Monad
|
||||
import Foreign.Marshal.Array (withArray)
|
||||
import Foreign.Ptr (castPtr)
|
||||
import Foreign.C.Types (CULong)
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras (xChangeProperty, propModeReplace)
|
||||
|
||||
import Data.Char (chr, toUpper)
|
||||
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.IORef
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
-- createKanjiPickerDialog: parent must be a Gtk.Window (ApplicationWindow is fine)
|
||||
-- components: full list of Text radicals (no keys bound)
|
||||
createKanjiPickerDialog :: Gtk.Window -> [T.Text] -> IO Gtk.Dialog
|
||||
createKanjiPickerDialog parent components = do
|
||||
dlg <- new Gtk.Dialog
|
||||
[ #transientFor := parent
|
||||
, #title := "Kanji Components"
|
||||
, #modal := True
|
||||
, #defaultWidth := 480
|
||||
, #defaultHeight := 320
|
||||
, #resizable := False
|
||||
]
|
||||
|
||||
content <- Gtk.dialogGetContentArea dlg
|
||||
|
||||
-- UI top: pager controls and page label
|
||||
pagerBox <- new Gtk.Box [ #orientation := Gtk.OrientationHorizontal, #spacing := 8 ]
|
||||
prevBtn <- new Gtk.Button [ #label := "Prev" ]
|
||||
pageLbl <- new Gtk.Label [ #label := "" ]
|
||||
nextBtn <- new Gtk.Button [ #label := "Next" ]
|
||||
Gtk.boxAppend pagerBox prevBtn
|
||||
Gtk.boxAppend pagerBox pageLbl
|
||||
Gtk.boxAppend pagerBox nextBtn
|
||||
|
||||
-- area that will contain the dynamic grid (we will swap children)
|
||||
gridContainer <- new Gtk.Box [ #orientation := Gtk.OrientationVertical, #spacing := 6 ]
|
||||
|
||||
-- selected label
|
||||
selected <- new Gtk.Label [ #label := "Selected:" ]
|
||||
|
||||
-- available keys to zip with components on each page
|
||||
let keys :: [Char]
|
||||
keys = "ASDFGHJKLQWERTYUIOPZXCVBNM" -- change order / letters as you like
|
||||
|
||||
pageSize = length keys
|
||||
|
||||
totalPages = (length components + pageSize - 1) `div` pageSize
|
||||
|
||||
-- state
|
||||
pageRef <- newIORef (0 :: Int)
|
||||
keyMapRef <- newIORef (Map.empty :: Map Char T.Text)
|
||||
btnMapRef <- newIORef (Map.empty :: Map Char Gtk.Button)
|
||||
gridRef <- newIORef (Nothing :: Maybe Gtk.Widget)
|
||||
|
||||
-- append controls to dialog
|
||||
Gtk.boxAppend content pagerBox
|
||||
Gtk.boxAppend content gridContainer
|
||||
Gtk.boxAppend content selected
|
||||
|
||||
-- appendSelected appends into the selected label (shared by clicks & keys)
|
||||
let appendSelected txt = do
|
||||
old <- Gtk.labelGetText selected
|
||||
let stripped = T.strip old
|
||||
base = if stripped == "Selected:" then "" else T.drop (T.length "Selected: " ) stripped
|
||||
newt = if T.null base then txt else base <> " " <> txt
|
||||
Gtk.labelSetText selected ("Selected: " <> newt)
|
||||
|
||||
-- build a page grid for given page index and set key/button maps
|
||||
let buildPage :: Int -> IO Gtk.Grid
|
||||
buildPage p = do
|
||||
let start = p * pageSize
|
||||
pageItems = take pageSize (drop start components)
|
||||
pairs = zip keys pageItems -- dynamic zip: keys -> components on this page
|
||||
|
||||
grid <- new Gtk.Grid [ #rowSpacing := 8, #columnSpacing := 8 ]
|
||||
|
||||
-- reset maps for this page
|
||||
let emptyKeyMap = Map.empty :: Map Char T.Text
|
||||
writeIORef keyMapRef emptyKeyMap
|
||||
writeIORef btnMapRef Map.empty
|
||||
|
||||
forM_ (zip [0..] pairs) $ \(i, (k, comp)) -> do
|
||||
-- button with centered label for the kanji
|
||||
btn <- new Gtk.Button [ #hexpand := True, #vexpand := True ]
|
||||
lbl <- new Gtk.Label [ #label := comp ]
|
||||
Gtk.widgetSetHalign lbl Gtk.AlignCenter
|
||||
Gtk.widgetSetValign lbl Gtk.AlignCenter
|
||||
#setChild btn (Just lbl)
|
||||
|
||||
-- small key label in the corner (Overlay)
|
||||
overlay <- new Gtk.Overlay []
|
||||
Gtk.overlaySetChild overlay (Just btn)
|
||||
|
||||
keyLbl <- new Gtk.Label [ #label := T.singleton (toUpper k) ]
|
||||
Gtk.widgetSetHalign keyLbl Gtk.AlignEnd
|
||||
Gtk.widgetSetValign keyLbl Gtk.AlignEnd
|
||||
Gtk.widgetSetMarginEnd keyLbl 6
|
||||
Gtk.widgetSetMarginBottom keyLbl 4
|
||||
sc <- Gtk.widgetGetStyleContext keyLbl
|
||||
Gtk.styleContextAddClass sc "small-key"
|
||||
Gtk.overlayAddOverlay overlay keyLbl
|
||||
|
||||
-- click action should append the component
|
||||
void $ Gtk.on btn #clicked $ appendSelected comp
|
||||
|
||||
-- put overlay into grid
|
||||
let cols = 8 :: Int -- visual columns (tweak to taste)
|
||||
col = fromIntegral (i `mod` cols)
|
||||
row = fromIntegral (i `div` cols)
|
||||
Gtk.gridAttach grid overlay col row 1 1
|
||||
|
||||
-- update maps
|
||||
modifyIORef' keyMapRef (Map.insert (toUpper k) comp)
|
||||
modifyIORef' btnMapRef (Map.insert (toUpper k) btn)
|
||||
|
||||
return grid
|
||||
|
||||
-- helper to render current page: remove old grid, create new one and show
|
||||
renderPage :: IO ()
|
||||
renderPage = do
|
||||
p <- readIORef pageRef
|
||||
let lblText = "Page " <> T.pack (show (p+1)) <> " / " <> T.pack (show totalPages)
|
||||
Gtk.labelSetText pageLbl lblText
|
||||
|
||||
-- remove old grid if any
|
||||
mOld <- readIORef gridRef
|
||||
case mOld of
|
||||
Just w -> void $ Gtk.boxRemove gridContainer w
|
||||
Nothing -> pure ()
|
||||
|
||||
-- build and append new grid
|
||||
g <- buildPage p
|
||||
wg <- Gtk.toWidget g
|
||||
writeIORef gridRef (Just wg)
|
||||
Gtk.boxAppend gridContainer g
|
||||
-- ensure visible
|
||||
Gtk.widgetShow g
|
||||
|
||||
-- Prev / Next handlers
|
||||
void $ Gtk.on prevBtn #clicked $ do
|
||||
modifyIORef' pageRef (\x -> max 0 (x - 1))
|
||||
renderPage
|
||||
|
||||
void $ Gtk.on nextBtn #clicked $ do
|
||||
modifyIORef' pageRef (\x -> min (totalPages - 1) (x + 1))
|
||||
renderPage
|
||||
|
||||
-- keyboard controller: left/right pages and per-page keys
|
||||
keyController <- Gtk.eventControllerKeyNew
|
||||
void $ Gtk.on keyController #keyPressed $ \keyval _keycode _state -> do
|
||||
u <- Gdk.keyvalToUnicode keyval
|
||||
if u == 0
|
||||
then return False
|
||||
else do
|
||||
let ch = toUpper (chr (fromIntegral u))
|
||||
case ch of
|
||||
'\x2190' -> do -- left arrow (not reliable via unicode here)
|
||||
modifyIORef' pageRef (\x -> max 0 (x - 1)); renderPage; return True
|
||||
'\x2192' -> do -- right arrow
|
||||
modifyIORef' pageRef (\x -> min (totalPages - 1) (x + 1)); renderPage; return True
|
||||
_ -> do
|
||||
km <- readIORef keyMapRef
|
||||
case Map.lookup ch km of
|
||||
Just comp -> appendSelected comp >> return True
|
||||
Nothing -> return False
|
||||
|
||||
-- attach controller to dialog
|
||||
Gtk.widgetAddController dlg keyController
|
||||
|
||||
-- initial render
|
||||
renderPage
|
||||
|
||||
return dlg
|
||||
|
||||
|
||||
-- Polymorphic: accepts any GTK window type
|
||||
setWindowAsDialog :: Gtk.IsWindow w => w -> IO ()
|
||||
setWindowAsDialog win = do
|
||||
-- upcast to concrete Gtk.Window right away (resolves ambiguity)
|
||||
wnd <- Gtk.toWindow win
|
||||
|
||||
-- now get surface with a concrete Window type in scope
|
||||
mSurface <- #getSurface wnd
|
||||
case mSurface of
|
||||
Just (surface :: Gdk.Surface) -> do
|
||||
-- cast to GDK X11 surface & display (explicit IO results)
|
||||
mX11Surface <- (castTo GdkX11.X11Surface surface) :: IO (Maybe GdkX11.X11Surface)
|
||||
display <- Gdk.surfaceGetDisplay surface
|
||||
mX11Display <- (castTo GdkX11.X11Display display) :: IO (Maybe GdkX11.X11Display)
|
||||
|
||||
case (mX11Display, mX11Surface) of
|
||||
(Just _gdkX11Disp, Just x11Surf) -> do
|
||||
-- get window XID and set ATOM via X11
|
||||
xidCULong <- GdkX11.x11SurfaceGetXid x11Surf
|
||||
|
||||
dpy <- openDisplay ""
|
||||
atomType <- internAtom dpy "_NET_WM_WINDOW_TYPE" False
|
||||
atomDialog <- internAtom dpy "_NET_WM_WINDOW_TYPE_DIALOG" False
|
||||
atomAtom <- internAtom dpy "ATOM" False
|
||||
|
||||
withArray [atomDialog] $ \ptr -> do
|
||||
let winX :: Window
|
||||
winX = fromIntegral (xidCULong :: CULong)
|
||||
void $ xChangeProperty dpy winX atomType atomAtom 32 propModeReplace (castPtr ptr) 1
|
||||
flush dpy
|
||||
|
||||
closeDisplay dpy
|
||||
_ -> putStrLn "Not running under X11."
|
||||
Nothing -> putStrLn "No surface available"
|
||||
|
||||
-- Polymorphic attach helper
|
||||
attachDialogOnRealize :: Gtk.IsWindow w => w -> IO SignalHandlerId
|
||||
attachDialogOnRealize win = do
|
||||
wnd <- Gtk.toWindow win
|
||||
on wnd #realize (setWindowAsDialog win)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Gtk.Application [#applicationId := "org.example.test"]
|
||||
|
||||
void $ Gtk.on app #activate $ do
|
||||
win <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Main Window"
|
||||
, #defaultWidth := 400
|
||||
, #defaultHeight := 100
|
||||
]
|
||||
|
||||
-- List of all kanji components (you can extend freely)
|
||||
let allComponents :: [T.Text]
|
||||
allComponents =
|
||||
[ "氵", "心", "亻", "木", "口", "日", "月", "艹"
|
||||
, "火", "女", "糸", "手", "金", "水", "土", "言"
|
||||
, "目", "耳", "足", "見", "虫", "貝", "車", "食"
|
||||
, "魚", "鳥", "雨", "馬", "風", "竹", "田", "米"
|
||||
, "石", "山", "川", "弓", "矢", "刀", "犬", "王"
|
||||
]
|
||||
|
||||
parentWin <- Gtk.toWindow win
|
||||
dlg <- createKanjiPickerDialog parentWin allComponents
|
||||
|
||||
-- Show both main window and dialog
|
||||
Gtk.widgetShow win
|
||||
Gtk.widgetShow dlg
|
||||
|
||||
void $ applicationRun app Nothing
|
||||
|
|
@ -1,266 +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
|
||||
-- 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 ()
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
|
||||
import Data.GI.Base
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gdk as Gdk
|
||||
import qualified GI.GdkX11 as GdkX11
|
||||
import GI.Gio
|
||||
import Control.Monad (void)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Gtk.Application [#applicationId := "org.example.test"]
|
||||
on app #activate $ do
|
||||
win <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Dialog Window"
|
||||
, #defaultWidth := 100
|
||||
, #defaultHeight := 40
|
||||
, #resizable := False
|
||||
, #decorated := False
|
||||
]
|
||||
Gtk.widgetShow win
|
||||
|
||||
mSurface <- #getSurface win
|
||||
case mSurface of
|
||||
Just surface -> do
|
||||
-- get X11 surface and display
|
||||
x11Surface <- castTo GdkX11.X11Surface surface
|
||||
display <- Gdk.surfaceGetDisplay surface
|
||||
x11Display <- castTo GdkX11.X11Display display
|
||||
|
||||
case (x11Display, x11Surface) of
|
||||
(Just d, Just s) -> do
|
||||
-- retrieve atoms via GDK X11
|
||||
atomDialog <- GdkX11.x11GetXatomByNameForDisplay d "_NET_WM_WINDOW_TYPE_DIALOG"
|
||||
atomType <- GdkX11.x11GetXatomByNameForDisplay d "_NET_WM_WINDOW_TYPE"
|
||||
|
||||
-- set window type using UTF8 property (technically still a string, but fine for WM hints)
|
||||
GdkX11.x11SurfaceSetUtf8Property
|
||||
s
|
||||
"_NET_WM_WINDOW_TYPE"
|
||||
(Just "_NET_WM_WINDOW_TYPE_DIALOG")
|
||||
|
||||
_ -> putStrLn "Not running under X11."
|
||||
Nothing -> pure ()
|
||||
|
||||
void $ applicationRun app Nothing
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings, OverloadedLabels, ImplicitParams #-}
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import System.Environment (getArgs, getProgName)
|
||||
import Data.GI.Base
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified Graphics.X11.Xlib as X11
|
||||
import Graphics.X11.Xlib.Misc
|
||||
import Graphics.X11.Xlib.Types
|
||||
import Foreign.C.Types
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Word
|
||||
|
||||
|
||||
-- | Hardcoded kana table: QWERTY key string -> Kana
|
||||
kanaMap :: Map.Map String Text
|
||||
kanaMap = Map.fromList
|
||||
[ ("1", "ぬ"), ("2", "ふ"), ("3", "あ"), ("4", "う"), ("5", "え"), ("6", "お")
|
||||
, ("7", "や"), ("8", "ゆ"), ("9", "よ"), ("0", "わ"), ("-", "ほ"), ("^", "へ")
|
||||
, ("q", "た"), ("w", "て"), ("e", "い"), ("r", "す"), ("t", "か"), ("y", "ん")
|
||||
, ("u", "な"), ("i", "に"), ("o", "ら"), ("p", "せ")
|
||||
, ("a", "ち"), ("s", "と"), ("d", "し"), ("f", "は"), ("g", "き"), ("h", "く")
|
||||
, ("j", "ま"), ("k", "の"), ("l", "り"), (";", "れ"), (":", "け")
|
||||
, ("z", "つ"), ("x", "さ"), ("c", "そ"), ("v", "ひ"), ("b", "こ"), ("n", "み")
|
||||
, ("m", "も"), (",", "ね"), (".", "る"), ("/", "め"), ("\\", "ろ")
|
||||
]
|
||||
|
||||
-- | Convert GDK keyval (Word32) to string (e.g., "e", "a", etc.)
|
||||
parseKeycode :: Word32 -> IO String
|
||||
parseKeycode keycode = do
|
||||
display <- X11.openDisplay ""
|
||||
let keycodeW8 = fromIntegral keycode :: Word8
|
||||
keysym <- keycodeToKeysym display keycodeW8 0
|
||||
return (keysymToString keysym)
|
||||
|
||||
|
||||
-- | GTK main logic
|
||||
activate :: Gtk.Application -> IO ()
|
||||
activate app = do
|
||||
window <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Kana Practice"
|
||||
]
|
||||
|
||||
label <- new Gtk.Label [ #label := "Press a kana key" ]
|
||||
#setChild window (Just label)
|
||||
|
||||
controller <- Gtk.new Gtk.EventControllerKey []
|
||||
Gtk.widgetAddController window controller
|
||||
|
||||
Gtk.on controller #keyPressed $ \_ keyval _ -> do
|
||||
keyStr <- liftIO (parseKeycode keyval)
|
||||
let kana = Map.lookup keyStr kanaMap
|
||||
case kana of
|
||||
Just k -> #setLabel label k
|
||||
Nothing -> #setLabel label "?"
|
||||
pure True
|
||||
|
||||
#show window
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Gtk.Application
|
||||
[ #applicationId := "org.example.kana"
|
||||
, On #activate (activate ?self)
|
||||
]
|
||||
args <- getArgs
|
||||
progName <- getProgName
|
||||
void $ #run app (Just $ progName : args)
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import GI.Gdk.Objects.Display
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Maybe
|
||||
import GI.Gdk
|
||||
import GI.Gtk
|
||||
import GI.Gio hiding (Application)
|
||||
import Control.Monad
|
||||
|
||||
printMessage :: IO ()
|
||||
printMessage = do
|
||||
putStrLn "clipboard changed!"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Application []
|
||||
void $ onApplicationActivate app $ do
|
||||
window <- applicationWindowNew app
|
||||
|
||||
clipboard <- displayGetDefault >>= maybe (error "No display") (liftM id . displayGetClipboard)
|
||||
on clipboard #changed printMessage
|
||||
#show window
|
||||
|
||||
_ <- applicationRun app Nothing
|
||||
return ()
|
||||
Loading…
Reference in a new issue