*[[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){ ''◆CONTENTS◆'' };&br; #contents *Summary [#j02438c3] Haskell は非正格な純粋関数型プログラミング言語です.~ -[http://www.haskell.org/ Haskell] -[http://www.haskell.org/haskellwiki/Haskell HaskellWiki] -[http://www.haskell.org/pipermail/libraries/ The Libraries Archives] -[[HaskellJP wiki:http://wiki.haskell.jp/]] -[[Learn You a Haskell for Great Good!:http://learnyouahaskell.com/]] -https://github.com/yallop/haskell2014-papers -http://www.reddit.com/r/haskell/ -[http://d.hatena.ne.jp/kazu-yamamoto/touch/20140206/1391666962 Real World Haskell の古いところ] -[[ゆるふわ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://www.cse.unsw.edu.au/~chak/haskell/ffi/ffi/ffise6.html -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]] -[[Theorem Prover Advent Calendar 2013 - Qiita [キータ]:http://qiita.com/advent-calendar/2013/theorem_prover]] -[[Haskell for OCaml programmers:http://staff.science.uva.nl/~poss/haskell-for-ocaml-programmers.html]] -[http://cx4a.org/posts/2014-06-03-solve-the-configurations-problem-for-haskell.html HaskellにおけるConfigurations Problemを解決する] -[http://www.sampou.org/haskell/haskell2010-report-htja/ Haskell 2010 言語報告書] --[http://www.sampou.org/haskell/haskell2010-report-htja/haskellch8.html Chapter 8 外部関数インターフェイス] *Haskell で LaTeX [#b3f747e0] **HaTeX [#vb17eba3] -[http://www.haskell.org/haskellwiki/HaTeX HaTeX - HaskellWiki] *[[fwdsumatrapdf>SumatraPDF/fwdsumatrapdf]] &aname(fwdsumatrapdf); [#j60bcd39] **Haskell 版 [#cbd580e5] The Glorious Glasgow Haskell Compilation System, version 7.8.2 で動作確認しています.~ Windows PowerShell またはコマンド プロンプトから以下のようにしてビルドします.~ hsc2hs fwdsumatrapdf_ffi.hsc ghc -cpp fwdsumatrapdf.hs fwdsumatrapdf_ffi.hs ---- -fwdsumatrapdf_ffi.hsc ---- {-# LANGUAGE ForeignFunctionInterface #-} module FwdSumatraPDF where import Graphics.Win32.GDI.Types (HWND) import Data.Bits ((.|.)) import System.Win32.Types (BOOL, BYTE, WORD, DWORD, UINT, LPARAM, LPBYTE, LPDWORD, LPWSTR, LPCWSTR, LPVOID, HANDLE) import Foreign.C.String (CWString) import Foreign.C.Types (CInt(..), CUInt(..), CWchar(..)) import Foreign.Ptr (Ptr, FunPtr) import Foreign.Storable (alignment, sizeOf, peek, peekByteOff, poke, pokeByteOff, Storable) #include <windows.h> ##ifdef x86_64_BUILD_ARCH ##define stdcall ccall ##endif foreign import ccall unsafe "wchar.h wcscmp" c_wcscmp :: CWString -> CWString -> IO CInt foreign import ccall unsafe "wchar.h wcsrchr" c_wcsrchr :: CWString -> CWchar -> IO (Ptr CWchar) foreign import stdcall unsafe "windows.h GetWindowTextW" getWindowTextW :: HWND -> LPWSTR -> CInt -> IO CInt foreign import stdcall unsafe "wrapper" mkEnumWindowsProc :: EnumWindowsProc -> IO (FunPtr EnumWindowsProc) foreign import stdcall safe "windows.h EnumWindows" enumWindows :: FunPtr EnumWindowsProc -> LPARAM -> IO BOOL foreign import stdcall unsafe "windows.h CreateProcessW" createProcessW :: LPCWSTR -> LPWSTR -> Ptr () -> Ptr () -> BOOL -> DWORD -> LPVOID -> LPCWSTR -> LPSTARTUPINFOW -> LPPROCESS_INFORMATION -> IO BOOL foreign import stdcall unsafe "windows.h WaitForInputIdle" waitForInputIdle :: HANDLE -> DWORD -> IO DWORD foreign import stdcall unsafe "wrapper" mkDdeCallback :: DdeCallback -> IO (FunPtr DdeCallback) foreign import stdcall unsafe "ddeml.h DdeInitializeW" ddeInitializeW :: LPDWORD -> FunPtr DdeCallback -> DWORD -> DWORD -> IO UINT foreign import stdcall unsafe "ddeml.h DdeUninitialize" ddeUninitialize :: DWORD -> IO BOOL foreign import stdcall unsafe "ddeml.h DdeCreateStringHandleW" ddeCreateStringHandleW :: DWORD -> LPWSTR -> CInt -> IO HANDLE foreign import stdcall unsafe "ddeml.h DdeFreeStringHandle" ddeFreeStringHandle :: DWORD -> HANDLE -> IO BOOL foreign import stdcall unsafe "ddeml.h DdeGetLastError" ddeGetLastError :: DWORD -> IO UINT foreign import stdcall unsafe "ddeml.h DdeCreateDataHandle" ddeCreateDataHandle :: DWORD -> LPBYTE -> DWORD -> DWORD -> HANDLE -> UINT -> UINT -> IO HANDLE foreign import stdcall unsafe "ddeml.h DdeFreeDataHandle" ddeFreeDataHandle :: HANDLE -> IO BOOL foreign import stdcall unsafe "ddeml.h DdeClientTransaction" ddeClientTransaction :: LPBYTE -> DWORD -> HANDLE -> HANDLE -> UINT -> UINT -> DWORD -> LPDWORD -> IO HANDLE foreign import stdcall unsafe "ddeml.h DdeConnect" ddeConnect :: DWORD -> HANDLE -> HANDLE -> Ptr () -> IO HANDLE foreign import stdcall unsafe "ddeml.h DdeDisconnect" ddeDisconnect :: HANDLE -> IO BOOL aPPCMD_CLIENTONLY :: DWORD aPPCMD_CLIENTONLY = 0x10 cP_WINUNICODE :: CInt cP_WINUNICODE = 1200 cF_UNICODETEXT :: UINT cF_UNICODETEXT = 13 xCLASS_FLAGS :: UINT xCLASS_FLAGS = 0x4000 xTYP_EXECUTE :: UINT xTYP_EXECUTE = 0x0050 .|. xCLASS_FLAGS timeout :: DWORD timeout = 10000 type EnumWindowsProc = HWND -> LPARAM -> IO BOOL type DdeCallback = UINT -> UINT -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> DWORD -> DWORD -> IO HANDLE 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 #size STARTUPINFOW alignment = sizeOf poke buf si = do (#poke STARTUPINFOW, cb) buf (siCb si) (#poke STARTUPINFOW, lpDesktop) buf (siDesktop si) (#poke STARTUPINFOW, lpTitle) buf (siTitle si) (#poke STARTUPINFOW, dwX) buf (siX si) (#poke STARTUPINFOW, dwY) buf (siY si) (#poke STARTUPINFOW, dwXSize) buf (siXSize si) (#poke STARTUPINFOW, dwYSize) buf (siYSize si) (#poke STARTUPINFOW, dwXCountChars) buf (siXCountChars si) (#poke STARTUPINFOW, dwYCountChars) buf (siYCountChars si) (#poke STARTUPINFOW, dwFillAttribute) buf (siFillAttribute si) (#poke STARTUPINFOW, dwFlags) buf (siFlags si) (#poke STARTUPINFOW, wShowWindow) buf (siShowWindow si) (#poke STARTUPINFOW, hStdInput) buf (siStdInput si) (#poke STARTUPINFOW, hStdOutput) buf (siStdOutput si) (#poke STARTUPINFOW, hStdError) buf (siStdError si) peek buf = do vcb <- (#peek STARTUPINFOW, cb) buf vlpDesktop <- (#peek STARTUPINFOW, lpDesktop) buf vlpTitle <- (#peek STARTUPINFOW, lpTitle) buf vdwX <- (#peek STARTUPINFOW, dwX) buf vdwY <- (#peek STARTUPINFOW, dwY) buf vdwXSize <- (#peek STARTUPINFOW, dwXSize) buf vdwYSize <- (#peek STARTUPINFOW, dwYSize) buf vdwXCountChars <- (#peek STARTUPINFOW, dwXCountChars) buf vdwYCountChars <- (#peek STARTUPINFOW, dwYCountChars) buf vdwFillAttribute <- (#peek STARTUPINFOW, dwFillAttribute) buf vdwFlags <- (#peek STARTUPINFOW, dwFlags) buf vwShowWindow <- (#peek STARTUPINFOW, wShowWindow) buf vhStdInput <- (#peek STARTUPINFOW, hStdInput) buf vhStdOutput <- (#peek STARTUPINFOW, hStdOutput) buf vhStdError <- (#peek STARTUPINFOW, hStdError) 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} 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 #size PROCESS_INFORMATION alignment = sizeOf poke buf pi = do (#poke PROCESS_INFORMATION, hProcess) buf (piProcess pi) (#poke PROCESS_INFORMATION, hThread) buf (piThread pi) (#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pi) (#poke PROCESS_INFORMATION, dwThreadId) buf (piThreadId pi) peek buf = do vhProcess <- (#peek PROCESS_INFORMATION, hProcess) buf vhThread <- (#peek PROCESS_INFORMATION, hThread) buf vdwProcessId <- (#peek PROCESS_INFORMATION, dwProcessId) buf vdwThreadId <- (#peek PROCESS_INFORMATION, dwThreadId) buf return $ PROCESS_INFORMATION { piProcess = vhProcess, piThread = vhThread, piProcessId = vdwProcessId, piThreadId = vdwThreadId} ---- -fwdsumatrapdf.hs ---- -- vim: ts=4 sw=4 expandtab: -- >hsc2hs fwdsumatrapdf_ffi.hsc -- >ghc -cpp fwdsumatrapdf.hs fwdsumatrapdf_ffi.hs module Main where import System.Directory (doesFileExist) import System.Environment (getArgs, getProgName) import System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure)) import System.IO.Unsafe (unsafePerformIO) import System.Win32.Registry (regOpenKeyEx, regQueryValue, regCloseKey, hKEY_LOCAL_MACHINE, kEY_QUERY_VALUE) import System.Win32.Types (nullPtr, nullFinalHANDLE, DWORD, MbHANDLE) import Graphics.Win32.GDI.Types (HWND) import Data.IORef (newIORef, readIORef, writeIORef, IORef) import Data.Maybe (fromJust, isJust) import Control.Exception (bracket, catch, throwIO, SomeException) import Control.Monad (return, when, void) import Foreign.C.String (newCWString, withCWString, withCWStringLen, CWString) import Foreign.C.Types (CWchar(..)) import Foreign.Ptr (castPtr) import Foreign.Marshal.Alloc (alloca, free) import Foreign.Marshal.Array (mallocArray) import Foreign.Storable (sizeOf, peek) import FwdSumatraPDF {-# 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 -> findSumatraPDFInRegistry where 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 return False else do sumatrapdfRegistry <- regQueryValue regKey Nothing regCloseKey regKey exist <- doesFileExist sumatrapdfRegistry if exist then do startSumatraPDF sumatrapdfRegistry return True else 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 False 0 nullPtr nullPtr p_si p_pi pi <- peek p_pi waitForInputIdle (piProcess pi) (fromIntegral timeout) ddeExecute :: String -> String -> String -> IO (Maybe DWORD, MbHANDLE, MbHANDLE, MbHANDLE, MbHANDLE, MbHANDLE) ddeExecute server topic command = do bracket (getIdInstance) (\idInstance -> do when (isJust idInstance) (void $ ddeUninitialize (fromJust idInstance))) (\idInstance -> do bracket (getHszServer (fromJust idInstance) server) (\hszServer -> do when (isJust hszServer) (void $ ddeFreeStringHandle (fromJust idInstance) (fromJust hszServer))) (\hszServer -> do bracket (getHszTopic (fromJust idInstance) topic) (\hszTopic -> do when (isJust hszTopic) (void $ ddeFreeStringHandle (fromJust idInstance) (fromJust hszTopic))) (\hszTopic -> do bracket (getHConvClient (fromJust idInstance) (fromJust hszServer) (fromJust hszTopic)) (\hConvClient -> do when (isJust hConvClient) (void $ ddeDisconnect (fromJust hConvClient))) (\hConvClient -> do bracket (getHDdeData (fromJust idInstance) command) (\hDdeData -> do when (isJust hDdeData) (void $ ddeFreeDataHandle (fromJust hDdeData))) (\hDdeData -> do bracket (getHDdeTransactionData (fromJust hDdeData) (fromJust hConvClient)) (\hDdeTransactionData -> do when (isJust hDdeTransactionData) (void $ ddeFreeDataHandle (fromJust hDdeTransactionData))) (\hDdeTransactionData -> do return (idInstance, hszServer, hszTopic, hConvClient, hDdeData, hDdeTransactionData))))))) where getIdInstance = do let sumatraDdeCallback uType uFmt hconv hsz1 hsza2 hdata dwData1 dwData2 = return nullPtr 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 Nothing else return $ Just idInstance getHszServer idInstance server = do withCWString server $ \sv -> do hszServer <- ddeCreateStringHandleW idInstance sv cP_WINUNICODE if hszServer == nullPtr then do throwIO $ userError "ddeCreateStringHandleW Error" return Nothing else return $ Just hszServer getHszTopic idInstance topic = do withCWString topic $ \tp -> do hszTopic <- ddeCreateStringHandleW idInstance tp cP_WINUNICODE if hszTopic == nullPtr then do throwIO $ userError "ddeCreateStringHandleW Error" return Nothing else return $ Just hszTopic getHConvClient idInstance hszServer hszTopic = do hConvClient <- ddeConnect idInstance hszServer hszTopic nullPtr if hConvClient == nullPtr then do throwIO $ userError "ddeConnect Error" return Nothing else return $ Just hConvClient getHDdeData idInstance command = do withCWStringLen command $ \(cmd, len) -> do hDdeData <- ddeCreateDataHandle idInstance (castPtr cmd) (fromIntegral ((len + 1) * (sizeOf (undefined :: CWchar)))) 0 nullPtr cF_UNICODETEXT 0 if hDdeData == nullPtr then do throwIO $ userError "ddeCreateDataHandle Error" return Nothing else return $ Just hDdeData getHDdeTransactionData hDdeData hConvClient = do hDdeTransactionData <- ddeClientTransaction (castPtr hDdeData) (-1) hConvClient nullPtr 0 xTYP_EXECUTE timeout nullPtr if hDdeTransactionData == nullPtr then do throwIO $ userError "ddeClientTransaction Error" return Nothing else return $ Just hDdeTransactionData 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 ----