*[[Haskell:http://www.haskell.org/]] [#r7b07a76] #ref(http://upload.wikimedia.org/wikipedia/commons/thumb/1/1c/Haskell-Logo.svg/200px-Haskell-Logo.svg.png,right,around,nolink,Haskell) &color(White,#5F2F2F){ ''◆目次◆'' };&br; #contents *Haskell 2010 [#j02438c3] -[[Haskell:http://www.haskell.org/]] -[[HaskellWiki:http://www.haskell.org/haskellwiki/Haskell]] -[[HaskellJP wiki:http://wiki.haskell.jp/]] -[[Learn You a Haskell for Great Good!:http://learnyouahaskell.com/]] -[[ゆるふわHaskell (Light & Airy Haskell):http://kzfm.github.io/laskell/]] -http://maoe.hatenadiary.jp/archive/category/Haskell -[[本物のプログラマはHaskellを使う:http://itpro.nikkeibp.co.jp/article/COLUMN/20060915/248215/]] -[[Haskellで文字列を UTF-32 ⇔UTF-16 変換する。:http://d.hatena.ne.jp/sirocco/20130416/1366103044]] -[[Haskellで副作用を起こす(Win32 API によるUTF-16 ⇔ Shift-JIS 変換):http://d.hatena.ne.jp/sirocco/20130422/1366632065]] -[[島ぶくろ Haskellプログラミング:http://saltheads.blog134.fc2.com/blog-category-16.html]] -[[unsafePerformIOでunsafeなグローバル変数を作る。:http://d.hatena.ne.jp/napthats/20120426/1335416167]] -[[Haskellの構造体をCと同期させる:http://tsubaki.hatenablog.com/entry/20110112/1294759187]] -[[Haskell@Windowsのコンソールで日本語が文字化けする話の対策:http://tsubaki.hatenablog.com/entry/2013/02/20/090115]] -[[How do I use Haskell's FFI on structs?:http://stackoverflow.com/questions/670221/how-do-i-use-haskells-ffi-on-structs]] -http://darcs.haskell.org/testsuite/timeout/ --http://darcs.haskell.org/testsuite/timeout/WinCBindings.hsc -https://bitbucket.org/dionthegod/fuzzywuzzy/src/cfd324244691/System/Win32/DebugProcess.hsc -http://tanakh.jp/pub/pfi-seminar-2011-12-08.html#1 -http://www.ync-net.co.jp/~kaz/cgi-bin/WiLiKi/wiliki.cgi?try%2fthrow%2fcatch%2ffinally -http://keqh.net/cookbook/ -[[Haskell の例外処理:http://tnomura9.exblog.jp/15094780/]] -[[Haskell での例外処理:http://d.hatena.ne.jp/kazu-yamamoto/20120604/1338802792]], [[Haskellでの例外処理(その2):http://d.hatena.ne.jp/kazu-yamamoto/20120605/1338871044]] -http://stackoverflow.com/questions/6009384/exception-handling-in-haskell -http://stackoverflow.com/questions/2386210/how-to-get-a-pointer-value-in-haskell -[[48時間でSchemeを書こう:http://ja.wikibooks.org/wiki/48%E6%99%82%E9%96%93%E3%81%A7Scheme%E3%82%92%E6%9B%B8%E3%81%93%E3%81%86]] -[[Haskellの勉強をしていたら、Elixirのパイプライン演算子がF#由来であることを知った:http://d.hatena.ne.jp/ajiyoshi/20130127/1359284684]] -[[ファンクタ, アプリカティブ, モナド:https://gist.github.com/kohyama/5856037]] -[[lhs2TeX:http://www.andres-loeh.de/lhs2tex/]] -[[Haskell Advent Calendar 2013 - Qiita [キータ]:http://qiita.com/advent-calendar/2013/haskell]] *[[fwdsumatrapdf>SumatraPDF/fwdsumatrapdf]] &aname(fwdsumatrapdf); [#j60bcd39] **Haskell 版 [#cbd580e5] The Glorious Glasgow Haskell Compilation System, version 7.6.3 でビルドできます.~ Windows PowerShell から以下のようにしてビルドします.~ PS C:\w32tex\bin> ghc fwdsumatrapdf.hs ---- -C:\w32tex\bin\fwdsumatrapdf.hs ---- -- vim: ts=4 sw=4 expandtab: -- >ghc fwdsumatrapdf.hs module Main where import System.Directory import System.Environment import System.Exit import System.Process import System.Win32.Registry import System.Win32.Types import System.IO.Unsafe import Data.Bits import Data.Int import Data.IORef import Debug.Trace import Graphics.Win32.GDI.Types import Control.Concurrent import Control.Exception import Control.Monad.Error import Control.Monad.Reader import Text.Printf import Foreign.C.Types import Foreign.C.String import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.ForeignPtr import Foreign.Storable foreign import ccall "wchar.h wcscmp" c_wcscmp :: CWString -> CWString -> IO CInt foreign import ccall "wchar.h wcsrchr" c_wcsrchr :: CWString -> CWchar -> IO (Ptr CWchar) foreign import stdcall "windows.h GetWindowTextW" getWindowTextW :: HWND -> CWString -> CInt -> IO CInt foreign import stdcall "wrapper" mkEnumWindowsProc :: EnumWindowsProc -> IO (FunPtr EnumWindowsProc) foreign import stdcall "windows.h EnumWindows" enumWindows :: FunPtr EnumWindowsProc -> LPARAM -> IO BOOL foreign import stdcall "windows.h CreateProcessW" createProcessW :: CWString -> CWString -> Ptr () -> Ptr () -> CInt -> CInt -> Ptr () -> Ptr () -> Ptr STARTUPINFOW -> Ptr PROCESS_INFORMATION -> IO BOOL foreign import stdcall "windows.h WaitForInputIdle" waitForInputIdle :: HANDLE -> CUInt -> IO CUInt foreign import stdcall "wrapper" mkDdeCallback :: DdeCallback -> IO (FunPtr DdeCallback) foreign import stdcall "ddeml.h DdeInitializeW" ddeInitializeW :: Ptr CUInt -> FunPtr DdeCallback -> CUInt -> CUInt -> IO CUInt foreign import stdcall "ddeml.h DdeUninitialize" ddeUninitialize :: CUInt -> IO BOOL foreign import stdcall "ddeml.h DdeCreateStringHandleW" ddeCreateStringHandleW :: CUInt -> CWString -> CInt -> IO HANDLE foreign import stdcall "ddeml.h DdeFreeStringHandle" ddeFreeStringHandle :: CUInt -> HANDLE -> IO BOOL foreign import stdcall "ddeml.h DdeGetLastError" ddeGetLastError :: CUInt -> IO CUInt foreign import stdcall "ddeml.h DdeCreateDataHandle" ddeCreateDataHandle :: CUInt -> CWString -> CInt -> CInt -> Ptr () -> CUInt -> CInt -> IO HANDLE foreign import stdcall "ddeml.h DdeFreeDataHandle" ddeFreeDataHandle :: HANDLE -> IO BOOL foreign import stdcall "ddeml.h DdeClientTransaction" ddeClientTransaction :: Ptr BYTE -> CUInt -> Ptr () -> Ptr () -> CInt -> CUInt -> CInt -> Ptr () -> IO HANDLE foreign import stdcall "ddeml.h DdeConnect" ddeConnect :: CUInt -> Ptr () -> Ptr () -> Ptr () -> IO HANDLE foreign import stdcall "ddeml.h DdeDisconnect" ddeDisconnect :: HANDLE -> IO BOOL type EnumWindowsProc = HWND -> LPARAM -> IO BOOL type DdeCallback = CUInt -> CUInt -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> DWORD -> DWORD -> IO (Ptr ()) type LPPROCESS_INFORMATION = Ptr PROCESS_INFORMATION data PROCESS_INFORMATION = PROCESS_INFORMATION { piProcess :: HANDLE , piThread :: HANDLE , piProcessId :: DWORD , piThreadId :: DWORD } deriving Show instance Storable PROCESS_INFORMATION where sizeOf = const (16) alignment = sizeOf poke buf pi = do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (piProcess pi) ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) buf (piThread pi) ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf (piProcessId pi) ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) buf (piThreadId pi) peek buf = do vhProcess <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf vhThread <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) buf vdwProcessId <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) buf vdwThreadId <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) buf return $ PROCESS_INFORMATION { piProcess = vhProcess, piThread = vhThread, piProcessId = vdwProcessId, piThreadId = vdwThreadId} type LPSTARTUPINFOW = Ptr STARTUPINFOW data STARTUPINFOW = STARTUPINFOW { siCb :: DWORD , siDesktop :: LPWSTR , siTitle :: LPWSTR , siX :: DWORD , siY :: DWORD , siXSize :: DWORD , siYSize :: DWORD , siXCountChars :: DWORD , siYCountChars :: DWORD , siFillAttribute :: DWORD , siFlags :: DWORD , siShowWindow :: WORD , siStdInput :: HANDLE , siStdOutput :: HANDLE , siStdError :: HANDLE } deriving Show instance Storable STARTUPINFOW where sizeOf = const (68) alignment = sizeOf poke buf si = do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (siCb si) ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf (siDesktop si) ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) buf (siTitle si) ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) buf (siX si) ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) buf (siY si) ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) buf (siXSize si) ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) buf (siYSize si) ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) buf (siXCountChars si) ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) buf (siYCountChars si) ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) buf (siFillAttribute si) ((\hsc_ptr -> pokeByteOff hsc_ptr 44)) buf (siFlags si) ((\hsc_ptr -> pokeByteOff hsc_ptr 48)) buf (siShowWindow si) ((\hsc_ptr -> pokeByteOff hsc_ptr 56)) buf (siStdInput si) ((\hsc_ptr -> pokeByteOff hsc_ptr 60)) buf (siStdOutput si) ((\hsc_ptr -> pokeByteOff hsc_ptr 64)) buf (siStdError si) peek buf = do vcb <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf vlpDesktop <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) buf vlpTitle <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) buf vdwX <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) buf vdwY <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) buf vdwXSize <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) buf vdwYSize <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) buf vdwXCountChars <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) buf vdwYCountChars <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) buf vdwFillAttribute <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) buf vdwFlags <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) buf vwShowWindow <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) buf vhStdInput <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) buf vhStdOutput <- ((\hsc_ptr -> peekByteOff hsc_ptr 60)) buf vhStdError <- ((\hsc_ptr -> peekByteOff hsc_ptr 64)) buf return $ STARTUPINFOW { siCb = vcb, siDesktop = vlpDesktop, siTitle = vlpTitle, siX = vdwX, siY = vdwY, siXSize = vdwXSize, siYSize = vdwYSize, siXCountChars = vdwXCountChars, siYCountChars = vdwYCountChars, siFillAttribute = vdwFillAttribute, siFlags = vdwFlags, siShowWindow = vwShowWindow, siStdInput = vhStdInput, siStdOutput = vhStdOutput, siStdError = vhStdError} aPPCMD_CLIENTONLY :: CUInt aPPCMD_CLIENTONLY = 0x10 cP_WINUNICODE :: CInt cP_WINUNICODE = 1200 cF_UNICODETEXT :: CUInt cF_UNICODETEXT = 13 xCLASS_FLAGS :: CUInt xCLASS_FLAGS = 0x4000 xTYP_EXECUTE :: CUInt xTYP_EXECUTE = 0x0050 .|. xCLASS_FLAGS timeout :: CInt timeout = 10000 {-# NOINLINE existSumatraHWND #-} existSumatraHWND :: IORef Bool existSumatraHWND = unsafePerformIO $ newIORef False runSumatraPDF :: String -> IO Bool runSumatraPDF pdf = do enumwindowsproc <- mkEnumWindowsProc getSumatraHWND enumWindows enumwindowsproc lParam existSumatraPDF <- readIORef existSumatraHWND case existSumatraPDF of True -> return True False -> do findSumatraPDFInRegistry return True where sumatrapdfWin32 = "C:\\Program Files\\SumatraPDF\\SumatraPDF.exe" sumatrapdfWin64 = "C:\\Program Files (x86)\\SumatraPDF\\SumatraPDF.exe" reuseInstance = "-reuse-instance" lParam = 0 getSumatraHWND hwnd lParam = do let maxSize = 1024 let latinCapitalLetterS = 0x53 -- 'S' == 0x53 bracket (do windowText <- mallocArray (fromIntegral maxSize) sumatrapdf <- newCWString "SumatraPDF" return (windowText, sumatrapdf)) (\(windowText, sumatrapdf) -> do free windowText free sumatrapdf) (\(windowText, sumatrapdf) -> do getWindowTextW hwnd windowText maxSize title <- c_wcsrchr windowText latinCapitalLetterS if title /= nullPtr then do cmp <- c_wcscmp title sumatrapdf if cmp == 0 then do writeIORef existSumatraHWND True return True else do return True else do return True) findSumatraPDFInRegistry = do let keyPath = "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\SumatraPDF.exe" regKey <- regOpenKeyEx hKEY_LOCAL_MACHINE keyPath kEY_QUERY_VALUE if regKey /= nullFinalHANDLE then do sumatrapdfRegistry <- regQueryValue regKey Nothing regCloseKey regKey startSumatraPDF sumatrapdfRegistry return True else do findSumatraPDF sumatrapdfWin32 findSumatraPDF sumatrapdfWin64 return False findSumatraPDF file = do exist <- doesFileExist file if exist then do startSumatraPDF file return True else do return False startSumatraPDF file = do let sumatrapdfCommandLine = "\"" ++ file ++ "\" " ++ reuseInstance ++ " " ++ "\"" ++ pdf ++ "\"" withCWString sumatrapdfCommandLine $ \cmd -> do alloca $ \p_si -> do alloca $ \p_pi -> do createProcessW nullPtr cmd nullPtr nullPtr 0 0 nullPtr nullPtr p_si p_pi pi <- peek p_pi waitForInputIdle (piProcess pi) (fromIntegral timeout) ddeExecute :: String -> String -> String -> IO (CUInt, HANDLE, HANDLE, HANDLE, HANDLE, Ptr ()) ddeExecute server topic command = do bracket (getIdInstance) (\idInstance -> do if idInstance /= 0 then ddeUninitialize idInstance else return False) (\idInstance -> do bracket (getHszServer idInstance server) (\hszServer -> do if hszServer /= nullPtr then ddeFreeStringHandle idInstance hszServer else return False) (\hszServer -> do bracket (getHszTopic idInstance topic) (\hszTopic -> do if hszTopic /= nullPtr then ddeFreeStringHandle idInstance hszTopic else return False) (\hszTopic -> do bracket (getHConvClient idInstance hszServer hszTopic) (\hConvClient -> do if hConvClient /= nullPtr then ddeDisconnect hConvClient else return False) (\hConvClient -> do bracket (getHDdeData idInstance command) (\hDdeData -> do if hDdeData /= nullPtr then ddeFreeDataHandle hDdeData else return False) (\hDdeData -> do bracket (getHDdeTransactionData hDdeData hConvClient) (\hDdeTransactionData -> do if hDdeTransactionData /= nullPtr then ddeFreeDataHandle hDdeTransactionData else return False) (\hDdeTransactionData -> do return (idInstance, hszServer, hszTopic, hConvClient, hDdeData, hDdeTransactionData))))))) where sumatraDdeCallback uType uFmt hconv hsz1 hsza2 hdata dwData1 dwData2 = do return nullPtr getIdInstance = do alloca $ \p_idInstance -> do ddecallback <- mkDdeCallback sumatraDdeCallback e <- ddeInitializeW p_idInstance ddecallback aPPCMD_CLIENTONLY 0 idInstance <- peek p_idInstance if idInstance == 0 || e /= 0 then do throwIO $ userError "ddeInitializeW Error" return idInstance else return idInstance getHszServer idInstance server = do withCWString server $ \sv -> do hszServer <- ddeCreateStringHandleW idInstance sv cP_WINUNICODE if hszServer == nullPtr then throwIO $ userError "ddeCreateStringHandleW Error" else return True return hszServer getHszTopic idInstance topic = do withCWString topic $ \tp -> do hszTopic <- ddeCreateStringHandleW idInstance tp cP_WINUNICODE if hszTopic == nullPtr then throwIO $ userError "ddeCreateStringHandleW Error" else return True return hszTopic getHConvClient idInstance hszServer hszTopic = do hConvClient <- ddeConnect idInstance hszServer hszTopic nullPtr if hConvClient == nullPtr then throwIO $ userError "ddeConnect Error" else return True return hConvClient getHDdeData idInstance command = do withCWStringLen command $ \(cmd, len) -> do hDdeData <- ddeCreateDataHandle idInstance cmd (fromIntegral ((len + 1) * (sizeOf $ CWchar 0))) 0 nullPtr cF_UNICODETEXT 0 if hDdeData == nullPtr then throwIO $ userError "ddeCreateDataHandle Error" else return True return hDdeData getHDdeTransactionData hDdeData hConvClient = do hDdeTransactionData <- ddeClientTransaction (castPtr hDdeData) (-1) hConvClient nullPtr 0 xTYP_EXECUTE timeout nullPtr if hDdeTransactionData == nullPtr then throwIO $ userError "ddeClientTransaction Error" else return True return hDdeData main :: IO a main = do args <- getArgs usage args let pdf = args !! 0 let tex = args !! 1 let line = read $ args !! 2 :: Int runSumatraPDF pdf `catch` printError let active = 0 let forwardSearch = "[ForwardSearch(\"" ++ pdf ++ "\",\"" ++ tex ++ "\"," ++ show line ++ ",0,0," ++ show active ++ ")]" ddeExecute "SUMATRA" "control" forwardSearch `catch` printError exitWith ExitSuccess where usage args = do case length args of 3 -> return ExitSuccess _ -> do progName <- getProgName putStrLn $ "usage: " ++ progName ++ " pdffile texfile line" exitWith $ ExitFailure 2 printError :: SomeException -> IO a printError e = do print e exitWith $ ExitFailure 1 ----