diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2013-2020, Keera Studios Ltd +Copyright (c) 2010-2012, Ivan Perez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ivan Perez, nor the name of Keera Studios, nor the + names of other contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keera-hails-reactive-htmldom.cabal b/keera-hails-reactive-htmldom.cabal new file mode 100644 --- /dev/null +++ b/keera-hails-reactive-htmldom.cabal @@ -0,0 +1,116 @@ +-- Copyright : (C) Keera Studios Ltd, 2013 +-- License : All Rights Reserved +-- Maintainer : support@keera.co.uk +-- +cabal-version: >=1.10 +build-type: Simple + +name: keera-hails-reactive-htmldom +author: Ivan Perez +maintainer: support@keera.co.uk +homepage: http://github.com/keera-studios/keera-hails +license: BSD3 +license-file: LICENSE +category: Web +version: 0.6.0 +synopsis: Keera Hails Reactive bindings for HTML DOM via GHCJS +description: + A layer defining RVs for HTML element fields and actions. + . + Reactive Values are an abstraction for reactive programming based on setters + and getters with change-based propagation. + . + They enable easy communication/synchronization rules via Reactive Rules + (RRs), which can keep two type-compatible RVs in sync directionally or + bidirectionally. + . + This library provides operations to turn HTML element properties and + fields into RVs, so that they can be used to create reactive user + interfaces with minimal effort. + . + For details, please see the paper "Bridging the GUI Gap with Reactive Values + and Relations", by Ivan Perez and Henrik Nilsson at Haskell Symposium 2015. + +source-repository head + type: git + location: git://github.com/keera-studios/keera-hails + subdir: keera-hails-reactive-htmldom + + +-- You can disable the hlint test suite with -f-test-hlint +flag test-hlint + default: False + manual: True + +-- You can disable the haddock coverage test suite with -f-test-doc-coverage +flag test-doc-coverage + default: False + manual: True + + +library + + exposed-modules: + Hails.MVC.View.HTML + + build-depends: + base >=4.2 && <5 + , ghcjs-dom >=0.2 && <0.10 + , keera-callbacks + , keera-hails-reactivevalues >=0.1.0 && <0.6 + , keera-hails-reactive-cbmvar + , mtl + , transformers >=0.4.3.0 && <0.6 + + hs-source-dirs: src/ + default-language: Haskell2010 + +test-suite hlint + + type: + exitcode-stdio-1.0 + + main-is: + HLintMain.hs + + hs-source-dirs: + tests + + if !flag(test-hlint) + buildable: False + else + build-depends: + base + , hlint >= 1.7 + + default-language: + Haskell2010 + + +-- Verify that the code is thoroughly documented +test-suite haddock-coverage + + type: + exitcode-stdio-1.0 + + main-is: + HaddockCoverage.hs + + ghc-options: + -Wall + + hs-source-dirs: + tests + + if !flag(test-doc-coverage) + buildable: False + else + build-depends: + base >= 4 && < 5 + , directory + , filepath + , process + , regex-posix + + default-language: + Haskell2010 diff --git a/src/Hails/MVC/View/HTML.hs b/src/Hails/MVC/View/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Hails/MVC/View/HTML.hs @@ -0,0 +1,68 @@ +-- | +-- +-- Copyright : (C) Keera Studios Ltd, 2013 +-- License : BSD3 +-- Maintainer : support@keera.co.uk +module Hails.MVC.View.HTML where + +import Control.Applicative ((<$>)) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Data.CBMVar (installCallbackCBMVar, newCBMVar, + readCBMVar, writeCBMVar) +import Data.CBMVar.Reactive (cbmvarReactiveRO, cbmvarReactiveRW) +import Data.ReactiveValue +import Data.String +import GHCJS.DOM.Element (IsElement, setInnerHTML) +import GHCJS.DOM.EventM (mouseButton, mouseClientXY, on) +import GHCJS.DOM.EventTargetClosures (EventName, unsafeEventName) +import GHCJS.DOM.GlobalEventHandlers (input, mouseDown, mouseMove) +import GHCJS.DOM.HTMLElement (setInnerText) +import GHCJS.DOM.HTMLInputElement (getValue, setValue) +import GHCJS.DOM.HTMLParagraphElement (HTMLParagraphElement (..)) +import GHCJS.DOM.MessageEvent (getData) +import GHCJS.DOM.Types (HTMLElement, HTMLInputElement (..), + IsGlobalEventHandlers, IsHTMLElement, + JSString, MouseEvent, fromJSValUnchecked, + toHTMLElement, toJSString) +import GHCJS.DOM.WebSocket (WebSocket, message, sendString) + +-- * GHCJS DOM Reactive API +inputTextReactive :: HTMLInputElement -> ReactiveFieldReadWrite IO String +inputTextReactive x = ReactiveFieldReadWrite setter getter notifier + where setter = setValue x + getter = getValue x + notifier p = void $ on x input (liftIO p) + +htmlElementClick :: IsHTMLElement e => e -> ReactiveFieldRead IO () +htmlElementClick e = ReactiveFieldRead (return ()) (\p -> void $ on e' click (liftIO p)) + where + e' = toHTMLElement e + +click :: EventName HTMLElement MouseEvent +click = unsafeEventName (toJSString "click") + +paragraphTextReactive :: HTMLParagraphElement -> ReactiveFieldWrite IO String +paragraphTextReactive x = ReactiveFieldWrite setter + where setter = setInnerHTML x + +websocketReactive :: WebSocket -> IO (ReactiveFieldReadWrite IO String) +websocketReactive socket = do + p <- newCBMVar "" + void $ on socket message (ask >>= \dt -> getData dt >>= \js -> liftIO (fromJSValUnchecked js) >>= \jss -> liftIO (writeCBMVar p (show (jss :: JSString)))) + let getter = readCBMVar p + notifier n = installCallbackCBMVar p n + setter x = do + sendString socket (fromString x :: JSString) + writeCBMVar p x + return (ReactiveFieldReadWrite setter getter notifier) + +mouseDownReactive :: (IsGlobalEventHandlers a, IsElement a) => a -> ReactiveFieldRead IO () +mouseDownReactive s = eventR $ \p -> void $ on s mouseDown (liftIO p) + +mousePosElementReactive :: (IsGlobalEventHandlers e, IsElement e) => e -> IO (ReactiveFieldRead IO (Int, Int)) +mousePosElementReactive e = do + p <- newCBMVar (0,0) + void $ on e mouseMove (mouseClientXY >>= \pos -> liftIO (writeCBMVar p pos)) + return (cbmvarReactiveRO p) diff --git a/tests/HLintMain.hs b/tests/HLintMain.hs new file mode 100644 --- /dev/null +++ b/tests/HLintMain.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (hlint) +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module runs HLint on the lens source tree. +----------------------------------------------------------------------------- +module Main where + +import Control.Monad +import Language.Haskell.HLint +import System.Environment +import System.Exit + +main :: IO () +main = do + args <- getArgs + hints <- hlint $ ["src", "--cross", "--hint=tests/HLint.hs" ] ++ args + unless (null hints) exitFailure diff --git a/tests/HaddockCoverage.hs b/tests/HaddockCoverage.hs new file mode 100644 --- /dev/null +++ b/tests/HaddockCoverage.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (HaddockCoverage) +-- Copyright : (C) 2015 Ivan Perez +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Ivan Perez +-- Stability : provisional +-- Portability : portable +-- +-- Copyright notice: This file borrows code +-- https://hackage.haskell.org/package/lens-4.7/src/tests/doctests.hsc +-- which is itself licensed BSD-style as well. +-- +-- Run haddock on a source tree and report if anything in any +-- module is not documented. +----------------------------------------------------------------------------- +module Main where + +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process +import Text.Regex.Posix + +main :: IO () +main = do + -- Find haskell modules + -- TODO: Ideally cabal should do this (provide us with the + -- list of modules). An alternative would be to use cabal haddock + -- but that would need a --no-html argument or something like that. + -- Alternatively, we could use cabal haddock with additional arguments. + -- + -- See: + -- https://github.com/keera-studios/haddock/commit/d5d752943c4e5c6c9ffcdde4dc136fcee967c495 + -- https://github.com/haskell/haddock/issues/309#issuecomment-150811929 + files <- getSources + + let haddockArgs = [ "--no-warnings", "--ignore-all-exports" ] ++ files + let cabalArgs = [ "exec", "--", "haddock" ] ++ haddockArgs + (code, out, _err) <- readProcessWithExitCode "cabal" cabalArgs "" + + -- Filter out coverage lines, and find those that denote undocumented + -- modules. + -- + -- TODO: is there a way to annotate a function as self-documenting, + -- in the same way we do with ANN for hlint? + let isIncompleteModule :: String -> Bool + isIncompleteModule line = isCoverageLine line && not (line =~ "^ *100%") + where isCoverageLine :: String -> Bool + isCoverageLine line = line =~ "^ *[0-9]+%" + + let incompleteModules :: [String] + incompleteModules = filter isIncompleteModule $ lines out + + -- Based on the result of haddock, report errors and exit. + -- Note that, unline haddock, this script does not + -- output anything to stdout. It uses stderr instead + -- (as it should). + case (code, incompleteModules) of + (ExitSuccess , []) -> return () + -- (ExitFailure _, _) -> exitFailure + (_ , _) -> do + hPutStrLn stderr "The following modules are not fully documented:" + mapM_ (hPutStrLn stderr) incompleteModules + exitFailure + +getSources :: IO [FilePath] +getSources = filter isHaskellFile <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + + isHaskellFile fp = (isSuffixOf ".hs" fp || isSuffixOf ".lhs" fp) + && not (any (`isSuffixOf` fp) excludedFiles) + + excludedFiles = [ ] + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c + +-- find-based implementation (not portable) +-- +-- getSources :: IO [FilePath] +-- getSources = fmap lines $ readProcess "find" ["src/", "-iname", "*hs"] ""